hpke 0.2.1 → 0.3.0

raw patch · 12 files changed

+694/−227 lines, 12 filesdep ~cryptonPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: crypton

API changes (from Hackage documentation)

Files

• ChangeLog.md +16/−0
• Crypto/HPKE/DHKEM.hs +306/−0
• Crypto/HPKE/ID.hs +10/−57
• Crypto/HPKE/Internal.hs +5/−1
• Crypto/HPKE/KDF.hs +0/−1
• Crypto/HPKE/KEM.hs +117/−120
• Crypto/HPKE/KeyPair.hs +17/−9
• Crypto/HPKE/Map.hs +43/−0
• Crypto/HPKE/Setup.hs +69/−35
• hpke.cabal +7/−3
• test/DHKEMSpec.hs +99/−0
• test/Test.hs +5/−1

@@ -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`,

@@ -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

@@ -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

@@ -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

@@ -12,7 +12,6 @@ ) where -import Crypto.Hash.IO (hashDigestSize) import Crypto.Hash.Algorithms (     HashAlgorithm,     SHA256 (..),

@@ -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  ---------------------------------------------------------------- 

@@ -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

@@ -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+        }

@@ -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

@@ -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

@@ -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

@@ -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