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

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

import Control.Applicative (pure)
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
(Alg -> Alg -> Bool) -> (Alg -> Alg -> Bool) -> Eq Alg
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
(Int -> Alg -> ShowS)
-> (Alg -> String) -> ([Alg] -> ShowS) -> Show Alg
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
(JwsAlg -> JwsAlg -> Bool)
-> (JwsAlg -> JwsAlg -> Bool) -> Eq JwsAlg
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
(Int -> JwsAlg -> ShowS)
-> (JwsAlg -> String) -> ([JwsAlg] -> ShowS) -> Show JwsAlg
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]
(Int -> ReadS JwsAlg)
-> ReadS [JwsAlg]
-> ReadPrec JwsAlg
-> ReadPrec [JwsAlg]
-> Read 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
(JweAlg -> JweAlg -> Bool)
-> (JweAlg -> JweAlg -> Bool) -> Eq JweAlg
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
(Int -> JweAlg -> ShowS)
-> (JweAlg -> String) -> ([JweAlg] -> ShowS) -> Show JweAlg
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]
(Int -> ReadS JweAlg)
-> ReadS [JweAlg]
-> ReadPrec JweAlg
-> ReadPrec [JweAlg]
-> Read 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
(Enc -> Enc -> Bool) -> (Enc -> Enc -> Bool) -> Eq Enc
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
(Int -> Enc -> ShowS)
-> (Enc -> String) -> ([Enc] -> ShowS) -> Show Enc
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 = Alg -> [(Alg, Text)] -> Maybe Text
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 = ((Text, Alg) -> (Alg, Text)) -> [(Text, Alg)] -> [(Alg, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Alg) -> (Alg, Text)
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 = Enc -> [(Enc, Text)] -> Maybe Text
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 = ((Text, Enc) -> (Enc, Text)) -> [(Text, Enc)] -> [(Enc, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Enc) -> (Enc, Text)
forall a b. (a, b) -> (b, a)
swap [(Text, Enc)]
encs

instance FromJSON Alg where
    parseJSON :: Value -> Parser Alg
parseJSON = String -> (Text -> Parser Alg) -> Value -> Parser Alg
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Alg" ((Text -> Parser Alg) -> Value -> Parser Alg)
-> (Text -> Parser Alg) -> Value -> Parser Alg
forall a b. (a -> b) -> a -> b
$ \Text
t ->
      Parser Alg -> (Alg -> Parser Alg) -> Maybe Alg -> Parser Alg
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser Alg
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported alg") Alg -> Parser Alg
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Alg -> Parser Alg) -> Maybe Alg -> Parser Alg
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Alg)] -> Maybe Alg
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 (Text -> Value) -> (Alg -> Text) -> Alg -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alg -> Text
algName

instance FromJSON JwsAlg where
    parseJSON :: Value -> Parser JwsAlg
parseJSON = String -> (Text -> Parser JwsAlg) -> Value -> Parser JwsAlg
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"JwsAlg" ((Text -> Parser JwsAlg) -> Value -> Parser JwsAlg)
-> (Text -> Parser JwsAlg) -> Value -> Parser JwsAlg
forall a b. (a -> b) -> a -> b
$ \Text
t -> case Text -> [(Text, Alg)] -> Maybe Alg
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
t [(Text, Alg)]
algs of
        Just (Signed JwsAlg
a) -> JwsAlg -> Parser JwsAlg
forall (f :: * -> *) a. Applicative f => a -> f a
pure JwsAlg
a
        Maybe Alg
_               -> String -> Parser JwsAlg
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 (Text -> Value) -> (Alg -> Text) -> Alg -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alg -> Text
algName (Alg -> Value) -> Alg -> Value
forall a b. (a -> b) -> a -> b
$ JwsAlg -> Alg
Signed JwsAlg
a

instance FromJSON JweAlg where
    parseJSON :: Value -> Parser JweAlg
parseJSON = String -> (Text -> Parser JweAlg) -> Value -> Parser JweAlg
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"JweAlg" ((Text -> Parser JweAlg) -> Value -> Parser JweAlg)
-> (Text -> Parser JweAlg) -> Value -> Parser JweAlg
forall a b. (a -> b) -> a -> b
$ \Text
t -> case Text -> [(Text, Alg)] -> Maybe Alg
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
t [(Text, Alg)]
algs of
        Just (Encrypted JweAlg
a) -> JweAlg -> Parser JweAlg
forall (f :: * -> *) a. Applicative f => a -> f a
pure JweAlg
a
        Maybe Alg
_                  -> String -> Parser JweAlg
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 (Text -> Value) -> (Alg -> Text) -> Alg -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alg -> Text
algName (Alg -> Value) -> Alg -> Value
forall a b. (a -> b) -> a -> b
$ JweAlg -> Alg
Encrypted JweAlg
a

instance FromJSON Enc where
    parseJSON :: Value -> Parser Enc
parseJSON = String -> (Text -> Parser Enc) -> Value -> Parser Enc
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Enc" ((Text -> Parser Enc) -> Value -> Parser Enc)
-> (Text -> Parser Enc) -> Value -> Parser Enc
forall a b. (a -> b) -> a -> b
$ \Text
t ->
      Parser Enc -> (Enc -> Parser Enc) -> Maybe Enc -> Parser Enc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser Enc
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported enc") Enc -> Parser Enc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Enc -> Parser Enc) -> Maybe Enc -> Parser Enc
forall a b. (a -> b) -> a -> b
$ Text -> [(Text, Enc)] -> Maybe Enc
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 (Text -> Value) -> (Enc -> Text) -> Enc -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Enc -> Text
encName