{-# LANGUAGE OverloadedStrings, DeriveGeneric, FlexibleContexts #-}
{-# OPTIONS_HADDOCK prune #-}

module Jose.Types
    ( Jwt (..)
    , Jwe
    , Jws
    , JwtClaims (..)
    , JwtHeader (..)
    , JwsHeader (..)
    , JweHeader (..)
    , JwtContent (..)
    , JwtEncoding (..)
    , JwtError (..)
    , IntDate (..)
    , Payload (..)
    , KeyId (..)
    , parseHeader
    , encodeHeader
    , defJwsHdr
    , defJweHdr
    )
where

import Control.Applicative
import Data.Aeson
import Data.Aeson.Types
import Data.Char (toUpper, toLower)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as H
import Data.Int (Int64)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Vector (singleton)
import GHC.Generics

import Jose.Jwa (JweAlg(..), JwsAlg (..), Enc(..))

-- | An encoded JWT.
newtype Jwt = Jwt { Jwt -> ByteString
unJwt :: ByteString } deriving (Int -> Jwt -> ShowS
[Jwt] -> ShowS
Jwt -> String
(Int -> Jwt -> ShowS)
-> (Jwt -> String) -> ([Jwt] -> ShowS) -> Show Jwt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Jwt] -> ShowS
$cshowList :: [Jwt] -> ShowS
show :: Jwt -> String
$cshow :: Jwt -> String
showsPrec :: Int -> Jwt -> ShowS
$cshowsPrec :: Int -> Jwt -> ShowS
Show, Jwt -> Jwt -> Bool
(Jwt -> Jwt -> Bool) -> (Jwt -> Jwt -> Bool) -> Eq Jwt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Jwt -> Jwt -> Bool
$c/= :: Jwt -> Jwt -> Bool
== :: Jwt -> Jwt -> Bool
$c== :: Jwt -> Jwt -> Bool
Eq)

-- | The payload to be encoded in a JWT.
data Payload = Nested Jwt
             | Claims ByteString
             deriving (Int -> Payload -> ShowS
[Payload] -> ShowS
Payload -> String
(Int -> Payload -> ShowS)
-> (Payload -> String) -> ([Payload] -> ShowS) -> Show Payload
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Payload] -> ShowS
$cshowList :: [Payload] -> ShowS
show :: Payload -> String
$cshow :: Payload -> String
showsPrec :: Int -> Payload -> ShowS
$cshowsPrec :: Int -> Payload -> ShowS
Show, Payload -> Payload -> Bool
(Payload -> Payload -> Bool)
-> (Payload -> Payload -> Bool) -> Eq Payload
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Payload -> Payload -> Bool
$c/= :: Payload -> Payload -> Bool
== :: Payload -> Payload -> Bool
$c== :: Payload -> Payload -> Bool
Eq)

-- | The header and claims of a decoded JWS.
type Jws = (JwsHeader, ByteString)

-- | The header and claims of a decoded JWE.
type Jwe = (JweHeader, ByteString)

-- | A decoded JWT which can be either a JWE or a JWS, or an unsecured JWT.
data JwtContent = Unsecured !ByteString | Jws !Jws | Jwe !Jwe deriving (Int -> JwtContent -> ShowS
[JwtContent] -> ShowS
JwtContent -> String
(Int -> JwtContent -> ShowS)
-> (JwtContent -> String)
-> ([JwtContent] -> ShowS)
-> Show JwtContent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JwtContent] -> ShowS
$cshowList :: [JwtContent] -> ShowS
show :: JwtContent -> String
$cshow :: JwtContent -> String
showsPrec :: Int -> JwtContent -> ShowS
$cshowsPrec :: Int -> JwtContent -> ShowS
Show, JwtContent -> JwtContent -> Bool
(JwtContent -> JwtContent -> Bool)
-> (JwtContent -> JwtContent -> Bool) -> Eq JwtContent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JwtContent -> JwtContent -> Bool
$c/= :: JwtContent -> JwtContent -> Bool
== :: JwtContent -> JwtContent -> Bool
$c== :: JwtContent -> JwtContent -> Bool
Eq)

-- | Defines the encoding information for a JWT.
--
-- Used for both encoding new JWTs and validating existing ones.
data JwtEncoding
    = JwsEncoding JwsAlg
    | JweEncoding JweAlg Enc
      deriving (JwtEncoding -> JwtEncoding -> Bool
(JwtEncoding -> JwtEncoding -> Bool)
-> (JwtEncoding -> JwtEncoding -> Bool) -> Eq JwtEncoding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JwtEncoding -> JwtEncoding -> Bool
$c/= :: JwtEncoding -> JwtEncoding -> Bool
== :: JwtEncoding -> JwtEncoding -> Bool
$c== :: JwtEncoding -> JwtEncoding -> Bool
Eq, Int -> JwtEncoding -> ShowS
[JwtEncoding] -> ShowS
JwtEncoding -> String
(Int -> JwtEncoding -> ShowS)
-> (JwtEncoding -> String)
-> ([JwtEncoding] -> ShowS)
-> Show JwtEncoding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JwtEncoding] -> ShowS
$cshowList :: [JwtEncoding] -> ShowS
show :: JwtEncoding -> String
$cshow :: JwtEncoding -> String
showsPrec :: Int -> JwtEncoding -> ShowS
$cshowsPrec :: Int -> JwtEncoding -> ShowS
Show)

data JwtHeader = JweH JweHeader
               | JwsH JwsHeader
               | UnsecuredH
                 deriving (Int -> JwtHeader -> ShowS
[JwtHeader] -> ShowS
JwtHeader -> String
(Int -> JwtHeader -> ShowS)
-> (JwtHeader -> String)
-> ([JwtHeader] -> ShowS)
-> Show JwtHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JwtHeader] -> ShowS
$cshowList :: [JwtHeader] -> ShowS
show :: JwtHeader -> String
$cshow :: JwtHeader -> String
showsPrec :: Int -> JwtHeader -> ShowS
$cshowsPrec :: Int -> JwtHeader -> ShowS
Show)

data KeyId
    = KeyId    Text
    | UTCKeyId UTCTime
      deriving (KeyId -> KeyId -> Bool
(KeyId -> KeyId -> Bool) -> (KeyId -> KeyId -> Bool) -> Eq KeyId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyId -> KeyId -> Bool
$c/= :: KeyId -> KeyId -> Bool
== :: KeyId -> KeyId -> Bool
$c== :: KeyId -> KeyId -> Bool
Eq, Int -> KeyId -> ShowS
[KeyId] -> ShowS
KeyId -> String
(Int -> KeyId -> ShowS)
-> (KeyId -> String) -> ([KeyId] -> ShowS) -> Show KeyId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyId] -> ShowS
$cshowList :: [KeyId] -> ShowS
show :: KeyId -> String
$cshow :: KeyId -> String
showsPrec :: Int -> KeyId -> ShowS
$cshowsPrec :: Int -> KeyId -> ShowS
Show, Eq KeyId
Eq KeyId
-> (KeyId -> KeyId -> Ordering)
-> (KeyId -> KeyId -> Bool)
-> (KeyId -> KeyId -> Bool)
-> (KeyId -> KeyId -> Bool)
-> (KeyId -> KeyId -> Bool)
-> (KeyId -> KeyId -> KeyId)
-> (KeyId -> KeyId -> KeyId)
-> Ord KeyId
KeyId -> KeyId -> Bool
KeyId -> KeyId -> Ordering
KeyId -> KeyId -> KeyId
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 :: KeyId -> KeyId -> KeyId
$cmin :: KeyId -> KeyId -> KeyId
max :: KeyId -> KeyId -> KeyId
$cmax :: KeyId -> KeyId -> KeyId
>= :: KeyId -> KeyId -> Bool
$c>= :: KeyId -> KeyId -> Bool
> :: KeyId -> KeyId -> Bool
$c> :: KeyId -> KeyId -> Bool
<= :: KeyId -> KeyId -> Bool
$c<= :: KeyId -> KeyId -> Bool
< :: KeyId -> KeyId -> Bool
$c< :: KeyId -> KeyId -> Bool
compare :: KeyId -> KeyId -> Ordering
$ccompare :: KeyId -> KeyId -> Ordering
$cp1Ord :: Eq KeyId
Ord)

instance ToJSON KeyId
  where
    toJSON :: KeyId -> Value
toJSON (KeyId Text
t)    = Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
t
    toJSON (UTCKeyId UTCTime
t) = UTCTime -> Value
forall a. ToJSON a => a -> Value
toJSON UTCTime
t

instance FromJSON KeyId
  where
    parseJSON :: Value -> Parser KeyId
parseJSON = String -> (Text -> Parser KeyId) -> Value -> Parser KeyId
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"KeyId" ((Text -> Parser KeyId) -> Value -> Parser KeyId)
-> (Text -> Parser KeyId) -> Value -> Parser KeyId
forall a b. (a -> b) -> a -> b
$ \Text
t -> do
        let asTime :: Result UTCTime
asTime = Value -> Result UTCTime
forall a. FromJSON a => Value -> Result a
fromJSON (Text -> Value
String Text
t) :: Result UTCTime
        case Result UTCTime
asTime of
            Success UTCTime
d -> KeyId -> Parser KeyId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> KeyId
UTCKeyId UTCTime
d)
            Result UTCTime
_         -> KeyId -> Parser KeyId
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> KeyId
KeyId Text
t)

-- | Header content for a JWS.
data JwsHeader = JwsHeader {
    JwsHeader -> JwsAlg
jwsAlg :: JwsAlg
  , JwsHeader -> Maybe Text
jwsTyp :: Maybe Text
  , JwsHeader -> Maybe Text
jwsCty :: Maybe Text
  , JwsHeader -> Maybe KeyId
jwsKid :: Maybe KeyId
  } deriving (JwsHeader -> JwsHeader -> Bool
(JwsHeader -> JwsHeader -> Bool)
-> (JwsHeader -> JwsHeader -> Bool) -> Eq JwsHeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JwsHeader -> JwsHeader -> Bool
$c/= :: JwsHeader -> JwsHeader -> Bool
== :: JwsHeader -> JwsHeader -> Bool
$c== :: JwsHeader -> JwsHeader -> Bool
Eq, Int -> JwsHeader -> ShowS
[JwsHeader] -> ShowS
JwsHeader -> String
(Int -> JwsHeader -> ShowS)
-> (JwsHeader -> String)
-> ([JwsHeader] -> ShowS)
-> Show JwsHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JwsHeader] -> ShowS
$cshowList :: [JwsHeader] -> ShowS
show :: JwsHeader -> String
$cshow :: JwsHeader -> String
showsPrec :: Int -> JwsHeader -> ShowS
$cshowsPrec :: Int -> JwsHeader -> ShowS
Show, (forall x. JwsHeader -> Rep JwsHeader x)
-> (forall x. Rep JwsHeader x -> JwsHeader) -> Generic JwsHeader
forall x. Rep JwsHeader x -> JwsHeader
forall x. JwsHeader -> Rep JwsHeader x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep JwsHeader x -> JwsHeader
$cfrom :: forall x. JwsHeader -> Rep JwsHeader x
Generic)

-- | Header content for a JWE.
data JweHeader = JweHeader {
    JweHeader -> JweAlg
jweAlg :: JweAlg
  , JweHeader -> Enc
jweEnc :: Enc
  , JweHeader -> Maybe Text
jweTyp :: Maybe Text
  , JweHeader -> Maybe Text
jweCty :: Maybe Text
  , JweHeader -> Maybe Text
jweZip :: Maybe Text
  , JweHeader -> Maybe KeyId
jweKid :: Maybe KeyId
  } deriving (JweHeader -> JweHeader -> Bool
(JweHeader -> JweHeader -> Bool)
-> (JweHeader -> JweHeader -> Bool) -> Eq JweHeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JweHeader -> JweHeader -> Bool
$c/= :: JweHeader -> JweHeader -> Bool
== :: JweHeader -> JweHeader -> Bool
$c== :: JweHeader -> JweHeader -> Bool
Eq, Int -> JweHeader -> ShowS
[JweHeader] -> ShowS
JweHeader -> String
(Int -> JweHeader -> ShowS)
-> (JweHeader -> String)
-> ([JweHeader] -> ShowS)
-> Show JweHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JweHeader] -> ShowS
$cshowList :: [JweHeader] -> ShowS
show :: JweHeader -> String
$cshow :: JweHeader -> String
showsPrec :: Int -> JweHeader -> ShowS
$cshowsPrec :: Int -> JweHeader -> ShowS
Show, (forall x. JweHeader -> Rep JweHeader x)
-> (forall x. Rep JweHeader x -> JweHeader) -> Generic JweHeader
forall x. Rep JweHeader x -> JweHeader
forall x. JweHeader -> Rep JweHeader x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep JweHeader x -> JweHeader
$cfrom :: forall x. JweHeader -> Rep JweHeader x
Generic)

newtype IntDate = IntDate POSIXTime deriving (Int -> IntDate -> ShowS
[IntDate] -> ShowS
IntDate -> String
(Int -> IntDate -> ShowS)
-> (IntDate -> String) -> ([IntDate] -> ShowS) -> Show IntDate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [IntDate] -> ShowS
$cshowList :: [IntDate] -> ShowS
show :: IntDate -> String
$cshow :: IntDate -> String
showsPrec :: Int -> IntDate -> ShowS
$cshowsPrec :: Int -> IntDate -> ShowS
Show, IntDate -> IntDate -> Bool
(IntDate -> IntDate -> Bool)
-> (IntDate -> IntDate -> Bool) -> Eq IntDate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IntDate -> IntDate -> Bool
$c/= :: IntDate -> IntDate -> Bool
== :: IntDate -> IntDate -> Bool
$c== :: IntDate -> IntDate -> Bool
Eq, Eq IntDate
Eq IntDate
-> (IntDate -> IntDate -> Ordering)
-> (IntDate -> IntDate -> Bool)
-> (IntDate -> IntDate -> Bool)
-> (IntDate -> IntDate -> Bool)
-> (IntDate -> IntDate -> Bool)
-> (IntDate -> IntDate -> IntDate)
-> (IntDate -> IntDate -> IntDate)
-> Ord IntDate
IntDate -> IntDate -> Bool
IntDate -> IntDate -> Ordering
IntDate -> IntDate -> IntDate
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 :: IntDate -> IntDate -> IntDate
$cmin :: IntDate -> IntDate -> IntDate
max :: IntDate -> IntDate -> IntDate
$cmax :: IntDate -> IntDate -> IntDate
>= :: IntDate -> IntDate -> Bool
$c>= :: IntDate -> IntDate -> Bool
> :: IntDate -> IntDate -> Bool
$c> :: IntDate -> IntDate -> Bool
<= :: IntDate -> IntDate -> Bool
$c<= :: IntDate -> IntDate -> Bool
< :: IntDate -> IntDate -> Bool
$c< :: IntDate -> IntDate -> Bool
compare :: IntDate -> IntDate -> Ordering
$ccompare :: IntDate -> IntDate -> Ordering
$cp1Ord :: Eq IntDate
Ord)

instance FromJSON IntDate where
    parseJSON :: Value -> Parser IntDate
parseJSON = String -> (Scientific -> Parser IntDate) -> Value -> Parser IntDate
forall a. String -> (Scientific -> Parser a) -> Value -> Parser a
withScientific String
"IntDate" ((Scientific -> Parser IntDate) -> Value -> Parser IntDate)
-> (Scientific -> Parser IntDate) -> Value -> Parser IntDate
forall a b. (a -> b) -> a -> b
$ \Scientific
n ->
        IntDate -> Parser IntDate
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntDate -> Parser IntDate)
-> (Int64 -> IntDate) -> Int64 -> Parser IntDate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> IntDate
IntDate (POSIXTime -> IntDate) -> (Int64 -> POSIXTime) -> Int64 -> IntDate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Parser IntDate) -> Int64 -> Parser IntDate
forall a b. (a -> b) -> a -> b
$ (Scientific -> Int64
forall a b. (RealFrac a, Integral b) => a -> b
round Scientific
n :: Int64)

instance ToJSON IntDate where
    toJSON :: IntDate -> Value
toJSON (IntDate POSIXTime
t) = Scientific -> Value
Number (Scientific -> Value) -> Scientific -> Value
forall a b. (a -> b) -> a -> b
$ Int64 -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral (POSIXTime -> Int64
forall a b. (RealFrac a, Integral b) => a -> b
round POSIXTime
t :: Int64)

-- | Registered claims defined in section 4 of the JWT spec.
data JwtClaims = JwtClaims
    { JwtClaims -> Maybe Text
jwtIss :: !(Maybe Text)
    , JwtClaims -> Maybe Text
jwtSub :: !(Maybe Text)
    , JwtClaims -> Maybe [Text]
jwtAud :: !(Maybe [Text])
    , JwtClaims -> Maybe IntDate
jwtExp :: !(Maybe IntDate)
    , JwtClaims -> Maybe IntDate
jwtNbf :: !(Maybe IntDate)
    , JwtClaims -> Maybe IntDate
jwtIat :: !(Maybe IntDate)
    , JwtClaims -> Maybe Text
jwtJti :: !(Maybe Text)
    } deriving (Int -> JwtClaims -> ShowS
[JwtClaims] -> ShowS
JwtClaims -> String
(Int -> JwtClaims -> ShowS)
-> (JwtClaims -> String)
-> ([JwtClaims] -> ShowS)
-> Show JwtClaims
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, (forall x. JwtClaims -> Rep JwtClaims x)
-> (forall x. Rep JwtClaims x -> JwtClaims) -> Generic JwtClaims
forall x. Rep JwtClaims x -> JwtClaims
forall x. JwtClaims -> Rep JwtClaims x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep JwtClaims x -> JwtClaims
$cfrom :: forall x. JwtClaims -> Rep JwtClaims x
Generic)

-- Deal with the case where "aud" may be a single value rather than an array
instance FromJSON JwtClaims where
    parseJSON :: Value -> Parser JwtClaims
parseJSON v :: Value
v@(Object Object
o) = case Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
"aud" Object
o of
        Just (a :: Value
a@(String Text
_)) -> Options -> Value -> Parser JwtClaims
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
claimsOptions (Value -> Parser JwtClaims) -> Value -> Parser JwtClaims
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert Text
"aud" (Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ Value -> Array
forall a. a -> Vector a
singleton Value
a) Object
o
        Maybe Value
_                   -> Options -> Value -> Parser JwtClaims
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
claimsOptions Value
v
    parseJSON Value
_            = String -> Parser JwtClaims
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"JwtClaims must be an object"

instance ToJSON JwtClaims where
    toJSON :: JwtClaims -> Value
toJSON = Options -> JwtClaims -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
claimsOptions

instance ToJSON Jwt where
    toJSON :: Jwt -> Value
toJSON (Jwt ByteString
bytes) = Text -> Value
String (ByteString -> Text
TE.decodeUtf8 ByteString
bytes)

instance FromJSON Jwt where
    parseJSON :: Value -> Parser Jwt
parseJSON (String Text
token) = Jwt -> Parser Jwt
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Jwt -> Parser Jwt) -> Jwt -> Parser Jwt
forall a b. (a -> b) -> a -> b
$ ByteString -> Jwt
Jwt (Text -> ByteString
TE.encodeUtf8 Text
token)
    parseJSON Value
_              = String -> Parser Jwt
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Jwt must be a string"

claimsOptions :: Options
claimsOptions :: Options
claimsOptions = String -> Options
prefixOptions String
"jwt"

defJwsHdr :: JwsHeader
defJwsHdr :: JwsHeader
defJwsHdr = JwsAlg -> Maybe Text -> Maybe Text -> Maybe KeyId -> JwsHeader
JwsHeader JwsAlg
RS256 Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe KeyId
forall a. Maybe a
Nothing

defJweHdr :: JweHeader
defJweHdr :: JweHeader
defJweHdr = JweAlg
-> Enc
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe KeyId
-> JweHeader
JweHeader JweAlg
RSA_OAEP Enc
A128GCM Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe KeyId
forall a. Maybe a
Nothing

-- | Decoding errors.
data JwtError = KeyError Text      -- ^ No suitable key or wrong key type
              | BadAlgorithm Text  -- ^ The supplied algorithm is invalid
              | BadDots Int        -- ^ Wrong number of "." characters in the JWT
              | BadHeader Text     -- ^ Header couldn't be decoded or contains bad data
              | BadClaims          -- ^ Claims part couldn't be decoded or contains bad data
              | BadSignature       -- ^ Signature is invalid
              | BadCrypto          -- ^ A cryptographic operation failed
              | Base64Error String -- ^ A base64 decoding error
                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)

instance ToJSON JwsHeader where
    toJSON :: JwsHeader -> Value
toJSON = Options -> JwsHeader -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
jwsOptions

instance FromJSON JwsHeader where
    parseJSON :: Value -> Parser JwsHeader
parseJSON = Options -> Value -> Parser JwsHeader
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
jwsOptions

instance ToJSON JweHeader where
    toJSON :: JweHeader -> Value
toJSON = Options -> JweHeader -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
jweOptions

instance FromJSON JweHeader where
    parseJSON :: Value -> Parser JweHeader
parseJSON = Options -> Value -> Parser JweHeader
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
jweOptions

instance FromJSON JwtHeader where
    parseJSON :: Value -> Parser JwtHeader
parseJSON v :: Value
v@(Object Object
o) = case Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
"alg" Object
o of
        Just (String Text
"none") -> JwtHeader -> Parser JwtHeader
forall (f :: * -> *) a. Applicative f => a -> f a
pure JwtHeader
UnsecuredH
        Maybe Value
_                    -> case Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
"enc" Object
o of
            Maybe Value
Nothing -> JwsHeader -> JwtHeader
JwsH (JwsHeader -> JwtHeader) -> Parser JwsHeader -> Parser JwtHeader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser JwsHeader
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
            Maybe Value
_       -> JweHeader -> JwtHeader
JweH (JweHeader -> JwtHeader) -> Parser JweHeader -> Parser JwtHeader
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser JweHeader
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
    parseJSON Value
_            = String -> Parser JwtHeader
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"JwtHeader must be an object"

encodeHeader :: ToJSON a => a -> ByteString
encodeHeader :: a -> ByteString
encodeHeader a
h = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
h

parseHeader :: ByteString -> Either JwtError JwtHeader
parseHeader :: ByteString -> Either JwtError JwtHeader
parseHeader ByteString
hdr = (String -> Either JwtError JwtHeader)
-> (JwtHeader -> Either JwtError JwtHeader)
-> Either String JwtHeader
-> Either JwtError JwtHeader
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (JwtError -> Either JwtError JwtHeader
forall a b. a -> Either a b
Left (JwtError -> Either JwtError JwtHeader)
-> (String -> JwtError) -> String -> Either JwtError JwtHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> JwtError
BadHeader (Text -> JwtError) -> (String -> Text) -> String -> JwtError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) JwtHeader -> Either JwtError JwtHeader
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String JwtHeader -> Either JwtError JwtHeader)
-> Either String JwtHeader -> Either JwtError JwtHeader
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String JwtHeader
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict' ByteString
hdr

jwsOptions :: Options
jwsOptions :: Options
jwsOptions = String -> Options
prefixOptions String
"jws"

jweOptions :: Options
jweOptions :: Options
jweOptions = String -> Options
prefixOptions String
"jwe"

prefixOptions :: String -> Options
prefixOptions :: String -> Options
prefixOptions String
prefix = Options
omitNothingOptions
    { fieldLabelModifier :: ShowS
fieldLabelModifier     = Int -> ShowS
dropPrefix (Int -> ShowS) -> Int -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prefix
    , constructorTagModifier :: ShowS
constructorTagModifier = String -> ShowS
addPrefix String
prefix
    }
  where
    omitNothingOptions :: Options
omitNothingOptions = Options
defaultOptions { omitNothingFields :: Bool
omitNothingFields = Bool
True }
    dropPrefix :: Int -> ShowS
dropPrefix Int
l String
s = let remainder :: String
remainder = Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
l String
s
                     in  (Char -> Char
toLower (Char -> Char) -> (String -> Char) -> String -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Char
forall a. [a] -> a
head) String
remainder Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
forall a. [a] -> [a]
tail String
remainder

    addPrefix :: String -> ShowS
addPrefix String
p String
s  = String
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> Char
toUpper (String -> Char
forall a. [a] -> a
head String
s) Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
forall a. [a] -> [a]
tail String
s