{-# 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.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))