Add SchnorrSignature type with parsing and serialization

libsecp256k1.cabal

@@ -47,6 +47,7 @@ library
     , hashable >=1.4.2 && <1.5
     , hedgehog >=1.2 && <1.5
     , memory >=0.14.15 && <1.0
+    , random >=1.2.1.2 && <1.3
     , transformers >=0.4.0.0 && <1.0
   default-language: Haskell2010
 
@@ -79,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

package.yaml

@@ -21,6 +21,7 @@ dependencies:
   - hashable >=1.4.2 && <1.5
   - hedgehog >= 1.2 && <1.5
   - memory >= 0.14.15 && <1.0
+  - random >=1.2.1.2 && <1.3
   - transformers >= 0.4.0.0 && <1.0
 default-extensions:
   - ImportQualifiedPost

src/Crypto/Secp256k1.hs

@@ -25,6 +25,7 @@ module Crypto.Secp256k1 (
     KeyPair,
     Signature,
     RecoverableSignature,
+    SchnorrSignature,
     Tweak,
 
     -- * Parsing and Serialization
@@ -40,6 +41,8 @@ module Crypto.Secp256k1 (
     exportSignatureDer,
     importRecoverableSignature,
     exportRecoverableSignature,
+    importSchnorrSignature,
+    exportSchnorrSignature,
     importTweak,
 
     -- * ECDSA Operations
@@ -73,6 +76,8 @@ module Crypto.Secp256k1 (
 
     -- * Schnorr Operations
     schnorrSign,
+    schnorrSignDeterministic,
+    schnorrSignNondeterministic,
     schnorrVerify,
 
     -- * Other
@@ -140,6 +145,7 @@ import Foreign.Storable (Storable (..))
 import GHC.Generics (Generic)
 import GHC.IO.Handle.Text (memcpy)
 import System.IO.Unsafe (unsafePerformIO)
+import System.Random (StdGen, newStdGen, randoms, randomIO)
 import Text.Read (
     Lexeme (String),
     lexP,
@@ -283,6 +289,28 @@ instance NFData Signature where
     rnf Signature{..} = seq signatureFPtr ()
 
 
+-- | Structure containing Schnorr Signature
+newtype SchnorrSignature = SchnorrSignature {schnorrSignatureFPtr :: ForeignPtr Prim.Sig64}
+
+
+instance Show SchnorrSignature where
+    show sig = (B8.unpack . encodeBase16) (exportSchnorrSignature sig)
+instance Read SchnorrSignature where
+    readsPrec i cs = case decodeBase16 $ B8.pack token of
+        Left e -> []
+        Right a -> maybeToList $ (,rest) <$> importSchnorrSignature a
+        where
+            trimmed = dropWhile isSpace cs
+            (token, rest) = span isAlphaNum trimmed
+instance Eq SchnorrSignature where
+    sig == sig' = unsafePerformIO . evalContT $ do
+        sigp <- ContT $ withForeignPtr (schnorrSignatureFPtr sig)
+        sigp' <- ContT $ withForeignPtr (schnorrSignatureFPtr sig')
+        (EQ ==) <$> lift (memCompare (castPtr sigp) (castPtr sigp') 64)
+instance NFData SchnorrSignature where
+    rnf SchnorrSignature{..} = seq schnorrSignatureFPtr ()
+
+
 -- | Structure containing Signature AND recovery ID
 newtype RecoverableSignature = RecoverableSignature {recoverableSignatureFPtr :: ForeignPtr Prim.RecSig65}
 
@@ -493,6 +521,23 @@ exportRecoverableSignature RecoverableSignature{..} = unsafePerformIO . evalCont
         unsafePackByteString (outBuf, 65)
 
 
+-- | Parses 'SchnorrSignature' from Schnorr (64 byte) representation
+importSchnorrSignature :: ByteString -> Maybe SchnorrSignature
+importSchnorrSignature bs
+    | BS.length bs /= 64 = Nothing
+    | otherwise = unsafePerformIO $ do
+        outBuf <- mallocBytes 64
+        unsafeUseByteString bs $ \(ptr, _) -> do
+            memcpy outBuf ptr 64
+        Just . SchnorrSignature <$> newForeignPtr finalizerFree outBuf
+
+
+-- | Serializes 'SchnorrSignature' to Schnorr (64 byte) representation
+exportSchnorrSignature :: SchnorrSignature -> ByteString
+exportSchnorrSignature (SchnorrSignature fptr) = unsafePerformIO $
+    withForeignPtr fptr $ \ptr -> BS.packCStringLen (castPtr ptr, 64)
+
+
 -- | Parses 'Tweak' from 32 byte @ByteString@. If the @ByteString@ is an invalid 'SecKey' then this will yield @Nothing@
 importTweak :: ByteString -> Maybe Tweak
 importTweak = fmap (Tweak . castForeignPtr . secKeyFPtr) . importSecKey
@@ -700,30 +745,47 @@ 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 -> Maybe Signature
-schnorrSign KeyPair{..} bs
+-- | 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
-            -- TODO: provide randomness here instead of supplying a null pointer
-            ret <- Prim.schnorrsigSign ctx sigBuf msgHashPtr keyPairPtr nullPtr
+            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 . Signature <$> newForeignPtr finalizerFree sigBuf
-                else free sigBuf $> Nothing
+                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.
-schnorrVerify :: PubKeyXO -> ByteString -> Signature -> Bool
-schnorrVerify PubKeyXO{..} bs Signature{..} = unsafePerformIO . evalContT $ do
+schnorrVerify :: PubKeyXO -> ByteString -> SchnorrSignature -> Bool
+schnorrVerify PubKeyXO{..} bs SchnorrSignature{..} = unsafePerformIO . evalContT $ do
     pubKeyPtr <- ContT (withForeignPtr pubKeyXOFPtr)
-    signaturePtr <- ContT (withForeignPtr signatureFPtr)
+    schnorrSignaturePtr <- ContT (withForeignPtr schnorrSignatureFPtr)
     (msgPtr, msgLen) <- ContT (unsafeUseByteString bs)
-    lift $ isSuccess <$> Prim.schnorrsigSignVerify ctx signaturePtr msgPtr msgLen pubKeyPtr
+    lift $ isSuccess <$> Prim.schnorrsigSignVerify ctx schnorrSignaturePtr msgPtr msgLen pubKeyPtr
 
 
 -- | Generate a tagged sha256 digest as specified in BIP340

test/Crypto/Secp256k1Prop.hs

@@ -5,6 +5,7 @@ module Crypto.Secp256k1Prop where
 
 import Control.Applicative (Applicative (liftA2), empty)
 import Control.Monad (when)
+import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Class (lift)
 import Crypto.Secp256k1
 import Crypto.Secp256k1.Gen
@@ -16,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
@@ -260,9 +262,17 @@ prop_schnorrSignaturesProducedAreValid = property $ do
     sk <- forAll secKeyGen
     msg <- forAll $ bytes (singleton 32)
     let kp = keyPairCreate sk
-    case schnorrSign kp msg of
-        Nothing -> failure
-        Just sig -> assert $ schnorrVerify (fst $ keyPairPubKeyXO kp) msg sig
+    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
@@ -297,9 +307,18 @@ prop_schnorrSignaturesUnforgeable = property $ do
     let kp = keyPairCreate sk
     pk <- forAll pubKeyXOGen
     msg <- forAll $ bytes (singleton 32)
-    case schnorrSign kp msg of
-        Nothing -> failure
-        Just sig -> assert . not $ schnorrVerify pk msg sig
+    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)
@@ -333,11 +352,27 @@ prop_derivedCompositeReadShowInvertTweak = derivedCompositeReadShowInvertTemplat
 
 
 prop_derivedCompositeReadShowInvertSignature :: Property
-prop_derivedCompositeReadShowInvertSignature = derivedCompositeReadShowInvertTemplate $ choice [ecdsa, schnorr]
+prop_derivedCompositeReadShowInvertSignature = derivedCompositeReadShowInvertTemplate ecdsaSignGen
     where
-        base = liftA2 (,) secKeyGen (bytes (singleton 32))
-        ecdsa = base >>= maybe empty pure . uncurry ecdsaSign
-        schnorr = base >>= maybe empty pure . uncurry (schnorrSign . keyPairCreate)
+        ecdsaSignGen = do
+            sk <- secKeyGen
+            msg <- bytes (singleton 32)
+            maybe empty pure $ ecdsaSign sk msg
+
+
+prop_derivedCompositeReadShowInvertSchnorrSignature :: Property
+prop_derivedCompositeReadShowInvertSchnorrSignature = property $ do
+    sk <- forAll secKeyGen
+    let kp = keyPairCreate sk
+    msg <- forAll $ bytes (singleton 32)
+    sig <- maybe failure pure $ schnorrSignDeterministic kp msg
+    let a = sig
+    annotateShow a
+    annotateShow (length $ show a)
+    annotateShow (Wrapped a)
+    case readMaybe (show (Wrapped a)) of
+        Nothing -> failure
+        Just x  -> x === Wrapped a
 
 
 prop_derivedCompositeReadShowInvertRecoverableSignature :: Property
@@ -355,5 +390,61 @@ prop_eqImportImpliesEqSecKey = property $ do
     k0 === k1
 
 
+prop_schnorrSignatureParseInvertsSerialize :: Property
+prop_schnorrSignatureParseInvertsSerialize = property $ do
+    sk <- forAll secKeyGen
+    msg <- forAll $ bytes (singleton 32)
+    let kp = keyPairCreate sk
+    sig <- maybe failure pure $ schnorrSignDeterministic kp msg
+    let serialized = exportSchnorrSignature sig
+    annotateShow serialized
+    annotateShow (BS.length serialized)
+    let parsed = importSchnorrSignature serialized
+    parsed === Just sig
+
+
+prop_schnorrSignatureValidityPreservedOverSerialization :: Property
+prop_schnorrSignatureValidityPreservedOverSerialization = property $ do
+    sk <- forAll secKeyGen
+    msg <- forAll $ bytes (singleton 32)
+    let kp = keyPairCreate sk
+    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 "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
+tests = $$discover