{-# LANGUAGE UndecidableInstances #-}
module Servant.Auth.Server.Internal.Class where

import Servant.Auth
import Data.Monoid
import Servant hiding (BasicAuth)

import Servant.Auth.JWT
import Servant.Auth.Server.Internal.Types
import Servant.Auth.Server.Internal.ConfigTypes
import Servant.Auth.Server.Internal.BasicAuth
import Servant.Auth.Server.Internal.Cookie
import Servant.Auth.Server.Internal.JWT (jwtAuthCheck)

-- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all
-- elements of @ctx@ to be the in the Context and whose authentication check
-- returns an @AuthCheck v@.
class IsAuth a v  where
  type family AuthArgs a :: [*]
  runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v)

instance FromJWT usr => IsAuth Cookie usr where
  type AuthArgs Cookie = '[CookieSettings, JWTSettings]
  runAuth :: proxy Cookie
-> proxy usr -> Unapp (AuthArgs Cookie) (AuthCheck usr)
runAuth proxy Cookie
_ proxy usr
_ = Unapp (AuthArgs Cookie) (AuthCheck usr)
forall usr.
FromJWT usr =>
CookieSettings -> JWTSettings -> AuthCheck usr
cookieAuthCheck

instance FromJWT usr => IsAuth JWT usr where
  type AuthArgs JWT = '[JWTSettings]
  runAuth :: proxy JWT -> proxy usr -> Unapp (AuthArgs JWT) (AuthCheck usr)
runAuth proxy JWT
_ proxy usr
_ = Unapp (AuthArgs JWT) (AuthCheck usr)
forall usr. FromJWT usr => JWTSettings -> AuthCheck usr
jwtAuthCheck

instance FromBasicAuthData usr => IsAuth BasicAuth usr where
  type AuthArgs BasicAuth = '[BasicAuthCfg]
  runAuth :: proxy BasicAuth
-> proxy usr -> Unapp (AuthArgs BasicAuth) (AuthCheck usr)
runAuth proxy BasicAuth
_ proxy usr
_ = Unapp (AuthArgs BasicAuth) (AuthCheck usr)
forall usr. FromBasicAuthData usr => BasicAuthCfg -> AuthCheck usr
basicAuthCheck

-- * Helper

class AreAuths (as :: [*]) (ctxs :: [*]) v where
  runAuths :: proxy as -> Context ctxs -> AuthCheck v

instance  AreAuths '[] ctxs v where
  runAuths :: proxy '[] -> Context ctxs -> AuthCheck v
runAuths proxy '[]
_ Context ctxs
_ = AuthCheck v
forall a. Monoid a => a
mempty

instance ( AuthCheck v ~ App (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))
         , IsAuth a v
         , AreAuths as ctxs v
         , AppCtx ctxs (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))
         ) => AreAuths (a ': as) ctxs v where
  runAuths :: proxy (a : as) -> Context ctxs -> AuthCheck v
runAuths proxy (a : as)
_ Context ctxs
ctxs = AuthCheck v
App (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))
go AuthCheck v -> AuthCheck v -> AuthCheck v
forall a. Semigroup a => a -> a -> a
<> Proxy as -> Context ctxs -> AuthCheck v
forall (as :: [*]) (ctxs :: [*]) v (proxy :: [*] -> *).
AreAuths as ctxs v =>
proxy as -> Context ctxs -> AuthCheck v
runAuths (Proxy as
forall k (t :: k). Proxy t
Proxy :: Proxy as) Context ctxs
ctxs
    where
      go :: App (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))
go = Proxy (AuthArgs a)
-> Context ctxs
-> Unapp (AuthArgs a) (AuthCheck v)
-> App (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v))
forall (ctx :: [*]) (ls :: [*]) res (proxy :: [*] -> *).
AppCtx ctx ls res =>
proxy ls -> Context ctx -> res -> App ls res
appCtx (Proxy (AuthArgs a)
forall k (t :: k). Proxy t
Proxy :: Proxy (AuthArgs a))
                  Context ctxs
ctxs
                  (Proxy a -> Proxy v -> Unapp (AuthArgs a) (AuthCheck v)
forall a v (proxy :: * -> *).
IsAuth a v =>
proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v)
runAuth (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) (Proxy v
forall k (t :: k). Proxy t
Proxy :: Proxy v))

type family Unapp ls res where
  Unapp '[] res = res
  Unapp (arg1 ': rest) res = arg1 -> Unapp rest res

type family App ls res where
  App '[] res = res
  App (arg1 ': rest) (arg1 -> res) = App rest res

-- | @AppCtx@ applies the function @res@ to the arguments in @ls@ by taking the
-- values from the Context provided.
class AppCtx ctx ls res where
  appCtx :: proxy ls -> Context ctx -> res -> App ls res

instance ( HasContextEntry ctxs ctx
         , AppCtx ctxs rest res
         ) => AppCtx ctxs (ctx ': rest) (ctx -> res) where
  appCtx :: proxy (ctx : rest)
-> Context ctxs -> (ctx -> res) -> App (ctx : rest) (ctx -> res)
appCtx proxy (ctx : rest)
_ Context ctxs
ctx ctx -> res
fn = Proxy rest -> Context ctxs -> res -> App rest res
forall (ctx :: [*]) (ls :: [*]) res (proxy :: [*] -> *).
AppCtx ctx ls res =>
proxy ls -> Context ctx -> res -> App ls res
appCtx (Proxy rest
forall k (t :: k). Proxy t
Proxy :: Proxy rest) Context ctxs
ctx (res -> App rest res) -> res -> App rest res
forall a b. (a -> b) -> a -> b
$ ctx -> res
fn (ctx -> res) -> ctx -> res
forall a b. (a -> b) -> a -> b
$ Context ctxs -> ctx
forall (context :: [*]) val.
HasContextEntry context val =>
Context context -> val
getContextEntry Context ctxs
ctx

instance AppCtx ctx '[] res where
  appCtx :: proxy '[] -> Context ctx -> res -> App '[] res
appCtx proxy '[]
_ Context ctx
_ res
r = res
App '[] res
r