-- 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.

@
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 = runExceptT $ do
  alg \<- 'bestJWSAlg' jwk
  'signClaims' jwk ('newJWSHeader' ((), alg)) claims

doJwtVerify :: 'JWK' -> 'SignedJWT' -> IO (Either 'JWTError' 'ClaimsSet')
doJwtVerify jwk jwt = runExceptT $ 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 = runExceptT $ do
  let
    k' = 'fromOctets' k      -- turn raw secret into symmetric JWK
    audCheck = const True  -- should be a proper audience check
  s' <- 'decodeCompact' s    -- decode JWT
  'verifyClaims' ('defaultJWTValidationSettings' audCheck) k' s'
@

-}
module Crypto.JWT
  (
  -- * Creating a JWT
    signClaims
  , SignedJWT

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

  -- * Claims Set
  , ClaimsSet
  , claimAud
  , claimExp
  , claimIat
  , claimIss
  , claimJti
  , claimNbf
  , claimSub
  , unregisteredClaims
  , addClaim
  , emptyClaimsSet
  , validateClaimsSet

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

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

  , 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 Data.Semigroup ((<>))

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


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
/= :: JWTError -> JWTError -> Bool
$c/= :: JWTError -> JWTError -> Bool
== :: JWTError -> JWTError -> Bool
$c== :: 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
showList :: [JWTError] -> ShowS
$cshowList :: [JWTError] -> ShowS
show :: JWTError -> String
$cshow :: JWTError -> String
showsPrec :: Int -> JWTError -> ShowS
$cshowsPrec :: Int -> JWTError -> ShowS
Show)
makeClassyPrisms ''JWTError

instance AsError JWTError where
  _Error :: p Error (f Error) -> p JWTError (f JWTError)
_Error = p Error (f Error) -> p JWTError (f JWTError)
forall r. AsJWTError r => Prism' r 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
/= :: StringOrURI -> StringOrURI -> Bool
$c/= :: StringOrURI -> StringOrURI -> Bool
== :: StringOrURI -> StringOrURI -> Bool
$c== :: 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
showList :: [StringOrURI] -> ShowS
$cshowList :: [StringOrURI] -> ShowS
show :: StringOrURI -> String
$cshow :: StringOrURI -> String
showsPrec :: Int -> StringOrURI -> ShowS
$cshowsPrec :: Int -> 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
stringOrUri

stringOrUri :: (Cons s s Char Char, AsEmpty s) => Prism' s StringOrURI
stringOrUri :: 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
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
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 (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> StringOrURI
Arbitrary Text
s)
{-# INLINE stringOrUri #-}

string :: Prism' StringOrURI T.Text
string :: p Text (f Text) -> p StringOrURI (f StringOrURI)
string = (Text -> StringOrURI)
-> (StringOrURI -> Maybe Text)
-> Prism StringOrURI StringOrURI Text 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 :: p URI (f URI) -> p StringOrURI (f StringOrURI)
uri = (URI -> StringOrURI)
-> (StringOrURI -> Maybe URI)
-> Prism StringOrURI StringOrURI URI 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 (m :: * -> *) a. MonadFail m => String -> m a
fail String
"failed to parse StringOrURI") StringOrURI -> Parser StringOrURI
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
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
/= :: NumericDate -> NumericDate -> Bool
$c/= :: NumericDate -> NumericDate -> Bool
== :: NumericDate -> NumericDate -> Bool
$c== :: 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
min :: NumericDate -> NumericDate -> NumericDate
$cmin :: NumericDate -> NumericDate -> NumericDate
max :: NumericDate -> NumericDate -> NumericDate
$cmax :: NumericDate -> NumericDate -> NumericDate
>= :: NumericDate -> NumericDate -> Bool
$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
compare :: NumericDate -> NumericDate -> Ordering
$ccompare :: NumericDate -> NumericDate -> Ordering
$cp1Ord :: Eq 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
showList :: [NumericDate] -> ShowS
$cshowList :: [NumericDate] -> ShowS
show :: NumericDate -> String
$cshow :: NumericDate -> String
showsPrec :: Int -> NumericDate -> ShowS
$cshowsPrec :: Int -> 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 (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
. POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime)
-> (Scientific -> POSIXTime) -> Scientific -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> POSIXTime
forall a. Fractional a => Rational -> a
fromRational (Rational -> POSIXTime)
-> (Scientific -> Rational) -> Scientific -> POSIXTime
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
$ POSIXTime -> Rational
forall a. Real a => a -> Rational
toRational (POSIXTime -> Rational) -> POSIXTime -> Rational
forall a b. (a -> b) -> a -> b
$ UTCTime -> POSIXTime
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
/= :: Audience -> Audience -> Bool
$c/= :: Audience -> Audience -> Bool
== :: Audience -> Audience -> Bool
$c== :: 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
showList :: [Audience] -> ShowS
$cshowList :: [Audience] -> ShowS
show :: Audience -> String
$cshow :: Audience -> String
showsPrec :: Int -> Audience -> ShowS
$cshowsPrec :: Int -> 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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (StringOrURI -> [StringOrURI])
-> Parser StringOrURI -> Parser [StringOrURI]
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.  Unrecognised
-- claims are gathered into the 'unregisteredClaims' map.
--
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
/= :: ClaimsSet -> ClaimsSet -> Bool
$c/= :: ClaimsSet -> ClaimsSet -> Bool
== :: ClaimsSet -> ClaimsSet -> Bool
$c== :: 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
showList :: [ClaimsSet] -> ShowS
$cshowList :: [ClaimsSet] -> ShowS
show :: ClaimsSet -> String
$cshow :: ClaimsSet -> String
showsPrec :: Int -> ClaimsSet -> ShowS
$cshowsPrec :: Int -> ClaimsSet -> ShowS
Show)

-- | The issuer claim identifies the principal that issued the
-- JWT.  The processing of this claim is generally application
-- specific.
claimIss :: Lens' ClaimsSet (Maybe StringOrURI)
claimIss :: (Maybe StringOrURI -> f (Maybe StringOrURI))
-> ClaimsSet -> f ClaimsSet
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe StringOrURI
a' -> ClaimsSet
h { _claimIss :: Maybe StringOrURI
_claimIss = Maybe StringOrURI
a' }) (Maybe StringOrURI -> f (Maybe StringOrURI)
f Maybe StringOrURI
a)

-- | 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' ClaimsSet (Maybe StringOrURI)
claimSub :: (Maybe StringOrURI -> f (Maybe StringOrURI))
-> ClaimsSet -> f ClaimsSet
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe StringOrURI
a' -> ClaimsSet
h { _claimSub :: Maybe StringOrURI
_claimSub = Maybe StringOrURI
a' }) (Maybe StringOrURI -> f (Maybe StringOrURI)
f Maybe StringOrURI
a)

-- | 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' ClaimsSet (Maybe Audience)
claimAud :: (Maybe Audience -> f (Maybe Audience)) -> ClaimsSet -> f ClaimsSet
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe Audience
a' -> ClaimsSet
h { _claimAud :: Maybe Audience
_claimAud = Maybe Audience
a' }) (Maybe Audience -> f (Maybe Audience)
f Maybe Audience
a)

-- | 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' ClaimsSet (Maybe NumericDate)
claimExp :: (Maybe NumericDate -> f (Maybe NumericDate))
-> ClaimsSet -> f ClaimsSet
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe NumericDate
a' -> ClaimsSet
h { _claimExp :: Maybe NumericDate
_claimExp = Maybe NumericDate
a' }) (Maybe NumericDate -> f (Maybe NumericDate)
f Maybe NumericDate
a)

-- | 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' ClaimsSet (Maybe NumericDate)
claimNbf :: (Maybe NumericDate -> f (Maybe NumericDate))
-> ClaimsSet -> f ClaimsSet
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe NumericDate
a' -> ClaimsSet
h { _claimNbf :: Maybe NumericDate
_claimNbf = Maybe NumericDate
a' }) (Maybe NumericDate -> f (Maybe NumericDate)
f Maybe NumericDate
a)

-- | 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' ClaimsSet (Maybe NumericDate)
claimIat :: (Maybe NumericDate -> f (Maybe NumericDate))
-> ClaimsSet -> f ClaimsSet
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe NumericDate
a' -> ClaimsSet
h { _claimIat :: Maybe NumericDate
_claimIat = Maybe NumericDate
a' }) (Maybe NumericDate -> f (Maybe NumericDate)
f Maybe NumericDate
a)

-- | 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' ClaimsSet (Maybe T.Text)
claimJti :: (Maybe Text -> f (Maybe Text)) -> ClaimsSet -> f ClaimsSet
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe Text
a' -> ClaimsSet
h { _claimJti :: Maybe Text
_claimJti = Maybe Text
a' }) (Maybe Text -> f (Maybe Text)
f Maybe Text
a)

-- | Claim Names can be defined at will by those using JWTs.
unregisteredClaims :: Lens' ClaimsSet (M.Map T.Text Value)
unregisteredClaims :: (Map Text Value -> f (Map Text Value)) -> ClaimsSet -> f ClaimsSet
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Map Text Value
a' -> ClaimsSet
h { _unregisteredClaims :: Map Text Value
_unregisteredClaims = Map Text Value
a' }) (Map Text Value -> f (Map Text Value)
f Map Text Value
a)


-- | 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

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)

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 (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 (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 (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 (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 (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 (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Text Value -> Parser (Map Text Value)
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 (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
.=) Maybe Audience
aud
      , (NumericDate -> (Key, Value))
-> Maybe NumericDate -> Maybe (Key, Value)
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
.=) Maybe NumericDate
exp'
      , (NumericDate -> (Key, Value))
-> Maybe NumericDate -> Maybe (Key, Value)
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
.=) Maybe NumericDate
iat
      , (StringOrURI -> (Key, Value))
-> Maybe StringOrURI -> Maybe (Key, Value)
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
.=) Maybe StringOrURI
iss
      , (Text -> (Key, Value)) -> Maybe Text -> Maybe (Key, Value)
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
.=) Maybe Text
jti
      , (NumericDate -> (Key, Value))
-> Maybe NumericDate -> Maybe (Key, Value)
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
.=) Maybe NumericDate
nbf
      , (StringOrURI -> (Key, Value))
-> Maybe StringOrURI -> Maybe (Key, Value)
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
.=) 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 -> POSIXTime
_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 :: (ValidationSettings -> f ValidationSettings) -> a -> f a
validationSettings = (ValidationSettings -> f ValidationSettings) -> a -> f a
forall a. HasJWTValidationSettings a => 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 :: (POSIXTime -> f POSIXTime) -> a -> f a
allowedSkew = (POSIXTime -> f POSIXTime) -> a -> f a
forall a. HasJWTValidationSettings a => Lens' a POSIXTime
jwtValidationSettingsAllowedSkew
instance HasJWTValidationSettings a => HasAudiencePredicate a where
  audiencePredicate :: ((StringOrURI -> Bool) -> f (StringOrURI -> Bool)) -> a -> f a
audiencePredicate = ((StringOrURI -> Bool) -> f (StringOrURI -> Bool)) -> a -> f a
forall a.
HasJWTValidationSettings a =>
Lens' a (StringOrURI -> Bool)
jwtValidationSettingsAudiencePredicate
instance HasJWTValidationSettings a => HasIssuerPredicate a where
  issuerPredicate :: ((StringOrURI -> Bool) -> f (StringOrURI -> Bool)) -> a -> f a
issuerPredicate = ((StringOrURI -> Bool) -> f (StringOrURI -> Bool)) -> a -> f a
forall a.
HasJWTValidationSettings a =>
Lens' a (StringOrURI -> Bool)
jwtValidationSettingsIssuerPredicate
instance HasJWTValidationSettings a => HasCheckIssuedAt a where
  checkIssuedAt :: (Bool -> f Bool) -> a -> f a
checkIssuedAt = (Bool -> f Bool) -> a -> f a
forall a. HasJWTValidationSettings a => 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
-> POSIXTime
-> Bool
-> (StringOrURI -> Bool)
-> (StringOrURI -> Bool)
-> JWTValidationSettings
JWTValidationSettings
  ValidationSettings
defaultValidationSettings
  POSIXTime
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.
--
-- These checks are performed by 'verifyClaims', which also
-- validates any signatures, so you shouldn't need to use this
-- function directly.
--
validateClaimsSet
  ::
    ( MonadTime m, HasAllowedSkew a, HasAudiencePredicate a
    , HasIssuerPredicate a
    , HasCheckIssuedAt a
    , AsJWTError e, MonadError e m
    )
  => a
  -> ClaimsSet
  -> m ClaimsSet
validateClaimsSet :: a -> ClaimsSet -> m ClaimsSet
validateClaimsSet a
conf ClaimsSet
claims =
  ClaimsSet
claims ClaimsSet -> m () -> m ClaimsSet
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 :: 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
< POSIXTime -> UTCTime -> UTCTime
addUTCTime (POSIXTime -> POSIXTime
forall a. Num a => a -> a
abs (Getting POSIXTime a POSIXTime -> a -> POSIXTime
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting POSIXTime a POSIXTime
forall s. HasAllowedSkew s => Lens' s POSIXTime
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 ()
_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
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. Prism (Maybe a) (Maybe b) a b
_Just)

validateIatClaim
  :: (MonadTime m, HasCheckIssuedAt a, HasAllowedSkew a, AsJWTError e, MonadError e m)
  => a
  -> ClaimsSet
  -> m ()
validateIatClaim :: 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
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
> POSIXTime -> UTCTime -> UTCTime
addUTCTime (POSIXTime -> POSIXTime
forall a. Num a => a -> a
abs (Getting POSIXTime a POSIXTime -> a -> POSIXTime
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting POSIXTime a POSIXTime
forall s. HasAllowedSkew s => Lens' s POSIXTime
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 ()
_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
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. Prism (Maybe a) (Maybe b) a b
_Just)

validateNbfClaim
  :: (MonadTime m, HasAllowedSkew a, AsJWTError e, MonadError e m)
  => a
  -> ClaimsSet
  -> m ()
validateNbfClaim :: 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
>= POSIXTime -> UTCTime -> UTCTime
addUTCTime (POSIXTime -> POSIXTime
forall a. Num a => a -> a
negate (POSIXTime -> POSIXTime
forall a. Num a => a -> a
abs (Getting POSIXTime a POSIXTime -> a -> POSIXTime
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting POSIXTime a POSIXTime
forall s. HasAllowedSkew s => Lens' s POSIXTime
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 ()
_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
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. Prism (Maybe a) (Maybe b) a b
_Just)

validateAudClaim
  :: (HasAudiencePredicate s, AsJWTError e, MonadError e m)
  => s
  -> ClaimsSet
  -> m ()
validateAudClaim :: 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)
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 ()
_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
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. Prism (Maybe a) (Maybe b) a 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 :: 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)
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 ()
_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
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. Prism (Maybe a) (Maybe b) a b
_Just)

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


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

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


-- | Cryptographically verify a JWS JWT, then validate the
-- Claims Set, returning it if valid.
--
-- 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.
--
-- See also 'verifyClaimsAt' which allows you to explicitly specify
-- the time.
--
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 :: a -> k -> SignedJWT -> m ClaimsSet
verifyClaims a
conf k
k SignedJWT
jws =
  -- It is important, for security reasons, that the signature get
  -- verified before the claims.
  (ByteString -> m ClaimsSet) -> a -> k -> SignedJWT -> m ClaimsSet
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 ClaimsSet
f a
conf k
k SignedJWT
jws m ClaimsSet -> (ClaimsSet -> m ClaimsSet) -> m ClaimsSet
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 ClaimsSet
f = (String -> m ClaimsSet)
-> (ClaimsSet -> m ClaimsSet)
-> Either String ClaimsSet
-> m ClaimsSet
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (AReview e String -> String -> m ClaimsSet
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
_JWTClaimsSetDecodeError) ClaimsSet -> m ClaimsSet
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String ClaimsSet -> m ClaimsSet)
-> (ByteString -> Either String ClaimsSet)
-> ByteString
-> m ClaimsSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ClaimsSet
forall a. FromJSON a => ByteString -> Either String a
eitherDecode


-- | Cryptographically verify a JWS JWT, then validate the
-- Claims Set, returning it if valid.
--
-- This is the same as 'verifyClaims' except that the time is
-- explicitly provided.  If you process many requests per second
-- this will allow you to avoid unnecessary repeat system calls.
--
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 :: a -> k -> UTCTime -> SignedJWT -> m ClaimsSet
verifyClaimsAt a
a k
k UTCTime
t SignedJWT
jwt = ReaderT WrappedUTCTime m ClaimsSet -> WrappedUTCTime -> m ClaimsSet
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> k -> SignedJWT -> ReaderT WrappedUTCTime m ClaimsSet
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
a k
k SignedJWT
jwt) (UTCTime -> WrappedUTCTime
WrappedUTCTime UTCTime
t)

-- | Create a JWS JWT
--
signClaims
  :: (MonadRandom m, MonadError e m, AsError e)
  => JWK
  -> JWSHeader ()
  -> ClaimsSet
  -> m SignedJWT
signClaims :: JWK -> JWSHeader () -> ClaimsSet -> m SignedJWT
signClaims JWK
k JWSHeader ()
h ClaimsSet
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 (ClaimsSet -> ByteString
forall a. ToJSON a => a -> ByteString
encode ClaimsSet
c) ((JWSHeader (), JWK) -> Identity (JWSHeader (), JWK)
forall a. a -> Identity a
Identity (JWSHeader ()
h, JWK
k))