{-# 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
(JWTAuthError e -> JWTAuthError e -> Bool)
-> (JWTAuthError e -> JWTAuthError e -> Bool)
-> Eq (JWTAuthError e)
forall e. Eq e => JWTAuthError e -> JWTAuthError e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: JWTAuthError e -> JWTAuthError e -> Bool
Eq, Int -> JWTAuthError e -> ShowS
[JWTAuthError e] -> ShowS
JWTAuthError e -> String
(Int -> JWTAuthError e -> ShowS)
-> (JWTAuthError e -> String)
-> ([JWTAuthError e] -> ShowS)
-> Show (JWTAuthError e)
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
$cshowsPrec :: forall e. Show e => Int -> JWTAuthError e -> ShowS
showsPrec :: Int -> JWTAuthError e -> ShowS
$cshow :: forall e. Show e => JWTAuthError e -> String
show :: JWTAuthError e -> String
$cshowList :: forall e. Show e => [JWTAuthError e] -> ShowS
showList :: [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
type instance
Prerequisite (JWTAuth' x scheme m e a) ts Request =
HasTrait (AuthorizationHeader scheme) ts
jwtAuth ::
( ArrowChoice h
, Get h (JWTAuth m e t) Request
, HasTrait (AuthorizationHeader "Bearer") ts
) =>
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 :: [*]).
(ArrowChoice h, Get h (JWTAuth m e t) Request,
HasTrait (AuthorizationHeader "Bearer") ts) =>
JWTAuth m e t
-> h (With Request ts, JWTAuthError e) Response
-> Middleware h ts (JWTAuth m e t : ts)
jwtAuth = forall (scheme :: Symbol) e t (h :: * -> * -> *) (m :: * -> *)
(ts :: [*]).
(ArrowChoice h, Get h (JWTAuth' 'Required scheme m e t) Request,
HasTrait (AuthorizationHeader scheme) ts) =>
JWTAuth' 'Required scheme m e t
-> h (With Request ts, JWTAuthError e) Response
-> Middleware h ts (JWTAuth' 'Required scheme m e t : ts)
jwtAuth' @"Bearer"
{-# INLINE jwtAuth #-}
optionalJWTAuth ::
( ArrowChoice h
, Get h (JWTAuth' Optional "Bearer" m e t) Request
, HasTrait (AuthorizationHeader "Bearer") ts
) =>
JWTAuth' Optional "Bearer" m e t ->
Middleware h ts (JWTAuth' Optional "Bearer" m e t : ts)
optionalJWTAuth :: forall (h :: * -> * -> *) (m :: * -> *) e t (ts :: [*]).
(ArrowChoice h, Get h (JWTAuth' 'Optional "Bearer" m e t) Request,
HasTrait (AuthorizationHeader "Bearer") ts) =>
JWTAuth' 'Optional "Bearer" m e t
-> Middleware h ts (JWTAuth' 'Optional "Bearer" m e t : ts)
optionalJWTAuth = forall (scheme :: Symbol) e t (h :: * -> * -> *) (m :: * -> *)
(ts :: [*]).
(ArrowChoice h, Get h (JWTAuth' 'Optional scheme m e t) Request,
HasTrait (AuthorizationHeader scheme) ts) =>
JWTAuth' 'Optional scheme m e t
-> Middleware h ts (JWTAuth' 'Optional scheme m e t : ts)
optionalJWTAuth' @"Bearer"
{-# INLINE optionalJWTAuth #-}
jwtAuthMiddleware ::
forall scheme e t x h m ts.
( ArrowChoice h
, Get h (JWTAuth' x scheme m e t) Request
, HasTrait (AuthorizationHeader scheme) ts
) =>
JWTAuth' x scheme m e t ->
h (Request `With` ts, Absence (JWTAuth' x scheme m e t) Request) Response ->
Middleware h ts (JWTAuth' x scheme m e t : ts)
jwtAuthMiddleware :: forall (scheme :: Symbol) e t (x :: Existence) (h :: * -> * -> *)
(m :: * -> *) (ts :: [*]).
(ArrowChoice h, Get h (JWTAuth' x scheme m e t) Request,
HasTrait (AuthorizationHeader scheme) ts) =>
JWTAuth' x scheme m e t
-> h (With Request ts, Absence (JWTAuth' x scheme m e t) Request)
Response
-> Middleware h ts (JWTAuth' x scheme m e t : ts)
jwtAuthMiddleware JWTAuth' x scheme m e t
authCfg h (With Request ts, Absence (JWTAuth' x scheme m e t) Request)
Response
errorHandler RequestHandler h (JWTAuth' x scheme m e t : ts)
nextHandler =
proc With Request ts
request -> do
Either
(Absence (JWTAuth' x scheme m e t) Request)
(With Request (JWTAuth' x scheme m e t : ts))
result <- JWTAuth' x scheme m e t
-> h (With Request ts)
(Either
(Absence (JWTAuth' x scheme m e t) Request)
(With Request (JWTAuth' x scheme m e t : ts)))
forall t (ts :: [*]) (h :: * -> * -> *) a.
(Get h t a, Prerequisite t ts a) =>
t -> h (With a ts) (Either (Absence t a) (With a (t : ts)))
probe JWTAuth' x scheme m e t
authCfg -< With Request ts
request
case Either
(Absence (JWTAuth' x scheme m e t) Request)
(With Request (JWTAuth' x scheme m e t : ts))
result of
Left Absence (JWTAuth' x scheme m e t) Request
err -> h (With Request ts, Absence (JWTAuth' x scheme m e t) Request)
Response
errorHandler -< (With Request ts
request, Absence (JWTAuth' x scheme m e t) Request
err)
Right With Request (JWTAuth' x scheme m e t : ts)
val -> RequestHandler h (JWTAuth' x scheme m e t : ts)
nextHandler -< With Request (JWTAuth' x scheme m e t : ts)
val
{-# INLINE jwtAuthMiddleware #-}
jwtAuth' ::
forall scheme e t h m ts.
( ArrowChoice h
, Get h (JWTAuth' Required scheme m e t) Request
, HasTrait (AuthorizationHeader scheme) ts
) =>
JWTAuth' Required scheme m e t ->
h (Request `With` ts, JWTAuthError e) Response ->
Middleware h ts (JWTAuth' Required scheme m e t : ts)
jwtAuth' :: forall (scheme :: Symbol) e t (h :: * -> * -> *) (m :: * -> *)
(ts :: [*]).
(ArrowChoice h, Get h (JWTAuth' 'Required scheme m e t) Request,
HasTrait (AuthorizationHeader scheme) ts) =>
JWTAuth' 'Required scheme m e t
-> h (With Request ts, JWTAuthError e) Response
-> Middleware h ts (JWTAuth' 'Required scheme m e t : ts)
jwtAuth' = JWTAuth' 'Required scheme m e t
-> h (With Request ts,
Absence (JWTAuth' 'Required scheme m e t) Request)
Response
-> Middleware h ts (JWTAuth' 'Required scheme m e t : ts)
JWTAuth' 'Required scheme m e t
-> h (With Request ts, JWTAuthError e) Response
-> Middleware h ts (JWTAuth' 'Required scheme m e t : ts)
forall (scheme :: Symbol) e t (x :: Existence) (h :: * -> * -> *)
(m :: * -> *) (ts :: [*]).
(ArrowChoice h, Get h (JWTAuth' x scheme m e t) Request,
HasTrait (AuthorizationHeader scheme) ts) =>
JWTAuth' x scheme m e t
-> h (With Request ts, Absence (JWTAuth' x scheme m e t) Request)
Response
-> Middleware h ts (JWTAuth' x scheme m e t : ts)
jwtAuthMiddleware
{-# INLINE jwtAuth' #-}
optionalJWTAuth' ::
forall scheme e t h m ts.
( ArrowChoice h
, Get h (JWTAuth' Optional scheme m e t) Request
, HasTrait (AuthorizationHeader scheme) ts
) =>
JWTAuth' Optional scheme m e t ->
Middleware h ts (JWTAuth' Optional scheme m e t : ts)
optionalJWTAuth' :: forall (scheme :: Symbol) e t (h :: * -> * -> *) (m :: * -> *)
(ts :: [*]).
(ArrowChoice h, Get h (JWTAuth' 'Optional scheme m e t) Request,
HasTrait (AuthorizationHeader scheme) ts) =>
JWTAuth' 'Optional scheme m e t
-> Middleware h ts (JWTAuth' 'Optional scheme m e t : ts)
optionalJWTAuth' JWTAuth' 'Optional scheme m e t
cfg = JWTAuth' 'Optional scheme m e t
-> h (With Request ts,
Absence (JWTAuth' 'Optional scheme m e t) Request)
Response
-> h (With Request (JWTAuth' 'Optional scheme m e t : ts)) Response
-> h (With Request ts) Response
forall (scheme :: Symbol) e t (x :: Existence) (h :: * -> * -> *)
(m :: * -> *) (ts :: [*]).
(ArrowChoice h, Get h (JWTAuth' x scheme m e t) Request,
HasTrait (AuthorizationHeader scheme) ts) =>
JWTAuth' x scheme m e t
-> h (With Request ts, Absence (JWTAuth' x scheme m e t) Request)
Response
-> Middleware h ts (JWTAuth' x scheme m e t : ts)
jwtAuthMiddleware JWTAuth' 'Optional scheme m e t
cfg (h (With Request ts,
Absence (JWTAuth' 'Optional scheme m e t) Request)
Response
-> h (With Request (JWTAuth' 'Optional scheme m e t : ts)) Response
-> h (With Request ts) Response)
-> h (With Request ts,
Absence (JWTAuth' 'Optional scheme m e t) Request)
Response
-> h (With Request (JWTAuth' 'Optional scheme m e t : ts)) Response
-> h (With Request ts) Response
forall a b. (a -> b) -> a -> b
$ ((With Request ts, Void) -> Response)
-> h (With Request ts, Void) Response
forall b c. (b -> c) -> h b c
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (Void -> Response
forall a. Void -> a
absurd (Void -> Response)
-> ((With Request ts, Void) -> Void)
-> (With Request ts, Void)
-> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (With Request ts, Void) -> Void
forall a b. (a, b) -> b
snd)
{-# INLINE optionalJWTAuth' #-}