-- Copyright (C) 2013, 2014, 2015, 2016, 2017  Fraser Tweedale
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{-|

JSON Web Token implementation (RFC 7519). A JWT is a JWS
with a payload of /claims/ to be transferred between two
parties.

JWTs use the JWS /compact serialisation/.
See "Crypto.JOSE.Compact" for details.

-}
module Crypto.JWT
  (
  -- * Overview / HOWTO
  -- ** Basic usage
  -- $basic

  -- ** Supporting additional claims via subtypes #subtypes#
  -- $subtypes

  -- * API
  -- ** Creating a JWT
    SignedJWT
  , signClaims
  , signJWT

  -- ** Validating a JWT and extracting claims
  , defaultJWTValidationSettings
  , verifyClaims
  , verifyJWT
  , HasAllowedSkew(..)
  , HasAudiencePredicate(..)
  , HasIssuerPredicate(..)
  , HasCheckIssuedAt(..)
  , JWTValidationSettings
  , HasJWTValidationSettings(..)

  -- *** Specifying the verification time
  , WrappedUTCTime(..)
  , verifyClaimsAt
  , verifyJWTAt

  -- ** Claims Set
  , ClaimsSet
  , emptyClaimsSet
  , HasClaimsSet(..)
  , validateClaimsSet
  -- *** Unregistered claims (__deprecated__)
  , addClaim
  , unregisteredClaims

  -- ** JWT errors
  , JWTError(..)
  , AsJWTError(..)

  -- ** Miscellaneous types
  , Audience(..)
  , StringOrURI
  , stringOrUri
  , string
  , uri
  , NumericDate(..)

  -- ** Re-exports
  , module Crypto.JOSE

  ) where

import Control.Applicative
import Control.Monad
import Control.Monad.Time (MonadTime(..))
import Data.Foldable (traverse_)
import Data.Functor.Identity
import Data.Maybe
import qualified Data.String

import Control.Lens (
  makeClassy, makeClassyPrisms, makePrisms,
  Lens', _Just, over, preview, view,
  Prism', prism', Cons, iso, AsEmpty)
import Control.Lens.Cons.Extras (recons)
import Control.Monad.Error.Lens (throwing, throwing_)
import Control.Monad.Except (MonadError)
import Control.Monad.Reader (ReaderT, asks, runReaderT)
import Data.Aeson
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Time (NominalDiffTime, UTCTime, addUTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import Network.URI (parseURI)

import Crypto.JOSE
import Crypto.JOSE.Types

{- $basic

@
import Crypto.JWT

mkClaims :: IO 'ClaimsSet'
mkClaims = do
  t <- 'currentTime'
  pure $ 'emptyClaimsSet'
    & 'claimIss' ?~ "alice"
    & 'claimAud' ?~ 'Audience' ["bob"]
    & 'claimIat' ?~ 'NumericDate' t

doJwtSign :: 'JWK' -> 'ClaimsSet' -> IO (Either 'JWTError' 'SignedJWT')
doJwtSign jwk claims = 'runJOSE' $ do
  alg \<- 'bestJWSAlg' jwk
  'signClaims' jwk ('newJWSHeader' ((), alg)) claims

doJwtVerify :: 'JWK' -> 'SignedJWT' -> IO (Either 'JWTError' 'ClaimsSet')
doJwtVerify jwk jwt = 'runJOSE' $ do
  let config = 'defaultJWTValidationSettings' (== "bob")
  'verifyClaims' config jwk jwt
@

Some JWT libraries have a function that takes two strings: the
"secret" (a symmetric key) and the raw JWT.  The following function
achieves the same:

@
verify :: L.ByteString -> L.ByteString -> IO (Either 'JWTError' 'ClaimsSet')
verify k s = 'runJOSE' $ do
  let
    k' = 'fromOctets' k      -- turn raw secret into symmetric JWK
    audCheck = const True  -- should be a proper audience check
  jwt <- 'decodeCompact' s    -- decode JWT
  'verifyClaims' ('defaultJWTValidationSettings' audCheck) k' jwt
@

-}

{- $subtypes

For applications that use __additional claims__, define a data type that wraps
'ClaimsSet' and includes fields for the additional claims.  You will also need
to define 'FromJSON' if verifying JWTs, and 'ToJSON' if producing JWTs.  The
following example is taken from
<https://datatracker.ietf.org/doc/html/rfc7519#section-3.1 RFC 7519 §3.1>.

@
import qualified Data.Aeson.KeyMap as M

data Super = Super { jwtClaims :: 'ClaimsSet', isRoot :: Bool }

instance 'HasClaimsSet' Super where
  'claimsSet' f s = fmap (\\a' -> s { jwtClaims = a' }) (f (jwtClaims s))

instance FromJSON Super where
  parseJSON = withObject \"Super\" $ \\o -> Super
    \<$\> parseJSON (Object o)
    \<*\> o .: "http://example.com/is_root"

instance ToJSON Super where
  toJSON s =
    ins "http://example.com/is_root" (isRoot s) (toJSON (jwtClaims s))
    where
      ins k v (Object o) = Object $ M.insert k (toJSON v) o
      ins _ _ a = a
@

__Use 'signJWT' and 'verifyJWT' when using custom payload types__ (instead of
'signClaims' and 'verifyClaims' which are specialised to 'ClaimsSet').

-}


data JWTError
  = JWSError Error
  -- ^ A JOSE error occurred while processing the JWT
  | JWTClaimsSetDecodeError String
  -- ^ The JWT payload is not a JWT Claims Set
  | JWTExpired
  | JWTNotYetValid
  | JWTNotInIssuer
  | JWTNotInAudience
  | JWTIssuedAtFuture
  deriving (JWTError -> JWTError -> Bool
(JWTError -> JWTError -> Bool)
-> (JWTError -> JWTError -> Bool) -> Eq JWTError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JWTError -> JWTError -> Bool
== :: JWTError -> JWTError -> Bool
$c/= :: JWTError -> JWTError -> Bool
/= :: JWTError -> JWTError -> Bool
Eq, Int -> JWTError -> ShowS
[JWTError] -> ShowS
JWTError -> String
(Int -> JWTError -> ShowS)
-> (JWTError -> String) -> ([JWTError] -> ShowS) -> Show JWTError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JWTError -> ShowS
showsPrec :: Int -> JWTError -> ShowS
$cshow :: JWTError -> String
show :: JWTError -> String
$cshowList :: [JWTError] -> ShowS
showList :: [JWTError] -> ShowS
Show)
makeClassyPrisms ''JWTError

instance AsError JWTError where
  _Error :: Prism' JWTError Error
_Error = p Error (f Error) -> p JWTError (f JWTError)
forall r. AsJWTError r => Prism' r Error
Prism' JWTError Error
_JWSError


-- RFC 7519 §2.  Terminology

-- | A JSON string value, with the additional requirement that while
--   arbitrary string values MAY be used, any value containing a @:@
--   character MUST be a URI.
--
-- __Note__: the 'IsString' instance will fail if the string
-- contains a @:@ but does not parse as a 'URI'.  Use 'stringOrUri'
-- directly in this situation.
--
data StringOrURI = Arbitrary T.Text | OrURI URI deriving (StringOrURI -> StringOrURI -> Bool
(StringOrURI -> StringOrURI -> Bool)
-> (StringOrURI -> StringOrURI -> Bool) -> Eq StringOrURI
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StringOrURI -> StringOrURI -> Bool
== :: StringOrURI -> StringOrURI -> Bool
$c/= :: StringOrURI -> StringOrURI -> Bool
/= :: StringOrURI -> StringOrURI -> Bool
Eq, Int -> StringOrURI -> ShowS
[StringOrURI] -> ShowS
StringOrURI -> String
(Int -> StringOrURI -> ShowS)
-> (StringOrURI -> String)
-> ([StringOrURI] -> ShowS)
-> Show StringOrURI
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StringOrURI -> ShowS
showsPrec :: Int -> StringOrURI -> ShowS
$cshow :: StringOrURI -> String
show :: StringOrURI -> String
$cshowList :: [StringOrURI] -> ShowS
showList :: [StringOrURI] -> ShowS
Show)

-- | Non-total.  A string with a @':'@ in it MUST parse as a URI
instance Data.String.IsString StringOrURI where
  fromString :: String -> StringOrURI
fromString = Maybe StringOrURI -> StringOrURI
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe StringOrURI -> StringOrURI)
-> (String -> Maybe StringOrURI) -> String -> StringOrURI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First StringOrURI) String StringOrURI
-> String -> Maybe StringOrURI
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First StringOrURI) String StringOrURI
forall s. (Cons s s Char Char, AsEmpty s) => Prism' s StringOrURI
Prism' String StringOrURI
stringOrUri

stringOrUri :: (Cons s s Char Char, AsEmpty s) => Prism' s StringOrURI
stringOrUri :: forall s. (Cons s s Char Char, AsEmpty s) => Prism' s StringOrURI
stringOrUri = (s -> Text) -> (Text -> s) -> Iso s s Text Text
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (Getting Text s Text -> s -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text s Text
forall s1 a s2.
(Cons s1 s1 a a, Cons s2 s2 a a, AsEmpty s2) =>
Getter s1 s2
Getter s Text
recons) (Getting s Text s -> Text -> s
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting s Text s
forall s1 a s2.
(Cons s1 s1 a a, Cons s2 s2 a a, AsEmpty s2) =>
Getter s1 s2
Getter Text s
recons) (p Text (f Text) -> p s (f s))
-> (p StringOrURI (f StringOrURI) -> p Text (f Text))
-> p StringOrURI (f StringOrURI)
-> p s (f s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StringOrURI -> Text)
-> (Text -> Maybe StringOrURI)
-> Prism Text Text StringOrURI StringOrURI
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' StringOrURI -> Text
rev Text -> Maybe StringOrURI
fwd
  where
  rev :: StringOrURI -> Text
rev (Arbitrary Text
s) = Text
s
  rev (OrURI URI
x) = String -> Text
T.pack (URI -> String
forall a. Show a => a -> String
show URI
x)
  fwd :: Text -> Maybe StringOrURI
fwd Text
s
    | (Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':') Text
s = URI -> StringOrURI
OrURI (URI -> StringOrURI) -> Maybe URI -> Maybe StringOrURI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe URI
parseURI (Text -> String
T.unpack Text
s)
    | Bool
otherwise = StringOrURI -> Maybe StringOrURI
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> StringOrURI
Arbitrary Text
s)
{-# INLINE stringOrUri #-}

string :: Prism' StringOrURI T.Text
string :: Prism' StringOrURI Text
string = (Text -> StringOrURI)
-> (StringOrURI -> Maybe Text) -> Prism' StringOrURI Text
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' Text -> StringOrURI
Arbitrary StringOrURI -> Maybe Text
f where
  f :: StringOrURI -> Maybe Text
f (Arbitrary Text
s) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s
  f StringOrURI
_ = Maybe Text
forall a. Maybe a
Nothing

uri :: Prism' StringOrURI URI
uri :: Prism' StringOrURI URI
uri = (URI -> StringOrURI)
-> (StringOrURI -> Maybe URI) -> Prism' StringOrURI URI
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' URI -> StringOrURI
OrURI StringOrURI -> Maybe URI
f where
  f :: StringOrURI -> Maybe URI
f (OrURI URI
s) = URI -> Maybe URI
forall a. a -> Maybe a
Just URI
s
  f StringOrURI
_ = Maybe URI
forall a. Maybe a
Nothing

instance FromJSON StringOrURI where
  parseJSON :: Value -> Parser StringOrURI
parseJSON = String
-> (Text -> Parser StringOrURI) -> Value -> Parser StringOrURI
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"StringOrURI"
    (Parser StringOrURI
-> (StringOrURI -> Parser StringOrURI)
-> Maybe StringOrURI
-> Parser StringOrURI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser StringOrURI
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"failed to parse StringOrURI") StringOrURI -> Parser StringOrURI
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe StringOrURI -> Parser StringOrURI)
-> (Text -> Maybe StringOrURI) -> Text -> Parser StringOrURI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First StringOrURI) Text StringOrURI
-> Text -> Maybe StringOrURI
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview Getting (First StringOrURI) Text StringOrURI
forall s. (Cons s s Char Char, AsEmpty s) => Prism' s StringOrURI
Prism Text Text StringOrURI StringOrURI
stringOrUri)

instance ToJSON StringOrURI where
  toJSON :: StringOrURI -> Value
toJSON (Arbitrary Text
s)  = Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
s
  toJSON (OrURI URI
x)      = String -> Value
forall a. ToJSON a => a -> Value
toJSON (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ URI -> String
forall a. Show a => a -> String
show URI
x


-- | A JSON numeric value representing the number of seconds from
--   1970-01-01T0:0:0Z UTC until the specified UTC date\/time.
--
newtype NumericDate = NumericDate UTCTime deriving (NumericDate -> NumericDate -> Bool
(NumericDate -> NumericDate -> Bool)
-> (NumericDate -> NumericDate -> Bool) -> Eq NumericDate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NumericDate -> NumericDate -> Bool
== :: NumericDate -> NumericDate -> Bool
$c/= :: NumericDate -> NumericDate -> Bool
/= :: NumericDate -> NumericDate -> Bool
Eq, Eq NumericDate
Eq NumericDate =>
(NumericDate -> NumericDate -> Ordering)
-> (NumericDate -> NumericDate -> Bool)
-> (NumericDate -> NumericDate -> Bool)
-> (NumericDate -> NumericDate -> Bool)
-> (NumericDate -> NumericDate -> Bool)
-> (NumericDate -> NumericDate -> NumericDate)
-> (NumericDate -> NumericDate -> NumericDate)
-> Ord NumericDate
NumericDate -> NumericDate -> Bool
NumericDate -> NumericDate -> Ordering
NumericDate -> NumericDate -> NumericDate
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NumericDate -> NumericDate -> Ordering
compare :: NumericDate -> NumericDate -> Ordering
$c< :: NumericDate -> NumericDate -> Bool
< :: NumericDate -> NumericDate -> Bool
$c<= :: NumericDate -> NumericDate -> Bool
<= :: NumericDate -> NumericDate -> Bool
$c> :: NumericDate -> NumericDate -> Bool
> :: NumericDate -> NumericDate -> Bool
$c>= :: NumericDate -> NumericDate -> Bool
>= :: NumericDate -> NumericDate -> Bool
$cmax :: NumericDate -> NumericDate -> NumericDate
max :: NumericDate -> NumericDate -> NumericDate
$cmin :: NumericDate -> NumericDate -> NumericDate
min :: NumericDate -> NumericDate -> NumericDate
Ord, Int -> NumericDate -> ShowS
[NumericDate] -> ShowS
NumericDate -> String
(Int -> NumericDate -> ShowS)
-> (NumericDate -> String)
-> ([NumericDate] -> ShowS)
-> Show NumericDate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NumericDate -> ShowS
showsPrec :: Int -> NumericDate -> ShowS
$cshow :: NumericDate -> String
show :: NumericDate -> String
$cshowList :: [NumericDate] -> ShowS
showList :: [NumericDate] -> ShowS
Show)
makePrisms ''NumericDate

instance FromJSON NumericDate where
  parseJSON :: Value -> Parser NumericDate
parseJSON = String
-> (Scientific -> Parser NumericDate)
-> Value
-> Parser NumericDate
forall a. String -> (Scientific -> Parser a) -> Value -> Parser a
withScientific String
"NumericDate" ((Scientific -> Parser NumericDate) -> Value -> Parser NumericDate)
-> (Scientific -> Parser NumericDate)
-> Value
-> Parser NumericDate
forall a b. (a -> b) -> a -> b
$
    NumericDate -> Parser NumericDate
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NumericDate -> Parser NumericDate)
-> (Scientific -> NumericDate) -> Scientific -> Parser NumericDate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> NumericDate
NumericDate (UTCTime -> NumericDate)
-> (Scientific -> UTCTime) -> Scientific -> NumericDate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> UTCTime
posixSecondsToUTCTime (NominalDiffTime -> UTCTime)
-> (Scientific -> NominalDiffTime) -> Scientific -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> NominalDiffTime
forall a. Fractional a => Rational -> a
fromRational (Rational -> NominalDiffTime)
-> (Scientific -> Rational) -> Scientific -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Rational
forall a. Real a => a -> Rational
toRational

instance ToJSON NumericDate where
  toJSON :: NumericDate -> Value
toJSON (NumericDate UTCTime
t)
    = Scientific -> Value
Number (Scientific -> Value) -> Scientific -> Value
forall a b. (a -> b) -> a -> b
$ Rational -> Scientific
forall a. Fractional a => Rational -> a
fromRational (Rational -> Scientific) -> Rational -> Scientific
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational (NominalDiffTime -> Rational) -> NominalDiffTime -> Rational
forall a b. (a -> b) -> a -> b
$ UTCTime -> NominalDiffTime
utcTimeToPOSIXSeconds UTCTime
t


-- | Audience data.  In the general case, the /aud/ value is an
-- array of case-sensitive strings, each containing a 'StringOrURI'
-- value.  In the special case when the JWT has one audience, the
-- /aud/ value MAY be a single case-sensitive string containing a
-- 'StringOrURI' value.
--
-- The 'ToJSON' instance formats an 'Audience' with one value as a
-- string (some non-compliant implementations require this.)
--
newtype Audience = Audience [StringOrURI] deriving (Audience -> Audience -> Bool
(Audience -> Audience -> Bool)
-> (Audience -> Audience -> Bool) -> Eq Audience
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Audience -> Audience -> Bool
== :: Audience -> Audience -> Bool
$c/= :: Audience -> Audience -> Bool
/= :: Audience -> Audience -> Bool
Eq, Int -> Audience -> ShowS
[Audience] -> ShowS
Audience -> String
(Int -> Audience -> ShowS)
-> (Audience -> String) -> ([Audience] -> ShowS) -> Show Audience
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Audience -> ShowS
showsPrec :: Int -> Audience -> ShowS
$cshow :: Audience -> String
show :: Audience -> String
$cshowList :: [Audience] -> ShowS
showList :: [Audience] -> ShowS
Show)
makePrisms ''Audience

instance FromJSON Audience where
  parseJSON :: Value -> Parser Audience
parseJSON Value
v = [StringOrURI] -> Audience
Audience ([StringOrURI] -> Audience)
-> Parser [StringOrURI] -> Parser Audience
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Parser [StringOrURI]
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v Parser [StringOrURI]
-> Parser [StringOrURI] -> Parser [StringOrURI]
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (StringOrURI -> [StringOrURI])
-> Parser StringOrURI -> Parser [StringOrURI]
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (StringOrURI -> [StringOrURI] -> [StringOrURI]
forall a. a -> [a] -> [a]
:[]) (Value -> Parser StringOrURI
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v))

instance ToJSON Audience where
  toJSON :: Audience -> Value
toJSON (Audience [StringOrURI
aud]) = StringOrURI -> Value
forall a. ToJSON a => a -> Value
toJSON StringOrURI
aud
  toJSON (Audience [StringOrURI]
auds) = [StringOrURI] -> Value
forall a. ToJSON a => a -> Value
toJSON [StringOrURI]
auds


-- | The JWT Claims Set represents a JSON object whose members are
-- the registered claims defined by RFC 7519.  To construct a
-- @ClaimsSet@ use 'emptyClaimsSet' then use the lenses defined in
-- 'HasClaimsSet' to set relevant claims.
--
-- For applications that use additional claims beyond those defined
-- by RFC 7519, define a [subtype](#g:subtypes) and instance 'HasClaimsSet'.
--
data ClaimsSet = ClaimsSet
  { ClaimsSet -> Maybe StringOrURI
_claimIss :: Maybe StringOrURI
  , ClaimsSet -> Maybe StringOrURI
_claimSub :: Maybe StringOrURI
  , ClaimsSet -> Maybe Audience
_claimAud :: Maybe Audience
  , ClaimsSet -> Maybe NumericDate
_claimExp :: Maybe NumericDate
  , ClaimsSet -> Maybe NumericDate
_claimNbf :: Maybe NumericDate
  , ClaimsSet -> Maybe NumericDate
_claimIat :: Maybe NumericDate
  , ClaimsSet -> Maybe Text
_claimJti :: Maybe T.Text
  , ClaimsSet -> Map Text Value
_unregisteredClaims :: M.Map T.Text Value
  }
  deriving (ClaimsSet -> ClaimsSet -> Bool
(ClaimsSet -> ClaimsSet -> Bool)
-> (ClaimsSet -> ClaimsSet -> Bool) -> Eq ClaimsSet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClaimsSet -> ClaimsSet -> Bool
== :: ClaimsSet -> ClaimsSet -> Bool
$c/= :: ClaimsSet -> ClaimsSet -> Bool
/= :: ClaimsSet -> ClaimsSet -> Bool
Eq, Int -> ClaimsSet -> ShowS
[ClaimsSet] -> ShowS
ClaimsSet -> String
(Int -> ClaimsSet -> ShowS)
-> (ClaimsSet -> String)
-> ([ClaimsSet] -> ShowS)
-> Show ClaimsSet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClaimsSet -> ShowS
showsPrec :: Int -> ClaimsSet -> ShowS
$cshow :: ClaimsSet -> String
show :: ClaimsSet -> String
$cshowList :: [ClaimsSet] -> ShowS
showList :: [ClaimsSet] -> ShowS
Show)

class HasClaimsSet a where
  claimsSet :: Lens' a ClaimsSet

  -- | The issuer claim identifies the principal that issued the
  -- JWT.  The processing of this claim is generally application
  -- specific.
  claimIss :: Lens' a (Maybe StringOrURI)
  {-# INLINE claimIss #-}

  -- | The subject claim identifies the principal that is the
  -- subject of the JWT.  The Claims in a JWT are normally
  -- statements about the subject.  The subject value MAY be scoped
  -- to be locally unique in the context of the issuer or MAY be
  -- globally unique.  The processing of this claim is generally
  -- application specific.
  claimSub :: Lens' a (Maybe StringOrURI)
  {-# INLINE claimSub #-}

  -- | The audience claim identifies the recipients that the JWT is
  -- intended for.  Each principal intended to process the JWT MUST
  -- identify itself with a value in the audience claim.  If the
  -- principal processing the claim does not identify itself with a
  -- value in the /aud/ claim when this claim is present, then the
  -- JWT MUST be rejected.
  claimAud :: Lens' a (Maybe Audience)
  {-# INLINE claimAud #-}

  -- | The expiration time claim identifies the expiration time on
  -- or after which the JWT MUST NOT be accepted for processing.
  -- The processing of /exp/ claim requires that the current
  -- date\/time MUST be before expiration date\/time listed in the
  -- /exp/ claim.  Implementers MAY provide for some small leeway,
  -- usually no more than a few minutes, to account for clock skew.
  claimExp :: Lens' a (Maybe NumericDate)
  {-# INLINE claimExp #-}

  -- | The not before claim identifies the time before which the JWT
  -- MUST NOT be accepted for processing.  The processing of the
  -- /nbf/ claim requires that the current date\/time MUST be after
  -- or equal to the not-before date\/time listed in the /nbf/
  -- claim.  Implementers MAY provide for some small leeway, usually
  -- no more than a few minutes, to account for clock skew.
  claimNbf :: Lens' a (Maybe NumericDate)
  {-# INLINE claimNbf #-}

  -- | The issued at claim identifies the time at which the JWT was
  -- issued.  This claim can be used to determine the age of the
  -- JWT.
  claimIat :: Lens' a (Maybe NumericDate)
  {-# INLINE claimIat #-}

  -- | The JWT ID claim provides a unique identifier for the JWT.
  -- The identifier value MUST be assigned in a manner that ensures
  -- that there is a negligible probability that the same value will
  -- be accidentally assigned to a different data object.  The /jti/
  -- claim can be used to prevent the JWT from being replayed.  The
  -- /jti/ value is a case-sensitive string.
  claimJti :: Lens' a (Maybe T.Text)
  {-# INLINE claimJti #-}

  claimAud = (ClaimsSet -> f ClaimsSet) -> a -> f a
forall a. HasClaimsSet a => Lens' a ClaimsSet
Lens' a ClaimsSet
claimsSet ((ClaimsSet -> f ClaimsSet) -> a -> f a)
-> ((Maybe Audience -> f (Maybe Audience))
    -> ClaimsSet -> f ClaimsSet)
-> (Maybe Audience -> f (Maybe Audience))
-> a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Audience -> f (Maybe Audience)) -> ClaimsSet -> f ClaimsSet
forall a. HasClaimsSet a => Lens' a (Maybe Audience)
Lens' ClaimsSet (Maybe Audience)
claimAud
  claimExp = (ClaimsSet -> f ClaimsSet) -> a -> f a
forall a. HasClaimsSet a => Lens' a ClaimsSet
Lens' a ClaimsSet
claimsSet ((ClaimsSet -> f ClaimsSet) -> a -> f a)
-> ((Maybe NumericDate -> f (Maybe NumericDate))
    -> ClaimsSet -> f ClaimsSet)
-> (Maybe NumericDate -> f (Maybe NumericDate))
-> a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe NumericDate -> f (Maybe NumericDate))
-> ClaimsSet -> f ClaimsSet
forall a. HasClaimsSet a => Lens' a (Maybe NumericDate)
Lens' ClaimsSet (Maybe NumericDate)
claimExp
  claimIat = (ClaimsSet -> f ClaimsSet) -> a -> f a
forall a. HasClaimsSet a => Lens' a ClaimsSet
Lens' a ClaimsSet
claimsSet ((ClaimsSet -> f ClaimsSet) -> a -> f a)
-> ((Maybe NumericDate -> f (Maybe NumericDate))
    -> ClaimsSet -> f ClaimsSet)
-> (Maybe NumericDate -> f (Maybe NumericDate))
-> a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe NumericDate -> f (Maybe NumericDate))
-> ClaimsSet -> f ClaimsSet
forall a. HasClaimsSet a => Lens' a (Maybe NumericDate)
Lens' ClaimsSet (Maybe NumericDate)
claimIat
  claimIss = (ClaimsSet -> f ClaimsSet) -> a -> f a
forall a. HasClaimsSet a => Lens' a ClaimsSet
Lens' a ClaimsSet
claimsSet ((ClaimsSet -> f ClaimsSet) -> a -> f a)
-> ((Maybe StringOrURI -> f (Maybe StringOrURI))
    -> ClaimsSet -> f ClaimsSet)
-> (Maybe StringOrURI -> f (Maybe StringOrURI))
-> a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe StringOrURI -> f (Maybe StringOrURI))
-> ClaimsSet -> f ClaimsSet
forall a. HasClaimsSet a => Lens' a (Maybe StringOrURI)
Lens' ClaimsSet (Maybe StringOrURI)
claimIss
  claimJti = (ClaimsSet -> f ClaimsSet) -> a -> f a
forall a. HasClaimsSet a => Lens' a ClaimsSet
Lens' a ClaimsSet
claimsSet ((ClaimsSet -> f ClaimsSet) -> a -> f a)
-> ((Maybe Text -> f (Maybe Text)) -> ClaimsSet -> f ClaimsSet)
-> (Maybe Text -> f (Maybe Text))
-> a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Text -> f (Maybe Text)) -> ClaimsSet -> f ClaimsSet
forall a. HasClaimsSet a => Lens' a (Maybe Text)
Lens' ClaimsSet (Maybe Text)
claimJti
  claimNbf = (ClaimsSet -> f ClaimsSet) -> a -> f a
forall a. HasClaimsSet a => Lens' a ClaimsSet
Lens' a ClaimsSet
claimsSet ((ClaimsSet -> f ClaimsSet) -> a -> f a)
-> ((Maybe NumericDate -> f (Maybe NumericDate))
    -> ClaimsSet -> f ClaimsSet)
-> (Maybe NumericDate -> f (Maybe NumericDate))
-> a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe NumericDate -> f (Maybe NumericDate))
-> ClaimsSet -> f ClaimsSet
forall a. HasClaimsSet a => Lens' a (Maybe NumericDate)
Lens' ClaimsSet (Maybe NumericDate)
claimNbf
  claimSub = (ClaimsSet -> f ClaimsSet) -> a -> f a
forall a. HasClaimsSet a => Lens' a ClaimsSet
Lens' a ClaimsSet
claimsSet ((ClaimsSet -> f ClaimsSet) -> a -> f a)
-> ((Maybe StringOrURI -> f (Maybe StringOrURI))
    -> ClaimsSet -> f ClaimsSet)
-> (Maybe StringOrURI -> f (Maybe StringOrURI))
-> a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe StringOrURI -> f (Maybe StringOrURI))
-> ClaimsSet -> f ClaimsSet
forall a. HasClaimsSet a => Lens' a (Maybe StringOrURI)
Lens' ClaimsSet (Maybe StringOrURI)
claimSub

instance HasClaimsSet ClaimsSet where
  claimsSet :: Lens' ClaimsSet ClaimsSet
claimsSet = (ClaimsSet -> f ClaimsSet) -> ClaimsSet -> f ClaimsSet
forall a. a -> a
id

  claimIss :: Lens' ClaimsSet (Maybe StringOrURI)
claimIss Maybe StringOrURI -> f (Maybe StringOrURI)
f h :: ClaimsSet
h@ClaimsSet{ _claimIss :: ClaimsSet -> Maybe StringOrURI
_claimIss = Maybe StringOrURI
a} = (Maybe StringOrURI -> ClaimsSet)
-> f (Maybe StringOrURI) -> f ClaimsSet
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe StringOrURI
a' -> ClaimsSet
h { _claimIss = a' }) (Maybe StringOrURI -> f (Maybe StringOrURI)
f Maybe StringOrURI
a)
  {-# INLINE claimIss #-}

  claimSub :: Lens' ClaimsSet (Maybe StringOrURI)
claimSub Maybe StringOrURI -> f (Maybe StringOrURI)
f h :: ClaimsSet
h@ClaimsSet{ _claimSub :: ClaimsSet -> Maybe StringOrURI
_claimSub = Maybe StringOrURI
a} = (Maybe StringOrURI -> ClaimsSet)
-> f (Maybe StringOrURI) -> f ClaimsSet
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe StringOrURI
a' -> ClaimsSet
h { _claimSub = a' }) (Maybe StringOrURI -> f (Maybe StringOrURI)
f Maybe StringOrURI
a)
  {-# INLINE claimSub #-}

  claimAud :: Lens' ClaimsSet (Maybe Audience)
claimAud Maybe Audience -> f (Maybe Audience)
f h :: ClaimsSet
h@ClaimsSet{ _claimAud :: ClaimsSet -> Maybe Audience
_claimAud = Maybe Audience
a} = (Maybe Audience -> ClaimsSet) -> f (Maybe Audience) -> f ClaimsSet
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe Audience
a' -> ClaimsSet
h { _claimAud = a' }) (Maybe Audience -> f (Maybe Audience)
f Maybe Audience
a)
  {-# INLINE claimAud #-}

  claimExp :: Lens' ClaimsSet (Maybe NumericDate)
claimExp Maybe NumericDate -> f (Maybe NumericDate)
f h :: ClaimsSet
h@ClaimsSet{ _claimExp :: ClaimsSet -> Maybe NumericDate
_claimExp = Maybe NumericDate
a} = (Maybe NumericDate -> ClaimsSet)
-> f (Maybe NumericDate) -> f ClaimsSet
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe NumericDate
a' -> ClaimsSet
h { _claimExp = a' }) (Maybe NumericDate -> f (Maybe NumericDate)
f Maybe NumericDate
a)
  {-# INLINE claimExp #-}

  claimNbf :: Lens' ClaimsSet (Maybe NumericDate)
claimNbf Maybe NumericDate -> f (Maybe NumericDate)
f h :: ClaimsSet
h@ClaimsSet{ _claimNbf :: ClaimsSet -> Maybe NumericDate
_claimNbf = Maybe NumericDate
a} = (Maybe NumericDate -> ClaimsSet)
-> f (Maybe NumericDate) -> f ClaimsSet
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe NumericDate
a' -> ClaimsSet
h { _claimNbf = a' }) (Maybe NumericDate -> f (Maybe NumericDate)
f Maybe NumericDate
a)
  {-# INLINE claimNbf #-}

  claimIat :: Lens' ClaimsSet (Maybe NumericDate)
claimIat Maybe NumericDate -> f (Maybe NumericDate)
f h :: ClaimsSet
h@ClaimsSet{ _claimIat :: ClaimsSet -> Maybe NumericDate
_claimIat = Maybe NumericDate
a} = (Maybe NumericDate -> ClaimsSet)
-> f (Maybe NumericDate) -> f ClaimsSet
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe NumericDate
a' -> ClaimsSet
h { _claimIat = a' }) (Maybe NumericDate -> f (Maybe NumericDate)
f Maybe NumericDate
a)
  {-# INLINE claimIat #-}

  claimJti :: Lens' ClaimsSet (Maybe Text)
claimJti Maybe Text -> f (Maybe Text)
f h :: ClaimsSet
h@ClaimsSet{ _claimJti :: ClaimsSet -> Maybe Text
_claimJti = Maybe Text
a} = (Maybe Text -> ClaimsSet) -> f (Maybe Text) -> f ClaimsSet
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe Text
a' -> ClaimsSet
h { _claimJti = a' }) (Maybe Text -> f (Maybe Text)
f Maybe Text
a)
  {-# INLINE claimJti #-}

-- | Claim Names can be defined at will by those using JWTs.
-- Use this lens to access a map non-RFC 7519 claims in the
-- Claims Set object.
unregisteredClaims :: Lens' ClaimsSet (M.Map T.Text Value)
unregisteredClaims :: Lens' ClaimsSet (Map Text Value)
unregisteredClaims Map Text Value -> f (Map Text Value)
f h :: ClaimsSet
h@ClaimsSet{ _unregisteredClaims :: ClaimsSet -> Map Text Value
_unregisteredClaims = Map Text Value
a} =
  (Map Text Value -> ClaimsSet) -> f (Map Text Value) -> f ClaimsSet
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Map Text Value
a' -> ClaimsSet
h { _unregisteredClaims = a' }) (Map Text Value -> f (Map Text Value)
f Map Text Value
a)
{-# INLINE unregisteredClaims #-}
{-# DEPRECATED unregisteredClaims "use a [subtype](#g:subtypes) to define additional claims" #-}

-- | Return an empty claims set.
--
emptyClaimsSet :: ClaimsSet
emptyClaimsSet :: ClaimsSet
emptyClaimsSet = Maybe StringOrURI
-> Maybe StringOrURI
-> Maybe Audience
-> Maybe NumericDate
-> Maybe NumericDate
-> Maybe NumericDate
-> Maybe Text
-> Map Text Value
-> ClaimsSet
ClaimsSet Maybe StringOrURI
forall a. Maybe a
n Maybe StringOrURI
forall a. Maybe a
n Maybe Audience
forall a. Maybe a
n Maybe NumericDate
forall a. Maybe a
n Maybe NumericDate
forall a. Maybe a
n Maybe NumericDate
forall a. Maybe a
n Maybe Text
forall a. Maybe a
n Map Text Value
forall k a. Map k a
M.empty where n :: Maybe a
n = Maybe a
forall a. Maybe a
Nothing

-- | Add a __non-RFC 7519__ claim.  Use the lenses from the
-- 'HasClaimsSet' class for setting registered claims.
--
addClaim :: T.Text -> Value -> ClaimsSet -> ClaimsSet
addClaim :: Text -> Value -> ClaimsSet -> ClaimsSet
addClaim Text
k Value
v = ASetter ClaimsSet ClaimsSet (Map Text Value) (Map Text Value)
-> (Map Text Value -> Map Text Value) -> ClaimsSet -> ClaimsSet
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter ClaimsSet ClaimsSet (Map Text Value) (Map Text Value)
Lens' ClaimsSet (Map Text Value)
unregisteredClaims (Text -> Value -> Map Text Value -> Map Text Value
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
k Value
v)
{-# DEPRECATED addClaim "use a [subtype](#g:subtypes) to define additional claims" #-}

registeredClaims :: S.Set T.Text
registeredClaims :: Set Text
registeredClaims = [Text] -> Set Text
forall a. [a] -> Set a
S.fromDistinctAscList
  [ Text
"aud"
  , Text
"exp"
  , Text
"iat"
  , Text
"iss"
  , Text
"jti"
  , Text
"nbf"
  , Text
"sub"
  ]

filterUnregistered :: M.Map T.Text Value -> M.Map T.Text Value
filterUnregistered :: Map Text Value -> Map Text Value
filterUnregistered Map Text Value
m =
#if MIN_VERSION_containers(0,5,8)
  Map Text Value
m Map Text Value -> Set Text -> Map Text Value
forall k a. Ord k => Map k a -> Set k -> Map k a
`M.withoutKeys` Set Text
registeredClaims
#else
  m `M.difference` M.fromSet (const ()) registeredClaims
#endif

toKeyMap :: M.Map T.Text Value -> KeyMap.KeyMap Value
toKeyMap :: Map Text Value -> KeyMap Value
toKeyMap = Map Key Value -> KeyMap Value
forall v. Map Key v -> KeyMap v
KeyMap.fromMap (Map Key Value -> KeyMap Value)
-> (Map Text Value -> Map Key Value)
-> Map Text Value
-> KeyMap Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Key) -> Map Text Value -> Map Key Value
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeysMonotonic Text -> Key
Key.fromText

fromKeyMap :: KeyMap.KeyMap Value -> M.Map T.Text Value
fromKeyMap :: KeyMap Value -> Map Text Value
fromKeyMap = (Key -> Text) -> Map Key Value -> Map Text Value
forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeysMonotonic Key -> Text
Key.toText (Map Key Value -> Map Text Value)
-> (KeyMap Value -> Map Key Value)
-> KeyMap Value
-> Map Text Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyMap Value -> Map Key Value
forall v. KeyMap v -> Map Key v
KeyMap.toMap

instance FromJSON ClaimsSet where
  parseJSON :: Value -> Parser ClaimsSet
parseJSON = String
-> (KeyMap Value -> Parser ClaimsSet) -> Value -> Parser ClaimsSet
forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
withObject String
"JWT Claims Set" (\KeyMap Value
o -> Maybe StringOrURI
-> Maybe StringOrURI
-> Maybe Audience
-> Maybe NumericDate
-> Maybe NumericDate
-> Maybe NumericDate
-> Maybe Text
-> Map Text Value
-> ClaimsSet
ClaimsSet
    (Maybe StringOrURI
 -> Maybe StringOrURI
 -> Maybe Audience
 -> Maybe NumericDate
 -> Maybe NumericDate
 -> Maybe NumericDate
 -> Maybe Text
 -> Map Text Value
 -> ClaimsSet)
-> Parser (Maybe StringOrURI)
-> Parser
     (Maybe StringOrURI
      -> Maybe Audience
      -> Maybe NumericDate
      -> Maybe NumericDate
      -> Maybe NumericDate
      -> Maybe Text
      -> Map Text Value
      -> ClaimsSet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe StringOrURI)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"iss"
    Parser
  (Maybe StringOrURI
   -> Maybe Audience
   -> Maybe NumericDate
   -> Maybe NumericDate
   -> Maybe NumericDate
   -> Maybe Text
   -> Map Text Value
   -> ClaimsSet)
-> Parser (Maybe StringOrURI)
-> Parser
     (Maybe Audience
      -> Maybe NumericDate
      -> Maybe NumericDate
      -> Maybe NumericDate
      -> Maybe Text
      -> Map Text Value
      -> ClaimsSet)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe StringOrURI)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"sub"
    Parser
  (Maybe Audience
   -> Maybe NumericDate
   -> Maybe NumericDate
   -> Maybe NumericDate
   -> Maybe Text
   -> Map Text Value
   -> ClaimsSet)
-> Parser (Maybe Audience)
-> Parser
     (Maybe NumericDate
      -> Maybe NumericDate
      -> Maybe NumericDate
      -> Maybe Text
      -> Map Text Value
      -> ClaimsSet)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe Audience)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"aud"
    Parser
  (Maybe NumericDate
   -> Maybe NumericDate
   -> Maybe NumericDate
   -> Maybe Text
   -> Map Text Value
   -> ClaimsSet)
-> Parser (Maybe NumericDate)
-> Parser
     (Maybe NumericDate
      -> Maybe NumericDate -> Maybe Text -> Map Text Value -> ClaimsSet)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe NumericDate)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"exp"
    Parser
  (Maybe NumericDate
   -> Maybe NumericDate -> Maybe Text -> Map Text Value -> ClaimsSet)
-> Parser (Maybe NumericDate)
-> Parser
     (Maybe NumericDate -> Maybe Text -> Map Text Value -> ClaimsSet)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe NumericDate)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"nbf"
    Parser
  (Maybe NumericDate -> Maybe Text -> Map Text Value -> ClaimsSet)
-> Parser (Maybe NumericDate)
-> Parser (Maybe Text -> Map Text Value -> ClaimsSet)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe NumericDate)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"iat"
    Parser (Maybe Text -> Map Text Value -> ClaimsSet)
-> Parser (Maybe Text) -> Parser (Map Text Value -> ClaimsSet)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyMap Value
o KeyMap Value -> Key -> Parser (Maybe Text)
forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"jti"
    Parser (Map Text Value -> ClaimsSet)
-> Parser (Map Text Value) -> Parser ClaimsSet
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Text Value -> Parser (Map Text Value)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text Value -> Map Text Value
filterUnregistered (Map Text Value -> Map Text Value)
-> (KeyMap Value -> Map Text Value)
-> KeyMap Value
-> Map Text Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyMap Value -> Map Text Value
fromKeyMap (KeyMap Value -> Map Text Value) -> KeyMap Value -> Map Text Value
forall a b. (a -> b) -> a -> b
$ KeyMap Value
o)
    )

instance ToJSON ClaimsSet where
  toJSON :: ClaimsSet -> Value
toJSON (ClaimsSet Maybe StringOrURI
iss Maybe StringOrURI
sub Maybe Audience
aud Maybe NumericDate
exp' Maybe NumericDate
nbf Maybe NumericDate
iat Maybe Text
jti Map Text Value
o) = KeyMap Value -> Value
Object (KeyMap Value -> Value) -> KeyMap Value -> Value
forall a b. (a -> b) -> a -> b
$
    ( Map Key Value -> KeyMap Value
forall v. Map Key v -> KeyMap v
KeyMap.fromMap (Map Key Value -> KeyMap Value)
-> ([(Key, Value)] -> Map Key Value)
-> [(Key, Value)]
-> KeyMap Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Value)] -> Map Key Value
forall k a. [(k, a)] -> Map k a
M.fromDistinctAscList ([(Key, Value)] -> KeyMap Value) -> [(Key, Value)] -> KeyMap Value
forall a b. (a -> b) -> a -> b
$ [Maybe (Key, Value)] -> [(Key, Value)]
forall a. [Maybe a] -> [a]
catMaybes
      [ (Audience -> (Key, Value)) -> Maybe Audience -> Maybe (Key, Value)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"aud" Key -> Audience -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> (Key, Value)
.=) Maybe Audience
aud
      , (NumericDate -> (Key, Value))
-> Maybe NumericDate -> Maybe (Key, Value)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"exp" Key -> NumericDate -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> (Key, Value)
.=) Maybe NumericDate
exp'
      , (NumericDate -> (Key, Value))
-> Maybe NumericDate -> Maybe (Key, Value)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"iat" Key -> NumericDate -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> (Key, Value)
.=) Maybe NumericDate
iat
      , (StringOrURI -> (Key, Value))
-> Maybe StringOrURI -> Maybe (Key, Value)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"iss" Key -> StringOrURI -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> (Key, Value)
.=) Maybe StringOrURI
iss
      , (Text -> (Key, Value)) -> Maybe Text -> Maybe (Key, Value)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"jti" Key -> Text -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> (Key, Value)
.=) Maybe Text
jti
      , (NumericDate -> (Key, Value))
-> Maybe NumericDate -> Maybe (Key, Value)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"nbf" Key -> NumericDate -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> (Key, Value)
.=) Maybe NumericDate
nbf
      , (StringOrURI -> (Key, Value))
-> Maybe StringOrURI -> Maybe (Key, Value)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"sub" Key -> StringOrURI -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
forall v. ToJSON v => Key -> v -> (Key, Value)
.=) Maybe StringOrURI
sub
      ]
    )
    KeyMap Value -> KeyMap Value -> KeyMap Value
forall a. Semigroup a => a -> a -> a
<> Map Text Value -> KeyMap Value
toKeyMap (Map Text Value -> Map Text Value
filterUnregistered Map Text Value
o)


data JWTValidationSettings = JWTValidationSettings
  { JWTValidationSettings -> ValidationSettings
_jwtValidationSettingsValidationSettings :: ValidationSettings
  , JWTValidationSettings -> NominalDiffTime
_jwtValidationSettingsAllowedSkew :: NominalDiffTime
  , JWTValidationSettings -> Bool
_jwtValidationSettingsCheckIssuedAt :: Bool
  -- ^ The allowed skew is interpreted in absolute terms;
  --   a nonzero value always expands the validity period.
  , JWTValidationSettings -> StringOrURI -> Bool
_jwtValidationSettingsAudiencePredicate :: StringOrURI -> Bool
  , JWTValidationSettings -> StringOrURI -> Bool
_jwtValidationSettingsIssuerPredicate :: StringOrURI -> Bool
  }
makeClassy ''JWTValidationSettings

instance {-# OVERLAPPABLE #-} HasJWTValidationSettings a => HasValidationSettings a where
  validationSettings :: Lens' a ValidationSettings
validationSettings = (ValidationSettings -> f ValidationSettings) -> a -> f a
forall c. HasJWTValidationSettings c => Lens' c ValidationSettings
Lens' a ValidationSettings
jwtValidationSettingsValidationSettings

-- | Maximum allowed skew when validating the /nbf/, /exp/ and /iat/ claims.
class HasAllowedSkew s where
  allowedSkew :: Lens' s NominalDiffTime

-- | Predicate for checking values in the /aud/ claim.
class HasAudiencePredicate s where
  audiencePredicate :: Lens' s (StringOrURI -> Bool)

-- | Predicate for checking the /iss/ claim.
class HasIssuerPredicate s where
  issuerPredicate :: Lens' s (StringOrURI -> Bool)

-- | Whether to check that the /iat/ claim is not in the future.
class HasCheckIssuedAt s where
  checkIssuedAt :: Lens' s Bool

instance HasJWTValidationSettings a => HasAllowedSkew a where
  allowedSkew :: Lens' a NominalDiffTime
allowedSkew = (NominalDiffTime -> f NominalDiffTime) -> a -> f a
forall c. HasJWTValidationSettings c => Lens' c NominalDiffTime
Lens' a NominalDiffTime
jwtValidationSettingsAllowedSkew
instance HasJWTValidationSettings a => HasAudiencePredicate a where
  audiencePredicate :: Lens' a (StringOrURI -> Bool)
audiencePredicate = ((StringOrURI -> Bool) -> f (StringOrURI -> Bool)) -> a -> f a
forall c.
HasJWTValidationSettings c =>
Lens' c (StringOrURI -> Bool)
Lens' a (StringOrURI -> Bool)
jwtValidationSettingsAudiencePredicate
instance HasJWTValidationSettings a => HasIssuerPredicate a where
  issuerPredicate :: Lens' a (StringOrURI -> Bool)
issuerPredicate = ((StringOrURI -> Bool) -> f (StringOrURI -> Bool)) -> a -> f a
forall c.
HasJWTValidationSettings c =>
Lens' c (StringOrURI -> Bool)
Lens' a (StringOrURI -> Bool)
jwtValidationSettingsIssuerPredicate
instance HasJWTValidationSettings a => HasCheckIssuedAt a where
  checkIssuedAt :: Lens' a Bool
checkIssuedAt = (Bool -> f Bool) -> a -> f a
forall c. HasJWTValidationSettings c => Lens' c Bool
Lens' a Bool
jwtValidationSettingsCheckIssuedAt

-- | Acquire the default validation settings.
--
-- <https://tools.ietf.org/html/rfc7519#section-4.1.3 RFC 7519 §4.1.3.>
-- states that applications MUST identify itself with a value in the
-- audience claim, therefore a predicate must be supplied.
--
-- The other defaults are:
--
-- - 'defaultValidationSettings' for JWS verification
-- - Zero clock skew tolerance when validating /nbf/, /exp/ and /iat/ claims
-- - /iat/ claim is checked
-- - /issuer/ claim is not checked
--
defaultJWTValidationSettings :: (StringOrURI -> Bool) -> JWTValidationSettings
defaultJWTValidationSettings :: (StringOrURI -> Bool) -> JWTValidationSettings
defaultJWTValidationSettings StringOrURI -> Bool
p = ValidationSettings
-> NominalDiffTime
-> Bool
-> (StringOrURI -> Bool)
-> (StringOrURI -> Bool)
-> JWTValidationSettings
JWTValidationSettings
  ValidationSettings
defaultValidationSettings
  NominalDiffTime
0
  Bool
True
  StringOrURI -> Bool
p
  (Bool -> StringOrURI -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | Validate the claims made by a ClaimsSet.
--
-- __You should never need to use this function directly.__
-- These checks are always performed by 'verifyClaims' and 'verifyJWT'.
-- The function is exported mainly for testing purposes.
--
validateClaimsSet
  ::
    ( MonadTime m, HasAllowedSkew a, HasAudiencePredicate a
    , HasIssuerPredicate a
    , HasCheckIssuedAt a
    , AsJWTError e, MonadError e m
    )
  => a
  -> ClaimsSet
  -> m ClaimsSet
validateClaimsSet :: forall (m :: * -> *) a e.
(MonadTime m, HasAllowedSkew a, HasAudiencePredicate a,
 HasIssuerPredicate a, HasCheckIssuedAt a, AsJWTError e,
 MonadError e m) =>
a -> ClaimsSet -> m ClaimsSet
validateClaimsSet a
conf ClaimsSet
claims =
  ClaimsSet
claims ClaimsSet -> m () -> m ClaimsSet
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ((a -> ClaimsSet -> m ()) -> m ())
-> [a -> ClaimsSet -> m ()] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (((ClaimsSet -> m ()) -> ClaimsSet -> m ()
forall a b. (a -> b) -> a -> b
$ ClaimsSet
claims) ((ClaimsSet -> m ()) -> m ())
-> ((a -> ClaimsSet -> m ()) -> ClaimsSet -> m ())
-> (a -> ClaimsSet -> m ())
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> ClaimsSet -> m ()) -> a -> ClaimsSet -> m ()
forall a b. (a -> b) -> a -> b
$ a
conf))
    [ a -> ClaimsSet -> m ()
forall (m :: * -> *) a e.
(MonadTime m, HasAllowedSkew a, AsJWTError e, MonadError e m) =>
a -> ClaimsSet -> m ()
validateExpClaim
    , a -> ClaimsSet -> m ()
forall (m :: * -> *) a e.
(MonadTime m, HasCheckIssuedAt a, HasAllowedSkew a, AsJWTError e,
 MonadError e m) =>
a -> ClaimsSet -> m ()
validateIatClaim
    , a -> ClaimsSet -> m ()
forall (m :: * -> *) a e.
(MonadTime m, HasAllowedSkew a, AsJWTError e, MonadError e m) =>
a -> ClaimsSet -> m ()
validateNbfClaim
    , a -> ClaimsSet -> m ()
forall s e (m :: * -> *).
(HasIssuerPredicate s, AsJWTError e, MonadError e m) =>
s -> ClaimsSet -> m ()
validateIssClaim
    , a -> ClaimsSet -> m ()
forall s e (m :: * -> *).
(HasAudiencePredicate s, AsJWTError e, MonadError e m) =>
s -> ClaimsSet -> m ()
validateAudClaim
    ]

validateExpClaim
  :: (MonadTime m, HasAllowedSkew a, AsJWTError e, MonadError e m)
  => a
  -> ClaimsSet
  -> m ()
validateExpClaim :: forall (m :: * -> *) a e.
(MonadTime m, HasAllowedSkew a, AsJWTError e, MonadError e m) =>
a -> ClaimsSet -> m ()
validateExpClaim a
conf =
  (NumericDate -> m ()) -> Maybe NumericDate -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\NumericDate
t -> do
    UTCTime
now <- m UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
currentTime
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a
abs (Getting NominalDiffTime a NominalDiffTime -> a -> NominalDiffTime
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting NominalDiffTime a NominalDiffTime
forall s. HasAllowedSkew s => Lens' s NominalDiffTime
Lens' a NominalDiffTime
allowedSkew a
conf)) (Getting UTCTime NumericDate UTCTime -> NumericDate -> UTCTime
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UTCTime NumericDate UTCTime
Iso' NumericDate UTCTime
_NumericDate NumericDate
t)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      AReview e () -> m ()
forall e (m :: * -> *) x. MonadError e m => AReview e () -> m x
throwing_ AReview e ()
forall r. AsJWTError r => Prism' r ()
Prism' e ()
_JWTExpired )
  (Maybe NumericDate -> m ())
-> (ClaimsSet -> Maybe NumericDate) -> ClaimsSet -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First NumericDate) ClaimsSet NumericDate
-> ClaimsSet -> Maybe NumericDate
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((Maybe NumericDate
 -> Const (First NumericDate) (Maybe NumericDate))
-> ClaimsSet -> Const (First NumericDate) ClaimsSet
forall a. HasClaimsSet a => Lens' a (Maybe NumericDate)
Lens' ClaimsSet (Maybe NumericDate)
claimExp ((Maybe NumericDate
  -> Const (First NumericDate) (Maybe NumericDate))
 -> ClaimsSet -> Const (First NumericDate) ClaimsSet)
-> ((NumericDate -> Const (First NumericDate) NumericDate)
    -> Maybe NumericDate
    -> Const (First NumericDate) (Maybe NumericDate))
-> Getting (First NumericDate) ClaimsSet NumericDate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NumericDate -> Const (First NumericDate) NumericDate)
-> Maybe NumericDate
-> Const (First NumericDate) (Maybe NumericDate)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just)

validateIatClaim
  :: (MonadTime m, HasCheckIssuedAt a, HasAllowedSkew a, AsJWTError e, MonadError e m)
  => a
  -> ClaimsSet
  -> m ()
validateIatClaim :: forall (m :: * -> *) a e.
(MonadTime m, HasCheckIssuedAt a, HasAllowedSkew a, AsJWTError e,
 MonadError e m) =>
a -> ClaimsSet -> m ()
validateIatClaim a
conf =
  (NumericDate -> m ()) -> Maybe NumericDate -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\NumericDate
t -> do
    UTCTime
now <- m UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
currentTime
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Getting Bool a Bool -> a -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool a Bool
forall s. HasCheckIssuedAt s => Lens' s Bool
Lens' a Bool
checkIssuedAt a
conf) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Getting UTCTime NumericDate UTCTime -> NumericDate -> UTCTime
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UTCTime NumericDate UTCTime
Iso' NumericDate UTCTime
_NumericDate NumericDate
t UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a
abs (Getting NominalDiffTime a NominalDiffTime -> a -> NominalDiffTime
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting NominalDiffTime a NominalDiffTime
forall s. HasAllowedSkew s => Lens' s NominalDiffTime
Lens' a NominalDiffTime
allowedSkew a
conf)) UTCTime
now) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        AReview e () -> m ()
forall e (m :: * -> *) x. MonadError e m => AReview e () -> m x
throwing_ AReview e ()
forall r. AsJWTError r => Prism' r ()
Prism' e ()
_JWTIssuedAtFuture )
    (Maybe NumericDate -> m ())
-> (ClaimsSet -> Maybe NumericDate) -> ClaimsSet -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First NumericDate) ClaimsSet NumericDate
-> ClaimsSet -> Maybe NumericDate
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((Maybe NumericDate
 -> Const (First NumericDate) (Maybe NumericDate))
-> ClaimsSet -> Const (First NumericDate) ClaimsSet
forall a. HasClaimsSet a => Lens' a (Maybe NumericDate)
Lens' ClaimsSet (Maybe NumericDate)
claimIat ((Maybe NumericDate
  -> Const (First NumericDate) (Maybe NumericDate))
 -> ClaimsSet -> Const (First NumericDate) ClaimsSet)
-> ((NumericDate -> Const (First NumericDate) NumericDate)
    -> Maybe NumericDate
    -> Const (First NumericDate) (Maybe NumericDate))
-> Getting (First NumericDate) ClaimsSet NumericDate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NumericDate -> Const (First NumericDate) NumericDate)
-> Maybe NumericDate
-> Const (First NumericDate) (Maybe NumericDate)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just)

validateNbfClaim
  :: (MonadTime m, HasAllowedSkew a, AsJWTError e, MonadError e m)
  => a
  -> ClaimsSet
  -> m ()
validateNbfClaim :: forall (m :: * -> *) a e.
(MonadTime m, HasAllowedSkew a, AsJWTError e, MonadError e m) =>
a -> ClaimsSet -> m ()
validateNbfClaim a
conf =
  (NumericDate -> m ()) -> Maybe NumericDate -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\NumericDate
t -> do
    UTCTime
now <- m UTCTime
forall (m :: * -> *). MonadTime m => m UTCTime
currentTime
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (UTCTime
now UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a
negate (NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a
abs (Getting NominalDiffTime a NominalDiffTime -> a -> NominalDiffTime
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting NominalDiffTime a NominalDiffTime
forall s. HasAllowedSkew s => Lens' s NominalDiffTime
Lens' a NominalDiffTime
allowedSkew a
conf))) (Getting UTCTime NumericDate UTCTime -> NumericDate -> UTCTime
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting UTCTime NumericDate UTCTime
Iso' NumericDate UTCTime
_NumericDate NumericDate
t)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      AReview e () -> m ()
forall e (m :: * -> *) x. MonadError e m => AReview e () -> m x
throwing_ AReview e ()
forall r. AsJWTError r => Prism' r ()
Prism' e ()
_JWTNotYetValid )
  (Maybe NumericDate -> m ())
-> (ClaimsSet -> Maybe NumericDate) -> ClaimsSet -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First NumericDate) ClaimsSet NumericDate
-> ClaimsSet -> Maybe NumericDate
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((Maybe NumericDate
 -> Const (First NumericDate) (Maybe NumericDate))
-> ClaimsSet -> Const (First NumericDate) ClaimsSet
forall a. HasClaimsSet a => Lens' a (Maybe NumericDate)
Lens' ClaimsSet (Maybe NumericDate)
claimNbf ((Maybe NumericDate
  -> Const (First NumericDate) (Maybe NumericDate))
 -> ClaimsSet -> Const (First NumericDate) ClaimsSet)
-> ((NumericDate -> Const (First NumericDate) NumericDate)
    -> Maybe NumericDate
    -> Const (First NumericDate) (Maybe NumericDate))
-> Getting (First NumericDate) ClaimsSet NumericDate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NumericDate -> Const (First NumericDate) NumericDate)
-> Maybe NumericDate
-> Const (First NumericDate) (Maybe NumericDate)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just)

validateAudClaim
  :: (HasAudiencePredicate s, AsJWTError e, MonadError e m)
  => s
  -> ClaimsSet
  -> m ()
validateAudClaim :: forall s e (m :: * -> *).
(HasAudiencePredicate s, AsJWTError e, MonadError e m) =>
s -> ClaimsSet -> m ()
validateAudClaim s
conf =
  ([StringOrURI] -> m ()) -> Maybe [StringOrURI] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
    (\[StringOrURI]
auds -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (Getting (StringOrURI -> Bool) s (StringOrURI -> Bool)
-> s -> StringOrURI -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (StringOrURI -> Bool) s (StringOrURI -> Bool)
forall s. HasAudiencePredicate s => Lens' s (StringOrURI -> Bool)
Lens' s (StringOrURI -> Bool)
audiencePredicate s
conf (StringOrURI -> Bool) -> [StringOrURI] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StringOrURI]
auds)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
        AReview e () -> m ()
forall e (m :: * -> *) x. MonadError e m => AReview e () -> m x
throwing_ AReview e ()
forall r. AsJWTError r => Prism' r ()
Prism' e ()
_JWTNotInAudience )
  (Maybe [StringOrURI] -> m ())
-> (ClaimsSet -> Maybe [StringOrURI]) -> ClaimsSet -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First [StringOrURI]) ClaimsSet [StringOrURI]
-> ClaimsSet -> Maybe [StringOrURI]
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((Maybe Audience -> Const (First [StringOrURI]) (Maybe Audience))
-> ClaimsSet -> Const (First [StringOrURI]) ClaimsSet
forall a. HasClaimsSet a => Lens' a (Maybe Audience)
Lens' ClaimsSet (Maybe Audience)
claimAud ((Maybe Audience -> Const (First [StringOrURI]) (Maybe Audience))
 -> ClaimsSet -> Const (First [StringOrURI]) ClaimsSet)
-> (([StringOrURI] -> Const (First [StringOrURI]) [StringOrURI])
    -> Maybe Audience -> Const (First [StringOrURI]) (Maybe Audience))
-> Getting (First [StringOrURI]) ClaimsSet [StringOrURI]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Audience -> Const (First [StringOrURI]) Audience)
-> Maybe Audience -> Const (First [StringOrURI]) (Maybe Audience)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((Audience -> Const (First [StringOrURI]) Audience)
 -> Maybe Audience -> Const (First [StringOrURI]) (Maybe Audience))
-> (([StringOrURI] -> Const (First [StringOrURI]) [StringOrURI])
    -> Audience -> Const (First [StringOrURI]) Audience)
-> ([StringOrURI] -> Const (First [StringOrURI]) [StringOrURI])
-> Maybe Audience
-> Const (First [StringOrURI]) (Maybe Audience)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([StringOrURI] -> Const (First [StringOrURI]) [StringOrURI])
-> Audience -> Const (First [StringOrURI]) Audience
Iso' Audience [StringOrURI]
_Audience)

validateIssClaim
  :: (HasIssuerPredicate s, AsJWTError e, MonadError e m)
  => s
  -> ClaimsSet
  -> m ()
validateIssClaim :: forall s e (m :: * -> *).
(HasIssuerPredicate s, AsJWTError e, MonadError e m) =>
s -> ClaimsSet -> m ()
validateIssClaim s
conf =
  (StringOrURI -> m ()) -> Maybe StringOrURI -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\StringOrURI
iss ->
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Getting (StringOrURI -> Bool) s (StringOrURI -> Bool)
-> s -> StringOrURI -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (StringOrURI -> Bool) s (StringOrURI -> Bool)
forall s. HasIssuerPredicate s => Lens' s (StringOrURI -> Bool)
Lens' s (StringOrURI -> Bool)
issuerPredicate s
conf StringOrURI
iss) (AReview e () -> m ()
forall e (m :: * -> *) x. MonadError e m => AReview e () -> m x
throwing_ AReview e ()
forall r. AsJWTError r => Prism' r ()
Prism' e ()
_JWTNotInIssuer) )
  (Maybe StringOrURI -> m ())
-> (ClaimsSet -> Maybe StringOrURI) -> ClaimsSet -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (First StringOrURI) ClaimsSet StringOrURI
-> ClaimsSet -> Maybe StringOrURI
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((Maybe StringOrURI
 -> Const (First StringOrURI) (Maybe StringOrURI))
-> ClaimsSet -> Const (First StringOrURI) ClaimsSet
forall a. HasClaimsSet a => Lens' a (Maybe StringOrURI)
Lens' ClaimsSet (Maybe StringOrURI)
claimIss ((Maybe StringOrURI
  -> Const (First StringOrURI) (Maybe StringOrURI))
 -> ClaimsSet -> Const (First StringOrURI) ClaimsSet)
-> ((StringOrURI -> Const (First StringOrURI) StringOrURI)
    -> Maybe StringOrURI
    -> Const (First StringOrURI) (Maybe StringOrURI))
-> Getting (First StringOrURI) ClaimsSet StringOrURI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StringOrURI -> Const (First StringOrURI) StringOrURI)
-> Maybe StringOrURI
-> Const (First StringOrURI) (Maybe StringOrURI)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just)

-- | A digitally signed or MACed JWT
--
type SignedJWT = CompactJWS JWSHeader


newtype WrappedUTCTime = WrappedUTCTime { WrappedUTCTime -> UTCTime
getUTCTime :: UTCTime }

#if MIN_VERSION_monad_time(0,4,0)
-- | @'monotonicTime' = pure 0@.  /jose/ doesn't use this so we fake it
#endif
instance Monad m => MonadTime (ReaderT WrappedUTCTime m) where
  currentTime :: ReaderT WrappedUTCTime m UTCTime
currentTime = (WrappedUTCTime -> UTCTime) -> ReaderT WrappedUTCTime m UTCTime
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WrappedUTCTime -> UTCTime
getUTCTime
#if MIN_VERSION_monad_time(0,4,0)
  monotonicTime :: ReaderT WrappedUTCTime m Double
monotonicTime = Double -> ReaderT WrappedUTCTime m Double
forall a. a -> ReaderT WrappedUTCTime m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
0
#endif


-- | Cryptographically verify a JWS JWT, then validate the
-- Claims Set, returning it if valid.  The claims are validated
-- at the current system time.
--
-- This is the only way to get at the claims of a JWS JWT,
-- enforcing that the claims are cryptographically and
-- semantically valid before the application can use them.
--
-- This function is abstracted over any payload type with 'HasClaimsSet' and
-- 'FromJSON' instances.  The 'verifyClaims' variant uses 'ClaimsSet' as the
-- payload type.
--
-- See also 'verifyClaimsAt' which allows you to explicitly specify
-- the time of validation (against which time-related claims will be
-- validated).
--
verifyJWT
  ::
    ( MonadTime m, HasAllowedSkew a, HasAudiencePredicate a
    , HasIssuerPredicate a
    , HasCheckIssuedAt a
    , HasValidationSettings a
    , AsError e, AsJWTError e, MonadError e m
    , VerificationKeyStore m (JWSHeader ()) payload k
    , HasClaimsSet payload, FromJSON payload
    )
  => a
  -> k
  -> SignedJWT
  -> m payload
verifyJWT :: forall (m :: * -> *) a e payload k.
(MonadTime m, HasAllowedSkew a, HasAudiencePredicate a,
 HasIssuerPredicate a, HasCheckIssuedAt a, HasValidationSettings a,
 AsError e, AsJWTError e, MonadError e m,
 VerificationKeyStore m (JWSHeader ()) payload k,
 HasClaimsSet payload, FromJSON payload) =>
a -> k -> SignedJWT -> m payload
verifyJWT a
conf k
k SignedJWT
jws =
  -- It is important, for security reasons, that the signature get
  -- verified before the claims.
  (ByteString -> m payload) -> a -> k -> SignedJWT -> m payload
forall a e (m :: * -> *) (h :: * -> *) p payload k s (t :: * -> *).
(HasAlgorithms a, HasValidationPolicy a, AsError e, MonadError e m,
 HasJWSHeader h, HasParams h,
 VerificationKeyStore m (h p) payload k, Cons s s Word8 Word8,
 AsEmpty s, Foldable t, ProtectionIndicator p) =>
(s -> m payload) -> a -> k -> JWS t p h -> m payload
verifyJWSWithPayload ByteString -> m payload
f a
conf k
k SignedJWT
jws m payload -> (payload -> m payload) -> m payload
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (ClaimsSet -> m ClaimsSet) -> payload -> m payload
forall a. HasClaimsSet a => Lens' a ClaimsSet
Lens' payload ClaimsSet
claimsSet (a -> ClaimsSet -> m ClaimsSet
forall (m :: * -> *) a e.
(MonadTime m, HasAllowedSkew a, HasAudiencePredicate a,
 HasIssuerPredicate a, HasCheckIssuedAt a, AsJWTError e,
 MonadError e m) =>
a -> ClaimsSet -> m ClaimsSet
validateClaimsSet a
conf)
  where
    f :: ByteString -> m payload
f = (String -> m payload)
-> (payload -> m payload) -> Either String payload -> m payload
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (AReview e String -> String -> m payload
forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing AReview e String
forall r. AsJWTError r => Prism' r String
Prism' e String
_JWTClaimsSetDecodeError) payload -> m payload
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String payload -> m payload)
-> (ByteString -> Either String payload) -> ByteString -> m payload
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String payload
forall a. FromJSON a => ByteString -> Either String a
eitherDecode

-- | Variant of 'verifyJWT' that uses 'ClaimsSet' as the payload type.
--
verifyClaims
  ::
    ( MonadTime m, HasAllowedSkew a, HasAudiencePredicate a
    , HasIssuerPredicate a
    , HasCheckIssuedAt a
    , HasValidationSettings a
    , AsError e, AsJWTError e, MonadError e m
    , VerificationKeyStore m (JWSHeader ()) ClaimsSet k
    )
  => a
  -> k
  -> SignedJWT
  -> m ClaimsSet
verifyClaims :: forall (m :: * -> *) a e k.
(MonadTime m, HasAllowedSkew a, HasAudiencePredicate a,
 HasIssuerPredicate a, HasCheckIssuedAt a, HasValidationSettings a,
 AsError e, AsJWTError e, MonadError e m,
 VerificationKeyStore m (JWSHeader ()) ClaimsSet k) =>
a -> k -> SignedJWT -> m ClaimsSet
verifyClaims = a -> k -> SignedJWT -> m ClaimsSet
forall (m :: * -> *) a e payload k.
(MonadTime m, HasAllowedSkew a, HasAudiencePredicate a,
 HasIssuerPredicate a, HasCheckIssuedAt a, HasValidationSettings a,
 AsError e, AsJWTError e, MonadError e m,
 VerificationKeyStore m (JWSHeader ()) payload k,
 HasClaimsSet payload, FromJSON payload) =>
a -> k -> SignedJWT -> m payload
verifyJWT

-- | Variant of 'verifyJWT' where the validation time is provided by
-- caller.  If you process many tokens per second
-- this lets you avoid unnecessary repeat system calls.
--
verifyJWTAt
  ::
    ( HasAllowedSkew a, HasAudiencePredicate a
    , HasIssuerPredicate a
    , HasCheckIssuedAt a
    , HasValidationSettings a
    , AsError e, AsJWTError e, MonadError e m
    , VerificationKeyStore (ReaderT WrappedUTCTime m) (JWSHeader ()) payload k
    , HasClaimsSet payload, FromJSON payload
    )
  => a
  -> k
  -> UTCTime
  -> SignedJWT
  -> m payload
verifyJWTAt :: forall a e (m :: * -> *) payload k.
(HasAllowedSkew a, HasAudiencePredicate a, HasIssuerPredicate a,
 HasCheckIssuedAt a, HasValidationSettings a, AsError e,
 AsJWTError e, MonadError e m,
 VerificationKeyStore
   (ReaderT WrappedUTCTime m) (JWSHeader ()) payload k,
 HasClaimsSet payload, FromJSON payload) =>
a -> k -> UTCTime -> SignedJWT -> m payload
verifyJWTAt a
a k
k UTCTime
t SignedJWT
jwt = ReaderT WrappedUTCTime m payload -> WrappedUTCTime -> m payload
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> k -> SignedJWT -> ReaderT WrappedUTCTime m payload
forall (m :: * -> *) a e payload k.
(MonadTime m, HasAllowedSkew a, HasAudiencePredicate a,
 HasIssuerPredicate a, HasCheckIssuedAt a, HasValidationSettings a,
 AsError e, AsJWTError e, MonadError e m,
 VerificationKeyStore m (JWSHeader ()) payload k,
 HasClaimsSet payload, FromJSON payload) =>
a -> k -> SignedJWT -> m payload
verifyJWT a
a k
k SignedJWT
jwt) (UTCTime -> WrappedUTCTime
WrappedUTCTime UTCTime
t)

-- | Variant of 'verifyJWT' that uses 'ClaimsSet' as the payload type and
-- where validation time is provided by caller.
--
verifyClaimsAt
  ::
    ( HasAllowedSkew a, HasAudiencePredicate a
    , HasIssuerPredicate a
    , HasCheckIssuedAt a
    , HasValidationSettings a
    , AsError e, AsJWTError e, MonadError e m
    , VerificationKeyStore (ReaderT WrappedUTCTime m) (JWSHeader ()) ClaimsSet k
    )
  => a
  -> k
  -> UTCTime
  -> SignedJWT
  -> m ClaimsSet
verifyClaimsAt :: forall a e (m :: * -> *) k.
(HasAllowedSkew a, HasAudiencePredicate a, HasIssuerPredicate a,
 HasCheckIssuedAt a, HasValidationSettings a, AsError e,
 AsJWTError e, MonadError e m,
 VerificationKeyStore
   (ReaderT WrappedUTCTime m) (JWSHeader ()) ClaimsSet k) =>
a -> k -> UTCTime -> SignedJWT -> m ClaimsSet
verifyClaimsAt = a -> k -> UTCTime -> SignedJWT -> m ClaimsSet
forall a e (m :: * -> *) payload k.
(HasAllowedSkew a, HasAudiencePredicate a, HasIssuerPredicate a,
 HasCheckIssuedAt a, HasValidationSettings a, AsError e,
 AsJWTError e, MonadError e m,
 VerificationKeyStore
   (ReaderT WrappedUTCTime m) (JWSHeader ()) payload k,
 HasClaimsSet payload, FromJSON payload) =>
a -> k -> UTCTime -> SignedJWT -> m payload
verifyJWTAt


-- | Create a JWS JWT.  The payload can be any type with a 'ToJSON'
-- instance.  See also 'signClaims' which uses 'ClaimsSet' as the
-- payload type.
--
-- __Does not set any fields in the Claims Set__, such as @"iat"@
-- ("Issued At") Claim.  The payload is encoded as-is.
--
signJWT
  :: ( MonadRandom m, MonadError e m, AsError e
     , ToJSON payload )
  => JWK
  -> JWSHeader ()
  -> payload
  -> m SignedJWT
signJWT :: forall (m :: * -> *) e payload.
(MonadRandom m, MonadError e m, AsError e, ToJSON payload) =>
JWK -> JWSHeader () -> payload -> m SignedJWT
signJWT JWK
k JWSHeader ()
h payload
c = ByteString -> Identity (JWSHeader (), JWK) -> m SignedJWT
forall s (a :: * -> *) (m :: * -> *) e (t :: * -> *) p.
(Cons s s Word8 Word8, HasJWSHeader a, HasParams a, MonadRandom m,
 AsError e, MonadError e m, Traversable t, ProtectionIndicator p) =>
s -> t (a p, JWK) -> m (JWS t p a)
signJWS (payload -> ByteString
forall a. ToJSON a => a -> ByteString
encode payload
c) ((JWSHeader (), JWK) -> Identity (JWSHeader (), JWK)
forall a. a -> Identity a
Identity (JWSHeader ()
h, JWK
k))

-- | Create a JWS JWT.  Specialisation of 'signJWT' with payload type fixed
-- at 'ClaimsSet'.
--
-- __Does not set any fields in the Claims Set__, such as @"iat"@
-- ("Issued At") Claim.  The payload is encoded as-is.
--
signClaims
  :: (MonadRandom m, MonadError e m, AsError e)
  => JWK
  -> JWSHeader ()
  -> ClaimsSet
  -> m SignedJWT
signClaims :: forall (m :: * -> *) e.
(MonadRandom m, MonadError e m, AsError e) =>
JWK -> JWSHeader () -> ClaimsSet -> m SignedJWT
signClaims = JWK -> JWSHeader () -> ClaimsSet -> m SignedJWT
forall (m :: * -> *) e payload.
(MonadRandom m, MonadError e m, AsError e, ToJSON payload) =>
JWK -> JWSHeader () -> payload -> m SignedJWT
signJWT