-- Copyright (C) 2013, 2014, 2015, 2016, 2020  Fraser Tweedale
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

{-|

JSON Web Signature (JWS) represents content secured with digital
signatures or Message Authentication Codes (MACs) using JavaScript
Object Notation (JSON) based data structures.  It is defined in
<https://tools.ietf.org/html/rfc7515 RFC 7515>.

@
import Crypto.JOSE

doJwsSign :: 'JWK' -> L.ByteString -> IO (Either 'Error' ('GeneralJWS' 'JWSHeader'))
doJwsSign jwk payload = 'runJOSE' $ do
  alg \<- 'bestJWSAlg' jwk
  'signJWS' payload [('newJWSHeader' ('Protected', alg), jwk)]

doJwsVerify :: 'JWK' -> 'GeneralJWS' 'JWSHeader' -> IO (Either 'Error' ())
doJwsVerify jwk jws = 'runJOSE' $
  'verifyJWS'' jwk jws
@

-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Crypto.JOSE.JWS
  (
  -- * Overview
    JWS
  , GeneralJWS
  , FlattenedJWS
  , CompactJWS

  -- ** Defining additional header parameters
  -- $extending

  -- * JWS creation
  , newJWSHeader
  , makeJWSHeader
  , signJWS

  -- * JWS verification
  , verifyJWS
  , verifyJWS'
  , verifyJWSWithPayload

  -- ** JWS validation settings
  , defaultValidationSettings
  , ValidationSettings
  , ValidationPolicy(..)
  , HasValidationSettings(..)
  , HasAlgorithms(..)
  , HasValidationPolicy(..)

  -- * Signature data
  , signatures
  , Signature
  , header
  , signature
  , rawProtectedHeader

  -- * JWS headers
  , Alg(..)
  , HasJWSHeader(..)
  , JWSHeader

  , module Crypto.JOSE.Error
  , module Crypto.JOSE.Header
  , module Crypto.JOSE.JWK
  ) where

import Control.Applicative ((<|>))
import Control.Monad (unless)
import Data.Foldable (toList)
import Data.Maybe (catMaybes, fromMaybe)
import Data.Monoid ((<>))
import Data.List.NonEmpty (NonEmpty)
import Data.Word (Word8)

import Control.Lens hiding ((.=))
import Control.Lens.Cons.Extras (recons)
import Control.Monad.Error.Lens (throwing, throwing_)
import Control.Monad.Except (MonadError)
import Data.Aeson
import qualified Data.Aeson.KeyMap as M
import qualified Data.ByteString as B
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T

import Crypto.JOSE.Compact
import Crypto.JOSE.Error
import Crypto.JOSE.JWA.JWS
import Crypto.JOSE.JWK
import Crypto.JOSE.JWK.Store
import Crypto.JOSE.Header
import qualified Crypto.JOSE.Types as Types
import Crypto.JOSE.Types.URI
import qualified Crypto.JOSE.Types.Internal as Types

{- $extending

Several specifications extend JWS with additional header parameters.
The 'JWS' type is parameterised over the header type; this library
provides the 'JWSHeader' type which encompasses all the JWS header
parameters defined in RFC 7515.  To define an extended header type
declare the data type, and instances for 'HasJWSHeader' and
'HasParams'.  For example:

@
data ACMEHeader p = ACMEHeader
  { _acmeJwsHeader :: 'JWSHeader' p
  , _acmeNonce :: 'Types.Base64Octets'
  }

acmeJwsHeader :: Lens' (ACMEHeader p) (JWSHeader p)
acmeJwsHeader f s\@(ACMEHeader { _acmeJwsHeader = a}) =
  fmap (\\a' -> s { _acmeJwsHeader = a'}) (f a)

acmeNonce :: Lens' (ACMEHeader p) Types.Base64Octets
acmeNonce f s\@(ACMEHeader { _acmeNonce = a}) =
  fmap (\\a' -> s { _acmeNonce = a'}) (f a)

instance HasJWSHeader ACMEHeader where
  jwsHeader = acmeJwsHeader

instance HasParams ACMEHeader where
  'parseParamsFor' proxy hp hu = ACMEHeader
    \<$> 'parseParamsFor' proxy hp hu
    \<*> 'headerRequiredProtected' "nonce" hp hu
  params h =
    (True, "nonce" .= view acmeNonce h)
    : 'params' (view acmeJwsHeader h)
  'extensions' = const ["nonce"]
@

See also:

- 'HasParams'
- 'headerRequired'
- 'headerRequiredProtected'
- 'headerOptional'
- 'headerOptional''
- 'headerOptionalProtected'

-}


jwsCritInvalidNames :: [T.Text]
jwsCritInvalidNames :: [Text]
jwsCritInvalidNames = [
  Text
"alg"
  , Text
"jku"
  , Text
"jwk"
  , Text
"x5u"
  , Text
"x5t"
  , Text
"x5t#S256"
  , Text
"x5c"
  , Text
"kid"
  , Text
"typ"
  , Text
"cty"
  , Text
"crit"
  ]

-- | JWS Header data type.
--
data JWSHeader p = JWSHeader
  { forall p. JWSHeader p -> HeaderParam p Alg
_jwsHeaderAlg :: HeaderParam p Alg
  , forall p. JWSHeader p -> Maybe (HeaderParam p URI)
_jwsHeaderJku :: Maybe (HeaderParam p Types.URI)  -- ^ JWK Set URL
  , forall p. JWSHeader p -> Maybe (HeaderParam p JWK)
_jwsHeaderJwk :: Maybe (HeaderParam p JWK)
  , forall p. JWSHeader p -> Maybe (HeaderParam p Text)
_jwsHeaderKid :: Maybe (HeaderParam p T.Text)  -- ^ interpretation unspecified
  , forall p. JWSHeader p -> Maybe (HeaderParam p URI)
_jwsHeaderX5u :: Maybe (HeaderParam p Types.URI)
  , forall p.
JWSHeader p -> Maybe (HeaderParam p (NonEmpty SignedCertificate))
_jwsHeaderX5c :: Maybe (HeaderParam p (NonEmpty Types.SignedCertificate))
  , forall p. JWSHeader p -> Maybe (HeaderParam p Base64SHA1)
_jwsHeaderX5t :: Maybe (HeaderParam p Types.Base64SHA1)
  , forall p. JWSHeader p -> Maybe (HeaderParam p Base64SHA256)
_jwsHeaderX5tS256 :: Maybe (HeaderParam p Types.Base64SHA256)
  , forall p. JWSHeader p -> Maybe (HeaderParam p Text)
_jwsHeaderTyp :: Maybe (HeaderParam p T.Text)  -- ^ Content Type (of object)
  , forall p. JWSHeader p -> Maybe (HeaderParam p Text)
_jwsHeaderCty :: Maybe (HeaderParam p T.Text)  -- ^ Content Type (of payload)
  , forall p. JWSHeader p -> Maybe (NonEmpty Text)
_jwsHeaderCrit :: Maybe (NonEmpty T.Text)
  }
  deriving (JWSHeader p -> JWSHeader p -> Bool
forall p. Eq p => JWSHeader p -> JWSHeader p -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JWSHeader p -> JWSHeader p -> Bool
$c/= :: forall p. Eq p => JWSHeader p -> JWSHeader p -> Bool
== :: JWSHeader p -> JWSHeader p -> Bool
$c== :: forall p. Eq p => JWSHeader p -> JWSHeader p -> Bool
Eq, Int -> JWSHeader p -> ShowS
forall p. Show p => Int -> JWSHeader p -> ShowS
forall p. Show p => [JWSHeader p] -> ShowS
forall p. Show p => JWSHeader p -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JWSHeader p] -> ShowS
$cshowList :: forall p. Show p => [JWSHeader p] -> ShowS
show :: JWSHeader p -> String
$cshow :: forall p. Show p => JWSHeader p -> String
showsPrec :: Int -> JWSHeader p -> ShowS
$cshowsPrec :: forall p. Show p => Int -> JWSHeader p -> ShowS
Show)

class HasJWSHeader a where
  jwsHeader :: Lens' (a p) (JWSHeader p)

instance HasJWSHeader JWSHeader where
  jwsHeader :: forall p. Lens' (JWSHeader p) (JWSHeader p)
jwsHeader = forall a. a -> a
id

instance HasJWSHeader a => HasAlg a where
  alg :: forall p. Lens' (a p) (HeaderParam p Alg)
alg = forall (a :: * -> *) p. HasJWSHeader a => Lens' (a p) (JWSHeader p)
jwsHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. \HeaderParam p Alg -> f (HeaderParam p Alg)
f h :: JWSHeader p
h@(JWSHeader { _jwsHeaderAlg :: forall p. JWSHeader p -> HeaderParam p Alg
_jwsHeaderAlg = HeaderParam p Alg
a }) ->
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HeaderParam p Alg
a' -> JWSHeader p
h { _jwsHeaderAlg :: HeaderParam p Alg
_jwsHeaderAlg = HeaderParam p Alg
a' }) (HeaderParam p Alg -> f (HeaderParam p Alg)
f HeaderParam p Alg
a)
instance HasJWSHeader a => HasJku a where
  jku :: forall p. Lens' (a p) (Maybe (HeaderParam p URI))
jku = forall (a :: * -> *) p. HasJWSHeader a => Lens' (a p) (JWSHeader p)
jwsHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. \Maybe (HeaderParam p URI) -> f (Maybe (HeaderParam p URI))
f h :: JWSHeader p
h@(JWSHeader { _jwsHeaderJku :: forall p. JWSHeader p -> Maybe (HeaderParam p URI)
_jwsHeaderJku = Maybe (HeaderParam p URI)
a }) ->
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe (HeaderParam p URI)
a' -> JWSHeader p
h { _jwsHeaderJku :: Maybe (HeaderParam p URI)
_jwsHeaderJku = Maybe (HeaderParam p URI)
a' }) (Maybe (HeaderParam p URI) -> f (Maybe (HeaderParam p URI))
f Maybe (HeaderParam p URI)
a)
instance HasJWSHeader a => HasJwk a where
  jwk :: forall p. Lens' (a p) (Maybe (HeaderParam p JWK))
jwk = forall (a :: * -> *) p. HasJWSHeader a => Lens' (a p) (JWSHeader p)
jwsHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. \Maybe (HeaderParam p JWK) -> f (Maybe (HeaderParam p JWK))
f h :: JWSHeader p
h@(JWSHeader { _jwsHeaderJwk :: forall p. JWSHeader p -> Maybe (HeaderParam p JWK)
_jwsHeaderJwk = Maybe (HeaderParam p JWK)
a }) ->
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe (HeaderParam p JWK)
a' -> JWSHeader p
h { _jwsHeaderJwk :: Maybe (HeaderParam p JWK)
_jwsHeaderJwk = Maybe (HeaderParam p JWK)
a' }) (Maybe (HeaderParam p JWK) -> f (Maybe (HeaderParam p JWK))
f Maybe (HeaderParam p JWK)
a)
instance HasJWSHeader a => HasKid a where
  kid :: forall p. Lens' (a p) (Maybe (HeaderParam p Text))
kid = forall (a :: * -> *) p. HasJWSHeader a => Lens' (a p) (JWSHeader p)
jwsHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. \Maybe (HeaderParam p Text) -> f (Maybe (HeaderParam p Text))
f h :: JWSHeader p
h@(JWSHeader { _jwsHeaderKid :: forall p. JWSHeader p -> Maybe (HeaderParam p Text)
_jwsHeaderKid = Maybe (HeaderParam p Text)
a }) ->
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe (HeaderParam p Text)
a' -> JWSHeader p
h { _jwsHeaderKid :: Maybe (HeaderParam p Text)
_jwsHeaderKid = Maybe (HeaderParam p Text)
a' }) (Maybe (HeaderParam p Text) -> f (Maybe (HeaderParam p Text))
f Maybe (HeaderParam p Text)
a)
instance HasJWSHeader a => HasX5u a where
  x5u :: forall p. Lens' (a p) (Maybe (HeaderParam p URI))
x5u = forall (a :: * -> *) p. HasJWSHeader a => Lens' (a p) (JWSHeader p)
jwsHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. \Maybe (HeaderParam p URI) -> f (Maybe (HeaderParam p URI))
f h :: JWSHeader p
h@(JWSHeader { _jwsHeaderX5u :: forall p. JWSHeader p -> Maybe (HeaderParam p URI)
_jwsHeaderX5u = Maybe (HeaderParam p URI)
a }) ->
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe (HeaderParam p URI)
a' -> JWSHeader p
h { _jwsHeaderX5u :: Maybe (HeaderParam p URI)
_jwsHeaderX5u = Maybe (HeaderParam p URI)
a' }) (Maybe (HeaderParam p URI) -> f (Maybe (HeaderParam p URI))
f Maybe (HeaderParam p URI)
a)
instance HasJWSHeader a => HasX5c a where
  x5c :: forall p.
Lens' (a p) (Maybe (HeaderParam p (NonEmpty SignedCertificate)))
x5c = forall (a :: * -> *) p. HasJWSHeader a => Lens' (a p) (JWSHeader p)
jwsHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. \Maybe (HeaderParam p (NonEmpty SignedCertificate))
-> f (Maybe (HeaderParam p (NonEmpty SignedCertificate)))
f h :: JWSHeader p
h@(JWSHeader { _jwsHeaderX5c :: forall p.
JWSHeader p -> Maybe (HeaderParam p (NonEmpty SignedCertificate))
_jwsHeaderX5c = Maybe (HeaderParam p (NonEmpty SignedCertificate))
a }) ->
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe (HeaderParam p (NonEmpty SignedCertificate))
a' -> JWSHeader p
h { _jwsHeaderX5c :: Maybe (HeaderParam p (NonEmpty SignedCertificate))
_jwsHeaderX5c = Maybe (HeaderParam p (NonEmpty SignedCertificate))
a' }) (Maybe (HeaderParam p (NonEmpty SignedCertificate))
-> f (Maybe (HeaderParam p (NonEmpty SignedCertificate)))
f Maybe (HeaderParam p (NonEmpty SignedCertificate))
a)
instance HasJWSHeader a => HasX5t a where
  x5t :: forall p. Lens' (a p) (Maybe (HeaderParam p Base64SHA1))
x5t = forall (a :: * -> *) p. HasJWSHeader a => Lens' (a p) (JWSHeader p)
jwsHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. \Maybe (HeaderParam p Base64SHA1)
-> f (Maybe (HeaderParam p Base64SHA1))
f h :: JWSHeader p
h@(JWSHeader { _jwsHeaderX5t :: forall p. JWSHeader p -> Maybe (HeaderParam p Base64SHA1)
_jwsHeaderX5t = Maybe (HeaderParam p Base64SHA1)
a }) ->
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe (HeaderParam p Base64SHA1)
a' -> JWSHeader p
h { _jwsHeaderX5t :: Maybe (HeaderParam p Base64SHA1)
_jwsHeaderX5t = Maybe (HeaderParam p Base64SHA1)
a' }) (Maybe (HeaderParam p Base64SHA1)
-> f (Maybe (HeaderParam p Base64SHA1))
f Maybe (HeaderParam p Base64SHA1)
a)
instance HasJWSHeader a => HasX5tS256 a where
  x5tS256 :: forall p. Lens' (a p) (Maybe (HeaderParam p Base64SHA256))
x5tS256 = forall (a :: * -> *) p. HasJWSHeader a => Lens' (a p) (JWSHeader p)
jwsHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. \Maybe (HeaderParam p Base64SHA256)
-> f (Maybe (HeaderParam p Base64SHA256))
f h :: JWSHeader p
h@(JWSHeader { _jwsHeaderX5tS256 :: forall p. JWSHeader p -> Maybe (HeaderParam p Base64SHA256)
_jwsHeaderX5tS256 = Maybe (HeaderParam p Base64SHA256)
a }) ->
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe (HeaderParam p Base64SHA256)
a' -> JWSHeader p
h { _jwsHeaderX5tS256 :: Maybe (HeaderParam p Base64SHA256)
_jwsHeaderX5tS256 = Maybe (HeaderParam p Base64SHA256)
a' }) (Maybe (HeaderParam p Base64SHA256)
-> f (Maybe (HeaderParam p Base64SHA256))
f Maybe (HeaderParam p Base64SHA256)
a)
instance HasJWSHeader a => HasTyp a where
  typ :: forall p. Lens' (a p) (Maybe (HeaderParam p Text))
typ = forall (a :: * -> *) p. HasJWSHeader a => Lens' (a p) (JWSHeader p)
jwsHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. \Maybe (HeaderParam p Text) -> f (Maybe (HeaderParam p Text))
f h :: JWSHeader p
h@(JWSHeader { _jwsHeaderTyp :: forall p. JWSHeader p -> Maybe (HeaderParam p Text)
_jwsHeaderTyp = Maybe (HeaderParam p Text)
a }) ->
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe (HeaderParam p Text)
a' -> JWSHeader p
h { _jwsHeaderTyp :: Maybe (HeaderParam p Text)
_jwsHeaderTyp = Maybe (HeaderParam p Text)
a' }) (Maybe (HeaderParam p Text) -> f (Maybe (HeaderParam p Text))
f Maybe (HeaderParam p Text)
a)
instance HasJWSHeader a => HasCty a where
  cty :: forall p. Lens' (a p) (Maybe (HeaderParam p Text))
cty = forall (a :: * -> *) p. HasJWSHeader a => Lens' (a p) (JWSHeader p)
jwsHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. \Maybe (HeaderParam p Text) -> f (Maybe (HeaderParam p Text))
f h :: JWSHeader p
h@(JWSHeader { _jwsHeaderCty :: forall p. JWSHeader p -> Maybe (HeaderParam p Text)
_jwsHeaderCty = Maybe (HeaderParam p Text)
a }) ->
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe (HeaderParam p Text)
a' -> JWSHeader p
h { _jwsHeaderCty :: Maybe (HeaderParam p Text)
_jwsHeaderCty = Maybe (HeaderParam p Text)
a' }) (Maybe (HeaderParam p Text) -> f (Maybe (HeaderParam p Text))
f Maybe (HeaderParam p Text)
a)
instance HasJWSHeader a => HasCrit a where
  crit :: forall p. Lens' (a p) (Maybe (NonEmpty Text))
crit = forall (a :: * -> *) p. HasJWSHeader a => Lens' (a p) (JWSHeader p)
jwsHeader forall b c a. (b -> c) -> (a -> b) -> a -> c
. \Maybe (NonEmpty Text) -> f (Maybe (NonEmpty Text))
f h :: JWSHeader p
h@(JWSHeader { _jwsHeaderCrit :: forall p. JWSHeader p -> Maybe (NonEmpty Text)
_jwsHeaderCrit = Maybe (NonEmpty Text)
a }) ->
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Maybe (NonEmpty Text)
a' -> JWSHeader p
h { _jwsHeaderCrit :: Maybe (NonEmpty Text)
_jwsHeaderCrit = Maybe (NonEmpty Text)
a' }) (Maybe (NonEmpty Text) -> f (Maybe (NonEmpty Text))
f Maybe (NonEmpty Text)
a)


-- | Construct a minimal header with the given algorithm and
-- protection indicator for the /alg/ header.
--
newJWSHeader :: (p, Alg) -> JWSHeader p
newJWSHeader :: forall p. (p, Alg) -> JWSHeader p
newJWSHeader (p, Alg)
a = forall p.
HeaderParam p Alg
-> Maybe (HeaderParam p URI)
-> Maybe (HeaderParam p JWK)
-> Maybe (HeaderParam p Text)
-> Maybe (HeaderParam p URI)
-> Maybe (HeaderParam p (NonEmpty SignedCertificate))
-> Maybe (HeaderParam p Base64SHA1)
-> Maybe (HeaderParam p Base64SHA256)
-> Maybe (HeaderParam p Text)
-> Maybe (HeaderParam p Text)
-> Maybe (NonEmpty Text)
-> JWSHeader p
JWSHeader (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall p a. p -> a -> HeaderParam p a
HeaderParam (p, Alg)
a) forall {a}. Maybe a
z forall {a}. Maybe a
z forall {a}. Maybe a
z forall {a}. Maybe a
z forall {a}. Maybe a
z forall {a}. Maybe a
z forall {a}. Maybe a
z forall {a}. Maybe a
z forall {a}. Maybe a
z forall {a}. Maybe a
z
  where z :: Maybe a
z = forall {a}. Maybe a
Nothing

-- | Make a JWS header for the given signing key.
--
-- Uses 'bestJWSAlg' to choose the algorithm.
-- If set, the JWK's @"kid"@, @"x5u"@, @"x5c"@, @"x5t"@ and
-- @"x5t#S256"@ parameters are copied to the JWS header (as
-- protected parameters).
--
-- May return 'KeySizeTooSmall' or 'KeyMismatch'.
--
makeJWSHeader
  :: forall e m p. (MonadError e m, AsError e, ProtectionIndicator p)
  => JWK
  -> m (JWSHeader p)
makeJWSHeader :: forall e (m :: * -> *) p.
(MonadError e m, AsError e, ProtectionIndicator p) =>
JWK -> m (JWSHeader p)
makeJWSHeader JWK
k = do
  let
    p :: p
p = forall a. ProtectionIndicator a => a
getProtected
    f :: ASetter s t a (Maybe (HeaderParam p a1))
      -> Getting (Maybe a1) JWK (Maybe a1)
      -> s -> t
    f :: forall s t a a1.
ASetter s t a (Maybe (HeaderParam p a1))
-> Getting (Maybe a1) JWK (Maybe a1) -> s -> t
f ASetter s t a (Maybe (HeaderParam p a1))
lh Getting (Maybe a1) JWK (Maybe a1)
lk = forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter s t a (Maybe (HeaderParam p a1))
lh (forall p a. p -> a -> HeaderParam p a
HeaderParam p
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe a1) JWK (Maybe a1)
lk JWK
k)
  Alg
algo <- forall e (m :: * -> *). (MonadError e m, AsError e) => JWK -> m Alg
bestJWSAlg JWK
k
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall p. (p, Alg) -> JWSHeader p
newJWSHeader (p
p, Alg
algo)
    forall a b. a -> (a -> b) -> b
& forall s t a a1.
ASetter s t a (Maybe (HeaderParam p a1))
-> Getting (Maybe a1) JWK (Maybe a1) -> s -> t
f forall (a :: * -> *) p.
HasKid a =>
Lens' (a p) (Maybe (HeaderParam p Text))
kid (Lens' JWK (Maybe Text)
jwkKid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s1 a s2.
(Cons s1 s1 a a, Cons s2 s2 a a, AsEmpty s2) =>
Getter s1 s2
recons)))
    forall a b. a -> (a -> b) -> b
& forall s t a a1.
ASetter s t a (Maybe (HeaderParam p a1))
-> Getting (Maybe a1) JWK (Maybe a1) -> s -> t
f forall (a :: * -> *) p.
HasX5u a =>
Lens' (a p) (Maybe (HeaderParam p URI))
x5u Lens' JWK (Maybe URI)
jwkX5u
    forall a b. a -> (a -> b) -> b
& forall s t a a1.
ASetter s t a (Maybe (HeaderParam p a1))
-> Getting (Maybe a1) JWK (Maybe a1) -> s -> t
f forall (a :: * -> *) p.
HasX5c a =>
Lens' (a p) (Maybe (HeaderParam p (NonEmpty SignedCertificate)))
x5c Getter JWK (Maybe (NonEmpty SignedCertificate))
jwkX5c
    forall a b. a -> (a -> b) -> b
& forall s t a a1.
ASetter s t a (Maybe (HeaderParam p a1))
-> Getting (Maybe a1) JWK (Maybe a1) -> s -> t
f forall (a :: * -> *) p.
HasX5t a =>
Lens' (a p) (Maybe (HeaderParam p Base64SHA1))
x5t Lens' JWK (Maybe Base64SHA1)
jwkX5t
    forall a b. a -> (a -> b) -> b
& forall s t a a1.
ASetter s t a (Maybe (HeaderParam p a1))
-> Getting (Maybe a1) JWK (Maybe a1) -> s -> t
f forall (a :: * -> *) p.
HasX5tS256 a =>
Lens' (a p) (Maybe (HeaderParam p Base64SHA256))
x5tS256 Lens' JWK (Maybe Base64SHA256)
jwkX5tS256


-- | Signature object containing header, and signature bytes.
--
-- If it was decoded from a serialised JWS, it "remembers" how the
-- protected header was encoded; the remembered value is used when
-- computing the signing input and when serialising the object.
--
-- The remembered value is not used in equality checks, i.e. two
-- decoded signatures with differently serialised by otherwise equal
-- protected headers, and equal signature bytes, are equal.
--
data Signature p a = Signature
  (Maybe T.Text)      -- Encoded protected header, if available
  (a p)               -- Header
  Types.Base64Octets  -- Signature
  deriving (Int -> Signature p a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall p (a :: * -> *). Show (a p) => Int -> Signature p a -> ShowS
forall p (a :: * -> *). Show (a p) => [Signature p a] -> ShowS
forall p (a :: * -> *). Show (a p) => Signature p a -> String
showList :: [Signature p a] -> ShowS
$cshowList :: forall p (a :: * -> *). Show (a p) => [Signature p a] -> ShowS
show :: Signature p a -> String
$cshow :: forall p (a :: * -> *). Show (a p) => Signature p a -> String
showsPrec :: Int -> Signature p a -> ShowS
$cshowsPrec :: forall p (a :: * -> *). Show (a p) => Int -> Signature p a -> ShowS
Show)

-- | Getter for header of a signature
header :: Getter (Signature p a) (a p)
header :: forall p (a :: * -> *). Getter (Signature p a) (a p)
header = forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (\(Signature Maybe Text
_ a p
h Base64Octets
_) -> a p
h)

-- | Getter for signature bytes
signature :: (Cons s s Word8 Word8, AsEmpty s) => Getter (Signature p a) s
signature :: forall s p (a :: * -> *).
(Cons s s Word8 Word8, AsEmpty s) =>
Getter (Signature p a) s
signature = forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (\(Signature Maybe Text
_ a p
_ (Types.Base64Octets ByteString
s)) -> ByteString
s) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s1 a s2.
(Cons s1 s1 a a, Cons s2 s2 a a, AsEmpty s2) =>
Getter s1 s2
recons
{-# INLINE signature #-}

instance (Eq (a p)) => Eq (Signature p a) where
  Signature Maybe Text
_ a p
h Base64Octets
s == :: Signature p a -> Signature p a -> Bool
== Signature Maybe Text
_ a p
h' Base64Octets
s' = a p
h forall a. Eq a => a -> a -> Bool
== a p
h' Bool -> Bool -> Bool
&& Base64Octets
s forall a. Eq a => a -> a -> Bool
== Base64Octets
s'

instance (HasParams a, ProtectionIndicator p) => FromJSON (Signature p a) where
  parseJSON :: Value -> Parser (Signature p a)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"signature" (\Object
o -> forall p (a :: * -> *).
Maybe Text -> a p -> Base64Octets -> Signature p a
Signature
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"protected" forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
""))  -- raw protected header
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> do
      Maybe Value
hpB64 <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"protected"
      Maybe Object
hp <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall {a}. Maybe a
Nothing)
        (forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"base64url-encoded header params"
          (forall a. (ByteString -> Parser a) -> Text -> Parser a
Types.parseB64Url (forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"protected header contains invalid JSON")
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Maybe a
decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s1 a s2.
(Cons s1 s1 a a, Cons s2 s2 a a, AsEmpty s2) =>
Getter s1 s2
recons)))
        Maybe Value
hpB64
      Maybe Object
hu <- Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"header"
      forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
Maybe Object -> Maybe Object -> Parser (a p)
parseParams Maybe Object
hp Maybe Object
hu
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"signature"
    )

instance (HasParams a, ProtectionIndicator p) => ToJSON (Signature p a) where
  toJSON :: Signature p a -> Value
toJSON s :: Signature p a
s@(Signature Maybe Text
_ a p
h Base64Octets
sig) =
    let
      pro :: [Pair] -> [Pair]
pro = case forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
Signature p a -> ByteString
rawProtectedHeader Signature p a
s of
        ByteString
"" -> forall a. a -> a
id
        ByteString
bs -> (Key
"protected" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (ByteString -> Text
T.decodeUtf8 (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s1 a s2.
(Cons s1 s1 a a, Cons s2 s2 a a, AsEmpty s2) =>
Getter s1 s2
recons ByteString
bs)) forall a. a -> [a] -> [a]
:)
      unp :: [Pair] -> [Pair]
unp = case forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
a p -> Maybe Value
unprotectedParams a p
h of
        Maybe Value
Nothing -> forall a. a -> a
id
        Just Value
o -> (Key
"header" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
o forall a. a -> [a] -> [a]
:)
    in
      [Pair] -> Value
object forall a b. (a -> b) -> a -> b
$ ([Pair] -> [Pair]
pro forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> [Pair]
unp) [Key
"signature" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Base64Octets
sig]


instance HasParams JWSHeader where
  parseParamsFor :: forall (b :: * -> *) p.
(HasParams b, ProtectionIndicator p) =>
Proxy b -> Maybe Object -> Maybe Object -> Parser (JWSHeader p)
parseParamsFor Proxy b
proxy Maybe Object
hp Maybe Object
hu = forall p.
HeaderParam p Alg
-> Maybe (HeaderParam p URI)
-> Maybe (HeaderParam p JWK)
-> Maybe (HeaderParam p Text)
-> Maybe (HeaderParam p URI)
-> Maybe (HeaderParam p (NonEmpty SignedCertificate))
-> Maybe (HeaderParam p Base64SHA1)
-> Maybe (HeaderParam p Base64SHA256)
-> Maybe (HeaderParam p Text)
-> Maybe (HeaderParam p Text)
-> Maybe (NonEmpty Text)
-> JWSHeader p
JWSHeader
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a p.
(FromJSON a, ProtectionIndicator p) =>
Text -> Maybe Object -> Maybe Object -> Parser (HeaderParam p a)
headerRequired Text
"alg" Maybe Object
hp Maybe Object
hu
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall p a.
ProtectionIndicator p =>
(Value -> Parser a)
-> Text
-> Maybe Object
-> Maybe Object
-> Parser (Maybe (HeaderParam p a))
headerOptional' Value -> Parser URI
uriFromJSON Text
"jku" Maybe Object
hp Maybe Object
hu
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a p.
(FromJSON a, ProtectionIndicator p) =>
Text
-> Maybe Object -> Maybe Object -> Parser (Maybe (HeaderParam p a))
headerOptional Text
"jwk" Maybe Object
hp Maybe Object
hu
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a p.
(FromJSON a, ProtectionIndicator p) =>
Text
-> Maybe Object -> Maybe Object -> Parser (Maybe (HeaderParam p a))
headerOptional Text
"kid" Maybe Object
hp Maybe Object
hu
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall p a.
ProtectionIndicator p =>
(Value -> Parser a)
-> Text
-> Maybe Object
-> Maybe Object
-> Parser (Maybe (HeaderParam p a))
headerOptional' Value -> Parser URI
uriFromJSON Text
"x5u" Maybe Object
hp Maybe Object
hu
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap)
          (\(Types.Base64X509 SignedCertificate
cert) -> SignedCertificate
cert) (forall a p.
(FromJSON a, ProtectionIndicator p) =>
Text
-> Maybe Object -> Maybe Object -> Parser (Maybe (HeaderParam p a))
headerOptional Text
"x5c" Maybe Object
hp Maybe Object
hu)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a p.
(FromJSON a, ProtectionIndicator p) =>
Text
-> Maybe Object -> Maybe Object -> Parser (Maybe (HeaderParam p a))
headerOptional Text
"x5t" Maybe Object
hp Maybe Object
hu
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a p.
(FromJSON a, ProtectionIndicator p) =>
Text
-> Maybe Object -> Maybe Object -> Parser (Maybe (HeaderParam p a))
headerOptional Text
"x5t#S256" Maybe Object
hp Maybe Object
hu
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a p.
(FromJSON a, ProtectionIndicator p) =>
Text
-> Maybe Object -> Maybe Object -> Parser (Maybe (HeaderParam p a))
headerOptional Text
"typ" Maybe Object
hp Maybe Object
hu
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a p.
(FromJSON a, ProtectionIndicator p) =>
Text
-> Maybe Object -> Maybe Object -> Parser (Maybe (HeaderParam p a))
headerOptional Text
"cty" Maybe Object
hp Maybe Object
hu
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a.
FromJSON a =>
Text -> Maybe Object -> Maybe Object -> Parser (Maybe a)
headerOptionalProtected Text
"crit" Maybe Object
hp Maybe Object
hu
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t0 :: * -> *) (t1 :: * -> *) (t2 :: * -> *) (t3 :: * -> *)
       (m :: * -> *).
(Foldable t0, Foldable t1, Traversable t2, Traversable t3,
 MonadFail m) =>
t0 Text -> t1 Text -> Object -> t2 (t3 Text) -> m (t2 (t3 Text))
parseCrit [Text]
jwsCritInvalidNames (forall (a :: * -> *). HasParams a => Proxy a -> [Text]
extensions Proxy b
proxy)
        (forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty Maybe Object
hp forall a. Semigroup a => a -> a -> a
<> forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty Maybe Object
hu))
  params :: forall p. ProtectionIndicator p => JWSHeader p -> [(Bool, Pair)]
params JWSHeader p
h =
    forall a. [Maybe a] -> [a]
catMaybes
      [ forall a. a -> Maybe a
Just (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall (a :: * -> *) p. HasAlg a => Lens' (a p) (HeaderParam p Alg)
alg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p a. ProtectionIndicator p => Getter (HeaderParam p a) Bool
isProtected) JWSHeader p
h, Key
"alg" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall (a :: * -> *) p. HasAlg a => Lens' (a p) (HeaderParam p Alg)
alg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p a. Lens' (HeaderParam p a) a
param) JWSHeader p
h)
      , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HeaderParam p URI
p -> (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall p a. ProtectionIndicator p => Getter (HeaderParam p a) Bool
isProtected HeaderParam p URI
p, Key
"jku" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views forall p a. Lens' (HeaderParam p a) a
param URI -> Value
uriToJSON HeaderParam p URI
p)) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (a :: * -> *) p.
HasJku a =>
Lens' (a p) (Maybe (HeaderParam p URI))
jku JWSHeader p
h)
      , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HeaderParam p JWK
p -> (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall p a. ProtectionIndicator p => Getter (HeaderParam p a) Bool
isProtected HeaderParam p JWK
p, Key
"jwk" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall p a. Lens' (HeaderParam p a) a
param HeaderParam p JWK
p)) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (a :: * -> *) p.
HasJwk a =>
Lens' (a p) (Maybe (HeaderParam p JWK))
jwk JWSHeader p
h)
      , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HeaderParam p Text
p -> (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall p a. ProtectionIndicator p => Getter (HeaderParam p a) Bool
isProtected HeaderParam p Text
p, Key
"kid" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall p a. Lens' (HeaderParam p a) a
param HeaderParam p Text
p)) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (a :: * -> *) p.
HasKid a =>
Lens' (a p) (Maybe (HeaderParam p Text))
kid JWSHeader p
h)
      , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HeaderParam p URI
p -> (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall p a. ProtectionIndicator p => Getter (HeaderParam p a) Bool
isProtected HeaderParam p URI
p, Key
"x5u" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views forall p a. Lens' (HeaderParam p a) a
param URI -> Value
uriToJSON HeaderParam p URI
p)) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (a :: * -> *) p.
HasX5u a =>
Lens' (a p) (Maybe (HeaderParam p URI))
x5u JWSHeader p
h)
      , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HeaderParam p (NonEmpty SignedCertificate)
p -> (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall p a. ProtectionIndicator p => Getter (HeaderParam p a) Bool
isProtected HeaderParam p (NonEmpty SignedCertificate)
p, Key
"x5c" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SignedCertificate -> Base64X509
Types.Base64X509 (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall p a. Lens' (HeaderParam p a) a
param HeaderParam p (NonEmpty SignedCertificate)
p))) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (a :: * -> *) p.
HasX5c a =>
Lens' (a p) (Maybe (HeaderParam p (NonEmpty SignedCertificate)))
x5c JWSHeader p
h)
      , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HeaderParam p Base64SHA1
p -> (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall p a. ProtectionIndicator p => Getter (HeaderParam p a) Bool
isProtected HeaderParam p Base64SHA1
p, Key
"x5t" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall p a. Lens' (HeaderParam p a) a
param HeaderParam p Base64SHA1
p)) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (a :: * -> *) p.
HasX5t a =>
Lens' (a p) (Maybe (HeaderParam p Base64SHA1))
x5t JWSHeader p
h)
      , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HeaderParam p Base64SHA256
p -> (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall p a. ProtectionIndicator p => Getter (HeaderParam p a) Bool
isProtected HeaderParam p Base64SHA256
p, Key
"x5t#S256" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall p a. Lens' (HeaderParam p a) a
param HeaderParam p Base64SHA256
p)) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (a :: * -> *) p.
HasX5tS256 a =>
Lens' (a p) (Maybe (HeaderParam p Base64SHA256))
x5tS256 JWSHeader p
h)
      , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HeaderParam p Text
p -> (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall p a. ProtectionIndicator p => Getter (HeaderParam p a) Bool
isProtected HeaderParam p Text
p, Key
"typ" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall p a. Lens' (HeaderParam p a) a
param HeaderParam p Text
p)) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (a :: * -> *) p.
HasTyp a =>
Lens' (a p) (Maybe (HeaderParam p Text))
typ JWSHeader p
h)
      , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\HeaderParam p Text
p -> (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall p a. ProtectionIndicator p => Getter (HeaderParam p a) Bool
isProtected HeaderParam p Text
p, Key
"cty" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall p a. Lens' (HeaderParam p a) a
param HeaderParam p Text
p)) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (a :: * -> *) p.
HasCty a =>
Lens' (a p) (Maybe (HeaderParam p Text))
cty JWSHeader p
h)
      , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NonEmpty Text
p -> (Bool
True, Key
"crit" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NonEmpty Text
p)) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (a :: * -> *) p.
HasCrit a =>
Lens' (a p) (Maybe (NonEmpty Text))
crit JWSHeader p
h)
      ]


-- | JSON Web Signature data type.  The payload can only be
-- accessed by verifying the JWS.
--
-- Parameterised by the signature container type, the header
-- 'ProtectionIndicator' type, and the header record type.
--
-- Use 'encode' and 'decode' to convert a JWS to or from JSON.
-- When encoding a @'JWS' []@ with exactly one signature, the
-- /flattened JWS JSON serialisation/ syntax is used, otherwise
-- the /general JWS JSON serialisation/ is used.
-- When decoding a @'JWS' []@ either serialisation is accepted.
--
-- @'JWS' 'Identity'@ uses the flattened JSON serialisation
-- or the /JWS compact serialisation/ (see 'decodeCompact' and
-- 'encodeCompact').
--
-- Use 'signJWS' to create a signed/MACed JWS.
--
-- Use 'verifyJWS' to verify a JWS and extract the payload.
--
data JWS t p a = JWS Types.Base64Octets (t (Signature p a))

-- | A JWS that allows multiple signatures, and cannot use
-- the /compact serialisation/.  Headers may be 'Protected'
-- or 'Unprotected'.
--
type GeneralJWS = JWS [] Protection

-- | A JWS with one signature, which uses the
-- /flattened serialisation/.  Headers may be 'Protected'
-- or 'Unprotected'.
--
type FlattenedJWS = JWS Identity Protection

-- | A JWS with one signature which only allows protected
-- parameters.  Can use the /flattened serialisation/ or
-- the /compact serialisation/.
--
type CompactJWS = JWS Identity ()

instance (Eq (t (Signature p a))) => Eq (JWS t p a) where
  JWS Base64Octets
p t (Signature p a)
sigs == :: JWS t p a -> JWS t p a -> Bool
== JWS Base64Octets
p' t (Signature p a)
sigs' = Base64Octets
p forall a. Eq a => a -> a -> Bool
== Base64Octets
p' Bool -> Bool -> Bool
&& t (Signature p a)
sigs forall a. Eq a => a -> a -> Bool
== t (Signature p a)
sigs'

instance (Show (t (Signature p a))) => Show (JWS t p a) where
  show :: JWS t p a -> String
show (JWS Base64Octets
p t (Signature p a)
sigs) = String
"JWS " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Base64Octets
p forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show t (Signature p a)
sigs

signatures :: Foldable t => Fold (JWS t p a) (Signature p a)
signatures :: forall (t :: * -> *) p (a :: * -> *).
Foldable t =>
Fold (JWS t p a) (Signature p a)
signatures = forall (f :: * -> *) s a. Foldable f => (s -> f a) -> Fold s a
folding (\(JWS Base64Octets
_ t (Signature p a)
sigs) -> t (Signature p a)
sigs)

instance (HasParams a, ProtectionIndicator p) => FromJSON (JWS [] p a) where
  parseJSON :: Value -> Parser (JWS [] p a)
parseJSON Value
v =
    forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"JWS JSON serialization" (\Object
o -> forall (t :: * -> *) p (a :: * -> *).
Base64Octets -> t (Signature p a) -> JWS t p a
JWS
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"payload"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"signatures") Value
v
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(JWS Base64Octets
p (Identity Signature p a
s)) -> forall (t :: * -> *) p (a :: * -> *).
Base64Octets -> t (Signature p a) -> JWS t p a
JWS Base64Octets
p [Signature p a
s]) (forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)

instance (HasParams a, ProtectionIndicator p) => FromJSON (JWS Identity p a) where
  parseJSON :: Value -> Parser (JWS Identity p a)
parseJSON =
    forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Flattened JWS JSON serialization" forall a b. (a -> b) -> a -> b
$ \Object
o ->
      if forall a. Key -> KeyMap a -> Bool
M.member Key
"signatures" Object
o
      then forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"\"signatures\" member MUST NOT be present"
      else (\Base64Octets
p Signature p a
s -> forall (t :: * -> *) p (a :: * -> *).
Base64Octets -> t (Signature p a) -> JWS t p a
JWS Base64Octets
p (forall (f :: * -> *) a. Applicative f => a -> f a
pure Signature p a
s)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"payload" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)

instance (HasParams a, ProtectionIndicator p) => ToJSON (JWS [] p a) where
  toJSON :: JWS [] p a -> Value
toJSON (JWS Base64Octets
p [Signature p a
s]) = forall v. ToJSON v => Key -> v -> Value -> Value
Types.insertToObject Key
"payload" Base64Octets
p (forall a. ToJSON a => a -> Value
toJSON Signature p a
s)
  toJSON (JWS Base64Octets
p [Signature p a]
ss) = [Pair] -> Value
object [Key
"payload" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Base64Octets
p, Key
"signatures" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Signature p a]
ss]

instance (HasParams a, ProtectionIndicator p) => ToJSON (JWS Identity p a) where
  toJSON :: JWS Identity p a -> Value
toJSON (JWS Base64Octets
p (Identity Signature p a
s)) = forall v. ToJSON v => Key -> v -> Value -> Value
Types.insertToObject Key
"payload" Base64Octets
p (forall a. ToJSON a => a -> Value
toJSON Signature p a
s)


signingInput
  :: (HasParams a, ProtectionIndicator p)
  => Signature p a
  -> Types.Base64Octets
  -> B.ByteString
signingInput :: forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
Signature p a -> Base64Octets -> ByteString
signingInput Signature p a
sig (Types.Base64Octets ByteString
p) =
  forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
Signature p a -> ByteString
rawProtectedHeader Signature p a
sig forall a. Semigroup a => a -> a -> a
<> ByteString
"." forall a. Semigroup a => a -> a -> a
<> forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review forall s1 s2.
(AsEmpty s1, AsEmpty s2, Cons s1 s1 Word8 Word8,
 Cons s2 s2 Word8 Word8) =>
Prism' s1 s2
Types.base64url ByteString
p

-- | Return the raw base64url-encoded protected header value.
-- If the Signature was decoded from JSON, this returns the
-- original string value as-is.
--
-- Application code should never need to use this.  It is exposed
-- for testing purposes.
rawProtectedHeader
  :: (HasParams a, ProtectionIndicator p)
  => Signature p a -> B.ByteString
rawProtectedHeader :: forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
Signature p a -> ByteString
rawProtectedHeader (Signature Maybe Text
raw a p
h Base64Octets
_) =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s1 a s2.
(Cons s1 s1 a a, Cons s2 s2 a a, AsEmpty s2) =>
Getter s1 s2
recons forall a b. (a -> b) -> a -> b
$ forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
a p -> ByteString
protectedParamsEncoded a p
h) Text -> ByteString
T.encodeUtf8 Maybe Text
raw

-- Convert JWS to compact serialization.
--
-- The operation is defined only when there is exactly one
-- signature and returns Nothing otherwise
--
instance HasParams a => ToCompact (JWS Identity () a) where
  toCompact :: JWS Identity () a -> [ByteString]
toCompact (JWS Base64Octets
p (Identity s :: Signature () a
s@(Signature Maybe Text
_ a ()
_ (Types.Base64Octets ByteString
sig)))) =
    [ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s1 a s2.
(Cons s1 s1 a a, Cons s2 s2 a a, AsEmpty s2) =>
Getter s1 s2
recons forall a b. (a -> b) -> a -> b
$ forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
Signature p a -> Base64Octets -> ByteString
signingInput Signature () a
s Base64Octets
p
    , forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review forall s1 s2.
(AsEmpty s1, AsEmpty s2, Cons s1 s1 Word8 Word8,
 Cons s2 s2 Word8 Word8) =>
Prism' s1 s2
Types.base64url ByteString
sig
    ]

instance HasParams a => FromCompact (JWS Identity () a) where
  fromCompact :: forall e (m :: * -> *).
(AsError e, MonadError e m) =>
[ByteString] -> m (JWS Identity () a)
fromCompact [ByteString]
xs = case [ByteString]
xs of
    [ByteString
h, ByteString
p, ByteString
s] -> do
      (Value
h', Value
p', Value
s') <- (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> ByteString -> m Value
t Natural
0 ByteString
h forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Natural -> ByteString -> m Value
t Natural
1 ByteString
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Natural -> ByteString -> m Value
t Natural
2 ByteString
s
      let o :: Value
o = [Pair] -> Value
object [ (Key
"payload", Value
p'), (Key
"protected", Value
h'), (Key
"signature", Value
s') ]
      case forall a. FromJSON a => Value -> Result a
fromJSON Value
o of
        Error String
e -> forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing forall r. AsError r => Prism' r String
_JSONDecodeError String
e
        Success JWS Identity () a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure JWS Identity () a
a
    [ByteString]
xs' -> forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing (forall r. AsError r => Prism' r CompactDecodeError
_CompactDecodeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' CompactDecodeError InvalidNumberOfParts
_CompactInvalidNumberOfParts)
            (Natural -> Natural -> InvalidNumberOfParts
InvalidNumberOfParts Natural
3 (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
xs')))
    where
      l :: Tagged CompactTextError (Identity CompactTextError)
-> Tagged e (Identity e)
l = forall r. AsError r => Prism' r CompactDecodeError
_CompactDecodeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' CompactDecodeError CompactTextError
_CompactInvalidText
      t :: Natural -> ByteString -> m Value
t Natural
n = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing Tagged CompactTextError (Identity CompactTextError)
-> Tagged e (Identity e)
l forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> UnicodeException -> CompactTextError
CompactTextError Natural
n) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
String)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
T.decodeUtf8' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s1 a s2.
(Cons s1 s1 a a, Cons s2 s2 a a, AsEmpty s2) =>
Getter s1 s2
recons


-- | Create a signed or MACed JWS with the given payload by
-- traversing a collection of @(header, key)@ pairs.
--
signJWS
  :: ( Cons s s Word8 Word8
     , HasJWSHeader a, HasParams a, MonadRandom m, AsError e, MonadError e m
     , Traversable t
     , ProtectionIndicator p
     )
  => s          -- ^ Payload
  -> t (a p, JWK) -- ^ Traversable of header, key pairs
  -> m (JWS t p a)
signJWS :: forall s (a :: * -> *) (m :: * -> *) e (t :: * -> *) p.
(Cons s s Word8 Word8, HasJWSHeader a, HasParams a, MonadRandom m,
 AsError e, MonadError e m, Traversable t, ProtectionIndicator p) =>
s -> t (a p, JWK) -> m (JWS t p a)
signJWS s
s =
  let s' :: ByteString
s' = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s1 a s2.
(Cons s1 s1 a a, Cons s2 s2 a a, AsEmpty s2) =>
Getter s1 s2
recons s
s
  in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) p (a :: * -> *).
Base64Octets -> t (Signature p a) -> JWS t p a
JWS (ByteString -> Base64Octets
Types.Base64Octets ByteString
s')) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall (a :: * -> *) (m :: * -> *) e p.
(HasJWSHeader a, HasParams a, MonadRandom m, AsError e,
 MonadError e m, ProtectionIndicator p) =>
ByteString -> a p -> JWK -> m (Signature p a)
mkSignature ByteString
s'))
{-# INLINE signJWS #-}

mkSignature
  :: ( HasJWSHeader a, HasParams a, MonadRandom m, AsError e, MonadError e m
     , ProtectionIndicator p
     )
  => B.ByteString -> a p -> JWK -> m (Signature p a)
mkSignature :: forall (a :: * -> *) (m :: * -> *) e p.
(HasJWSHeader a, HasParams a, MonadRandom m, AsError e,
 MonadError e m, ProtectionIndicator p) =>
ByteString -> a p -> JWK -> m (Signature p a)
mkSignature ByteString
p a p
h JWK
k =
  let
    almostSig :: ByteString -> Signature p a
almostSig = forall p (a :: * -> *).
Maybe Text -> a p -> Base64Octets -> Signature p a
Signature forall {a}. Maybe a
Nothing a p
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Base64Octets
Types.Base64Octets
  in
    ByteString -> Signature p a
almostSig
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) e.
(MonadRandom m, MonadError e m, AsError e) =>
Alg -> KeyMaterial -> ByteString -> m ByteString
sign
          (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall (a :: * -> *) p. HasAlg a => Lens' (a p) (HeaderParam p Alg)
alg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p a. Lens' (HeaderParam p a) a
param) a p
h)
          (JWK
k forall s a. s -> Getting a s a -> a
^. Lens' JWK KeyMaterial
jwkMaterial)
          (forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
Signature p a -> Base64Octets -> ByteString
signingInput (ByteString -> Signature p a
almostSig ByteString
"") (ByteString -> Base64Octets
Types.Base64Octets ByteString
p))


-- | Validation policy.
--
data ValidationPolicy
  = AnyValidated
  -- ^ One successfully validated signature is sufficient
  | AllValidated
  -- ^ All signatures in all configured algorithms must be validated.
  -- No signatures in configured algorithms is also an error.
  deriving (ValidationPolicy -> ValidationPolicy -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidationPolicy -> ValidationPolicy -> Bool
$c/= :: ValidationPolicy -> ValidationPolicy -> Bool
== :: ValidationPolicy -> ValidationPolicy -> Bool
$c== :: ValidationPolicy -> ValidationPolicy -> Bool
Eq)

-- | Validation settings:
--
-- * The set of acceptable signature algorithms
-- * The validation policy
--
data ValidationSettings = ValidationSettings
  (S.Set Alg)
  ValidationPolicy

class HasValidationSettings a where
  validationSettings :: Lens' a ValidationSettings

  validationSettingsAlgorithms :: Lens' a (S.Set Alg)
  validationSettingsAlgorithms = forall a. HasValidationSettings a => Lens' a ValidationSettings
validationSettings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {f :: * -> *}.
Functor f =>
(Set Alg -> f (Set Alg))
-> ValidationSettings -> f ValidationSettings
go where
    go :: (Set Alg -> f (Set Alg))
-> ValidationSettings -> f ValidationSettings
go Set Alg -> f (Set Alg)
f (ValidationSettings Set Alg
algs ValidationPolicy
pol) =
      (Set Alg -> ValidationPolicy -> ValidationSettings
`ValidationSettings` ValidationPolicy
pol) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Alg -> f (Set Alg)
f Set Alg
algs

  validationSettingsValidationPolicy :: Lens' a ValidationPolicy
  validationSettingsValidationPolicy = forall a. HasValidationSettings a => Lens' a ValidationSettings
validationSettings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {f :: * -> *}.
Functor f =>
(ValidationPolicy -> f ValidationPolicy)
-> ValidationSettings -> f ValidationSettings
go where
    go :: (ValidationPolicy -> f ValidationPolicy)
-> ValidationSettings -> f ValidationSettings
go ValidationPolicy -> f ValidationPolicy
f (ValidationSettings Set Alg
algs ValidationPolicy
pol) =
      Set Alg -> ValidationPolicy -> ValidationSettings
ValidationSettings Set Alg
algs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValidationPolicy -> f ValidationPolicy
f ValidationPolicy
pol

instance HasValidationSettings ValidationSettings where
  validationSettings :: Lens' ValidationSettings ValidationSettings
validationSettings = forall a. a -> a
id

class HasAlgorithms s where
  algorithms :: Lens' s (S.Set Alg)
class HasValidationPolicy s where
  validationPolicy :: Lens' s ValidationPolicy

instance HasValidationSettings a => HasAlgorithms a where
  algorithms :: Lens' a (Set Alg)
algorithms = forall a. HasValidationSettings a => Lens' a (Set Alg)
validationSettingsAlgorithms
instance HasValidationSettings a => HasValidationPolicy a where
  validationPolicy :: Lens' a ValidationPolicy
validationPolicy = forall a. HasValidationSettings a => Lens' a ValidationPolicy
validationSettingsValidationPolicy

-- | The default validation settings.
--
-- - All algorithms except "none" are acceptable.
-- - All signatures must be valid (and there must be at least one signature.)
--
defaultValidationSettings :: ValidationSettings
defaultValidationSettings :: ValidationSettings
defaultValidationSettings = Set Alg -> ValidationPolicy -> ValidationSettings
ValidationSettings
  ( forall a. Ord a => [a] -> Set a
S.fromList
    [ Alg
HS256, Alg
HS384, Alg
HS512
    , Alg
RS256, Alg
RS384, Alg
RS512
    , Alg
ES256, Alg
ES384, Alg
ES512
    , Alg
PS256, Alg
PS384, Alg
PS512
    , Alg
EdDSA
    , Alg
ES256K
    ] )
  ValidationPolicy
AllValidated

-- | Verify a JWS with the default validation settings.
--
-- See also 'defaultValidationSettings'.
--
verifyJWS'
  ::  ( AsError e, MonadError e m , HasJWSHeader h, HasParams h
      , VerificationKeyStore m (h p) s k
      , Cons s s Word8 Word8, AsEmpty s
      , Foldable t
      , ProtectionIndicator p
      )
  => k      -- ^ key or key store
  -> JWS t p h  -- ^ JWS
  -> m s
verifyJWS' :: forall e (m :: * -> *) (h :: * -> *) p s k (t :: * -> *).
(AsError e, MonadError e m, HasJWSHeader h, HasParams h,
 VerificationKeyStore m (h p) s k, Cons s s Word8 Word8, AsEmpty s,
 Foldable t, ProtectionIndicator p) =>
k -> JWS t p h -> m s
verifyJWS' = forall a e (m :: * -> *) (h :: * -> *) p s k (t :: * -> *).
(HasAlgorithms a, HasValidationPolicy a, AsError e, MonadError e m,
 HasJWSHeader h, HasParams h, VerificationKeyStore m (h p) s k,
 Cons s s Word8 Word8, AsEmpty s, Foldable t,
 ProtectionIndicator p) =>
a -> k -> JWS t p h -> m s
verifyJWS ValidationSettings
defaultValidationSettings
{-# INLINE verifyJWS' #-}

-- | Verify a JWS.
--
-- Signatures made with an unsupported algorithms are ignored.
-- If the validation policy is 'AnyValidated', a single successfully
-- validated signature is sufficient.  If the validation policy is
-- 'AllValidated' then all remaining signatures (there must be at least one)
-- must be valid.
--
-- Returns the payload if successfully verified.
--
verifyJWS
  ::  ( HasAlgorithms a, HasValidationPolicy a, AsError e, MonadError e m
      , HasJWSHeader h, HasParams h
      , VerificationKeyStore m (h p) s k
      , Cons s s Word8 Word8, AsEmpty s
      , Foldable t
      , ProtectionIndicator p
      )
  => a        -- ^ validation settings
  -> k        -- ^ key or key store
  -> JWS t p h  -- ^ JWS
  -> m s
verifyJWS :: forall a e (m :: * -> *) (h :: * -> *) p s k (t :: * -> *).
(HasAlgorithms a, HasValidationPolicy a, AsError e, MonadError e m,
 HasJWSHeader h, HasParams h, VerificationKeyStore m (h p) s k,
 Cons s s Word8 Word8, AsEmpty s, Foldable t,
 ProtectionIndicator p) =>
a -> k -> JWS t p h -> m s
verifyJWS = forall a e (m :: * -> *) (h :: * -> *) p payload k s (t :: * -> *).
(HasAlgorithms a, HasValidationPolicy a, AsError e, MonadError e m,
 HasJWSHeader h, HasParams h,
 VerificationKeyStore m (h p) payload k, Cons s s Word8 Word8,
 AsEmpty s, Foldable t, ProtectionIndicator p) =>
(s -> m payload) -> a -> k -> JWS t p h -> m payload
verifyJWSWithPayload forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE verifyJWS #-}

verifyJWSWithPayload
  ::  ( HasAlgorithms a, HasValidationPolicy a, AsError e, MonadError e m
      , HasJWSHeader h, HasParams h
      , VerificationKeyStore m (h p) payload k
      , Cons s s Word8 Word8, AsEmpty s
      , Foldable t
      , ProtectionIndicator p
      )
  => (s -> m payload)  -- ^ payload decoder
  -> a                 -- ^ validation settings
  -> k                 -- ^ key or key store
  -> JWS t p h         -- ^ JWS
  -> m payload
verifyJWSWithPayload :: forall a e (m :: * -> *) (h :: * -> *) p payload k s (t :: * -> *).
(HasAlgorithms a, HasValidationPolicy a, AsError e, MonadError e m,
 HasJWSHeader h, HasParams h,
 VerificationKeyStore m (h p) payload k, Cons s s Word8 Word8,
 AsEmpty s, Foldable t, ProtectionIndicator p) =>
(s -> m payload) -> a -> k -> JWS t p h -> m payload
verifyJWSWithPayload s -> m payload
dec a
conf k
k (JWS p :: Base64Octets
p@(Types.Base64Octets ByteString
p') t (Signature p h)
sigs) =
  let
    algs :: S.Set Alg
    algs :: Set Alg
algs = a
conf forall s a. s -> Getting a s a -> a
^. forall s. HasAlgorithms s => Lens' s (Set Alg)
algorithms
    policy :: ValidationPolicy
    policy :: ValidationPolicy
policy = a
conf forall s a. s -> Getting a s a -> a
^. forall s. HasValidationPolicy s => Lens' s ValidationPolicy
validationPolicy
    shouldValidateSig :: Signature p h -> Bool
shouldValidateSig = (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set Alg
algs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall p (a :: * -> *). Getter (Signature p a) (a p)
header forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> *) p. HasAlg a => Lens' (a p) (HeaderParam p Alg)
alg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p a. Lens' (HeaderParam p a) a
param)

    applyPolicy :: ValidationPolicy -> [Bool] -> f ()
applyPolicy ValidationPolicy
AnyValidated [Bool]
xs = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
xs) (forall e (m :: * -> *) x. MonadError e m => AReview e () -> m x
throwing_ forall r. AsError r => Prism' r ()
_JWSNoValidSignatures)
    applyPolicy ValidationPolicy
AllValidated [] = forall e (m :: * -> *) x. MonadError e m => AReview e () -> m x
throwing_ forall r. AsError r => Prism' r ()
_JWSNoSignatures
    applyPolicy ValidationPolicy
AllValidated [Bool]
xs = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
xs) (forall e (m :: * -> *) x. MonadError e m => AReview e () -> m x
throwing_ forall r. AsError r => Prism' r ()
_JWSInvalidSignature)

    validate :: payload -> Signature p h -> m Bool
validate payload
payload Signature p h
sig = do
      [JWK]
keys <- forall (m :: * -> *) h s a.
VerificationKeyStore m h s a =>
h -> s -> a -> m [JWK]
getVerificationKeys (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall p (a :: * -> *). Getter (Signature p a) (a p)
header Signature p h
sig) payload
payload k
k
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JWK]
keys
        then forall e (m :: * -> *) x. MonadError e m => AReview e () -> m x
throwing_ forall r. AsError r => Prism' r ()
_NoUsableKeys
        else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((forall a. Eq a => a -> a -> Bool
== forall a b. b -> Either a b
Right Bool
True) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> *) p.
(HasJWSHeader a, HasParams a, ProtectionIndicator p) =>
Base64Octets -> Signature p a -> JWK -> Either Error Bool
verifySig Base64Octets
p Signature p h
sig) [JWK]
keys
  in do
    payload
payload <- (s -> m payload
dec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s1 a s2.
(Cons s1 s1 a a, Cons s2 s2 a a, AsEmpty s2) =>
Getter s1 s2
recons) ByteString
p'
    [Bool]
results <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (payload -> Signature p h -> m Bool
validate payload
payload) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall {p}. Signature p h -> Bool
shouldValidateSig forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t (Signature p h)
sigs
    payload
payload forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall {e} {f :: * -> *}.
(MonadError e f, AsError e) =>
ValidationPolicy -> [Bool] -> f ()
applyPolicy ValidationPolicy
policy [Bool]
results
{-# INLINE verifyJWSWithPayload #-}

verifySig
  :: (HasJWSHeader a, HasParams a, ProtectionIndicator p)
  => Types.Base64Octets
  -> Signature p a
  -> JWK
  -> Either Error Bool
verifySig :: forall (a :: * -> *) p.
(HasJWSHeader a, HasParams a, ProtectionIndicator p) =>
Base64Octets -> Signature p a -> JWK -> Either Error Bool
verifySig Base64Octets
msg sig :: Signature p a
sig@(Signature Maybe Text
_ a p
h (Types.Base64Octets ByteString
s)) JWK
k =
  forall e (m :: * -> *).
(MonadError e m, AsError e) =>
Alg -> KeyMaterial -> ByteString -> ByteString -> m Bool
verify (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall (a :: * -> *) p. HasAlg a => Lens' (a p) (HeaderParam p Alg)
alg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p a. Lens' (HeaderParam p a) a
param) a p
h) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' JWK KeyMaterial
jwkMaterial JWK
k) ByteString
tbs ByteString
s
  where
  tbs :: ByteString
tbs = forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
Signature p a -> Base64Octets -> ByteString
signingInput Signature p a
sig Base64Octets
msg