Utilities for testing Marshal and MarshalJSON classes (#415)

* Adding tools for performing Marshal and MarshalJSON identity tests

* New dependency on data-default

* Renamed some arbitrary (test) functions for clarity

CHANGELOG.md

@@ -5,6 +5,14 @@ All notable changes to this project will be documented in this file.
 The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/)
 and this project adheres to [Semantic Versioning](http://semver.org/spec/v2.0.0.html).
 
+## [1.0.3] - 2023-09-02
+
+### Changed
+
+- New dependency on data-default
+- Renamed some arbitrary (test) functions for clarity
+- Reworked the identity testing tool to include Marshal and MarshalJSON classes
+
 ## [1.0.2] - 2023-08-04
 
 ### Fixed

haskoin-core.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           haskoin-core
-version:        1.0.2
+version:        1.0.3
 synopsis:       Bitcoin & Bitcoin Cash library for Haskell
 description:    Please see the README on GitHub at <https://github.com/haskoin/haskoin-core#readme>
 category:       Bitcoin, Finance, Network
@@ -118,6 +118,7 @@ library
     , conduit >=1.3.1.2
     , containers >=0.6.2.1
     , cryptonite >=0.26
+    , data-default >=0.7.1.1
     , deepseq >=1.4.4.0
     , entropy >=0.4.1.5
     , hashable >=1.3.0.0
@@ -175,6 +176,7 @@ test-suite spec
     , conduit >=1.3.1.2
     , containers >=0.6.2.1
     , cryptonite >=0.26
+    , data-default >=0.7.1.1
     , deepseq >=1.4.4.0
     , entropy >=0.4.1.5
     , hashable >=1.3.0.0

package.yaml

@@ -1,5 +1,5 @@
 name: haskoin-core
-version: 1.0.2
+version: 1.0.3
 synopsis: Bitcoin & Bitcoin Cash library for Haskell
 description: Please see the README on GitHub at <https://github.com/haskoin/haskoin-core#readme>
 category: Bitcoin, Finance, Network
@@ -31,6 +31,7 @@ dependencies:
   - containers >= 0.6.2.1
   - cryptonite >= 0.26
   - deepseq >= 1.4.4.0
+  - data-default >= 0.7.1.1
   - entropy >= 0.4.1.5
   - hashable >= 1.3.0.0
   - hspec >= 2.7.1

src/Haskoin/Util/Arbitrary/Keys.hs

@@ -24,6 +24,10 @@ import Test.QuickCheck
 arbitraryPrivateKey :: Gen PrivateKey
 arbitraryPrivateKey = wrapSecKey <$> arbitrary <*> arbitrary
 
+-- | Arbitrary public key, either compressed or not.
+arbitraryPublicKey :: Ctx -> Gen PublicKey
+arbitraryPublicKey ctx = snd <$> arbitraryKeyPair ctx
+
 -- | Arbitrary keypair, both either compressed or not.
 arbitraryKeyPair :: Ctx -> Gen (PrivateKey, PublicKey)
 arbitraryKeyPair ctx = do
@@ -43,9 +47,13 @@ arbitraryXPrvKey =
     <*> arbitraryHash256
     <*> arbitrary
 
+-- | Arbitrary extended public key.
+arbitraryXPubKey :: Ctx -> Gen XPubKey
+arbitraryXPubKey ctx = snd <$> arbitraryXKeyPair ctx
+
 -- | Arbitrary extended public key with its corresponding private key.
-arbitraryXPubKey :: Ctx -> Gen (XPrvKey, XPubKey)
-arbitraryXPubKey ctx = (\k -> (k, deriveXPubKey ctx k)) <$> arbitraryXPrvKey
+arbitraryXKeyPair :: Ctx -> Gen (XPrvKey, XPubKey)
+arbitraryXKeyPair ctx = (\k -> (k, deriveXPubKey ctx k)) <$> arbitraryXPrvKey
 
 {- Custom derivations -}
 

src/Haskoin/Util/Arbitrary/Util.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 -- |
@@ -18,17 +19,16 @@ module Haskoin.Util.Arbitrary.Util
     arbitraryMaybe,
     arbitraryNetwork,
     arbitraryUTCTime,
-    SerialBox (..),
-    JsonBox (..),
-    NetBox (..),
     ReadBox (..),
+    JsonBox (..),
+    MarshalJsonBox (..),
+    SerialBox (..),
+    MarshalBox (..),
+    IdentityTests (..),
     testIdentity,
     testSerial,
     testRead,
     testJson,
-    testNetJson,
-    arbitraryNetData,
-    genNetData,
   )
 where
 
@@ -42,14 +42,17 @@ import qualified Data.ByteString.Short as BSS
 import Data.Bytes.Get
 import Data.Bytes.Put
 import Data.Bytes.Serial
+import Data.Default
 import qualified Data.Map.Strict as Map
 import Data.Proxy
 import Data.Time.Clock (UTCTime (..))
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 import qualified Data.Typeable as T
 import Data.Word (Word32)
+import Haskoin.Crypto (Ctx)
 import Haskoin.Network.Constants
 import Haskoin.Network.Data
+import Haskoin.Util
 import Test.Hspec (Spec, describe, shouldBe, shouldSatisfy)
 import Test.Hspec.QuickCheck (prop)
 import Test.QuickCheck
@@ -98,10 +101,8 @@ arbitraryNetwork = elements allNets
 
 -- Helpers for creating Serial and JSON Identity tests
 
-data SerialBox
-  = forall a.
-    (Show a, Eq a, T.Typeable a, Serial a) =>
-    SerialBox (Gen a)
+instance Show Ctx where
+  show _ = "Ctx"
 
 data ReadBox
   = forall a.
@@ -113,30 +114,68 @@ data JsonBox
     (Show a, Eq a, T.Typeable a, A.ToJSON a, A.FromJSON a) =>
     JsonBox (Gen a)
 
-data NetBox
+data MarshalJsonBox
+  = forall s a.
+    (Show a, Show s, Eq a, T.Typeable a, MarshalJSON s a) =>
+    MarshalJsonBox (Gen (s, a))
+
+data SerialBox
   = forall a.
-    (Show a, Eq a, T.Typeable a) =>
-    NetBox
-      ( Network -> a -> A.Value,
-        Network -> a -> A.Encoding,
-        Network -> A.Value -> A.Parser a,
-        Gen (Network, a)
-      )
-
-testIdentity :: [SerialBox] -> [ReadBox] -> [JsonBox] -> [NetBox] -> Spec
-testIdentity serialVals readVals jsonVals netVals = do
-  describe "Binary Encoding" $
-    forM_ serialVals $
-      \(SerialBox g) -> testSerial g
+    (Show a, Eq a, T.Typeable a, Serial a) =>
+    SerialBox (Gen a)
+
+data MarshalBox
+  = forall s a.
+    (Show a, Show s, Eq a, T.Typeable a, Marshal s a) =>
+    MarshalBox (Gen (s, a))
+
+data IdentityTests = IdentityTests
+  { readTests :: [ReadBox],
+    jsonTests :: [JsonBox],
+    marshalJsonTests :: [MarshalJsonBox],
+    serialTests :: [SerialBox],
+    marshalTests :: [MarshalBox]
+  }
+
+instance Default IdentityTests where
+  def =
+    IdentityTests
+      { readTests = [],
+        jsonTests = [],
+        marshalJsonTests = [],
+        serialTests = [],
+        marshalTests = []
+      }
+
+testIdentity :: IdentityTests -> Spec
+testIdentity t = do
   describe "Read/Show Encoding" $
-    forM_ readVals $
+    forM_ t.readTests $
       \(ReadBox g) -> testRead g
   describe "Data.Aeson Encoding" $
-    forM_ jsonVals $
+    forM_ t.jsonTests $
       \(JsonBox g) -> testJson g
-  describe "Data.Aeson Encoding with Network" $
-    forM_ netVals $
-      \(NetBox (j, e, p, g)) -> testNetJson j e p g
+  describe "MarshalJSON Encoding" $
+    forM_ t.marshalJsonTests $
+      \(MarshalJsonBox g) -> testMarshalJson g
+  describe "Binary Encoding" $
+    forM_ t.serialTests $
+      \(SerialBox g) -> testSerial g
+  describe "Marshal Encoding" $
+    forM_ t.marshalTests $
+      \(MarshalBox g) -> testMarshal g
+
+-- | Generate Read/Show identity tests
+testRead ::
+  (Eq a, Read a, Show a, T.Typeable a) => Gen a -> Spec
+testRead gen =
+  prop ("read/show identity for " <> name) $
+    forAll gen $
+      \x -> (read . show) x `shouldBe` x
+  where
+    name = show $ T.typeRep $ proxy gen
+    proxy :: Gen a -> Proxy a
+    proxy = const Proxy
 
 -- | Generate binary identity tests
 testSerial ::
@@ -153,16 +192,19 @@ testSerial gen =
     proxy :: Gen a -> Proxy a
     proxy = const Proxy
 
--- | Generate Read/Show identity tests
-testRead ::
-  (Eq a, Read a, Show a, T.Typeable a) => Gen a -> Spec
-testRead gen =
-  prop ("read/show identity for " <> name) $
-    forAll gen $
-      \x -> (read . show) x `shouldBe` x
+-- | Generate Marshal identity tests
+testMarshal ::
+  (Eq a, Show a, Show s, T.Typeable a, Marshal s a) =>
+  Gen (s, a) ->
+  Spec
+testMarshal gen = do
+  prop ("Marshal marshalPut/marshalGet identity for " <> name) $
+    forAll gen $ \(s, a) -> do
+      (unmarshal s . marshal s) a `shouldBe` Right a
+      (unmarshalLazy s . marshalLazy s) a `shouldBe` a
   where
     name = show $ T.typeRep $ proxy gen
-    proxy :: Gen a -> Proxy a
+    proxy :: Gen (s, a) -> Proxy a
     proxy = const Proxy
 
 -- | Generate Data.Aeson identity tests
@@ -182,40 +224,25 @@ testJson gen = do
       (A.decode . A.encodingToLazyByteString . A.toEncoding) (toMap x)
         == Just (toMap x)
 
--- | Generate Data.Aeson identity tests for type that need the @Network@
-testNetJson ::
-  (Eq a, Show a, T.Typeable a) =>
-  (Network -> a -> A.Value) ->
-  (Network -> a -> A.Encoding) ->
-  (Network -> A.Value -> A.Parser a) ->
-  Gen (Network, a) ->
+-- | Generate MarshalJSON identity tests
+testMarshalJson ::
+  (Eq a, Show a, Show s, T.Typeable a, MarshalJSON s a) =>
+  Gen (s, a) ->
   Spec
-testNetJson j e p g = do
-  prop ("Data.Aeson toJSON/fromJSON identity (with network) for " <> name) $
-    forAll g $
-      \(net, x) -> dec net (encVal net x) `shouldBe` Just x
-  prop ("Data.Aeson toEncoding/fromJSON identity (with network) for " <> name) $
-    forAll g $
-      \(net, x) -> dec net (encEnc net x) `shouldBe` Just x
+testMarshalJson gen = do
+  prop ("MarshalJSON marshalValue/unmarshalValue identity for " <> name) $
+    forAll gen $
+      \(s, a) -> a `shouldSatisfy` marshalJsonID s
+  prop ("MarshalJSON marshalEncoding/unmarshalValue identity for " <> name) $
+    forAll gen $
+      \(s, a) -> a `shouldSatisfy` marshalEncodingID s
   where
-    encVal net = A.encode . toMap . j net
-    encEnc net = A.encodingToLazyByteString . toMapE . e net
-    dec net = A.parseMaybe (p net) . fromMap <=< A.decode
-    name = show $ T.typeRep $ proxy j
-    proxy :: (Network -> a -> A.Value) -> Proxy a
+    name = show $ T.typeRep $ proxy gen
+    proxy :: Gen (s, a) -> Proxy a
     proxy = const Proxy
-
-arbitraryNetData :: (Arbitrary a) => Gen (Network, a)
-arbitraryNetData = do
-  net <- arbitraryNetwork
-  x <- arbitrary
-  return (net, x)
-
-genNetData :: Gen a -> Gen (Network, a)
-genNetData gen = do
-  net <- arbitraryNetwork
-  x <- gen
-  return (net, x)
+    marshalJsonID s a =
+      A.parseMaybe (unmarshalValue s) (marshalValue s a) == Just a
+    marshalEncodingID s a = unmarshalJSON s (marshalJSON s a) == Just a
 
 toMap :: a -> Map.Map String a
 toMap = Map.singleton "object"

test/Haskoin/AddressSpec.hs

@@ -5,6 +5,7 @@ module Haskoin.AddressSpec (spec) where
 
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as B
+import Data.Default (def)
 import Data.Maybe (fromJust, isJust)
 import Data.Text (Text)
 import Data.Text qualified as T
@@ -19,19 +20,17 @@ import Test.Hspec
 import Test.Hspec.QuickCheck
 import Test.QuickCheck
 
-serialVals :: [SerialBox]
-serialVals = [SerialBox arbitraryAddressAll]
-
-readVals :: [ReadBox]
-readVals = [ReadBox arbitraryAddressAll]
-
-netVals :: [NetBox]
-netVals =
-  [NetBox (marshalValue, marshalEncoding, unmarshalValue, arbitraryNetAddress)]
+identityTests :: IdentityTests
+identityTests =
+  def
+    { readTests = [ReadBox arbitraryAddressAll],
+      serialTests = [SerialBox arbitraryAddressAll],
+      marshalJsonTests = [MarshalJsonBox arbitraryNetAddress]
+    }
 
 spec :: Spec
 spec = prepareContext $ \ctx -> do
-  testIdentity serialVals readVals [] netVals
+  testIdentity identityTests
   describe "Address properties" $ do
     prop "encodes and decodes base58 bytestring" $
       forAll arbitraryBS $ \bs ->