fixed issues with read/show inversion when types are part of derived instances

Author: ProofOfKeags

libsecp256k1.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           libsecp256k1
-version:        0.1.3
+version:        0.1.5
 synopsis:       Bindings for secp256k1
 description:    Sign and verify signatures using the secp256k1 library.
 category:       Crypto
@@ -45,7 +45,7 @@ library
     , deepseq >=1.4.8 && <1.5
     , entropy >=0.3.8 && <0.5
     , hashable >=1.4.2 && <1.5
-    , hedgehog ==1.2.*
+    , hedgehog >=1.2 && <1.5
     , memory >=0.14.15 && <1.0
     , transformers >=0.4.0.0 && <1.0
   default-language: Haskell2010
@@ -73,8 +73,9 @@ test-suite spec
     , either
     , entropy >=0.3.8 && <0.5
     , hashable >=1.4.2 && <1.5
-    , hedgehog ==1.2.*
+    , hedgehog >=1.2 && <1.5
     , hspec
+    , hspec-api
     , libsecp256k1
     , memory >=0.14.15 && <1.0
     , monad-par

package.yaml

@@ -1,5 +1,5 @@
 name: libsecp256k1
-version: 0.1.3
+version: 0.1.5
 synopsis: Bindings for secp256k1
 description: Sign and verify signatures using the secp256k1 library.
 category: Crypto
@@ -19,7 +19,7 @@ dependencies:
   - deepseq >=1.4.8 && <1.5
   - entropy >= 0.3.8 && <0.5
   - hashable >=1.4.2 && <1.5
-  - hedgehog >= 1.2 && <1.3
+  - hedgehog >= 1.2 && <1.5
   - memory >= 0.14.15 && <1.0
   - transformers >= 0.4.0.0 && <1.0
 default-extensions:
@@ -39,6 +39,7 @@ tests:
     dependencies:
       - either
       - hspec
+      - hspec-api
       - libsecp256k1
       - monad-par
       - HUnit

src/Crypto/Secp256k1.hs

@@ -93,6 +93,7 @@ import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
 import Data.ByteString.Char8 qualified as B8
 import Data.ByteString.Unsafe (unsafePackCStringLen, unsafePackMallocCStringLen)
+import Data.Char (isAlphaNum, isSpace)
 import Data.Foldable (for_)
 import Data.Functor (($>))
 import Data.Hashable (Hashable (..))
@@ -152,17 +153,15 @@ newtype SecKey = SecKey {secKeyFPtr :: ForeignPtr Prim.Seckey32}
 
 
 instance Show SecKey where
-    show SecKey{..} = unsafePerformIO . evalContT $ do
-        secKeyPtr <- ContT (withForeignPtr secKeyFPtr)
-        -- avoid allocating a new bytestring because we are only reading from this pointer
-        bs <- lift (Data.ByteString.Unsafe.unsafePackCStringLen (castPtr secKeyPtr, 32))
-        pure $ "0x" <> B8.unpack (BA.convertToBase BA.Base16 bs)
+    show sk = B8.unpack $ encodeBase16 $ exportSecKey sk
 instance Read SecKey where
-    readsPrec i s = case s of
-        ('0' : 'x' : cs) -> case decodeBase16 $ B8.pack (Prelude.take 64 cs) of
-            Left e -> []
-            Right a -> maybeToList $ (,Prelude.drop 64 cs) <$> importSecKey a
-        _ -> []
+    readsPrec i cs = case decodeBase16 . B8.pack $ pre of
+        Left e -> []
+        Right a -> case importSecKey a of
+            Nothing -> []
+            Just x -> [(x, suf)]
+        where
+            (pre, suf) = Prelude.splitAt 64 (dropWhile isSpace cs)
 instance Eq SecKey where
     sk == sk' = unsafePerformIO . evalContT $ do
         skp <- ContT $ withForeignPtr (secKeyFPtr sk)
@@ -184,16 +183,15 @@ newtype PubKeyXY = PubKeyXY {pubKeyXYFPtr :: ForeignPtr Prim.Pubkey64}
 
 
 instance Show PubKeyXY where
-    show pk = "0x" <> B8.unpack (BA.convertToBase BA.Base16 (exportPubKeyXY True pk))
+    show pk = B8.unpack (encodeBase16 (exportPubKeyXY True pk))
 instance Read PubKeyXY where
-    readsPrec i s = case s of
-        ('0' : 'x' : cs) -> maybeToList $ case cs of
-            ('0' : '2' : _) -> parseNextN 66 cs
-            ('0' : '3' : _) -> parseNextN 66 cs
-            ('0' : '4' : _) -> parseNextN 130 cs
-            _ -> Nothing
-        _ -> []
+    readsPrec i cs = maybeToList $ case trimmed of
+        ('0' : '2' : _) -> parseNextN 66 trimmed
+        ('0' : '3' : _) -> parseNextN 66 trimmed
+        ('0' : '4' : _) -> parseNextN 130 trimmed
+        _ -> Nothing
         where
+            trimmed = dropWhile isSpace cs
             hush x = case x of
                 Left _ -> Nothing
                 Right a -> Just a
@@ -223,13 +221,14 @@ newtype PubKeyXO = PubKeyXO {pubKeyXOFPtr :: ForeignPtr Prim.XonlyPubkey64}
 
 
 instance Show PubKeyXO where
-    show pk = "0x" <> B8.unpack (BA.convertToBase BA.Base16 (exportPubKeyXO pk))
+    show pk = B8.unpack (encodeBase16 (exportPubKeyXO pk))
 instance Read PubKeyXO where
-    readsPrec i s = case s of
-        ('0' : 'x' : bytes) -> case decodeBase16 $ B8.pack (Prelude.take 64 bytes) of
-            Left e -> []
-            Right a -> maybeToList $ (,Prelude.drop 64 bytes) <$> importPubKeyXO a
-        _ -> []
+    readsPrec i s = case decodeBase16 . B8.pack $ pre of
+        Left e -> error s
+        Right a -> maybeToList $ (,suf) <$> importPubKeyXO a
+        where
+            trimmed = dropWhile isSpace s
+            (pre, suf) = Prelude.splitAt 64 trimmed
 instance Eq PubKeyXO where
     pk == pk' = unsafePerformIO . evalContT $ do
         pkp <- ContT . withForeignPtr . pubKeyXOFPtr $ pk
@@ -266,7 +265,14 @@ newtype Signature = Signature {signatureFPtr :: ForeignPtr Prim.Sig64}
 
 
 instance Show Signature where
-    show sig = "0x" <> (B8.unpack . encodeBase16) (exportSignatureCompact sig)
+    show sig = (B8.unpack . encodeBase16) (exportSignatureCompact sig)
+instance Read Signature where
+    readsPrec i cs = case decodeBase16 $ B8.pack token of
+        Left e -> []
+        Right a -> maybeToList $ (,rest) <$> importSignature a
+        where
+            trimmed = dropWhile isSpace cs
+            (token, rest) = span isAlphaNum trimmed
 instance Eq Signature where
     sig == sig' = unsafePerformIO . evalContT $ do
         sigp <- ContT $ withForeignPtr (signatureFPtr sig)
@@ -281,7 +287,14 @@ newtype RecoverableSignature = RecoverableSignature {recoverableSignatureFPtr ::
 
 
 instance Show RecoverableSignature where
-    show recSig = "0x" <> (B8.unpack . encodeBase16) (exportRecoverableSignature recSig)
+    show recSig = (B8.unpack . encodeBase16) (exportRecoverableSignature recSig)
+instance Read RecoverableSignature where
+    readsPrec i cs = case decodeBase16 $ B8.pack token of
+        Left e -> error . show $ trimmed
+        Right a -> maybeToList $ (,rest) <$> importRecoverableSignature a
+        where
+            trimmed = dropWhile isSpace cs
+            (token, rest) = span isAlphaNum trimmed
 instance Eq RecoverableSignature where
     rs == rs' = unsafePerformIO . evalContT $ do
         rsp <- ContT $ withForeignPtr (recoverableSignatureFPtr rs)
@@ -297,6 +310,14 @@ newtype Tweak = Tweak {tweakFPtr :: ForeignPtr Prim.Tweak32}
 
 instance Show Tweak where
     show (Tweak fptr) = show (SecKey $ castForeignPtr fptr)
+instance Read Tweak where
+    readsPrec i cs = case decodeBase16 . B8.pack $ pre of
+        Left e -> []
+        Right a -> case importTweak a of
+            Nothing -> []
+            Just x -> [(x, suf)]
+        where
+            (pre, suf) = Prelude.splitAt 64 (dropWhile isSpace cs)
 
 
 instance Eq Tweak where

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-21.25
+resolver: lts-22.13
 nix:
   packages:
     - secp256k1

stack.yaml.lock

@@ -6,7 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    sha256: a81fb3877c4f9031e1325eb3935122e608d80715dc16b586eb11ddbff8671ecd
-    size: 640086
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/25.yaml
-  original: lts-21.25
+    sha256: 6f0bea3ba5b07360f25bc886e8cff8d847767557a492a6f7f6dcb06e3cc79ee9
+    size: 712905
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/13.yaml
+  original: lts-22.13

test/Crypto/Secp256k1Prop.hs

@@ -3,15 +3,17 @@
 
 module Crypto.Secp256k1Prop where
 
+import Control.Applicative (Applicative (liftA2), empty)
 import Control.Monad (when)
+import Control.Monad.Trans.Class (lift)
 import Crypto.Secp256k1
 import Crypto.Secp256k1.Gen
 import Data.ByteArray.Sized (sizedByteArray)
 import Data.ByteString qualified as BS
 import Data.Maybe (fromJust, isJust)
 import Data.Void
 import Hedgehog
-import Hedgehog.Gen hiding (discard, maybe)
+import Hedgehog.Gen hiding (discard, maybe, prune)
 import Hedgehog.Range (linear, singleton)
 import Text.Read (readMaybe)
 
@@ -99,12 +101,22 @@ prop_pubKeyXOSerializeInvertsParse = withDiscards 200 . property $ do
         Just pk -> exportPubKeyXO pk === bs
 
 
+prop_signatureReadInvertsShow :: Property
+prop_signatureReadInvertsShow = property $ do
+    sk <- forAll secKeyGen
+    bs <- forAll (bytes $ singleton 32)
+    sig <- maybe failure pure $ ecdsaSign sk bs
+    case readMaybe (show sig) of
+        Nothing -> failure
+        Just x -> sig === x
+
+
 prop_signatureParseInvertsSerialize :: Property
 prop_signatureParseInvertsSerialize = property $ do
     sk <- forAll secKeyGen
     bs <- forAll $ bytes (singleton 32)
 
-    sig <- maybe failure pure (ecdsaSign sk bs)
+    sig <- maybe failure pure $ ecdsaSign sk bs
 
     exportDer <- forAll $ element [False, True]
     let export = if exportDer then exportSignatureDer else exportSignatureCompact
@@ -116,6 +128,17 @@ prop_signatureParseInvertsSerialize = property $ do
         Just x -> x === sig
 
 
+prop_recoverableSignatureReadInvertsShow :: Property
+prop_recoverableSignatureReadInvertsShow = property $ do
+    sk <- forAll secKeyGen
+    bs <- forAll $ bytes (singleton 32)
+    recSig <- maybe failure pure $ ecdsaSignRecoverable sk bs
+    let export = exportRecoverableSignature recSig
+    case importRecoverableSignature export of
+        Nothing -> failure
+        Just x -> x === recSig
+
+
 prop_recoverableSignatureParseInvertsSerialize :: Property
 prop_recoverableSignatureParseInvertsSerialize = property $ do
     sk <- forAll secKeyGen
@@ -141,7 +164,8 @@ prop_ecdsaSignaturesProducedAreValid :: Property
 prop_ecdsaSignaturesProducedAreValid = property $ do
     sk <- forAll secKeyGen
     msg <- forAll $ bytes (singleton 32)
-    case ecdsaSign sk msg of
+    let sig = ecdsaSign sk msg
+    case sig of
         Nothing -> failure
         Just sig -> assert $ ecdsaVerify msg (derivePubKey sk) sig
 
@@ -159,7 +183,7 @@ prop_ecdsaSignatureValidityPreservedOverSerialization :: Property
 prop_ecdsaSignatureValidityPreservedOverSerialization = property $ do
     sk <- forAll secKeyGen
     msg <- forAll $ bytes (singleton 32)
-    let sig = fromJust $ ecdsaSign sk msg
+    sig <- maybe failure pure $ ecdsaSign sk msg
     useDer <- forAll enumBounded
     let export =
             if useDer
@@ -260,7 +284,8 @@ prop_ecdsaSignaturesUnforgeable = property $ do
     pk <- forAll pubKeyXYGen
     when (pk == derivePubKey sk) discard
     msg <- forAll $ bytes (singleton 32)
-    case ecdsaSign sk msg of
+    let sig = ecdsaSign sk msg
+    case sig of
         Nothing -> failure
         Just sig -> assert . not $ ecdsaVerify msg pk sig
 
@@ -276,5 +301,58 @@ prop_schnorrSignaturesUnforgeable = property $ do
         Just sig -> assert . not $ schnorrVerify pk msg sig
 
 
+newtype Wrapped a = Wrapped {secKey :: a} deriving (Show, Read, Eq)
+
+
+derivedCompositeReadShowInvertTemplate :: (Eq a, Read a, Show a) => Gen a -> Property
+derivedCompositeReadShowInvertTemplate gen = property $ do
+    a <- forAll gen
+    annotateShow a
+    annotateShow (length $ show a)
+    annotateShow (Wrapped a)
+    case readMaybe (show (Wrapped a)) of
+        Nothing -> failure
+        Just x -> x === Wrapped a
+
+
+prop_derivedCompositeReadShowInvertSecKey :: Property
+prop_derivedCompositeReadShowInvertSecKey = derivedCompositeReadShowInvertTemplate secKeyGen
+
+
+prop_derivedCompositeReadShowInvertPubKeyXY :: Property
+prop_derivedCompositeReadShowInvertPubKeyXY = derivedCompositeReadShowInvertTemplate pubKeyXYGen
+
+
+prop_derivedCompositeReadShowInvertPubKeyXO :: Property
+prop_derivedCompositeReadShowInvertPubKeyXO = derivedCompositeReadShowInvertTemplate pubKeyXOGen
+
+
+prop_derivedCompositeReadShowInvertTweak :: Property
+prop_derivedCompositeReadShowInvertTweak = derivedCompositeReadShowInvertTemplate tweakGen
+
+
+prop_derivedCompositeReadShowInvertSignature :: Property
+prop_derivedCompositeReadShowInvertSignature = derivedCompositeReadShowInvertTemplate $ choice [ecdsa, schnorr]
+    where
+        base = liftA2 (,) secKeyGen (bytes (singleton 32))
+        ecdsa = base >>= maybe empty pure . uncurry ecdsaSign
+        schnorr = base >>= maybe empty pure . uncurry (schnorrSign . keyPairCreate)
+
+
+prop_derivedCompositeReadShowInvertRecoverableSignature :: Property
+prop_derivedCompositeReadShowInvertRecoverableSignature = derivedCompositeReadShowInvertTemplate $ do
+    sk <- secKeyGen
+    msg <- bytes (singleton 32)
+    maybe empty pure $ ecdsaSignRecoverable sk msg
+
+
+prop_eqImportImpliesEqSecKey :: Property
+prop_eqImportImpliesEqSecKey = property $ do
+    bs <- forAll $ bytes $ singleton 32
+    k0 <- maybe discard pure $ importSecKey bs
+    k1 <- maybe discard pure $ importSecKey bs
+    k0 === k1
+
+
 tests :: Group
 tests = $$discover

test/Main.hs

@@ -1,18 +1,19 @@
 module Main where
 
+import Crypto.Secp256k1
 import Crypto.Secp256k1Prop qualified as Secp256k1Prop
 import GHC.IO.Encoding (setLocaleEncoding, utf8)
 import Hedgehog (checkSequential)
 import Hedgehog.Main
 import Spec qualified
-import Test.Hspec.Formatters
+import Test.Hspec.Api.Formatters.V1
 import Test.Hspec.Runner (Config (..), defaultConfig, hspecWith)
 
 
 main :: IO ()
 main = do
     setLocaleEncoding utf8
-    hspecWith defaultConfig{configFormatter = Just progress} Spec.spec
+    hspecWith (useFormatter ("progress", progress) defaultConfig) Spec.spec
     defaultMain
         [ checkSequential Secp256k1Prop.tests
         ]