{-# LANGUAGE DuplicateRecordFields #-}
module WebGear.Core.Trait.Auth.JWT (
JWTAuth' (..),
JWTAuth,
Realm (..),
JWTAuthError (..),
jwtAuth,
optionalJWTAuth,
jwtAuth',
optionalJWTAuth',
) where
import Control.Arrow (ArrowChoice, arr)
import qualified Crypto.JWT as JWT
import Data.Void (Void, absurd)
import GHC.TypeLits (Symbol)
import WebGear.Core.Handler
import WebGear.Core.Modifiers (Existence (..))
import WebGear.Core.Request (Request)
import WebGear.Core.Response (Response)
import WebGear.Core.Trait
import WebGear.Core.Trait.Auth.Common
data JWTAuth' (x :: Existence) (scheme :: Symbol) m e a = JWTAuth'
{ forall (x :: Existence) (scheme :: Symbol) (m :: * -> *) e a.
JWTAuth' x scheme m e a -> JWTValidationSettings
jwtValidationSettings :: JWT.JWTValidationSettings
, forall (x :: Existence) (scheme :: Symbol) (m :: * -> *) e a.
JWTAuth' x scheme m e a -> JWKSet
jwkSet :: JWT.JWKSet
, forall (x :: Existence) (scheme :: Symbol) (m :: * -> *) e a.
JWTAuth' x scheme m e a -> ClaimsSet -> m (Either e a)
toJWTAttribute :: JWT.ClaimsSet -> m (Either e a)
}
type JWTAuth = JWTAuth' Required "Bearer"
data JWTAuthError e
=
| JWTAuthSchemeMismatch
| JWTAuthTokenBadFormat JWT.JWTError
| JWTAuthAttributeError e
deriving stock (JWTAuthError e -> JWTAuthError e -> Bool
forall e. Eq e => JWTAuthError e -> JWTAuthError e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JWTAuthError e -> JWTAuthError e -> Bool
$c/= :: forall e. Eq e => JWTAuthError e -> JWTAuthError e -> Bool
== :: JWTAuthError e -> JWTAuthError e -> Bool
$c== :: forall e. Eq e => JWTAuthError e -> JWTAuthError e -> Bool
Eq, Int -> JWTAuthError e -> ShowS
forall e. Show e => Int -> JWTAuthError e -> ShowS
forall e. Show e => [JWTAuthError e] -> ShowS
forall e. Show e => JWTAuthError e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JWTAuthError e] -> ShowS
$cshowList :: forall e. Show e => [JWTAuthError e] -> ShowS
show :: JWTAuthError e -> String
$cshow :: forall e. Show e => JWTAuthError e -> String
showsPrec :: Int -> JWTAuthError e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> JWTAuthError e -> ShowS
Show)
instance Trait (JWTAuth' Required scheme m e a) Request where
type Attribute (JWTAuth' Required scheme m e a) Request = a
instance TraitAbsence (JWTAuth' Required scheme m e a) Request where
type Absence (JWTAuth' Required scheme m e a) Request = JWTAuthError e
instance Trait (JWTAuth' Optional scheme m e a) Request where
type Attribute (JWTAuth' Optional scheme m e a) Request = Either (JWTAuthError e) a
instance TraitAbsence (JWTAuth' Optional scheme m e a) Request where
type Absence (JWTAuth' Optional scheme m e a) Request = Void
jwtAuth ::
( Get h (JWTAuth m e t) Request
, ArrowChoice h
) =>
JWTAuth m e t ->
h (Request `With` ts, JWTAuthError e) Response ->
Middleware h ts (JWTAuth m e t : ts)
jwtAuth :: forall (h :: * -> * -> *) (m :: * -> *) e t (ts :: [*]).
(Get h (JWTAuth m e t) Request, ArrowChoice h) =>
JWTAuth m e t
-> h (With Request ts, JWTAuthError e) Response
-> Middleware h ts (JWTAuth m e t : ts)
jwtAuth = forall (s :: Symbol) e t (h :: * -> * -> *) (m :: * -> *)
(ts :: [*]).
(Get h (JWTAuth' 'Required s m e t) Request, ArrowChoice h) =>
JWTAuth' 'Required s m e t
-> h (With Request ts, JWTAuthError e) Response
-> Middleware h ts (JWTAuth' 'Required s m e t : ts)
jwtAuth' @"Bearer"
{-# INLINE jwtAuth #-}
optionalJWTAuth ::
( Get h (JWTAuth' Optional "Bearer" m e t) Request
, ArrowChoice h
) =>
JWTAuth' Optional "Bearer" m e t ->
Middleware h ts (JWTAuth' Optional "Bearer" m e t : ts)
optionalJWTAuth :: forall (h :: * -> * -> *) (m :: * -> *) e t (ts :: [*]).
(Get h (JWTAuth' 'Optional "Bearer" m e t) Request,
ArrowChoice h) =>
JWTAuth' 'Optional "Bearer" m e t
-> Middleware h ts (JWTAuth' 'Optional "Bearer" m e t : ts)
optionalJWTAuth = forall (s :: Symbol) e t (h :: * -> * -> *) (m :: * -> *)
(ts :: [*]).
(Get h (JWTAuth' 'Optional s m e t) Request, ArrowChoice h) =>
JWTAuth' 'Optional s m e t
-> Middleware h ts (JWTAuth' 'Optional s m e t : ts)
optionalJWTAuth' @"Bearer"
{-# INLINE optionalJWTAuth #-}
jwtAuthMiddleware ::
forall s e t x h m ts.
( Get h (JWTAuth' x s m e t) Request
, ArrowChoice h
) =>
JWTAuth' x s m e t ->
h (Request `With` ts, Absence (JWTAuth' x s m e t) Request) Response ->
Middleware h ts (JWTAuth' x s m e t : ts)
jwtAuthMiddleware :: forall (s :: Symbol) e t (x :: Existence) (h :: * -> * -> *)
(m :: * -> *) (ts :: [*]).
(Get h (JWTAuth' x s m e t) Request, ArrowChoice h) =>
JWTAuth' x s m e t
-> h (With Request ts, Absence (JWTAuth' x s m e t) Request)
Response
-> Middleware h ts (JWTAuth' x s m e t : ts)
jwtAuthMiddleware JWTAuth' x s m e t
authCfg h (With Request ts, Absence (JWTAuth' x s m e t) Request) Response
errorHandler RequestHandler h (JWTAuth' x s m e t : ts)
nextHandler =
proc With Request ts
request -> do
Either
(Absence (JWTAuth' x s m e t) Request)
(With Request (JWTAuth' x s m e t : ts))
result <- forall t (ts :: [*]) (h :: * -> * -> *) a.
Get h t a =>
t -> h (With a ts) (Either (Absence t a) (With a (t : ts)))
probe JWTAuth' x s m e t
authCfg -< With Request ts
request
case Either
(Absence (JWTAuth' x s m e t) Request)
(With Request (JWTAuth' x s m e t : ts))
result of
Left Absence (JWTAuth' x s m e t) Request
err -> h (With Request ts, Absence (JWTAuth' x s m e t) Request) Response
errorHandler -< (With Request ts
request, Absence (JWTAuth' x s m e t) Request
err)
Right With Request (JWTAuth' x s m e t : ts)
val -> RequestHandler h (JWTAuth' x s m e t : ts)
nextHandler -< With Request (JWTAuth' x s m e t : ts)
val
{-# INLINE jwtAuthMiddleware #-}
jwtAuth' ::
forall s e t h m ts.
( Get h (JWTAuth' Required s m e t) Request
, ArrowChoice h
) =>
JWTAuth' Required s m e t ->
h (Request `With` ts, JWTAuthError e) Response ->
Middleware h ts (JWTAuth' Required s m e t : ts)
jwtAuth' :: forall (s :: Symbol) e t (h :: * -> * -> *) (m :: * -> *)
(ts :: [*]).
(Get h (JWTAuth' 'Required s m e t) Request, ArrowChoice h) =>
JWTAuth' 'Required s m e t
-> h (With Request ts, JWTAuthError e) Response
-> Middleware h ts (JWTAuth' 'Required s m e t : ts)
jwtAuth' = forall (s :: Symbol) e t (x :: Existence) (h :: * -> * -> *)
(m :: * -> *) (ts :: [*]).
(Get h (JWTAuth' x s m e t) Request, ArrowChoice h) =>
JWTAuth' x s m e t
-> h (With Request ts, Absence (JWTAuth' x s m e t) Request)
Response
-> Middleware h ts (JWTAuth' x s m e t : ts)
jwtAuthMiddleware
{-# INLINE jwtAuth' #-}
optionalJWTAuth' ::
forall s e t h m ts.
( Get h (JWTAuth' Optional s m e t) Request
, ArrowChoice h
) =>
JWTAuth' Optional s m e t ->
Middleware h ts (JWTAuth' Optional s m e t : ts)
optionalJWTAuth' :: forall (s :: Symbol) e t (h :: * -> * -> *) (m :: * -> *)
(ts :: [*]).
(Get h (JWTAuth' 'Optional s m e t) Request, ArrowChoice h) =>
JWTAuth' 'Optional s m e t
-> Middleware h ts (JWTAuth' 'Optional s m e t : ts)
optionalJWTAuth' JWTAuth' 'Optional s m e t
cfg = forall (s :: Symbol) e t (x :: Existence) (h :: * -> * -> *)
(m :: * -> *) (ts :: [*]).
(Get h (JWTAuth' x s m e t) Request, ArrowChoice h) =>
JWTAuth' x s m e t
-> h (With Request ts, Absence (JWTAuth' x s m e t) Request)
Response
-> Middleware h ts (JWTAuth' x s m e t : ts)
jwtAuthMiddleware JWTAuth' 'Optional s m e t
cfg forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a. Void -> a
absurd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)
{-# INLINE optionalJWTAuth' #-}