{-# 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 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.HashMap.Strict        as StrictMap
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)

-- $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 s1 :: Text
s1) == :: Signature -> Signature -> Bool
== (Signature s2 :: 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 _ c :: JWTClaimsSet
c _ _) = JWTClaimsSet
c
claims (Verified _ c :: JWTClaimsSet
c _) = JWTClaimsSet
c

-- | Extract the header from a JSON Web Token
header :: JWT r -> JOSEHeader
header :: JWT r -> JOSEHeader
header (Unverified h :: JOSEHeader
h _ _ _) = JOSEHeader
h
header (Verified h :: JOSEHeader
h _ _) = JOSEHeader
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 _ _ s :: 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 s :: 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 s :: Text
s) = Text -> String
T.unpack Text
s
    show (U 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.
    JOSEHeader -> 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.
  , JOSEHeader -> 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>
  , JOSEHeader -> 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>
  , JOSEHeader -> Maybe Text
kid :: Maybe T.Text
} deriving (JOSEHeader -> JOSEHeader -> Bool
(JOSEHeader -> JOSEHeader -> Bool)
-> (JOSEHeader -> JOSEHeader -> Bool) -> Eq JOSEHeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JOSEHeader -> JOSEHeader -> Bool
$c/= :: JOSEHeader -> JOSEHeader -> Bool
== :: JOSEHeader -> JOSEHeader -> Bool
$c== :: JOSEHeader -> JOSEHeader -> Bool
Eq, Int -> JOSEHeader -> ShowS
[JOSEHeader] -> ShowS
JOSEHeader -> String
(Int -> JOSEHeader -> ShowS)
-> (JOSEHeader -> String)
-> ([JOSEHeader] -> ShowS)
-> Show JOSEHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JOSEHeader] -> ShowS
$cshowList :: [JOSEHeader] -> ShowS
show :: JOSEHeader -> String
$cshow :: JOSEHeader -> String
showsPrec :: Int -> JOSEHeader -> ShowS
$cshowsPrec :: Int -> JOSEHeader -> ShowS
Show)

instance Monoid JOSEHeader where
    mempty :: JOSEHeader
mempty =
      Maybe Text
-> Maybe Text -> Maybe Algorithm -> Maybe Text -> JOSEHeader
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 :: JOSEHeader -> JOSEHeader -> JOSEHeader
mappend = JOSEHeader -> JOSEHeader -> JOSEHeader
forall a. Semigroup a => a -> a -> a
(Semigroup.<>)

instance Semigroup.Semigroup JOSEHeader where
  JOSEHeader a :: Maybe Text
a b :: Maybe Text
b c :: Maybe Algorithm
c d :: Maybe Text
d <> :: JOSEHeader -> JOSEHeader -> JOSEHeader
<> JOSEHeader a' :: Maybe Text
a' b' :: Maybe Text
b' c' :: Maybe Algorithm
c' d' :: Maybe Text
d' =
    Maybe Text
-> Maybe Text -> Maybe Algorithm -> Maybe Text -> JOSEHeader
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 a :: Maybe StringOrURI
a b :: Maybe StringOrURI
b c :: Maybe (Either StringOrURI [StringOrURI])
c d :: Maybe NumericDate
d e :: Maybe NumericDate
e f :: Maybe NumericDate
f g :: Maybe StringOrURI
g h :: ClaimsMap
h <> :: JWTClaimsSet -> JWTClaimsSet -> JWTClaimsSet
<> JWTClaimsSet a' :: Maybe StringOrURI
a' b' :: Maybe StringOrURI
b' c' :: Maybe (Either StringOrURI [StringOrURI])
c' d' :: Maybe NumericDate
d' e' :: Maybe NumericDate
e' f' :: Maybe NumericDate
f' g' :: Maybe StringOrURI
g' h' :: 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 -> JOSEHeader -> JWTClaimsSet -> Text
encodeSigned signer :: Signer
signer header' :: JOSEHeader
header' claims' :: 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 _    -> Algorithm
HS256
                        RSAPrivateKey _ -> Algorithm
RS256

          header'' :: Text
header''  = JOSEHeader -> Text
forall a. ToJSON a => a -> Text
encodeJWT JOSEHeader
header' {
                        typ :: Maybe Text
typ = Text -> Maybe Text
forall a. a -> Maybe a
Just "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 -> JOSEHeader -> Text
encodeUnsigned claims' :: JWTClaimsSet
claims' header' :: JOSEHeader
header' = [Text] -> Text
dotted [Text
header'', Text
claim, ""]
    where claim :: Text
claim     = JWTClaimsSet -> Text
forall a. ToJSON a => a -> Text
encodeJWT JWTClaimsSet
claims'
          header'' :: Text
header''  = JOSEHeader -> Text
forall a. ToJSON a => a -> Text
encodeJWT JOSEHeader
header' {
                        typ :: Maybe Text
typ = Text -> Maybe Text
forall a. a -> Maybe a
Just "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 input :: Text
input = do
    (h :: Text
h,c :: Text
c,s :: 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
input
    let header' :: Maybe JOSEHeader
header' = Text -> Maybe JOSEHeader
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
    JOSEHeader
-> JWTClaimsSet -> Signature -> Text -> JWT UnverifiedJWT
Unverified (JOSEHeader
 -> JWTClaimsSet -> Signature -> Text -> JWT UnverifiedJWT)
-> Maybe JOSEHeader
-> Maybe (JWTClaimsSet -> Signature -> Text -> JWT UnverifiedJWT)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe JOSEHeader
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 (h :: c
h:c :: c
c:s :: c
s:_) = (c, c, c) -> Maybe (c, c, c)
forall a. a -> Maybe a
Just (c
h,c
c,c
s)
        extractElems _         = 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
signer (Unverified header' :: JOSEHeader
header' claims' :: JWTClaimsSet
claims' unverifiedSignature :: Signature
unverifiedSignature originalClaim :: 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
$ JOSEHeader -> JWTClaimsSet -> Signature -> JWT VerifiedJWT
Verified JOSEHeader
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
signer input :: 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 bs :: ByteString
bs =
    case ByteString -> [PrivKey]
readKeyFileFromMemory ByteString
bs of
        [(PrivKeyRSA k :: PrivateKey
k)] -> PrivateKey -> Maybe PrivateKey
forall a. a -> Maybe a
Just PrivateKey
k
        _                -> 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 i :: NominalDiffTime
i | NominalDiffTime
i NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = Maybe NumericDate
forall a. Maybe a
Nothing
numericDate i :: 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 t :: 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 t :: 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 t :: Text
t)   = Text
t
stringOrURIToText (U uri :: 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)

-- | Convert the `aud` claim in a `JWTClaimsSet` into a `[StringOrURI]`
auds :: JWTClaimsSet -> [StringOrURI]
auds :: JWTClaimsSet -> [StringOrURI]
auds jwt :: JWTClaimsSet
jwt = case JWTClaimsSet -> Maybe (Either StringOrURI [StringOrURI])
aud JWTClaimsSet
jwt of
    Nothing         -> []
    Just (Left a :: StringOrURI
a)   -> [StringOrURI
a]
    Just (Right as :: [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 x :: 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 _  -> Maybe a
forall a. Maybe a
Nothing
               Right s :: 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 "."


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

calculateDigest :: Signer -> T.Text -> T.Text
calculateDigest :: Signer -> Text -> Text
calculateDigest (HMACSecret key :: ByteString
key) msg :: 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 key :: PrivateKey
key) msg :: 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' bs :: 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 sig :: ByteString
sig -> ByteString
sig
        Left  _   -> String -> ByteString
forall a. HasCallStack => String -> a
error "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 a :: Map Text Value
a <> :: ClaimsMap -> ClaimsMap -> ClaimsMap
<> ClaimsMap b :: 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
. Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
StrictMap.toList

removeRegisteredClaims :: ClaimsMap -> ClaimsMap
removeRegisteredClaims :: ClaimsMap -> ClaimsMap
removeRegisteredClaims (ClaimsMap input :: 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 (\_ _ _ -> 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 (\e :: Text
e -> (Text
e, Value
Null)) ["iss", "sub", "aud", "exp", "nbf", "iat", "jti"]

instance ToJSON JWTClaimsSet where
    toJSON :: JWTClaimsSet -> Value
toJSON JWTClaimsSet{..} = [(Text, Value)] -> Value
object ([(Text, Value)] -> Value) -> [(Text, Value)] -> Value
forall a b. (a -> b) -> a -> b
$ [Maybe (Text, Value)] -> [(Text, Value)]
forall a. [Maybe a] -> [a]
catMaybes [
                  (StringOrURI -> (Text, Value))
-> Maybe StringOrURI -> Maybe (Text, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ("iss" Text -> StringOrURI -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=) Maybe StringOrURI
iss
                , (StringOrURI -> (Text, Value))
-> Maybe StringOrURI -> Maybe (Text, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ("sub" Text -> StringOrURI -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=) Maybe StringOrURI
sub
                , (StringOrURI -> (Text, Value))
-> ([StringOrURI] -> (Text, Value))
-> Either StringOrURI [StringOrURI]
-> (Text, Value)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ("aud" Text -> StringOrURI -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=) ("aud" Text -> [StringOrURI] -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=) (Either StringOrURI [StringOrURI] -> (Text, Value))
-> Maybe (Either StringOrURI [StringOrURI]) -> Maybe (Text, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Either StringOrURI [StringOrURI])
aud
                , (NumericDate -> (Text, Value))
-> Maybe NumericDate -> Maybe (Text, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ("exp" Text -> NumericDate -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=) Maybe NumericDate
exp
                , (NumericDate -> (Text, Value))
-> Maybe NumericDate -> Maybe (Text, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ("nbf" Text -> NumericDate -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=) Maybe NumericDate
nbf
                , (NumericDate -> (Text, Value))
-> Maybe NumericDate -> Maybe (Text, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ("iat" Text -> NumericDate -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=) Maybe NumericDate
iat
                , (StringOrURI -> (Text, Value))
-> Maybe StringOrURI -> Maybe (Text, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ("jti" Text -> StringOrURI -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.=) Maybe StringOrURI
jti
            ] [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. [a] -> [a] -> [a]
++ Map Text Value -> [(Text, Value)]
forall k a. Map k a -> [(k, a)]
Map.toList (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)

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 "JWTClaimsSet"
                     (\o :: 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 -> Text -> Parser (Maybe StringOrURI)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "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 -> Text -> Parser (Maybe StringOrURI)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "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 Text -> Object -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
StrictMap.lookup "aud" Object
o of
                         (Just as :: Value
as@(JSON.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 t :: 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 (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 -> Text -> Parser (Maybe NumericDate)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "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 -> Text -> Parser (Maybe NumericDate)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "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 -> Text -> Parser (Maybe NumericDate)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "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 -> Text -> Parser (Maybe StringOrURI)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "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 JOSEHeader
parseJSON = String
-> (Object -> Parser JOSEHeader) -> Value -> Parser JOSEHeader
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject "JOSEHeader"
                    (\o :: Object
o -> Maybe Text
-> Maybe Text -> Maybe Algorithm -> Maybe Text -> JOSEHeader
JOSEHeader
                    (Maybe Text
 -> Maybe Text -> Maybe Algorithm -> Maybe Text -> JOSEHeader)
-> Parser (Maybe Text)
-> Parser
     (Maybe Text -> Maybe Algorithm -> Maybe Text -> JOSEHeader)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "typ"
                    Parser (Maybe Text -> Maybe Algorithm -> Maybe Text -> JOSEHeader)
-> Parser (Maybe Text)
-> Parser (Maybe Algorithm -> Maybe Text -> JOSEHeader)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "cty"
                    Parser (Maybe Algorithm -> Maybe Text -> JOSEHeader)
-> Parser (Maybe Algorithm) -> Parser (Maybe Text -> JOSEHeader)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe Algorithm)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "alg"
                    Parser (Maybe Text -> JOSEHeader)
-> Parser (Maybe Text) -> Parser JOSEHeader
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? "kid")

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

instance ToJSON NumericDate where
    toJSON :: NumericDate -> Value
toJSON (NumericDate i :: 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) 0

instance FromJSON NumericDate where
    parseJSON :: Value -> Parser NumericDate
parseJSON (Number x :: 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 _          = Parser NumericDate
forall (m :: * -> *) a. MonadPlus m => m a
mzero

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

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

instance ToJSON StringOrURI where
    toJSON :: StringOrURI -> Value
toJSON (S s :: Text
s)   = Text -> Value
String Text
s
    toJSON (U uri :: 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 ""

instance FromJSON StringOrURI where
    parseJSON :: Value -> Parser StringOrURI
parseJSON (String s :: 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 s :: 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 _                                   = 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.