{-# LANGUAGE CPP #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Servant.Auth.Server.Internal where

import Control.Monad.Trans (liftIO)
import Servant
  ( Handler
  , HasContextEntry (getContextEntry)
  , HasServer (..)
  , Proxy (..)
  , (:>)
  )
import Servant.Auth
import Servant.Auth.JWT (ToJWT)
import Servant.Server.Internal (DelayedIO, addAuthCheck, withRequest)

import Servant.Auth.Server.Internal.AddSetCookie
import Servant.Auth.Server.Internal.Class
import Servant.Auth.Server.Internal.ConfigTypes
import Servant.Auth.Server.Internal.Cookie
import Servant.Auth.Server.Internal.JWT
import Servant.Auth.Server.Internal.Types

instance
  ( -- this constraint is needed to implement hoistServer
    AddSetCookies n (ServerT api Handler) (ServerT (AddSetCookiesApi n api) Handler)
  , AreAuths auths ctxs v
  , HasContextEntry ctxs CookieSettings
  , HasContextEntry ctxs JWTSettings
  , HasServer (AddSetCookiesApi n api) ctxs
  , HasServer api ctxs
  , ToJWT v
  , n ~ 'S ('S 'Z)
  )
  => HasServer (Auth auths v :> api) ctxs
  where
  type ServerT (Auth auths v :> api) m = AuthResult v -> ServerT api m

  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 =
    Proxy (AddSetCookieApi (AddSetCookieApi api))
-> Context ctxs
-> Delayed
     env (ServerT (AddSetCookieApi (AddSetCookieApi api)) Handler)
-> Router env
forall env.
Proxy (AddSetCookieApi (AddSetCookieApi api))
-> Context ctxs
-> Delayed
     env (ServerT (AddSetCookieApi (AddSetCookieApi api)) Handler)
-> Router env
forall {k} (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route
      (Proxy (AddSetCookieApi (AddSetCookieApi api))
Proxy (AddSetCookiesApi n api)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (AddSetCookiesApi n api))
      Context ctxs
context
      (((AuthResult v -> ServerT api Handler)
 -> (AuthResult v, SetCookieList n)
 -> ServerT (AddSetCookieApi (AddSetCookieApi api)) Handler)
-> Delayed env (AuthResult v -> ServerT api Handler)
-> Delayed
     env
     ((AuthResult v, SetCookieList n)
      -> ServerT (AddSetCookieApi (AddSetCookieApi api)) Handler)
forall a b. (a -> b) -> Delayed env a -> Delayed env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AuthResult v -> ServerT api Handler)
-> (AuthResult v, SetCookieList n)
-> ServerT (AddSetCookieApi (AddSetCookieApi api)) Handler
(AuthResult v -> ServerT api Handler)
-> (AuthResult v, SetCookieList n)
-> ServerT (AddSetCookiesApi n api) Handler
go Delayed env (Server (Auth auths v :> api))
Delayed env (AuthResult v -> ServerT api Handler)
subserver Delayed
  env
  ((AuthResult v, SetCookieList n)
   -> ServerT (AddSetCookieApi (AddSetCookieApi api)) Handler)
-> DelayedIO (AuthResult v, SetCookieList n)
-> Delayed
     env (ServerT (AddSetCookieApi (AddSetCookieApi api)) Handler)
forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
`addAuthCheck` DelayedIO (AuthResult v, SetCookieList n)
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 = (Request -> DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z))))
-> DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z))))
 -> DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z))))
-> (Request
    -> DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z))))
-> DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))
forall a b. (a -> b) -> a -> b
$ \Request
req -> IO (AuthResult v, SetCookieList ('S ('S 'Z)))
-> DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))
forall a. IO a -> DelayedIO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (AuthResult v, SetCookieList ('S ('S 'Z)))
 -> DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z))))
-> IO (AuthResult v, SetCookieList ('S ('S 'Z)))
-> DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))
forall a b. (a -> b) -> a -> b
$ do
        AuthResult v
authResult <- AuthCheck v -> Request -> IO (AuthResult v)
forall val. AuthCheck val -> Request -> IO (AuthResult val)
runAuthCheck (Proxy auths -> Context ctxs -> AuthCheck v
forall (as :: [*]) (ctxs :: [*]) v (proxy :: [*] -> *).
AreAuths as ctxs v =>
proxy as -> Context ctxs -> AuthCheck v
forall (proxy :: [*] -> *).
proxy auths -> Context ctxs -> AuthCheck v
runAuths (Proxy auths
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
        (AuthResult v, SetCookieList ('S ('S 'Z)))
-> IO (AuthResult v, SetCookieList ('S ('S 'Z)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthResult v
authResult, SetCookieList ('S ('S 'Z))
cookies)

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

      cookieSettings :: CookieSettings
      cookieSettings :: CookieSettings
cookieSettings = Context ctxs -> 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 <- CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
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
            SetCookieList ('S ('S 'Z)) -> IO (SetCookieList ('S ('S 'Z)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SetCookieList ('S ('S 'Z)) -> IO (SetCookieList ('S ('S 'Z))))
-> SetCookieList ('S ('S 'Z)) -> IO (SetCookieList ('S ('S 'Z)))
forall a b. (a -> b) -> a -> b
$ SetCookie -> Maybe SetCookie
forall a. a -> Maybe a
Just SetCookie
xsrf Maybe SetCookie
-> SetCookieList ('S 'Z) -> SetCookieList ('S ('S 'Z))
forall (n1 :: Nat).
Maybe SetCookie -> SetCookieList n1 -> SetCookieList ('S n1)
`SetCookieCons` (Maybe SetCookie
ejwt Maybe SetCookie -> SetCookieList 'Z -> SetCookieList ('S 'Z)
forall (n1 :: Nat).
Maybe SetCookie -> SetCookieList n1 -> SetCookieList ('S n1)
`SetCookieCons` SetCookieList 'Z
SetCookieNil)
          AuthResult v
_ -> SetCookieList ('S ('S 'Z)) -> IO (SetCookieList ('S ('S 'Z)))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SetCookieList ('S ('S 'Z)) -> IO (SetCookieList ('S ('S 'Z))))
-> SetCookieList ('S ('S 'Z)) -> IO (SetCookieList ('S ('S 'Z)))
forall a b. (a -> b) -> a -> b
$ Maybe SetCookie
forall a. Maybe a
Nothing Maybe SetCookie
-> SetCookieList ('S 'Z) -> SetCookieList ('S ('S 'Z))
forall (n1 :: Nat).
Maybe SetCookie -> SetCookieList n1 -> SetCookieList ('S n1)
`SetCookieCons` (Maybe SetCookie
forall a. Maybe a
Nothing Maybe SetCookie -> SetCookieList 'Z -> SetCookieList ('S 'Z)
forall (n1 :: Nat).
Maybe SetCookie -> SetCookieList n1 -> SetCookieList ('S n1)
`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) = SetCookieList n
-> ServerT api Handler -> ServerT (AddSetCookiesApi n api) Handler
forall (n :: Nat) orig new.
AddSetCookies n orig new =>
SetCookieList n -> orig -> new
addSetCookies SetCookieList n
cookies (ServerT api Handler -> ServerT (AddSetCookiesApi n api) Handler)
-> ServerT api Handler -> ServerT (AddSetCookiesApi n api) Handler
forall a b. (a -> b) -> a -> b
$ AuthResult v -> ServerT api Handler
fn AuthResult v
authResult

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