Refactor Schnorr signing for deterministic and non-deterministic options

- Add deterministic and non-deterministic Schnorr signing functions
- Update tests to cover new signing functions
- Modify schnorrSign to accept optional StdGen for controlled randomness

Author: prolic

libsecp256k1.cabal

@@ -80,5 +80,6 @@ test-suite spec
     , libsecp256k1
     , memory >=0.14.15 && <1.0
     , monad-par
+    , random >=1.2.1.2 && <1.3
     , transformers >=0.4.0.0 && <1.0
   default-language: Haskell2010

src/Crypto/Secp256k1.hs

@@ -76,6 +76,8 @@ module Crypto.Secp256k1 (
 
     -- * Schnorr Operations
     schnorrSign,
+    schnorrSignDeterministic,
+    schnorrSignNondeterministic,
     schnorrVerify,
 
     -- * Other
@@ -143,7 +145,7 @@ import Foreign.Storable (Storable (..))
 import GHC.Generics (Generic)
 import GHC.IO.Handle.Text (memcpy)
 import System.IO.Unsafe (unsafePerformIO)
-import System.Random (newStdGen, randoms)
+import System.Random (StdGen, newStdGen, randoms, randomIO)
 import Text.Read (
     Lexeme (String),
     lexP,
@@ -743,23 +745,38 @@ keyPairPubKeyXOTweakAdd KeyPair{..} Tweak{..} = unsafePerformIO . evalContT $ do
             else free keyPairOut $> Nothing
 
 
--- | Compute a schnorr signature using a 'KeyPair'. The @ByteString@ must be 32 bytes long to get a @Just@ out of this
--- function
-schnorrSign :: KeyPair -> ByteString -> IO (Maybe SchnorrSignature)
-schnorrSign KeyPair{..} bs
-    | BS.length bs /= 32 = pure Nothing
-    | otherwise = evalContT $ do
+-- | Compute a schnorr signature using a 'KeyPair'. The @ByteString@ must be 32 bytes long to get 
+-- a @Just@ out of this function. Optionally takes a 'StdGen' for deterministic signing.
+schnorrSign :: Maybe StdGen -> KeyPair -> ByteString -> Maybe SchnorrSignature
+schnorrSign mGen KeyPair{..} bs
+    | BS.length bs /= 32 = Nothing
+    | otherwise = unsafePerformIO . evalContT $ do
         (msgHashPtr, _) <- ContT (unsafeUseByteString bs)
         keyPairPtr <- ContT (withForeignPtr keyPairFPtr)
         lift $ do
             sigBuf <- mallocBytes 64
-            gen <- newStdGen
-            let randomBytes = BS.pack $ Prelude.take 32 $ randoms gen
-            BS.useAsCString randomBytes $ \randomPtr -> do
-                ret <- Prim.schnorrsigSign ctx sigBuf msgHashPtr keyPairPtr (castPtr randomPtr)
-                if isSuccess ret
-                    then Just . SchnorrSignature <$> newForeignPtr finalizerFree sigBuf
-                    else free sigBuf $> Nothing
+            ret <- case mGen of
+                Just gen -> do
+                    let randomBytes = BS.pack $ Prelude.take 32 $ randoms gen
+                    BS.useAsCStringLen randomBytes $ \(ptr, _) ->
+                        Prim.schnorrsigSign ctx sigBuf msgHashPtr keyPairPtr (castPtr ptr)
+                Nothing ->
+                    Prim.schnorrsigSign ctx sigBuf msgHashPtr keyPairPtr nullPtr
+            if isSuccess ret
+                then Just . SchnorrSignature <$> newForeignPtr finalizerFree sigBuf
+                else do
+                    free sigBuf
+                    return Nothing
+
+
+-- | Compute a deterministic schnorr signature using a 'KeyPair'.
+schnorrSignDeterministic :: KeyPair -> ByteString -> Maybe SchnorrSignature
+schnorrSignDeterministic = schnorrSign Nothing
+
+
+-- | Compute a non-deterministic schnorr signature using a 'KeyPair'.
+schnorrSignNondeterministic :: KeyPair -> ByteString -> IO (Maybe SchnorrSignature)
+schnorrSignNondeterministic kp bs = newStdGen >>= \gen -> pure $ schnorrSign (Just gen) kp bs
 
 
 -- | Verify the authenticity of a schnorr signature. @True@ means the 'Signature' is correct.

test/Crypto/Secp256k1Prop.hs

@@ -17,6 +17,7 @@ import Hedgehog
 import Hedgehog.Gen hiding (discard, maybe, prune)
 import Hedgehog.Range (linear, singleton)
 import Text.Read (readMaybe)
+import System.Random (StdGen, mkStdGen)
 
 
 prop_secKeyReadInvertsShow :: Property
@@ -261,10 +262,17 @@ prop_schnorrSignaturesProducedAreValid = property $ do
     sk <- forAll secKeyGen
     msg <- forAll $ bytes (singleton 32)
     let kp = keyPairCreate sk
-    sig <- liftIO $ schnorrSign kp msg
-    case sig of
-        Nothing -> failure
-        Just s -> assert $ schnorrVerify (fst $ keyPairPubKeyXO kp) msg s
+    sig <- maybe failure pure $ schnorrSignDeterministic kp msg
+    assert $ schnorrVerify (fst $ keyPairPubKeyXO kp) msg sig
+
+
+prop_schnorrSignaturesProducedAreValidNonDeterministic :: Property
+prop_schnorrSignaturesProducedAreValidNonDeterministic = property $ do
+    sk <- forAll secKeyGen
+    msg <- forAll $ bytes (singleton 32)
+    let kp = keyPairCreate sk
+    sig <- liftIO $ maybe (error "Failed to sign") pure =<< schnorrSignNondeterministic kp msg
+    assert $ schnorrVerify (fst $ keyPairPubKeyXO kp) msg sig
 
 
 prop_pubKeyCombineTweakIdentity :: Property
@@ -299,10 +307,18 @@ prop_schnorrSignaturesUnforgeable = property $ do
     let kp = keyPairCreate sk
     pk <- forAll pubKeyXOGen
     msg <- forAll $ bytes (singleton 32)
-    sig <- liftIO $ schnorrSign kp msg
-    case sig of
-        Nothing -> failure
-        Just s -> assert . not $ schnorrVerify pk msg s
+    sig <- maybe failure pure $ schnorrSignDeterministic kp msg
+    assert . not $ schnorrVerify pk msg sig
+
+
+prop_schnorrSignaturesUnforgeableNonDeterministic :: Property
+prop_schnorrSignaturesUnforgeableNonDeterministic = property $ do
+    sk <- forAll secKeyGen
+    let kp = keyPairCreate sk
+    pk <- forAll pubKeyXOGen
+    msg <- forAll $ bytes (singleton 32)
+    sig <- liftIO $ maybe (error "Failed to sign") pure =<< schnorrSignNondeterministic kp msg
+    assert . not $ schnorrVerify pk msg sig
 
 
 newtype Wrapped a = Wrapped {secKey :: a} deriving (Show, Read, Eq)
@@ -349,8 +365,7 @@ prop_derivedCompositeReadShowInvertSchnorrSignature = property $ do
     sk <- forAll secKeyGen
     let kp = keyPairCreate sk
     msg <- forAll $ bytes (singleton 32)
-    mSig <- liftIO $ schnorrSign kp msg
-    sig <- maybe failure pure mSig
+    sig <- maybe failure pure $ schnorrSignDeterministic kp msg
     let a = sig
     annotateShow a
     annotateShow (length $ show a)
@@ -380,7 +395,7 @@ prop_schnorrSignatureParseInvertsSerialize = property $ do
     sk <- forAll secKeyGen
     msg <- forAll $ bytes (singleton 32)
     let kp = keyPairCreate sk
-    sig <- liftIO $ maybe (error "schnorrSign failed") pure =<< schnorrSign kp msg
+    sig <- maybe failure pure $ schnorrSignDeterministic kp msg
     let serialized = exportSchnorrSignature sig
     annotateShow serialized
     annotateShow (BS.length serialized)
@@ -393,22 +408,43 @@ prop_schnorrSignatureValidityPreservedOverSerialization = property $ do
     sk <- forAll secKeyGen
     msg <- forAll $ bytes (singleton 32)
     let kp = keyPairCreate sk
-    sig <- liftIO $ maybe (error "schnorrSign failed") pure =<< schnorrSign kp msg
+    sig <- maybe failure pure $ schnorrSignDeterministic kp msg
     let serialized = exportSchnorrSignature sig
     let parsed = importSchnorrSignature serialized
     parsed === Just sig
     assert $ schnorrVerify (fst $ keyPairPubKeyXO kp) msg sig
 
 
+prop_schnorrSignatureDeterministic :: Property
+prop_schnorrSignatureDeterministic = property $ do
+    sk <- forAll secKeyGen
+    msg <- forAll $ bytes (singleton 32)
+    let kp = keyPairCreate sk
+    sig1 <- maybe failure pure $ schnorrSignDeterministic kp msg
+    sig2 <- maybe failure pure $ schnorrSignDeterministic kp msg
+    sig1 === sig2
+
+
 prop_schnorrSignatureNonDeterministic :: Property
 prop_schnorrSignatureNonDeterministic = property $ do
     sk <- forAll secKeyGen
     msg <- forAll $ bytes (singleton 32)
     let kp = keyPairCreate sk
-    sig1 <- liftIO $ maybe (error "schnorrSign failed") pure =<< schnorrSign kp msg
-    sig2 <- liftIO $ maybe (error "schnorrSign failed") pure =<< schnorrSign kp msg
+    sig1 <- liftIO $ maybe (error "Failed to sign") pure =<< schnorrSignNondeterministic kp msg
+    sig2 <- liftIO $ maybe (error "Failed to sign") pure =<< schnorrSignNondeterministic kp msg
     sig1 /== sig2
 
 
+prop_schnorrSignWithStdGen :: Property
+prop_schnorrSignWithStdGen = property $ do
+    sk <- forAll secKeyGen
+    msg <- forAll $ bytes (singleton 32)
+    let kp = keyPairCreate sk
+    stdGen <- forAll $ mkStdGen <$> integral (linear 0 maxBound)
+    sig1 <- maybe failure pure $ schnorrSign (Just stdGen) kp msg
+    sig2 <- maybe failure pure $ schnorrSign (Just stdGen) kp msg
+    sig1 === sig2
+
+
 tests :: Group
 tests = $$discover