Search code examples
haskellservant

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

I am trying to get access to my custom monad in the Generalized Auth Handler But i Haven't been able to solve the TypeErros I am getting. I've tried following along with the docs but I haven't been able to convert the examples over to my use case (this is probably because I lack a fully developed understanding of the type level machinery going on in the server). I have an auth situation which doesn't quite fit the Servant-Auth case. Here is the minimal server.

{-# 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 "[email protected]"
                -- return $ AuthUser 1 "[email protected]"
  in mkAuthHandler handler

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

If possible I would like to not pass my AppEnv to my handler and simply treat it as if it were just part of my Reader and use asks.

Below are my AppEnv and 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)

EDIT: Errors

Error:

    • 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
Solution 
  • hoistServer :: HasServer api '[] => Proxy api -> (forall x. m x -> n x) -> ServerT api m -> ServerT api n

    You're calling hoistServer where api ~ TodoAPI, so we need to solve the constraint HasServer TodoAPI '[]. The relevant instance for the problem you're having is this one:

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

    So now we need to solve the constraint HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag))). tag there is "JWT", so plug that in, then apply your type instance, and we get that we need to solve HasContextEntry context (AuthHandler Request AuthUser).

    The trouble is, what's context there? It's '[]. Well, that's not going to work. To fix it, you need to use hoistServerWithContext instead of hoistServer, like this:

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

    That has this type:

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

    So we get to solve HasServer TodoAPI '[AuthHandler Request AuthUser] instead, so now we can solve the HasContextEntry constraint, and it compiles fine.