{-# Language DeriveFunctor #-}
{-# language DeriveGeneric #-}
{-# language DerivingStrategies #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# language OverloadedStrings #-}
{-# options_ghc -Wno-unused-top-binds #-}
-- | Decode and validate a JWT token
--
-- provides 'Validation' function for the individual fields as well
module Network.OAuth2.JWT (
  -- * 1) Decode a string into claims
  jwtClaims
  -- * 2) Extract and validate the individual claims
  , decValidSub, decValidExp, decValidNbf, decValidEmail, decValidAud
  , UserSub, userSub, UserEmail, userEmail, ApiAudience, apiAudience
  , JWTException(..)
                          ) where

import Control.Monad.IO.Class (MonadIO(..))
import qualified Data.List.NonEmpty as NE (NonEmpty(..))
import GHC.Exception (Exception(..))
import GHC.Generics (Generic)
import Data.Maybe (fromMaybe)
import Data.String (IsString(..))
import Data.Typeable

-- aeson
import qualified Data.Aeson as A (FromJSON(..), ToJSON(..), ToJSONKey(..), FromJSON(..), FromJSONKey(..), Value(..))
-- containers
import qualified Data.Map.Strict as M (Map, lookup)
-- jwt
import qualified Web.JWT as J (decode, claims, JWTClaimsSet(..), StringOrURI, NumericDate, ClaimsMap(..))
-- scientific
import Data.Scientific (coefficient)
-- text
import qualified Data.Text as T (Text, unpack)
-- time
import Data.Time (UTCTime(..), NominalDiffTime, getCurrentTime, fromGregorian, addUTCTime, diffUTCTime)
-- validation-micro
import Validation.Micro (Validation(..), bindValidation, failure, validationToEither, maybeToSuccess)


-- | 'sub' field
newtype UserSub = UserSub { UserSub -> Text
userSub :: T.Text }
  deriving (UserSub -> UserSub -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserSub -> UserSub -> Bool
$c/= :: UserSub -> UserSub -> Bool
== :: UserSub -> UserSub -> Bool
$c== :: UserSub -> UserSub -> Bool
Eq, Eq UserSub
UserSub -> UserSub -> Bool
UserSub -> UserSub -> Ordering
UserSub -> UserSub -> UserSub
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 :: UserSub -> UserSub -> UserSub
$cmin :: UserSub -> UserSub -> UserSub
max :: UserSub -> UserSub -> UserSub
$cmax :: UserSub -> UserSub -> UserSub
>= :: UserSub -> UserSub -> Bool
$c>= :: UserSub -> UserSub -> Bool
> :: UserSub -> UserSub -> Bool
$c> :: UserSub -> UserSub -> Bool
<= :: UserSub -> UserSub -> Bool
$c<= :: UserSub -> UserSub -> Bool
< :: UserSub -> UserSub -> Bool
$c< :: UserSub -> UserSub -> Bool
compare :: UserSub -> UserSub -> Ordering
$ccompare :: UserSub -> UserSub -> Ordering
Ord, forall x. Rep UserSub x -> UserSub
forall x. UserSub -> Rep UserSub x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UserSub x -> UserSub
$cfrom :: forall x. UserSub -> Rep UserSub x
Generic, String -> UserSub
forall a. (String -> a) -> IsString a
fromString :: String -> UserSub
$cfromString :: String -> UserSub
IsString)
  deriving newtype (Int -> UserSub -> ShowS
[UserSub] -> ShowS
UserSub -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserSub] -> ShowS
$cshowList :: [UserSub] -> ShowS
show :: UserSub -> String
$cshow :: UserSub -> String
showsPrec :: Int -> UserSub -> ShowS
$cshowsPrec :: Int -> UserSub -> ShowS
Show, [UserSub] -> Encoding
[UserSub] -> Value
UserSub -> Encoding
UserSub -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [UserSub] -> Encoding
$ctoEncodingList :: [UserSub] -> Encoding
toJSONList :: [UserSub] -> Value
$ctoJSONList :: [UserSub] -> Value
toEncoding :: UserSub -> Encoding
$ctoEncoding :: UserSub -> Encoding
toJSON :: UserSub -> Value
$ctoJSON :: UserSub -> Value
A.ToJSON, Value -> Parser [UserSub]
Value -> Parser UserSub
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [UserSub]
$cparseJSONList :: Value -> Parser [UserSub]
parseJSON :: Value -> Parser UserSub
$cparseJSON :: Value -> Parser UserSub
A.FromJSON, ToJSONKeyFunction [UserSub]
ToJSONKeyFunction UserSub
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
toJSONKeyList :: ToJSONKeyFunction [UserSub]
$ctoJSONKeyList :: ToJSONKeyFunction [UserSub]
toJSONKey :: ToJSONKeyFunction UserSub
$ctoJSONKey :: ToJSONKeyFunction UserSub
A.ToJSONKey, FromJSONKeyFunction [UserSub]
FromJSONKeyFunction UserSub
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
fromJSONKeyList :: FromJSONKeyFunction [UserSub]
$cfromJSONKeyList :: FromJSONKeyFunction [UserSub]
fromJSONKey :: FromJSONKeyFunction UserSub
$cfromJSONKey :: FromJSONKeyFunction UserSub
A.FromJSONKey)

newtype UserEmail = UserEmail { UserEmail -> Text
userEmail :: T.Text }
  deriving (UserEmail -> UserEmail -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserEmail -> UserEmail -> Bool
$c/= :: UserEmail -> UserEmail -> Bool
== :: UserEmail -> UserEmail -> Bool
$c== :: UserEmail -> UserEmail -> Bool
Eq, Eq UserEmail
UserEmail -> UserEmail -> Bool
UserEmail -> UserEmail -> Ordering
UserEmail -> UserEmail -> UserEmail
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 :: UserEmail -> UserEmail -> UserEmail
$cmin :: UserEmail -> UserEmail -> UserEmail
max :: UserEmail -> UserEmail -> UserEmail
$cmax :: UserEmail -> UserEmail -> UserEmail
>= :: UserEmail -> UserEmail -> Bool
$c>= :: UserEmail -> UserEmail -> Bool
> :: UserEmail -> UserEmail -> Bool
$c> :: UserEmail -> UserEmail -> Bool
<= :: UserEmail -> UserEmail -> Bool
$c<= :: UserEmail -> UserEmail -> Bool
< :: UserEmail -> UserEmail -> Bool
$c< :: UserEmail -> UserEmail -> Bool
compare :: UserEmail -> UserEmail -> Ordering
$ccompare :: UserEmail -> UserEmail -> Ordering
Ord, forall x. Rep UserEmail x -> UserEmail
forall x. UserEmail -> Rep UserEmail x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UserEmail x -> UserEmail
$cfrom :: forall x. UserEmail -> Rep UserEmail x
Generic, String -> UserEmail
forall a. (String -> a) -> IsString a
fromString :: String -> UserEmail
$cfromString :: String -> UserEmail
IsString)
  deriving newtype (Int -> UserEmail -> ShowS
[UserEmail] -> ShowS
UserEmail -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserEmail] -> ShowS
$cshowList :: [UserEmail] -> ShowS
show :: UserEmail -> String
$cshow :: UserEmail -> String
showsPrec :: Int -> UserEmail -> ShowS
$cshowsPrec :: Int -> UserEmail -> ShowS
Show, [UserEmail] -> Encoding
[UserEmail] -> Value
UserEmail -> Encoding
UserEmail -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [UserEmail] -> Encoding
$ctoEncodingList :: [UserEmail] -> Encoding
toJSONList :: [UserEmail] -> Value
$ctoJSONList :: [UserEmail] -> Value
toEncoding :: UserEmail -> Encoding
$ctoEncoding :: UserEmail -> Encoding
toJSON :: UserEmail -> Value
$ctoJSON :: UserEmail -> Value
A.ToJSON, Value -> Parser [UserEmail]
Value -> Parser UserEmail
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [UserEmail]
$cparseJSONList :: Value -> Parser [UserEmail]
parseJSON :: Value -> Parser UserEmail
$cparseJSON :: Value -> Parser UserEmail
A.FromJSON, ToJSONKeyFunction [UserEmail]
ToJSONKeyFunction UserEmail
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
toJSONKeyList :: ToJSONKeyFunction [UserEmail]
$ctoJSONKeyList :: ToJSONKeyFunction [UserEmail]
toJSONKey :: ToJSONKeyFunction UserEmail
$ctoJSONKey :: ToJSONKeyFunction UserEmail
A.ToJSONKey, FromJSONKeyFunction [UserEmail]
FromJSONKeyFunction UserEmail
forall a.
FromJSONKeyFunction a -> FromJSONKeyFunction [a] -> FromJSONKey a
fromJSONKeyList :: FromJSONKeyFunction [UserEmail]
$cfromJSONKeyList :: FromJSONKeyFunction [UserEmail]
fromJSONKey :: FromJSONKeyFunction UserEmail
$cfromJSONKey :: FromJSONKeyFunction UserEmail
A.FromJSONKey)

-- | intended audience of the token (== API key ID )
newtype ApiAudience = ApiAudience { ApiAudience -> Text
apiAudience :: T.Text } deriving (ApiAudience -> ApiAudience -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApiAudience -> ApiAudience -> Bool
$c/= :: ApiAudience -> ApiAudience -> Bool
== :: ApiAudience -> ApiAudience -> Bool
$c== :: ApiAudience -> ApiAudience -> Bool
Eq, Eq ApiAudience
ApiAudience -> ApiAudience -> Bool
ApiAudience -> ApiAudience -> Ordering
ApiAudience -> ApiAudience -> ApiAudience
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 :: ApiAudience -> ApiAudience -> ApiAudience
$cmin :: ApiAudience -> ApiAudience -> ApiAudience
max :: ApiAudience -> ApiAudience -> ApiAudience
$cmax :: ApiAudience -> ApiAudience -> ApiAudience
>= :: ApiAudience -> ApiAudience -> Bool
$c>= :: ApiAudience -> ApiAudience -> Bool
> :: ApiAudience -> ApiAudience -> Bool
$c> :: ApiAudience -> ApiAudience -> Bool
<= :: ApiAudience -> ApiAudience -> Bool
$c<= :: ApiAudience -> ApiAudience -> Bool
< :: ApiAudience -> ApiAudience -> Bool
$c< :: ApiAudience -> ApiAudience -> Bool
compare :: ApiAudience -> ApiAudience -> Ordering
$ccompare :: ApiAudience -> ApiAudience -> Ordering
Ord, Int -> ApiAudience -> ShowS
[ApiAudience] -> ShowS
ApiAudience -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApiAudience] -> ShowS
$cshowList :: [ApiAudience] -> ShowS
show :: ApiAudience -> String
$cshow :: ApiAudience -> String
showsPrec :: Int -> ApiAudience -> ShowS
$cshowsPrec :: Int -> ApiAudience -> ShowS
Show, forall x. Rep ApiAudience x -> ApiAudience
forall x. ApiAudience -> Rep ApiAudience x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ApiAudience x -> ApiAudience
$cfrom :: forall x. ApiAudience -> Rep ApiAudience x
Generic, Typeable, String -> ApiAudience
forall a. (String -> a) -> IsString a
fromString :: String -> ApiAudience
$cfromString :: String -> ApiAudience
IsString)
instance A.ToJSON ApiAudience

-- | Decode a string into a 'J.JWTClaimsSet'
jwtClaims :: T.Text -> Maybe J.JWTClaimsSet
jwtClaims :: Text -> Maybe JWTClaimsSet
jwtClaims Text
t = forall r. JWT r -> JWTClaimsSet
J.claims forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe (JWT UnverifiedJWT)
J.decode Text
t

-- | decoded claims from the JWT token, valid (at least) for the Google OpenID implementation as of February 2021
--
data JWTClaims =
  JWTClaims {
    JWTClaims -> Text
jcAud :: T.Text -- "aud"ience field
  , JWTClaims -> UTCTime
jcExp :: UTCTime -- "exp"iry date
  , JWTClaims -> UTCTime
jcIat :: UTCTime -- Issued AT
  , JWTClaims -> UTCTime
jcNbf :: UTCTime -- Not BeFore
  , JWTClaims -> UserSub
jcSub :: UserSub -- "sub"ject
  , JWTClaims -> UserEmail
jcEmail :: UserEmail
            } deriving (JWTClaims -> JWTClaims -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JWTClaims -> JWTClaims -> Bool
$c/= :: JWTClaims -> JWTClaims -> Bool
== :: JWTClaims -> JWTClaims -> Bool
$c== :: JWTClaims -> JWTClaims -> Bool
Eq, Int -> JWTClaims -> ShowS
[JWTClaims] -> ShowS
JWTClaims -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JWTClaims] -> ShowS
$cshowList :: [JWTClaims] -> ShowS
show :: JWTClaims -> String
$cshow :: JWTClaims -> String
showsPrec :: Int -> JWTClaims -> ShowS
$cshowsPrec :: Int -> JWTClaims -> ShowS
Show)

-- | @sub@
decValidSub :: J.JWTClaimsSet -> Validation (NE.NonEmpty JWTException) UserSub
decValidSub :: JWTClaimsSet -> Validation (NonEmpty JWTException) UserSub
decValidSub JWTClaimsSet
jc = forall a.
ToJSON a =>
Maybe a -> Validation (NonEmpty JWTException) UserSub
decSub (JWTClaimsSet -> Maybe StringOrURI
J.sub JWTClaimsSet
jc)

-- | @exp@
decValidExp :: Maybe NominalDiffTime
            -> UTCTime -- ^ current time
            -> J.JWTClaimsSet
            -> Validation (NE.NonEmpty JWTException) UTCTime
decValidExp :: Maybe NominalDiffTime
-> UTCTime
-> JWTClaimsSet
-> Validation (NonEmpty JWTException) UTCTime
decValidExp Maybe NominalDiffTime
nsecs UTCTime
t JWTClaimsSet
jc = Maybe NumericDate -> Validation (NonEmpty JWTException) UTCTime
decExp (JWTClaimsSet -> Maybe NumericDate
J.exp JWTClaimsSet
jc) forall e a b.
Validation e a -> (a -> Validation e b) -> Validation e b
`bindValidation` Maybe NominalDiffTime
-> UTCTime -> UTCTime -> Validation (NonEmpty JWTException) UTCTime
validateExp Maybe NominalDiffTime
nsecs UTCTime
t

-- | @nbf@
decValidNbf :: UTCTime -- ^ current time
            -> J.JWTClaimsSet -> Validation (NE.NonEmpty JWTException) UTCTime
decValidNbf :: UTCTime
-> JWTClaimsSet -> Validation (NonEmpty JWTException) UTCTime
decValidNbf UTCTime
t JWTClaimsSet
jc = Maybe NumericDate -> Validation (NonEmpty JWTException) UTCTime
decNbf (JWTClaimsSet -> Maybe NumericDate
J.nbf JWTClaimsSet
jc) forall e a b.
Validation e a -> (a -> Validation e b) -> Validation e b
`bindValidation` UTCTime -> UTCTime -> Validation (NonEmpty JWTException) UTCTime
validateNbf UTCTime
t

-- | @email@
decValidEmail :: J.JWTClaimsSet -> Validation (NE.NonEmpty JWTException) UserEmail
decValidEmail :: JWTClaimsSet -> Validation (NonEmpty JWTException) UserEmail
decValidEmail JWTClaimsSet
jc = forall k.
(Ord k, IsString k) =>
Map k Value -> Validation (NonEmpty JWTException) UserEmail
decEmail (ClaimsMap -> Map Text Value
J.unClaimsMap forall a b. (a -> b) -> a -> b
$ JWTClaimsSet -> ClaimsMap
J.unregisteredClaims JWTClaimsSet
jc)

-- | @aud@
decValidAud :: ApiAudience -> J.JWTClaimsSet -> Validation (NE.NonEmpty JWTException) T.Text
decValidAud :: ApiAudience
-> JWTClaimsSet -> Validation (NonEmpty JWTException) Text
decValidAud ApiAudience
a JWTClaimsSet
jc = Maybe (Either StringOrURI [StringOrURI])
-> Validation (NonEmpty JWTException) Text
decAud (JWTClaimsSet -> Maybe (Either StringOrURI [StringOrURI])
J.aud JWTClaimsSet
jc) forall e a b.
Validation e a -> (a -> Validation e b) -> Validation e b
`bindValidation` ApiAudience -> Text -> Validation (NonEmpty JWTException) Text
validateAud ApiAudience
a


-- | Decode and validate the 'aud', 'exp' and 'nbf' fields of the JWT
decodeValidateJWT :: MonadIO f =>
                     ApiAudience -- ^ intended token audience (its meaning depends on the OAuth identity provider )
                  -> Maybe NominalDiffTime -- ^ buffer period to allow for API roundtrip delays (defaults to 0 if Nothing)
                  -> T.Text -- ^ JWT-encoded string, e.g. the contents of the id_token field
                  -> f (Either (NE.NonEmpty JWTException) JWTClaims)
decodeValidateJWT :: forall (f :: * -> *).
MonadIO f =>
ApiAudience
-> Maybe NominalDiffTime
-> Text
-> f (Either (NonEmpty JWTException) JWTClaims)
decodeValidateJWT ApiAudience
iaud Maybe NominalDiffTime
nsecs Text
jstr = case forall e a. Validation e a -> Either e a
validationToEither forall a b. (a -> b) -> a -> b
$ Text -> Validation (NonEmpty JWTException) JWTClaims
decodeJWT Text
jstr of
  Right JWTClaims
jwc -> forall e a. Validation e a -> Either e a
validationToEither forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
ApiAudience
-> Maybe NominalDiffTime
-> JWTClaims
-> m (Validation (NonEmpty JWTException) JWTClaims)
validateJWT ApiAudience
iaud Maybe NominalDiffTime
nsecs JWTClaims
jwc
  Left NonEmpty JWTException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left NonEmpty JWTException
e


-- | Validate the 'aud', 'exp' and 'nbf' fields
validateJWT :: MonadIO m =>
               ApiAudience -- ^ intended token audience (its meaning depends on the OAuth identity provider )
            -> Maybe NominalDiffTime
            -> JWTClaims
            -> m (Validation (NE.NonEmpty JWTException) JWTClaims)
validateJWT :: forall (m :: * -> *).
MonadIO m =>
ApiAudience
-> Maybe NominalDiffTime
-> JWTClaims
-> m (Validation (NonEmpty JWTException) JWTClaims)
validateJWT ApiAudience
a Maybe NominalDiffTime
nsecs JWTClaims
j = do
  UTCTime
t <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (
    Text
-> UTCTime
-> UTCTime
-> UTCTime
-> UserSub
-> UserEmail
-> JWTClaims
JWTClaims forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      ApiAudience -> Text -> Validation (NonEmpty JWTException) Text
validateAud ApiAudience
a (JWTClaims -> Text
jcAud JWTClaims
j) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
      Maybe NominalDiffTime
-> UTCTime -> UTCTime -> Validation (NonEmpty JWTException) UTCTime
validateExp Maybe NominalDiffTime
nsecs UTCTime
t (JWTClaims -> UTCTime
jcExp JWTClaims
j) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (JWTClaims -> UTCTime
jcIat JWTClaims
j) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
      UTCTime -> UTCTime -> Validation (NonEmpty JWTException) UTCTime
validateNbf UTCTime
t (JWTClaims -> UTCTime
jcNbf JWTClaims
j) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (JWTClaims -> UserSub
jcSub JWTClaims
j) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (JWTClaims -> UserEmail
jcEmail JWTClaims
j)
       )

-- | Fails if the 'exp'iry field is not at least 'nsecs' seconds in the future
validateExp :: Maybe NominalDiffTime -- ^ defaults to 0 if Nothing
            -> UTCTime -> UTCTime -> Validation (NE.NonEmpty JWTException) UTCTime
validateExp :: Maybe NominalDiffTime
-> UTCTime -> UTCTime -> Validation (NonEmpty JWTException) UTCTime
validateExp Maybe NominalDiffTime
nsecs UTCTime
t UTCTime
texp = do
  if forall a. a -> Maybe a -> a
fromMaybe NominalDiffTime
0 Maybe NominalDiffTime
nsecs NominalDiffTime -> UTCTime -> UTCTime
`addUTCTime` UTCTime
texp forall a. Ord a => a -> a -> Bool
> UTCTime
t then
    forall e a. a -> Validation e a
Success UTCTime
texp
    else forall e a. e -> Validation (NonEmpty e) a
failure (UTCTime -> JWTException
JEExpiredToken UTCTime
texp)


-- | Fails if the current time is before the 'nbf' time (= token is not yet valid)
validateNbf :: UTCTime -> UTCTime -> Validation (NE.NonEmpty JWTException) UTCTime
validateNbf :: UTCTime -> UTCTime -> Validation (NonEmpty JWTException) UTCTime
validateNbf UTCTime
t UTCTime
tnbf = do
  if UTCTime
t UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
tnbf forall a. Ord a => a -> a -> Bool
> NominalDiffTime
0 then
    forall e a. a -> Validation e a
Success UTCTime
tnbf
    else forall e a. e -> Validation (NonEmpty e) a
failure (UTCTime -> JWTException
JENotYetValid UTCTime
tnbf)

-- | Fails if the 'aud'ience field is not equal to the supplied ApiAudience
validateAud :: ApiAudience -- ^ intended audience of the token (== API key ID )
            -> T.Text -- ^ decoded from the JWT
            -> Validation (NE.NonEmpty JWTException) T.Text
validateAud :: ApiAudience -> Text -> Validation (NonEmpty JWTException) Text
validateAud aa :: ApiAudience
aa@(ApiAudience Text
a) Text
audt
  | Text
a forall a. Eq a => a -> a -> Bool
== Text
audt = forall e a. a -> Validation e a
Success Text
audt
  | Bool
otherwise = forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ ApiAudience -> JWTException
JEAudienceNotFound ApiAudience
aa

decodeJWT :: T.Text
          -> Validation (NE.NonEmpty JWTException) JWTClaims
decodeJWT :: Text -> Validation (NonEmpty JWTException) JWTClaims
decodeJWT Text
jwts = case forall r. JWT r -> JWTClaimsSet
J.claims forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe (JWT UnverifiedJWT)
J.decode Text
jwts of
  Maybe JWTClaimsSet
Nothing -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ Text -> JWTException
JEMalformedJWT Text
jwts
  Just (J.JWTClaimsSet Maybe StringOrURI
_ Maybe StringOrURI
subm Maybe (Either StringOrURI [StringOrURI])
audm Maybe NumericDate
expm Maybe NumericDate
nbfm Maybe NumericDate
iatm Maybe StringOrURI
_ (J.ClaimsMap Map Text Value
cms)) ->
    Text
-> UTCTime
-> UTCTime
-> UTCTime
-> UserSub
-> UserEmail
-> JWTClaims
JWTClaims forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Maybe (Either StringOrURI [StringOrURI])
-> Validation (NonEmpty JWTException) Text
decAud Maybe (Either StringOrURI [StringOrURI])
audm forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
      Maybe NumericDate -> Validation (NonEmpty JWTException) UTCTime
decExp Maybe NumericDate
expm forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
      Maybe NumericDate -> Validation (NonEmpty JWTException) UTCTime
decIat Maybe NumericDate
iatm forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
      Maybe NumericDate -> Validation (NonEmpty JWTException) UTCTime
decNbf Maybe NumericDate
nbfm forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
      forall a.
ToJSON a =>
Maybe a -> Validation (NonEmpty JWTException) UserSub
decSub Maybe StringOrURI
subm forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>
      forall k.
(Ord k, IsString k) =>
Map k Value -> Validation (NonEmpty JWTException) UserEmail
decEmail Map Text Value
cms

decAud :: Maybe (Either J.StringOrURI [J.StringOrURI])
       -> Validation (NE.NonEmpty JWTException) T.Text
decAud :: Maybe (Either StringOrURI [StringOrURI])
-> Validation (NonEmpty JWTException) Text
decAud Maybe (Either StringOrURI [StringOrURI])
aam = forall a. String -> Maybe a -> Validation (NonEmpty JWTException) a
claimNotFound String
"aud" (Maybe (Either StringOrURI [StringOrURI]) -> Maybe Text
fromAud Maybe (Either StringOrURI [StringOrURI])
aam)

decExp :: Maybe J.NumericDate -> Validation (NE.NonEmpty JWTException) UTCTime
decExp :: Maybe NumericDate -> Validation (NonEmpty JWTException) UTCTime
decExp Maybe NumericDate
em = forall a. String -> Maybe a -> Validation (NonEmpty JWTException) a
claimNotFound String
"exp" (Maybe NumericDate -> Maybe UTCTime
fromNumericDate Maybe NumericDate
em)

decIat :: Maybe J.NumericDate -> Validation (NE.NonEmpty JWTException) UTCTime
decIat :: Maybe NumericDate -> Validation (NonEmpty JWTException) UTCTime
decIat Maybe NumericDate
im = forall a. String -> Maybe a -> Validation (NonEmpty JWTException) a
claimNotFound String
"iat" (Maybe NumericDate -> Maybe UTCTime
fromNumericDate Maybe NumericDate
im)

decNbf :: Maybe J.NumericDate
       -> Validation (NE.NonEmpty JWTException) UTCTime
decNbf :: Maybe NumericDate -> Validation (NonEmpty JWTException) UTCTime
decNbf Maybe NumericDate
im = forall a. String -> Maybe a -> Validation (NonEmpty JWTException) a
claimNotFound String
"nbf" (Maybe NumericDate -> Maybe UTCTime
fromNumericDate Maybe NumericDate
im)

decSub :: A.ToJSON a =>
          Maybe a -> Validation (NE.NonEmpty JWTException) UserSub
decSub :: forall a.
ToJSON a =>
Maybe a -> Validation (NonEmpty JWTException) UserSub
decSub Maybe a
sm = forall a. String -> Maybe a -> Validation (NonEmpty JWTException) a
claimNotFound String
"sub" (Text -> UserSub
UserSub forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ToJSON a => Maybe a -> Maybe Text
fromStringOrUri Maybe a
sm)

decEmail :: (Ord k, IsString k) =>
            M.Map k A.Value -> Validation (NE.NonEmpty JWTException) UserEmail
decEmail :: forall k.
(Ord k, IsString k) =>
Map k Value -> Validation (NonEmpty JWTException) UserEmail
decEmail Map k Value
cms = forall a. String -> Maybe a -> Validation (NonEmpty JWTException) a
claimNotFound String
"email" (case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup k
"email" Map k Value
cms of
                                           Just (A.String Text
ems) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> UserEmail
UserEmail Text
ems
                                           Maybe Value
_ -> forall a. Maybe a
Nothing)

claimNotFound :: String -> Maybe a -> Validation (NE.NonEmpty JWTException) a
claimNotFound :: forall a. String -> Maybe a -> Validation (NonEmpty JWTException) a
claimNotFound String
c = forall e a. e -> Maybe a -> Validation e a
maybeToSuccess (String -> JWTException
JEClaimNotFound String
c forall a. a -> [a] -> NonEmpty a
NE.:| [])

-- | Possible exception states of authentication request
data JWTException = JEMalformedJWT T.Text
                   | JEClaimNotFound String
                   | JEAudienceNotFound ApiAudience
                   | JEExpiredToken UTCTime
                   | JENotYetValid UTCTime
                   | JENoToken
                   deriving (JWTException -> JWTException -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JWTException -> JWTException -> Bool
$c/= :: JWTException -> JWTException -> Bool
== :: JWTException -> JWTException -> Bool
$c== :: JWTException -> JWTException -> Bool
Eq, Eq JWTException
JWTException -> JWTException -> Bool
JWTException -> JWTException -> Ordering
JWTException -> JWTException -> JWTException
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 :: JWTException -> JWTException -> JWTException
$cmin :: JWTException -> JWTException -> JWTException
max :: JWTException -> JWTException -> JWTException
$cmax :: JWTException -> JWTException -> JWTException
>= :: JWTException -> JWTException -> Bool
$c>= :: JWTException -> JWTException -> Bool
> :: JWTException -> JWTException -> Bool
$c> :: JWTException -> JWTException -> Bool
<= :: JWTException -> JWTException -> Bool
$c<= :: JWTException -> JWTException -> Bool
< :: JWTException -> JWTException -> Bool
$c< :: JWTException -> JWTException -> Bool
compare :: JWTException -> JWTException -> Ordering
$ccompare :: JWTException -> JWTException -> Ordering
Ord, forall x. Rep JWTException x -> JWTException
forall x. JWTException -> Rep JWTException x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep JWTException x -> JWTException
$cfrom :: forall x. JWTException -> Rep JWTException x
Generic, Typeable)

instance Show JWTException where
  show :: JWTException -> String
show = \case
    JEMalformedJWT Text
jt -> [String] -> String
unwords [String
"Cannot decode JWT token :", Text -> String
T.unpack Text
jt]
    JEClaimNotFound String
c -> [String] -> String
unwords [String
"JWT claim not found :", String
c]
    JEAudienceNotFound ApiAudience
a -> [String] -> String
unwords [String
"audience", forall a. Show a => a -> String
show ApiAudience
a, String
"not found"]
    JEExpiredToken UTCTime
t -> [String] -> String
unwords [String
"JWT token expired on", forall a. Show a => a -> String
show UTCTime
t]
    JENotYetValid UTCTime
t -> [String] -> String
unwords [String
"JWT token not yet valid:", forall a. Show a => a -> String
show UTCTime
t]
    JWTException
JENoToken -> String
"No token found"
instance Exception JWTException
instance A.ToJSON JWTException

fromAud :: Maybe (Either J.StringOrURI [J.StringOrURI]) -> Maybe T.Text
fromAud :: Maybe (Either StringOrURI [StringOrURI]) -> Maybe Text
fromAud Maybe (Either StringOrURI [StringOrURI])
mm = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing Either StringOrURI [StringOrURI] -> Maybe Text
f Maybe (Either StringOrURI [StringOrURI])
mm
  where
    g :: a -> Maybe Text
g a
str = case forall a. ToJSON a => a -> Value
A.toJSON a
str of
      A.String Text
s -> forall a. a -> Maybe a
Just Text
s
      Value
_ -> forall a. Maybe a
Nothing
    f :: Either StringOrURI [StringOrURI] -> Maybe Text
f = \case
      Left StringOrURI
sou -> forall {a}. ToJSON a => a -> Maybe Text
g StringOrURI
sou
      Right [StringOrURI]
sous -> forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall {a}. ToJSON a => a -> Maybe Text
g [StringOrURI]
sous

fromNumericDate :: Maybe J.NumericDate -> Maybe UTCTime
fromNumericDate :: Maybe NumericDate -> Maybe UTCTime
fromNumericDate Maybe NumericDate
tjm = case forall a. ToJSON a => a -> Value
A.toJSON Maybe NumericDate
tjm of
  A.Number Scientific
x -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> UTCTime -> UTCTime
addUTCTime (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Scientific -> Integer
coefficient Scientific
x) UTCTime
epoch
  Value
_ -> forall a. Maybe a
Nothing

fromStringOrUri :: (A.ToJSON a) => Maybe a -> Maybe T.Text
fromStringOrUri :: forall a. ToJSON a => Maybe a -> Maybe Text
fromStringOrUri Maybe a
sm = case forall a. ToJSON a => a -> Value
A.toJSON Maybe a
sm of
  A.String Text
t -> forall a. a -> Maybe a
Just Text
t
  Value
_ -> forall a. Maybe a
Nothing

epoch :: UTCTime
epoch :: UTCTime
epoch = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Int -> Int -> Day
fromGregorian Integer
1970 Int
1 Int
1) DiffTime
0