module Servant.Server.Experimental.Auth where
import Control.Monad.Trans.Except (ExceptT,
runExceptT)
import Data.Proxy (Proxy (Proxy))
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Network.Wai (Request)
import Servant ((:>))
import Servant.API.Experimental.Auth
import Servant.Server.Internal (HasContextEntry,
HasServer, ServerT,
getContextEntry,
route)
import Servant.Server.Internal.Router (Router' (WithRequest))
import Servant.Server.Internal.RoutingApplication (RouteResult (FailFatal, Route),
addAuthCheck)
import Servant.Server.Internal.ServantErr (ServantErr)
type family AuthServerData a :: *
newtype AuthHandler r usr = AuthHandler
{ unAuthHandler :: r -> ExceptT ServantErr IO usr }
deriving (Generic, Typeable)
mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr
mkAuthHandler = AuthHandler
instance ( HasServer api context
, HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag)))
)
=> HasServer (AuthProtect tag :> api) context where
type ServerT (AuthProtect tag :> api) m =
AuthServerData (AuthProtect tag) -> ServerT api m
route Proxy context subserver = WithRequest $ \ request ->
route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)
where
authHandler = unAuthHandler (getContextEntry context)
authCheck = fmap (either FailFatal Route) . runExceptT . authHandler