{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Crypto.JOSE.Header
(
HeaderParam(..)
, ProtectionIndicator(..)
, Protection(..)
, protection
, isProtected
, param
, HasParams(..)
, headerRequired
, headerRequiredProtected
, headerOptional
, headerOptional'
, headerOptionalProtected
, parseParams
, parseCrit
, protectedParamsEncoded
, unprotectedParams
, 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.Monoid ((<>))
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
class HasParams (a :: Type -> Type) where
params :: ProtectionIndicator p => a p -> [(Bool, Pair)]
extensions :: Proxy a -> [T.Text]
extensions = forall a b. a -> b -> a
const []
parseParamsFor
:: (HasParams b, ProtectionIndicator p)
=> Proxy b -> Maybe Object -> Maybe Object -> Parser (a p)
parseParams
:: forall a p. (HasParams a, ProtectionIndicator p)
=> Maybe Object
-> Maybe Object
-> Parser (a p)
parseParams :: forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
Maybe Object -> Maybe Object -> Parser (a p)
parseParams = forall (a :: * -> *) (b :: * -> *) p.
(HasParams a, HasParams b, ProtectionIndicator p) =>
Proxy b -> Maybe Object -> Maybe Object -> Parser (a p)
parseParamsFor (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
protectedParams
:: (HasParams a, ProtectionIndicator p)
=> a p -> Maybe Value
protectedParams :: forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
a p -> Maybe Value
protectedParams a p
h =
case (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
a p -> [(Bool, Pair)]
params) a p
h of
[] -> forall a. Maybe a
Nothing
[Pair]
xs -> forall a. a -> Maybe a
Just ([Pair] -> Value
object [Pair]
xs)
protectedParamsEncoded
:: (HasParams a, ProtectionIndicator p)
=> a p -> L.ByteString
protectedParamsEncoded :: forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
a p -> ByteString
protectedParamsEncoded =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (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
base64url forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
a p -> Maybe Value
protectedParams
unprotectedParams
:: (HasParams a, ProtectionIndicator p)
=> a p -> Maybe Value
unprotectedParams :: forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
a p -> Maybe Value
unprotectedParams a p
h =
case (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> *) p.
(HasParams a, ProtectionIndicator p) =>
a p -> [(Bool, Pair)]
params) a p
h of
[] -> forall a. Maybe a
Nothing
[Pair]
xs -> forall a. a -> Maybe a
Just ([Pair] -> Value
object [Pair]
xs)
data Protection = Protected | Unprotected
deriving (Protection -> Protection -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Protection -> Protection -> Bool
$c/= :: Protection -> Protection -> Bool
== :: Protection -> Protection -> Bool
$c== :: Protection -> Protection -> Bool
Eq, Int -> Protection -> ShowS
[Protection] -> ShowS
Protection -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Protection] -> ShowS
$cshowList :: [Protection] -> ShowS
show :: Protection -> String
$cshow :: Protection -> String
showsPrec :: Int -> Protection -> ShowS
$cshowsPrec :: Int -> Protection -> ShowS
Show)
class Eq a => ProtectionIndicator a where
getProtected :: a
getUnprotected :: Maybe a
instance ProtectionIndicator Protection where
getProtected :: Protection
getProtected = Protection
Protected
getUnprotected :: Maybe Protection
getUnprotected = forall a. a -> Maybe a
Just Protection
Unprotected
instance ProtectionIndicator () where
getProtected :: ()
getProtected = ()
getUnprotected :: Maybe ()
getUnprotected = forall a. Maybe a
Nothing
data p a = p a
deriving (HeaderParam p a -> HeaderParam p a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
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
$c== :: forall p a.
(Eq p, Eq a) =>
HeaderParam p a -> HeaderParam p a -> Bool
Eq, Int -> HeaderParam p a -> ShowS
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
showList :: [HeaderParam p a] -> ShowS
$cshowList :: forall p a. (Show p, Show a) => [HeaderParam p a] -> ShowS
show :: HeaderParam p a -> String
$cshow :: forall p a. (Show p, Show a) => HeaderParam p a -> String
showsPrec :: Int -> HeaderParam p a -> ShowS
$cshowsPrec :: forall p a. (Show p, Show a) => Int -> 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) = forall p a. p -> a -> HeaderParam p a
HeaderParam p
p (a -> b
f a
a)
protection :: Lens' (HeaderParam p a) p
protection :: forall p a. Lens' (HeaderParam p a) p
protection p -> f p
f (HeaderParam p
p a
v) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\p
p' -> 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`" #-}
param :: Lens' (HeaderParam p a) a
param :: forall p a. Lens' (HeaderParam p a) a
param a -> f a
f (HeaderParam p
p a
v) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
v' -> 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" #-}
isProtected :: (ProtectionIndicator p) => Getter (HeaderParam p a) Bool
isProtected :: forall p a. ProtectionIndicator p => Getter (HeaderParam p a) Bool
isProtected = forall p a. Lens' (HeaderParam p a) p
protection 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 a. Eq a => a -> a -> Bool
== forall a. ProtectionIndicator a => a
getProtected)
headerOptional
:: (FromJSON a, ProtectionIndicator p)
=> T.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' forall a. FromJSON a => Value -> Parser a
parseJSON
headerOptional'
:: (ProtectionIndicator p)
=> (Value -> Parser a)
-> T.Text
-> Maybe Object
-> Maybe Object
-> Parser (Maybe (HeaderParam p a))
Value -> Parser a
parser Text
kText Maybe Object
hp Maybe Object
hu = case (Maybe Object
hp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k, Maybe Object
hu forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k) of
(Just Value
_, Just Value
_) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"duplicate header " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
kText
(Just Value
v, Maybe Value
Nothing) -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p a. p -> a -> HeaderParam p a
HeaderParam forall a. ProtectionIndicator a => a
getProtected forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
parser Value
v
(Maybe Value
Nothing, Just Value
v) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unprotected header not supported")
(\p
p -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p a. p -> a -> HeaderParam p a
HeaderParam p
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
parser Value
v)
forall a. ProtectionIndicator a => Maybe a
getUnprotected
(Maybe Value
Nothing, Maybe Value
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
where
k :: Key
k = Text -> Key
Key.fromText Text
kText
headerOptionalProtected
:: FromJSON a
=> T.Text
-> Maybe Object
-> Maybe Object
-> Parser (Maybe a)
Text
kText Maybe Object
hp Maybe Object
hu = case (Maybe Object
hp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k, Maybe Object
hu forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k) of
(Just Value
_, Just Value
_) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"duplicate header " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
kText
(Maybe Value
_, Just Value
_) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"header must be protected: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
kText
(Just Value
v, Maybe Value
_) -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
(Maybe Value, Maybe Value)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
where
k :: Key
k = Text -> Key
Key.fromText Text
kText
headerRequired
:: (FromJSON a, ProtectionIndicator p)
=> T.Text
-> Maybe Object
-> Maybe Object
-> Parser (HeaderParam p a)
Text
kText Maybe Object
hp Maybe Object
hu = case (Maybe Object
hp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k, Maybe Object
hu forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k) of
(Just Value
_, Just Value
_) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"duplicate header " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
kText
(Just Value
v, Maybe Value
Nothing) -> forall p a. p -> a -> HeaderParam p a
HeaderParam forall a. ProtectionIndicator a => a
getProtected forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
(Maybe Value
Nothing, Just Value
v) -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unprotected header not supported")
(\p
p -> forall p a. p -> a -> HeaderParam p a
HeaderParam p
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)
forall a. ProtectionIndicator a => Maybe a
getUnprotected
(Maybe Value
Nothing, Maybe Value
Nothing) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"missing required header " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Key
k
where
k :: Key
k = Text -> Key
Key.fromText Text
kText
headerRequiredProtected
:: FromJSON a
=> T.Text
-> Maybe Object
-> Maybe Object
-> Parser a
Text
kText Maybe Object
hp Maybe Object
hu = case (Maybe Object
hp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k, Maybe Object
hu forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall v. Key -> KeyMap v -> Maybe v
M.lookup Key
k) of
(Just Value
_, Just Value
_) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"duplicate header " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
kText
(Maybe Value
_, Just Value
_) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"header must be protected: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Text
kText
(Just Value
v, Maybe Value
_) -> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
(Maybe Value, Maybe Value)
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"missing required protected header: " forall a. Semigroup a => a -> a -> a
<> 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t0 Text
reserved = forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"crit key is reserved"
| Text
s forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` t1 Text
exts = 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 forall a. Key -> KeyMap a -> Bool
`M.member` Object
o) = forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"crit key is not present in headers"
| Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
s
parseCrit
:: (Foldable t0, Foldable t1, Traversable t2, Traversable t3, Fail.MonadFail m)
=> t0 T.Text
-> t1 T.Text
-> Object
-> t2 (t3 T.Text)
-> 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 = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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))
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))