{-# LANGUAGE CPP                #-}
{-# LANGUAGE EmptyDataDecls     #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RankNTypes         #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE StandaloneDeriving #-}

{-|
Module:      Web.JWT
License:     MIT
Maintainer:  Stefan Saasen <stefan@saasen.me>
Stability:   experimental

This implementation of JWT is based on <https://tools.ietf.org/html/rfc7519>
but currently only implements the minimum required to work with the Atlassian Connect framework and GitHub App

Known limitations:

   * Only HMAC SHA-256 and RSA SHA-256 algorithms are currently a supported signature algorithm

   * There is currently no verification of time related information
   ('exp', 'nbf', 'iat').

   * Registered claims are not validated
-}
module Web.JWT
    (
    -- * Encoding & Decoding JWTs
    -- ** Decoding
    -- $docDecoding
      decode
    , verify
    , decodeAndVerifySignature
    -- ** Encoding
    , encodeSigned
    , encodeUnsigned

    -- * Utility functions
    -- ** Common
    , tokenIssuer
    , hmacSecret
    , readRsaSecret
    -- ** JWT structure
    , claims
    , header
    , signature
    -- ** JWT claims set
    , auds
    , intDate
    , numericDate
    , stringOrURI
    , stringOrURIToText
    , secondsSinceEpoch

    -- * Types
    , UnverifiedJWT
    , VerifiedJWT
    , Signature
    , Signer(..)
    , JWT
    , Algorithm(..)
    , JWTClaimsSet(..)
    , ClaimsMap(..)
    , IntDate
    , NumericDate
    , StringOrURI
    , JWTHeader
    , JOSEHeader(..)

    -- * Deprecated
    , rsaKeySecret
    ) where

import           Data.Bifunctor             (first)
import qualified Data.ByteString.Char8      as C8
import qualified Data.ByteString.Lazy.Char8 as BL (fromStrict, toStrict)
import qualified Data.ByteString.Extended as BS
import qualified Data.Text.Extended         as T
import qualified Data.Text.Encoding         as TE

import           Control.Applicative
import           Control.Monad
import           Crypto.Hash.Algorithms
import           Crypto.MAC.HMAC
import           Crypto.PubKey.RSA          (PrivateKey)
import           Crypto.PubKey.RSA.PKCS15   (sign)
import           Data.ByteArray.Encoding
import           Data.Aeson                 hiding (decode, encode)
import qualified Data.Aeson                 as JSON
import qualified Data.Map                   as Map
import           Data.Maybe
import           Data.Scientific
import qualified Data.Semigroup             as Semigroup
import           Data.Time.Clock            (NominalDiffTime)
import           Data.X509                  (PrivKey (PrivKeyRSA))
import           Data.X509.Memory           (readKeyFileFromMemory)
import qualified Network.URI                as URI
import           Prelude                    hiding (exp)

#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key             as Key
import qualified Data.Aeson.KeyMap          as KeyMap
#else
import qualified Data.HashMap.Strict        as KeyMap
#endif

-- $setup
-- The code examples in this module require GHC's `OverloadedStrings`
-- extension:
--
-- >>> :set -XOverloadedStrings

{-# DEPRECATED JWTHeader "Use JOSEHeader instead. JWTHeader will be removed in 1.0" #-}
type JWTHeader = JOSEHeader

data Signer = HMACSecret BS.ByteString
            | RSAPrivateKey PrivateKey

newtype Signature = Signature T.Text deriving (Int -> Signature -> ShowS
[Signature] -> ShowS
Signature -> String
(Int -> Signature -> ShowS)
-> (Signature -> String)
-> ([Signature] -> ShowS)
-> Show Signature
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Signature] -> ShowS
$cshowList :: [Signature] -> ShowS
show :: Signature -> String
$cshow :: Signature -> String
showsPrec :: Int -> Signature -> ShowS
$cshowsPrec :: Int -> Signature -> ShowS
Show)

instance Eq Signature where
    (Signature Text
s1) == :: Signature -> Signature -> Bool
== (Signature Text
s2) = Text
s1 Text -> Text -> Bool
`T.constTimeCompare` Text
s2

-- | JSON Web Token without signature verification
data UnverifiedJWT

-- | JSON Web Token that has been successfully verified
data VerifiedJWT


-- | The JSON Web Token
data JWT r where
   Unverified :: JWTHeader -> JWTClaimsSet -> Signature -> T.Text -> JWT UnverifiedJWT
   Verified   :: JWTHeader -> JWTClaimsSet -> Signature -> JWT VerifiedJWT

deriving instance Show (JWT r)

-- | Extract the claims set from a JSON Web Token
claims :: JWT r -> JWTClaimsSet
claims :: JWT r -> JWTClaimsSet
claims (Unverified JWTHeader
_ JWTClaimsSet
c Signature
_ Text
_) = JWTClaimsSet
c
claims (Verified JWTHeader
_ JWTClaimsSet
c Signature
_) = JWTClaimsSet
c

-- | Extract the header from a JSON Web Token
header :: JWT r -> JOSEHeader
header :: JWT r -> JWTHeader
header (Unverified JWTHeader
h JWTClaimsSet
_ Signature
_ Text
_) = JWTHeader
h
header (Verified JWTHeader
h JWTClaimsSet
_ Signature
_) = JWTHeader
h

-- | Extract the signature from a verified JSON Web Token
signature :: JWT r -> Maybe Signature
signature :: JWT r -> Maybe Signature
signature Unverified{}     = Maybe Signature
forall a. Maybe a
Nothing
signature (Verified JWTHeader
_ JWTClaimsSet
_ Signature
s) = Signature -> Maybe Signature
forall a. a -> Maybe a
Just Signature
s

-- | A JSON numeric value representing the number of seconds from
-- 1970-01-01T0:0:0Z UTC until the specified UTC date/time.
{-# DEPRECATED IntDate "Use NumericDate instead. IntDate will be removed in 1.0" #-}
type IntDate = NumericDate

-- | 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 Integer deriving (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, 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)


-- | Return the seconds since 1970-01-01T0:0:0Z UTC for the given 'IntDate'
secondsSinceEpoch :: NumericDate -> NominalDiffTime
secondsSinceEpoch :: NumericDate -> NominalDiffTime
secondsSinceEpoch (NumericDate Integer
s) = Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger Integer
s

-- | 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 [RFC3986].  StringOrURI values are
-- compared as case-sensitive strings with no transformations or
-- canonicalizations applied.
data StringOrURI = S T.Text | U URI.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)

instance Show StringOrURI where
    show :: StringOrURI -> String
show (S Text
s) = Text -> String
T.unpack Text
s
    show (U URI
u) = URI -> String
forall a. Show a => a -> String
show URI
u

data Algorithm = HS256 -- ^ HMAC using SHA-256 hash algorithm
               | RS256 -- ^ RSA using SHA-256 hash algorithm
                 deriving (Algorithm -> Algorithm -> Bool
(Algorithm -> Algorithm -> Bool)
-> (Algorithm -> Algorithm -> Bool) -> Eq Algorithm
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Algorithm -> Algorithm -> Bool
$c/= :: Algorithm -> Algorithm -> Bool
== :: Algorithm -> Algorithm -> Bool
$c== :: Algorithm -> Algorithm -> Bool
Eq, Int -> Algorithm -> ShowS
[Algorithm] -> ShowS
Algorithm -> String
(Int -> Algorithm -> ShowS)
-> (Algorithm -> String)
-> ([Algorithm] -> ShowS)
-> Show Algorithm
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Algorithm] -> ShowS
$cshowList :: [Algorithm] -> ShowS
show :: Algorithm -> String
$cshow :: Algorithm -> String
showsPrec :: Int -> Algorithm -> ShowS
$cshowsPrec :: Int -> Algorithm -> ShowS
Show)

-- | JOSE Header, describes the cryptographic operations applied to the JWT
data JOSEHeader = JOSEHeader {
    -- | The typ (type) Header Parameter defined by [JWS] and [JWE] is used to
    -- declare the MIME Media Type [IANA.MediaTypes] of this complete JWT in
    -- contexts where this is useful to the application.
    -- This parameter has no effect upon the JWT processing.
    JWTHeader -> Maybe Text
typ :: Maybe T.Text
    -- | The cty (content type) Header Parameter defined by [JWS] and [JWE] is
    -- used by this specification to convey structural information about the JWT.
  , JWTHeader -> Maybe Text
cty :: Maybe T.Text
    -- | The alg (algorithm) used for signing the JWT. The HS256 (HMAC using
    -- SHA-256) is the only required algorithm in addition to "none" which means
    -- that no signature will be used.
    --
    -- See <http://tools.ietf.org/html/draft-ietf-jose-json-web-algorithms-23#page-6>
  , JWTHeader -> Maybe Algorithm
alg :: Maybe Algorithm
    -- | The "kid" (key ID) Header Parameter is a hint indicating which key
    -- was used to secure the JWS.  This parameter allows originators to
    -- explicitly signal a change of key to recipients.  The structure of
    -- the "kid" value is unspecified.  Its value MUST be a case-sensitive
    -- string.  Use of this Header Parameter is OPTIONAL.
    --
    -- See <https://tools.ietf.org/html/rfc7515#section-4.1.4>
  , JWTHeader -> Maybe Text
kid :: Maybe T.Text
} deriving (JWTHeader -> JWTHeader -> Bool
(JWTHeader -> JWTHeader -> Bool)
-> (JWTHeader -> JWTHeader -> Bool) -> Eq JWTHeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JWTHeader -> JWTHeader -> Bool
$c/= :: JWTHeader -> JWTHeader -> Bool
== :: JWTHeader -> JWTHeader -> Bool
$c== :: JWTHeader -> JWTHeader -> Bool
Eq, 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)

instance Monoid JOSEHeader where
    mempty :: JWTHeader
mempty =
      Maybe Text
-> Maybe Text -> Maybe Algorithm -> Maybe Text -> JWTHeader
JOSEHeader Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe Algorithm
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing
    mappend :: JWTHeader -> JWTHeader -> JWTHeader
mappend = JWTHeader -> JWTHeader -> JWTHeader
forall a. Semigroup a => a -> a -> a
(Semigroup.<>)

instance Semigroup.Semigroup JOSEHeader where
  JOSEHeader Maybe Text
a Maybe Text
b Maybe Algorithm
c Maybe Text
d <> :: JWTHeader -> JWTHeader -> JWTHeader
<> JOSEHeader Maybe Text
a' Maybe Text
b' Maybe Algorithm
c' Maybe Text
d' =
    Maybe Text
-> Maybe Text -> Maybe Algorithm -> Maybe Text -> JWTHeader
JOSEHeader (Maybe Text
a Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Text
a') (Maybe Text
b Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Text
b') (Maybe Algorithm
c Maybe Algorithm -> Maybe Algorithm -> Maybe Algorithm
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Algorithm
c') (Maybe Text
d Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Text
d')

-- | The JWT Claims Set represents a JSON object whose members are the claims conveyed by the JWT.
data JWTClaimsSet = JWTClaimsSet {
    -- Registered Claim Names
    -- http://self-issued.info/docs/draft-ietf-oauth-json-web-token.html#ClaimsContents

    -- | The iss (issuer) claim identifies the principal that issued the JWT.
    JWTClaimsSet -> Maybe StringOrURI
iss                :: Maybe StringOrURI

    -- | The sub (subject) claim identifies the principal that is the subject of the JWT.
  , JWTClaimsSet -> Maybe StringOrURI
sub                :: Maybe StringOrURI

    -- | The aud (audience) claim identifies the audiences that the JWT is intended for according to draft 18 of the JWT spec, the aud claim is option and may be present in singular or as a list.
  , JWTClaimsSet -> Maybe (Either StringOrURI [StringOrURI])
aud                :: Maybe (Either StringOrURI [StringOrURI])

    -- | The exp (expiration time) claim identifies the expiration time on or after which the JWT MUST NOT be accepted for processing. Its value MUST be a number containing an IntDate value.
  , JWTClaimsSet -> Maybe NumericDate
exp                :: Maybe IntDate

    -- | The nbf (not before) claim identifies the time before which the JWT MUST NOT be accepted for processing.
  , JWTClaimsSet -> Maybe NumericDate
nbf                :: Maybe IntDate

    -- | The iat (issued at) claim identifies the time at which the JWT was issued.
  , JWTClaimsSet -> Maybe NumericDate
iat                :: Maybe IntDate

    -- | The jti (JWT ID) claim provides a unique identifier for the JWT.
  , JWTClaimsSet -> Maybe StringOrURI
jti                :: Maybe StringOrURI

  , JWTClaimsSet -> ClaimsMap
unregisteredClaims :: ClaimsMap

} deriving (Int -> JWTClaimsSet -> ShowS
[JWTClaimsSet] -> ShowS
JWTClaimsSet -> String
(Int -> JWTClaimsSet -> ShowS)
-> (JWTClaimsSet -> String)
-> ([JWTClaimsSet] -> ShowS)
-> Show JWTClaimsSet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JWTClaimsSet] -> ShowS
$cshowList :: [JWTClaimsSet] -> ShowS
show :: JWTClaimsSet -> String
$cshow :: JWTClaimsSet -> String
showsPrec :: Int -> JWTClaimsSet -> ShowS
$cshowsPrec :: Int -> JWTClaimsSet -> ShowS
Show, JWTClaimsSet -> JWTClaimsSet -> Bool
(JWTClaimsSet -> JWTClaimsSet -> Bool)
-> (JWTClaimsSet -> JWTClaimsSet -> Bool) -> Eq JWTClaimsSet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JWTClaimsSet -> JWTClaimsSet -> Bool
$c/= :: JWTClaimsSet -> JWTClaimsSet -> Bool
== :: JWTClaimsSet -> JWTClaimsSet -> Bool
$c== :: JWTClaimsSet -> JWTClaimsSet -> Bool
Eq)

instance Monoid JWTClaimsSet where
  mempty :: JWTClaimsSet
mempty =
    Maybe StringOrURI
-> Maybe StringOrURI
-> Maybe (Either StringOrURI [StringOrURI])
-> Maybe NumericDate
-> Maybe NumericDate
-> Maybe NumericDate
-> Maybe StringOrURI
-> ClaimsMap
-> JWTClaimsSet
JWTClaimsSet Maybe StringOrURI
forall a. Maybe a
Nothing Maybe StringOrURI
forall a. Maybe a
Nothing Maybe (Either StringOrURI [StringOrURI])
forall a. Maybe a
Nothing Maybe NumericDate
forall a. Maybe a
Nothing Maybe NumericDate
forall a. Maybe a
Nothing Maybe NumericDate
forall a. Maybe a
Nothing Maybe StringOrURI
forall a. Maybe a
Nothing (ClaimsMap -> JWTClaimsSet) -> ClaimsMap -> JWTClaimsSet
forall a b. (a -> b) -> a -> b
$ Map Text Value -> ClaimsMap
ClaimsMap Map Text Value
forall k a. Map k a
Map.empty
  mappend :: JWTClaimsSet -> JWTClaimsSet -> JWTClaimsSet
mappend = JWTClaimsSet -> JWTClaimsSet -> JWTClaimsSet
forall a. Semigroup a => a -> a -> a
(Semigroup.<>)

instance Semigroup.Semigroup JWTClaimsSet where
  JWTClaimsSet Maybe StringOrURI
a Maybe StringOrURI
b Maybe (Either StringOrURI [StringOrURI])
c Maybe NumericDate
d Maybe NumericDate
e Maybe NumericDate
f Maybe StringOrURI
g ClaimsMap
h <> :: JWTClaimsSet -> JWTClaimsSet -> JWTClaimsSet
<> JWTClaimsSet Maybe StringOrURI
a' Maybe StringOrURI
b' Maybe (Either StringOrURI [StringOrURI])
c' Maybe NumericDate
d' Maybe NumericDate
e' Maybe NumericDate
f' Maybe StringOrURI
g' ClaimsMap
h' =
    Maybe StringOrURI
-> Maybe StringOrURI
-> Maybe (Either StringOrURI [StringOrURI])
-> Maybe NumericDate
-> Maybe NumericDate
-> Maybe NumericDate
-> Maybe StringOrURI
-> ClaimsMap
-> JWTClaimsSet
JWTClaimsSet (Maybe StringOrURI
a Maybe StringOrURI -> Maybe StringOrURI -> Maybe StringOrURI
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe StringOrURI
a') (Maybe StringOrURI
b Maybe StringOrURI -> Maybe StringOrURI -> Maybe StringOrURI
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe StringOrURI
b') (Maybe (Either StringOrURI [StringOrURI])
c Maybe (Either StringOrURI [StringOrURI])
-> Maybe (Either StringOrURI [StringOrURI])
-> Maybe (Either StringOrURI [StringOrURI])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Either StringOrURI [StringOrURI])
c') (Maybe NumericDate
d Maybe NumericDate -> Maybe NumericDate -> Maybe NumericDate
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe NumericDate
d') (Maybe NumericDate
e Maybe NumericDate -> Maybe NumericDate -> Maybe NumericDate
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe NumericDate
e') (Maybe NumericDate
f Maybe NumericDate -> Maybe NumericDate -> Maybe NumericDate
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe NumericDate
f') (Maybe StringOrURI
g Maybe StringOrURI -> Maybe StringOrURI -> Maybe StringOrURI
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe StringOrURI
g') (ClaimsMap
h ClaimsMap -> ClaimsMap -> ClaimsMap
forall a. Semigroup a => a -> a -> a
Semigroup.<> ClaimsMap
h')

-- | Encode a claims set using the given secret
--
--  @
--  let
--      cs = mempty { -- mempty returns a default JWTClaimsSet
--         iss = stringOrURI "Foo"
--       , unregisteredClaims = Map.fromList [("http://example.com/is_root", (Bool True))]
--      }
--      key = hmacSecret "secret-key"
--  in encodeSigned key mempty cs
-- @
-- > "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJodHRwOi8vZXhhbXBsZS5jb20vaXNfcm9vdCI6dHJ1ZSwiaXNzIjoiRm9vIn0.vHQHuG3ujbnBUmEp-fSUtYxk27rLiP2hrNhxpyWhb2E"
encodeSigned :: Signer -> JOSEHeader -> JWTClaimsSet -> T.Text
encodeSigned :: Signer -> JWTHeader -> JWTClaimsSet -> Text
encodeSigned Signer
signer JWTHeader
header' JWTClaimsSet
claims' = [Text] -> Text
dotted [Text
header'', Text
claim, Text
signature']
    where claim :: Text
claim     = JWTClaimsSet -> Text
forall a. ToJSON a => a -> Text
encodeJWT JWTClaimsSet
claims'
          algo :: Algorithm
algo      = case Signer
signer of
                        HMACSecret ByteString
_    -> Algorithm
HS256
                        RSAPrivateKey PrivateKey
_ -> Algorithm
RS256

          header'' :: Text
header''  = JWTHeader -> Text
forall a. ToJSON a => a -> Text
encodeJWT JWTHeader
header' {
                        typ :: Maybe Text
typ = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"JWT"
                      , alg :: Maybe Algorithm
alg = Algorithm -> Maybe Algorithm
forall a. a -> Maybe a
Just Algorithm
algo
                      }
          signature' :: Text
signature' = Signer -> Text -> Text
calculateDigest Signer
signer ([Text] -> Text
dotted [Text
header'', Text
claim])

-- | Encode a claims set without signing it
--
--  @
--  let
--      cs = mempty { -- mempty returns a default JWTClaimsSet
--      iss = stringOrURI "Foo"
--    , iat = numericDate 1394700934
--    , unregisteredClaims = Map.fromList [("http://example.com/is_root", (Bool True))]
--  }
--  in encodeUnsigned cs mempty
--  @
-- > "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJpYXQiOjEzOTQ3MDA5MzQsImh0dHA6Ly9leGFtcGxlLmNvbS9pc19yb290Ijp0cnVlLCJpc3MiOiJGb28ifQ."
encodeUnsigned :: JWTClaimsSet -> JOSEHeader -> T.Text
encodeUnsigned :: JWTClaimsSet -> JWTHeader -> Text
encodeUnsigned JWTClaimsSet
claims' JWTHeader
header' = [Text] -> Text
dotted [Text
header'', Text
claim, Text
""]
    where claim :: Text
claim     = JWTClaimsSet -> Text
forall a. ToJSON a => a -> Text
encodeJWT JWTClaimsSet
claims'
          header'' :: Text
header''  = JWTHeader -> Text
forall a. ToJSON a => a -> Text
encodeJWT JWTHeader
header' {
                        typ :: Maybe Text
typ = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"JWT"
                      , alg :: Maybe Algorithm
alg = Algorithm -> Maybe Algorithm
forall a. a -> Maybe a
Just Algorithm
HS256
                      }

-- | Decode a claims set without verifying the signature. This is useful if
-- information from the claim set is required in order to verify the claim
-- (e.g. the secret needs to be retrieved based on unverified information
-- from the claims set).
--
-- >>> :{
--  let
--      input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U" :: T.Text
--      mJwt = decode input
--  in fmap header mJwt
-- :}
-- Just (JOSEHeader {typ = Just "JWT", cty = Nothing, alg = Just HS256, kid = Nothing})
--
-- and
--
-- >>> :{
--  let
--      input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U" :: T.Text
--      mJwt = decode input
--  in fmap claims mJwt
-- :}
-- Just (JWTClaimsSet {iss = Nothing, sub = Nothing, aud = Nothing, exp = Nothing, nbf = Nothing, iat = Nothing, jti = Nothing, unregisteredClaims = ClaimsMap {unClaimsMap = fromList [("some",String "payload")]}})
decode :: T.Text -> Maybe (JWT UnverifiedJWT)
decode :: Text -> Maybe (JWT UnverifiedJWT)
decode Text
input = do
    (Text
h,Text
c,Text
s) <- [Text] -> Maybe (Text, Text, Text)
forall c. [c] -> Maybe (c, c, c)
extractElems ([Text] -> Maybe (Text, Text, Text))
-> [Text] -> Maybe (Text, Text, Text)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"." Text
input
    let header' :: Maybe JWTHeader
header' = Text -> Maybe JWTHeader
forall a. FromJSON a => Text -> Maybe a
parseJWT Text
h
        claims' :: Maybe JWTClaimsSet
claims' = Text -> Maybe JWTClaimsSet
forall a. FromJSON a => Text -> Maybe a
parseJWT Text
c
    JWTHeader -> JWTClaimsSet -> Signature -> Text -> JWT UnverifiedJWT
Unverified (JWTHeader
 -> JWTClaimsSet -> Signature -> Text -> JWT UnverifiedJWT)
-> Maybe JWTHeader
-> Maybe (JWTClaimsSet -> Signature -> Text -> JWT UnverifiedJWT)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe JWTHeader
header' Maybe (JWTClaimsSet -> Signature -> Text -> JWT UnverifiedJWT)
-> Maybe JWTClaimsSet
-> Maybe (Signature -> Text -> JWT UnverifiedJWT)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe JWTClaimsSet
claims' Maybe (Signature -> Text -> JWT UnverifiedJWT)
-> Maybe Signature -> Maybe (Text -> JWT UnverifiedJWT)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Signature -> Maybe Signature
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Signature -> Maybe Signature)
-> (Text -> Signature) -> Text -> Maybe Signature
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Signature
Signature (Text -> Maybe Signature) -> Text -> Maybe Signature
forall a b. (a -> b) -> a -> b
$ Text
s) Maybe (Text -> JWT UnverifiedJWT)
-> Maybe Text -> Maybe (JWT UnverifiedJWT)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Maybe Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text) -> ([Text] -> Text) -> [Text] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
dotted ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Text
h,Text
c])
    where
        extractElems :: [c] -> Maybe (c, c, c)
extractElems (c
h:c
c:c
s:[c]
_) = (c, c, c) -> Maybe (c, c, c)
forall a. a -> Maybe a
Just (c
h,c
c,c
s)
        extractElems [c]
_         = Maybe (c, c, c)
forall a. Maybe a
Nothing

-- | Using a known secret and a decoded claims set verify that the signature is correct
-- and return a verified JWT token as a result.
--
-- This will return a VerifiedJWT if and only if the signature can be verified using the
-- given secret.
--
-- The separation between decode and verify is very useful if you are communicating with
-- multiple different services with different secrets and it allows you to lookup the
-- correct secret for the unverified JWT before trying to verify it. If this is not an
-- isuse for you (there will only ever be one secret) then you should just use
-- 'decodeAndVerifySignature'.
--
-- >>> :{
--  let
--      input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U" :: T.Text
--      mUnverifiedJwt = decode input
--      mVerifiedJwt = verify (hmacSecret "secret") =<< mUnverifiedJwt
--  in signature =<< mVerifiedJwt
-- :}
-- Just (Signature "Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U")
verify :: Signer -> JWT UnverifiedJWT -> Maybe (JWT VerifiedJWT)
verify :: Signer -> JWT UnverifiedJWT -> Maybe (JWT VerifiedJWT)
verify Signer
signer (Unverified JWTHeader
header' JWTClaimsSet
claims' Signature
unverifiedSignature Text
originalClaim) = do
   let calculatedSignature :: Signature
calculatedSignature = Text -> Signature
Signature (Text -> Signature) -> Text -> Signature
forall a b. (a -> b) -> a -> b
$ Signer -> Text -> Text
calculateDigest Signer
signer Text
originalClaim
   Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Signature
unverifiedSignature Signature -> Signature -> Bool
forall a. Eq a => a -> a -> Bool
== Signature
calculatedSignature)
   JWT VerifiedJWT -> Maybe (JWT VerifiedJWT)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JWT VerifiedJWT -> Maybe (JWT VerifiedJWT))
-> JWT VerifiedJWT -> Maybe (JWT VerifiedJWT)
forall a b. (a -> b) -> a -> b
$ JWTHeader -> JWTClaimsSet -> Signature -> JWT VerifiedJWT
Verified JWTHeader
header' JWTClaimsSet
claims' Signature
calculatedSignature

-- | Decode a claims set and verify that the signature matches by using the supplied secret.
-- The algorithm is based on the supplied header value.
--
-- This will return a VerifiedJWT if and only if the signature can be verified
-- using the given secret.
--
-- >>> :{
--  let
--      input = "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ9.eyJzb21lIjoicGF5bG9hZCJ9.Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U" :: T.Text
--      mJwt = decodeAndVerifySignature (hmacSecret "secret") input
--  in signature =<< mJwt
-- :}
-- Just (Signature "Joh1R2dYzkRvDkqv3sygm5YyK8Gi4ShZqbhK2gxcs2U")
decodeAndVerifySignature :: Signer -> T.Text -> Maybe (JWT VerifiedJWT)
decodeAndVerifySignature :: Signer -> Text -> Maybe (JWT VerifiedJWT)
decodeAndVerifySignature Signer
signer Text
input = Signer -> JWT UnverifiedJWT -> Maybe (JWT VerifiedJWT)
verify Signer
signer (JWT UnverifiedJWT -> Maybe (JWT VerifiedJWT))
-> Maybe (JWT UnverifiedJWT) -> Maybe (JWT VerifiedJWT)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Maybe (JWT UnverifiedJWT)
decode Text
input

-- | Try to extract the value for the issue claim field 'iss' from the web token in JSON form
tokenIssuer :: T.Text -> Maybe StringOrURI
tokenIssuer :: Text -> Maybe StringOrURI
tokenIssuer = Text -> Maybe (JWT UnverifiedJWT)
decode (Text -> Maybe (JWT UnverifiedJWT))
-> (JWT UnverifiedJWT -> Maybe StringOrURI)
-> Text
-> Maybe StringOrURI
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (JWTClaimsSet -> Maybe JWTClaimsSet)
-> (JWT UnverifiedJWT -> JWTClaimsSet)
-> JWT UnverifiedJWT
-> Maybe JWTClaimsSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JWTClaimsSet -> Maybe JWTClaimsSet
forall (f :: * -> *) a. Applicative f => a -> f a
pure JWT UnverifiedJWT -> JWTClaimsSet
forall r. JWT r -> JWTClaimsSet
claims (JWT UnverifiedJWT -> Maybe JWTClaimsSet)
-> (JWTClaimsSet -> Maybe StringOrURI)
-> JWT UnverifiedJWT
-> Maybe StringOrURI
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> JWTClaimsSet -> Maybe StringOrURI
iss

-- | Create a Secret using the given key.
-- Consider using `HMACSecret` instead if your key is not already a "Data.Text".
hmacSecret :: T.Text -> Signer
hmacSecret :: Text -> Signer
hmacSecret = ByteString -> Signer
HMACSecret (ByteString -> Signer) -> (Text -> ByteString) -> Text -> Signer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TE.encodeUtf8

-- | Create an RSAPrivateKey from PEM contents
--
-- Please, consider using 'readRsaSecret' instead.
rsaKeySecret :: String -> IO (Maybe Signer)
rsaKeySecret :: String -> IO (Maybe Signer)
rsaKeySecret = Maybe Signer -> IO (Maybe Signer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Signer -> IO (Maybe Signer))
-> (String -> Maybe Signer) -> String -> IO (Maybe Signer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PrivateKey -> Signer) -> Maybe PrivateKey -> Maybe Signer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrivateKey -> Signer
RSAPrivateKey (Maybe PrivateKey -> Maybe Signer)
-> (String -> Maybe PrivateKey) -> String -> Maybe Signer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe PrivateKey
readRsaSecret (ByteString -> Maybe PrivateKey)
-> (String -> ByteString) -> String -> Maybe PrivateKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
C8.pack

-- | Create an RSA 'PrivateKey' from PEM contents
--
-- > readRsaSecret <$> BS.readFile "foo.pem"
--
-- >>> :{
--   -- A random example key created with `ssh-keygen -t rsa`
--   fromJust . readRsaSecret . C8.pack $ unlines
--       [ "-----BEGIN RSA PRIVATE KEY-----"
--       , "MIIEowIBAAKCAQEAkkmgbLluo5HommstpHr1h53uWfuN3CwYYYR6I6a2MzAHIMIv"
--       , "8Ak2ha+N2UDeYsfVhZ/DOnE+PMm2RpYSaiYT0l2a7ZkmRSbcyvVFt3XLePJbmUgo"
--       , "ieyccS4uYHeqRggdWH9His3JaR2N71N9iU0+mY5nu2+15iYw3naT/PSx01IzBqHN"
--       , "Zie1z3FYX09FgOs31mcR8VWj8DefxbKE08AW+vDMT2AmUC2b+Gqk6SqRz29HuPBs"
--       , "yyV4Xl9CgzcCWjuXTv6mevDygo5RVZg34U6L1iFRgwwHbrLcd2N97wlKz+OiDSgM"
--       , "sbZWA0i2D9ZsDR9rdEdXzUIw6toIRYZfeI9QYQIDAQABAoIBAEXkh5Fqx0G/ZLLi"
--       , "olwDo2u4OTkkxxJ6vutYsEJ4VHUAbWdpYB3/SN12kv9JzvbDI3FEc7JoiKPifAQd"
--       , "j47HwpCvyGXc1jwT5UnTBgwxa5XNtZX2s+ex9Mzek6njgqcTGXI+3Z+j0qc2R6og"
--       , "6cm/7jjPoSAcr3vWo2KmpO4muw+LbYoSGo0Jydoa5cGtkmDfsjjrMw7mDoRttdhw"
--       , "WdhS+q2aJPFI7q7itoYUd7KLe3nOeM0zd35Pc8Qc6jGk+JZxQdXrb/NrSNgAATcN"
--       , "GGS226Q444N0pAfc188IDcAtQPSJpzbs/1+TPzE4ov/lpHTr91hXr3RLyVgYBI01"
--       , "jrggfAECgYEAwaC4iDSZQ+8eUx/zR973Lu9mvQxC2BZn6QcOtBcIRBdGRlXfhwuD"
--       , "UgwVZ2M3atH5ZXFuQ7pRtJtj7KCFy7HUFAJC15RCfLjx+n39bISNp5NOJEdI+UM+"
--       , "G2xMHv5ywkULV7Jxb+tSgsYIvJ0tBjACkif8ahNjgVJmgMSOgdHR2pkCgYEAwWkN"
--       , "uquRqKekx4gx1gJYV7Y6tPWcsZpEcgSS7AGNJ4UuGZGGHdStpUoJICn2cFUngYNz"
--       , "eJXOg+VhQJMqQx9c+u85mg/tJluGaw95tBAafspwvhKewlO9OhQeVInPbXMUwrJ0"
--       , "PS3XV7c74nxm6Nn4QHlM07orn3lOiWxZF8BBSQkCgYATjwSU3ZtNvW22v9d3PxKA"
--       , "7zXVitOFuF2usEPP9TOkjSVQHYSCw6r0MrxGwULry2IB2T9mH//42mlxkZVySfg+"
--       , "PSw7UoKUzqnCv89Fku4sKzkNeRXp99ziMEJQLyuwbAEFTsUepQqkoxRm2QmfQmJA"
--       , "GUHqBSNcANLR1wj+HA+yoQKBgQCBlqj7RQ+AaGsQwiFaGhIlGtU1AEgv+4QWvRfQ"
--       , "B64TJ7neqdGp1SFP2U5J/bPASl4A+hl5Vy6a0ysZQEGV3cLH41e98SPdin+C5kiO"
--       , "LCgEghGOWR2EaOUlr+sui3OvCueDGFynzTo27G+0bdPp+nnKgTvHtTqbTIUhsLX1"
--       , "IvzbOQKBgH4q36jgBb9T3hjXtWyrytlmFtBdw0i+UiMvMlnOqujGhcnOk5UMyxOQ"
--       , "sQI+/31jIGbmlE7YaYykR1FH3LzAjO4J1+m7vv5fIRdG8+sI01xTc8UAdbmWtK+5"
--       , "TK1oLP43BHH5gRAfIlXj2qmap5lEG6If/xYB4MOs8Bui5iKaJlM5"
--       , "-----END RSA PRIVATE KEY-----"
--       ]
-- :}
-- PrivateKey {private_pub = PublicKey {public_size = 256, public_n = 1846..., public_e = 65537}, private_d = 8823..., private_p = 135..., private_q = 1358..., private_dP = 1373..., private_dQ = 9100..., private_qinv = 8859...}
--
readRsaSecret :: BS.ByteString -> Maybe PrivateKey
readRsaSecret :: ByteString -> Maybe PrivateKey
readRsaSecret ByteString
bs =
    case ByteString -> [PrivKey]
readKeyFileFromMemory ByteString
bs of
        [(PrivKeyRSA PrivateKey
k)] -> PrivateKey -> Maybe PrivateKey
forall a. a -> Maybe a
Just PrivateKey
k
        [PrivKey]
_                -> Maybe PrivateKey
forall a. Maybe a
Nothing

-- | Convert the `NominalDiffTime` into an IntDate. Returns a Nothing if the
-- argument is invalid (e.g. the NominalDiffTime must be convertible into a
-- positive Integer representing the seconds since epoch).
{-# DEPRECATED intDate "Use numericDate instead. intDate will be removed in 1.0" #-}
intDate :: NominalDiffTime -> Maybe IntDate
intDate :: NominalDiffTime -> Maybe NumericDate
intDate = NominalDiffTime -> Maybe NumericDate
numericDate

-- | Convert the `NominalDiffTime` into an NumericDate. Returns a Nothing if the
-- argument is invalid (e.g. the NominalDiffTime must be convertible into a
-- positive Integer representing the seconds since epoch).
numericDate :: NominalDiffTime -> Maybe NumericDate
numericDate :: NominalDiffTime -> Maybe NumericDate
numericDate NominalDiffTime
i | NominalDiffTime
i NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
0 = Maybe NumericDate
forall a. Maybe a
Nothing
numericDate NominalDiffTime
i         = NumericDate -> Maybe NumericDate
forall a. a -> Maybe a
Just (NumericDate -> Maybe NumericDate)
-> NumericDate -> Maybe NumericDate
forall a b. (a -> b) -> a -> b
$ Integer -> NumericDate
NumericDate (Integer -> NumericDate) -> Integer -> NumericDate
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round NominalDiffTime
i

-- | Convert a `T.Text` into a 'StringOrURI`. Returns a Nothing if the
-- String cannot be converted (e.g. if the String contains a ':' but is
-- *not* a valid URI).
stringOrURI :: T.Text -> Maybe StringOrURI
stringOrURI :: Text -> Maybe StringOrURI
stringOrURI Text
t | String -> Bool
URI.isURI (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t = URI -> StringOrURI
U (URI -> StringOrURI) -> Maybe URI -> Maybe StringOrURI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe URI
URI.parseURI (Text -> String
T.unpack Text
t)
stringOrURI Text
t                          = StringOrURI -> Maybe StringOrURI
forall a. a -> Maybe a
Just (Text -> StringOrURI
S Text
t)


-- | Convert a `StringOrURI` into a `T.Text`. Returns the T.Text
-- representing the String as-is or a Text representation of the URI
-- otherwise.
stringOrURIToText :: StringOrURI -> T.Text
stringOrURIToText :: StringOrURI -> Text
stringOrURIToText (S Text
t)   = Text
t
stringOrURIToText (U URI
uri) = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS -> URI -> ShowS
URI.uriToString ShowS
forall a. a -> a
id URI
uri (String
""::String)

-- | Convert the `aud` claim in a `JWTClaimsSet` into a `[StringOrURI]`
auds :: JWTClaimsSet -> [StringOrURI]
auds :: JWTClaimsSet -> [StringOrURI]
auds JWTClaimsSet
jwt = case JWTClaimsSet -> Maybe (Either StringOrURI [StringOrURI])
aud JWTClaimsSet
jwt of
    Maybe (Either StringOrURI [StringOrURI])
Nothing         -> []
    Just (Left StringOrURI
a)   -> [StringOrURI
a]
    Just (Right [StringOrURI]
as) -> [StringOrURI]
as

-- =================================================================================

encodeJWT :: ToJSON a => a -> T.Text
encodeJWT :: a -> Text
encodeJWT = ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> (a -> ByteString) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base -> ByteString -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64URLUnpadded (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
JSON.encode

parseJWT :: FromJSON a => T.Text -> Maybe a
parseJWT :: Text -> Maybe a
parseJWT Text
x = case Base -> ByteString -> Either String ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base64URLUnpadded (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
x of
               Left String
_  -> Maybe a
forall a. Maybe a
Nothing
               Right ByteString
s -> ByteString -> Maybe a
forall a. FromJSON a => ByteString -> Maybe a
JSON.decode (ByteString -> Maybe a) -> ByteString -> Maybe a
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.fromStrict ByteString
s

dotted :: [T.Text] -> T.Text
dotted :: [Text] -> Text
dotted = Text -> [Text] -> Text
T.intercalate Text
"."


-- =================================================================================

calculateDigest :: Signer -> T.Text -> T.Text
calculateDigest :: Signer -> Text -> Text
calculateDigest (HMACSecret ByteString
key) Text
msg =
    ByteString -> Text
TE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Base -> HMAC SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64URLUnpadded (ByteString -> ByteString -> HMAC SHA256
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
hmac ByteString
key (Text -> ByteString
TE.encodeUtf8 Text
msg) :: HMAC SHA256)

calculateDigest (RSAPrivateKey PrivateKey
key) Text
msg = ByteString -> Text
TE.decodeUtf8
    (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Base -> ByteString -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64URLUnpadded
    (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
sign'
    (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
msg
  where
    sign' :: BS.ByteString -> BS.ByteString
    sign' :: ByteString -> ByteString
sign' ByteString
bs = case Maybe Blinder
-> Maybe SHA256
-> PrivateKey
-> ByteString
-> Either Error ByteString
forall hashAlg.
HashAlgorithmASN1 hashAlg =>
Maybe Blinder
-> Maybe hashAlg
-> PrivateKey
-> ByteString
-> Either Error ByteString
sign Maybe Blinder
forall a. Maybe a
Nothing (SHA256 -> Maybe SHA256
forall a. a -> Maybe a
Just SHA256
SHA256) PrivateKey
key ByteString
bs of
        Right ByteString
sig -> ByteString
sig
        Left  Error
_   -> String -> ByteString
forall a. HasCallStack => String -> a
error String
"impossible"  -- This function can only fail with @SignatureTooLong@,
                                         -- which is impossible because we use a hash.

-- =================================================================================

newtype ClaimsMap = ClaimsMap { ClaimsMap -> Map Text Value
unClaimsMap :: Map.Map T.Text Value }
    deriving (ClaimsMap -> ClaimsMap -> Bool
(ClaimsMap -> ClaimsMap -> Bool)
-> (ClaimsMap -> ClaimsMap -> Bool) -> Eq ClaimsMap
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClaimsMap -> ClaimsMap -> Bool
$c/= :: ClaimsMap -> ClaimsMap -> Bool
== :: ClaimsMap -> ClaimsMap -> Bool
$c== :: ClaimsMap -> ClaimsMap -> Bool
Eq, Int -> ClaimsMap -> ShowS
[ClaimsMap] -> ShowS
ClaimsMap -> String
(Int -> ClaimsMap -> ShowS)
-> (ClaimsMap -> String)
-> ([ClaimsMap] -> ShowS)
-> Show ClaimsMap
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ClaimsMap] -> ShowS
$cshowList :: [ClaimsMap] -> ShowS
show :: ClaimsMap -> String
$cshow :: ClaimsMap -> String
showsPrec :: Int -> ClaimsMap -> ShowS
$cshowsPrec :: Int -> ClaimsMap -> ShowS
Show)

instance Monoid ClaimsMap where
  mempty :: ClaimsMap
mempty =
    Map Text Value -> ClaimsMap
ClaimsMap Map Text Value
forall a. Monoid a => a
mempty
  mappend :: ClaimsMap -> ClaimsMap -> ClaimsMap
mappend = ClaimsMap -> ClaimsMap -> ClaimsMap
forall a. Semigroup a => a -> a -> a
(Semigroup.<>)

instance Semigroup.Semigroup ClaimsMap where
  ClaimsMap Map Text Value
a <> :: ClaimsMap -> ClaimsMap -> ClaimsMap
<> ClaimsMap Map Text Value
b =
    Map Text Value -> ClaimsMap
ClaimsMap (Map Text Value -> ClaimsMap) -> Map Text Value -> ClaimsMap
forall a b. (a -> b) -> a -> b
$ Map Text Value
a Map Text Value -> Map Text Value -> Map Text Value
forall a. Semigroup a => a -> a -> a
Semigroup.<> Map Text Value
b

fromHashMap :: Object -> ClaimsMap
fromHashMap :: Object -> ClaimsMap
fromHashMap = Map Text Value -> ClaimsMap
ClaimsMap (Map Text Value -> ClaimsMap)
-> (Object -> Map Text Value) -> Object -> ClaimsMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Value)] -> Map Text Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Value)] -> Map Text Value)
-> (Object -> [(Text, Value)]) -> Object -> Map Text Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, Value) -> (Text, Value))
-> [(Key, Value)] -> [(Text, Value)]
forall a b. (a -> b) -> [a] -> [b]
map ((Key -> Text) -> (Key, Value) -> (Text, Value)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Key -> Text
toText) ([(Key, Value)] -> [(Text, Value)])
-> (Object -> [(Key, Value)]) -> Object -> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList
  where
#if MIN_VERSION_aeson(2,0,0)
    toText :: Key -> Text
toText = Key -> Text
Key.toText
#else
    toText = id
#endif

removeRegisteredClaims :: ClaimsMap -> ClaimsMap
removeRegisteredClaims :: ClaimsMap -> ClaimsMap
removeRegisteredClaims (ClaimsMap Map Text Value
input) = Map Text Value -> ClaimsMap
ClaimsMap (Map Text Value -> ClaimsMap) -> Map Text Value -> ClaimsMap
forall a b. (a -> b) -> a -> b
$ (Text -> Value -> Value -> Maybe Value)
-> Map Text Value -> Map Text Value -> Map Text Value
forall k a b.
Ord k =>
(k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWithKey (\Text
_ Value
_ Value
_ -> Maybe Value
forall a. Maybe a
Nothing) Map Text Value
input Map Text Value
registeredClaims
    where
        registeredClaims :: Map Text Value
registeredClaims = [(Text, Value)] -> Map Text Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Value)] -> Map Text Value)
-> [(Text, Value)] -> Map Text Value
forall a b. (a -> b) -> a -> b
$ (Text -> (Text, Value)) -> [Text] -> [(Text, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\Text
e -> (Text
e, Value
Null)) [Text
"iss", Text
"sub", Text
"aud", Text
"exp", Text
"nbf", Text
"iat", Text
"jti"]

instance ToJSON JWTClaimsSet where
    toJSON :: JWTClaimsSet -> Value
toJSON JWTClaimsSet{Maybe (Either StringOrURI [StringOrURI])
Maybe StringOrURI
Maybe NumericDate
ClaimsMap
unregisteredClaims :: ClaimsMap
jti :: Maybe StringOrURI
iat :: Maybe NumericDate
nbf :: Maybe NumericDate
exp :: Maybe NumericDate
aud :: Maybe (Either StringOrURI [StringOrURI])
sub :: Maybe StringOrURI
iss :: Maybe StringOrURI
unregisteredClaims :: JWTClaimsSet -> ClaimsMap
jti :: JWTClaimsSet -> Maybe StringOrURI
iat :: JWTClaimsSet -> Maybe NumericDate
nbf :: JWTClaimsSet -> Maybe NumericDate
exp :: JWTClaimsSet -> Maybe NumericDate
aud :: JWTClaimsSet -> Maybe (Either StringOrURI [StringOrURI])
sub :: JWTClaimsSet -> Maybe StringOrURI
iss :: JWTClaimsSet -> Maybe StringOrURI
..} = [(Key, Value)] -> Value
object ([(Key, Value)] -> Value) -> [(Key, Value)] -> Value
forall a b. (a -> b) -> a -> b
$ [Maybe (Key, Value)] -> [(Key, Value)]
forall a. [Maybe a] -> [a]
catMaybes [
                  (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
                , (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
                , (StringOrURI -> (Key, Value))
-> ([StringOrURI] -> (Key, Value))
-> Either StringOrURI [StringOrURI]
-> (Key, Value)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Key
"aud" Key -> StringOrURI -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) (Key
"aud" Key -> [StringOrURI] -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) (Either StringOrURI [StringOrURI] -> (Key, Value))
-> Maybe (Either StringOrURI [StringOrURI]) -> Maybe (Key, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Either StringOrURI [StringOrURI])
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
"nbf" Key -> NumericDate -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) Maybe NumericDate
nbf
                , (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
"jti" Key -> StringOrURI -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) Maybe StringOrURI
jti
            ] [(Key, Value)] -> [(Key, Value)] -> [(Key, Value)]
forall a. [a] -> [a] -> [a]
++ ((Text, Value) -> (Key, Value))
-> [(Text, Value)] -> [(Key, Value)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Key) -> (Text, Value) -> (Key, Value)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Key
fromText) (Map Text Value -> [(Text, Value)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Text Value -> [(Text, Value)])
-> Map Text Value -> [(Text, Value)]
forall a b. (a -> b) -> a -> b
$ ClaimsMap -> Map Text Value
unClaimsMap (ClaimsMap -> Map Text Value) -> ClaimsMap -> Map Text Value
forall a b. (a -> b) -> a -> b
$ ClaimsMap -> ClaimsMap
removeRegisteredClaims ClaimsMap
unregisteredClaims)
      where
#if MIN_VERSION_aeson(2,0,0)
        fromText :: Text -> Key
fromText = Text -> Key
Key.fromText
#else
        fromText = id
#endif

instance FromJSON JWTClaimsSet where
        parseJSON :: Value -> Parser JWTClaimsSet
parseJSON = String
-> (Object -> Parser JWTClaimsSet) -> Value -> Parser JWTClaimsSet
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"JWTClaimsSet"
                     (\Object
o -> Maybe StringOrURI
-> Maybe StringOrURI
-> Maybe (Either StringOrURI [StringOrURI])
-> Maybe NumericDate
-> Maybe NumericDate
-> Maybe NumericDate
-> Maybe StringOrURI
-> ClaimsMap
-> JWTClaimsSet
JWTClaimsSet
                     (Maybe StringOrURI
 -> Maybe StringOrURI
 -> Maybe (Either StringOrURI [StringOrURI])
 -> Maybe NumericDate
 -> Maybe NumericDate
 -> Maybe NumericDate
 -> Maybe StringOrURI
 -> ClaimsMap
 -> JWTClaimsSet)
-> Parser (Maybe StringOrURI)
-> Parser
     (Maybe StringOrURI
      -> Maybe (Either StringOrURI [StringOrURI])
      -> Maybe NumericDate
      -> Maybe NumericDate
      -> Maybe NumericDate
      -> Maybe StringOrURI
      -> ClaimsMap
      -> JWTClaimsSet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe StringOrURI)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"iss"
                     Parser
  (Maybe StringOrURI
   -> Maybe (Either StringOrURI [StringOrURI])
   -> Maybe NumericDate
   -> Maybe NumericDate
   -> Maybe NumericDate
   -> Maybe StringOrURI
   -> ClaimsMap
   -> JWTClaimsSet)
-> Parser (Maybe StringOrURI)
-> Parser
     (Maybe (Either StringOrURI [StringOrURI])
      -> Maybe NumericDate
      -> Maybe NumericDate
      -> Maybe NumericDate
      -> Maybe StringOrURI
      -> ClaimsMap
      -> JWTClaimsSet)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe StringOrURI)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"sub"
                     Parser
  (Maybe (Either StringOrURI [StringOrURI])
   -> Maybe NumericDate
   -> Maybe NumericDate
   -> Maybe NumericDate
   -> Maybe StringOrURI
   -> ClaimsMap
   -> JWTClaimsSet)
-> Parser (Maybe (Either StringOrURI [StringOrURI]))
-> Parser
     (Maybe NumericDate
      -> Maybe NumericDate
      -> Maybe NumericDate
      -> Maybe StringOrURI
      -> ClaimsMap
      -> JWTClaimsSet)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
"aud" Object
o of
                         (Just as :: Value
as@(JSON.Array Array
_)) -> Either StringOrURI [StringOrURI]
-> Maybe (Either StringOrURI [StringOrURI])
forall a. a -> Maybe a
Just (Either StringOrURI [StringOrURI]
 -> Maybe (Either StringOrURI [StringOrURI]))
-> ([StringOrURI] -> Either StringOrURI [StringOrURI])
-> [StringOrURI]
-> Maybe (Either StringOrURI [StringOrURI])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StringOrURI] -> Either StringOrURI [StringOrURI]
forall a b. b -> Either a b
Right ([StringOrURI] -> Maybe (Either StringOrURI [StringOrURI]))
-> Parser [StringOrURI]
-> Parser (Maybe (Either StringOrURI [StringOrURI]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser [StringOrURI]
forall a. FromJSON a => Value -> Parser a
parseJSON Value
as
                         (Just (JSON.String Text
t))   -> Maybe (Either StringOrURI [StringOrURI])
-> Parser (Maybe (Either StringOrURI [StringOrURI]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Either StringOrURI [StringOrURI])
 -> Parser (Maybe (Either StringOrURI [StringOrURI])))
-> Maybe (Either StringOrURI [StringOrURI])
-> Parser (Maybe (Either StringOrURI [StringOrURI]))
forall a b. (a -> b) -> a -> b
$ StringOrURI -> Either StringOrURI [StringOrURI]
forall a b. a -> Either a b
Left (StringOrURI -> Either StringOrURI [StringOrURI])
-> Maybe StringOrURI -> Maybe (Either StringOrURI [StringOrURI])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe StringOrURI
stringOrURI Text
t
                         Maybe Value
_                        -> Maybe (Either StringOrURI [StringOrURI])
-> Parser (Maybe (Either StringOrURI [StringOrURI]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Either StringOrURI [StringOrURI])
forall a. Maybe a
Nothing
                     Parser
  (Maybe NumericDate
   -> Maybe NumericDate
   -> Maybe NumericDate
   -> Maybe StringOrURI
   -> ClaimsMap
   -> JWTClaimsSet)
-> Parser (Maybe NumericDate)
-> Parser
     (Maybe NumericDate
      -> Maybe NumericDate
      -> Maybe StringOrURI
      -> ClaimsMap
      -> JWTClaimsSet)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe NumericDate)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"exp"
                     Parser
  (Maybe NumericDate
   -> Maybe NumericDate
   -> Maybe StringOrURI
   -> ClaimsMap
   -> JWTClaimsSet)
-> Parser (Maybe NumericDate)
-> Parser
     (Maybe NumericDate
      -> Maybe StringOrURI -> ClaimsMap -> JWTClaimsSet)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe NumericDate)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"nbf"
                     Parser
  (Maybe NumericDate
   -> Maybe StringOrURI -> ClaimsMap -> JWTClaimsSet)
-> Parser (Maybe NumericDate)
-> Parser (Maybe StringOrURI -> ClaimsMap -> JWTClaimsSet)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe NumericDate)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"iat"
                     Parser (Maybe StringOrURI -> ClaimsMap -> JWTClaimsSet)
-> Parser (Maybe StringOrURI) -> Parser (ClaimsMap -> JWTClaimsSet)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe StringOrURI)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"jti"
                     Parser (ClaimsMap -> JWTClaimsSet)
-> Parser ClaimsMap -> Parser JWTClaimsSet
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ClaimsMap -> Parser ClaimsMap
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClaimsMap -> ClaimsMap
removeRegisteredClaims (ClaimsMap -> ClaimsMap) -> ClaimsMap -> ClaimsMap
forall a b. (a -> b) -> a -> b
$ Object -> ClaimsMap
fromHashMap Object
o))

instance FromJSON JOSEHeader where
    parseJSON :: Value -> Parser JWTHeader
parseJSON = String -> (Object -> Parser JWTHeader) -> Value -> Parser JWTHeader
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"JOSEHeader"
                    (\Object
o -> Maybe Text
-> Maybe Text -> Maybe Algorithm -> Maybe Text -> JWTHeader
JOSEHeader
                    (Maybe Text
 -> Maybe Text -> Maybe Algorithm -> Maybe Text -> JWTHeader)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text -> Maybe Algorithm -> Maybe Text -> JWTHeader)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"typ"
                    Parser (Maybe Text -> Maybe Algorithm -> Maybe Text -> JWTHeader)
-> Parser (Maybe Text)
-> Parser (Maybe Algorithm -> Maybe Text -> JWTHeader)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"cty"
                    Parser (Maybe Algorithm -> Maybe Text -> JWTHeader)
-> Parser (Maybe Algorithm) -> Parser (Maybe Text -> JWTHeader)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Algorithm)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"alg"
                    Parser (Maybe Text -> JWTHeader)
-> Parser (Maybe Text) -> Parser JWTHeader
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"kid")

instance ToJSON JOSEHeader where
    toJSON :: JWTHeader -> Value
toJSON JOSEHeader{Maybe Text
Maybe Algorithm
kid :: Maybe Text
alg :: Maybe Algorithm
cty :: Maybe Text
typ :: Maybe Text
kid :: JWTHeader -> Maybe Text
alg :: JWTHeader -> Maybe Algorithm
cty :: JWTHeader -> Maybe Text
typ :: JWTHeader -> Maybe Text
..} = [(Key, Value)] -> Value
object ([(Key, Value)] -> Value) -> [(Key, Value)] -> Value
forall a b. (a -> b) -> a -> b
$ [Maybe (Key, Value)] -> [(Key, Value)]
forall a. [Maybe a] -> [a]
catMaybes [
                  (Text -> (Key, Value)) -> Maybe Text -> Maybe (Key, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"typ" Key -> Text -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) Maybe Text
typ
                , (Text -> (Key, Value)) -> Maybe Text -> Maybe (Key, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"cty" Key -> Text -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) Maybe Text
cty
                , (Algorithm -> (Key, Value))
-> Maybe Algorithm -> Maybe (Key, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"alg" Key -> Algorithm -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) Maybe Algorithm
alg
                , (Text -> (Key, Value)) -> Maybe Text -> Maybe (Key, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"kid" Key -> Text -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) Maybe Text
kid
            ]

instance ToJSON NumericDate where
    toJSON :: NumericDate -> Value
toJSON (NumericDate Integer
i) = Scientific -> Value
Number (Scientific -> Value) -> Scientific -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Int -> Scientific
scientific (Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i) Int
0

instance FromJSON NumericDate where
    parseJSON :: Value -> Parser NumericDate
parseJSON (Number Scientific
x) = NumericDate -> Parser NumericDate
forall (m :: * -> *) a. Monad m => a -> m a
return (NumericDate -> Parser NumericDate)
-> NumericDate -> Parser NumericDate
forall a b. (a -> b) -> a -> b
$ Integer -> NumericDate
NumericDate (Integer -> NumericDate) -> Integer -> NumericDate
forall a b. (a -> b) -> a -> b
$ Scientific -> Integer
coefficient Scientific
x
    parseJSON Value
_          = Parser NumericDate
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance ToJSON Algorithm where
    toJSON :: Algorithm -> Value
toJSON Algorithm
HS256 = Text -> Value
String (Text
"HS256"::T.Text)
    toJSON Algorithm
RS256 = Text -> Value
String (Text
"RS256"::T.Text)

instance FromJSON Algorithm where
    parseJSON :: Value -> Parser Algorithm
parseJSON (String Text
"HS256") = Algorithm -> Parser Algorithm
forall (m :: * -> *) a. Monad m => a -> m a
return Algorithm
HS256
    parseJSON (String Text
"RS256") = Algorithm -> Parser Algorithm
forall (m :: * -> *) a. Monad m => a -> m a
return Algorithm
RS256
    parseJSON Value
_                = Parser Algorithm
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance ToJSON StringOrURI where
    toJSON :: StringOrURI -> Value
toJSON (S Text
s)   = Text -> Value
String Text
s
    toJSON (U URI
uri) = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ShowS -> URI -> ShowS
URI.uriToString ShowS
forall a. a -> a
id URI
uri String
""

instance FromJSON StringOrURI where
    parseJSON :: Value -> Parser StringOrURI
parseJSON (String Text
s) | String -> Bool
URI.isURI (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s = StringOrURI -> Parser StringOrURI
forall (m :: * -> *) a. Monad m => a -> m a
return (StringOrURI -> Parser StringOrURI)
-> StringOrURI -> Parser StringOrURI
forall a b. (a -> b) -> a -> b
$ URI -> StringOrURI
U (URI -> StringOrURI) -> URI -> StringOrURI
forall a b. (a -> b) -> a -> b
$ URI -> Maybe URI -> URI
forall a. a -> Maybe a -> a
fromMaybe URI
URI.nullURI (Maybe URI -> URI) -> Maybe URI -> URI
forall a b. (a -> b) -> a -> b
$ String -> Maybe URI
URI.parseURI (String -> Maybe URI) -> String -> Maybe URI
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s
    parseJSON (String Text
s)                          = StringOrURI -> Parser StringOrURI
forall (m :: * -> *) a. Monad m => a -> m a
return (StringOrURI -> Parser StringOrURI)
-> StringOrURI -> Parser StringOrURI
forall a b. (a -> b) -> a -> b
$ Text -> StringOrURI
S Text
s
    parseJSON Value
_                                   = Parser StringOrURI
forall (m :: * -> *) a. MonadPlus m => m a
mzero

-- $docDecoding
-- There are three use cases supported by the set of decoding/verification
-- functions:
--
-- (1) Unsecured JWTs (<http://tools.ietf.org/html/draft-ietf-oauth-json-web-token-30#section-6>).
--      This is supported by the decode function 'decode'.
--      As a client you don't care about signing or encrypting so you only get back a 'JWT' 'UnverifiedJWT'.
--      I.e. the type makes it clear that no signature verification was attempted.
--
-- (2) Signed JWTs you want to verify using a known secret.
--      This is what 'decodeAndVerifySignature' supports, given a secret
--      and JSON it will return a 'JWT' 'VerifiedJWT' if the signature can be
--      verified.
--
-- (3) Signed JWTs that need to be verified using a secret that depends on
--      information contained in the JWT. E.g. the secret depends on
--      some claim, therefore the JWT needs to be decoded first and after
--      retrieving the appropriate secret value, verified in a subsequent step.
--      This is supported by using the `verify` function which given
--      a 'JWT' 'UnverifiedJWT' and a secret will return a 'JWT' 'VerifiedJWT' iff the
--      signature can be verified.