{-# 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 :: forall (m :: * -> *) (n :: * -> *).
Proxy (Auth auths v :> api)
-> Proxy ctxs
-> (forall x. m x -> n x)
-> ServerT (Auth auths v :> api) m
-> ServerT (Auth auths v :> api) n
hoistServerWithContext Proxy (Auth auths v :> api)
_ Proxy ctxs
pc forall x. m x -> n x
nt ServerT (Auth auths v :> api) m
s = forall {k} (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (forall {k} (t :: k). Proxy t
Proxy :: Proxy api) Proxy ctxs
pc forall x. m x -> n x
nt forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (Auth auths v :> api) m
s
#endif

  route :: forall env.
Proxy (Auth auths v :> api)
-> Context ctxs
-> Delayed env (Server (Auth auths v :> api))
-> Router env
route Proxy (Auth auths v :> api)
_ Context ctxs
context Delayed env (Server (Auth auths v :> api))
subserver =
    forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (forall {k} (t :: k). Proxy t
Proxy :: Proxy (AddSetCookiesApi n api))
          Context ctxs
context
          (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AuthResult v -> ServerT api Handler)
-> (AuthResult v, SetCookieList n)
-> ServerT (AddSetCookiesApi n api) Handler
go Delayed env (Server (Auth auths v :> api))
subserver forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
`addAuthCheck` DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))
authCheck)

    where
      authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))
      authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))
authCheck = forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest forall a b. (a -> b) -> a -> b
$ \Request
req -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        AuthResult v
authResult <- forall val. AuthCheck val -> Request -> IO (AuthResult val)
runAuthCheck (forall (as :: [*]) (ctxs :: [*]) v (proxy :: [*] -> *).
AreAuths as ctxs v =>
proxy as -> Context ctxs -> AuthCheck v
runAuths (forall {k} (t :: k). Proxy t
Proxy :: Proxy auths) Context ctxs
context) Request
req
        SetCookieList ('S ('S 'Z))
cookies <- AuthResult v -> IO (SetCookieList ('S ('S 'Z)))
makeCookies AuthResult v
authResult
        forall (m :: * -> *) a. Monad m => a -> m a
return (AuthResult v
authResult, SetCookieList ('S ('S 'Z))
cookies)

      jwtSettings :: JWTSettings
      jwtSettings :: JWTSettings
jwtSettings = forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry Context ctxs
context

      cookieSettings :: CookieSettings
      cookieSettings :: CookieSettings
cookieSettings = forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry Context ctxs
context

      makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))
      makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))
makeCookies AuthResult v
authResult = do
        case AuthResult v
authResult of
          (Authenticated v
v) -> do
            Maybe SetCookie
ejwt <- forall v.
ToJWT v =>
CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
makeSessionCookie CookieSettings
cookieSettings JWTSettings
jwtSettings v
v
            SetCookie
xsrf <- CookieSettings -> IO SetCookie
makeXsrfCookie CookieSettings
cookieSettings
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just SetCookie
xsrf forall (n :: Nat).
Maybe SetCookie -> SetCookieList n -> SetCookieList ('S n)
`SetCookieCons` (Maybe SetCookie
ejwt forall (n :: Nat).
Maybe SetCookie -> SetCookieList n -> SetCookieList ('S n)
`SetCookieCons` SetCookieList 'Z
SetCookieNil)
          AuthResult v
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Maybe a
Nothing forall (n :: Nat).
Maybe SetCookie -> SetCookieList n -> SetCookieList ('S n)
`SetCookieCons` (forall a. Maybe a
Nothing forall (n :: Nat).
Maybe SetCookie -> SetCookieList n -> SetCookieList ('S n)
`SetCookieCons` SetCookieList 'Z
SetCookieNil)

      go :: (AuthResult v -> ServerT api Handler)
         -> (AuthResult v, SetCookieList n)
         -> ServerT (AddSetCookiesApi n api) Handler
      go :: (AuthResult v -> ServerT api Handler)
-> (AuthResult v, SetCookieList n)
-> ServerT (AddSetCookiesApi n api) Handler
go AuthResult v -> ServerT api Handler
fn (AuthResult v
authResult, SetCookieList n
cookies) = forall (n :: Nat) orig new.
AddSetCookies n orig new =>
SetCookieList n -> orig -> new
addSetCookies SetCookieList n
cookies forall a b. (a -> b) -> a -> b
$ AuthResult v -> ServerT api Handler
fn AuthResult v
authResult