{-# LANGUAGE OverloadedStrings, DeriveGeneric, RecordWildCards, CPP #-}
{-# OPTIONS_HADDOCK prune #-}

module Jose.Jwk
    ( EcCurve (..)
    , KeyUse (..)
    , KeyId
    , Jwk (..)
    , JwkSet (..)
    , isPublic
    , isPrivate
    , jwkId
    , jwkUse
    , canDecodeJws
    , canDecodeJwe
    , canEncodeJws
    , canEncodeJwe
    , generateRsaKeyPair
    , generateSymmetricKey
    )
where

import           Control.Monad (unless)
import           Crypto.Error (CryptoFailable(..))
import           Crypto.Random (MonadRandom, getRandomBytes)
import qualified Crypto.PubKey.RSA as RSA
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.Ed448 as Ed448
import qualified Crypto.PubKey.ECC.Types as ECC
import           Crypto.Number.Serialize
import           Data.Aeson (fromJSON, genericToJSON, Object, Result(..), Value(..), FromJSON(..), ToJSON(..), withText)
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as KM
#else
import qualified Data.HashMap.Strict as H
#endif
import           Data.Aeson.Types (Parser, Options (..), defaultOptions)
import qualified Data.ByteArray as BA
import           Data.ByteString (ByteString)
import qualified Data.ByteString as B
import           Data.Maybe (isNothing, fromMaybe)
import           Data.Text (Text)
import qualified Data.Text.Encoding as TE
import           GHC.Generics (Generic)

import qualified Jose.Internal.Base64 as B64
import           Jose.Jwa
import           Jose.Types (KeyId, JwsHeader(..), JweHeader(..))

data KeyType = Rsa
             | Ec
             | Okp
             | Oct
               deriving (KeyType -> KeyType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyType -> KeyType -> Bool
$c/= :: KeyType -> KeyType -> Bool
== :: KeyType -> KeyType -> Bool
$c== :: KeyType -> KeyType -> Bool
Eq)

data EcCurve = P_256
             | P_384
             | P_521
               deriving (EcCurve -> EcCurve -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EcCurve -> EcCurve -> Bool
$c/= :: EcCurve -> EcCurve -> Bool
== :: EcCurve -> EcCurve -> Bool
$c== :: EcCurve -> EcCurve -> Bool
Eq,Int -> EcCurve -> ShowS
[EcCurve] -> ShowS
EcCurve -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EcCurve] -> ShowS
$cshowList :: [EcCurve] -> ShowS
show :: EcCurve -> String
$cshow :: EcCurve -> String
showsPrec :: Int -> EcCurve -> ShowS
$cshowsPrec :: Int -> EcCurve -> ShowS
Show)

data KeyUse  = Sig
             | Enc
               deriving (KeyUse -> KeyUse -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyUse -> KeyUse -> Bool
$c/= :: KeyUse -> KeyUse -> Bool
== :: KeyUse -> KeyUse -> Bool
$c== :: KeyUse -> KeyUse -> Bool
Eq,Int -> KeyUse -> ShowS
[KeyUse] -> ShowS
KeyUse -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyUse] -> ShowS
$cshowList :: [KeyUse] -> ShowS
show :: KeyUse -> String
$cshow :: KeyUse -> String
showsPrec :: Int -> KeyUse -> ShowS
$cshowsPrec :: Int -> KeyUse -> ShowS
Show)

data Jwk = RsaPublicJwk  !RSA.PublicKey   !(Maybe KeyId) !(Maybe KeyUse) !(Maybe Alg)
         | RsaPrivateJwk !RSA.PrivateKey  !(Maybe KeyId) !(Maybe KeyUse) !(Maybe Alg)
         | EcPublicJwk   !ECDSA.PublicKey !(Maybe KeyId) !(Maybe KeyUse) !(Maybe Alg) !EcCurve
         | EcPrivateJwk  !ECDSA.KeyPair   !(Maybe KeyId) !(Maybe KeyUse) !(Maybe Alg) !EcCurve
         | Ed25519PrivateJwk !Ed25519.SecretKey !Ed25519.PublicKey !(Maybe KeyId)
         | Ed25519PublicJwk !Ed25519.PublicKey !(Maybe KeyId)
         | Ed448PrivateJwk !Ed448.SecretKey !Ed448.PublicKey !(Maybe KeyId)
         | Ed448PublicJwk !Ed448.PublicKey !(Maybe KeyId)
         | SymmetricJwk  !ByteString      !(Maybe KeyId) !(Maybe KeyUse) !(Maybe Alg)
         | UnsupportedJwk Object
           deriving (Int -> Jwk -> ShowS
[Jwk] -> ShowS
Jwk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Jwk] -> ShowS
$cshowList :: [Jwk] -> ShowS
show :: Jwk -> String
$cshow :: Jwk -> String
showsPrec :: Int -> Jwk -> ShowS
$cshowsPrec :: Int -> Jwk -> ShowS
Show, Jwk -> Jwk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Jwk -> Jwk -> Bool
$c/= :: Jwk -> Jwk -> Bool
== :: Jwk -> Jwk -> Bool
$c== :: Jwk -> Jwk -> Bool
Eq)

newtype JwkSet = JwkSet
    { JwkSet -> [Jwk]
keys :: [Jwk]
    } deriving (Int -> JwkSet -> ShowS
[JwkSet] -> ShowS
JwkSet -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JwkSet] -> ShowS
$cshowList :: [JwkSet] -> ShowS
show :: JwkSet -> String
$cshow :: JwkSet -> String
showsPrec :: Int -> JwkSet -> ShowS
$cshowsPrec :: Int -> JwkSet -> ShowS
Show, JwkSet -> JwkSet -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JwkSet -> JwkSet -> Bool
$c/= :: JwkSet -> JwkSet -> Bool
== :: JwkSet -> JwkSet -> Bool
$c== :: JwkSet -> JwkSet -> Bool
Eq, forall x. Rep JwkSet x -> JwkSet
forall x. JwkSet -> Rep JwkSet x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep JwkSet x -> JwkSet
$cfrom :: forall x. JwkSet -> Rep JwkSet x
Generic)

generateRsaKeyPair :: (MonadRandom m)
    => Int
    -> KeyId
    -> KeyUse
    -> Maybe Alg
    -> m (Jwk, Jwk)
generateRsaKeyPair :: forall (m :: * -> *).
MonadRandom m =>
Int -> KeyId -> KeyUse -> Maybe Alg -> m (Jwk, Jwk)
generateRsaKeyPair Int
nBytes KeyId
id' KeyUse
kuse Maybe Alg
kalg = do
    (PublicKey
kPub, PrivateKey
kPr) <- forall (m :: * -> *).
MonadRandom m =>
Int -> Integer -> m (PublicKey, PrivateKey)
RSA.generate Int
nBytes Integer
65537
    forall (m :: * -> *) a. Monad m => a -> m a
return (PublicKey -> Maybe KeyId -> Maybe KeyUse -> Maybe Alg -> Jwk
RsaPublicJwk PublicKey
kPub (forall a. a -> Maybe a
Just KeyId
id') (forall a. a -> Maybe a
Just KeyUse
kuse) Maybe Alg
kalg, PrivateKey -> Maybe KeyId -> Maybe KeyUse -> Maybe Alg -> Jwk
RsaPrivateJwk PrivateKey
kPr (forall a. a -> Maybe a
Just KeyId
id') (forall a. a -> Maybe a
Just KeyUse
kuse) Maybe Alg
kalg)

generateSymmetricKey :: (MonadRandom m)
    => Int
    -> KeyId
    -> KeyUse
    -> Maybe Alg
    -> m Jwk
generateSymmetricKey :: forall (m :: * -> *).
MonadRandom m =>
Int -> KeyId -> KeyUse -> Maybe Alg -> m Jwk
generateSymmetricKey Int
size KeyId
id' KeyUse
kuse Maybe Alg
kalg = do
    ByteString
k <- forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
size
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe KeyId -> Maybe KeyUse -> Maybe Alg -> Jwk
SymmetricJwk ByteString
k (forall a. a -> Maybe a
Just KeyId
id') (forall a. a -> Maybe a
Just KeyUse
kuse) Maybe Alg
kalg

isPublic :: Jwk -> Bool
isPublic :: Jwk -> Bool
isPublic RsaPublicJwk {} = Bool
True
isPublic EcPublicJwk  {} = Bool
True
isPublic Jwk
_ = Bool
False

isPrivate :: Jwk -> Bool
isPrivate :: Jwk -> Bool
isPrivate RsaPrivateJwk {} = Bool
True
isPrivate EcPrivateJwk  {} = Bool
True
isPrivate Jwk
_ = Bool
False

canDecodeJws :: JwsHeader -> Jwk -> Bool
canDecodeJws :: JwsHeader -> Jwk -> Bool
canDecodeJws JwsHeader
hdr Jwk
jwk = Jwk -> Maybe KeyUse
jwkUse Jwk
jwk forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just KeyUse
Enc Bool -> Bool -> Bool
&&
    Maybe KeyId -> Jwk -> Bool
keyIdCompatible (JwsHeader -> Maybe KeyId
jwsKid JwsHeader
hdr) Jwk
jwk Bool -> Bool -> Bool
&&
    Alg -> Jwk -> Bool
algCompatible (JwsAlg -> Alg
Signed (JwsHeader -> JwsAlg
jwsAlg JwsHeader
hdr)) Jwk
jwk Bool -> Bool -> Bool
&&
    case (JwsHeader -> JwsAlg
jwsAlg JwsHeader
hdr, Jwk
jwk) of
        (JwsAlg
EdDSA, Ed25519PublicJwk {}) -> Bool
True
        (JwsAlg
EdDSA, Ed25519PrivateJwk {}) -> Bool
True
        (JwsAlg
EdDSA, Ed448PublicJwk {}) -> Bool
True
        (JwsAlg
EdDSA, Ed448PrivateJwk {}) -> Bool
True
        (JwsAlg
RS256, RsaPublicJwk {}) -> Bool
True
        (JwsAlg
RS384, RsaPublicJwk {}) -> Bool
True
        (JwsAlg
RS512, RsaPublicJwk {}) -> Bool
True
        (JwsAlg
RS256, RsaPrivateJwk {}) -> Bool
True
        (JwsAlg
RS384, RsaPrivateJwk {}) -> Bool
True
        (JwsAlg
RS512, RsaPrivateJwk {}) -> Bool
True
        (JwsAlg
HS256, SymmetricJwk {}) -> Bool
True
        (JwsAlg
HS384, SymmetricJwk {}) -> Bool
True
        (JwsAlg
HS512, SymmetricJwk {}) -> Bool
True
        (JwsAlg
ES256, EcPublicJwk {})  -> Bool
True
        (JwsAlg
ES384, EcPublicJwk {})  -> Bool
True
        (JwsAlg
ES512, EcPublicJwk {})  -> Bool
True
        (JwsAlg
ES256, EcPrivateJwk {})  -> Bool
True
        (JwsAlg
ES384, EcPrivateJwk {})  -> Bool
True
        (JwsAlg
ES512, EcPrivateJwk {})  -> Bool
True
        (JwsAlg, Jwk)
_                        -> Bool
False

canEncodeJws :: JwsAlg -> Jwk -> Bool
canEncodeJws :: JwsAlg -> Jwk -> Bool
canEncodeJws JwsAlg
a Jwk
jwk = Jwk -> Maybe KeyUse
jwkUse Jwk
jwk forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just KeyUse
Enc Bool -> Bool -> Bool
&&
    Alg -> Jwk -> Bool
algCompatible (JwsAlg -> Alg
Signed JwsAlg
a) Jwk
jwk Bool -> Bool -> Bool
&&
    case (JwsAlg
a, Jwk
jwk) of
        (JwsAlg
EdDSA, Ed25519PrivateJwk {}) -> Bool
True
        (JwsAlg
EdDSA, Ed448PrivateJwk {}) -> Bool
True
        (JwsAlg
RS256, RsaPrivateJwk {}) -> Bool
True
        (JwsAlg
RS384, RsaPrivateJwk {}) -> Bool
True
        (JwsAlg
RS512, RsaPrivateJwk {}) -> Bool
True
        (JwsAlg
HS256, SymmetricJwk {})  -> Bool
True
        (JwsAlg
HS384, SymmetricJwk {})  -> Bool
True
        (JwsAlg
HS512, SymmetricJwk {})  -> Bool
True
        (JwsAlg
ES256, EcPrivateJwk {})  -> Bool
True
        (JwsAlg
ES384, EcPrivateJwk {})  -> Bool
True
        (JwsAlg
ES512, EcPrivateJwk {})  -> Bool
True
        (JwsAlg, Jwk)
_                         -> Bool
False

canDecodeJwe :: JweHeader -> Jwk -> Bool
canDecodeJwe :: JweHeader -> Jwk -> Bool
canDecodeJwe JweHeader
hdr Jwk
jwk = Jwk -> Maybe KeyUse
jwkUse Jwk
jwk forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just KeyUse
Sig Bool -> Bool -> Bool
&&
    Maybe KeyId -> Jwk -> Bool
keyIdCompatible (JweHeader -> Maybe KeyId
jweKid JweHeader
hdr) Jwk
jwk Bool -> Bool -> Bool
&&
    Alg -> Jwk -> Bool
algCompatible (JweAlg -> Alg
Encrypted (JweHeader -> JweAlg
jweAlg JweHeader
hdr)) Jwk
jwk Bool -> Bool -> Bool
&&
    case (JweHeader -> JweAlg
jweAlg JweHeader
hdr, Jwk
jwk) of
        (JweAlg
RSA1_5,       RsaPrivateJwk {}) -> Bool
True
        (JweAlg
RSA_OAEP,     RsaPrivateJwk {}) -> Bool
True
        (JweAlg
RSA_OAEP_256, RsaPrivateJwk {}) -> Bool
True
        (JweAlg
A128KW,       SymmetricJwk ByteString
k Maybe KeyId
_ Maybe KeyUse
_ Maybe Alg
_) -> ByteString -> Int
B.length ByteString
k forall a. Eq a => a -> a -> Bool
== Int
16
        (JweAlg
A192KW,       SymmetricJwk ByteString
k Maybe KeyId
_ Maybe KeyUse
_ Maybe Alg
_) -> ByteString -> Int
B.length ByteString
k forall a. Eq a => a -> a -> Bool
== Int
24
        (JweAlg
A256KW,       SymmetricJwk ByteString
k Maybe KeyId
_ Maybe KeyUse
_ Maybe Alg
_) -> ByteString -> Int
B.length ByteString
k forall a. Eq a => a -> a -> Bool
== Int
32
        (JweAlg, Jwk)
_                            -> Bool
False

canEncodeJwe :: JweAlg -> Jwk -> Bool
canEncodeJwe :: JweAlg -> Jwk -> Bool
canEncodeJwe JweAlg
a Jwk
jwk = Jwk -> Maybe KeyUse
jwkUse Jwk
jwk forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just KeyUse
Sig Bool -> Bool -> Bool
&&
    Alg -> Jwk -> Bool
algCompatible (JweAlg -> Alg
Encrypted JweAlg
a) Jwk
jwk Bool -> Bool -> Bool
&&
    case (JweAlg
a, Jwk
jwk) of
        (JweAlg
RSA1_5,       RsaPublicJwk {})  -> Bool
True
        (JweAlg
RSA_OAEP,     RsaPublicJwk {})  -> Bool
True
        (JweAlg
RSA_OAEP_256, RsaPublicJwk {})  -> Bool
True
        (JweAlg
RSA1_5,       RsaPrivateJwk {}) -> Bool
True
        (JweAlg
RSA_OAEP,     RsaPrivateJwk {}) -> Bool
True
        (JweAlg
RSA_OAEP_256, RsaPrivateJwk {}) -> Bool
True
        (JweAlg
A128KW,       SymmetricJwk ByteString
k Maybe KeyId
_ Maybe KeyUse
_ Maybe Alg
_) -> ByteString -> Int
B.length ByteString
k forall a. Eq a => a -> a -> Bool
== Int
16
        (JweAlg
A192KW,       SymmetricJwk ByteString
k Maybe KeyId
_ Maybe KeyUse
_ Maybe Alg
_) -> ByteString -> Int
B.length ByteString
k forall a. Eq a => a -> a -> Bool
== Int
24
        (JweAlg
A256KW,       SymmetricJwk ByteString
k Maybe KeyId
_ Maybe KeyUse
_ Maybe Alg
_) -> ByteString -> Int
B.length ByteString
k forall a. Eq a => a -> a -> Bool
== Int
32
        (JweAlg, Jwk)
_                            -> Bool
False

keyIdCompatible :: Maybe KeyId -> Jwk -> Bool
keyIdCompatible :: Maybe KeyId -> Jwk -> Bool
keyIdCompatible Maybe KeyId
Nothing Jwk
_ = Bool
True
keyIdCompatible Maybe KeyId
id' Jwk
jwk   = Maybe KeyId
id' forall a. Eq a => a -> a -> Bool
== Jwk -> Maybe KeyId
jwkId Jwk
jwk

algCompatible :: Alg -> Jwk -> Bool
algCompatible :: Alg -> Jwk -> Bool
algCompatible Alg
a Jwk
k' = case Jwk -> Maybe Alg
jwkAlg Jwk
k' of
    Maybe Alg
Nothing -> Bool
True
    Just Alg
ka -> Alg
a forall a. Eq a => a -> a -> Bool
== Alg
ka

ecCurve :: Text -> Maybe (EcCurve, ECC.Curve)
ecCurve :: Text -> Maybe (EcCurve, Curve)
ecCurve Text
c = case Text
c of
    Text
"P-256" -> forall a. a -> Maybe a
Just (EcCurve
P_256, CurveName -> Curve
ECC.getCurveByName CurveName
ECC.SEC_p256r1)
    Text
"P-384" -> forall a. a -> Maybe a
Just (EcCurve
P_384, CurveName -> Curve
ECC.getCurveByName CurveName
ECC.SEC_p384r1)
    Text
"P-521" -> forall a. a -> Maybe a
Just (EcCurve
P_521, CurveName -> Curve
ECC.getCurveByName CurveName
ECC.SEC_p521r1)
    Text
_ -> forall a. Maybe a
Nothing

ecCurveName :: EcCurve -> Text
ecCurveName :: EcCurve -> Text
ecCurveName EcCurve
c = case EcCurve
c of
    EcCurve
P_256 -> Text
"P-256"
    EcCurve
P_384 -> Text
"P-384"
    EcCurve
P_521 -> Text
"P-521"

jwkId :: Jwk -> Maybe KeyId
jwkId :: Jwk -> Maybe KeyId
jwkId Jwk
key = case Jwk
key of
    Ed25519PrivateJwk SecretKey
_ PublicKey
_ Maybe KeyId
keyId -> Maybe KeyId
keyId
    Ed25519PublicJwk PublicKey
_ Maybe KeyId
keyId -> Maybe KeyId
keyId
    Ed448PrivateJwk SecretKey
_ PublicKey
_ Maybe KeyId
keyId -> Maybe KeyId
keyId
    Ed448PublicJwk PublicKey
_ Maybe KeyId
keyId -> Maybe KeyId
keyId
    RsaPublicJwk  PublicKey
_ Maybe KeyId
keyId Maybe KeyUse
_ Maybe Alg
_ -> Maybe KeyId
keyId
    RsaPrivateJwk PrivateKey
_ Maybe KeyId
keyId Maybe KeyUse
_ Maybe Alg
_ -> Maybe KeyId
keyId
    EcPublicJwk   PublicKey
_ Maybe KeyId
keyId Maybe KeyUse
_ Maybe Alg
_ EcCurve
_ -> Maybe KeyId
keyId
    EcPrivateJwk  KeyPair
_ Maybe KeyId
keyId Maybe KeyUse
_ Maybe Alg
_ EcCurve
_ -> Maybe KeyId
keyId
    SymmetricJwk  ByteString
_ Maybe KeyId
keyId Maybe KeyUse
_ Maybe Alg
_ -> Maybe KeyId
keyId
    UnsupportedJwk Object
_ -> forall a. Maybe a
Nothing

jwkUse :: Jwk -> Maybe KeyUse
jwkUse :: Jwk -> Maybe KeyUse
jwkUse Jwk
key = case Jwk
key of
    Ed25519PrivateJwk {} -> forall a. a -> Maybe a
Just KeyUse
Sig
    Ed25519PublicJwk PublicKey
_ Maybe KeyId
_ -> forall a. a -> Maybe a
Just KeyUse
Sig
    Ed448PrivateJwk {} -> forall a. a -> Maybe a
Just KeyUse
Sig
    Ed448PublicJwk PublicKey
_ Maybe KeyId
_ -> forall a. a -> Maybe a
Just KeyUse
Sig
    RsaPublicJwk  PublicKey
_ Maybe KeyId
_ Maybe KeyUse
u Maybe Alg
_ -> Maybe KeyUse
u
    RsaPrivateJwk PrivateKey
_ Maybe KeyId
_ Maybe KeyUse
u Maybe Alg
_ -> Maybe KeyUse
u
    EcPublicJwk   PublicKey
_ Maybe KeyId
_ Maybe KeyUse
u Maybe Alg
_ EcCurve
_ -> Maybe KeyUse
u
    EcPrivateJwk  KeyPair
_ Maybe KeyId
_ Maybe KeyUse
u Maybe Alg
_ EcCurve
_ -> Maybe KeyUse
u
    SymmetricJwk  ByteString
_ Maybe KeyId
_ Maybe KeyUse
u Maybe Alg
_ -> Maybe KeyUse
u
    UnsupportedJwk Object
_ -> forall a. Maybe a
Nothing

jwkAlg :: Jwk -> Maybe Alg
jwkAlg :: Jwk -> Maybe Alg
jwkAlg Jwk
key = case Jwk
key of
    Ed25519PrivateJwk {} -> forall a. a -> Maybe a
Just (JwsAlg -> Alg
Signed JwsAlg
EdDSA)
    Ed25519PublicJwk PublicKey
_ Maybe KeyId
_ -> forall a. a -> Maybe a
Just (JwsAlg -> Alg
Signed JwsAlg
EdDSA)
    Ed448PrivateJwk {} -> forall a. a -> Maybe a
Just (JwsAlg -> Alg
Signed JwsAlg
EdDSA)
    Ed448PublicJwk PublicKey
_ Maybe KeyId
_ -> forall a. a -> Maybe a
Just (JwsAlg -> Alg
Signed JwsAlg
EdDSA)
    RsaPublicJwk  PublicKey
_ Maybe KeyId
_ Maybe KeyUse
_ Maybe Alg
a -> Maybe Alg
a
    RsaPrivateJwk PrivateKey
_ Maybe KeyId
_ Maybe KeyUse
_ Maybe Alg
a -> Maybe Alg
a
    EcPublicJwk   PublicKey
_ Maybe KeyId
_ Maybe KeyUse
_ Maybe Alg
a EcCurve
_ -> Maybe Alg
a
    EcPrivateJwk  KeyPair
_ Maybe KeyId
_ Maybe KeyUse
_ Maybe Alg
a EcCurve
_ -> Maybe Alg
a
    SymmetricJwk  ByteString
_ Maybe KeyId
_ Maybe KeyUse
_ Maybe Alg
a -> Maybe Alg
a
    UnsupportedJwk Object
_ -> forall a. Maybe a
Nothing


newtype JwkBytes = JwkBytes {JwkBytes -> ByteString
bytes :: ByteString} deriving (Int -> JwkBytes -> ShowS
[JwkBytes] -> ShowS
JwkBytes -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JwkBytes] -> ShowS
$cshowList :: [JwkBytes] -> ShowS
show :: JwkBytes -> String
$cshow :: JwkBytes -> String
showsPrec :: Int -> JwkBytes -> ShowS
$cshowsPrec :: Int -> JwkBytes -> ShowS
Show)

instance FromJSON KeyType where
    parseJSON :: Value -> Parser KeyType
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"KeyType" forall a b. (a -> b) -> a -> b
$ \Text
t ->
        case Text
t of
          Text
"RSA" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyType
Rsa
          Text
"OKP" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyType
Okp
          Text
"EC"  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyType
Ec
          Text
"oct" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyType
Oct
          Text
_     -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unsupported key type"

instance ToJSON KeyType where
    toJSON :: KeyType -> Value
toJSON KeyType
kt = case KeyType
kt of
                    KeyType
Rsa -> Text -> Value
String Text
"RSA"
                    KeyType
Okp -> Text -> Value
String Text
"OKP"
                    KeyType
Ec  -> Text -> Value
String Text
"EC"
                    KeyType
Oct -> Text -> Value
String Text
"oct"

instance FromJSON KeyUse where
    parseJSON :: Value -> Parser KeyUse
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"KeyUse" forall a b. (a -> b) -> a -> b
$ \Text
t ->
        case Text
t of
          Text
"sig" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyUse
Sig
          Text
"enc" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyUse
Enc
          Text
_     -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"'use' value must be either 'sig' or 'enc'"

instance ToJSON KeyUse where
    toJSON :: KeyUse -> Value
toJSON KeyUse
ku = case KeyUse
ku of
                    KeyUse
Sig -> Text -> Value
String Text
"sig"
                    KeyUse
Enc -> Text -> Value
String Text
"enc"

instance FromJSON EcCurve where
    parseJSON :: Value -> Parser EcCurve
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"EcCurve" forall a b. (a -> b) -> a -> b
$ \Text
t ->
        case Text
t of
          Text
"P-256" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure EcCurve
P_256
          Text
"P-384" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure EcCurve
P_384
          Text
"P-521" -> forall (f :: * -> *) a. Applicative f => a -> f a
pure EcCurve
P_521
          Text
_       -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unsupported 'crv' value"

instance ToJSON EcCurve where
    toJSON :: EcCurve -> Value
toJSON EcCurve
c =  case EcCurve
c of
                    EcCurve
P_256 -> Text -> Value
String Text
"P-256"
                    EcCurve
P_384 -> Text -> Value
String Text
"P-384"
                    EcCurve
P_521 -> Text -> Value
String Text
"P-521"

instance FromJSON JwkBytes where
    parseJSON :: Value -> Parser JwkBytes
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"JwkBytes" forall a b. (a -> b) -> a -> b
$ \Text
t ->
        case forall input output (m :: * -> *).
(ByteArrayAccess input, ByteArray output, MonadError JwtError m) =>
input -> m output
B64.decode (Text -> ByteString
TE.encodeUtf8 Text
t) of
          Left  JwtError
_  -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"could not base64 decode bytes"
          Right ByteString
b  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ByteString -> JwkBytes
JwkBytes ByteString
b

instance ToJSON JwkBytes where
    toJSON :: JwkBytes -> Value
toJSON (JwkBytes ByteString
b) = Text -> Value
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8 forall a b. (a -> b) -> a -> b
$ forall input output.
(ByteArrayAccess input, ByteArray output) =>
input -> output
B64.encode ByteString
b

instance FromJSON Jwk where
    parseJSON :: Value -> Parser Jwk
parseJSON (Object Object
k) = Object -> Parser Jwk
parseJwk Object
k
    parseJSON Value
_            = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Jwk must be a JSON object"

parseJwk :: Object -> Parser Jwk
parseJwk :: Object -> Parser Jwk
parseJwk Object
k =
    case (Result (Maybe Alg)
checkAlg, Result (Maybe KeyType)
checkKty) of
        (Success Maybe Alg
_, Success Maybe KeyType
_) -> do
            JwkData
jwkData <- forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
k) :: Parser JwkData
            case JwkData -> Either String Jwk
createJwk JwkData
jwkData of
                Left  String
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
                Right Jwk
jwk -> forall (m :: * -> *) a. Monad m => a -> m a
return Jwk
jwk
        (Result (Maybe Alg), Result (Maybe KeyType))
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> Jwk
UnsupportedJwk Object
k)
  where
#if MIN_VERSION_aeson(2,0,0)
    algValue :: Value
algValue = forall a. a -> Maybe a -> a
fromMaybe Value
Null (forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"alg" Object
k)
    -- kty is required so if it's missing here we do nothing and allow decoding to fail
    -- later
    ktyValue :: Value
ktyValue = forall a. a -> Maybe a -> a
fromMaybe Value
Null (forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"kty" Object
k)
#else
    algValue = fromMaybe Null (H.lookup "alg" k)
    ktyValue = fromMaybe Null (H.lookup "kty" k)
#endif
    checkAlg :: Result (Maybe Alg)
checkAlg = forall a. FromJSON a => Value -> Result a
fromJSON Value
algValue :: Result (Maybe Alg)
    checkKty :: Result (Maybe KeyType)
checkKty = forall a. FromJSON a => Value -> Result a
fromJSON Value
ktyValue :: Result (Maybe KeyType)

instance ToJSON Jwk where
    toJSON :: Jwk -> Value
toJSON Jwk
jwk = case Jwk
jwk of
        RsaPublicJwk PublicKey
pubKey Maybe KeyId
mId Maybe KeyUse
mUse Maybe Alg
mAlg ->
          forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ PublicKey -> Maybe KeyId -> Maybe KeyUse -> Maybe Alg -> JwkData
createPubData PublicKey
pubKey Maybe KeyId
mId Maybe KeyUse
mUse Maybe Alg
mAlg
        RsaPrivateJwk PrivateKey
privKey Maybe KeyId
mId Maybe KeyUse
mUse Maybe Alg
mAlg ->
            let pubData :: JwkData
pubData = PublicKey -> Maybe KeyId -> Maybe KeyUse -> Maybe Alg -> JwkData
createPubData (PrivateKey -> PublicKey
RSA.private_pub PrivateKey
privKey) Maybe KeyId
mId Maybe KeyUse
mUse Maybe Alg
mAlg
            in  forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ JwkData
pubData
                { d :: Maybe JwkBytes
d  = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> JwkBytes
JwkBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ba. ByteArray ba => Integer -> ba
i2osp forall a b. (a -> b) -> a -> b
$ PrivateKey -> Integer
RSA.private_d PrivateKey
privKey
                , p :: Maybe JwkBytes
p  = Integer -> Maybe JwkBytes
i2b forall a b. (a -> b) -> a -> b
$ PrivateKey -> Integer
RSA.private_p    PrivateKey
privKey
                , q :: Maybe JwkBytes
q  = Integer -> Maybe JwkBytes
i2b forall a b. (a -> b) -> a -> b
$ PrivateKey -> Integer
RSA.private_q    PrivateKey
privKey
                , dp :: Maybe JwkBytes
dp = Integer -> Maybe JwkBytes
i2b forall a b. (a -> b) -> a -> b
$ PrivateKey -> Integer
RSA.private_dP   PrivateKey
privKey
                , dq :: Maybe JwkBytes
dq = Integer -> Maybe JwkBytes
i2b forall a b. (a -> b) -> a -> b
$ PrivateKey -> Integer
RSA.private_dQ   PrivateKey
privKey
                , qi :: Maybe JwkBytes
qi = Integer -> Maybe JwkBytes
i2b forall a b. (a -> b) -> a -> b
$ PrivateKey -> Integer
RSA.private_qinv PrivateKey
privKey
                }

        Ed25519PrivateJwk SecretKey
kPr PublicKey
kPub Maybe KeyId
kid_ -> forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ JwkData
defJwk
            { kty :: KeyType
kty = KeyType
Okp
            , crv :: Maybe Text
crv = forall a. a -> Maybe a
Just Text
"Ed25519"
            , d :: Maybe JwkBytes
d = forall a. a -> Maybe a
Just (ByteString -> JwkBytes
JwkBytes (forall input output.
(ByteArrayAccess input, ByteArray output) =>
input -> output
BA.convert SecretKey
kPr))
            , x :: Maybe JwkBytes
x = forall a. a -> Maybe a
Just (ByteString -> JwkBytes
JwkBytes (forall input output.
(ByteArrayAccess input, ByteArray output) =>
input -> output
BA.convert PublicKey
kPub))
            , kid :: Maybe KeyId
kid = Maybe KeyId
kid_
            }

        Ed25519PublicJwk PublicKey
kPub Maybe KeyId
kid_ -> forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ JwkData
defJwk
            { kty :: KeyType
kty = KeyType
Okp
            , crv :: Maybe Text
crv = forall a. a -> Maybe a
Just Text
"Ed25519"
            , x :: Maybe JwkBytes
x = forall a. a -> Maybe a
Just (ByteString -> JwkBytes
JwkBytes (forall input output.
(ByteArrayAccess input, ByteArray output) =>
input -> output
BA.convert PublicKey
kPub))
            , kid :: Maybe KeyId
kid = Maybe KeyId
kid_
            }

        Ed448PrivateJwk SecretKey
kPr PublicKey
kPub Maybe KeyId
kid_ -> forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ JwkData
defJwk
            { kty :: KeyType
kty = KeyType
Okp
            , crv :: Maybe Text
crv = forall a. a -> Maybe a
Just Text
"Ed448"
            , d :: Maybe JwkBytes
d = forall a. a -> Maybe a
Just (ByteString -> JwkBytes
JwkBytes (forall input output.
(ByteArrayAccess input, ByteArray output) =>
input -> output
BA.convert SecretKey
kPr))
            , x :: Maybe JwkBytes
x = forall a. a -> Maybe a
Just (ByteString -> JwkBytes
JwkBytes (forall input output.
(ByteArrayAccess input, ByteArray output) =>
input -> output
BA.convert PublicKey
kPub))
            , kid :: Maybe KeyId
kid = Maybe KeyId
kid_
            }

        Ed448PublicJwk PublicKey
kPub Maybe KeyId
kid_ -> forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ JwkData
defJwk
            { kty :: KeyType
kty = KeyType
Okp
            , crv :: Maybe Text
crv = forall a. a -> Maybe a
Just Text
"Ed448"
            , x :: Maybe JwkBytes
x = forall a. a -> Maybe a
Just (ByteString -> JwkBytes
JwkBytes (forall input output.
(ByteArrayAccess input, ByteArray output) =>
input -> output
BA.convert PublicKey
kPub))
            , kid :: Maybe KeyId
kid = Maybe KeyId
kid_
            }


        SymmetricJwk ByteString
bs Maybe KeyId
mId Maybe KeyUse
mUse Maybe Alg
mAlg -> forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ JwkData
defJwk
            { kty :: KeyType
kty = KeyType
Oct
            , k :: Maybe JwkBytes
k   = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ByteString -> JwkBytes
JwkBytes ByteString
bs
            , kid :: Maybe KeyId
kid = Maybe KeyId
mId
            , use :: Maybe KeyUse
use = Maybe KeyUse
mUse
            , alg :: Maybe Alg
alg = Maybe Alg
mAlg
            }

        EcPublicJwk PublicKey
pubKey Maybe KeyId
mId Maybe KeyUse
mUse Maybe Alg
mAlg EcCurve
c -> forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ JwkData
defJwk
            { kty :: KeyType
kty = KeyType
Ec
            , x :: Maybe JwkBytes
x   = forall a b. (a, b) -> a
fst (PublicKey -> (Maybe JwkBytes, Maybe JwkBytes)
ecPoint PublicKey
pubKey)
            , y :: Maybe JwkBytes
y   = forall a b. (a, b) -> b
snd (PublicKey -> (Maybe JwkBytes, Maybe JwkBytes)
ecPoint PublicKey
pubKey)
            , kid :: Maybe KeyId
kid = Maybe KeyId
mId
            , use :: Maybe KeyUse
use = Maybe KeyUse
mUse
            , alg :: Maybe Alg
alg = Maybe Alg
mAlg
            , crv :: Maybe Text
crv = forall a. a -> Maybe a
Just (EcCurve -> Text
ecCurveName EcCurve
c)
            }

        EcPrivateJwk KeyPair
kp Maybe KeyId
mId Maybe KeyUse
mUse Maybe Alg
mAlg EcCurve
c -> forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ JwkData
defJwk
            { kty :: KeyType
kty = KeyType
Ec
            , x :: Maybe JwkBytes
x   = forall a b. (a, b) -> a
fst (PublicKey -> (Maybe JwkBytes, Maybe JwkBytes)
ecPoint (KeyPair -> PublicKey
ECDSA.toPublicKey KeyPair
kp))
            , y :: Maybe JwkBytes
y   = forall a b. (a, b) -> b
snd (PublicKey -> (Maybe JwkBytes, Maybe JwkBytes)
ecPoint (KeyPair -> PublicKey
ECDSA.toPublicKey KeyPair
kp))
            , d :: Maybe JwkBytes
d   = Integer -> Maybe JwkBytes
i2b (PrivateKey -> Integer
ECDSA.private_d (KeyPair -> PrivateKey
ECDSA.toPrivateKey KeyPair
kp))
            , kid :: Maybe KeyId
kid = Maybe KeyId
mId
            , use :: Maybe KeyUse
use = Maybe KeyUse
mUse
            , alg :: Maybe Alg
alg = Maybe Alg
mAlg
            , crv :: Maybe Text
crv = forall a. a -> Maybe a
Just (EcCurve -> Text
ecCurveName EcCurve
c)
            }

        UnsupportedJwk Object
k -> Object -> Value
Object Object
k
      where
        i2b :: Integer -> Maybe JwkBytes
i2b Integer
0 = forall a. Maybe a
Nothing
        i2b Integer
i = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> JwkBytes
JwkBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ba. ByteArray ba => Integer -> ba
i2osp forall a b. (a -> b) -> a -> b
$ Integer
i
        ecPoint :: PublicKey -> (Maybe JwkBytes, Maybe JwkBytes)
ecPoint PublicKey
pk = case PublicKey -> PublicPoint
ECDSA.public_q PublicKey
pk of
            ECC.Point Integer
xi Integer
yi -> (Integer -> Maybe JwkBytes
i2b Integer
xi, Integer -> Maybe JwkBytes
i2b Integer
yi)
            PublicPoint
_             -> (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)

        createPubData :: PublicKey -> Maybe KeyId -> Maybe KeyUse -> Maybe Alg -> JwkData
createPubData PublicKey
pubKey Maybe KeyId
mId Maybe KeyUse
mUse Maybe Alg
mAlg = JwkData
defJwk
                              { n :: Maybe JwkBytes
n   = Integer -> Maybe JwkBytes
i2b (PublicKey -> Integer
RSA.public_n PublicKey
pubKey)
                              , e :: Maybe JwkBytes
e   = Integer -> Maybe JwkBytes
i2b (PublicKey -> Integer
RSA.public_e PublicKey
pubKey)
                              , kid :: Maybe KeyId
kid = Maybe KeyId
mId
                              , use :: Maybe KeyUse
use = Maybe KeyUse
mUse
                              , alg :: Maybe Alg
alg = Maybe Alg
mAlg
                              }
instance ToJSON JwkSet
instance FromJSON JwkSet

aesonOptions :: Options
aesonOptions :: Options
aesonOptions = Options
defaultOptions { omitNothingFields :: Bool
omitNothingFields = Bool
True }

data JwkData = J
    { JwkData -> KeyType
kty :: KeyType
    -- There's probably a better way to parse this
    -- than encoding all the possible key params
    -- but this will do for now.
    , JwkData -> Maybe JwkBytes
n   :: Maybe JwkBytes
    , JwkData -> Maybe JwkBytes
e   :: Maybe JwkBytes
    , JwkData -> Maybe JwkBytes
d   :: Maybe JwkBytes
    , JwkData -> Maybe JwkBytes
p   :: Maybe JwkBytes
    , JwkData -> Maybe JwkBytes
q   :: Maybe JwkBytes
    , JwkData -> Maybe JwkBytes
dp  :: Maybe JwkBytes
    , JwkData -> Maybe JwkBytes
dq  :: Maybe JwkBytes
    , JwkData -> Maybe JwkBytes
qi  :: Maybe JwkBytes
    , JwkData -> Maybe JwkBytes
k   :: Maybe JwkBytes
    , JwkData -> Maybe Text
crv :: Maybe Text
    , JwkData -> Maybe JwkBytes
x   :: Maybe JwkBytes
    , JwkData -> Maybe JwkBytes
y   :: Maybe JwkBytes
    , JwkData -> Maybe KeyUse
use :: Maybe KeyUse
    , JwkData -> Maybe Alg
alg :: Maybe Alg
    , JwkData -> Maybe KeyId
kid :: Maybe KeyId
    , JwkData -> Maybe Text
x5u :: Maybe Text
    , JwkData -> Maybe [Text]
x5c :: Maybe [Text]
    , JwkData -> Maybe Text
x5t :: Maybe Text
    } deriving (forall x. Rep JwkData x -> JwkData
forall x. JwkData -> Rep JwkData x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep JwkData x -> JwkData
$cfrom :: forall x. JwkData -> Rep JwkData x
Generic)

instance FromJSON JwkData
instance ToJSON   JwkData where
    toJSON :: JwkData -> Value
toJSON = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
aesonOptions

defJwk :: JwkData
defJwk :: JwkData
defJwk = J
    { kty :: KeyType
kty = KeyType
Rsa
    , n :: Maybe JwkBytes
n   = forall a. Maybe a
Nothing
    , e :: Maybe JwkBytes
e   = forall a. Maybe a
Nothing
    , d :: Maybe JwkBytes
d   = forall a. Maybe a
Nothing
    , p :: Maybe JwkBytes
p   = forall a. Maybe a
Nothing
    , q :: Maybe JwkBytes
q   = forall a. Maybe a
Nothing
    , dp :: Maybe JwkBytes
dp  = forall a. Maybe a
Nothing
    , dq :: Maybe JwkBytes
dq  = forall a. Maybe a
Nothing
    , qi :: Maybe JwkBytes
qi  = forall a. Maybe a
Nothing
    , k :: Maybe JwkBytes
k   = forall a. Maybe a
Nothing
    , crv :: Maybe Text
crv = forall a. Maybe a
Nothing
    , x :: Maybe JwkBytes
x   = forall a. Maybe a
Nothing
    , y :: Maybe JwkBytes
y   = forall a. Maybe a
Nothing
    , use :: Maybe KeyUse
use = forall a. a -> Maybe a
Just KeyUse
Sig
    , alg :: Maybe Alg
alg = forall a. Maybe a
Nothing
    , kid :: Maybe KeyId
kid = forall a. Maybe a
Nothing
    , x5u :: Maybe Text
x5u = forall a. Maybe a
Nothing
    , x5c :: Maybe [Text]
x5c = forall a. Maybe a
Nothing
    , x5t :: Maybe Text
x5t = forall a. Maybe a
Nothing
    }

createJwk :: JwkData -> Either String Jwk
createJwk :: JwkData -> Either String Jwk
createJwk J {Maybe [Text]
Maybe Text
Maybe Alg
Maybe KeyId
Maybe JwkBytes
Maybe KeyUse
KeyType
x5t :: Maybe Text
x5c :: Maybe [Text]
x5u :: Maybe Text
kid :: Maybe KeyId
alg :: Maybe Alg
use :: Maybe KeyUse
y :: Maybe JwkBytes
x :: Maybe JwkBytes
crv :: Maybe Text
k :: Maybe JwkBytes
qi :: Maybe JwkBytes
dq :: Maybe JwkBytes
dp :: Maybe JwkBytes
q :: Maybe JwkBytes
p :: Maybe JwkBytes
d :: Maybe JwkBytes
e :: Maybe JwkBytes
n :: Maybe JwkBytes
kty :: KeyType
x5t :: JwkData -> Maybe Text
x5c :: JwkData -> Maybe [Text]
x5u :: JwkData -> Maybe Text
e :: JwkData -> Maybe JwkBytes
n :: JwkData -> Maybe JwkBytes
y :: JwkData -> Maybe JwkBytes
alg :: JwkData -> Maybe Alg
use :: JwkData -> Maybe KeyUse
k :: JwkData -> Maybe JwkBytes
kid :: JwkData -> Maybe KeyId
x :: JwkData -> Maybe JwkBytes
crv :: JwkData -> Maybe Text
kty :: JwkData -> KeyType
qi :: JwkData -> Maybe JwkBytes
dq :: JwkData -> Maybe JwkBytes
dp :: JwkData -> Maybe JwkBytes
q :: JwkData -> Maybe JwkBytes
p :: JwkData -> Maybe JwkBytes
d :: JwkData -> Maybe JwkBytes
..} = case KeyType
kty of
    KeyType
Rsa -> do
        JwkBytes
nb <- forall {a} {b}. a -> Maybe b -> Either a b
note String
"n is required for an RSA key" Maybe JwkBytes
n
        JwkBytes
eb <- forall {a} {b}. a -> Maybe b -> Either a b
note String
"e is required for an RSA key" Maybe JwkBytes
e
        Either String ()
checkNoEc
        let kPub :: PublicKey
kPub = JwkBytes -> JwkBytes -> PublicKey
rsaPub JwkBytes
nb JwkBytes
eb
        case Maybe JwkBytes
d of
            Maybe JwkBytes
Nothing -> do
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Maybe a -> Bool
isNothing (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe JwkBytes
p, Maybe JwkBytes
q, Maybe JwkBytes
dp, Maybe JwkBytes
dq, Maybe JwkBytes
qi])) (forall a b. a -> Either a b
Left String
"RSA private parameters can't be set for a public key")
                forall (m :: * -> *) a. Monad m => a -> m a
return (PublicKey -> Maybe KeyId -> Maybe KeyUse -> Maybe Alg -> Jwk
RsaPublicJwk PublicKey
kPub Maybe KeyId
kid Maybe KeyUse
use Maybe Alg
alg)
            Just JwkBytes
db -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PrivateKey -> Maybe KeyId -> Maybe KeyUse -> Maybe Alg -> Jwk
RsaPrivateJwk (PublicKey
-> Integer
-> Integer
-> Integer
-> Integer
-> Integer
-> Integer
-> PrivateKey
RSA.PrivateKey PublicKey
kPub (forall ba. ByteArrayAccess ba => ba -> Integer
os2ip (JwkBytes -> ByteString
bytes JwkBytes
db)) (Maybe JwkBytes -> Integer
os2mip Maybe JwkBytes
p) (Maybe JwkBytes -> Integer
os2mip Maybe JwkBytes
q) (Maybe JwkBytes -> Integer
os2mip Maybe JwkBytes
dp) (Maybe JwkBytes -> Integer
os2mip Maybe JwkBytes
dq) (Maybe JwkBytes -> Integer
os2mip Maybe JwkBytes
qi)) Maybe KeyId
kid Maybe KeyUse
use Maybe Alg
alg
    KeyType
Oct -> do
        JwkBytes
kb <- forall {a} {b}. a -> Maybe b -> Either a b
note String
"k is required for a symmetric key" Maybe JwkBytes
k
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Maybe a -> Bool
isNothing (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe JwkBytes
n, Maybe JwkBytes
e, Maybe JwkBytes
d, Maybe JwkBytes
p, Maybe JwkBytes
q, Maybe JwkBytes
dp, Maybe JwkBytes
dq, Maybe JwkBytes
qi])) (forall a b. a -> Either a b
Left String
"RSA parameters can't be set for a symmetric key")
        Either String ()
checkNoEc
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe KeyId -> Maybe KeyUse -> Maybe Alg -> Jwk
SymmetricJwk (JwkBytes -> ByteString
bytes JwkBytes
kb) Maybe KeyId
kid Maybe KeyUse
use Maybe Alg
alg
    KeyType
Okp -> do
        Text
crv' <- forall {a} {b}. a -> Maybe b -> Either a b
note String
"crv is required for an OKP key" Maybe Text
crv
        JwkBytes
x' <- forall {a} {b}. a -> Maybe b -> Either a b
note String
"x is required for an OKP key" Maybe JwkBytes
x
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Maybe a -> Bool
isNothing (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe JwkBytes
n, Maybe JwkBytes
e, Maybe JwkBytes
p, Maybe JwkBytes
q, Maybe JwkBytes
dp, Maybe JwkBytes
dq, Maybe JwkBytes
qi])) (forall a b. a -> Either a b
Left String
"RSA parameters can't be set for an OKP key")
        case Text
crv' of
          Text
"Ed25519" -> case Maybe JwkBytes
d of
              Just JwkBytes
db -> do
                  SecretKey
secKey <- forall {a} {t} {b}.
IsString a =>
(t -> CryptoFailable b) -> t -> Either a b
createOkpKey forall ba. ByteArrayAccess ba => ba -> CryptoFailable SecretKey
Ed25519.secretKey (JwkBytes -> ByteString
bytes JwkBytes
db)
                  PublicKey
pubKey <- forall {a} {t} {b}.
IsString a =>
(t -> CryptoFailable b) -> t -> Either a b
createOkpKey forall ba. ByteArrayAccess ba => ba -> CryptoFailable PublicKey
Ed25519.publicKey (JwkBytes -> ByteString
bytes JwkBytes
x')
                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PublicKey
pubKey forall a. Eq a => a -> a -> Bool
== SecretKey -> PublicKey
Ed25519.toPublic SecretKey
secKey) (forall a b. a -> Either a b
Left String
"Public key x doesn't match private key d")
                  forall (m :: * -> *) a. Monad m => a -> m a
return (SecretKey -> PublicKey -> Maybe KeyId -> Jwk
Ed25519PrivateJwk SecretKey
secKey PublicKey
pubKey Maybe KeyId
kid)
              Maybe JwkBytes
Nothing -> do
                  PublicKey
pubKey <- forall {a} {t} {b}.
IsString a =>
(t -> CryptoFailable b) -> t -> Either a b
createOkpKey forall ba. ByteArrayAccess ba => ba -> CryptoFailable PublicKey
Ed25519.publicKey (JwkBytes -> ByteString
bytes JwkBytes
x')
                  forall (m :: * -> *) a. Monad m => a -> m a
return (PublicKey -> Maybe KeyId -> Jwk
Ed25519PublicJwk PublicKey
pubKey Maybe KeyId
kid)
          Text
"Ed448" -> case Maybe JwkBytes
d of
              Just JwkBytes
db -> do
                  SecretKey
secKey <- forall {a} {t} {b}.
IsString a =>
(t -> CryptoFailable b) -> t -> Either a b
createOkpKey forall ba. ByteArrayAccess ba => ba -> CryptoFailable SecretKey
Ed448.secretKey (JwkBytes -> ByteString
bytes JwkBytes
db)
                  PublicKey
pubKey <- forall {a} {t} {b}.
IsString a =>
(t -> CryptoFailable b) -> t -> Either a b
createOkpKey forall ba. ByteArrayAccess ba => ba -> CryptoFailable PublicKey
Ed448.publicKey (JwkBytes -> ByteString
bytes JwkBytes
x')
                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PublicKey
pubKey forall a. Eq a => a -> a -> Bool
== SecretKey -> PublicKey
Ed448.toPublic SecretKey
secKey) (forall a b. a -> Either a b
Left String
"Public key x doesn't match private key d")
                  forall (m :: * -> *) a. Monad m => a -> m a
return (SecretKey -> PublicKey -> Maybe KeyId -> Jwk
Ed448PrivateJwk SecretKey
secKey PublicKey
pubKey Maybe KeyId
kid)
              Maybe JwkBytes
Nothing -> do
                  PublicKey
pubKey <- forall {a} {t} {b}.
IsString a =>
(t -> CryptoFailable b) -> t -> Either a b
createOkpKey forall ba. ByteArrayAccess ba => ba -> CryptoFailable PublicKey
Ed448.publicKey (JwkBytes -> ByteString
bytes JwkBytes
x')
                  forall (m :: * -> *) a. Monad m => a -> m a
return (PublicKey -> Maybe KeyId -> Jwk
Ed448PublicJwk PublicKey
pubKey Maybe KeyId
kid)

          Text
_ -> forall a b. a -> Either a b
Left String
"Unknown or unsupported OKP type"
    KeyType
Ec  -> do
        Text
crv' <- forall {a} {b}. a -> Maybe b -> Either a b
note String
"crv is required for an elliptic curve key" Maybe Text
crv
        (EcCurve
crv'', Curve
c) <- forall {a} {b}. a -> Maybe b -> Either a b
note String
"crv must be a valid EC curve name" (Text -> Maybe (EcCurve, Curve)
ecCurve Text
crv')
        PublicPoint
ecPt <- Either String PublicPoint
ecPoint
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Maybe a -> Bool
isNothing (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe JwkBytes
n, Maybe JwkBytes
e, Maybe JwkBytes
p, Maybe JwkBytes
q, Maybe JwkBytes
dp, Maybe JwkBytes
dq, Maybe JwkBytes
qi])) (forall a b. a -> Either a b
Left String
"RSA parameters can't be set for an elliptic curve key")
        case Maybe JwkBytes
d of
            Maybe JwkBytes
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PublicKey
-> Maybe KeyId -> Maybe KeyUse -> Maybe Alg -> EcCurve -> Jwk
EcPublicJwk (Curve -> PublicPoint -> PublicKey
ECDSA.PublicKey Curve
c PublicPoint
ecPt) Maybe KeyId
kid Maybe KeyUse
use Maybe Alg
alg EcCurve
crv''
            Just JwkBytes
db -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ KeyPair
-> Maybe KeyId -> Maybe KeyUse -> Maybe Alg -> EcCurve -> Jwk
EcPrivateJwk (Curve -> PublicPoint -> Integer -> KeyPair
ECDSA.KeyPair Curve
c PublicPoint
ecPt (forall ba. ByteArrayAccess ba => ba -> Integer
os2ip (JwkBytes -> ByteString
bytes JwkBytes
db))) Maybe KeyId
kid Maybe KeyUse
use Maybe Alg
alg EcCurve
crv''
  where
    checkNoEc :: Either String ()
checkNoEc = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Maybe a -> Bool
isNothing Maybe Text
crv) (forall a b. a -> Either a b
Left String
"Elliptic curve type can't be set for an RSA key") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Maybe a -> Bool
isNothing (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe JwkBytes
x, Maybe JwkBytes
y])) (forall a b. a -> Either a b
Left String
"Elliptic curve coordinates can't be set for an RSA key")
    createOkpKey :: (t -> CryptoFailable b) -> t -> Either a b
createOkpKey t -> CryptoFailable b
f t
ba = case t -> CryptoFailable b
f t
ba of
       CryptoPassed b
k_ -> forall a b. b -> Either a b
Right b
k_
       CryptoFailable b
_ -> forall a b. a -> Either a b
Left a
"Invalid OKP key data"

    note :: a -> Maybe b -> Either a b
note a
err      = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left a
err) forall a b. b -> Either a b
Right
    os2mip :: Maybe JwkBytes -> Integer
os2mip        = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Integer
0 (forall ba. ByteArrayAccess ba => ba -> Integer
os2ip forall b c a. (b -> c) -> (a -> b) -> a -> c
. JwkBytes -> ByteString
bytes)
    rsaPub :: JwkBytes -> JwkBytes -> PublicKey
rsaPub JwkBytes
nb JwkBytes
eb  = let m :: Integer
m  = forall ba. ByteArrayAccess ba => ba -> Integer
os2ip forall a b. (a -> b) -> a -> b
$ JwkBytes -> ByteString
bytes JwkBytes
nb
                        ex :: Integer
ex = forall ba. ByteArrayAccess ba => ba -> Integer
os2ip forall a b. (a -> b) -> a -> b
$ JwkBytes -> ByteString
bytes JwkBytes
eb
                    in Int -> Integer -> Integer -> PublicKey
RSA.PublicKey (forall {t} {t}. (Integral t, Num t, Ord t) => t -> t -> t
rsaSize Integer
m Int
1) Integer
m Integer
ex
    rsaSize :: t -> t -> t
rsaSize t
m t
i   = if t
2 forall a b. (Num a, Integral b) => a -> b -> a
^ (t
i forall a. Num a => a -> a -> a
* t
8) forall a. Ord a => a -> a -> Bool
> t
m then t
i else t -> t -> t
rsaSize t
m (t
iforall a. Num a => a -> a -> a
+t
1)
    ecPoint :: Either String PublicPoint
ecPoint       = do
        JwkBytes
xb <- forall {a} {b}. a -> Maybe b -> Either a b
note String
"x is required for an EC key" Maybe JwkBytes
x
        JwkBytes
yb <- forall {a} {b}. a -> Maybe b -> Either a b
note String
"y is required for an EC key" Maybe JwkBytes
y
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> PublicPoint
ECC.Point (forall ba. ByteArrayAccess ba => ba -> Integer
os2ip (JwkBytes -> ByteString
bytes JwkBytes
xb)) (forall ba. ByteArrayAccess ba => ba -> Integer
os2ip (JwkBytes -> ByteString
bytes JwkBytes
yb))