Perturbing/add bls sig bindings

cardano-crypto-class/src/Cardano/Crypto/EllipticCurve/BLS12_381/Internal.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RoleAnnotations #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
@@ -45,6 +46,13 @@ module Cardano.Crypto.EllipticCurve.BLS12_381.Internal (
   Point2,
   PT,
   Scalar (..),
+  SecretKey (..),
+  PublicKey (..),
+  Signature (..),
+  Dual,
+  FinalVerifyOrder,
+  PairingSide,
+  ProofOfPossession (..),
   Fr (..),
   unsafePointFromPointPtr,
 
@@ -71,12 +79,17 @@ module Cardano.Crypto.EllipticCurve.BLS12_381.Internal (
     c_blst_affine_in_g,
     c_blst_generator,
     c_blst_p_is_equal,
-    c_blst_p_is_inf
+    c_blst_p_is_inf,
+    c_blst_sk_to_pk,
+    c_blst_sign
   ),
 
   -- * Pairing check
   c_blst_miller_loop,
 
+  -- * Keygen
+  c_blst_keygen,
+
   -- * FP12 functions
 
   --
@@ -167,6 +180,15 @@ module Cardano.Crypto.EllipticCurve.BLS12_381.Internal (
 
   -- * Pairings
   millerLoop,
+  finalVerifyPairs,
+
+  -- * BLS signature operations
+  blsKeyGen,
+  blsSkToPk,
+  blsSign,
+  blsSignatureVerify,
+  blsProofOfPossessionProve,
+  blsProofOfPossessionVerify,
 )
 where
 
@@ -193,6 +215,11 @@ import System.IO.Unsafe (unsafePerformIO)
 data Curve1
 data Curve2
 
+-- | A type family mapping a curve to its dual curve (its an involution).
+type family Dual curve where
+  Dual Curve1 = Curve2
+  Dual Curve2 = Curve1
+
 ---- Unsafe PointPtr types
 
 -- | A pointer to a (projective) point one of the two elliptical curves
@@ -407,6 +434,9 @@ class BLS curve where
   compressedSizePoint_ :: Proxy curve -> CSize
   sizeAffine_ :: Proxy curve -> CSize
 
+  c_blst_sk_to_pk :: PointPtr curve -> ScalarPtr -> IO ()
+  c_blst_sign :: Proxy curve -> PointPtr (Dual curve) -> PointPtr (Dual curve) -> ScalarPtr -> IO ()
+
 instance BLS Curve1 where
   c_blst_on_curve = c_blst_p1_on_curve
 
@@ -439,6 +469,9 @@ instance BLS Curve1 where
   serializedSizePoint_ _ = 96
   sizeAffine_ _ = c_size_blst_affine1
 
+  c_blst_sk_to_pk = c_blst_sk_to_pk_in_g1
+  c_blst_sign _ = c_blst_sign_pk_in_g1
+
 instance BLS Curve2 where
   c_blst_on_curve = c_blst_p2_on_curve
 
@@ -471,6 +504,9 @@ instance BLS Curve2 where
   serializedSizePoint_ _ = 192
   sizeAffine_ _ = c_size_blst_affine2
 
+  c_blst_sk_to_pk = c_blst_sk_to_pk_in_g2
+  c_blst_sign _ = c_blst_sign_pk_in_g2
+
 instance BLS curve => Eq (Affine curve) where
   a == b = unsafePerformIO $
     withAffine a $ \aptr ->
@@ -484,6 +520,35 @@ sizeScalar = fromIntegral c_size_blst_scalar
 
 newtype Scalar = Scalar (ForeignPtr Void)
 
+{-
+- The BLS signature scheme as specified in the IETF draft
+- https://www.ietf.org/archive/id/draft-irtf-cfrg-bls-signature-05.html
+-
+- Note that the specification defines two variants, 'minimal-signature-size'
+- and 'minimal-pubkey-size'. The former uses G1 for signatures and G2 for
+- public keys, while the latter does the opposite.
+-
+- Below we implement both variants, using the phantom types 'Curve1' and
+- 'Curve2' to distinguish them. The user-facing API is so that
+-
+- * Curve1 as 'curve' corresponds to "minimal-pubkey-size", i.e. public keys
+-   are points in G1, signatures are points in G2 and POPs are points in G2.
+- * Curve2 as 'curve' corresponds to "minimal-signature-size", i.e. public keys
+-   are points in G2, signatures are points in G1 and POPs are points in G1.
+-
+- TODO: Add note on switching these around / reusing secret keys for both variants
+-}
+
+-- TODO: Asses is wrapping Scalar is enough to ensure security
+-- against accidental leakage of secret keys.
+newtype SecretKey = SecretKey {unSecretKey :: Scalar}
+newtype PublicKey curve = PublicKey {unPublicKey :: Point curve}
+newtype Signature curve = Signature {unSignature :: Point (Dual curve)}
+data ProofOfPossession curve = ProofOfPossession
+  { unMu1 :: Point (Dual curve)
+  , unMu2 :: Point (Dual curve)
+  }
+
 withIntScalar :: Integer -> (ScalarPtr -> IO a) -> IO a
 withIntScalar i go = do
   s <- scalarFromInteger i
@@ -727,6 +792,23 @@ foreign import ccall "blst_fp12_finalverify" c_blst_fp12_finalverify :: PTPtr ->
 foreign import ccall "blst_miller_loop"
   c_blst_miller_loop :: PTPtr -> Affine2Ptr -> Affine1Ptr -> IO ()
 
+---- BLS signatures Secret-key operations
+
+foreign import ccall "blst_keygen"
+  c_blst_keygen :: ScalarPtr -> Ptr CChar -> CSize -> Ptr CChar -> CSize -> IO ()
+
+foreign import ccall "blst_sk_to_pk_in_g1"
+  c_blst_sk_to_pk_in_g1 :: Point1Ptr -> ScalarPtr -> IO ()
+
+foreign import ccall "blst_sign_pk_in_g1"
+  c_blst_sign_pk_in_g1 :: Point2Ptr -> Point2Ptr -> ScalarPtr -> IO ()
+
+foreign import ccall "blst_sk_to_pk_in_g2"
+  c_blst_sk_to_pk_in_g2 :: Point2Ptr -> ScalarPtr -> IO ()
+
+foreign import ccall "blst_sign_pk_in_g2"
+  c_blst_sign_pk_in_g2 :: Point1Ptr -> Point1Ptr -> ScalarPtr -> IO ()
+
 ---- Raw BLST error constants
 
 foreign import ccall "blst_success" c_blst_success :: CInt
@@ -1091,7 +1173,123 @@ millerLoop p1 p2 =
         withNewPT' $ \ppt ->
           c_blst_miller_loop ppt ap2 ap1
 
----- Utility
+-- A single side of e(·,·): the point on `curve` and the point on its `Dual`.
+type PairingSide curve = (Point curve, Point (Dual curve))
+
+class (BLS curve, BLS (Dual curve)) => FinalVerifyOrder curve where
+  millerSide :: PairingSide curve -> PT
+  finalVerifyPairs :: PairingSide curve -> PairingSide curve -> Bool
+  finalVerifyPairs lhs rhs = ptFinalVerify (millerSide lhs) (millerSide rhs)
+
+instance FinalVerifyOrder Curve1 where
+  -- Curve1: miller loop expects (g1, g2)
+  millerSide (g1, g2) = millerLoop g1 g2
+
+instance FinalVerifyOrder Curve2 where
+  -- Curve2: miller loop expects (g1, g2) but our Pair is (g2, g1)
+  millerSide (g2, g1) = millerLoop g1 g2
+
+---- BLS signatures operations
+
+-- Following the rust bindings as per this reference:
+-- https://github.com/supranational/blst/blob/f48500c1fdbefa7c0bf9800bccd65d28236799c1/bindings/rust/src/lib.rs#L559
+
+-- | Generate a secret key from the given input keying material (ikm)
+-- and optional extra info. The ikm must be at least 32 bytes long.
+-- See https://www.ietf.org/archive/id/draft-irtf-cfrg-bls-signature-05.html#name-keygen
+-- on this length requirement. Note that the blst library itself does not
+-- enforce this length requirement.
+blsKeyGen :: ByteString -> Maybe ByteString -> Either BLSTError SecretKey
+blsKeyGen ikm info = unsafePerformIO $ do
+  withMaybeCStringLen info $ \(infoPtr, infoLen) ->
+    BSU.unsafeUseAsCStringLen ikm $ \(ikmPtr, ikmLen) ->
+      if ikmLen < 32
+        then return $ Left BLST_BAD_ENCODING
+        else do
+          sk <- withNewScalar' $ \skPtr ->
+            c_blst_keygen skPtr ikmPtr (fromIntegral ikmLen) infoPtr (fromIntegral infoLen)
+          return $ Right (SecretKey sk)
+
+-- | Derive the public key from a secret key.
+-- Note that given the choice of Curve1 or Curve2, the public key
+-- will be a point on the corresponding curve.
+blsSkToPk :: BLS curve => SecretKey -> PublicKey curve
+blsSkToPk (SecretKey sk) = PublicKey . unsafePerformIO $
+  withNewPoint' $ \pkPtr ->
+    withScalar sk $ \skPtr ->
+      c_blst_sk_to_pk pkPtr skPtr
+
+-- | Sign a message with the given secret key.
+-- Note that given the choice of Curve1 or Curve2, the signature
+-- will be a point on the dual of the corresponding curve.
+blsSign ::
+  forall curve.
+  (BLS curve, BLS (Dual curve)) =>
+  Proxy curve ->
+  SecretKey -> -- secret key
+  ByteString -> -- message
+  Maybe ByteString -> -- domain separation tag (for protocol separation)
+  Maybe ByteString -> -- augmentation (per message augmentation)
+  Signature curve -- signature
+blsSign _ (SecretKey sk) msg dst aug = Signature . unsafePerformIO $
+  BSU.unsafeUseAsCStringLen msg $ \(msgPtr, msgLen) ->
+    withMaybeCStringLen dst $ \(dstPtr, dstLen) ->
+      withMaybeCStringLen aug $ \(augPtr, augLen) ->
+        withNewPoint' @(Dual curve) $ \sigPtr -> do
+          withNewPoint_ @(Dual curve) $ \hPtr -> do
+            c_blst_hash @(Dual curve)
+              hPtr
+              msgPtr
+              (fromIntegral msgLen)
+              dstPtr
+              (fromIntegral dstLen)
+              augPtr
+              (fromIntegral augLen)
+            withScalar sk $ \skPtr ->
+              c_blst_sign (Proxy @curve) sigPtr hPtr skPtr
+
+-- | Verify a BLS signature via the naive way.
+blsSignatureVerify ::
+  forall curve.
+  FinalVerifyOrder curve =>
+  PublicKey curve -> -- pk on curve
+  ByteString -> -- msg
+  Signature curve -> -- sig on dual curve
+  Maybe ByteString -> -- domain separation tag (for protocol separation)
+  Maybe ByteString -> -- augmentation (per message augmentation)
+  Bool
+blsSignatureVerify (PublicKey pk) msg (Signature sig) dst aug =
+  -- here we check that e(g1, sig) == e(pk, H(msg)) or equivalently
+  -- e(sig, g2) == e(H(msg),pk) depending on the curve choice for pk/sig.
+  finalVerifyPairs @curve (blsGenerator, sig) (pk, blsHash msg dst aug)
+
+blsProofOfPossessionProve ::
+  forall curve.
+  (BLS curve, BLS (Dual curve)) =>
+  SecretKey -> -- secret key
+  Maybe ByteString -> -- domain separation tag (for protocol separation)
+  Maybe ByteString -> -- augmentation (per message augmentation)
+  ProofOfPossession curve -- proof of possession
+blsProofOfPossessionProve (SecretKey sk) dst aug = ProofOfPossession mu1 mu2
+  where
+    skAsInteger = unsafePerformIO $ scalarToInteger sk
+    PublicKey pk = blsSkToPk @curve (SecretKey sk)
+    mu1 :: Point (Dual curve)
+    mu1 = blsMult (blsHash ("PoP" <> blsCompress pk) dst aug) skAsInteger
+    mu2 :: Point (Dual curve)
+    mu2 = blsMult blsGenerator skAsInteger
+
+blsProofOfPossessionVerify ::
+  forall curve.
+  FinalVerifyOrder curve =>
+  PublicKey curve -> -- pk on curve
+  ProofOfPossession curve -> -- proof of possession
+  Maybe ByteString -> -- domain separation tag (for protocol separation)
+  Maybe ByteString -> -- augmentation (per message augmentation)
+  Bool
+blsProofOfPossessionVerify (PublicKey pk) (ProofOfPossession mu1 mu2) dst aug =
+  finalVerifyPairs @curve (blsGenerator, mu1) (pk, blsHash ("PoP" <> blsCompress pk) dst aug)
+    && finalVerifyPairs @curve (pk, blsGenerator) (blsGenerator, mu2)
 
 withMaybeCStringLen :: Maybe ByteString -> (CStringLen -> IO a) -> IO a
 withMaybeCStringLen Nothing go = go (nullPtr, 0)