-- Copyright (C) 2016, 2017  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.

{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-|

Types and functions for working with JOSE header parameters.

-}
module Crypto.JOSE.Header
  (
  -- * Defining header data types
    HeaderParam(..)
  , ProtectionIndicator(..)
  , Protection(..)
  , protection
  , isProtected
  , param

  -- * Defining header parsers
  -- $parsing
  , HasParams(..)
  , headerRequired
  , headerRequiredProtected
  , headerOptional
  , headerOptional'
  , headerOptionalProtected

  -- * Parsing headers
  , parseParams
  , parseCrit

  -- * Encoding headers
  , protectedParamsEncoded
  , unprotectedParams


  -- * Header fields shared by JWS and JWE
  , HasAlg(..)
  , HasJku(..)
  , HasJwk(..)
  , HasKid(..)
  , HasX5u(..)
  , HasX5c(..)
  , HasX5t(..)
  , HasX5tS256(..)
  , HasTyp(..)
  , HasCty(..)
  , HasCrit(..)
  ) where


import qualified Control.Monad.Fail as Fail
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty)
import Data.Proxy (Proxy(..))

import Control.Lens (Lens', Getter, review, to)
import Data.Aeson (FromJSON(..), Object, Value, encode, object)
import Data.Aeson.Types (Pair, Parser)
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as M
import qualified Data.ByteString.Lazy as L
import qualified Data.Text as T

import qualified Crypto.JOSE.JWA.JWS as JWA.JWS
import Crypto.JOSE.JWK (JWK)
import Crypto.JOSE.Types.Internal (base64url)
import qualified Crypto.JOSE.Types as Types


-- | A thing with parameters.
--
class HasParams (a :: Type -> Type) where
  -- | Return a list of parameters,
  -- each paired with whether it is protected or not.
  params :: ProtectionIndicator p => a p -> [(Bool, Pair)]

  -- | List of "known extensions", i.e. keys that may appear in the
  -- "crit" header parameter.
  extensions :: Proxy a -> [T.Text]
  extensions = [Text] -> Proxy a -> [Text]
forall a b. a -> b -> a
const []

  parseParamsFor
    :: (HasParams b, ProtectionIndicator p)
    => Proxy b -> Maybe Object -> Maybe Object -> Parser (a p)

-- | Parse a pair of objects (protected and unprotected header)
--
-- This internally invokes 'parseParamsFor' applied to a proxy for
-- the target type.  (This allows the parsing of the "crit" parameter
-- to access "known extensions" understood by the target type.)
--
parseParams
  :: forall a p. (HasParams a, ProtectionIndicator p)
  => Maybe Object -- ^ protected header
  -> Maybe Object -- ^ unprotected header
  -> Parser (a p)
parseParams :: forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
Maybe Object -> Maybe Object -> Parser (a p)
parseParams = Proxy a -> Maybe Object -> Maybe Object -> Parser (a p)
forall (a :: * -> *) (b :: * -> *) p.
(HasParams a, HasParams b, ProtectionIndicator p) =>
Proxy b -> Maybe Object -> Maybe Object -> Parser (a p)
forall (b :: * -> *) p.
(HasParams b, ProtectionIndicator p) =>
Proxy b -> Maybe Object -> Maybe Object -> Parser (a p)
parseParamsFor (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

protectedParams
  :: (HasParams a, ProtectionIndicator p)
  => a p -> Maybe Value {- ^ Object -}
protectedParams :: forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
a p -> Maybe Value
protectedParams a p
h =
  case (((Bool, Pair) -> Pair) -> [(Bool, Pair)] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, Pair) -> Pair
forall a b. (a, b) -> b
snd ([(Bool, Pair)] -> [Pair])
-> (a p -> [(Bool, Pair)]) -> a p -> [Pair]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool, Pair) -> Bool) -> [(Bool, Pair)] -> [(Bool, Pair)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool, Pair) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, Pair)] -> [(Bool, Pair)])
-> (a p -> [(Bool, Pair)]) -> a p -> [(Bool, Pair)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a p -> [(Bool, Pair)]
forall p. ProtectionIndicator p => a p -> [(Bool, Pair)]
forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
a p -> [(Bool, Pair)]
params) a p
h of
    [] -> Maybe Value
forall a. Maybe a
Nothing
    [Pair]
xs -> Value -> Maybe Value
forall a. a -> Maybe a
Just ([Pair] -> Value
object [Pair]
xs)

-- | Return the base64url-encoded protected parameters
--
protectedParamsEncoded
  :: (HasParams a, ProtectionIndicator p)
  => a p -> L.ByteString
protectedParamsEncoded :: forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
a p -> ByteString
protectedParamsEncoded =
  ByteString -> (Value -> ByteString) -> Maybe Value -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
forall a. Monoid a => a
mempty (AReview ByteString ByteString -> ByteString -> ByteString
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview ByteString ByteString
forall s1 s2.
(AsEmpty s1, AsEmpty s2, Cons s1 s1 Word8 Word8,
 Cons s2 s2 Word8 Word8) =>
Prism' s1 s2
Prism' ByteString ByteString
base64url (ByteString -> ByteString)
-> (Value -> ByteString) -> Value -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode) (Maybe Value -> ByteString)
-> (a p -> Maybe Value) -> a p -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a p -> Maybe Value
forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
a p -> Maybe Value
protectedParams

-- | Return unprotected params as a JSON 'Value' (always an object)
--
unprotectedParams
  :: (HasParams a, ProtectionIndicator p)
  => a p -> Maybe Value {- ^ Object -}
unprotectedParams :: forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
a p -> Maybe Value
unprotectedParams a p
h =
  case (((Bool, Pair) -> Pair) -> [(Bool, Pair)] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map (Bool, Pair) -> Pair
forall a b. (a, b) -> b
snd ([(Bool, Pair)] -> [Pair])
-> (a p -> [(Bool, Pair)]) -> a p -> [Pair]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Bool, Pair) -> Bool) -> [(Bool, Pair)] -> [(Bool, Pair)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ((Bool, Pair) -> Bool) -> (Bool, Pair) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, Pair) -> Bool
forall a b. (a, b) -> a
fst) ([(Bool, Pair)] -> [(Bool, Pair)])
-> (a p -> [(Bool, Pair)]) -> a p -> [(Bool, Pair)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a p -> [(Bool, Pair)]
forall p. ProtectionIndicator p => a p -> [(Bool, Pair)]
forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
a p -> [(Bool, Pair)]
params) a p
h of
    [] -> Maybe Value
forall a. Maybe a
Nothing
    [Pair]
xs -> Value -> Maybe Value
forall a. a -> Maybe a
Just ([Pair] -> Value
object [Pair]
xs)

-- | Whether a header is protected or unprotected
--
data Protection = Protected | Unprotected
  deriving (Protection -> Protection -> Bool
(Protection -> Protection -> Bool)
-> (Protection -> Protection -> Bool) -> Eq Protection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Protection -> Protection -> Bool
== :: Protection -> Protection -> Bool
$c/= :: Protection -> Protection -> Bool
/= :: Protection -> Protection -> Bool
Eq, Int -> Protection -> ShowS
[Protection] -> ShowS
Protection -> String
(Int -> Protection -> ShowS)
-> (Protection -> String)
-> ([Protection] -> ShowS)
-> Show Protection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Protection -> ShowS
showsPrec :: Int -> Protection -> ShowS
$cshow :: Protection -> String
show :: Protection -> String
$cshowList :: [Protection] -> ShowS
showList :: [Protection] -> ShowS
Show)

class Eq a => ProtectionIndicator a where
  -- | Get a value for indicating protection.
  getProtected :: a

  -- | Get a 'Just' a value for indicating no protection, or 'Nothing'
  -- if the type does not support unprotected headers.
  getUnprotected :: Maybe a

instance ProtectionIndicator Protection where
  getProtected :: Protection
getProtected = Protection
Protected
  getUnprotected :: Maybe Protection
getUnprotected = Protection -> Maybe Protection
forall a. a -> Maybe a
Just Protection
Unprotected

instance ProtectionIndicator () where
  getProtected :: ()
getProtected = ()
  getUnprotected :: Maybe ()
getUnprotected = Maybe ()
forall a. Maybe a
Nothing


-- | A header value, along with a protection indicator.
--
data HeaderParam p a = HeaderParam p a
  deriving (HeaderParam p a -> HeaderParam p a -> Bool
(HeaderParam p a -> HeaderParam p a -> Bool)
-> (HeaderParam p a -> HeaderParam p a -> Bool)
-> Eq (HeaderParam p a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall p a.
(Eq p, Eq a) =>
HeaderParam p a -> HeaderParam p a -> Bool
$c== :: forall p a.
(Eq p, Eq a) =>
HeaderParam p a -> HeaderParam p a -> Bool
== :: HeaderParam p a -> HeaderParam p a -> Bool
$c/= :: forall p a.
(Eq p, Eq a) =>
HeaderParam p a -> HeaderParam p a -> Bool
/= :: HeaderParam p a -> HeaderParam p a -> Bool
Eq, Int -> HeaderParam p a -> ShowS
[HeaderParam p a] -> ShowS
HeaderParam p a -> String
(Int -> HeaderParam p a -> ShowS)
-> (HeaderParam p a -> String)
-> ([HeaderParam p a] -> ShowS)
-> Show (HeaderParam p a)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall p a. (Show p, Show a) => Int -> HeaderParam p a -> ShowS
forall p a. (Show p, Show a) => [HeaderParam p a] -> ShowS
forall p a. (Show p, Show a) => HeaderParam p a -> String
$cshowsPrec :: forall p a. (Show p, Show a) => Int -> HeaderParam p a -> ShowS
showsPrec :: Int -> HeaderParam p a -> ShowS
$cshow :: forall p a. (Show p, Show a) => HeaderParam p a -> String
show :: HeaderParam p a -> String
$cshowList :: forall p a. (Show p, Show a) => [HeaderParam p a] -> ShowS
showList :: [HeaderParam p a] -> ShowS
Show)

instance Functor (HeaderParam p) where
  fmap :: forall a b. (a -> b) -> HeaderParam p a -> HeaderParam p b
fmap a -> b
f (HeaderParam p
p a
a) = p -> b -> HeaderParam p b
forall p a. p -> a -> HeaderParam p a
HeaderParam p
p (a -> b
f a
a)

-- | Lens for the 'Protection' of a 'HeaderParam'
protection :: Lens' (HeaderParam p a) p
protection :: forall p a (f :: * -> *).
Functor f =>
(p -> f p) -> HeaderParam p a -> f (HeaderParam p a)
protection p -> f p
f (HeaderParam p
p a
v) = (p -> HeaderParam p a) -> f p -> f (HeaderParam p a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\p
p' -> p -> a -> HeaderParam p a
forall p a. p -> a -> HeaderParam p a
HeaderParam p
p' a
v) (p -> f p
f p
p)
{-# ANN protection "HLint: ignore Avoid lambda using `infix`" #-}

-- | Lens for a 'HeaderParam' value
param :: Lens' (HeaderParam p a) a
param :: forall p a (f :: * -> *).
Functor f =>
(a -> f a) -> HeaderParam p a -> f (HeaderParam p a)
param a -> f a
f (HeaderParam p
p a
v) = (a -> HeaderParam p a) -> f a -> f (HeaderParam p a)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
v' -> p -> a -> HeaderParam p a
forall p a. p -> a -> HeaderParam p a
HeaderParam p
p a
v') (a -> f a
f a
v)
{-# ANN param "HLint: ignore Avoid lambda" #-}

-- | Getter for whether a parameter is protected
isProtected :: (ProtectionIndicator p) => Getter (HeaderParam p a) Bool
isProtected :: forall p a. ProtectionIndicator p => Getter (HeaderParam p a) Bool
isProtected = (p -> f p) -> HeaderParam p a -> f (HeaderParam p a)
forall p a (f :: * -> *).
Functor f =>
(p -> f p) -> HeaderParam p a -> f (HeaderParam p a)
protection ((p -> f p) -> HeaderParam p a -> f (HeaderParam p a))
-> ((Bool -> f Bool) -> p -> f p)
-> (Bool -> f Bool)
-> HeaderParam p a
-> f (HeaderParam p a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (p -> Bool) -> (Bool -> f Bool) -> p -> f p
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (p -> p -> Bool
forall a. Eq a => a -> a -> Bool
== p
forall a. ProtectionIndicator a => a
getProtected)


{- $parsing

The 'parseParamsFor' function defines the parser for a header type.

@
'parseParamsFor'
  :: ('HasParams' a, HasParams b)
  => Proxy b -> Maybe Object -> Maybe Object -> 'Parser' a
@

It is defined over two objects: the /protected header/ and the
/unprotected header/.  The following functions are provided for
parsing header parameters:

['headerOptional']
  An optional parameter that may be protected or unprotected.
['headerRequired']
  A required parameter that may be protected or unprotected.
['headerOptionalProtected']
  An optional parameter that, if present, MUST be carried in the protected header.
['headerRequiredProtected']
  A required parameter that, if present, MUST be carried in the protected header.

Duplicate headers are forbidden.  The above functions all perform
duplicate header detection.  If you do not use them, be sure to
perform this detection yourself!

An example parser:

@
instance HasParams ACMEHeader where
  'parseParamsFor' proxy hp hu = ACMEHeader
    \<$> 'parseParamsFor' proxy hp hu
    \<*> 'headerRequiredProtected' "nonce" hp hu
@

-}

-- | Parse an optional parameter that may be carried in either
-- the protected or the unprotected header.
--
headerOptional
  :: (FromJSON a, ProtectionIndicator p)
  => T.Text
  -> Maybe Object
  -> Maybe Object
  -> Parser (Maybe (HeaderParam p a))
headerOptional :: forall a p.
(FromJSON a, ProtectionIndicator p) =>
Text
-> Maybe Object -> Maybe Object -> Parser (Maybe (HeaderParam p a))
headerOptional = (Value -> Parser a)
-> Text
-> Maybe Object
-> Maybe Object
-> Parser (Maybe (HeaderParam p a))
forall p a.
ProtectionIndicator p =>
(Value -> Parser a)
-> Text
-> Maybe Object
-> Maybe Object
-> Parser (Maybe (HeaderParam p a))
headerOptional' Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON

-- | Parse an optional parameter that may be carried in either
-- the protected or the unprotected header.  Like 'headerOptional',
-- but with an explicit argument for the parser.
--
headerOptional'
  :: (ProtectionIndicator p)
  => (Value -> Parser a)
  -> T.Text
  -> Maybe Object
  -> Maybe Object
  -> Parser (Maybe (HeaderParam p a))
headerOptional' :: forall p a.
ProtectionIndicator p =>
(Value -> Parser a)
-> Text
-> Maybe Object
-> Maybe Object
-> Parser (Maybe (HeaderParam p a))
headerOptional' Value -> Parser a
parser Text
kText Maybe Object
hp Maybe Object
hu = case (Maybe Object
hp Maybe Object -> (Object -> Maybe Value) -> Maybe Value
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k, Maybe Object
hu Maybe Object -> (Object -> Maybe Value) -> Maybe Value
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k) of
  (Just Value
_, Just Value
_)    -> String -> Parser (Maybe (HeaderParam p a))
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Maybe (HeaderParam p a)))
-> String -> Parser (Maybe (HeaderParam p a))
forall a b. (a -> b) -> a -> b
$ String
"duplicate header " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
kText
  (Just Value
v, Maybe Value
Nothing)   -> HeaderParam p a -> Maybe (HeaderParam p a)
forall a. a -> Maybe a
Just (HeaderParam p a -> Maybe (HeaderParam p a))
-> (a -> HeaderParam p a) -> a -> Maybe (HeaderParam p a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> a -> HeaderParam p a
forall p a. p -> a -> HeaderParam p a
HeaderParam p
forall a. ProtectionIndicator a => a
getProtected (a -> Maybe (HeaderParam p a))
-> Parser a -> Parser (Maybe (HeaderParam p a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
parser Value
v
  (Maybe Value
Nothing, Just Value
v)   -> Parser (Maybe (HeaderParam p a))
-> (p -> Parser (Maybe (HeaderParam p a)))
-> Maybe p
-> Parser (Maybe (HeaderParam p a))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    (String -> Parser (Maybe (HeaderParam p a))
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unprotected header not supported")
    (\p
p -> HeaderParam p a -> Maybe (HeaderParam p a)
forall a. a -> Maybe a
Just (HeaderParam p a -> Maybe (HeaderParam p a))
-> (a -> HeaderParam p a) -> a -> Maybe (HeaderParam p a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> a -> HeaderParam p a
forall p a. p -> a -> HeaderParam p a
HeaderParam p
p (a -> Maybe (HeaderParam p a))
-> Parser a -> Parser (Maybe (HeaderParam p a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
parser Value
v)
    Maybe p
forall a. ProtectionIndicator a => Maybe a
getUnprotected
  (Maybe Value
Nothing, Maybe Value
Nothing)  -> Maybe (HeaderParam p a) -> Parser (Maybe (HeaderParam p a))
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (HeaderParam p a)
forall a. Maybe a
Nothing
  where
    k :: Key
k = Text -> Key
Key.fromText Text
kText

-- | Parse an optional parameter that, if present, MUST be carried
-- in the protected header.
--
headerOptionalProtected
  :: FromJSON a
  => T.Text
  -> Maybe Object
  -> Maybe Object
  -> Parser (Maybe a)
headerOptionalProtected :: forall a.
FromJSON a =>
Text -> Maybe Object -> Maybe Object -> Parser (Maybe a)
headerOptionalProtected Text
kText Maybe Object
hp Maybe Object
hu = case (Maybe Object
hp Maybe Object -> (Object -> Maybe Value) -> Maybe Value
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k, Maybe Object
hu Maybe Object -> (Object -> Maybe Value) -> Maybe Value
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k) of
  (Just Value
_, Just Value
_)    -> String -> Parser (Maybe a)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Maybe a)) -> String -> Parser (Maybe a)
forall a b. (a -> b) -> a -> b
$ String
"duplicate header " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
kText
  (Maybe Value
_, Just Value
_) -> String -> Parser (Maybe a)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Maybe a)) -> String -> Parser (Maybe a)
forall a b. (a -> b) -> a -> b
$ String
"header must be protected: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
kText
  (Just Value
v, Maybe Value
_) -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Parser a -> Parser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
  (Maybe Value, Maybe Value)
_           -> Maybe a -> Parser (Maybe a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
  where
    k :: Key
k = Text -> Key
Key.fromText Text
kText

-- | Parse a required parameter that may be carried in either
-- the protected or the unprotected header.
--
headerRequired
  :: (FromJSON a, ProtectionIndicator p)
  => T.Text
  -> Maybe Object
  -> Maybe Object
  -> Parser (HeaderParam p a)
headerRequired :: forall a p.
(FromJSON a, ProtectionIndicator p) =>
Text -> Maybe Object -> Maybe Object -> Parser (HeaderParam p a)
headerRequired Text
kText Maybe Object
hp Maybe Object
hu = case (Maybe Object
hp Maybe Object -> (Object -> Maybe Value) -> Maybe Value
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k, Maybe Object
hu Maybe Object -> (Object -> Maybe Value) -> Maybe Value
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k) of
  (Just Value
_, Just Value
_)    -> String -> Parser (HeaderParam p a)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (HeaderParam p a))
-> String -> Parser (HeaderParam p a)
forall a b. (a -> b) -> a -> b
$ String
"duplicate header " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
kText
  (Just Value
v, Maybe Value
Nothing)   -> p -> a -> HeaderParam p a
forall p a. p -> a -> HeaderParam p a
HeaderParam p
forall a. ProtectionIndicator a => a
getProtected (a -> HeaderParam p a) -> Parser a -> Parser (HeaderParam p a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
  (Maybe Value
Nothing, Just Value
v)   -> Parser (HeaderParam p a)
-> (p -> Parser (HeaderParam p a))
-> Maybe p
-> Parser (HeaderParam p a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    (String -> Parser (HeaderParam p a)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unprotected header not supported")
    (\p
p -> p -> a -> HeaderParam p a
forall p a. p -> a -> HeaderParam p a
HeaderParam p
p (a -> HeaderParam p a) -> Parser a -> Parser (HeaderParam p a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)
    Maybe p
forall a. ProtectionIndicator a => Maybe a
getUnprotected
  (Maybe Value
Nothing, Maybe Value
Nothing)  -> String -> Parser (HeaderParam p a)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (HeaderParam p a))
-> String -> Parser (HeaderParam p a)
forall a b. (a -> b) -> a -> b
$ String
"missing required header " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Key -> String
forall a. Show a => a -> String
show Key
k
  where
    k :: Key
k = Text -> Key
Key.fromText Text
kText

-- | Parse a required parameter that MUST be carried
-- in the protected header.
--
headerRequiredProtected
  :: FromJSON a
  => T.Text
  -> Maybe Object
  -> Maybe Object
  -> Parser a
headerRequiredProtected :: forall a.
FromJSON a =>
Text -> Maybe Object -> Maybe Object -> Parser a
headerRequiredProtected Text
kText Maybe Object
hp Maybe Object
hu = case (Maybe Object
hp Maybe Object -> (Object -> Maybe Value) -> Maybe Value
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k, Maybe Object
hu Maybe Object -> (Object -> Maybe Value) -> Maybe Value
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k) of
  (Just Value
_, Just Value
_)    -> String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ String
"duplicate header " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
kText
  (Maybe Value
_, Just Value
_) -> String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ String
"header must be protected: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
kText
  (Just Value
v, Maybe Value
_) -> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
  (Maybe Value, Maybe Value)
_           -> String -> Parser a
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser a) -> String -> Parser a
forall a b. (a -> b) -> a -> b
$ String
"missing required protected header: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
kText
  where
    k :: Key
k = Text -> Key
Key.fromText Text
kText


critObjectParser
  :: (Foldable t0, Foldable t1, Fail.MonadFail m)
  => t0 T.Text -> t1 T.Text -> Object -> T.Text -> m T.Text
critObjectParser :: forall (t0 :: * -> *) (t1 :: * -> *) (m :: * -> *).
(Foldable t0, Foldable t1, MonadFail m) =>
t0 Text -> t1 Text -> Object -> Text -> m Text
critObjectParser t0 Text
reserved t1 Text
exts Object
o Text
s
  | Text
s Text -> t0 Text -> Bool
forall a. Eq a => a -> t0 a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t0 Text
reserved         = String -> m Text
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"crit key is reserved"
  | Text
s Text -> t1 Text -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` t1 Text
exts          = String -> m Text
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"crit key is not understood"
  | Bool -> Bool
not (Text -> Key
Key.fromText Text
s Key -> Object -> Bool
forall a. Key -> KeyMap a -> Bool
`M.member` Object
o) = String -> m Text
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"crit key is not present in headers"
  | Bool
otherwise                 = Text -> m Text
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
s

-- | Parse a "crit" header param
--
-- Fails if:
--
-- * any reserved header appears in "crit" header
-- * any value in "crit" is not a recognised extension
-- * any value in "crit" does not have a corresponding key in the object
--
parseCrit
  :: (Foldable t0, Foldable t1, Traversable t2, Traversable t3, Fail.MonadFail m)
  => t0 T.Text -- ^ reserved header parameters
  -> t1 T.Text -- ^ recognised extensions
  -> Object    -- ^ full header (union of protected and unprotected headers)
  -> t2 (t3 T.Text) -- ^ crit header
  -> m (t2 (t3 T.Text))
parseCrit :: 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 t0 Text
reserved t1 Text
exts Object
o = (t3 Text -> m (t3 Text)) -> t2 (t3 Text) -> m (t2 (t3 Text))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t2 a -> m (t2 b)
mapM ((Text -> m Text) -> t3 Text -> m (t3 Text)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> t3 a -> m (t3 b)
mapM (t0 Text -> t1 Text -> Object -> Text -> m Text
forall (t0 :: * -> *) (t1 :: * -> *) (m :: * -> *).
(Foldable t0, Foldable t1, MonadFail m) =>
t0 Text -> t1 Text -> Object -> Text -> m Text
critObjectParser t0 Text
reserved t1 Text
exts Object
o))
  -- TODO fail on duplicate strings


class HasAlg a where
  alg :: Lens' (a p) (HeaderParam p JWA.JWS.Alg)

class HasJku a where
  jku :: Lens' (a p) (Maybe (HeaderParam p Types.URI))

class HasJwk a where
  jwk :: Lens' (a p) (Maybe (HeaderParam p JWK))

class HasKid a where
  kid :: Lens' (a p) (Maybe (HeaderParam p T.Text))

class HasX5u a where
  x5u :: Lens' (a p) (Maybe (HeaderParam p Types.URI))

class HasX5c a where
  x5c :: Lens' (a p) (Maybe (HeaderParam p (NonEmpty Types.SignedCertificate)))

class HasX5t a where
  x5t :: Lens' (a p) (Maybe (HeaderParam p Types.Base64SHA1))

class HasX5tS256 a where
  x5tS256 :: Lens' (a p) (Maybe (HeaderParam p Types.Base64SHA256))

class HasTyp a where
  typ :: Lens' (a p) (Maybe (HeaderParam p T.Text))

class HasCty a where
  cty :: Lens' (a p) (Maybe (HeaderParam p T.Text))

class HasCrit a where
  crit :: Lens' (a p) (Maybe (NonEmpty T.Text))