Factor out TestSetup in era-crossing ThreadNet tests

docs/website/contents/references/threadnet_tests.md

@@ -0,0 +1,59 @@
+# ThreadNet tests
+
+The ThreadNet tests spin up a network of nodes, but they are all within a single process --- a network of threads.
+
+The purpose of the ThreadNet tests is to run a simple testnet within a Haskell process, and leverage the QuickCheck infrastructure to vary the parameters of the testnet. The following basic ideas apply:
+- all the nodes are honest --- can a few honest nodes build a chain together?
+- The test have an ability to partition the network, in order to check that the node can recover from the network partition. The test only supports an "easy" case of partition, half-in-half.
+- The leader schedule is not prescribed, but rather evolved naturally as it would in the real system.
+
+## Enumeration and description of the ThreadNet tests
+
+### Shelley era crossing tests
+
+These exercise an era transitions between two consecutive Cardano eras.
+
+We currently the following Shelley-based era crossing tests:
+
+- [Test.ThreadNet.ShelleyAllegra](./../../../../ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/ShelleyAllegra.hs)
+- [Test.ThreadNet.AllegraMary](./../../../../ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/AllegraMary.hs)
+- [Test.ThreadNet.MaryAlonzo](./../../../../ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/MaryAlonzo.hs)
+
+The test scenario is roughly as follows:
+
+- generate credentials of several core nodes.
+- Craft a protocol version update transaction that is signed by all core nodes. The meaning of the transaction is "every node proposes to increment the protocol version".
+- Spin up a network of core nodes.
+- Repeatedly submit the update transaction to the mempool of every core node, so that it end ups in the first minted block.
+- Wait for several slots
+- Stop the nodes, examine their final chains, and make sure the hard fork has happened.
+
+### Shelley test that updates the decentralisation parameter
+
+- [Test.ThreadNet.Shelley](./../../../../ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs)
+
+This test has a structure similar to the Shelley era crossing tests, but actually does not cross between eras, but rather updates the decentralisation parameter.
+
+### Test that crosses from Byron to Shelley, the "Cardano" test
+
+- [Test.ThreadNet.Cardano](./../../../../ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs)
+
+The `Test.ThreadNet.Cardano` module contains the test that crosses from Byron to Shelley. Notably, it uses the Cardano block type, rather than the more specialised two-era `ShelleyBasedHardForkBlock`. Otherwise the flow of the test is very similar to the Shelley-based era crossing tests described above.
+
+### Byron tests
+
+There are two more ThreadNet tests that test the Byron-era consensus code:
+
+- the [Test.ThreadNet.Byron](./../../../../ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/Byron.hs) tests an ability of the nodes to build a chain using the old BFT protocol and also a bunch of Byron-specific chain properties related to epoch boundary blocks (EBBs).
+- The [Test.ThreadNet.DualByron](./../../../../ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs) test runs the Byron ledger and the Byron specification in lockstep, verifying that they agree at every point.
+
+These are very old tests that are mostly irrelevant today.
+
+### Mock block tests
+
+There are four ThreadNet tests that use a mock block, rather than a real Shelley block:
+
+- [Test.ThreadNet.BFT](./../../../../ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs) --- tests convergence of the Byron-era BFT consensus.
+- [Test.ThreadNet.PBFT](./../../../../ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/PBFT.hs) --- tests convergence of the Shelley-era Permissive BFT (PBFT) consensus.
+- [Test.ThreadNet.Praos](./../../../../ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs) --- tests convergence of Praos.
+- [Test.ThreadNet.LeaderSchedule](./../../../../ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/LeaderSchedule.hs) --- looks very similar to the Praos test, but I don't know what exactly it tests.

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node.hs

@@ -43,6 +43,7 @@ import Ouroboros.Consensus.Protocol.TPraos
 import Ouroboros.Consensus.Shelley.Ledger
 import Ouroboros.Consensus.Shelley.Ledger.Inspect ()
 import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion ()
+import Ouroboros.Consensus.Shelley.Node.Common (validateGenesis)
 import Ouroboros.Consensus.Shelley.Node.DiffusionPipelining ()
 import Ouroboros.Consensus.Shelley.Node.Serialisation ()
 import Ouroboros.Consensus.Shelley.Node.TPraos

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/Common.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -17,13 +18,16 @@ module Ouroboros.Consensus.Shelley.Node.Common
   , ShelleyEraWithCrypto
   , ShelleyLeaderCredentials (..)
   , shelleyBlockIssuerVKey
+  , validateGenesis
   ) where
 
 import Cardano.Ledger.BaseTypes (unNonZero)
 import qualified Cardano.Ledger.Keys as SL
 import qualified Cardano.Ledger.Shelley.API as SL
 import Cardano.Ledger.Slot
+import Data.Bifunctor (first)
 import Data.Text (Text)
+import qualified Data.Text as Text
 import Ouroboros.Consensus.Block
   ( CannotForge
   , ForgeStateInfo
@@ -134,3 +138,14 @@ data ProtocolParamsShelleyBased c = ProtocolParamsShelleyBased
   -- mutually incompatible.
   , shelleyBasedLeaderCredentials :: [ShelleyLeaderCredentials c]
   }
+
+-- | Check the validity of the genesis config. To be used in conjunction with
+-- 'assertWithMsg'.
+validateGenesis :: SL.ShelleyGenesis -> Either String ()
+validateGenesis = first errsToString . SL.validateGenesis
+ where
+  errsToString :: [SL.ValidationErr] -> String
+  errsToString errs =
+    Text.unpack $
+      Text.unlines
+        ("Invalid genesis config:" : map SL.describeValidationErr errs)

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs

@@ -27,7 +27,6 @@ module Ouroboros.Consensus.Shelley.Node.TPraos
   , protocolInfoTPraosShelleyBased
   , shelleyBlockForging
   , shelleySharedBlockForging
-  , validateGenesis
   ) where
 
 import Cardano.Crypto.Hash (Hash)
@@ -44,9 +43,7 @@ import Cardano.Slotting.EpochInfo
 import Cardano.Slotting.Time (mkSlotLength)
 import Control.Monad.Except (Except)
 import qualified Control.Tracer as Tracer
-import Data.Bifunctor (first)
 import qualified Data.Text as T
-import qualified Data.Text as Text
 import Lens.Micro ((^.))
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Config
@@ -72,6 +69,7 @@ import Ouroboros.Consensus.Shelley.Node.Common
   , ShelleyEraWithCrypto
   , ShelleyLeaderCredentials (..)
   , shelleyBlockIssuerVKey
+  , validateGenesis
   )
 import Ouroboros.Consensus.Shelley.Node.Serialisation ()
 import Ouroboros.Consensus.Shelley.Protocol.TPraos ()
@@ -154,17 +152,6 @@ shelleySharedBlockForging hotKey slotToPeriod credentials =
   ProtocolInfo
 -------------------------------------------------------------------------------}
 
--- | Check the validity of the genesis config. To be used in conjunction with
--- 'assertWithMsg'.
-validateGenesis :: SL.ShelleyGenesis -> Either String ()
-validateGenesis = first errsToString . SL.validateGenesis
- where
-  errsToString :: [SL.ValidationErr] -> String
-  errsToString errs =
-    Text.unpack $
-      Text.unlines
-        ("Invalid genesis config:" : map SL.describeValidationErr errs)
-
 protocolInfoShelley ::
   forall m c.
   ( IOLike m

ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs

@@ -8,7 +8,6 @@
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -193,7 +192,6 @@ type ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 =
   , -- At the moment, fix the protocols together
     ProtoCrypto proto1 ~ ProtoCrypto proto2
   , PraosCrypto (ProtoCrypto proto1)
-  , proto1 ~ TPraos (ProtoCrypto proto1)
   , proto1 ~ proto2
   , MemPack (TxOut (LedgerState (ShelleyBlock proto1 era1)))
   , MemPack (TxOut (LedgerState (ShelleyBlock proto2 era2)))
@@ -237,19 +235,19 @@ instance
 
   hardForkEraTranslation =
     EraTranslation
-      { translateLedgerState = PCons translateLedgerState PNil
-      , translateLedgerTables = PCons translateLedgerTables PNil
+      { translateLedgerState = PCons translateLedgerStateInstance PNil
+      , translateLedgerTables = PCons translateLedgerTablesInstance PNil
       , translateChainDepState = PCons translateChainDepStateAcrossShelley PNil
       , crossEraForecast = PCons crossEraForecastAcrossShelley PNil
       }
    where
-    translateLedgerState ::
+    translateLedgerStateInstance ::
       InPairs.RequiringBoth
         WrapLedgerConfig
         TranslateLedgerState
         (ShelleyBlock proto1 era1)
         (ShelleyBlock proto2 era2)
-    translateLedgerState =
+    translateLedgerStateInstance =
       InPairs.RequireBoth $
         \_cfg1 cfg2 ->
           HFC.TranslateLedgerState
@@ -263,11 +261,11 @@ instance
                   . Flip
             }
 
-    translateLedgerTables ::
+    translateLedgerTablesInstance ::
       TranslateLedgerTables
         (ShelleyBlock proto1 era1)
         (ShelleyBlock proto2 era2)
-    translateLedgerTables =
+    translateLedgerTablesInstance =
       HFC.TranslateLedgerTables
         { translateTxInWith = coerce
         , translateTxOutWith = SL.upgradeTxOut
@@ -390,7 +388,23 @@ protocolInfoShelleyBasedHardFork ::
   ( KESAgentContext (ProtoCrypto proto2) m
   , ShelleyBasedHardForkConstraints proto1 era1 proto2 era2
   ) =>
+  ( ProtocolParamsShelleyBased (ProtoCrypto proto1) ->
+    L.TransitionConfig era1 ->
+    SL.ProtVer ->
+    ( ProtocolInfo (ShelleyBlock proto1 era1)
+    , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock proto1 era1)]
+    )
+  ) ->
+  ( ProtocolParamsShelleyBased (ProtoCrypto proto2) ->
+    L.TransitionConfig era2 ->
+    SL.ProtVer ->
+    ( ProtocolInfo (ShelleyBlock proto2 era2)
+    , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock proto2 era2)]
+    )
+  ) ->
   ProtocolParamsShelleyBased (ProtoCrypto proto1) ->
+  (ConsensusConfig proto1 -> PartialConsensusConfig proto1) ->
+  (ConsensusConfig proto2 -> PartialConsensusConfig proto2) ->
   SL.ProtVer ->
   SL.ProtVer ->
   L.TransitionConfig era2 ->
@@ -400,7 +414,11 @@ protocolInfoShelleyBasedHardFork ::
     m [MkBlockForging m (ShelleyBasedHardForkBlock proto1 era1 proto2 era2)]
   )
 protocolInfoShelleyBasedHardFork
+  protocolInfoProtoShelleyBased1 -- TODO(geo2a): come up with a better name for this argument
+  protocolInfoProtoShelleyBased2
   protocolParamsShelleyBased
+  toPartialConsensusConfig1
+  toPartialConsensusConfig2
   protVer1
   protVer2
   transCfg2
@@ -410,20 +428,15 @@ protocolInfoShelleyBasedHardFork
       protocolInfo1
       blockForging1
       eraParams1
-      tpraosParams
+      toPartialConsensusConfig1
       toPartialLedgerConfig1
       -- Era 2
       protocolInfo2
       blockForging2
       eraParams2
-      tpraosParams
+      toPartialConsensusConfig2
       toPartialLedgerConfig2
    where
-    ProtocolParamsShelleyBased
-      { shelleyBasedInitialNonce
-      , shelleyBasedLeaderCredentials
-      } = protocolParamsShelleyBased
-
     -- Era 1
 
     genesis :: SL.ShelleyGenesis
@@ -433,7 +446,7 @@ protocolInfoShelleyBasedHardFork
     blockForging1 ::
       Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock proto1 era1)]
     (protocolInfo1, blockForging1) =
-      protocolInfoTPraosShelleyBased
+      protocolInfoProtoShelleyBased1
         protocolParamsShelleyBased
         (transCfg2 ^. L.tcPreviousEraConfigL)
         protVer1
@@ -444,9 +457,9 @@ protocolInfoShelleyBasedHardFork
     toPartialLedgerConfig1 ::
       LedgerConfig (ShelleyBlock proto1 era1) ->
       PartialLedgerConfig (ShelleyBlock proto1 era1)
-    toPartialLedgerConfig1 cfg =
+    toPartialLedgerConfig1 cfg1 =
       ShelleyPartialLedgerConfig
-        { shelleyLedgerConfig = cfg
+        { shelleyLedgerConfig = cfg1
         , shelleyTriggerHardFork = hardForkTrigger
         }
 
@@ -456,11 +469,8 @@ protocolInfoShelleyBasedHardFork
     blockForging2 ::
       Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock proto2 era2)]
     (protocolInfo2, blockForging2) =
-      protocolInfoTPraosShelleyBased
-        ProtocolParamsShelleyBased
-          { shelleyBasedInitialNonce
-          , shelleyBasedLeaderCredentials
-          }
+      protocolInfoProtoShelleyBased2
+        protocolParamsShelleyBased
         transCfg2
         protVer2
 
@@ -470,9 +480,9 @@ protocolInfoShelleyBasedHardFork
     toPartialLedgerConfig2 ::
       LedgerConfig (ShelleyBlock proto2 era2) ->
       PartialLedgerConfig (ShelleyBlock proto2 era2)
-    toPartialLedgerConfig2 cfg =
+    toPartialLedgerConfig2 cfg2 =
       ShelleyPartialLedgerConfig
-        { shelleyLedgerConfig = cfg
+        { shelleyLedgerConfig = cfg2
         , shelleyTriggerHardFork = TriggerHardForkNotDuringThisExecution
         }