{-# LANGUAGE DuplicateRecordFields #-}

{- | JWT authentication support.

 Middlewares defined in this module add JWT authentication support to
 handlers. In most cases, you just need to use `JWTAuth` trait and
 `jwtAuth` middleware. The table below describes when to use other
 traits and middlewares.

 +----------+-------------+-----------------------+--------------------+
 | Type     | Auth Scheme | Trait                 | Middleware         |
 +----------+-------------+-----------------------+--------------------+
 | Required | Bearer      | 'JWTAuth'             | 'jwtAuth'          |
 +----------+-------------+-----------------------+--------------------+
 | Optional | Bearer      | 'JWTAuth'' 'Optional' | 'optionalJWTAuth'  |
 +----------+-------------+-----------------------+--------------------+
 | Required | Any scheme  | 'JWTAuth'' 'Required' | 'jwtAuth''         |
 +----------+-------------+-----------------------+--------------------+
 | Optional | Any scheme  | 'JWTAuth'' 'Optional' | 'optionalJWTAuth'' |
 +----------+-------------+-----------------------+--------------------+

 For example, given this handler:

 @
 myHandler :: ('Handler' h IO, 'HasTrait' ('JWTAuth' IO () 'JWT.ClaimsSet') ts) => 'RequestHandler' h ts
 myHandler = ....
 @

 and the following definitions:

 @
 authConfig :: 'JWTAuth' IO () 'JWT.ClaimsSet'
 authConfig = 'JWTAuth''
   { jwtValidationSettings = 'JWT.defaultJWTValidationSettings' (const True)
   , jwkSet = ....
   , toJWTAttribute = pure . Right
   }

 type ErrorTraits = [Status, RequiredRequestHeader \"Content-Type\" Text, RequiredRequestHeader \"WWW-Authenticate\" Text, Body Text]

 errorHandler :: ('Handler' h IO, Sets h ErrorTraits Response)
              => h (Request \`With\` ts, 'JWTAuthError' e) Response
 errorHandler = 'respondUnauthorized' \"Bearer\" \"MyRealm\"
 @

 we can add JWT authentication to @myHandler@:

 @
 myHandlerWithAuth :: ('Handler' h IO, Get h ('JWTAuth' IO () 'JWT.ClaimsSet') Request, Sets h ErrorTraits Response)
                   => 'RequestHandler' h ts
 myHandlerWithAuth = 'jwtAuth' authConfig errorHandler myHandler
 @

 The middlewares defined below take a 'JWTAuth'' parameter which has
 settings for validating a JWT. It also contains a function of type
 @'JWT.ClaimsSet' -> m (Either e a)@. This is used to convert the set
 of claims in the JWT to a value of type @a@ or fail with an error of
 type @e@. In this case @a@ is the type of the trait attribute and the
 next handler is invoked after this conversion.

 Middlewares marked as 'Required' take an additional error handling
 arrow as a parameter. This arrow is used when an error is encountered
 in authentication. This arrow receives the original request and a
 'JWTAuthError' as inputs and must produce a response as the output.

 Middlewares marked as 'Optional' do not have this additional error
 handling arrow. Instead, the trait attribute is of type @Either
 ('JWTAuthError' e) a@. The next handler will get the errors in this
 trait attribute and must handle it.
-}
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

{- | Trait for JWT authentication with a bearer token:
 https://tools.ietf.org/html/rfc6750

 This trait supports a custom scheme instead of the standard
 \"Bearer\" scheme.
-}
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
  -- ^ Settings to validate the JWT
  , forall (x :: Existence) (scheme :: Symbol) (m :: * -> *) e a.
JWTAuth' x scheme m e a -> JWKSet
jwkSet :: JWT.JWKSet
  -- ^ JWK to validate the JWT
  , 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)
  -- ^ Convert the claims set to the trait attribute or an error
  }

-- | Trait for JWT authentication with the \"Bearer\" scheme
type JWTAuth = JWTAuth' Required "Bearer"

-- | Error extracting a JWT from a request
data JWTAuthError e
  = JWTAuthHeaderMissing
  | 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

{- | Middleware to add JWT authentication protection for a
 handler. Expects the JWT to be available via a standard bearer
 authorization header in the format:

 > Authorization: Bearer <jwt>

 Example usage:

 > jwtAuth cfg errorHandler nextHandler

 The @errorHandler@ is invoked if the credentials are invalid or
 missing. The @nextHandler@ is invoked if the credentials were
 retrieved successfully.
-}
jwtAuth ::
  ( ArrowChoice h
  , Get h (JWTAuth m e t) Request
  , HasTrait (AuthorizationHeader "Bearer") ts
  ) =>
  -- | Authentication configuration
  JWTAuth m e t ->
  -- | Error handler
  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 #-}

{- | Middleware to add optional JWT authentication protection for a
 handler. Expects the JWT to be available via a standard bearer
 authorization header in the format:

 > Authorization: Bearer <jwt>

 Example usage:

 > optionalJWTAuth cfg handler

 This middleware will not fail if authorization credentials are
 invalid or missing. Instead the trait attribute is of type @'Either'
 ('JWTAuthError' e) t@ so that the handler can process the
 authentication error appropriately.
-}
optionalJWTAuth ::
  ( ArrowChoice h
  , Get h (JWTAuth' Optional "Bearer" m e t) Request
  , HasTrait (AuthorizationHeader "Bearer") ts
  ) =>
  -- | Authentication configuration
  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 #-}

{- | Middleware to add JWT authentication protection for a
 handler. Expects the JWT to be available via an authorization header
 in the format:

 > Authorization: <scheme> <jwt>

 Example usage:

 > jwtAuth' @"<scheme>" cfg errorHandler nextHandler

 The @errorHandler@ is invoked if the credentials are invalid or
 missing. The @nextHandler@ is invoked if the credentials were
 retrieved successfully.
-}
jwtAuth' ::
  forall scheme e t h m ts.
  ( ArrowChoice h
  , Get h (JWTAuth' Required scheme m e t) Request
  , HasTrait (AuthorizationHeader scheme) ts
  ) =>
  -- | Authentication configuration
  JWTAuth' Required scheme m e t ->
  -- | Error handler
  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' #-}

{- | Middleware to add JWT authentication protection for a
 handler. Expects the JWT to be available via an authorization header
 in the format:

 > Authorization: <scheme> <jwt>

 Example usage:

 > optionalJWTAuth' @"<scheme>" cfg nextHandler

 This middleware will not fail if authorization credentials are
 invalid or missing. Instead the trait attribute is of type @'Either'
 ('JWTAuthError' e) t@ so that the handler can process the
 authentication error appropriately.
-}
optionalJWTAuth' ::
  forall scheme e t h m ts.
  ( ArrowChoice h
  , Get h (JWTAuth' Optional scheme m e t) Request
  , HasTrait (AuthorizationHeader scheme) ts
  ) =>
  -- | Authentication configuration
  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' #-}