-- Copyright (C) 2013, 2014, 2015, 2016, 2017  Fraser Tweedale
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

{-|

A JSON Web Key (JWK) is a JavaScript Object Notation (JSON) data
structure that represents a cryptographic key.  This module also
defines a JSON Web Key Set (JWK Set) JSON data structure for
representing a set of JWKs.

@
-- Generate RSA JWK and set "kid" param to
-- base64url-encoded SHA-256 thumbprint of key.
--
doGen :: IO JWK
doGen = do
  jwk <- 'genJWK' ('RSAGenParam' (4096 \`div` 8))
  let
    h = view 'thumbprint' jwk :: Digest SHA256
    kid = view (re ('Types.base64url' . 'digest') . utf8) h
  pure $ set 'jwkKid' (Just kid) jwk
@

-}
module Crypto.JOSE.JWK
  (
  -- * JWK generation
    genJWK
  , KeyMaterialGenParam(..)
  , Crv(..)
  , OKPCrv(..)
  , JWK
  , AsPublicKey(..)

  -- * Parts of a JWK
  , jwkMaterial
  , jwkUse
  , KeyUse(..)
  , jwkKeyOps
  , KeyOp(..)
  , jwkAlg
  , JWKAlg(..)
  , jwkKid
  , jwkX5u
  , jwkX5c
  , setJWKX5c
  , jwkX5t
  , jwkX5tS256

  -- * Converting from other key formats
  , fromKeyMaterial
  , fromRSA
  , fromOctets
  , fromX509Certificate

  -- * JWK Thumbprint
  , thumbprint
  , digest
  , Types.base64url
  , module Crypto.Hash

  -- * JWK Set
  , JWKSet(..)

  -- Miscellaneous
  , checkJWK
  , bestJWSAlg

  , module Crypto.JOSE.JWA.JWK
  ) where

import Control.Applicative
import Control.Monad ((>=>))
import Data.Function (on)
import Data.Maybe (catMaybes)
import Data.Monoid ((<>))
import Data.Word (Word8)

import Control.Lens hiding ((.=))
import Control.Lens.Cons.Extras (recons)
import Control.Monad.Except (MonadError, runExcept)
import Control.Monad.Error.Lens (throwing, throwing_)
import Crypto.Hash
import qualified Crypto.PubKey.RSA as RSA
import Data.Aeson
import Data.Aeson.Types (explicitParseFieldMaybe')
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Builder as Builder
import Data.List.NonEmpty
import qualified Data.Text as T
import qualified Data.X509 as X509

import Crypto.JOSE.Error
import qualified Crypto.JOSE.JWA.JWE.Alg as JWA.JWE
import Crypto.JOSE.JWA.JWK
import qualified Crypto.JOSE.JWA.JWS as JWA.JWS
import qualified Crypto.JOSE.TH
import qualified Crypto.JOSE.Types as Types
import Crypto.JOSE.Types.URI
import qualified Crypto.JOSE.Types.Internal as Types


-- | RFC 7517 §4.4.  "alg" (Algorithm) Parameter
--
-- See also RFC 7518 §6.4. which states that for "oct" keys, an
-- "alg" member SHOULD be present to identify the algorithm intended
-- to be used with the key, unless the application uses another
-- means or convention to determine the algorithm used.
--
data JWKAlg = JWSAlg JWA.JWS.Alg | JWEAlg JWA.JWE.Alg
  deriving (JWKAlg -> JWKAlg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JWKAlg -> JWKAlg -> Bool
$c/= :: JWKAlg -> JWKAlg -> Bool
== :: JWKAlg -> JWKAlg -> Bool
$c== :: JWKAlg -> JWKAlg -> Bool
Eq, Int -> JWKAlg -> ShowS
[JWKAlg] -> ShowS
JWKAlg -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JWKAlg] -> ShowS
$cshowList :: [JWKAlg] -> ShowS
show :: JWKAlg -> String
$cshow :: JWKAlg -> String
showsPrec :: Int -> JWKAlg -> ShowS
$cshowsPrec :: Int -> JWKAlg -> ShowS
Show)

instance FromJSON JWKAlg where
  parseJSON :: Value -> Parser JWKAlg
parseJSON Value
v = (Alg -> JWKAlg
JWSAlg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Alg -> JWKAlg
JWEAlg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)

instance ToJSON JWKAlg where
  toJSON :: JWKAlg -> Value
toJSON (JWSAlg Alg
alg) = forall a. ToJSON a => a -> Value
toJSON Alg
alg
  toJSON (JWEAlg Alg
alg) = forall a. ToJSON a => a -> Value
toJSON Alg
alg


-- | RFC 7517 §4.3.  "key_ops" (Key Operations) Parameter
--
$(Crypto.JOSE.TH.deriveJOSEType "KeyOp"
  [ "sign", "verify", "encrypt", "decrypt"
  , "wrapKey", "unwrapKey", "deriveKey", "deriveBits"
  ])


-- | RFC 7517 §4.2.  "use" (Public Key Use) Parameter
--
$(Crypto.JOSE.TH.deriveJOSEType "KeyUse" ["sig", "enc"])


-- | RFC 7517 §4.  JSON Web Key (JWK) Format
--
data JWK = JWK
  {
    JWK -> KeyMaterial
_jwkMaterial :: Crypto.JOSE.JWA.JWK.KeyMaterial
  , JWK -> Maybe KeyUse
_jwkUse :: Maybe KeyUse
  , JWK -> Maybe [KeyOp]
_jwkKeyOps :: Maybe [KeyOp]
  , JWK -> Maybe JWKAlg
_jwkAlg :: Maybe JWKAlg
  , JWK -> Maybe Text
_jwkKid :: Maybe T.Text
  , JWK -> Maybe URI
_jwkX5u :: Maybe Types.URI
  , JWK -> Maybe (NonEmpty SignedCertificate)
_jwkX5cRaw :: Maybe (NonEmpty X509.SignedCertificate)
  , JWK -> Maybe Base64SHA1
_jwkX5t :: Maybe Types.Base64SHA1
  , JWK -> Maybe Base64SHA256
_jwkX5tS256 :: Maybe Types.Base64SHA256
  }
  deriving (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, 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)
makeLenses ''JWK

-- | Get the certificate chain.  Not a lens, because the key of the first
-- certificate in the chain must correspond be the public key of the JWK.
-- To set the certificate chain use 'setJWKX5c'.
--
jwkX5c :: Getter JWK (Maybe (NonEmpty X509.SignedCertificate))
jwkX5c :: Getter JWK (Maybe (NonEmpty SignedCertificate))
jwkX5c = Lens' JWK (Maybe (NonEmpty SignedCertificate))
jwkX5cRaw

-- | Set the @"x5c"@ Certificate Chain parameter.  If setting the list,
-- checks that the key in the first certificate matches the JWK; returns
-- @Nothing@ if it does not.
--
setJWKX5c :: Maybe (NonEmpty X509.SignedCertificate) -> JWK -> Maybe JWK
setJWKX5c :: Maybe (NonEmpty SignedCertificate) -> JWK -> Maybe JWK
setJWKX5c Maybe (NonEmpty SignedCertificate)
Nothing JWK
k = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' JWK (Maybe (NonEmpty SignedCertificate))
jwkX5cRaw forall a. Maybe a
Nothing JWK
k)
setJWKX5c certs :: Maybe (NonEmpty SignedCertificate)
certs@(Just (SignedCertificate
cert :| [SignedCertificate]
_)) JWK
key
  | JWK -> SignedCertificate -> Bool
certMatchesKey JWK
key SignedCertificate
cert = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' JWK (Maybe (NonEmpty SignedCertificate))
jwkX5cRaw Maybe (NonEmpty SignedCertificate)
certs JWK
key)
  | Bool
otherwise = forall a. Maybe a
Nothing

certMatchesKey :: JWK -> X509.SignedCertificate -> Bool
certMatchesKey :: JWK -> SignedCertificate -> Bool
certMatchesKey JWK
key SignedCertificate
cert =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ((forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview (Lens' JWK KeyMaterial
jwkMaterial forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k. AsPublicKey k => Getter k (Maybe k)
asPublicKey)) JWK
key)
    (SignedCertificate -> Maybe JWK
fromX509CertificateMaybe SignedCertificate
cert)


instance FromJSON JWK where
  parseJSON :: Value -> Parser JWK
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"JWK" (\Object
o -> KeyMaterial
-> Maybe KeyUse
-> Maybe [KeyOp]
-> Maybe JWKAlg
-> Maybe Text
-> Maybe URI
-> Maybe (NonEmpty SignedCertificate)
-> Maybe Base64SHA1
-> Maybe Base64SHA256
-> JWK
JWK
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"use"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"key_ops"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"alg"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"kid"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Value -> Parser a) -> Object -> Key -> Parser (Maybe a)
explicitParseFieldMaybe' Value -> Parser URI
uriFromJSON Object
o Key
"x5u"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (\(Types.Base64X509 SignedCertificate
cert) -> SignedCertificate
cert) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"x5c")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"x5t"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"x5t#S256"
    ) forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall {m :: * -> *}. MonadFail m => JWK -> m JWK
checkKey
    where
    checkKey :: JWK -> m JWK
checkKey JWK
k
      | forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. JWK -> SignedCertificate -> Bool
certMatchesKey JWK
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
Data.List.NonEmpty.head) (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getter JWK (Maybe (NonEmpty SignedCertificate))
jwkX5c JWK
k)
        = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"X.509 cert in \"x5c\" param does not match key"
      | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure JWK
k

instance ToJSON JWK where
  toJSON :: JWK -> Value
toJSON JWK{Maybe [KeyOp]
Maybe (NonEmpty SignedCertificate)
Maybe Text
Maybe URI
Maybe Base64SHA256
Maybe Base64SHA1
Maybe JWKAlg
Maybe KeyUse
KeyMaterial
_jwkX5tS256 :: Maybe Base64SHA256
_jwkX5t :: Maybe Base64SHA1
_jwkX5cRaw :: Maybe (NonEmpty SignedCertificate)
_jwkX5u :: Maybe URI
_jwkKid :: Maybe Text
_jwkAlg :: Maybe JWKAlg
_jwkKeyOps :: Maybe [KeyOp]
_jwkUse :: Maybe KeyUse
_jwkMaterial :: KeyMaterial
_jwkX5tS256 :: JWK -> Maybe Base64SHA256
_jwkX5t :: JWK -> Maybe Base64SHA1
_jwkX5cRaw :: JWK -> Maybe (NonEmpty SignedCertificate)
_jwkX5u :: JWK -> Maybe URI
_jwkKid :: JWK -> Maybe Text
_jwkAlg :: JWK -> Maybe JWKAlg
_jwkKeyOps :: JWK -> Maybe [KeyOp]
_jwkUse :: JWK -> Maybe KeyUse
_jwkMaterial :: JWK -> KeyMaterial
..} = [Pair] -> Value -> Value
Types.insertManyToObject [Pair]
kvs (forall a. ToJSON a => a -> Value
toJSON KeyMaterial
_jwkMaterial)
    where
      kvs :: [Pair]
kvs = forall a. [Maybe a] -> [a]
catMaybes
        [ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"alg" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) Maybe JWKAlg
_jwkAlg
        , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"use" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) Maybe KeyUse
_jwkUse
        , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"key_ops" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) Maybe [KeyOp]
_jwkKeyOps
        , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"kid" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) Maybe Text
_jwkKid
        , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"x5u" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) (URI -> Value
uriToJSON forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe URI
_jwkX5u)
        , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Key
"x5c" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SignedCertificate -> Base64X509
Types.Base64X509) Maybe (NonEmpty SignedCertificate)
_jwkX5cRaw
        , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"x5t" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) Maybe Base64SHA1
_jwkX5t
        , forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Key
"x5t#S256" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) Maybe Base64SHA256
_jwkX5tS256
        ]

-- | Generate a JWK.  Apart from key parameters, no other parameters are set.
--
genJWK :: MonadRandom m => KeyMaterialGenParam -> m JWK
genJWK :: forall (m :: * -> *). MonadRandom m => KeyMaterialGenParam -> m JWK
genJWK KeyMaterialGenParam
p = KeyMaterial -> JWK
fromKeyMaterial forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadRandom m =>
KeyMaterialGenParam -> m KeyMaterial
genKeyMaterial KeyMaterialGenParam
p

fromKeyMaterial :: KeyMaterial -> JWK
fromKeyMaterial :: KeyMaterial -> JWK
fromKeyMaterial KeyMaterial
k = KeyMaterial
-> Maybe KeyUse
-> Maybe [KeyOp]
-> Maybe JWKAlg
-> Maybe Text
-> Maybe URI
-> Maybe (NonEmpty SignedCertificate)
-> Maybe Base64SHA1
-> Maybe Base64SHA256
-> JWK
JWK KeyMaterial
k forall a. Maybe a
z forall a. Maybe a
z forall a. Maybe a
z forall a. Maybe a
z forall a. Maybe a
z forall a. Maybe a
z forall a. Maybe a
z forall a. Maybe a
z where z :: Maybe a
z = forall a. Maybe a
Nothing


-- | Convert RSA private key into a JWK
--
fromRSA :: RSA.PrivateKey -> JWK
fromRSA :: PrivateKey -> JWK
fromRSA = KeyMaterial -> JWK
fromKeyMaterial forall b c a. (b -> c) -> (a -> b) -> a -> c
. RSAKeyParameters -> KeyMaterial
RSAKeyMaterial forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrivateKey -> RSAKeyParameters
toRSAKeyParameters

-- | Convert an RSA public key into a JWK
--
fromRSAPublic :: RSA.PublicKey -> JWK
fromRSAPublic :: PublicKey -> JWK
fromRSAPublic = KeyMaterial -> JWK
fromKeyMaterial forall b c a. (b -> c) -> (a -> b) -> a -> c
. RSAKeyParameters -> KeyMaterial
RSAKeyMaterial forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicKey -> RSAKeyParameters
toRSAPublicKeyParameters

-- | Convert an EC public key into a JWK
--
fromECPublic :: (AsError e, MonadError e m) => X509.PubKeyEC -> m JWK
fromECPublic :: forall e (m :: * -> *).
(AsError e, MonadError e m) =>
PubKeyEC -> m JWK
fromECPublic = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (KeyMaterial -> JWK
fromKeyMaterial forall b c a. (b -> c) -> (a -> b) -> a -> c
. ECKeyParameters -> KeyMaterial
ECKeyMaterial) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *).
(MonadError e m, AsError e) =>
PubKeyEC -> m ECKeyParameters
ecParametersFromX509


-- | Convert octet string into a JWK
--
fromOctets :: Cons s s Word8 Word8 => s -> JWK
fromOctets :: forall s. Cons s s Word8 Word8 => s -> JWK
fromOctets =
  KeyMaterial -> JWK
fromKeyMaterial forall b c a. (b -> c) -> (a -> b) -> a -> c
. OctKeyParameters -> KeyMaterial
OctKeyMaterial forall b c a. (b -> c) -> (a -> b) -> a -> c
. Base64Octets -> OctKeyParameters
OctKeyParameters forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Base64Octets
Types.Base64Octets
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s1 a s2.
(Cons s1 s1 a a, Cons s2 s2 a a, AsEmpty s2) =>
Getter s1 s2
recons
{-# INLINE fromOctets #-}


-- | Convert an X.509 certificate into a JWK.
--
-- Supports RSA and ECDSA (when the curve is supported).  Other key types
-- will throw 'AlgorithmNotImplemented'.
--
-- The @"x5c"@ field of the resulting JWK contains the certificate.
--
fromX509Certificate
  :: (AsError e, MonadError e m)
  => X509.SignedCertificate -> m JWK
fromX509Certificate :: forall e (m :: * -> *).
(AsError e, MonadError e m) =>
SignedCertificate -> m JWK
fromX509Certificate SignedCertificate
cert = do
  JWK
k <- case (Certificate -> PubKey
X509.certPubKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Show a, Eq a, ASN1Object a) => Signed a -> a
X509.signedObject forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Show a, Eq a, ASN1Object a) => SignedExact a -> Signed a
X509.getSigned) SignedCertificate
cert of
    X509.PubKeyRSA PublicKey
k -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (PublicKey -> JWK
fromRSAPublic PublicKey
k)
    X509.PubKeyEC PubKeyEC
k -> forall e (m :: * -> *).
(AsError e, MonadError e m) =>
PubKeyEC -> m JWK
fromECPublic PubKeyEC
k
    PubKey
_ -> forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing forall r. AsError r => Prism' r Text
_KeyMismatch Text
"X.509 key type not supported"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ JWK
k forall a b. a -> (a -> b) -> b
& forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' JWK (Maybe (NonEmpty SignedCertificate))
jwkX5cRaw (forall a. a -> Maybe a
Just (forall (f :: * -> *) a. Applicative f => a -> f a
pure SignedCertificate
cert))

fromX509CertificateMaybe :: X509.SignedCertificate -> Maybe JWK
fromX509CertificateMaybe :: SignedCertificate -> Maybe JWK
fromX509CertificateMaybe = Either Error JWK -> Maybe JWK
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Except e a -> Either e a
runExcept forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *).
(AsError e, MonadError e m) =>
SignedCertificate -> m JWK
fromX509Certificate
  where
    f :: Either Error JWK -> Maybe JWK
    f :: Either Error JWK -> Maybe JWK
f (Left Error
_) = forall a. Maybe a
Nothing
    f (Right JWK
jwk) = forall a. a -> Maybe a
Just JWK
jwk


instance AsPublicKey JWK where
  asPublicKey :: Getter JWK (Maybe JWK)
asPublicKey = forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (Lens' JWK KeyMaterial
jwkMaterial (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall k. AsPublicKey k => Getter k (Maybe k)
asPublicKey))


-- | RFC 7517 §5.  JWK Set Format
--
newtype JWKSet = JWKSet [JWK] deriving (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, 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)

instance FromJSON JWKSet where
  parseJSON :: Value -> Parser JWKSet
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"JWKSet" (\Object
o -> [JWK] -> JWKSet
JWKSet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"keys")

instance ToJSON JWKSet where
  toJSON :: JWKSet -> Value
toJSON (JWKSet [JWK]
ks) = [Pair] -> Value
object [Key
"keys" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON [JWK]
ks]


-- | Sanity-check a JWK.
--
-- Return an appropriate error if the key is size is too small to be
-- used with any JOSE algorithm, or for other problems that mean the
-- key cannot be used.
--
checkJWK :: (MonadError e m, AsError e) => JWK -> m ()
checkJWK :: forall e (m :: * -> *). (MonadError e m, AsError e) => JWK -> m ()
checkJWK JWK
jwk = case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' JWK KeyMaterial
jwkMaterial JWK
jwk of
  RSAKeyMaterial (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' RSAKeyParameters Base64Integer
rsaN -> Types.Base64Integer Integer
n)
    | Integer
n forall a. Ord a => a -> a -> Bool
>= Integer
2 forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
2040 :: Integer) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    | Bool
otherwise -> forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing forall r. AsError r => Prism' r ()
_KeySizeTooSmall ()
  OctKeyMaterial (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Iso' OctKeyParameters Base64Octets
octK -> Types.Base64Octets ByteString
k)
    | ByteString -> Int
B.length ByteString
k forall a. Ord a => a -> a -> Bool
>= Int
256 forall a. Integral a => a -> a -> a
`div` Int
8 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    | Bool
otherwise -> forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing forall r. AsError r => Prism' r ()
_KeySizeTooSmall ()
  KeyMaterial
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | Choose the cryptographically strongest JWS algorithm for a
-- given key.  The JWK "alg" algorithm parameter is ignored.
--
bestJWSAlg
  :: (MonadError e m, AsError e)
  => JWK
  -> m JWA.JWS.Alg
bestJWSAlg :: forall e (m :: * -> *). (MonadError e m, AsError e) => JWK -> m Alg
bestJWSAlg JWK
jwk = case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' JWK KeyMaterial
jwkMaterial JWK
jwk of
  ECKeyMaterial ECKeyParameters
k -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getter ECKeyParameters Crv
ecCrv ECKeyParameters
k of
    Crv
P_256 -> Alg
JWA.JWS.ES256
    Crv
P_384 -> Alg
JWA.JWS.ES384
    Crv
P_521 -> Alg
JWA.JWS.ES512
    Crv
Secp256k1 -> Alg
JWA.JWS.ES256K
  RSAKeyMaterial RSAKeyParameters
k ->
    let
      Types.Base64Integer Integer
n = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' RSAKeyParameters Base64Integer
rsaN RSAKeyParameters
k
    in
      if Integer
n forall a. Ord a => a -> a -> Bool
>= Integer
2 forall a b. (Num a, Integral b) => a -> b -> a
^ (Integer
2040 :: Integer)
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure Alg
JWA.JWS.PS512
      else forall e (m :: * -> *) x. MonadError e m => AReview e () -> m x
throwing_ forall r. AsError r => Prism' r ()
_KeySizeTooSmall
  OctKeyMaterial (OctKeyParameters (Types.Base64Octets ByteString
k))
    | ByteString -> Int
B.length ByteString
k forall a. Ord a => a -> a -> Bool
>= Int
512 forall a. Integral a => a -> a -> a
`div` Int
8 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Alg
JWA.JWS.HS512
    | ByteString -> Int
B.length ByteString
k forall a. Ord a => a -> a -> Bool
>= Int
384 forall a. Integral a => a -> a -> a
`div` Int
8 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Alg
JWA.JWS.HS384
    | ByteString -> Int
B.length ByteString
k forall a. Ord a => a -> a -> Bool
>= Int
256 forall a. Integral a => a -> a -> a
`div` Int
8 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Alg
JWA.JWS.HS256
    | Bool
otherwise -> forall e (m :: * -> *) x. MonadError e m => AReview e () -> m x
throwing_ forall r. AsError r => Prism' r ()
_KeySizeTooSmall
  OKPKeyMaterial OKPKeyParameters
k -> case OKPKeyParameters
k of
    (Ed25519Key PublicKey
_ Maybe SecretKey
_)  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Alg
JWA.JWS.EdDSA
    (Ed448Key PublicKey
_ Maybe SecretKey
_)    -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Alg
JWA.JWS.EdDSA
    (X25519Key PublicKey
_ Maybe SecretKey
_)   -> forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing forall r. AsError r => Prism' r Text
_KeyMismatch Text
"Cannot sign with X25519 key"
    (X448Key PublicKey
_ Maybe SecretKey
_)     -> forall e (m :: * -> *) t x.
MonadError e m =>
AReview e t -> t -> m x
throwing forall r. AsError r => Prism' r Text
_KeyMismatch Text
"Cannot sign with X448 key"


-- | Compute the JWK Thumbprint of a JWK
--
thumbprint :: HashAlgorithm a => Getter JWK (Digest a)
thumbprint :: forall a. HashAlgorithm a => Getter JWK (Digest a)
thumbprint = forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
hash forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. JWK -> ByteString
thumbprintRepr)

-- | Prism from ByteString to @HashAlgorithm a => Digest a@.
--
-- Use @'re' digest@ to view the bytes of a digest
--
digest :: HashAlgorithm a => Prism' B.ByteString (Digest a)
digest :: forall a. HashAlgorithm a => Prism' ByteString (Digest a)
digest = forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString

-- | JWK canonicalised for thumbprint computation
--
thumbprintRepr :: JWK -> L.ByteString
thumbprintRepr :: JWK -> ByteString
thumbprintRepr JWK
k = Builder -> ByteString
Builder.toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tag. Encoding' tag -> Builder
fromEncoding forall b c a. (b -> c) -> (a -> b) -> a -> c
. Series -> Encoding
pairs forall a b. (a -> b) -> a -> b
$
  case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' JWK KeyMaterial
jwkMaterial JWK
k of
    ECKeyMaterial ECKeyParameters
k' -> Key
"crv" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=
      forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getter ECKeyParameters Crv
ecCrv ECKeyParameters
k'
      forall a. Semigroup a => a -> a -> a
<> Key
"kty" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"EC" :: T.Text)
      forall a. Semigroup a => a -> a -> a
<> Key
"x" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getter ECKeyParameters SizedBase64Integer
ecX ECKeyParameters
k'
      forall a. Semigroup a => a -> a -> a
<> Key
"y" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getter ECKeyParameters SizedBase64Integer
ecY ECKeyParameters
k'
    RSAKeyMaterial RSAKeyParameters
k' ->
      Key
"e" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' RSAKeyParameters Base64Integer
rsaE RSAKeyParameters
k' forall a. Semigroup a => a -> a -> a
<> Key
"kty" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"RSA" :: T.Text) forall a. Semigroup a => a -> a -> a
<> Key
"n" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' RSAKeyParameters Base64Integer
rsaN RSAKeyParameters
k'
    OctKeyMaterial (OctKeyParameters Base64Octets
k') ->
      Key
"k" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Base64Octets
k' forall a. Semigroup a => a -> a -> a
<> Key
"kty" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"oct" :: T.Text)
    OKPKeyMaterial (Ed25519Key PublicKey
pk Maybe SecretKey
_) -> forall {a} {a}.
(Semigroup a, KeyValue a, ByteArrayAccess a) =>
Text -> a -> a
okpSeries Text
"Ed25519" PublicKey
pk
    OKPKeyMaterial (Ed448Key PublicKey
pk Maybe SecretKey
_) -> forall {a} {a}.
(Semigroup a, KeyValue a, ByteArrayAccess a) =>
Text -> a -> a
okpSeries Text
"Ed448" PublicKey
pk
    OKPKeyMaterial (X25519Key PublicKey
pk Maybe SecretKey
_) -> forall {a} {a}.
(Semigroup a, KeyValue a, ByteArrayAccess a) =>
Text -> a -> a
okpSeries Text
"X25519" PublicKey
pk
    OKPKeyMaterial (X448Key PublicKey
pk Maybe SecretKey
_) -> forall {a} {a}.
(Semigroup a, KeyValue a, ByteArrayAccess a) =>
Text -> a -> a
okpSeries Text
"X448" PublicKey
pk
  where
    b64 :: a -> Base64Octets
b64 = ByteString -> Base64Octets
Types.Base64Octets forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert
    okpSeries :: Text -> a -> a
okpSeries Text
crv a
pk =
      Key
"crv" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
crv :: T.Text) forall a. Semigroup a => a -> a -> a
<> Key
"kty" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"OKP" :: T.Text) forall a. Semigroup a => a -> a -> a
<> Key
"x" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall {a}. ByteArrayAccess a => a -> Base64Octets
b64 a
pk