Propagate UTxO-HD to ouroboros-consensus-test (#4363)

-- * Use MKs in `ouroboros-consensus-test` Co-authored-by: Nick Frisby <nick.frisby@iohk.io> Co-authored-by: Damian Nadales <damian.nadales@iohk.io> Co-authored-by: Joris Dral <joris@well-typed.com> skip-checks: true -- * Some stylish changes in `ouroboros-consensus` after it was merged --------- Co-authored-by: Nick Frisby <nick.frisby@iohk.io> Co-authored-by: Damian Nadales <damian.nadales@iohk.io> Co-authored-by: Joris Dral <joris@well-typed.com>
IntersectMBO · Mar 21, 2023 · 24ff4fd · 24ff4fd
1 parent f7a8a57
commit 24ff4fd
Show file tree

Hide file tree

Showing 68 changed files with 5,364 additions and 758 deletions.
diff --git a/cabal.project b/cabal.project
@@ -148,3 +148,9 @@ constraints:
 
 allow-newer:
     Unique:hashable
+
+source-repository-package
+  type: git
+  location: https://github.com/stevana/quickcheck-state-machine
+  tag: dba5d7edea6304c410d13182747d2cc483f134f3
+  --sha256: 13za4y26w2wi1fd9l3q40ln2ixm3pqccs0bawbbf230asdci56nf
diff --git a/ouroboros-consensus-mock-test/ouroboros-consensus-mock-test.cabal b/ouroboros-consensus-mock-test/ouroboros-consensus-mock-test.cabal
@@ -59,6 +59,7 @@ test-suite test
   main-is:             Main.hs
   other-modules:
                        Test.Consensus.Ledger.Mock
+                       Test.Consensus.Ledger.Mock.LedgerTables
 
                        Test.ThreadNet.BFT
                        Test.ThreadNet.LeaderSchedule

diff --git a/ouroboros-consensus-mock-test/src/Test/Consensus/Ledger/Mock/Generators.hs b/ouroboros-consensus-mock-test/src/Test/Consensus/Ledger/Mock/Generators.hs
@@ -25,7 +25,10 @@ import           Test.QuickCheck
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.HeaderValidation
+import           Ouroboros.Consensus.Ledger.Basics
+import           Ouroboros.Consensus.Ledger.Query
 import           Ouroboros.Consensus.Ledger.SupportsMempool
+import           Ouroboros.Consensus.Ledger.Tables.Utils
 import           Ouroboros.Consensus.Protocol.BFT
 
 import           Ouroboros.Consensus.Mock.Ledger.Block
@@ -110,8 +113,18 @@ instance Arbitrary (SomeSecond BlockQuery (SimpleBlock c ext)) where
 instance (SimpleCrypto c, Typeable ext) => Arbitrary (SomeResult (SimpleBlock c ext)) where
   arbitrary = SomeResult QueryLedgerTip <$> arbitrary
 
-instance Arbitrary (LedgerState (SimpleBlock c ext)) where
-  arbitrary = SimpleLedgerState <$> arbitrary
+instance (SimpleCrypto c, Typeable ext)
+         => Arbitrary (LedgerState (SimpleBlock c ext) EmptyMK) where
+  arbitrary =
+        forgetLedgerTables
+    <$> arbitrary @(LedgerState (SimpleBlock c ext) ValuesMK)
+
+instance (SimpleCrypto c, Typeable ext)
+         => Arbitrary (LedgerState (SimpleBlock c ext) ValuesMK) where
+  arbitrary =
+        unstowLedgerTables
+    .   flip SimpleLedgerState emptyLedgerTables
+    <$> arbitrary
 
 instance HashAlgorithm (SimpleHash c) => Arbitrary (AnnTip (SimpleBlock c ext)) where
   arbitrary = do

diff --git a/ouroboros-consensus-mock-test/src/Test/ThreadNet/TxGen/Mock.hs b/ouroboros-consensus-mock-test/src/Test/ThreadNet/TxGen/Mock.hs
@@ -9,6 +9,7 @@ import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 
 import           Ouroboros.Consensus.Block
+import           Ouroboros.Consensus.Ledger.Tables
 import           Ouroboros.Consensus.Mock.Ledger
 
 import           Test.QuickCheck hiding (elements)
@@ -32,7 +33,7 @@ instance TxGen (SimpleBlock SimpleMockCrypto ext) where
       addrs = Map.keys $ mkAddrDist numCoreNodes
 
       utxo :: Utxo
-      utxo = mockUtxo $ simpleLedgerState ledgerState
+      utxo = mockUtxo $ simpleLedgerState $ stowLedgerTables ledgerState
 
 genSimpleTx :: SlotNo -> [Addr] -> Utxo -> Gen Tx
 genSimpleTx curSlotNo addrs u = do

diff --git a/ouroboros-consensus-mock-test/test/Main.hs b/ouroboros-consensus-mock-test/test/Main.hs
@@ -3,6 +3,7 @@ module Main (main) where
 import           Test.Tasty
 
 import qualified Test.Consensus.Ledger.Mock (tests)
+import qualified Test.Consensus.Ledger.Mock.LedgerTables (tests)
 import qualified Test.ThreadNet.BFT (tests)
 import qualified Test.ThreadNet.LeaderSchedule (tests)
 import qualified Test.ThreadNet.PBFT (tests)
@@ -17,15 +18,9 @@ tests :: TestTree
 tests =
   testGroup "ouroboros-consensus"
   [ Test.Consensus.Ledger.Mock.tests
+  , Test.Consensus.Ledger.Mock.LedgerTables.tests
   , Test.ThreadNet.BFT.tests
   , Test.ThreadNet.LeaderSchedule.tests
   , Test.ThreadNet.PBFT.tests
   , Test.ThreadNet.Praos.tests
   ]
-
--- Counter to address the zfs copy bug on Hydra
--- ```
--- cannot execute binary file: Exec format error
--- ```
---
--- 3
diff --git a/ouroboros-consensus-mock-test/test/Test/Consensus/Ledger/Mock/LedgerTables.hs b/ouroboros-consensus-mock-test/test/Test/Consensus/Ledger/Mock/LedgerTables.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Test.Consensus.Ledger.Mock.LedgerTables (tests) where
+
+import           Test.Consensus.Ledger.Mock.Generators ()
+import           Test.LedgerTables
+
+import           Ouroboros.Consensus.Ledger.Basics
+import           Ouroboros.Consensus.Mock.Ledger
+import           Ouroboros.Consensus.Protocol.PBFT
+import           Test.Tasty
+import           Test.Tasty.QuickCheck
+
+type Block = SimpleBlock SimpleMockCrypto (SimplePBftExt SimpleMockCrypto PBftMockCrypto)
+
+tests :: TestTree
+tests = testGroup "LedgerTables"
+  [ testProperty "Stowable laws" (prop_stowable_laws @Block)
+  , testProperty "TableStuff laws" (prop_tablestuff_laws @Block)
+  ]
+
+instance Arbitrary (LedgerTables (LedgerState Block) ValuesMK) where
+  arbitrary = projectLedgerTables <$> arbitrary
diff --git a/ouroboros-consensus-mock/ouroboros-consensus-mock.cabal b/ouroboros-consensus-mock/ouroboros-consensus-mock.cabal
@@ -61,6 +61,7 @@ library
                      , mtl               >=2.2   && <2.3
                      , nothunks
                      , serialise         >=0.2   && <0.3
+                     , text
                      , time
 
                      , ouroboros-network-api

diff --git a/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Address.hs b/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Ledger/Address.hs
@@ -11,8 +11,11 @@ import           Control.DeepSeq (NFData)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.String
+import           Data.Text (pack, unpack)
 import           NoThunks.Class (NoThunks)
 
+import           Cardano.Binary (FromCBOR (..), ToCBOR (..))
+
 import           Ouroboros.Consensus.Node.ProtocolInfo
 import           Ouroboros.Consensus.NodeId (NodeId (..))
 import           Ouroboros.Consensus.Util.Condense
@@ -29,6 +32,12 @@ newtype Addr = Addr String
     , NoThunks
     )
 
+instance ToCBOR Addr where
+  toCBOR (Addr a) = toCBOR $ pack a
+
+instance FromCBOR Addr where
+  fromCBOR = Addr . unpack <$> fromCBOR
+
 instance Condense Addr where
   condense (Addr addr) = addr