71 lines
2.8 KiB
Haskell
71 lines
2.8 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Servant.Auth.Server.Internal where
|
|
|
|
import Control.Monad.Trans (liftIO)
|
|
import Servant ((:>), Handler, HasServer (..),
|
|
Proxy (..),
|
|
HasContextEntry(getContextEntry))
|
|
import Servant.Auth
|
|
import Servant.Auth.JWT (ToJWT)
|
|
|
|
import Servant.Auth.Server.Internal.AddSetCookie
|
|
import Servant.Auth.Server.Internal.Class
|
|
import Servant.Auth.Server.Internal.Cookie
|
|
import Servant.Auth.Server.Internal.ConfigTypes
|
|
import Servant.Auth.Server.Internal.JWT
|
|
import Servant.Auth.Server.Internal.Types
|
|
|
|
import Servant.Server.Internal (DelayedIO, addAuthCheck, withRequest)
|
|
|
|
instance ( n ~ 'S ('S 'Z)
|
|
, HasServer (AddSetCookiesApi n api) ctxs, AreAuths auths ctxs v
|
|
, HasServer api ctxs -- this constraint is needed to implement hoistServer
|
|
, AddSetCookies n (ServerT api Handler) (ServerT (AddSetCookiesApi n api) Handler)
|
|
, ToJWT v
|
|
, HasContextEntry ctxs CookieSettings
|
|
, HasContextEntry ctxs JWTSettings
|
|
) => HasServer (Auth auths v :> api) ctxs where
|
|
type ServerT (Auth auths v :> api) m = AuthResult v -> ServerT api m
|
|
|
|
#if MIN_VERSION_servant_server(0,12,0)
|
|
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
|
|
#endif
|
|
|
|
route _ context subserver =
|
|
route (Proxy :: Proxy (AddSetCookiesApi n api))
|
|
context
|
|
(fmap go subserver `addAuthCheck` authCheck)
|
|
|
|
where
|
|
authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))
|
|
authCheck = withRequest $ \req -> liftIO $ do
|
|
authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req
|
|
cookies <- makeCookies authResult
|
|
return (authResult, cookies)
|
|
|
|
jwtSettings :: JWTSettings
|
|
jwtSettings = getContextEntry context
|
|
|
|
cookieSettings :: CookieSettings
|
|
cookieSettings = getContextEntry context
|
|
|
|
makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))
|
|
makeCookies authResult = do
|
|
xsrf <- makeXsrfCookie cookieSettings
|
|
fmap (Just xsrf `SetCookieCons`) $
|
|
case authResult of
|
|
(Authenticated v) -> do
|
|
ejwt <- makeSessionCookie cookieSettings jwtSettings v
|
|
case ejwt of
|
|
Nothing -> return $ Nothing `SetCookieCons` SetCookieNil
|
|
Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil
|
|
_ -> return $ Nothing `SetCookieCons` SetCookieNil
|
|
|
|
go :: (AuthResult v -> ServerT api Handler)
|
|
-> (AuthResult v, SetCookieList n)
|
|
-> ServerT (AddSetCookiesApi n api) Handler
|
|
go fn (authResult, cookies) = addSetCookies cookies $ fn authResult
|