{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK prune #-}

module Jose.Jwa
    ( Alg (..)
    , JwsAlg (..)
    , JweAlg (..)
    , Enc (..)
    , encName
    )
where

import Data.Aeson
import Data.Text (Text)
import Data.Tuple (swap)

-- | General representation of the @alg@ JWT header value.
data Alg = Signed JwsAlg | Encrypted JweAlg deriving (Alg -> Alg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Alg -> Alg -> Bool
$c/= :: Alg -> Alg -> Bool
== :: Alg -> Alg -> Bool
$c== :: Alg -> Alg -> Bool
Eq, Int -> Alg -> ShowS
[Alg] -> ShowS
Alg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Alg] -> ShowS
$cshowList :: [Alg] -> ShowS
show :: Alg -> String
$cshow :: Alg -> String
showsPrec :: Int -> Alg -> ShowS
$cshowsPrec :: Int -> Alg -> ShowS
Show)

-- | A subset of the signature algorithms from the
-- <https://tools.ietf.org/html/rfc7518#section-3 JWA Spec>.
data JwsAlg = None | HS256 | HS384 | HS512 | RS256 | RS384 | RS512 | ES256 | ES384 | ES512 | EdDSA deriving (JwsAlg -> JwsAlg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JwsAlg -> JwsAlg -> Bool
$c/= :: JwsAlg -> JwsAlg -> Bool
== :: JwsAlg -> JwsAlg -> Bool
$c== :: JwsAlg -> JwsAlg -> Bool
Eq, Int -> JwsAlg -> ShowS
[JwsAlg] -> ShowS
JwsAlg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JwsAlg] -> ShowS
$cshowList :: [JwsAlg] -> ShowS
show :: JwsAlg -> String
$cshow :: JwsAlg -> String
showsPrec :: Int -> JwsAlg -> ShowS
$cshowsPrec :: Int -> JwsAlg -> ShowS
Show, ReadPrec [JwsAlg]
ReadPrec JwsAlg
Int -> ReadS JwsAlg
ReadS [JwsAlg]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [JwsAlg]
$creadListPrec :: ReadPrec [JwsAlg]
readPrec :: ReadPrec JwsAlg
$creadPrec :: ReadPrec JwsAlg
readList :: ReadS [JwsAlg]
$creadList :: ReadS [JwsAlg]
readsPrec :: Int -> ReadS JwsAlg
$creadsPrec :: Int -> ReadS JwsAlg
Read)

-- | A subset of the key management algorithms from the
-- <https://tools.ietf.org/html/rfc7518#section-4 JWA Spec>.
data JweAlg = RSA1_5 | RSA_OAEP | RSA_OAEP_256 | A128KW | A192KW | A256KW deriving (JweAlg -> JweAlg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JweAlg -> JweAlg -> Bool
$c/= :: JweAlg -> JweAlg -> Bool
== :: JweAlg -> JweAlg -> Bool
$c== :: JweAlg -> JweAlg -> Bool
Eq, Int -> JweAlg -> ShowS
[JweAlg] -> ShowS
JweAlg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JweAlg] -> ShowS
$cshowList :: [JweAlg] -> ShowS
show :: JweAlg -> String
$cshow :: JweAlg -> String
showsPrec :: Int -> JweAlg -> ShowS
$cshowsPrec :: Int -> JweAlg -> ShowS
Show, ReadPrec [JweAlg]
ReadPrec JweAlg
Int -> ReadS JweAlg
ReadS [JweAlg]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [JweAlg]
$creadListPrec :: ReadPrec [JweAlg]
readPrec :: ReadPrec JweAlg
$creadPrec :: ReadPrec JweAlg
readList :: ReadS [JweAlg]
$creadList :: ReadS [JweAlg]
readsPrec :: Int -> ReadS JweAlg
$creadsPrec :: Int -> ReadS JweAlg
Read)

-- | Content encryption algorithms from the
-- <https://tools.ietf.org/html/rfc7518#section-5 JWA Spec>.
data Enc = A128CBC_HS256 | A192CBC_HS384 | A256CBC_HS512 | A128GCM | A192GCM | A256GCM deriving (Enc -> Enc -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Enc -> Enc -> Bool
$c/= :: Enc -> Enc -> Bool
== :: Enc -> Enc -> Bool
$c== :: Enc -> Enc -> Bool
Eq, Int -> Enc -> ShowS
[Enc] -> ShowS
Enc -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Enc] -> ShowS
$cshowList :: [Enc] -> ShowS
show :: Enc -> String
$cshow :: Enc -> String
showsPrec :: Int -> Enc -> ShowS
$cshowsPrec :: Int -> Enc -> ShowS
Show)

algs :: [(Text, Alg)]
algs :: [(Text, Alg)]
algs = [(Text
"none", JwsAlg -> Alg
Signed JwsAlg
None), (Text
"HS256", JwsAlg -> Alg
Signed JwsAlg
HS256), (Text
"HS384", JwsAlg -> Alg
Signed JwsAlg
HS384), (Text
"HS512", JwsAlg -> Alg
Signed JwsAlg
HS512), (Text
"RS256", JwsAlg -> Alg
Signed JwsAlg
RS256), (Text
"RS384", JwsAlg -> Alg
Signed JwsAlg
RS384), (Text
"RS512", JwsAlg -> Alg
Signed JwsAlg
RS512), (Text
"ES256", JwsAlg -> Alg
Signed JwsAlg
ES256), (Text
"ES384", JwsAlg -> Alg
Signed JwsAlg
ES384), (Text
"ES512", JwsAlg -> Alg
Signed JwsAlg
ES512), (Text
"EdDSA", JwsAlg -> Alg
Signed JwsAlg
EdDSA), (Text
"RSA1_5", JweAlg -> Alg
Encrypted JweAlg
RSA1_5), (Text
"RSA-OAEP", JweAlg -> Alg
Encrypted JweAlg
RSA_OAEP), (Text
"RSA-OAEP-256", JweAlg -> Alg
Encrypted JweAlg
RSA_OAEP_256), (Text
"A128KW", JweAlg -> Alg
Encrypted JweAlg
A128KW), (Text
"A192KW", JweAlg -> Alg
Encrypted JweAlg
A192KW), (Text
"A256KW", JweAlg -> Alg
Encrypted JweAlg
A256KW)]

algName :: Alg -> Text
algName :: Alg -> Text
algName Alg
a = let Just Text
n = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Alg
a [(Alg, Text)]
algNames in Text
n

algNames :: [(Alg, Text)]
algNames :: [(Alg, Text)]
algNames = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> (b, a)
swap [(Text, Alg)]
algs

encs :: [(Text, Enc)]
encs :: [(Text, Enc)]
encs = [(Text
"A128CBC-HS256", Enc
A128CBC_HS256), (Text
"A256CBC-HS512", Enc
A256CBC_HS512), (Text
"A192CBC-HS384", Enc
A192CBC_HS384), (Text
"A128GCM", Enc
A128GCM), (Text
"A192GCM", Enc
A192GCM), (Text
"A256GCM", Enc
A256GCM)]

encName :: Enc -> Text
encName :: Enc -> Text
encName Enc
e = let Just Text
n = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Enc
e [(Enc, Text)]
encNames in Text
n

encNames :: [(Enc, Text)]
encNames :: [(Enc, Text)]
encNames = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> (b, a)
swap [(Text, Enc)]
encs

instance FromJSON Alg where
    parseJSON :: Value -> Parser Alg
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Alg" forall a b. (a -> b) -> a -> b
$ \Text
t ->
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported alg") forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
t [(Text, Alg)]
algs

instance ToJSON Alg where
    toJSON :: Alg -> Value
toJSON = Text -> Value
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alg -> Text
algName

instance FromJSON JwsAlg where
    parseJSON :: Value -> Parser JwsAlg
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"JwsAlg" forall a b. (a -> b) -> a -> b
$ \Text
t -> case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
t [(Text, Alg)]
algs of
        Just (Signed JwsAlg
a) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure JwsAlg
a
        Maybe Alg
_               -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported JWS algorithm"

instance ToJSON JwsAlg where
    toJSON :: JwsAlg -> Value
toJSON JwsAlg
a = Text -> Value
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alg -> Text
algName forall a b. (a -> b) -> a -> b
$ JwsAlg -> Alg
Signed JwsAlg
a

instance FromJSON JweAlg where
    parseJSON :: Value -> Parser JweAlg
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"JweAlg" forall a b. (a -> b) -> a -> b
$ \Text
t -> case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
t [(Text, Alg)]
algs of
        Just (Encrypted JweAlg
a) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure JweAlg
a
        Maybe Alg
_                  -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported JWE algorithm"

instance ToJSON JweAlg where
    toJSON :: JweAlg -> Value
toJSON JweAlg
a = Text -> Value
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alg -> Text
algName forall a b. (a -> b) -> a -> b
$ JweAlg -> Alg
Encrypted JweAlg
a

instance FromJSON Enc where
    parseJSON :: Value -> Parser Enc
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Enc" forall a b. (a -> b) -> a -> b
$ \Text
t ->
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported enc") forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
t [(Text, Enc)]
encs

instance ToJSON Enc where
    toJSON :: Enc -> Value
toJSON = Text -> Value
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. Enc -> Text
encName