Как получить доступ к монаде читателя с Generalized Auth в Servant - PullRequest
Новая
       28

Как получить доступ к монаде читателя с Generalized Auth в Servant

2 голосов
/ 06 января 2020

Я пытаюсь получить доступ к моей пользовательской монаде в Обобщенном обработчике аутентификации, но я не смог решить 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

1 Ответ

1 голос
/ 06 января 2020 
hoistServer :: HasServer api '[] => Proxy api -> (forall x. m x -> n x) -> ServerT api m -> ServerT api n

Вы звоните hoistServer, где api ~ TodoAPI, поэтому нам нужно решить ограничение 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, и оно прекрасно компилируется.

...