73 lines
2.4 KiB
Haskell
73 lines
2.4 KiB
Haskell
|
{-# 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 _ _ = cookieAuthCheck
|
||
|
|
|
||
|
|
instance FromJWT usr => IsAuth JWT usr where
|
||
|
|
type AuthArgs JWT = '[JWTSettings]
|
||
|
|
runAuth _ _ = jwtAuthCheck
|
||
|
|
|
||
|
|
instance FromBasicAuthData usr => IsAuth BasicAuth usr where
|
||
|
|
type AuthArgs BasicAuth = '[BasicAuthCfg]
|
||
|
|
runAuth _ _ = basicAuthCheck
|
||
|
|
|
||
|
|
-- * Helper
|
||
|
|
|
||
|
|
class AreAuths (as :: [*]) (ctxs :: [*]) v where
|
||
|
|
runAuths :: proxy as -> Context ctxs -> AuthCheck v
|
||
|
|
|
||
|
|
instance AreAuths '[] ctxs v where
|
||
|
|
runAuths _ _ = 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 _ ctxs = go <> runAuths (Proxy :: Proxy as) ctxs
|
||
|
|
where
|
||
|
|
go = appCtx (Proxy :: Proxy (AuthArgs a))
|
||
|
|
ctxs
|
||
|
|
(runAuth (Proxy :: Proxy a) (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 _ ctx fn = appCtx (Proxy :: Proxy rest) ctx $ fn $ getContextEntry ctx
|
||
|
|
|
||
|
|
instance AppCtx ctx '[] res where
|
||
|
|
appCtx _ _ r = r
|