{-# 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
(KeyType -> KeyType -> Bool)
-> (KeyType -> KeyType -> Bool) -> Eq KeyType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyType -> KeyType -> Bool
== :: KeyType -> KeyType -> Bool
$c/= :: KeyType -> KeyType -> Bool
/= :: KeyType -> KeyType -> Bool
Eq)

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

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

newtype JwkSet = JwkSet
    { JwkSet -> [Jwk]
keys :: [Jwk]
    } deriving (Int -> JwkSet -> ShowS
[JwkSet] -> ShowS
JwkSet -> String
(Int -> JwkSet -> ShowS)
-> (JwkSet -> String) -> ([JwkSet] -> ShowS) -> Show JwkSet
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> JwkSet -> ShowS
showsPrec :: Int -> JwkSet -> ShowS
$cshow :: JwkSet -> String
show :: JwkSet -> String
$cshowList :: [JwkSet] -> ShowS
showList :: [JwkSet] -> ShowS
Show, JwkSet -> JwkSet -> Bool
(JwkSet -> JwkSet -> Bool)
-> (JwkSet -> JwkSet -> Bool) -> Eq JwkSet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: JwkSet -> JwkSet -> Bool
== :: JwkSet -> JwkSet -> Bool
$c/= :: JwkSet -> JwkSet -> Bool
/= :: JwkSet -> JwkSet -> Bool
Eq, (forall x. JwkSet -> Rep JwkSet x)
-> (forall x. Rep JwkSet x -> JwkSet) -> Generic JwkSet
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
$cfrom :: forall x. JwkSet -> Rep JwkSet x
from :: forall x. JwkSet -> Rep JwkSet x
$cto :: forall x. Rep JwkSet x -> JwkSet
to :: forall x. Rep JwkSet x -> JwkSet
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) <- Int -> Integer -> m (PublicKey, PrivateKey)
forall (m :: * -> *).
MonadRandom m =>
Int -> Integer -> m (PublicKey, PrivateKey)
RSA.generate Int
nBytes Integer
65537
    (Jwk, Jwk) -> m (Jwk, Jwk)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (PublicKey -> Maybe KeyId -> Maybe KeyUse -> Maybe Alg -> Jwk
RsaPublicJwk PublicKey
kPub (KeyId -> Maybe KeyId
forall a. a -> Maybe a
Just KeyId
id') (KeyUse -> Maybe KeyUse
forall a. a -> Maybe a
Just KeyUse
kuse) Maybe Alg
kalg, PrivateKey -> Maybe KeyId -> Maybe KeyUse -> Maybe Alg -> Jwk
RsaPrivateJwk PrivateKey
kPr (KeyId -> Maybe KeyId
forall a. a -> Maybe a
Just KeyId
id') (KeyUse -> Maybe KeyUse
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 <- Int -> m ByteString
forall byteArray. ByteArray byteArray => Int -> m byteArray
forall (m :: * -> *) byteArray.
(MonadRandom m, ByteArray byteArray) =>
Int -> m byteArray
getRandomBytes Int
size
    Jwk -> m Jwk
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Jwk -> m Jwk) -> Jwk -> m Jwk
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe KeyId -> Maybe KeyUse -> Maybe Alg -> Jwk
SymmetricJwk ByteString
k (KeyId -> Maybe KeyId
forall a. a -> Maybe a
Just KeyId
id') (KeyUse -> Maybe KeyUse
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 Maybe KeyUse -> Maybe KeyUse -> Bool
forall a. Eq a => a -> a -> Bool
/= KeyUse -> Maybe KeyUse
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 Maybe KeyUse -> Maybe KeyUse -> Bool
forall a. Eq a => a -> a -> Bool
/= KeyUse -> Maybe KeyUse
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 Maybe KeyUse -> Maybe KeyUse -> Bool
forall a. Eq a => a -> a -> Bool
/= KeyUse -> Maybe KeyUse
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 Int -> Int -> Bool
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 Int -> Int -> Bool
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 Int -> Int -> Bool
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 Maybe KeyUse -> Maybe KeyUse -> Bool
forall a. Eq a => a -> a -> Bool
/= KeyUse -> Maybe KeyUse
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 Int -> Int -> Bool
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 Int -> Int -> Bool
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 Int -> Int -> Bool
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' Maybe KeyId -> Maybe KeyId -> Bool
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 Alg -> Alg -> Bool
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" -> (EcCurve, Curve) -> Maybe (EcCurve, Curve)
forall a. a -> Maybe a
Just (EcCurve
P_256, CurveName -> Curve
ECC.getCurveByName CurveName
ECC.SEC_p256r1)
    Text
"P-384" -> (EcCurve, Curve) -> Maybe (EcCurve, Curve)
forall a. a -> Maybe a
Just (EcCurve
P_384, CurveName -> Curve
ECC.getCurveByName CurveName
ECC.SEC_p384r1)
    Text
"P-521" -> (EcCurve, Curve) -> Maybe (EcCurve, Curve)
forall a. a -> Maybe a
Just (EcCurve
P_521, CurveName -> Curve
ECC.getCurveByName CurveName
ECC.SEC_p521r1)
    Text
_ -> Maybe (EcCurve, Curve)
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
_ -> Maybe KeyId
forall a. Maybe a
Nothing

jwkUse :: Jwk -> Maybe KeyUse
jwkUse :: Jwk -> Maybe KeyUse
jwkUse Jwk
key = case Jwk
key of
    Ed25519PrivateJwk {} -> KeyUse -> Maybe KeyUse
forall a. a -> Maybe a
Just KeyUse
Sig
    Ed25519PublicJwk PublicKey
_ Maybe KeyId
_ -> KeyUse -> Maybe KeyUse
forall a. a -> Maybe a
Just KeyUse
Sig
    Ed448PrivateJwk {} -> KeyUse -> Maybe KeyUse
forall a. a -> Maybe a
Just KeyUse
Sig
    Ed448PublicJwk PublicKey
_ Maybe KeyId
_ -> KeyUse -> Maybe KeyUse
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
_ -> Maybe KeyUse
forall a. Maybe a
Nothing

jwkAlg :: Jwk -> Maybe Alg
jwkAlg :: Jwk -> Maybe Alg
jwkAlg Jwk
key = case Jwk
key of
    Ed25519PrivateJwk {} -> Alg -> Maybe Alg
forall a. a -> Maybe a
Just (JwsAlg -> Alg
Signed JwsAlg
EdDSA)
    Ed25519PublicJwk PublicKey
_ Maybe KeyId
_ -> Alg -> Maybe Alg
forall a. a -> Maybe a
Just (JwsAlg -> Alg
Signed JwsAlg
EdDSA)
    Ed448PrivateJwk {} -> Alg -> Maybe Alg
forall a. a -> Maybe a
Just (JwsAlg -> Alg
Signed JwsAlg
EdDSA)
    Ed448PublicJwk PublicKey
_ Maybe KeyId
_ -> Alg -> Maybe Alg
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
_ -> Maybe Alg
forall a. Maybe a
Nothing


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

instance FromJSON KeyType where
    parseJSON :: Value -> Parser KeyType
parseJSON = String -> (Text -> Parser KeyType) -> Value -> Parser KeyType
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"KeyType" ((Text -> Parser KeyType) -> Value -> Parser KeyType)
-> (Text -> Parser KeyType) -> Value -> Parser KeyType
forall a b. (a -> b) -> a -> b
$ \Text
t ->
        case Text
t of
          Text
"RSA" -> KeyType -> Parser KeyType
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyType
Rsa
          Text
"OKP" -> KeyType -> Parser KeyType
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyType
Okp
          Text
"EC"  -> KeyType -> Parser KeyType
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyType
Ec
          Text
"oct" -> KeyType -> Parser KeyType
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyType
Oct
          Text
_     -> String -> Parser KeyType
forall a. String -> Parser a
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 = String -> (Text -> Parser KeyUse) -> Value -> Parser KeyUse
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"KeyUse" ((Text -> Parser KeyUse) -> Value -> Parser KeyUse)
-> (Text -> Parser KeyUse) -> Value -> Parser KeyUse
forall a b. (a -> b) -> a -> b
$ \Text
t ->
        case Text
t of
          Text
"sig" -> KeyUse -> Parser KeyUse
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyUse
Sig
          Text
"enc" -> KeyUse -> Parser KeyUse
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyUse
Enc
          Text
_     -> String -> Parser KeyUse
forall a. String -> Parser a
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 = String -> (Text -> Parser EcCurve) -> Value -> Parser EcCurve
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"EcCurve" ((Text -> Parser EcCurve) -> Value -> Parser EcCurve)
-> (Text -> Parser EcCurve) -> Value -> Parser EcCurve
forall a b. (a -> b) -> a -> b
$ \Text
t ->
        case Text
t of
          Text
"P-256" -> EcCurve -> Parser EcCurve
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EcCurve
P_256
          Text
"P-384" -> EcCurve -> Parser EcCurve
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EcCurve
P_384
          Text
"P-521" -> EcCurve -> Parser EcCurve
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EcCurve
P_521
          Text
_       -> String -> Parser EcCurve
forall a. String -> Parser a
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 = String -> (Text -> Parser JwkBytes) -> Value -> Parser JwkBytes
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"JwkBytes" ((Text -> Parser JwkBytes) -> Value -> Parser JwkBytes)
-> (Text -> Parser JwkBytes) -> Value -> Parser JwkBytes
forall a b. (a -> b) -> a -> b
$ \Text
t ->
        case ByteString -> Either JwtError ByteString
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
_  -> String -> Parser JwkBytes
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"could not base64 decode bytes"
          Right ByteString
b  -> JwkBytes -> Parser JwkBytes
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JwkBytes -> Parser JwkBytes) -> JwkBytes -> Parser JwkBytes
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 (Text -> Value) -> (ByteString -> Text) -> ByteString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TE.decodeUtf8 (ByteString -> Value) -> ByteString -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
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
_            = String -> Parser Jwk
forall a. String -> Parser a
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 <- Value -> Parser 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 -> String -> Parser Jwk
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
                Right Jwk
jwk -> Jwk -> Parser Jwk
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Jwk
jwk
        (Result (Maybe Alg), Result (Maybe KeyType))
_ -> Jwk -> Parser Jwk
forall a. a -> Parser a
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 = Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Key -> Object -> Maybe Value
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 = Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe Value
Null (Key -> Object -> Maybe Value
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 = Value -> Result (Maybe Alg)
forall a. FromJSON a => Value -> Result a
fromJSON Value
algValue :: Result (Maybe Alg)
    checkKty :: Result (Maybe KeyType)
checkKty = Value -> Result (Maybe KeyType)
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 ->
          JwkData -> Value
forall a. ToJSON a => a -> Value
toJSON (JwkData -> Value) -> JwkData -> Value
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  JwkData -> Value
forall a. ToJSON a => a -> Value
toJSON (JwkData -> Value) -> JwkData -> Value
forall a b. (a -> b) -> a -> b
$ JwkData
pubData
                { d  = Just . JwkBytes . i2osp $ RSA.private_d privKey
                , p  = i2b $ RSA.private_p    privKey
                , q  = i2b $ RSA.private_q    privKey
                , dp = i2b $ RSA.private_dP   privKey
                , dq = i2b $ RSA.private_dQ   privKey
                , qi = i2b $ RSA.private_qinv privKey
                }

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

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

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

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


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

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

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

        UnsupportedJwk Object
k -> Object -> Value
Object Object
k
      where
        i2b :: Integer -> Maybe JwkBytes
i2b Integer
0 = Maybe JwkBytes
forall a. Maybe a
Nothing
        i2b Integer
i = JwkBytes -> Maybe JwkBytes
forall a. a -> Maybe a
Just (JwkBytes -> Maybe JwkBytes)
-> (Integer -> JwkBytes) -> Integer -> Maybe JwkBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> JwkBytes
JwkBytes (ByteString -> JwkBytes)
-> (Integer -> ByteString) -> Integer -> JwkBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> ByteString
forall ba. ByteArray ba => Integer -> ba
i2osp (Integer -> Maybe JwkBytes) -> Integer -> Maybe JwkBytes
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
_             -> (Maybe JwkBytes
forall a. Maybe a
Nothing, Maybe JwkBytes
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   = i2b (RSA.public_n pubKey)
                              , e   = i2b (RSA.public_e pubKey)
                              , kid = mId
                              , use = mUse
                              , alg = mAlg
                              }
instance ToJSON JwkSet
instance FromJSON JwkSet

aesonOptions :: Options
aesonOptions :: Options
aesonOptions = Options
defaultOptions { omitNothingFields = 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. JwkData -> Rep JwkData x)
-> (forall x. Rep JwkData x -> JwkData) -> Generic JwkData
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
$cfrom :: forall x. JwkData -> Rep JwkData x
from :: forall x. JwkData -> Rep JwkData x
$cto :: forall x. Rep JwkData x -> JwkData
to :: forall x. Rep JwkData x -> JwkData
Generic)

instance FromJSON JwkData
instance ToJSON   JwkData where
    toJSON :: JwkData -> Value
toJSON = Options -> JwkData -> Value
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   = Maybe JwkBytes
forall a. Maybe a
Nothing
    , e :: Maybe JwkBytes
e   = Maybe JwkBytes
forall a. Maybe a
Nothing
    , d :: Maybe JwkBytes
d   = Maybe JwkBytes
forall a. Maybe a
Nothing
    , p :: Maybe JwkBytes
p   = Maybe JwkBytes
forall a. Maybe a
Nothing
    , q :: Maybe JwkBytes
q   = Maybe JwkBytes
forall a. Maybe a
Nothing
    , dp :: Maybe JwkBytes
dp  = Maybe JwkBytes
forall a. Maybe a
Nothing
    , dq :: Maybe JwkBytes
dq  = Maybe JwkBytes
forall a. Maybe a
Nothing
    , qi :: Maybe JwkBytes
qi  = Maybe JwkBytes
forall a. Maybe a
Nothing
    , k :: Maybe JwkBytes
k   = Maybe JwkBytes
forall a. Maybe a
Nothing
    , crv :: Maybe Text
crv = Maybe Text
forall a. Maybe a
Nothing
    , x :: Maybe JwkBytes
x   = Maybe JwkBytes
forall a. Maybe a
Nothing
    , y :: Maybe JwkBytes
y   = Maybe JwkBytes
forall a. Maybe a
Nothing
    , use :: Maybe KeyUse
use = KeyUse -> Maybe KeyUse
forall a. a -> Maybe a
Just KeyUse
Sig
    , alg :: Maybe Alg
alg = Maybe Alg
forall a. Maybe a
Nothing
    , kid :: Maybe KeyId
kid = Maybe KeyId
forall a. Maybe a
Nothing
    , x5u :: Maybe Text
x5u = Maybe Text
forall a. Maybe a
Nothing
    , x5c :: Maybe [Text]
x5c = Maybe [Text]
forall a. Maybe a
Nothing
    , x5t :: Maybe Text
x5t = Maybe Text
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
d :: JwkData -> Maybe JwkBytes
p :: JwkData -> Maybe JwkBytes
q :: JwkData -> Maybe JwkBytes
dp :: JwkData -> Maybe JwkBytes
dq :: JwkData -> Maybe JwkBytes
qi :: JwkData -> Maybe JwkBytes
kty :: JwkData -> KeyType
crv :: JwkData -> Maybe Text
x :: JwkData -> Maybe JwkBytes
kid :: JwkData -> Maybe KeyId
k :: JwkData -> Maybe JwkBytes
use :: JwkData -> Maybe KeyUse
alg :: JwkData -> Maybe Alg
y :: JwkData -> Maybe JwkBytes
n :: JwkData -> Maybe JwkBytes
e :: JwkData -> Maybe JwkBytes
x5u :: JwkData -> Maybe Text
x5c :: JwkData -> Maybe [Text]
x5t :: JwkData -> Maybe Text
kty :: KeyType
n :: Maybe JwkBytes
e :: Maybe JwkBytes
d :: Maybe JwkBytes
p :: Maybe JwkBytes
q :: Maybe JwkBytes
dp :: Maybe JwkBytes
dq :: Maybe JwkBytes
qi :: Maybe JwkBytes
k :: Maybe JwkBytes
crv :: Maybe Text
x :: Maybe JwkBytes
y :: Maybe JwkBytes
use :: Maybe KeyUse
alg :: Maybe Alg
kid :: Maybe KeyId
x5u :: Maybe Text
x5c :: Maybe [Text]
x5t :: Maybe Text
..} = case KeyType
kty of
    KeyType
Rsa -> do
        JwkBytes
nb <- String -> Maybe JwkBytes -> Either String JwkBytes
forall {a} {b}. a -> Maybe b -> Either a b
note String
"n is required for an RSA key" Maybe JwkBytes
n
        JwkBytes
eb <- String -> Maybe JwkBytes -> Either String JwkBytes
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
                Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe [JwkBytes] -> Bool
forall a. Maybe a -> Bool
isNothing ([Maybe JwkBytes] -> Maybe [JwkBytes]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe JwkBytes
p, Maybe JwkBytes
q, Maybe JwkBytes
dp, Maybe JwkBytes
dq, Maybe JwkBytes
qi])) (String -> Either String ()
forall a b. a -> Either a b
Left String
"RSA private parameters can't be set for a public key")
                Jwk -> Either String Jwk
forall a. a -> Either String a
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 -> Jwk -> Either String Jwk
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Jwk -> Either String Jwk) -> Jwk -> Either String Jwk
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 (ByteString -> Integer
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 <- String -> Maybe JwkBytes -> Either String JwkBytes
forall {a} {b}. a -> Maybe b -> Either a b
note String
"k is required for a symmetric key" Maybe JwkBytes
k
        Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe [JwkBytes] -> Bool
forall a. Maybe a -> Bool
isNothing ([Maybe JwkBytes] -> Maybe [JwkBytes]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [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])) (String -> Either String ()
forall a b. a -> Either a b
Left String
"RSA parameters can't be set for a symmetric key")
        Either String ()
checkNoEc
        Jwk -> Either String Jwk
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Jwk -> Either String Jwk) -> Jwk -> Either String Jwk
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' <- String -> Maybe Text -> Either String Text
forall {a} {b}. a -> Maybe b -> Either a b
note String
"crv is required for an OKP key" Maybe Text
crv
        JwkBytes
x' <- String -> Maybe JwkBytes -> Either String JwkBytes
forall {a} {b}. a -> Maybe b -> Either a b
note String
"x is required for an OKP key" Maybe JwkBytes
x
        Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe [JwkBytes] -> Bool
forall a. Maybe a -> Bool
isNothing ([Maybe JwkBytes] -> Maybe [JwkBytes]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe JwkBytes
n, Maybe JwkBytes
e, Maybe JwkBytes
p, Maybe JwkBytes
q, Maybe JwkBytes
dp, Maybe JwkBytes
dq, Maybe JwkBytes
qi])) (String -> Either String ()
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 <- (ByteString -> CryptoFailable SecretKey)
-> ByteString -> Either String SecretKey
forall {a} {t} {b}.
IsString a =>
(t -> CryptoFailable b) -> t -> Either a b
createOkpKey ByteString -> CryptoFailable SecretKey
forall ba. ByteArrayAccess ba => ba -> CryptoFailable SecretKey
Ed25519.secretKey (JwkBytes -> ByteString
bytes JwkBytes
db)
                  PublicKey
pubKey <- (ByteString -> CryptoFailable PublicKey)
-> ByteString -> Either String PublicKey
forall {a} {t} {b}.
IsString a =>
(t -> CryptoFailable b) -> t -> Either a b
createOkpKey ByteString -> CryptoFailable PublicKey
forall ba. ByteArrayAccess ba => ba -> CryptoFailable PublicKey
Ed25519.publicKey (JwkBytes -> ByteString
bytes JwkBytes
x')
                  Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PublicKey
pubKey PublicKey -> PublicKey -> Bool
forall a. Eq a => a -> a -> Bool
== SecretKey -> PublicKey
Ed25519.toPublic SecretKey
secKey) (String -> Either String ()
forall a b. a -> Either a b
Left String
"Public key x doesn't match private key d")
                  Jwk -> Either String Jwk
forall a. a -> Either String a
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 <- (ByteString -> CryptoFailable PublicKey)
-> ByteString -> Either String PublicKey
forall {a} {t} {b}.
IsString a =>
(t -> CryptoFailable b) -> t -> Either a b
createOkpKey ByteString -> CryptoFailable PublicKey
forall ba. ByteArrayAccess ba => ba -> CryptoFailable PublicKey
Ed25519.publicKey (JwkBytes -> ByteString
bytes JwkBytes
x')
                  Jwk -> Either String Jwk
forall a. a -> Either String a
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 <- (ByteString -> CryptoFailable SecretKey)
-> ByteString -> Either String SecretKey
forall {a} {t} {b}.
IsString a =>
(t -> CryptoFailable b) -> t -> Either a b
createOkpKey ByteString -> CryptoFailable SecretKey
forall ba. ByteArrayAccess ba => ba -> CryptoFailable SecretKey
Ed448.secretKey (JwkBytes -> ByteString
bytes JwkBytes
db)
                  PublicKey
pubKey <- (ByteString -> CryptoFailable PublicKey)
-> ByteString -> Either String PublicKey
forall {a} {t} {b}.
IsString a =>
(t -> CryptoFailable b) -> t -> Either a b
createOkpKey ByteString -> CryptoFailable PublicKey
forall ba. ByteArrayAccess ba => ba -> CryptoFailable PublicKey
Ed448.publicKey (JwkBytes -> ByteString
bytes JwkBytes
x')
                  Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (PublicKey
pubKey PublicKey -> PublicKey -> Bool
forall a. Eq a => a -> a -> Bool
== SecretKey -> PublicKey
Ed448.toPublic SecretKey
secKey) (String -> Either String ()
forall a b. a -> Either a b
Left String
"Public key x doesn't match private key d")
                  Jwk -> Either String Jwk
forall a. a -> Either String a
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 <- (ByteString -> CryptoFailable PublicKey)
-> ByteString -> Either String PublicKey
forall {a} {t} {b}.
IsString a =>
(t -> CryptoFailable b) -> t -> Either a b
createOkpKey ByteString -> CryptoFailable PublicKey
forall ba. ByteArrayAccess ba => ba -> CryptoFailable PublicKey
Ed448.publicKey (JwkBytes -> ByteString
bytes JwkBytes
x')
                  Jwk -> Either String Jwk
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (PublicKey -> Maybe KeyId -> Jwk
Ed448PublicJwk PublicKey
pubKey Maybe KeyId
kid)

          Text
_ -> String -> Either String Jwk
forall a b. a -> Either a b
Left String
"Unknown or unsupported OKP type"
    KeyType
Ec  -> do
        Text
crv' <- String -> Maybe Text -> Either String Text
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) <- String -> Maybe (EcCurve, Curve) -> Either String (EcCurve, Curve)
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
        Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe [JwkBytes] -> Bool
forall a. Maybe a -> Bool
isNothing ([Maybe JwkBytes] -> Maybe [JwkBytes]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe JwkBytes
n, Maybe JwkBytes
e, Maybe JwkBytes
p, Maybe JwkBytes
q, Maybe JwkBytes
dp, Maybe JwkBytes
dq, Maybe JwkBytes
qi])) (String -> Either String ()
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 -> Jwk -> Either String Jwk
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Jwk -> Either String Jwk) -> Jwk -> Either String Jwk
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 -> Jwk -> Either String Jwk
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Jwk -> Either String Jwk) -> Jwk -> Either String Jwk
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 (ByteString -> Integer
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 = Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Text
crv) (String -> Either String ()
forall a b. a -> Either a b
Left String
"Elliptic curve type can't be set for an RSA key") Either String () -> Either String () -> Either String ()
forall a b. Either String a -> Either String b -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
       Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe [JwkBytes] -> Bool
forall a. Maybe a -> Bool
isNothing ([Maybe JwkBytes] -> Maybe [JwkBytes]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe JwkBytes
x, Maybe JwkBytes
y])) (String -> Either String ()
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_ -> b -> Either a b
forall a b. b -> Either a b
Right b
k_
       CryptoFailable b
_ -> a -> Either a b
forall a b. a -> Either a b
Left a
"Invalid OKP key data"

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