Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Use MKs in ouroboros-consensus-byron-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>
  • Loading branch information
4 people committed Mar 24, 2023
1 parent 785158f commit f7a14b6
Show file tree
Hide file tree
Showing 15 changed files with 161 additions and 37 deletions.
Expand Up @@ -43,6 +43,7 @@ library
, cardano-ledger-binary:{cardano-ledger-binary, testlib}
, cardano-ledger-byron
, cardano-ledger-byron-test
, cardano-slotting
, containers >=0.5 && <0.7
, hedgehog-quickcheck
, mtl >=2.2 && <2.3
Expand All @@ -59,14 +60,15 @@ library
-Wall -Wcompat -Wincomplete-uni-patterns
-Wincomplete-record-updates -Wpartial-fields -Widentities
-Wredundant-constraints -Wmissing-export-lists -Wunused-packages
-fno-ignore-asserts
-Wno-unticked-promoted-constructors -fno-ignore-asserts

test-suite test
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: Main.hs
other-modules:
Test.Consensus.Byron.Golden
Test.Consensus.Byron.LedgerTables
Test.Consensus.Byron.Serialisation
Test.ThreadNet.Byron
Test.ThreadNet.DualByron
Expand Down Expand Up @@ -104,4 +106,5 @@ test-suite test
-Wall -Wcompat -Wincomplete-uni-patterns
-Wincomplete-record-updates -Wpartial-fields -Widentities
-Wredundant-constraints -Wmissing-export-lists -Wunused-packages
-fno-ignore-asserts -threaded -rtsopts
-Wno-unticked-promoted-constructors -fno-ignore-asserts -threaded
-rtsopts
Expand Up @@ -203,7 +203,7 @@ forgeDualByronBlock
=> TopLevelConfig DualByronBlock
-> BlockNo -- ^ Current block number
-> SlotNo -- ^ Current slot number
-> TickedLedgerState DualByronBlock -- ^ Ledger
-> TickedLedgerState DualByronBlock mk -- ^ Ledger
-> [Validated (GenTx DualByronBlock)] -- ^ Txs to add in the block
-> PBftIsLeader PBftByronCrypto -- ^ Leader proof ('IsLeader')
-> DualByronBlock
Expand Down
@@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
Expand Down Expand Up @@ -140,8 +141,8 @@ protocolInfoDualByron abstractGenesis@ByronSpecGenesis{..} params credss =
configGenesisData = Impl.configGenesisData translated
protocolParameters = Impl.gdProtocolParameters configGenesisData

initAbstractState :: LedgerState ByronSpecBlock
initConcreteState :: LedgerState ByronBlock
initAbstractState :: LedgerState ByronSpecBlock ValuesMK
initConcreteState :: LedgerState ByronBlock ValuesMK

initAbstractState = initByronSpecLedgerState abstractGenesis
initConcreteState = initByronLedgerState concreteGenesis (Just initUtxo)
Expand Down
@@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
Expand All @@ -18,6 +19,7 @@ import Ouroboros.Consensus.ByronSpec.Ledger
import Ouroboros.Consensus.HeaderValidation
import Ouroboros.Consensus.Ledger.Dual
import Ouroboros.Consensus.Ledger.SupportsMempool (GenTxId)
import Ouroboros.Consensus.Ledger.Tables
import Ouroboros.Consensus.Node.NetworkProtocolVersion
import Ouroboros.Consensus.Node.Run
import Ouroboros.Consensus.Node.Serialisation
Expand Down Expand Up @@ -61,9 +63,9 @@ instance DecodeDiskDep (NestedCtxt Header) DualByronBlock where
(NestedCtxt (CtxtDual ctxt)) =
decodeDiskDep ccfg (NestedCtxt ctxt)

instance EncodeDisk DualByronBlock (LedgerState DualByronBlock) where
instance EncodeDisk DualByronBlock (LedgerState DualByronBlock EmptyMK) where
encodeDisk _ = encodeDualLedgerState encodeByronLedgerState
instance DecodeDisk DualByronBlock (LedgerState DualByronBlock) where
instance DecodeDisk DualByronBlock (LedgerState DualByronBlock EmptyMK) where
decodeDisk _ = decodeDualLedgerState decodeByronLedgerState

-- | @'ChainDepState' ('BlockProtocol' 'DualByronBlock')@
Expand Down
@@ -1,6 +1,9 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module Test.Consensus.Byron.Examples (
-- * Setup
cfg
Expand Down Expand Up @@ -36,6 +39,7 @@ import Ouroboros.Consensus.Config
import Ouroboros.Consensus.HeaderValidation
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.Tables.Utils
import qualified Ouroboros.Consensus.Mempool as Mempool
import Ouroboros.Consensus.NodeId
import Ouroboros.Consensus.Protocol.Abstract
Expand Down Expand Up @@ -102,10 +106,11 @@ examples = Golden.Examples {
, exampleQuery = unlabelled exampleQuery
, exampleResult = unlabelled exampleResult
, exampleAnnTip = unlabelled exampleAnnTip
, exampleLedgerState = unlabelled exampleLedgerState
, exampleLedgerState = unlabelled $ forgetLedgerTables exampleLedgerState
, exampleChainDepState = unlabelled exampleChainDepState
, exampleExtLedgerState = unlabelled exampleExtLedgerState
, exampleExtLedgerState = unlabelled $ forgetLedgerTables exampleExtLedgerState
, exampleSlotNo = unlabelled exampleSlotNo
, exampleLedgerTables = unlabelled NoByronLedgerTables
}
where
regularAndEBB :: a -> a -> Labelled a
Expand All @@ -121,7 +126,7 @@ exampleBlock =
(Mempool.mkOverrides Mempool.noOverridesMeasure)
(BlockNo 1)
(SlotNo 1)
(applyChainTick ledgerConfig (SlotNo 1) ledgerStateAfterEBB)
(applyChainTick ledgerConfig (SlotNo 1) (forgetLedgerTables ledgerStateAfterEBB))
[ValidatedByronTx exampleGenTx]
(fakeMkIsLeader leaderCredentials)
where
Expand Down Expand Up @@ -166,7 +171,7 @@ exampleChainDepState = S.fromList signers
where
signers = map (`S.PBftSigner` CC.exampleKeyHash) [1..4]

emptyLedgerState :: LedgerState ByronBlock
emptyLedgerState :: LedgerState ByronBlock ValuesMK
emptyLedgerState = ByronLedgerState {
byronLedgerTipBlockNo = Origin
, byronLedgerState = initState
Expand All @@ -177,22 +182,28 @@ emptyLedgerState = ByronLedgerState {
Right initState = runExcept $
CC.Block.initialChainValidationState ledgerConfig

ledgerStateAfterEBB :: LedgerState ByronBlock
ledgerStateAfterEBB :: LedgerState ByronBlock ValuesMK
ledgerStateAfterEBB =
reapplyLedgerBlock ledgerConfig exampleEBB
applyLedgerTablesDiffs emptyLedgerState
. reapplyLedgerBlock ledgerConfig exampleEBB
. applyLedgerTablesDiffsTicked emptyLedgerState
. applyChainTick ledgerConfig (SlotNo 0)
. forgetLedgerTables
$ emptyLedgerState

exampleLedgerState :: LedgerState ByronBlock
exampleLedgerState :: LedgerState ByronBlock ValuesMK
exampleLedgerState =
reapplyLedgerBlock ledgerConfig exampleBlock
applyLedgerTablesDiffs emptyLedgerState
. reapplyLedgerBlock ledgerConfig exampleBlock
. applyLedgerTablesDiffsTicked ledgerStateAfterEBB
. applyChainTick ledgerConfig (SlotNo 1)
. forgetLedgerTables
$ ledgerStateAfterEBB

exampleHeaderState :: HeaderState ByronBlock
exampleHeaderState = HeaderState (NotOrigin exampleAnnTip) exampleChainDepState

exampleExtLedgerState :: ExtLedgerState ByronBlock
exampleExtLedgerState :: ExtLedgerState ByronBlock ValuesMK
exampleExtLedgerState = ExtLedgerState {
ledgerState = exampleLedgerState
, headerState = exampleHeaderState
Expand Down
@@ -1,26 +1,30 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Consensus.Byron.Generators (
RegularBlock (..)
, epochSlots
, genByronLedgerConfig
, genByronLedgerState
, k
, protocolMagicId
) where

import Cardano.Chain.Block (ABlockOrBoundary (..),
ABlockOrBoundaryHdr (..))
ABlockOrBoundaryHdr (..), ChainValidationState (..),
cvsPreviousHash)
import qualified Cardano.Chain.Block as CC.Block
import qualified Cardano.Chain.Byron.API as API
import Cardano.Chain.Common (KeyHash)
import qualified Cardano.Chain.Delegation as CC.Del
import qualified Cardano.Chain.Delegation.Validation.Activation as CC.Act
import qualified Cardano.Chain.Delegation.Validation.Interface as CC.DI
import qualified Cardano.Chain.Delegation.Validation.Scheduling as CC.Sched
import qualified Cardano.Chain.Genesis as Byron
import qualified Cardano.Chain.Genesis as CC.Genesis
import Cardano.Chain.Slotting (EpochNumber, EpochSlots (..),
SlotNumber)
Expand All @@ -31,6 +35,7 @@ import qualified Cardano.Chain.UTxO as CC.UTxO
import Cardano.Crypto (ProtocolMagicId (..))
import Cardano.Crypto.Hashing (Hash)
import Cardano.Ledger.Binary (decCBOR, encCBOR)
import Cardano.Slotting.Slot (WithOrigin (..))
import Control.Monad (replicateM)
import Data.Coerce (coerce)
import qualified Data.Map.Strict as Map
Expand All @@ -39,13 +44,15 @@ import Ouroboros.Consensus.Byron.Ledger
import Ouroboros.Consensus.Byron.Protocol
import Ouroboros.Consensus.Config.SecurityParam
import Ouroboros.Consensus.HeaderValidation (AnnTip (..))
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsMempool (GenTxId)
import Ouroboros.Consensus.Protocol.PBFT.State (PBftState)
import qualified Ouroboros.Consensus.Protocol.PBFT.State as PBftState
import Ouroboros.Network.SizeInBytes
import qualified Test.Cardano.Chain.Block.Gen as CC
import qualified Test.Cardano.Chain.Common.Gen as CC
import qualified Test.Cardano.Chain.Delegation.Gen as CC
import qualified Test.Cardano.Chain.Genesis.Gen as CC
import qualified Test.Cardano.Chain.MempoolPayload.Gen as CC
import qualified Test.Cardano.Chain.Slotting.Gen as CC
import qualified Test.Cardano.Chain.Update.Gen as UG
Expand Down Expand Up @@ -262,9 +269,34 @@ instance Arbitrary CC.Del.Map where
instance Arbitrary ByronTransition where
arbitrary = ByronTransitionInfo . Map.fromList <$> arbitrary

instance Arbitrary (LedgerState ByronBlock) where
instance Arbitrary (LedgerState ByronBlock mk) where
arbitrary = ByronLedgerState <$> arbitrary <*> arbitrary <*> arbitrary

-- | Generator for a Byron ledger state in which the tip of the ledger given by
-- `byronLedgerTipBlockNo` is consistent with the chain validation state, i.e., if there is no
-- previous block, the ledger tip wil be `Origin`.
genByronLedgerState :: Gen (LedgerState ByronBlock EmptyMK)
genByronLedgerState = do
chainValidationState <- arbitrary
ledgerTransition <- arbitrary
ledgerTipBlockNo <- genLedgerTipBlockNo chainValidationState
pure $ ByronLedgerState {
byronLedgerTipBlockNo = ledgerTipBlockNo
, byronLedgerState = chainValidationState
, byronLedgerTransition = ledgerTransition
}
where
genLedgerTipBlockNo ChainValidationState { cvsPreviousHash } =
case cvsPreviousHash of
Left _ -> pure Origin
Right _ -> At <$> arbitrary

instance Arbitrary (LedgerTables (LedgerState ByronBlock) mk) where
arbitrary = pure NoByronLedgerTables

genByronLedgerConfig :: Gen Byron.Config
genByronLedgerConfig = hedgehog $ CC.genConfig protocolMagicId

instance Arbitrary (TipInfoIsEBB ByronBlock) where
arbitrary = TipInfoIsEBB <$> arbitrary <*> elements [IsEBB, IsNotEBB]

Expand Down
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
Expand Down Expand Up @@ -41,6 +42,7 @@ import qualified Ouroboros.Consensus.Byron.Crypto.DSIGN as Crypto
import Ouroboros.Consensus.Byron.Ledger (ByronBlock)
import qualified Ouroboros.Consensus.Byron.Ledger as Byron
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Tables (EmptyMK)
import Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..),
ProtocolInfo (..))
import Ouroboros.Consensus.NodeId (CoreNodeId (..))
Expand Down Expand Up @@ -88,7 +90,7 @@ mkUpdateLabels
-> NodeJoinPlan
-> NodeTopology
-> Ref.Result
-> Byron.LedgerState ByronBlock
-> Byron.LedgerState ByronBlock EmptyMK
-- ^ from 'nodeOutputFinalLedger'
-> (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel)
mkUpdateLabels params numSlots genesisConfig nodeJoinPlan topology result
Expand Down
2 changes: 2 additions & 0 deletions ouroboros-consensus-byron-test/test/Main.hs
@@ -1,6 +1,7 @@
module Main (main) where

import qualified Test.Consensus.Byron.Golden (tests)
import qualified Test.Consensus.Byron.LedgerTables (tests)
import qualified Test.Consensus.Byron.Serialisation (tests)
import Test.Tasty
import qualified Test.ThreadNet.Byron (tests)
Expand All @@ -15,6 +16,7 @@ tests :: TestTree
tests =
testGroup "byron"
[ Test.Consensus.Byron.Golden.tests
, Test.Consensus.Byron.LedgerTables.tests
, Test.Consensus.Byron.Serialisation.tests
, Test.ThreadNet.Byron.tests
, Test.ThreadNet.DualByron.tests
Expand Down
@@ -0,0 +1,15 @@
{-# LANGUAGE TypeApplications #-}

module Test.Consensus.Byron.LedgerTables (tests) where

import Ouroboros.Consensus.Byron.Ledger
import Test.Consensus.Byron.Generators ()
import Test.LedgerTables
import Test.Tasty
import Test.Tasty.QuickCheck

tests :: TestTree
tests = testGroup "LedgerTables"
[ testProperty "Stowable laws" (prop_stowable_laws @ByronBlock)
, testProperty "TableStuff laws" (prop_tablestuff_laws @ByronBlock)
]
5 changes: 4 additions & 1 deletion ouroboros-consensus-byron-test/test/Test/ThreadNet/Byron.hs
@@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
Expand Down Expand Up @@ -47,6 +48,7 @@ import Ouroboros.Consensus.Byron.Ledger.Conversions
import Ouroboros.Consensus.Byron.Node
import Ouroboros.Consensus.Byron.Protocol
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Tables
import qualified Ouroboros.Consensus.Mempool as Mempool
import Ouroboros.Consensus.Node.NetworkProtocolVersion
import Ouroboros.Consensus.Node.ProtocolInfo
Expand Down Expand Up @@ -783,6 +785,7 @@ tests = testGroup "Byron" $
defaultSlotLength :: SlotLength
defaultSlotLength = slotLengthFromSec 1


prop_deterministicPlan :: PBftParams -> NumSlots -> NumCoreNodes -> Property
prop_deterministicPlan params numSlots numCoreNodes =
property $ case Ref.simulate params njp numSlots of
Expand Down Expand Up @@ -966,7 +969,7 @@ prop_simple_real_pbft_convergence TestSetup
finalChains :: [(NodeId, Chain ByronBlock)]
finalChains = Map.toList $ nodeOutputFinalChain <$> testOutputNodes testOutput

finalLedgers :: [(NodeId, Byron.LedgerState ByronBlock)]
finalLedgers :: [(NodeId, Byron.LedgerState ByronBlock EmptyMK)]
finalLedgers = Map.toList $ nodeOutputFinalLedger <$> testOutputNodes testOutput

pvuLabels :: [(NodeId, ProtocolVersionUpdateLabel)]
Expand Down
10 changes: 6 additions & 4 deletions ouroboros-consensus-byron-test/test/Test/ThreadNet/DualByron.hs
@@ -1,3 +1,4 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
Expand Down Expand Up @@ -35,6 +36,7 @@ import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Dual
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.Ledger.Tables.Utils
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.NodeId
import Ouroboros.Consensus.Protocol.PBFT
Expand Down Expand Up @@ -256,13 +258,13 @@ byronPBftParams ByronSpecGenesis{..} =
instance TxGen DualByronBlock where
testGenTxs _coreNodeId _numCoreNodes curSlotNo cfg () = \st -> do
n <- choose (0, 20)
go [] n $ applyChainTick (configLedger cfg) curSlotNo st
go [] n $ applyLedgerTablesDiffsTicked st $ applyChainTick (configLedger cfg) curSlotNo $ forgetLedgerTables st
where
-- Attempt to produce @n@ transactions
-- Stops when the transaction generator cannot produce more txs
go :: [GenTx DualByronBlock] -- Accumulator
-> Integer -- Number of txs to still produce
-> TickedLedgerState DualByronBlock
-> TickedLedgerState DualByronBlock ValuesMK
-> Gen [GenTx DualByronBlock]
go acc 0 _ = return (reverse acc)
go acc n st = do
Expand All @@ -273,7 +275,7 @@ instance TxGen DualByronBlock where
curSlotNo
tx
st of
Right (st', _vtx) -> go (tx:acc) (n - 1) st'
Right (st', _vtx) -> go (tx:acc) (n - 1) (forgetLedgerTablesDiffsTicked st')
Left _ -> error "testGenTxs: unexpected invalid tx"

-- | Generate transaction
Expand All @@ -283,7 +285,7 @@ instance TxGen DualByronBlock where
-- for now. Extending the scope will require integration with the restart/rekey
-- infrastructure of the Byron tests.
genTx :: TopLevelConfig DualByronBlock
-> Ticked (LedgerState DualByronBlock)
-> TickedLedgerState DualByronBlock ValuesMK
-> Gen (GenTx DualByronBlock)
genTx cfg st = do
aux <- sigGen (Rules.ctxtUTXOW cfg') st'
Expand Down

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

0 comments on commit f7a14b6

Please sign in to comment.