{-# Language DeriveFunctor #-}
{-# language DeriveGeneric #-}
{-# language DerivingStrategies #-}
{-# language GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# language OverloadedStrings #-}
module Network.OAuth2.JWT 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
import qualified Data.Aeson as A (FromJSON(..), ToJSON(..), ToJSONKey(..), FromJSON(..), FromJSONKey(..), Value(..))
import qualified Data.Map.Strict as M (Map, lookup)
import qualified Web.JWT as J (decode, claims, JWTClaimsSet(..), StringOrURI, NumericDate, ClaimsMap(..))
import Data.Scientific (coefficient)
import qualified Data.Text as T (Text, unpack)
import Data.Time (UTCTime(..), NominalDiffTime, getCurrentTime, fromGregorian, addUTCTime, diffUTCTime)
import Validation (Validation(..), failure, validationToEither, maybeToSuccess)
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)
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
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
data JWTClaims =
JWTClaims {
JWTClaims -> Text
jcAud :: T.Text
, JWTClaims -> UTCTime
jcExp :: UTCTime
, JWTClaims -> UTCTime
jcIat :: UTCTime
, JWTClaims -> UTCTime
jcNbf :: UTCTime
, JWTClaims -> UserSub
jcSub :: UserSub
, 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)
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)
decValidExp :: Maybe NominalDiffTime
-> UTCTime
-> 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
decValidNbf :: UTCTime -> 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
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)
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
bindValidation :: Validation e a -> (a -> Validation e b) -> Validation e b
bindValidation :: forall e a b.
Validation e a -> (a -> Validation e b) -> Validation e b
bindValidation Validation e a
v a -> Validation e b
f = case Validation e a
v of
Failure e
e -> forall e a. e -> Validation e a
Failure e
e
Success a
a -> a -> Validation e b
f a
a
decodeValidateJWT :: MonadIO f =>
ApiAudience
-> Maybe NominalDiffTime
-> T.Text
-> 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
validateJWT :: MonadIO m =>
ApiAudience
-> 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)
)
validateExp :: Maybe NominalDiffTime
-> 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)
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)
validateAud :: ApiAudience
-> T.Text
-> 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.:| [])
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