如何在 Servant 中使用 Generalized Auth 访问 reader monad

Question

我正在尝试在通用身份验证处理程序中访问我的自定义 monad，但我无法解决我遇到的 TypeErros。我已经尝试按照文档进行操作，但无法将示例转换为我的用例（这可能是因为我对服务器中运行的类型级机制缺乏全面的了解）。我有一个不太适合 Servant-Auth 案例的身份验证情况。这是最小的服务器。

{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE FlexibleContexts      #-}

module Adapter.Servant.TodoAPI2 (todoApp) where

import ClassyPrelude hiding (Handler)
import Servant
import Servant.Server
import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData,
                                         mkAuthHandler)
import Control.Monad.Except
import Domain.Types.AppT 
import Domain.Types.AppEnv
import Network.Wai.Handler.Warp
import Network.Wai
import Network.Wai.Middleware.RequestLogger

readerToHandler :: AppEnv -> AppT a -> Handler a
readerToHandler env appt = do
  val <- liftIO $ runExceptT $ runReaderT (runAppT appt) env
  case val of
    Left e -> throwError e
    Right s -> return s 

type TodoAPI = "a" :> Get '[JSON] Int
          :<|> "b" :> Get '[JSON] Bool
          :<|> "c" :> Get '[JSON] Int
          :<|> "d" :> AuthProtect "JWT" :> Get '[JSON] Int

todoAPI :: Proxy TodoAPI
todoAPI = Proxy

todoServerT :: ServerT TodoAPI AppT
todoServerT = a 
         :<|> b 
         :<|> c 
         :<|> d 
  where
    a :: AppT Int
    a = return 1797

    b :: AppT Bool
    b = return True

    c :: AppT Int
    c = throwError $ (ServerError 500 "Failed Computation" "" [])

    d :: AuthUser -> AppT Int
    d au = do
      sec <- asks secret 
      liftIO $ print $ sec 
      return $ 1798

todoServer :: AppEnv -> Server TodoAPI
todoServer env = hoistServer todoAPI (readerToHandler env) todoServerT

todoApp :: AppEnv -> Application
todoApp env = serveWithContext todoAPI (genAuthServerContext env) (todoServer env)


data AuthUser = AuthUser 
  { auth_user_id :: Int64 
  , auth_user_email :: Text
  } deriving (Eq, Show, Generic)


type instance AuthServerData (AuthProtect "JWT") = AuthUser

authHandler :: AppEnv -> AuthHandler Request (AuthUser)
authHandler env =
  let handler req =
        case lookup "Authorization" (requestHeaders req) of
          Nothing ->
            throwError (err401 {errBody = "Missing 'Authorization' header"})
          Just token -> do
            liftIO $ print $ secret env
            -- sec <- asks secret
            case (token == "HELLOWORLD") of
              False ->
                throwError (err401 {errBody = "Wrong 'Authorization' token"})
              -- True -> do
              True -> return $ AuthUser 1 "ethangardner@afito.com"
                -- return $ AuthUser 1 "ethangardner@afito.com"
  in mkAuthHandler handler

genAuthServerContext :: AppEnv -> Context (AuthHandler Request (AuthUser) ': '[])
genAuthServerContext env = (authHandler env) :. EmptyContext

如果可能的话，我不想将我的 AppEnv 传递给我的处理程序，而只是将其视为我的 Reader 的一部分并使用 asks。

下面是我的 AppEnv 和 AppT。

module Domain.Types.AppEnv (AppEnv(..)) where

import ClassyPrelude hiding (Handler)
import Data.Pool
import Database.PostgreSQL.Simple

data AppEnv = AppEnv 
 { pgEnv :: !(Pool Connection)
 , secret :: Text
 }

module Domain.Types.AppT (AppT(..)) where

import ClassyPrelude
import Servant.Server
import Control.Monad.Except
import Control.Monad.Catch (MonadThrow)
import Domain.Types.AppEnv

newtype AppT a = AppT 
 { runAppT :: ReaderT AppEnv (ExceptT ServerError IO) a
 } deriving (Functor, Applicative, Monad, MonadIO, MonadReader AppEnv, MonadThrow, MonadError ServerError)

编辑：错误

错误：

    • No instance for (HasContextEntry
                         '[] (AuthHandler Request AuthUser))
        arising from a use of ‘hoistServer’
    • In the expression:
        hoistServer todoAPI (readerToHandler env) todoServerT
      In an equation for ‘todoServer’:
          todoServer env
            = hoistServer todoAPI (readerToHandler env) todoServerT
   |
55 | todoServer env = hoistServer todoAPI (readerToHandler env) todoServerT

Answer 1

hoistServer :: HasServer api '[] => Proxy api -> (forall x. m x -> n x) -> ServerT api m -> ServerT api n

您在 api ~ TodoAPI 处调用 hoistServer，因此我们需要求解约束 HasServer TodoAPI '[]。您遇到的问题的相关实例是：

instance (HasServer api context, HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag)))) => HasServer (AuthProtect tag :> api :: Type) context

所以现在我们需要解决约束HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag)))。 tag 有 "JWT"，所以插入它，然后应用你的 type instance，我们得到我们需要解决 HasContextEntry context (AuthHandler Request AuthUser).

问题是，context 那里有什么？是 '[]。好吧，那是行不通的。 要修复它，您需要使用 hoistServerWithContext 而不是 hoistServer，像这样：

todoServer env = hoistServerWithContext todoAPI (Proxy :: Proxy '[AuthHandler Request AuthUser]) (readerToHandler env) todoServerT

有这种类型：

hoistServerWithContext :: HasServer api context => Proxy api -> Proxy context -> (forall x. m x -> n x) -> ServerT api m -> ServerT api n

所以我们改为求解 HasServer TodoAPI '[AuthHandler Request AuthUser]，所以现在我们可以求解 HasContextEntry 约束，并且编译正常。

如何在 Servant 中使用 Generalized Auth 访问 reader monad

How to get access to reader monad with Generalized Auth in Servant

haskell

servant