{-# 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 :: 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
hoistServerWithContext (Proxy api
forall k (t :: k). Proxy t
Proxy :: Proxy api) Proxy ctxs
pc 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

  route :: 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 (Server (AddSetCookieApi (AddSetCookieApi api)))
-> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (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 ('S ('S 'Z)))
 -> Server (AddSetCookieApi (AddSetCookieApi api)))
-> Delayed env (AuthResult v -> ServerT api Handler)
-> Delayed
     env
     ((AuthResult v, SetCookieList ('S ('S 'Z)))
      -> Server (AddSetCookieApi (AddSetCookieApi api)))
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
(AuthResult v -> ServerT api Handler)
-> (AuthResult v, SetCookieList ('S ('S 'Z)))
-> Server (AddSetCookieApi (AddSetCookieApi api))
go Delayed env (Server (Auth auths v :> api))
Delayed env (AuthResult v -> ServerT api Handler)
subserver Delayed
  env
  ((AuthResult v, SetCookieList ('S ('S 'Z)))
   -> Server (AddSetCookieApi (AddSetCookieApi api)))
-> DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))
-> Delayed env (Server (AddSetCookieApi (AddSetCookieApi api)))
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 = (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 (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
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 (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
        SetCookie
xsrf <- CookieSettings -> IO SetCookie
makeXsrfCookie CookieSettings
cookieSettings
        (SetCookieList ('S 'Z) -> SetCookieList ('S ('S 'Z)))
-> IO (SetCookieList ('S 'Z)) -> IO (SetCookieList ('S ('S 'Z)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SetCookie -> Maybe SetCookie
forall a. a -> Maybe a
Just SetCookie
xsrf Maybe SetCookie
-> SetCookieList ('S 'Z) -> SetCookieList ('S ('S 'Z))
forall (n :: Nat).
Maybe SetCookie -> SetCookieList n -> SetCookieList ('S n)
`SetCookieCons`) (IO (SetCookieList ('S 'Z)) -> IO (SetCookieList ('S ('S 'Z))))
-> IO (SetCookieList ('S 'Z)) -> IO (SetCookieList ('S ('S 'Z)))
forall a b. (a -> b) -> a -> b
$
          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
              case Maybe SetCookie
ejwt of
                Maybe SetCookie
Nothing  -> SetCookieList ('S 'Z) -> IO (SetCookieList ('S 'Z))
forall (m :: * -> *) a. Monad m => a -> m a
return (SetCookieList ('S 'Z) -> IO (SetCookieList ('S 'Z)))
-> SetCookieList ('S 'Z) -> IO (SetCookieList ('S 'Z))
forall a b. (a -> b) -> a -> b
$ Maybe SetCookie
forall a. Maybe a
Nothing Maybe SetCookie -> SetCookieList 'Z -> SetCookieList ('S 'Z)
forall (n :: Nat).
Maybe SetCookie -> SetCookieList n -> SetCookieList ('S n)
`SetCookieCons` SetCookieList 'Z
SetCookieNil
                Just SetCookie
jwt -> SetCookieList ('S 'Z) -> IO (SetCookieList ('S 'Z))
forall (m :: * -> *) a. Monad m => a -> m a
return (SetCookieList ('S 'Z) -> IO (SetCookieList ('S 'Z)))
-> SetCookieList ('S 'Z) -> IO (SetCookieList ('S 'Z))
forall a b. (a -> b) -> a -> b
$ SetCookie -> Maybe SetCookie
forall a. a -> Maybe a
Just SetCookie
jwt Maybe SetCookie -> SetCookieList 'Z -> SetCookieList ('S 'Z)
forall (n :: Nat).
Maybe SetCookie -> SetCookieList n -> SetCookieList ('S n)
`SetCookieCons` SetCookieList 'Z
SetCookieNil
            AuthResult v
_ -> SetCookieList ('S 'Z) -> IO (SetCookieList ('S 'Z))
forall (m :: * -> *) a. Monad m => a -> m a
return (SetCookieList ('S 'Z) -> IO (SetCookieList ('S 'Z)))
-> SetCookieList ('S 'Z) -> IO (SetCookieList ('S 'Z))
forall a b. (a -> b) -> a -> b
$ Maybe SetCookie
forall a. Maybe a
Nothing Maybe SetCookie -> SetCookieList 'Z -> SetCookieList ('S 'Z)
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) = SetCookieList n
-> ServerT api Handler
-> Server (AddSetCookieApi (AddSetCookieApi api))
forall (n :: Nat) orig new.
AddSetCookies n orig new =>
SetCookieList n -> orig -> new
addSetCookies SetCookieList n
cookies (ServerT api Handler
 -> Server (AddSetCookieApi (AddSetCookieApi api)))
-> ServerT api Handler
-> Server (AddSetCookieApi (AddSetCookieApi api))
forall a b. (a -> b) -> a -> b
$ AuthResult v -> ServerT api Handler
fn AuthResult v
authResult