diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,21 @@ # ChangeLog for hpke +## 0.3.0 + +* A receiver authenticates a sender by its **public** key. `setupBaseR`, + `setupPSKR` and `setupR` took the sender's secret key for the + authenticated modes and derived the public one from it; RFC 9180 section + 4.1 is `AuthDecap(enc, skR, pkS)`, and a receiver has only the public one. + As it stood, `mode_auth` and `mode_auth_psk` could not be used by a real + receiver. **Breaking**: those three now take a `Maybe EncodedPublicKey`. +* DHKEM is an instance of crypton's `Crypto.KEM.KEM`, in the new + `Crypto.HPKE.DHKEM`, with one type per suite RFC 9180 registers. + `setupS` and `setupR` go through the class rather than reaching for the + group directly. +* `toPublicKey` gives the public key that goes with a secret key, for the + `KEM_ID` named. +* The lower bound on crypton moves to 2.1.8, which is where `Crypto.KEM` is. + ## 0.2.1 * `Show EncodedSecretKey` no longer prints the key. `Show` is what `print`, diff --git a/Crypto/HPKE/DHKEM.hs b/Crypto/HPKE/DHKEM.hs new file mode 100644 --- /dev/null +++ b/Crypto/HPKE/DHKEM.hs @@ -0,0 +1,306 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | DHKEM as an instance of @crypton@'s 'KEM' class. +-- +-- RFC 9180 section 4.1 builds a key encapsulation mechanism out of a +-- Diffie-Hellman group: the exchange's output goes through HKDF with the +-- ephemeral and the recipient public keys as context, under labels that +-- name the ciphersuite. That construction, and not the bare exchange, is +-- what a KEM is, which is why @crypton@ has the class and no instance for +-- the groups themselves. +-- +-- There is one type per suite RFC 9180 registers, and no way to spell +-- anything else. The group does not pick the suite on its own -- the hash +-- and the registered code point are part of what the shared secret is +-- derived from -- but the registry lists each group exactly once, so +-- naming the group names all three. +-- +-- The instance is here rather than in @crypton@ because those labels carry +-- the HPKE ciphersuite identifier and the protocol's own version string, +-- which is the same reason TLS 1.3's labelled HKDF lives in @tls@ rather +-- than in @crypton@. +-- +-- Only @Encap@ and @Decap@ are instance methods. DHKEM also has +-- @AuthEncap@ and @AuthDecap@, in that same section 4.1, where a static +-- sender key contributes a second Diffie-Hellman and its public key joins +-- the context; they take an argument the class has no room for, so they +-- are not here. 'Crypto.HPKE.setupBaseS' with a sender key is the way to +-- those, through the mode of section 5.1.3. +module Crypto.HPKE.DHKEM ( + -- * The suites RFC 9180 registers + DHKEM_P256, + DHKEM_P384, + DHKEM_P521, + DHKEM_X25519, + DHKEM_X448, + + -- * The classes they implement + KEM (..), + HPKEKEM (..), + SharedSecret (..), +) where + +import Crypto.ECC ( + Curve_P256R1, + Curve_P384R1, + Curve_P521R1, + Curve_X25519, + Curve_X448, + EllipticCurve (..), + EllipticCurveDH (..), + KeyPair (..), + ) +import Crypto.Error (CryptoError (..)) +import Crypto.KEM (KEM (..)) +import Crypto.Random (MonadRandom) +import Data.Kind (Type) + +import Crypto.HPKE.ID +import Crypto.HPKE.KDF +import Crypto.HPKE.KEM +import Crypto.HPKE.PublicKey +import Crypto.HPKE.Types + +---------------------------------------------------------------- + +-- | DHKEM(P-256, HKDF-SHA256). +data DHKEM_P256 + +-- | DHKEM(P-384, HKDF-SHA384). +data DHKEM_P384 + +-- | DHKEM(P-521, HKDF-SHA512). +data DHKEM_P521 + +-- | DHKEM(X25519, HKDF-SHA256). +data DHKEM_X25519 + +-- | DHKEM(X448, HKDF-SHA512). +data DHKEM_X448 + +---------------------------------------------------------------- + +-- What a registered suite is made of. Not exported: it exists so that the +-- five instances below are five names rather than five copies of the same +-- code, and a sixth suite would be a line here and not a design. +class + ( EllipticCurve (HPKEKEMGroup kem) + , EllipticCurveDH (HPKEKEMGroup kem) + , HashAlgorithm (HPKEKEMHash kem) + , KDF (HPKEKEMHash kem) + ) => + HPKEKEMRegistered kem + where + type HPKEKEMGroup kem :: Type + type HPKEKEMHash kem :: Type + hpkeKEMID :: proxy kem -> KEM_ID + hpkeKEMHash :: proxy kem -> HPKEKEMHash kem + +{- FOURMOLU_DISABLE -} +instance HPKEKEMRegistered DHKEM_P256 where + type HPKEKEMGroup DHKEM_P256 = Curve_P256R1 + type HPKEKEMHash DHKEM_P256 = SHA256 + hpkeKEMID _ = DHKEM_P256_HKDF_SHA256 + hpkeKEMHash _ = SHA256 + +instance HPKEKEMRegistered DHKEM_P384 where + type HPKEKEMGroup DHKEM_P384 = Curve_P384R1 + type HPKEKEMHash DHKEM_P384 = SHA384 + hpkeKEMID _ = DHKEM_P384_HKDF_SHA384 + hpkeKEMHash _ = SHA384 + +instance HPKEKEMRegistered DHKEM_P521 where + type HPKEKEMGroup DHKEM_P521 = Curve_P521R1 + type HPKEKEMHash DHKEM_P521 = SHA512 + hpkeKEMID _ = DHKEM_P521_HKDF_SHA512 + hpkeKEMHash _ = SHA512 + +instance HPKEKEMRegistered DHKEM_X25519 where + type HPKEKEMGroup DHKEM_X25519 = Curve_X25519 + type HPKEKEMHash DHKEM_X25519 = SHA256 + hpkeKEMID _ = DHKEM_X25519_HKDF_SHA256 + hpkeKEMHash _ = SHA256 + +instance HPKEKEMRegistered DHKEM_X448 where + type HPKEKEMGroup DHKEM_X448 = Curve_X448 + type HPKEKEMHash DHKEM_X448 = SHA512 + hpkeKEMID _ = DHKEM_X448_HKDF_SHA512 + hpkeKEMHash _ = SHA512 +{- FOURMOLU_ENABLE -} + +---------------------------------------------------------------- + +-- | The keys and the encapsulated value are the serialized forms of RFC +-- 9180 section 4, which is what travels and what this package's other +-- entry points already speak. The coins are the sender's ephemeral secret +-- key, @skE@, which is what the appendix A vectors fix. +instance KEM DHKEM_P256 where + type EncapsulationKey DHKEM_P256 = EncodedPublicKey + type DecapsulationKey DHKEM_P256 = EncodedSecretKey + type Ciphertext DHKEM_P256 = EncodedPublicKey + type Coins DHKEM_P256 = EncodedSecretKey + generateKeyPair = dhkemGenerateKeyPair + encapsulate = dhkemEncapsulate + encapsulateWith = dhkemEncapsulateWith + decapsulate = dhkemDecapsulate + +instance KEM DHKEM_P384 where + type EncapsulationKey DHKEM_P384 = EncodedPublicKey + type DecapsulationKey DHKEM_P384 = EncodedSecretKey + type Ciphertext DHKEM_P384 = EncodedPublicKey + type Coins DHKEM_P384 = EncodedSecretKey + generateKeyPair = dhkemGenerateKeyPair + encapsulate = dhkemEncapsulate + encapsulateWith = dhkemEncapsulateWith + decapsulate = dhkemDecapsulate + +instance KEM DHKEM_P521 where + type EncapsulationKey DHKEM_P521 = EncodedPublicKey + type DecapsulationKey DHKEM_P521 = EncodedSecretKey + type Ciphertext DHKEM_P521 = EncodedPublicKey + type Coins DHKEM_P521 = EncodedSecretKey + generateKeyPair = dhkemGenerateKeyPair + encapsulate = dhkemEncapsulate + encapsulateWith = dhkemEncapsulateWith + decapsulate = dhkemDecapsulate + +instance KEM DHKEM_X25519 where + type EncapsulationKey DHKEM_X25519 = EncodedPublicKey + type DecapsulationKey DHKEM_X25519 = EncodedSecretKey + type Ciphertext DHKEM_X25519 = EncodedPublicKey + type Coins DHKEM_X25519 = EncodedSecretKey + generateKeyPair = dhkemGenerateKeyPair + encapsulate = dhkemEncapsulate + encapsulateWith = dhkemEncapsulateWith + decapsulate = dhkemDecapsulate + +instance KEM DHKEM_X448 where + type EncapsulationKey DHKEM_X448 = EncodedPublicKey + type DecapsulationKey DHKEM_X448 = EncodedSecretKey + type Ciphertext DHKEM_X448 = EncodedPublicKey + type Coins DHKEM_X448 = EncodedSecretKey + generateKeyPair = dhkemGenerateKeyPair + encapsulate = dhkemEncapsulate + encapsulateWith = dhkemEncapsulateWith + decapsulate = dhkemDecapsulate + +---------------------------------------------------------------- + +-- | DHKEM has all four operations of RFC 9180 section 4.1, so the +-- authenticated pair is defined rather than left to refuse. +instance HPKEKEM DHKEM_P256 where + authEncapWith = dhkemAuthEncapWith + authDecap = dhkemAuthDecap + toEncapsulationKey = dhkemToEncapsulationKey + +instance HPKEKEM DHKEM_P384 where + authEncapWith = dhkemAuthEncapWith + authDecap = dhkemAuthDecap + toEncapsulationKey = dhkemToEncapsulationKey + +instance HPKEKEM DHKEM_P521 where + authEncapWith = dhkemAuthEncapWith + authDecap = dhkemAuthDecap + toEncapsulationKey = dhkemToEncapsulationKey + +instance HPKEKEM DHKEM_X25519 where + authEncapWith = dhkemAuthEncapWith + authDecap = dhkemAuthDecap + toEncapsulationKey = dhkemToEncapsulationKey + +instance HPKEKEM DHKEM_X448 where + authEncapWith = dhkemAuthEncapWith + authDecap = dhkemAuthDecap + toEncapsulationKey = dhkemToEncapsulationKey + +---------------------------------------------------------------- + +dhkemAuthEncapWith + :: HPKEKEMRegistered kem + => proxy kem + -> EncodedSecretKey + -> EncodedPublicKey + -> EncodedSecretKey + -> Either HPKEError (EncodedPublicKey, SharedSecret) +dhkemAuthEncapWith p skSm pkRm skEm = + flop <$> encapEnv (groupOf p) (deriveOf p) skEm (Just skSm) pkRm + +dhkemAuthDecap + :: HPKEKEMRegistered kem + => proxy kem + -> EncodedPublicKey + -> EncodedSecretKey + -> EncodedPublicKey + -> Either HPKEError SharedSecret +dhkemAuthDecap p pkSm skRm enc = + decapEnv (groupOf p) (deriveOf p) skRm (Just pkSm) enc + +dhkemToEncapsulationKey + :: HPKEKEMRegistered kem + => proxy kem -> EncodedSecretKey -> Either HPKEError EncodedPublicKey +dhkemToEncapsulationKey p skm = + serializePublicKey g . scalarToPoint g <$> deserializeSecretKey g skm + where + g = groupOf p + +flop :: (SharedSecret, EncodedPublicKey) -> (EncodedPublicKey, SharedSecret) +flop (ss, enc) = (enc, ss) + +---------------------------------------------------------------- + +dhkemGenerateKeyPair + :: (HPKEKEMRegistered kem, MonadRandom m) + => proxy kem -> m (EncodedPublicKey, EncodedSecretKey) +dhkemGenerateKeyPair p = do + KeyPair pk sk <- curveGenerateKeyPair g + return (serializePublicKey g pk, serializeSecretKey g sk) + where + g = groupOf p + +dhkemEncapsulate + :: (HPKEKEMRegistered kem, MonadRandom m) + => proxy kem + -> EncodedPublicKey + -> m (CryptoFailable (EncodedPublicKey, SharedSecret)) +dhkemEncapsulate p pkRm = + dhkemEncapsulateWith p pkRm . snd <$> dhkemGenerateKeyPair p + +dhkemEncapsulateWith + :: HPKEKEMRegistered kem + => proxy kem + -> EncodedPublicKey + -> EncodedSecretKey + -> CryptoFailable (EncodedPublicKey, SharedSecret) +dhkemEncapsulateWith p pkRm skEm = + toCryptoFailable $ flop <$> encapEnv (groupOf p) (deriveOf p) skEm Nothing pkRm + +dhkemDecapsulate + :: HPKEKEMRegistered kem + => proxy kem + -> EncodedSecretKey + -> EncodedPublicKey + -> CryptoFailable SharedSecret +dhkemDecapsulate p skRm enc = + toCryptoFailable $ decapEnv (groupOf p) (deriveOf p) skRm Nothing enc + +---------------------------------------------------------------- + +groupOf :: proxy kem -> Proxy (HPKEKEMGroup kem) +groupOf _ = Proxy + +deriveOf :: forall proxy kem. HPKEKEMRegistered kem => proxy kem -> KeyDeriveFunction +deriveOf p = extractAndExpand (hpkeKEMHash p) (suiteKEM (hpkeKEMID p)) + +-- | The class answers with a 'CryptoFailable', which carries a reason from +-- a fixed list and not a message. What is lost is the string; what each +-- error means is kept. 'Crypto.HPKE.setupBaseS' and its neighbours still +-- throw the 'HPKEError' with its message. +toCryptoFailable :: Either HPKEError a -> CryptoFailable a +toCryptoFailable (Right a) = CryptoPassed a +toCryptoFailable (Left e) = CryptoFailed $ case e of + DeserializeError _ -> CryptoError_PointFormatInvalid + EncapError _ -> CryptoError_ScalarMultiplicationInvalid + DecapError _ -> CryptoError_ScalarMultiplicationInvalid + _ -> CryptoError_ParameterInvalid diff --git a/Crypto/HPKE/ID.hs b/Crypto/HPKE/ID.hs --- a/Crypto/HPKE/ID.hs +++ b/Crypto/HPKE/ID.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} module Crypto.HPKE.ID ( @@ -18,30 +19,15 @@ DHKEM_X448_HKDF_SHA512, .. ), - defaultKEMMap, - KEMGroup (..), - -- - HPKEMap (..), - defaultHPKEMap, + suiteKEM, ) where import Crypto.Cipher.AES (AES128, AES256) import Crypto.Cipher.ChaChaPoly1305 (ChaCha20Poly1305) -import Crypto.ECC ( - Curve_P256R1, - Curve_P384R1, - Curve_P521R1, - Curve_X25519, - Curve_X448, - EllipticCurve (..), - EllipticCurveDH (..), - ) -import Data.Proxy (Proxy (..)) -import Data.Word (Word16) -import Text.Printf (printf) import Crypto.HPKE.AEAD import Crypto.HPKE.KDF +import Crypto.HPKE.Types ---------------------------------------------------------------- @@ -141,43 +127,10 @@ ---------------------------------------------------------------- -{- FOURMOLU_DISABLE -} -p256 :: Proxy Curve_P256R1 -p256 = Proxy :: Proxy Curve_P256R1 -p384 :: Proxy Curve_P384R1 -p384 = Proxy :: Proxy Curve_P384R1 -p521 :: Proxy Curve_P521R1 -p521 = Proxy :: Proxy Curve_P521R1 -x25519 :: Proxy Curve_X25519 -x25519 = Proxy :: Proxy Curve_X25519 -x448 :: Proxy Curve_X448 -x448 = Proxy :: Proxy Curve_X448 - -data KEMGroup - = forall c. (EllipticCurve c, EllipticCurveDH c) => KEMGroup (Proxy c) - -defaultKEMMap :: [(KEM_ID, (KEMGroup, KDFHash))] -defaultKEMMap = - [ (DHKEM_P256_HKDF_SHA256, (KEMGroup p256, KDFHash SHA256)) - , (DHKEM_P384_HKDF_SHA384, (KEMGroup p384, KDFHash SHA384)) - , (DHKEM_P521_HKDF_SHA512, (KEMGroup p521, KDFHash SHA512)) - , (DHKEM_X25519_HKDF_SHA256, (KEMGroup x25519, KDFHash SHA256)) - , (DHKEM_X448_HKDF_SHA512, (KEMGroup x448, KDFHash SHA512)) - ] -{- FOURMOLU_ENABLE -} - ----------------------------------------------------------------- - -data HPKEMap = HPKEMap - { kemMap :: [(KEM_ID, (KEMGroup, KDFHash))] - , kdfMap :: [(KDF_ID, KDFHash)] - , cipherMap :: [(AEAD_ID, AEADCipher)] - } - -defaultHPKEMap :: HPKEMap -defaultHPKEMap = - HPKEMap - { kemMap = defaultKEMMap - , kdfMap = defaultKDFMap - , cipherMap = defaultAEADMap - } +-- | The @suite_id@ of RFC 9180 section 4.1, which goes into every label the +-- KEM derives under. This is what ties a DHKEM to its registered code +-- point rather than to its group and hash alone. +suiteKEM :: KEM_ID -> Suite +suiteKEM kem_id = "KEM" <> i + where + i = i2ospOf_ 2 $ fromIntegral $ fromKEM_ID kem_id diff --git a/Crypto/HPKE/Internal.hs b/Crypto/HPKE/Internal.hs --- a/Crypto/HPKE/Internal.hs +++ b/Crypto/HPKE/Internal.hs @@ -6,13 +6,14 @@ setupR, -- * Unified types - KEMGroup (..), + KEMAlg (..), KDFHash (..), AEADCipher (..), -- * API Aead (..), KDF (..), + HPKEKEM (..), -- * Types Mode (..), @@ -28,12 +29,15 @@ -- * Generating key pair genKeyPair, + toPublicKey, ) where import Crypto.HPKE.AEAD import Crypto.HPKE.ID import Crypto.HPKE.KDF +import Crypto.HPKE.KEM import Crypto.HPKE.KeyPair +import Crypto.HPKE.Map import Crypto.HPKE.KeySchedule import Crypto.HPKE.PublicKey import Crypto.HPKE.Setup diff --git a/Crypto/HPKE/KDF.hs b/Crypto/HPKE/KDF.hs --- a/Crypto/HPKE/KDF.hs +++ b/Crypto/HPKE/KDF.hs @@ -12,7 +12,6 @@ ) where -import Crypto.Hash.IO (hashDigestSize) import Crypto.Hash.Algorithms ( HashAlgorithm, SHA256 (..), diff --git a/Crypto/HPKE/KEM.hs b/Crypto/HPKE/KEM.hs --- a/Crypto/HPKE/KEM.hs +++ b/Crypto/HPKE/KEM.hs @@ -1,64 +1,121 @@ +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Crypto.HPKE.KEM ( - encapGen, + HPKEKEM (..), + KEMAlg (..), encapEnv, decapEnv, - genKeyPairP, ) where -import qualified Control.Exception as E import Crypto.ECC ( EllipticCurve (..), EllipticCurveDH (..), - KeyPair (..), ) -import Crypto.Random (drgNew, withDRG) +import Crypto.KEM (KEM (..)) +import Crypto.Random (MonadRandom) import Crypto.HPKE.PublicKey import Crypto.HPKE.Types ---------------------------------------------------------------- +-- | What HPKE needs of a KEM beyond what @crypton@'s 'KEM' class says. +-- +-- RFC 9180 section 4.1 gives DHKEM four operations and the class has room +-- for two: @Encap@ is 'encapsulate', @Decap@ is 'decapsulate'. @AuthEncap@ +-- and @AuthDecap@ take a static sender key, which the class has no argument +-- for, so they are here. They default to refusing, which is what a KEM +-- with no authenticated mode -- any post-quantum one -- should do. +-- +-- The equalities pin the four associated types to the serialized forms of +-- section 4, which is what travels and what this package's entry points +-- take, so that 'Crypto.HPKE.setupS' can be written once for every KEM. +class + ( KEM kem + , EncapsulationKey kem ~ EncodedPublicKey + , DecapsulationKey kem ~ EncodedSecretKey + , Ciphertext kem ~ EncodedPublicKey + , Coins kem ~ EncodedSecretKey + ) => + HPKEKEM kem + where + -- | Draw what 'encapsulate' would have drawn, so that the + -- authenticated forms can generate their ephemeral key the same way. + -- + -- For every KEM here the coins are a secret key, so the default is to + -- draw a key pair and keep the half that is one. + generateCoins :: MonadRandom m => proxy kem -> m EncodedSecretKey + generateCoins p = snd `fmap` generateKeyPair p + + -- | @AuthEncap@ of section 4.1, with the ephemeral key supplied. + authEncapWith + :: proxy kem + -> EncodedSecretKey + -- ^ @skS@, the sender's static key + -> EncodedPublicKey + -- ^ @pkR@ + -> EncodedSecretKey + -- ^ @skE@ + -> Either HPKEError (EncodedPublicKey, SharedSecret) + authEncapWith _ _ _ _ = Left $ Unsupported "authenticated mode" + + -- | @AuthDecap@ of section 4.1. The sender is named by its public + -- key: a receiver does not have the other side's secret key, and + -- asking for one would be asking for the wrong thing. + authDecap + :: proxy kem + -> EncodedPublicKey + -- ^ @pkS@, the sender's static public key + -> EncodedSecretKey + -- ^ @skR@ + -> EncodedPublicKey + -- ^ @enc@ + -> Either HPKEError SharedSecret + authDecap _ _ _ _ = Left $ Unsupported "authenticated mode" + + -- | The encapsulation key a decapsulation key belongs to. + toEncapsulationKey + :: proxy kem -> EncodedSecretKey -> Either HPKEError EncodedPublicKey + +-- | A KEM that HPKE can run over, with its identity forgotten, for the +-- table that turns a @KEM_ID@ into one. +data KEMAlg = forall kem. HPKEKEM kem => KEMAlg (Proxy kem) + +---------------------------------------------------------------- + +-- | @Encap@ and @AuthEncap@ of RFC 9180 section 4.1, with the ephemeral key +-- supplied. +-- +-- Written out the same way 'decap' is: what it needs are the ephemeral key, +-- the sender's static key if the mode is authenticated, and the recipient's +-- public key. encap :: (EllipticCurve group, EllipticCurveDH group) - => Env group + => Proxy group + -> KeyDeriveFunction + -> SecretKey group + -> Maybe (SecretKey group) -> Encap -encap Env{..} enc0@(EncodedPublicKey pkRm) = do - pkR <- deserializePublicKey envProxy enc0 - let skE = envSecretKey - dh0 <- ecdh' envProxy skE pkR $ EncapError "encap" - (dh, pkSm) <- case envAuthKey of +encap proxy derive skE mskS enc0@(EncodedPublicKey pkRm) = do + pkR <- deserializePublicKey proxy enc0 + dh0 <- ecdh' proxy skE pkR $ EncapError "encap" + (dh, pkSm) <- case mskS of Nothing -> return (dh0, "") Just skS -> do - let pkS = scalarToPoint envProxy skS - dh1 <- ecdh' envProxy skS pkR $ EncapError "encap" - let EncodedPublicKey pk = serializePublicKey envProxy pkS + let pkS = scalarToPoint proxy skS + dh1 <- ecdh' proxy skS pkR $ EncapError "encap" + let EncodedPublicKey pk = serializePublicKey proxy pkS return (dh0 <> dh1, pk) - let pkE = scalarToPoint envProxy skE - let enc@(EncodedPublicKey pkEm) = serializePublicKey envProxy pkE + let pkE = scalarToPoint proxy skE + let enc@(EncodedPublicKey pkEm) = serializePublicKey proxy pkE kem_context = pkEm <> pkRm <> pkSm - shared_secret = SharedSecret $ convert $ envDerive dh kem_context + shared_secret = SharedSecret $ convert $ derive dh kem_context return (shared_secret, enc) -encapGen - :: (EllipticCurve group, EllipticCurveDH group) - => Proxy group - -> KeyDeriveFunction - -> Maybe EncodedSecretKey - -> IO Encap -encapGen proxy derive mskSm = do - mskS <- case mskSm of - Nothing -> return $ Nothing - Just skSm -> case deserializeSecretKey proxy skSm of - Left err -> E.throwIO err - Right x -> return $ Just x - env <- genEnv proxy derive mskS - return $ encap env - encapEnv :: (EllipticCurve group, EllipticCurveDH group) => Proxy group @@ -66,32 +123,37 @@ -> EncodedSecretKey -> Maybe EncodedSecretKey -> Encap -encapEnv proxy derive skRm skSm enc = do - env <- newEnvDeserialize proxy derive skRm skSm - encap env enc +encapEnv proxy derive skEm mskSm enc = do + skE <- deserializeSecretKey proxy skEm + mskS <- traverse (deserializeSecretKey proxy) mskSm + encap proxy derive skE mskS enc ---------------------------------------------------------------- +-- | @Decap@ and @AuthDecap@ of RFC 9180 section 4.1. +-- +-- The sender is named by its public key, because that is all a receiver +-- has: @AuthDecap(enc, skR, pkS)@. decap :: (EllipticCurve group, EllipticCurveDH group) - => Env group + => Proxy group + -> KeyDeriveFunction + -> SecretKey group + -> Maybe (PublicKey group) -> Decap -decap Env{..} enc@(EncodedPublicKey pkEm) = do - pkE <- deserializePublicKey envProxy enc - let skR = envSecretKey - dh0 <- ecdh' envProxy skR pkE $ DecapError "decap" - (dh, pkSm) <- case envAuthKey of +decap proxy derive skR mpkS enc@(EncodedPublicKey pkEm) = do + pkE <- deserializePublicKey proxy enc + dh0 <- ecdh' proxy skR pkE $ DecapError "decap" + (dh, pkSm) <- case mpkS of Nothing -> return (dh0, "") - Just skS -> do - let pkS = scalarToPoint envProxy skS - dh1 <- ecdh' envProxy skR pkS $ EncapError "decap" - let EncodedPublicKey pk = serializePublicKey envProxy pkS + Just pkS -> do + dh1 <- ecdh' proxy skR pkS $ DecapError "decap" + let EncodedPublicKey pk = serializePublicKey proxy pkS return (dh0 <> dh1, pk) - - let pkR = scalarToPoint envProxy skR - let EncodedPublicKey pkRm = serializePublicKey envProxy pkR + let pkR = scalarToPoint proxy skR + let EncodedPublicKey pkRm = serializePublicKey proxy pkR kem_context = pkEm <> pkRm <> pkSm - shared_secret = SharedSecret $ convert $ envDerive dh kem_context + shared_secret = SharedSecret $ convert $ derive dh kem_context return shared_secret decapEnv @@ -99,77 +161,12 @@ => Proxy group -> KeyDeriveFunction -> EncodedSecretKey - -> Maybe EncodedSecretKey + -> Maybe EncodedPublicKey -> Decap -decapEnv proxy derive skRm mskSm enc = do - env <- newEnvDeserialize proxy derive skRm mskSm - decap env enc - ----------------------------------------------------------------- - -{- FOURMOLU_DISABLE -} -data Env group = Env - { envSecretKey :: SecretKey group - , envAuthKey :: Maybe (SecretKey group) - , envProxy :: Proxy group - , envDerive :: KeyDeriveFunction - } -{- FOURMOLU_ENABLE -} - ----------------------------------------------------------------- - -newEnv - :: forall group - . EllipticCurve group - => KeyDeriveFunction - -> SecretKey group - -> Maybe (SecretKey group) - -> Env group -newEnv derive skR mskS = - Env - { envSecretKey = skR - , envAuthKey = mskS - , envProxy = proxy - , envDerive = derive - } - where - proxy = Proxy :: Proxy group - ----------------------------------------------------------------- - -genEnv - :: EllipticCurve group - => Proxy group - -> KeyDeriveFunction - -> Maybe (SecretKey group) - -> IO (Env group) -genEnv proxy derive mskS = do - (_, sk) <- genKeyPairP proxy - return $ newEnv derive sk mskS - -genKeyPairP - :: EllipticCurve curve - => proxy curve -> IO (Point curve, Scalar curve) -genKeyPairP proxy = do - gen <- drgNew - let (KeyPair pk sk, _) = withDRG gen $ curveGenerateKeyPair proxy - return (pk, sk) - ----------------------------------------------------------------- - -newEnvDeserialize - :: EllipticCurve group - => Proxy group - -> KeyDeriveFunction - -> EncodedSecretKey - -> Maybe EncodedSecretKey - -> Either HPKEError (Env group) -newEnvDeserialize proxy derive skRm mskSm = do +decapEnv proxy derive skRm mpkSm enc = do skR <- deserializeSecretKey proxy skRm - mskS <- case mskSm of - Nothing -> Right $ Nothing - Just skSm -> Just <$> deserializeSecretKey proxy skSm - return $ newEnv derive skR mskS + mpkS <- traverse (deserializePublicKey proxy) mpkSm + decap proxy derive skR mpkS enc ---------------------------------------------------------------- diff --git a/Crypto/HPKE/KeyPair.hs b/Crypto/HPKE/KeyPair.hs --- a/Crypto/HPKE/KeyPair.hs +++ b/Crypto/HPKE/KeyPair.hs @@ -3,11 +3,11 @@ module Crypto.HPKE.KeyPair where import qualified Control.Exception as E -import Crypto.ECC ( - EllipticCurve (..), - ) +import Crypto.KEM (generateKeyPair) + import Crypto.HPKE.ID -import Crypto.HPKE.KEM (genKeyPairP) +import Crypto.HPKE.KEM (HPKEKEM (..), KEMAlg (..)) +import Crypto.HPKE.Map import Crypto.HPKE.Types ---------------------------------------------------------------- @@ -18,8 +18,16 @@ :: HPKEMap -> KEM_ID -> IO (EncodedPublicKey, EncodedSecretKey) genKeyPair HPKEMap{..} kem_id = case lookup kem_id kemMap of Nothing -> E.throwIO $ Unsupported $ show kem_id - Just (KEMGroup proxy, _) -> do - (pk, sk) <- genKeyPairP proxy - let pkm = EncodedPublicKey $ encodePoint proxy pk - skm = EncodedSecretKey $ encodeScalar proxy sk - return (pkm, skm) + Just (KEMAlg kem) -> generateKeyPair kem + +-- | The public key that goes with a secret key, for the KEM named by the +-- 'KEM_ID'. A receiver authenticating a sender is given the sender's +-- public key; this is how the sender arrives at one to publish. +toPublicKey + :: HPKEMap + -> KEM_ID + -> EncodedSecretKey + -> Either HPKEError EncodedPublicKey +toPublicKey HPKEMap{..} kem_id skm = case lookup kem_id kemMap of + Nothing -> Left $ Unsupported $ show kem_id + Just (KEMAlg kem) -> toEncapsulationKey kem skm diff --git a/Crypto/HPKE/Map.hs b/Crypto/HPKE/Map.hs new file mode 100644 --- /dev/null +++ b/Crypto/HPKE/Map.hs @@ -0,0 +1,43 @@ + +-- | Which algorithms this package will run, and under which identifiers. +module Crypto.HPKE.Map ( + HPKEMap (..), + defaultHPKEMap, + defaultKEMMap, +) where + +import Crypto.HPKE.DHKEM +import Crypto.HPKE.ID +import Crypto.HPKE.KEM +import Crypto.HPKE.Types + +---------------------------------------------------------------- + +{- FOURMOLU_DISABLE -} +-- | The five DHKEMs of RFC 9180 section 7.1. A KEM added here needs +-- instances of 'Crypto.KEM.KEM' and 'HPKEKEM' and nothing else. +defaultKEMMap :: [(KEM_ID, KEMAlg)] +defaultKEMMap = + [ (DHKEM_P256_HKDF_SHA256, KEMAlg (Proxy :: Proxy DHKEM_P256)) + , (DHKEM_P384_HKDF_SHA384, KEMAlg (Proxy :: Proxy DHKEM_P384)) + , (DHKEM_P521_HKDF_SHA512, KEMAlg (Proxy :: Proxy DHKEM_P521)) + , (DHKEM_X25519_HKDF_SHA256, KEMAlg (Proxy :: Proxy DHKEM_X25519)) + , (DHKEM_X448_HKDF_SHA512, KEMAlg (Proxy :: Proxy DHKEM_X448)) + ] +{- FOURMOLU_ENABLE -} + +---------------------------------------------------------------- + +data HPKEMap = HPKEMap + { kemMap :: [(KEM_ID, KEMAlg)] + , kdfMap :: [(KDF_ID, KDFHash)] + , cipherMap :: [(AEAD_ID, AEADCipher)] + } + +defaultHPKEMap :: HPKEMap +defaultHPKEMap = + HPKEMap + { kemMap = defaultKEMMap + , kdfMap = defaultKDFMap + , cipherMap = defaultAEADMap + } diff --git a/Crypto/HPKE/Setup.hs b/Crypto/HPKE/Setup.hs --- a/Crypto/HPKE/Setup.hs +++ b/Crypto/HPKE/Setup.hs @@ -13,12 +13,15 @@ import qualified Control.Exception as E +import Crypto.KEM (encapsulate, encapsulateWith, decapsulate) + import Crypto.HPKE.AEAD import Crypto.HPKE.Context import Crypto.HPKE.ID import Crypto.HPKE.KDF import Crypto.HPKE.KEM import Crypto.HPKE.KeySchedule +import Crypto.HPKE.Map import Crypto.HPKE.Types -- | Setting up base/auth mode for a sender. @@ -51,17 +54,17 @@ -> AEAD_ID -> EncodedSecretKey -- ^ My secret key - -> Maybe EncodedSecretKey - -- ^ My secret key for authentication. - -- 'mode_base' is used if 'Nothing'. 'base_auth' is used, otherwise. + -> Maybe EncodedPublicKey + -- ^ The sender's public key, for authentication. + -- 'mode_base' is used if 'Nothing'. 'mode_auth' is used, otherwise. -> EncodedPublicKey - -- ^ Peer's public key. + -- ^ The encapsulated key, @enc@. -> Info -> IO ContextR -setupBaseR kem_id kdf_id aead_id skRm mskSm enc info = - setupR defaultHPKEMap mode kem_id kdf_id aead_id skRm mskSm enc info "" "" +setupBaseR kem_id kdf_id aead_id skRm mpkSm enc info = + setupR defaultHPKEMap mode kem_id kdf_id aead_id skRm mpkSm enc info "" "" where - mode = case mskSm of + mode = case mpkSm of Nothing -> ModeBase _ -> ModeAuth @@ -99,19 +102,19 @@ -> AEAD_ID -> EncodedSecretKey -- ^ My secret key - -> Maybe EncodedSecretKey - -- ^ My secret key for authentication. - -- 'mode_base' is used if 'Nothing'. 'base_auth' is used, otherwise. + -> Maybe EncodedPublicKey + -- ^ The sender's public key, for authentication. + -- 'mode_psk' is used if 'Nothing'. 'mode_auth_psk' is used, otherwise. -> EncodedPublicKey - -- ^ Peer's public key. + -- ^ The encapsulated key, @enc@. -> Info -> PSK -> PSK_ID -> IO ContextR -setupPSKR kem_id kdf_id aead_id skRm mskSm = - setupR defaultHPKEMap mode kem_id kdf_id aead_id skRm mskSm +setupPSKR kem_id kdf_id aead_id skRm mpkSm = + setupR defaultHPKEMap mode kem_id kdf_id aead_id skRm mpkSm where - mode = case mskSm of + mode = case mpkSm of Nothing -> ModePsk _ -> ModeAuthPsk @@ -137,12 +140,9 @@ setupS hpkeMap mode kem_id kdf_id aead_id mskEm mskSm pkRm info psk psk_id = do verifyPSKInput mode psk psk_id let r = look hpkeMap kem_id kdf_id aead_id - throwOnError r $ \((KEMGroup group, KDFHash h), KDFHash h', AEADCipher c) -> do - let derive = extractAndExpand h $ suiteKEM kem_id - encap <- case mskEm of - Nothing -> encapGen group derive mskSm - Just skEm -> return $ encapEnv group derive skEm mskSm - throwOnError (encap pkRm) $ \(shared_secret, enc) -> do + throwOnError r $ \(KEMAlg kem, KDFHash h', AEADCipher c) -> do + encapped <- hpkeEncap kem mskEm mskSm pkRm + throwOnError encapped $ \(enc, shared_secret) -> do let (nk, nn, seal', _) = aeadParams c suite' = suiteHPKE kem_id kdf_id aead_id keys = keySchedule h' suite' nk nn mode info psk psk_id shared_secret @@ -159,22 +159,19 @@ -> AEAD_ID -> EncodedSecretKey -- ^ My secret key - -> Maybe EncodedSecretKey - -- ^ My secret key for authentication. - -- 'mode_base' is used if 'Nothing'. 'base_auth' is used, otherwise. + -> Maybe EncodedPublicKey + -- ^ The sender's public key, for the authenticated modes. -> EncodedPublicKey - -- ^ Peer's public key. + -- ^ The encapsulated key, @enc@. -> Info -> PSK -> PSK_ID -> IO ContextR -setupR hpkeMap mode kem_id kdf_id aead_id skRm mskSm enc info psk psk_id = do +setupR hpkeMap mode kem_id kdf_id aead_id skRm mpkSm enc info psk psk_id = do verifyPSKInput mode psk psk_id let r = look hpkeMap kem_id kdf_id aead_id - throwOnError r $ \((KEMGroup group, KDFHash h), KDFHash h', AEADCipher c) -> do - let derive = extractAndExpand h $ suiteKEM kem_id - decap = decapEnv group derive skRm mskSm - throwOnError (decap enc) $ \shared_secret -> do + throwOnError r $ \(KEMAlg kem, KDFHash h', AEADCipher c) -> do + throwOnError (hpkeDecap kem skRm mpkSm enc) $ \shared_secret -> do let (nk, nn, _, open') = aeadParams c suite' = suiteHPKE kem_id kdf_id aead_id keys = keySchedule h' suite' nk nn mode info psk psk_id shared_secret @@ -182,6 +179,48 @@ let expand' = labeledExpand suite' prk "sec" newContextR key nonce open' expand' +-- | The four ways RFC 9180 reaches a shared secret on the sending side. +-- The two unauthenticated ones are @crypton@'s 'encapsulate' and +-- 'encapsulateWith'; the two authenticated ones are what 'HPKEKEM' adds, +-- and a KEM without them refuses here rather than further down. +hpkeEncap + :: HPKEKEM kem + => proxy kem + -> Maybe EncodedSecretKey + -- ^ @skE@, drawn here if absent + -> Maybe EncodedSecretKey + -- ^ @skS@, which makes it an authenticated mode + -> EncodedPublicKey + -> IO (Either HPKEError (EncodedPublicKey, SharedSecret)) +hpkeEncap kem mskEm mskSm pkRm = case (mskEm, mskSm) of + (Nothing, Nothing) -> toHPKEError EncapError <$> encapsulate kem pkRm + (Just skEm, Nothing) -> + return $ toHPKEError EncapError $ encapsulateWith kem pkRm skEm + (Nothing, Just skSm) -> do + skEm <- generateCoins kem + return $ authEncapWith kem skSm pkRm skEm + (Just skEm, Just skSm) -> return $ authEncapWith kem skSm pkRm skEm + +-- | And the two on the receiving side. +hpkeDecap + :: HPKEKEM kem + => proxy kem + -> EncodedSecretKey + -> Maybe EncodedPublicKey + -- ^ @pkS@, which makes it an authenticated mode + -> EncodedPublicKey + -> Either HPKEError SharedSecret +hpkeDecap kem skRm Nothing enc = + toHPKEError DecapError $ decapsulate kem skRm enc +hpkeDecap kem skRm (Just pkSm) enc = authDecap kem pkSm skRm enc + +-- | The class answers with a 'CryptoFailable', which has a reason and no +-- message. Everything above here wants an 'HPKEError', so the reason is +-- spelled back out. +toHPKEError :: (String -> HPKEError) -> CryptoFailable a -> Either HPKEError a +toHPKEError _ (CryptoPassed a) = Right a +toHPKEError con (CryptoFailed e) = Left $ con $ show e + aeadParams :: Aead a => Proxy a -> (Int, Int, Key -> Seal, Key -> Open) @@ -198,7 +237,7 @@ -> KEM_ID -> KDF_ID -> AEAD_ID - -> Either HPKEError ((KEMGroup, KDFHash), KDFHash, AEADCipher) + -> Either HPKEError (KEMAlg, KDFHash, AEADCipher) look HPKEMap{..} kem_id kdf_id aead_id = do k <- lookupE kem_id kemMap h <- lookupE kdf_id kdfMap @@ -219,11 +258,6 @@ got_psk_id = psk_id /= "" ---------------------------------------------------------------- - -suiteKEM :: KEM_ID -> Suite -suiteKEM kem_id = "KEM" <> i - where - i = i2ospOf_ 2 $ fromIntegral $ fromKEM_ID kem_id suiteHPKE :: KEM_ID -> KDF_ID -> AEAD_ID -> Suite suiteHPKE kem_id hkdf_id aead_id = "HPKE" <> i0 <> i1 <> i2 diff --git a/hpke.cabal b/hpke.cabal --- a/hpke.cabal +++ b/hpke.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: hpke -version: 0.2.1 +version: 0.3.0 license: BSD3 license-file: LICENSE maintainer: kazu@iij.ad.jp @@ -15,6 +15,7 @@ library exposed-modules: Crypto.HPKE + Crypto.HPKE.DHKEM Crypto.HPKE.Internal other-modules: Crypto.HPKE.AEAD Crypto.HPKE.Context @@ -23,6 +24,7 @@ Crypto.HPKE.KEM Crypto.HPKE.KeyPair Crypto.HPKE.KeySchedule + Crypto.HPKE.Map Crypto.HPKE.PublicKey Crypto.HPKE.Setup Crypto.HPKE.Types @@ -32,7 +34,7 @@ base >=4.7 && <5, base16-bytestring, bytestring, - crypton >= 2.0 && <2.2, + crypton >=2.1.8 && <2.3, ram default-extensions: Strict StrictData @@ -48,6 +50,7 @@ A4Spec A5Spec A6Spec + DHKEMSpec SecretSpec Test @@ -61,4 +64,5 @@ base16-bytestring, crypton, hpke, - hspec + hspec, + ram diff --git a/test/DHKEMSpec.hs b/test/DHKEMSpec.hs new file mode 100644 --- /dev/null +++ b/test/DHKEMSpec.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module DHKEMSpec where + +import Crypto.Error (CryptoFailable (..)) +import Data.ByteArray (convert) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base16 as B16 +import Data.Proxy (Proxy (..)) +import Test.Hspec + +import Crypto.HPKE +import Crypto.HPKE.DHKEM + +x25519 :: Proxy DHKEM_X25519 +x25519 = Proxy + +p256 :: Proxy DHKEM_P256 +p256 = Proxy + +hex :: ByteString -> ByteString +hex = B16.decodeLenient + +-- RFC 9180 A.1.1, DHKEM(X25519, HKDF-SHA256). The four keys are the ones +-- A1Spec already drives the whole of HPKE with; the shared secret is the +-- value the appendix gives for the KEM step alone, which nothing else here +-- reaches. +skEm, pkEm, skRm, pkRm, sharedSecret :: ByteString +skEm = "52c4a758a802cd8b936eceea314432798d5baf2d7e9235dc084ab1b9cfa2f736" +pkEm = "37fda3567bdbd628e88668c3c8d7e97d1d1253b6d4ea6d44c150f741f1bf4431" +skRm = "4612c550263fc8ad58375df3f557aac531d26850903e55a9f23f21d8534e8ac8" +pkRm = "3948cfe0ad1ddb695d780e59077195da6c56506b027329794ab02bca80815c4d" +sharedSecret = "fe0e18c9f024ce43799ae393c7e8fe8fce9d218875e8227b0187c04e7d2ea1fc" + +spec :: Spec +spec = do + describe "DHKEM through crypton's KEM class" $ do + it "A.1.1: encapsulating with the vector's ephemeral key" $ + case encapsulateWith + x25519 + (EncodedPublicKey (hex pkRm)) + (EncodedSecretKey (hex skEm)) of + CryptoFailed e -> expectationFailure (show e) + CryptoPassed (EncodedPublicKey enc, ss) -> do + enc `shouldBe` hex pkEm + (convert ss :: ByteString) `shouldBe` hex sharedSecret + + it "A.1.1: the receiver recovers that secret" $ + case decapsulate + x25519 + (EncodedSecretKey (hex skRm)) + (EncodedPublicKey (hex pkEm)) of + CryptoFailed e -> expectationFailure (show e) + CryptoPassed ss -> + (convert ss :: ByteString) `shouldBe` hex sharedSecret + + it "a generated X25519 pair encapsulates and decapsulates" $ + roundTrip x25519 + + it "a generated P-256 pair encapsulates and decapsulates" $ + roundTrip p256 + + it "the authenticated mode binds the sender's public key" $ do + (pkS, skS) <- generateKeyPair x25519 + (pkR, skR) <- generateKeyPair x25519 + (pkOther, _) <- generateKeyPair x25519 + skE <- generateCoins x25519 + case authEncapWith x25519 skS pkR skE of + Left e -> expectationFailure (show e) + Right (enc, ss) -> do + -- the receiver has the sender's public key, not its + -- secret one, which is the whole point of the argument + authDecap x25519 pkS skR enc `shouldBe` Right ss + authDecap x25519 pkOther skR enc `shouldNotBe` Right ss + + it "refuses an encapsulated value that is not a point" $ do + (_, sk) <- generateKeyPair x25519 + case decapsulate x25519 sk (EncodedPublicKey "short") of + CryptoPassed _ -> expectationFailure "a 5-byte point was accepted" + CryptoFailed _ -> return () + +roundTrip + :: ( KEM kem + , EncapsulationKey kem ~ EncodedPublicKey + , DecapsulationKey kem ~ EncodedSecretKey + , Ciphertext kem ~ EncodedPublicKey + ) + => Proxy kem -> Expectation +roundTrip p = do + (pk, sk) <- generateKeyPair p + r <- encapsulate p pk + case r of + CryptoFailed e -> expectationFailure (show e) + CryptoPassed (enc, ss) -> case decapsulate p sk enc of + CryptoFailed e -> expectationFailure (show e) + CryptoPassed ss' -> + (convert ss' :: ByteString) `shouldBe` convert ss diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -50,7 +50,7 @@ kdf_id aead_id skRm - mskSm -- auth + mpkSm -- auth: the sender's public key, which is all a receiver has pkEm info psk @@ -87,6 +87,10 @@ mskSm | _skSm == "" = Nothing | otherwise = Just $ EncodedSecretKey $ B16.decodeLenient _skSm + -- The vectors give the sender's secret key; a receiver is given the + -- public one. Deriving it here is sound because the same derivation is + -- pinned by "enc `shouldBe` pkEm" above, for every suite tested. + mpkSm = either (error . show) id . toPublicKey defaultHPKEMap kem_id <$> mskSm psk = B16.decodeLenient _psk psk_id = B16.decodeLenient _psk_id ct0 = B16.decodeLenient _ct0