Fix BLS pop dst and no context API

cardano-crypto-class/CHANGELOG.md

@@ -4,6 +4,12 @@
 
 * Replace memory dependency with ram (drop in replacement)
 * Depend on crypton ^>- 1.1
+* Fix the DST used when hashing the public key for BLS12-381 proofs of possession:
+  `createPossessionProofDSIGN` and `verifyPossessionProofDSIGN` now use the
+  `"BLS_POP_"`-prefixed DST prescribed by draft-irtf-cfrg-bls-signature-06
+  (Section 4.2.3) instead of the `"BLS_SIG_"` one used for ordinary signatures.
+  The PoP DST is selected internally per curve variant, so these functions (and
+  `aggregateVerKeysDSIGN`) no longer take a signing context.
 
 ## 2.5.1.0
 

cardano-crypto-class/bench/Bench/Crypto/DSIGN.hs

@@ -139,15 +139,15 @@ benchAggDSIGN _ lbl =
       [ bgroup ("n=" <> show n)
           [ env (pure (mkCase @v ctx msg n)) $ \c ->
               bench "provePoP (all)" $
-                nf (proveAllPoPs @v ctx) (caseSKs c)
+                nf (proveAllPoPs @v) (caseSKs c)
 
           , env (pure (mkCase @v ctx msg n)) $ \c ->
               bench "verifyPoP (all)" $
-                nf (verifyAllPoPs @v ctx) (caseVKPoPs c)
+                nf (verifyAllPoPs @v) (caseVKPoPs c)
 
           , env (pure (mkCase @v ctx msg n)) $ \c ->
               bench "aggregateVerKeys (with PoPs)" $
-                nf (aggregateVerKeysDSIGN @v ctx) (caseVKPoPs c)
+                nf (aggregateVerKeysDSIGN @v) (caseVKPoPs c)
 
           , env (pure (mkCase @v ctx msg n)) $ \c ->
               bench "aggregateVerKeys (no PoPs)" $
@@ -184,17 +184,16 @@ mkCase :: forall v a. (DSIGNAggregatable v, Signable v a)
 mkCase ctx msg n =
   let sks  = replicate n (genKeyDSIGN @v testSeed)
       vks  = map deriveVerKeyDSIGN sks
-      pops = map (createPossessionProofDSIGN @v ctx) sks
+      pops = map (createPossessionProofDSIGN @v) sks
       sigs = map (signDSIGN @v ctx msg) sks
       vkp  = zip vks pops
   in AggCase sks vks vkp sigs
 
 proveAllPoPs :: forall v. DSIGNAggregatable v
-  => ContextDSIGN v -> [SignKeyDSIGN v] -> [PossessionProofDSIGN v]
-proveAllPoPs ctx = map (createPossessionProofDSIGN @v ctx)
+  => [SignKeyDSIGN v] -> [PossessionProofDSIGN v]
+proveAllPoPs = map (createPossessionProofDSIGN @v)
 
 verifyAllPoPs :: forall v. DSIGNAggregatable v
-  => ContextDSIGN v
-  -> [(VerKeyDSIGN v, PossessionProofDSIGN v)]
+  => [(VerKeyDSIGN v, PossessionProofDSIGN v)]
   -> Either String ()
-verifyAllPoPs ctx = F.foldl' (\acc (vk,pop) -> acc >> verifyPossessionProofDSIGN @v ctx vk pop) (Right ())
+verifyAllPoPs = F.foldl' (\acc (vk,pop) -> acc >> verifyPossessionProofDSIGN @v vk pop) (Right ())

cardano-crypto-class/src/Cardano/Crypto/DSIGN/BLS12381/Internal.hs

@@ -98,10 +98,11 @@ import Data.Bifunctor (first)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
-import Data.Data (Typeable)
+import Data.Data (Typeable, eqT)
 import qualified Data.Foldable as F (foldl')
 import Data.Kind (Type)
 import Data.Proxy (Proxy (Proxy))
+import Data.Type.Equality ((:~:) (Refl))
 import Foreign.C.Types
 import GHC.Generics (Generic)
 import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
@@ -133,9 +134,32 @@ minSigPoPDST = BLS12381SignContext (Just "BLS_SIG_BLS12381G1_XMD:SHA-256_SSWU_RO
 minVerKeyPoPDST :: BLS12381SignContext
 minVerKeyPoPDST = BLS12381SignContext (Just "BLS_SIG_BLS12381G2_XMD:SHA-256_SSWU_RO_POP_") Nothing
 
+-- The context used by @hash_pubkey_to_point@ when creating and verifying
+-- proofs of possession for the minimal signature size variant, as per
+-- draft-irtf-cfrg-bls-signature-06, Section 4.2.3: proofs of possession use
+-- @"BLS_POP_" || H2C_SUITE_ID || SC_TAG || "_"@ as DST, whereas ordinary
+-- signatures use the @"BLS_SIG_"@ prefix. Not exported: it is applied
+-- internally by 'createPossessionProofDSIGN' and 'verifyPossessionProofDSIGN',
+-- so users cannot accidentally create or verify a proof under the signature
+-- DST.
+minSigPoPProofDST :: BLS12381SignContext
+minSigPoPProofDST = BLS12381SignContext (Just "BLS_POP_BLS12381G1_XMD:SHA-256_SSWU_RO_POP_") Nothing
+
+-- As 'minSigPoPProofDST', for the minimal verification key size variant.
+minVerKeyPoPProofDST :: BLS12381SignContext
+minVerKeyPoPProofDST = BLS12381SignContext (Just "BLS_POP_BLS12381G2_XMD:SHA-256_SSWU_RO_POP_") Nothing
+
+-- Select the proof-of-possession context for the curve the verification keys
+-- live on.
+popProofSignContext :: forall curve. Typeable curve => Proxy curve -> BLS12381SignContext
+popProofSignContext _ =
+  case eqT @curve @Curve1 of
+    Just Refl -> minVerKeyPoPProofDST
+    Nothing -> minSigPoPProofDST
+
 type family CurveVariant (c :: Type) :: Symbol where
-  CurveVariant Curve1 = "BLS-Signature-Mininimal-Verification-Key-Size"
-  CurveVariant Curve2 = "BLS-Signature-Mininimal-Signature-Size"
+  CurveVariant Curve1 = "BLS-Signature-Minimal-Verification-Key-Size"
+  CurveVariant Curve2 = "BLS-Signature-Minimal-Signature-Size"
 
 -- | This module provides support only for proof-of-possession (PoP) ciphersuite
 -- contexts:
@@ -194,6 +218,14 @@ type family CurveVariant (c :: Type) :: Symbol where
 --   public keys live in G1 (48 bytes compressed), signatures in G2
 --   (96 bytes compressed).
 --
+-- Within each variant, the PoP ciphersuite prescribes two DSTs (Section 4.2.3):
+-- ordinary signing and verification use the @\"BLS_SIG_\"@-prefixed DST
+-- ('minSigPoPDST' \/ 'minVerKeyPoPDST'), while creating and verifying proofs of
+-- possession hash the public key with the @\"BLS_POP_\"@-prefixed DST.
+-- 'createPossessionProofDSIGN' and 'verifyPossessionProofDSIGN' take no signing
+-- context: they select the @\"BLS_POP_\"@ context internally from the curve, so
+-- callers cannot accidentally use the signature DST for proofs of possession.
+--
 -- The draft recommends the minimal-pubkey-size variant for aggregation,
 -- because the size of @(PK_1, ..., PK_n, signature)@ is usually dominated by
 -- the public keys. Other protocols, like Leios, might favor minimal-signature-size.
@@ -223,14 +255,14 @@ type family CurveVariant (c :: Type) :: Symbol where
 --         (mkSeedFromBytes (BS.replicate 32 2))
 --     vk1 = deriveVerKeyDSIGN sk1
 --     vk2 = deriveVerKeyDSIGN sk2
---     pop1 = createPossessionProofDSIGN ctx sk1
---     pop2 = createPossessionProofDSIGN ctx sk2
+--     pop1 = createPossessionProofDSIGN sk1
+--     pop2 = createPossessionProofDSIGN sk2
 -- :}
 --
--- >>> verifyPossessionProofDSIGN ctx vk1 pop1
+-- >>> verifyPossessionProofDSIGN vk1 pop1
 -- Right ()
 --
--- >>> verifyPossessionProofDSIGN ctx vk2 pop2
+-- >>> verifyPossessionProofDSIGN vk2 pop2
 -- Right ()
 --
 -- -- Once the proofs have been checked, it is safe to aggregate keys
@@ -540,15 +572,15 @@ instance
                 else Right $ SigBLS12381 aggrPoint
 
   {-# INLINE createPossessionProofDSIGN #-}
-  createPossessionProofDSIGN ctx sk =
+  createPossessionProofDSIGN sk =
     let vk = deriveVerKeyDSIGN sk :: VerKeyDSIGN (BLS12381DSIGN curve)
-        SigBLS12381 sig = signDSIGN ctx (rawEncodeFixedSized vk) sk
+        SigBLS12381 sig = signDSIGN (popProofSignContext (Proxy @curve)) (rawEncodeFixedSized vk) sk
      in PossessionProofBLS12381 sig
   {-# INLINE verifyPossessionProofDSIGN #-}
-  verifyPossessionProofDSIGN ctx vk (PossessionProofBLS12381 mu1Psb) =
+  verifyPossessionProofDSIGN vk (PossessionProofBLS12381 mu1Psb) =
     first
       (const "verifyPossessionProofDSIGN: BLS12381DSIGN failed to verify.")
-      (verifyDSIGN ctx vk (rawEncodeFixedSized vk) (SigBLS12381 mu1Psb))
+      (verifyDSIGN (popProofSignContext (Proxy @curve)) vk (rawEncodeFixedSized vk) (SigBLS12381 mu1Psb))
 
 deriving stock instance
   BLS (DualCurve curve) =>

cardano-crypto-class/src/Cardano/Crypto/DSIGN/Class.hs

@@ -552,14 +552,12 @@ class
   -- | Create a PoP from the signing key.
   createPossessionProofDSIGN ::
     HasCallStack =>
-    ContextDSIGN v ->
     SignKeyDSIGN v ->
     PossessionProofDSIGN v
 
   -- | Verify that PoP matches the verification key.
   verifyPossessionProofDSIGN ::
     HasCallStack =>
-    ContextDSIGN v ->
     VerKeyDSIGN v ->
     PossessionProofDSIGN v ->
     Either String ()
@@ -577,16 +575,13 @@ class
 
 -- | Aggregate multiple verification keys into a single verification key given
 -- their corresponding Proofs of Possession.
---
--- Note that the signing context is passed since the PoP might depend on it.
 aggregateVerKeysDSIGN ::
   (HasCallStack, DSIGNAggregatable v) =>
-  ContextDSIGN v ->
   [(VerKeyDSIGN v, PossessionProofDSIGN v)] ->
   Either String (VerKeyDSIGN v)
-aggregateVerKeysDSIGN ctx verKeysAndPoPs = do
+aggregateVerKeysDSIGN verKeysAndPoPs = do
   -- Verify every verKey and its PoP (fail-fast)
-  forM_ verKeysAndPoPs $ uncurry (verifyPossessionProofDSIGN ctx)
+  forM_ verKeysAndPoPs $ uncurry verifyPossessionProofDSIGN
   uncheckedAggregateVerKeysDSIGN (map fst verKeysAndPoPs)
 
 possessionProofSizeDSIGN :: forall v proxy. DSIGNAggregatable v => proxy v -> Word

cardano-crypto-class/testlib/Test/Crypto/DSIGN.hs

@@ -172,13 +172,11 @@ defaultSignKeyGen =
 defaultPossessionProofGen
   :: forall v.
      DSIGNAggregatable v
-  => Gen (ContextDSIGN v)
-  -> Gen (KeyGenContextDSIGN v)
+  => Gen (KeyGenContextDSIGN v)
   -> Gen (PossessionProofDSIGN v)
-defaultPossessionProofGen genContext genKeyCtx = do
-  ctx <- genContext
-  sk  <- defaultSignKeyWithContextGen @v genKeyCtx
-  pure $ createPossessionProofDSIGN ctx sk
+defaultPossessionProofGen genKeyCtx = do
+  sk <- defaultSignKeyWithContextGen @v genKeyCtx
+  pure $ createPossessionProofDSIGN sk
 
 -- Used for adjusting no of quick check tests
 -- By default up to 100 tests are performed which may not be enough to catch hidden bugs
@@ -817,15 +815,15 @@ testDSIGNAggregatableWithContext _ genContext genKeyCtx genMsg name = testEnough
       forAllShow (genAggregateCase genContext genMsg) ppShow $
           \(ctx, msg, vksPops, sigs) -> (=== Right ()) $ do
             sig <- aggregateSigsDSIGN @v sigs
-            aggVk <- aggregateVerKeysDSIGN ctx vksPops
+            aggVk <- aggregateVerKeysDSIGN vksPops
             verifyDSIGN @v ctx aggVk msg sig
     prop "aggregate verify negative (wrong message)" $
       withNumTests 1000 .
       forAllShow (genAggregateCase genContext genMsg) ppShow $ \(ctx, msg, vksPops, sigs) ->
           forAllShow arbitrary ppShow $ \msg' ->
             msg /= msg' ==> (=/= Right ()) $ do
                 sig <- aggregateSigsDSIGN @v sigs
-                aggVk <- aggregateVerKeysDSIGN ctx vksPops
+                aggVk <- aggregateVerKeysDSIGN vksPops
                 verifyDSIGN @v ctx aggVk msg' sig
     prop "aggregate verify negative (wrong PoP)" $
         forAllShow (genAggregateCaseAtLeast2 genContext genMsg) ppShow $
@@ -834,7 +832,7 @@ testDSIGNAggregatableWithContext _ genContext genKeyCtx genMsg name = testEnough
               (a:b:rest) -> (=/= Right ()) $ do
                 let vksPops' = (fst a, snd b) : (fst b, snd a) : rest
                 sig <- aggregateSigsDSIGN @v sigs
-                aggVk <- aggregateVerKeysDSIGN ctx vksPops'
+                aggVk <- aggregateVerKeysDSIGN vksPops'
                 verifyDSIGN @v ctx aggVk msg sig
               _ ->
                 counterexample "genAggregateCaseAtLeast2 produced <2 entries (bug in generator)" False
@@ -850,7 +848,7 @@ testDSIGNAggregatableWithContext _ genContext genKeyCtx genMsg name = testEnough
       => (PossessionProofDSIGN v -> prop)
       -> Property
     forAllPoP =
-      forAllShow (defaultPossessionProofGen @v genContext genKeyCtx) ppShow
+      forAllShow (defaultPossessionProofGen @v genKeyCtx) ppShow
     genAggregateCase genCtx genMsg' = do
       ctx <- genCtx
       msg <- genMsg'
@@ -859,7 +857,7 @@ testDSIGNAggregatableWithContext _ genContext genKeyCtx genMsg name = testEnough
       n   <- Gen.chooseInt (1, 8)
       sks <- replicateM n (defaultSignKeyWithContextGen @v genKeyCtx)
       let vksPops = [ ( deriveVerKeyDSIGN sk
-                     , createPossessionProofDSIGN ctx sk
+                     , createPossessionProofDSIGN sk
                      )
                    | sk <- sks
                    ]
@@ -874,7 +872,7 @@ testDSIGNAggregatableWithContext _ genContext genKeyCtx genMsg name = testEnough
       n   <- Gen.chooseInt (2, 8)
       sks <- replicateM n (defaultSignKeyWithContextGen @v genKeyCtx)
       let vksPops = [ ( deriveVerKeyDSIGN sk
-                     , createPossessionProofDSIGN ctx sk
+                     , createPossessionProofDSIGN sk
                      )
                    | sk <- sks
                    ]