{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Test.ThreadNet.Byron (
    tests
    -- * To support the DualByron tests
  , TestSetup (..)
  , byronPBftParams
  , expectedCannotForge
  , genTestSetup
  , noEBBs
  ) where

import qualified Cardano.Chain.Block as Block
import qualified Cardano.Chain.Common as Common
import qualified Cardano.Chain.Delegation as Delegation
import qualified Cardano.Chain.Genesis as Genesis
import           Cardano.Chain.ProtocolConstants (kEpochSlots)
import           Cardano.Chain.Slotting (EpochNumber (..), unEpochSlots)
import qualified Cardano.Crypto as Crypto
import qualified Cardano.Crypto.DSIGN as Crypto
import           Cardano.Crypto.Seed (mkSeedFromBytes)
import           Cardano.Ledger.Binary (byronProtVer, reAnnotate)
import qualified Cardano.Ledger.Binary.Plain as Plain
import           Control.Monad (join)
import qualified Data.ByteString as BS
import           Data.Coerce (coerce)
import           Data.Functor ((<&>))
import qualified Data.Map.Strict as Map
import           Data.Maybe (mapMaybe)
import qualified Data.Set as Set
import           Data.Word (Word64)
import           Numeric.Search.Range (searchFromTo)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.BlockchainTime
import qualified Ouroboros.Consensus.Byron.Crypto.DSIGN as Crypto
import           Ouroboros.Consensus.Byron.Ledger (ByronBlock,
                     ByronNodeToNodeVersion (..))
import qualified Ouroboros.Consensus.Byron.Ledger as Byron
import           Ouroboros.Consensus.Byron.Ledger.Conversions
import           Ouroboros.Consensus.Byron.Node
import           Ouroboros.Consensus.Byron.Protocol
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Node.NetworkProtocolVersion
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.NodeId
import           Ouroboros.Consensus.Protocol.PBFT
import qualified Ouroboros.Consensus.Protocol.PBFT.Crypto as Crypto
import           Ouroboros.Consensus.TypeFamilyWrappers
import           Ouroboros.Consensus.Util.Condense (condense)
import           Ouroboros.Network.Mock.Chain (Chain)
import qualified Ouroboros.Network.Mock.Chain as Chain
import           Test.Cardano.Slotting.Numeric ()
import           Test.QuickCheck
import           Test.Tasty
import           Test.Tasty.QuickCheck
import           Test.ThreadNet.General
import           Test.ThreadNet.Infra.Byron
import           Test.ThreadNet.Network (NodeOutput (..),
                     TestNodeInitialization (..))
import qualified Test.ThreadNet.Ref.PBFT as Ref
import           Test.ThreadNet.Rekeying
import           Test.ThreadNet.TxGen.Byron ()
import           Test.ThreadNet.Util
import           Test.ThreadNet.Util.NodeJoinPlan
import           Test.ThreadNet.Util.NodeRestarts
import           Test.ThreadNet.Util.NodeToNodeVersion
import           Test.ThreadNet.Util.NodeTopology
import           Test.ThreadNet.Util.Seed
import           Test.Util.HardFork.Future (singleEraFuture)
import           Test.Util.Orphans.Arbitrary ()
import           Test.Util.Slots (NumSlots (..))
import qualified Test.Util.Stream as Stream
import           Test.Util.TestEnv (adjustQuickCheckTests)

data TestSetup = TestSetup
  { TestSetup -> ProduceEBBs
setupEBBs         :: ProduceEBBs
  , TestSetup -> SecurityParam
setupK            :: SecurityParam
  , TestSetup -> TestConfig
setupTestConfig   :: TestConfig
  , TestSetup -> NodeJoinPlan
setupNodeJoinPlan :: NodeJoinPlan
  , TestSetup -> NodeRestarts
setupNodeRestarts :: NodeRestarts
  , TestSetup -> SlotLength
setupSlotLength   :: SlotLength
  , TestSetup -> (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
  }
  deriving (Int -> TestSetup -> ShowS
[TestSetup] -> ShowS
TestSetup -> [Char]
(Int -> TestSetup -> ShowS)
-> (TestSetup -> [Char])
-> ([TestSetup] -> ShowS)
-> Show TestSetup
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestSetup -> ShowS
showsPrec :: Int -> TestSetup -> ShowS
$cshow :: TestSetup -> [Char]
show :: TestSetup -> [Char]
$cshowList :: [TestSetup] -> ShowS
showList :: [TestSetup] -> ShowS
Show)

instance Arbitrary TestSetup where
  arbitrary :: Gen TestSetup
arbitrary = do
     -- TODO Issue #1566 will bring this to k>=0
      SecurityParam
k <- Word64 -> SecurityParam
SecurityParam (Word64 -> SecurityParam) -> Gen Word64 -> Gen SecurityParam
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
10)

      Gen (Gen TestSetup) -> Gen TestSetup
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Gen (Gen TestSetup) -> Gen TestSetup)
-> Gen (Gen TestSetup) -> Gen TestSetup
forall a b. (a -> b) -> a -> b
$ SecurityParam
-> NumCoreNodes -> NumSlots -> SlotLength -> Gen TestSetup
genTestSetup SecurityParam
k (NumCoreNodes -> NumSlots -> SlotLength -> Gen TestSetup)
-> Gen NumCoreNodes
-> Gen (NumSlots -> SlotLength -> Gen TestSetup)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen NumCoreNodes
forall a. Arbitrary a => Gen a
arbitrary Gen (NumSlots -> SlotLength -> Gen TestSetup)
-> Gen NumSlots -> Gen (SlotLength -> Gen TestSetup)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen NumSlots
forall a. Arbitrary a => Gen a
arbitrary Gen (SlotLength -> Gen TestSetup)
-> Gen SlotLength -> Gen (Gen TestSetup)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen SlotLength
forall a. Arbitrary a => Gen a
arbitrary

  -- TODO shrink

-- | An entrypoint used by "Test.ThreadNet.DualByron"
--
-- See the @'Arbitrary' 'Test.ThreadNet.DualByron.SetupDualByron'@ instance.
genTestSetup :: SecurityParam -> NumCoreNodes -> NumSlots -> SlotLength -> Gen TestSetup
genTestSetup :: SecurityParam
-> NumCoreNodes -> NumSlots -> SlotLength -> Gen TestSetup
genTestSetup SecurityParam
k NumCoreNodes
numCoreNodes NumSlots
numSlots SlotLength
setupSlotLength = do
    ProduceEBBs
setupEBBs    <- Gen ProduceEBBs
forall a. Arbitrary a => Gen a
arbitrary
    Seed
initSeed     <- Gen Seed
forall a. Arbitrary a => Gen a
arbitrary
    NodeTopology
nodeTopology <- HasCallStack => NumCoreNodes -> Gen NodeTopology
NumCoreNodes -> Gen NodeTopology
genNodeTopology NumCoreNodes
numCoreNodes

    let testConfig :: TestConfig
testConfig = TestConfig
          { Seed
initSeed :: Seed
initSeed :: Seed
initSeed
          , NodeTopology
nodeTopology :: NodeTopology
nodeTopology :: NodeTopology
nodeTopology
          , NumCoreNodes
numCoreNodes :: NumCoreNodes
numCoreNodes :: NumCoreNodes
numCoreNodes
          , NumSlots
numSlots :: NumSlots
numSlots :: NumSlots
numSlots
          }
    let params :: PBftParams
params = SecurityParam -> NumCoreNodes -> PBftParams
byronPBftParams SecurityParam
k NumCoreNodes
numCoreNodes

    NodeJoinPlan
nodeJoinPlan <- PBftParams -> NumSlots -> Gen NodeJoinPlan
genByronNodeJoinPlan PBftParams
params NumSlots
numSlots
    NodeRestarts
nodeRestarts <- NodeJoinPlan -> NumSlots -> Gen NodeRestarts
genNodeRestarts NodeJoinPlan
nodeJoinPlan NumSlots
numSlots Gen NodeRestarts
-> (NodeRestarts -> Gen NodeRestarts) -> Gen NodeRestarts
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                    PBftParams
-> NodeJoinPlan
-> NodeTopology
-> NumSlots
-> NodeRestarts
-> Gen NodeRestarts
genNodeRekeys PBftParams
params NodeJoinPlan
nodeJoinPlan NodeTopology
nodeTopology NumSlots
numSlots

    (NodeToNodeVersion, ByronNodeToNodeVersion)
setupVersion <- Proxy ByronBlock
-> Gen (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> Gen (NodeToNodeVersion, BlockNodeToNodeVersion blk)
genVersion (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @ByronBlock)


    TestSetup -> Gen TestSetup
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestSetup -> Gen TestSetup) -> TestSetup -> Gen TestSetup
forall a b. (a -> b) -> a -> b
$ ProduceEBBs
-> SecurityParam
-> TestConfig
-> NodeJoinPlan
-> NodeRestarts
-> SlotLength
-> (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
-> TestSetup
TestSetup
      ProduceEBBs
setupEBBs
      SecurityParam
k
      TestConfig
testConfig
      NodeJoinPlan
nodeJoinPlan
      NodeRestarts
nodeRestarts
      SlotLength
setupSlotLength
      (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
(NodeToNodeVersion, ByronNodeToNodeVersion)
setupVersion

tests :: TestTree
tests :: TestTree
tests = [Char] -> [TestTree] -> TestTree
testGroup [Char]
"Byron" ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$
    [ [Char]
-> (TestSetup -> NumSlots -> NumCoreNodes -> Property) -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"trivial join plan is considered deterministic"
        ((TestSetup -> NumSlots -> NumCoreNodes -> Property) -> TestTree)
-> (TestSetup -> NumSlots -> NumCoreNodes -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ \TestSetup{setupK :: TestSetup -> SecurityParam
setupK = SecurityParam
k, setupTestConfig :: TestSetup -> TestConfig
setupTestConfig = TestConfig{NumCoreNodes
numCoreNodes :: TestConfig -> NumCoreNodes
numCoreNodes :: NumCoreNodes
numCoreNodes}} ->
          PBftParams -> NumSlots -> NumCoreNodes -> Property
prop_deterministicPlan (PBftParams -> NumSlots -> NumCoreNodes -> Property)
-> PBftParams -> NumSlots -> NumCoreNodes -> Property
forall a b. (a -> b) -> a -> b
$ SecurityParam -> NumCoreNodes -> PBftParams
byronPBftParams SecurityParam
k NumCoreNodes
numCoreNodes
    , (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
10) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
      -- as of merging PR #773, this test case fails without the commit that
      -- introduces the InvalidRollForward exception
      --
      -- See a related discussion at
      -- https://github.com/IntersectMBO/ouroboros-network/pull/773#issuecomment-522192097
      [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"addressed by InvalidRollForward exception (PR #773)" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          Property -> Property
forall prop. Testable prop => prop -> Property
once (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          let ncn :: NumCoreNodes
ncn = Word64 -> NumCoreNodes
NumCoreNodes Word64
3 in
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
ProduceEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
10
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn
              , numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
24
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan (Map CoreNodeId SlotNo -> NodeJoinPlan)
-> Map CoreNodeId SlotNo -> NodeJoinPlan
forall a b. (a -> b) -> a -> b
$ [(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
0,Word64 -> SlotNo
SlotNo Word64
0), (Word64 -> CoreNodeId
CoreNodeId Word64
1,Word64 -> SlotNo
SlotNo Word64
20), (Word64 -> CoreNodeId
CoreNodeId Word64
2,Word64 -> SlotNo
SlotNo Word64
22)]
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = NodeRestarts
noRestarts
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"rewind to EBB supported as of Issue #1312, #1" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          Property -> Property
forall prop. Testable prop => prop -> Property
once (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          let ncn :: NumCoreNodes
ncn = Word64 -> NumCoreNodes
NumCoreNodes Word64
2 in
          -- When node 1 joins in slot 1, it leads with an empty chain and so
          -- forges the 0-EBB again. This causes it to report slot 0 as the
          -- found intersection point to node 0, which causes node 0 to
          -- \"rewind\" to slot 0 (even though it's already there). That rewind
          -- fails if EBBs don't affect the PBFT chain state, since its chain
          -- state is empty.
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
ProduceEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
10
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
2
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan ([(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
0,Word64 -> SlotNo
SlotNo Word64
0),(Word64 -> CoreNodeId
CoreNodeId Word64
1,Word64 -> SlotNo
SlotNo Word64
1)])
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = NodeRestarts
noRestarts
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"rewind to EBB supported as of Issue #1312, #2" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          Property -> Property
forall prop. Testable prop => prop -> Property
once (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          let ncn :: NumCoreNodes
ncn = Word64 -> NumCoreNodes
NumCoreNodes Word64
2 in
          -- Same as above, except node 0 gets to forge an actual block before
          -- node 1 tells it to rewind to the EBB.
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
ProduceEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
10
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
4
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan ([(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
0,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
0}),(Word64 -> CoreNodeId
CoreNodeId Word64
1,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
3})])
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = NodeRestarts
noRestarts
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"one testOutputTipBlockNos update per node per slot" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          Property -> Property
forall prop. Testable prop => prop -> Property
once (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          let ncn :: NumCoreNodes
ncn = Word64 -> NumCoreNodes
NumCoreNodes Word64
2 in
          -- In this example, a node was forging a new block and then
          -- restarting. Its instrumentation thread ran before and also after
          -- the restart, which caused the 'testOutputTipBlockNos' field to
          -- contain data from the middle of the slot (after the node lead)
          -- instead of only from the onset of the slot.
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
ProduceEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
5
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
7
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan ([(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
0,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
0}),(Word64 -> CoreNodeId
CoreNodeId Word64
1,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
0})])
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts
NodeRestarts ([(SlotNo, Map CoreNodeId NodeRestart)]
-> Map SlotNo (Map CoreNodeId NodeRestart)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(SlotNo {unSlotNo :: Word64
unSlotNo = Word64
5},[(CoreNodeId, NodeRestart)] -> Map CoreNodeId NodeRestart
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
1,NodeRestart
NodeRestart)])])
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"BlockFetch live lock due to an EBB at the ImmutableDB tip, Issue #1435" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          Property -> Property
forall prop. Testable prop => prop -> Property
once (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          let ncn :: NumCoreNodes
ncn = Word64 -> NumCoreNodes
NumCoreNodes Word64
4 in
          -- c0's ImmutableDB is T > U > V. Note that U is an EBB and U and V
          -- are both in slot 50. When its BlockFetchServer tries to stream T
          -- and U using a ChainDB.Iterator, instead of looking in the
          -- ImmutableDB, we end up looking in the VolatileDB and incorrectly
          -- return ForkTooOld. The client keeps on requesting this block range,
          -- resulting in a live lock.
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
ProduceEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
5
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
58
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan (Map CoreNodeId SlotNo -> NodeJoinPlan)
-> Map CoreNodeId SlotNo -> NodeJoinPlan
forall a b. (a -> b) -> a -> b
$ [(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
0,Word64 -> SlotNo
SlotNo Word64
3),(Word64 -> CoreNodeId
CoreNodeId Word64
1,Word64 -> SlotNo
SlotNo Word64
3),(Word64 -> CoreNodeId
CoreNodeId Word64
2,Word64 -> SlotNo
SlotNo Word64
5),(Word64 -> CoreNodeId
CoreNodeId Word64
3,Word64 -> SlotNo
SlotNo Word64
57)]
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = NodeRestarts
noRestarts
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"ImmutableDB is leaking file handles, #1543" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          -- The failure was: c0 leaks one ImmutableDB file handle (for path
          -- @00000.epoch@, read only, offset at 0).
          --
          -- The test case seems somewhat fragile, since the 'slotLength' value
          -- seems to matter!
          Property -> Property
forall prop. Testable prop => prop -> Property
once (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          let ncn5 :: NumCoreNodes
ncn5 = Word64 -> NumCoreNodes
NumCoreNodes Word64
5 in
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
NoEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
2
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn5
              -- Still fails if I increase numSlots.
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
54
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn5
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan (Map CoreNodeId SlotNo -> NodeJoinPlan)
-> Map CoreNodeId SlotNo -> NodeJoinPlan
forall a b. (a -> b) -> a -> b
$ [(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
              [ (Word64 -> CoreNodeId
CoreNodeId Word64
0, SlotNo {unSlotNo :: Word64
unSlotNo = Word64
0})
              , (Word64 -> CoreNodeId
CoreNodeId Word64
1, SlotNo {unSlotNo :: Word64
unSlotNo = Word64
0})
              , (Word64 -> CoreNodeId
CoreNodeId Word64
2, SlotNo {unSlotNo :: Word64
unSlotNo = Word64
0})
              , (Word64 -> CoreNodeId
CoreNodeId Word64
3, SlotNo {unSlotNo :: Word64
unSlotNo = Word64
53})
              , (Word64 -> CoreNodeId
CoreNodeId Word64
4, SlotNo {unSlotNo :: Word64
unSlotNo = Word64
53})
              ]
              -- Passes if I drop either of these restarts.
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts
NodeRestarts (Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts)
-> Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts
forall a b. (a -> b) -> a -> b
$ [(SlotNo, Map CoreNodeId NodeRestart)]
-> Map SlotNo (Map CoreNodeId NodeRestart)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
              [ (SlotNo {unSlotNo :: Word64
unSlotNo = Word64
50},[(CoreNodeId, NodeRestart)] -> Map CoreNodeId NodeRestart
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
0,NodeRestart
NodeRestart)])
              , (SlotNo {unSlotNo :: Word64
unSlotNo = Word64
53},[(CoreNodeId, NodeRestart)] -> Map CoreNodeId NodeRestart
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
3,NodeRestart
NodeRestart)])
              ]
              -- Slot length of 19s passes, and 21s also fails; I haven't seen this matter before.
            , setupSlotLength :: SlotLength
setupSlotLength = Integer -> SlotLength
slotLengthFromSec Integer
20
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion    = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , -- Byron runs are slow, so do 10x less of this narrow test
      (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
10) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
      [Char] -> (Seed -> Word64 -> Property) -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"re-delegation via NodeRekey" ((Seed -> Word64 -> Property) -> TestTree)
-> (Seed -> Word64 -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ \Seed
seed Word64
w ->
          let ncn :: NumCoreNodes
ncn = Word64 -> NumCoreNodes
NumCoreNodes Word64
5
              k :: Num a => a
              k :: forall a. Num a => a
k = a
5   -- small so that multiple epochs fit into a simulation
              window :: Num a => a
              window :: forall a. Num a => a
window = a
20   -- just for generality
              slotsPerEpoch :: Num a => a
              slotsPerEpoch :: forall a. Num a => a
slotsPerEpoch = Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> a) -> Word64 -> a
forall a b. (a -> b) -> a -> b
$ EpochSlots -> Word64
unEpochSlots (EpochSlots -> Word64) -> EpochSlots -> Word64
forall a b. (a -> b) -> a -> b
$
                              BlockCount -> EpochSlots
kEpochSlots (BlockCount -> EpochSlots) -> BlockCount -> EpochSlots
forall a b. (a -> b) -> a -> b
$ Word64 -> BlockCount
forall a b. Coercible a b => a -> b
coerce (Word64
forall a. Num a => a
k :: Word64)
              slotsPerRekey :: Num a => a
              slotsPerRekey :: forall a. Num a => a
slotsPerRekey = a
2 a -> a -> a
forall a. Num a => a -> a -> a
* a
forall a. Num a => a
k    -- delegations take effect 2k slots later
          in
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
ProduceEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
forall a. Num a => a
k
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots (Word64 -> NumSlots) -> Word64 -> NumSlots
forall a b. (a -> b) -> a -> b
$ Word64
forall a. Num a => a
window Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
forall a. Num a => a
slotsPerEpoch Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
forall a. Num a => a
slotsPerRekey Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
forall a. Num a => a
window
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn
              , initSeed :: Seed
initSeed     = Seed
seed
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = NumCoreNodes -> NodeJoinPlan
trivialNodeJoinPlan NumCoreNodes
ncn
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts
NodeRestarts (Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts)
-> Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts
forall a b. (a -> b) -> a -> b
$ SlotNo
-> Map CoreNodeId NodeRestart
-> Map SlotNo (Map CoreNodeId NodeRestart)
forall k a. k -> a -> Map k a
Map.singleton (Word64 -> SlotNo
SlotNo (Word64
forall a. Num a => a
slotsPerEpoch Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
mod Word64
w Word64
forall a. Num a => a
window)) (CoreNodeId -> NodeRestart -> Map CoreNodeId NodeRestart
forall k a. k -> a -> Map k a
Map.singleton (Word64 -> CoreNodeId
CoreNodeId Word64
0) NodeRestart
NodeRekey)
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"exercise a corner case of mkCurrentBlockContext" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          -- The current chain fragment is @Empty a :> B@ and we're trying to
          -- forge B'; the oddity is that B and B' have the same slot, since
          -- the node is actually leading for the /second/ time in that slot
          -- due to the 'NodeRestart'.
          --
          -- This failed with @Exception: the first block on the Byron chain
          -- must be an EBB@.
          let k :: SecurityParam
k   = Word64 -> SecurityParam
SecurityParam Word64
1
              ncn :: NumCoreNodes
ncn = Word64 -> NumCoreNodes
NumCoreNodes Word64
2
          in
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
NoEBBs
            , setupK :: SecurityParam
setupK          = SecurityParam
k
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
2
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = NumCoreNodes -> NodeJoinPlan
trivialNodeJoinPlan NumCoreNodes
ncn
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts
NodeRestarts (Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts)
-> Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts
forall a b. (a -> b) -> a -> b
$ SlotNo
-> Map CoreNodeId NodeRestart
-> Map SlotNo (Map CoreNodeId NodeRestart)
forall k a. k -> a -> Map k a
Map.singleton (Word64 -> SlotNo
SlotNo Word64
1) (CoreNodeId -> NodeRestart -> Map CoreNodeId NodeRestart
forall k a. k -> a -> Map k a
Map.singleton (Word64 -> CoreNodeId
CoreNodeId Word64
1) NodeRestart
NodeRestart)
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"correct EpochNumber in delegation certificate 1" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          -- Node 3 rekeys in slot 59, which is epoch 1. But Node 3 also leads
          -- that slot, and it forged and adopted a block before restarting. So
          -- the delegation transaction ends up in a block in slot 60, which is
          -- epoch 2.
          Property -> Property
forall prop. Testable prop => prop -> Property
once (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          let ncn4 :: NumCoreNodes
ncn4 = Word64 -> NumCoreNodes
NumCoreNodes Word64
4 in
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
NoEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
3
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn4
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
72
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn4
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = NumCoreNodes -> NodeJoinPlan
trivialNodeJoinPlan NumCoreNodes
ncn4
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts
NodeRestarts ([(SlotNo, Map CoreNodeId NodeRestart)]
-> Map SlotNo (Map CoreNodeId NodeRestart)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> SlotNo
SlotNo Word64
59,[(CoreNodeId, NodeRestart)] -> Map CoreNodeId NodeRestart
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
3,NodeRestart
NodeRekey)])])
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"correct EpochNumber in delegation certificate 2" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          -- Revealed the incorrectness of setting the dlg cert epoch based on
          -- the slot in which the node rekeyed. It must be based on the slot
          -- in which the next block will be successfully forged; hence adding
          -- 'rekeyOracle' fixed this.
          --
          -- Node 2 joins and rekeys in slot 58, epoch 2. It also leads slot
          -- 59. So its dlg cert tx will only be included in the block in slot
          -- 60. However, since that's epoch 3, the tx is discarded as invalid
          -- before the block is forged.
          let ncn3 :: NumCoreNodes
ncn3 = Word64 -> NumCoreNodes
NumCoreNodes Word64
3 in
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
ProduceEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
2
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn3
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
84
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn3
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan ([(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
0,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
1}),(Word64 -> CoreNodeId
CoreNodeId Word64
1,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
1}),(Word64 -> CoreNodeId
CoreNodeId Word64
2,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
58})])
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts
NodeRestarts ([(SlotNo, Map CoreNodeId NodeRestart)]
-> Map SlotNo (Map CoreNodeId NodeRestart)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(SlotNo {unSlotNo :: Word64
unSlotNo = Word64
58},[(CoreNodeId, NodeRestart)] -> Map CoreNodeId NodeRestart
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
2,NodeRestart
NodeRekey)])])
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"repeatedly add the the dlg cert tx" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          -- Revealed the incorrectness of only adding dlg cert tx to the
          -- mempool once (since it may be essentially immediately discarded);
          -- hence adding it every time the ledger tip changes fixed this.
          --
          -- The failure was: PBftNotGenesisDelegate in Slot 95. It disappeared
          -- with the mesh topology, which usually means subtle timings are
          -- involved, unfortunately.
          --
          -- c2 rekeys in s83. c0 leads s84. But c2's dlg cert tx never reached
          -- c0. It turns out that c2 told c0 it exists but then discarded it
          -- before c0 actually requested it.
          --
          -- Excerpt of c2 trace events during s83:
          --
          -- > TraceLabelPeer (CoreId (CoreNodeId 0)) Send MsgRequestNext
          -- > TraceLabelPeer (CoreId (CoreNodeId 0)) Send MsgReplyTxIds (BlockingReply ((dlgid: certificateid: fb50aa22,202) :| []))
          -- > SwitchedToChain
          -- >         { _prevChain = AnchoredFragment {anchorPoint = BlockPoint (SlotNo 25) 26851f52, unanchorFragment = ChainFragment (SFT (fromList
          -- >            [ByronHeader {..., byronHeaderSlotNo = SlotNo {unSlotNo = 27}, byronHeaderHash = ByronHash {unByronHash = AbstractHash d50e0d2c}}
          -- >            ,ByronHeader {..., byronHeaderSlotNo = SlotNo {unSlotNo = 28}, byronHeaderHash = ByronHash {unByronHash = AbstractHash 1523de50}}
          -- >            ,ByronHeader {..., byronHeaderSlotNo = SlotNo {unSlotNo = 30}, byronHeaderHash = ByronHash {unByronHash = AbstractHash 77cb5dda}}
          -- >            ,ByronHeader {..., byronHeaderSlotNo = SlotNo {unSlotNo = 31}, byronHeaderHash = ByronHash {unByronHash = AbstractHash 7efd3ec2}}
          -- >            ,ByronHeader {..., byronHeaderSlotNo = SlotNo {unSlotNo = 33}, byronHeaderHash = ByronHash {unByronHash = AbstractHash 8903fa61}}
          -- > {-an EBB-} ,ByronHeader {..., byronHeaderSlotNo = SlotNo {unSlotNo = 40}, byronHeaderHash = ByronHash {unByronHash = AbstractHash 43f8067e}}
          -- >            ]))}
          -- >         , _newChain = AnchoredFragment {anchorPoint = BlockPoint (SlotNo 27) d50e0d2c, unanchorFragment = ChainFragment (SFT (fromList
          -- >            [ByronHeader {..., byronHeaderSlotNo = SlotNo {unSlotNo = 28}, byronHeaderHash = 1523de50}
          -- >            ,ByronHeader {..., byronHeaderSlotNo = SlotNo {unSlotNo = 30}, byronHeaderHash = 77cb5dda}
          -- >            ,ByronHeader {..., byronHeaderSlotNo = SlotNo {unSlotNo = 31}, byronHeaderHash = 7efd3ec2}
          -- >            ,ByronHeader {..., byronHeaderSlotNo = SlotNo {unSlotNo = 33}, byronHeaderHash = 8903fa61}
          -- >            ,ByronHeader {..., byronHeaderSlotNo = SlotNo {unSlotNo = 34}, byronHeaderHash = afa797b4}
          -- >            ]))}}
          --
          -- That SwitchedToChain rolled back the slot 40 EBB (epoch 1) and
          -- picked up a proper block in slot 34 (epoch 0) instead.
          --
          -- > TraceMempoolRemoveTxs (SyncWithLedger (At (SlotNo {unSlotNo = 35}))) [(dlg: Delegation.Certificate { w = #2, iVK = pub:a3219c1a, dVK = pub:1862f6a2 },MempoolDlgErr (WrongEpoch (EpochNumber {getEpochNumber = 0}) (EpochNumber {getEpochNumber = 2})))] (MempoolSize {msNumTxs = 0, msNumBytes = 0})
          -- > TraceLabelPeer (CoreId (CoreNodeId 0)) Recv MsgBatchDone
          -- > TraceLabelPeer (CoreId (CoreNodeId 0)) Recv MsgRequestTxs [dlgid: certificateid: fb50aa22]
          -- > TraceLabelPeer (CoreId (CoreNodeId 0)) Send MsgReplyTxs []
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
ProduceEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
4
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = Word64 -> NumCoreNodes
NumCoreNodes Word64
3
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
96
              , nodeTopology :: NodeTopology
nodeTopology =    --   1 <-> 0 <-> 2
                Map CoreNodeId (Set CoreNodeId) -> NodeTopology
NodeTopology (Map CoreNodeId (Set CoreNodeId) -> NodeTopology)
-> Map CoreNodeId (Set CoreNodeId) -> NodeTopology
forall a b. (a -> b) -> a -> b
$ [(CoreNodeId, Set CoreNodeId)] -> Map CoreNodeId (Set CoreNodeId)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
0,[CoreNodeId] -> Set CoreNodeId
forall a. Ord a => [a] -> Set a
Set.fromList []),(Word64 -> CoreNodeId
CoreNodeId Word64
1,[CoreNodeId] -> Set CoreNodeId
forall a. Ord a => [a] -> Set a
Set.fromList [Word64 -> CoreNodeId
CoreNodeId Word64
0]),(Word64 -> CoreNodeId
CoreNodeId Word64
2,[CoreNodeId] -> Set CoreNodeId
forall a. Ord a => [a] -> Set a
Set.fromList [Word64 -> CoreNodeId
CoreNodeId Word64
0])]
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan (Map CoreNodeId SlotNo -> NodeJoinPlan)
-> Map CoreNodeId SlotNo -> NodeJoinPlan
forall a b. (a -> b) -> a -> b
$ [(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
0,Word64 -> SlotNo
SlotNo Word64
0),(Word64 -> CoreNodeId
CoreNodeId Word64
1,Word64 -> SlotNo
SlotNo Word64
0),(Word64 -> CoreNodeId
CoreNodeId Word64
2,Word64 -> SlotNo
SlotNo Word64
83)]
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts
NodeRestarts (Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts)
-> Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts
forall a b. (a -> b) -> a -> b
$ [(SlotNo, Map CoreNodeId NodeRestart)]
-> Map SlotNo (Map CoreNodeId NodeRestart)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> SlotNo
SlotNo Word64
83,[(CoreNodeId, NodeRestart)] -> Map CoreNodeId NodeRestart
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
2,NodeRestart
NodeRekey)])]
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"topology prevents timely dlg cert tx propagation" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          -- Caught a bug in the test infrastructure. If node X rekeys in slot
          -- S and Y leads slot S+1, then either the topology must connect X
          -- and Y directly, or Y must join before slot S. Otherwise, X
          -- successfully propagates its dlg cert tx to the pre-existing nodes,
          -- but Y won't pull it from them in time to include the tx in its
          -- block for S+1. When Y joined in S, its mini protocols all failed
          -- and were delayed to restart in the next slot (S+1). They do so,
          -- but it forges its block in S+1 before the dlg cert tx arrives.
          --
          -- The expected failure is an unexpected block rejection (cf
          -- 'pgaExpectedCannotForge') (PBftNotGenesisDelegate) in Slot 49.
          -- It disappears with the mesh topology, which usually means subtle
          -- timings are involved, unfortunately.
          --
          -- c3 and c4 join in s37. c4 rekeys in s37. c3 leads in s38.
          --
          -- The dlg cert tx does not arrive at c3 in time because of the
          -- topology. When c3 and c4 join in s37, their mini protocol threads
          -- that serve {c0,c1,c2} as clients fail and are scheduled to restart
          -- at the onset of the next slot (s38). Since c3 and c4 are not
          -- directly connected, and in particular the mini protocol instances
          -- with clients in {c0,c1,c2} and server c4 are down, c4 cannot
          -- communicate its dlg cert tx to c3 in time (it arrives in s38, but
          -- after c3 has forged its block).
          let ncn5 :: NumCoreNodes
ncn5 = Word64 -> NumCoreNodes
NumCoreNodes Word64
5 in
          Property -> Property
forall prop. Testable prop => prop -> Property
expectFailure (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          Property -> Property
forall prop. Testable prop => prop -> Property
once (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
ProduceEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
2
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn5
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
50
              , nodeTopology :: NodeTopology
nodeTopology = -- 3 <-> {0,1,2} <-> 4
                Map CoreNodeId (Set CoreNodeId) -> NodeTopology
NodeTopology ([(CoreNodeId, Set CoreNodeId)] -> Map CoreNodeId (Set CoreNodeId)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
0,[CoreNodeId] -> Set CoreNodeId
forall a. Ord a => [a] -> Set a
Set.fromList []),(Word64 -> CoreNodeId
CoreNodeId Word64
1,[CoreNodeId] -> Set CoreNodeId
forall a. Ord a => [a] -> Set a
Set.fromList [Word64 -> CoreNodeId
CoreNodeId Word64
0]),(Word64 -> CoreNodeId
CoreNodeId Word64
2,[CoreNodeId] -> Set CoreNodeId
forall a. Ord a => [a] -> Set a
Set.fromList [Word64 -> CoreNodeId
CoreNodeId Word64
0, Word64 -> CoreNodeId
CoreNodeId Word64
1]),(Word64 -> CoreNodeId
CoreNodeId Word64
3,[CoreNodeId] -> Set CoreNodeId
forall a. Ord a => [a] -> Set a
Set.fromList [Word64 -> CoreNodeId
CoreNodeId Word64
0,Word64 -> CoreNodeId
CoreNodeId Word64
1,Word64 -> CoreNodeId
CoreNodeId Word64
2]),(Word64 -> CoreNodeId
CoreNodeId Word64
4,[CoreNodeId] -> Set CoreNodeId
forall a. Ord a => [a] -> Set a
Set.fromList [Word64 -> CoreNodeId
CoreNodeId Word64
0,Word64 -> CoreNodeId
CoreNodeId Word64
1,Word64 -> CoreNodeId
CoreNodeId Word64
2])])
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan ([(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
0,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
0}),(Word64 -> CoreNodeId
CoreNodeId Word64
1,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
0}),(Word64 -> CoreNodeId
CoreNodeId Word64
2,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
0}),(Word64 -> CoreNodeId
CoreNodeId Word64
3,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
37}),(Word64 -> CoreNodeId
CoreNodeId Word64
4,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
37})])
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts
NodeRestarts ([(SlotNo, Map CoreNodeId NodeRestart)]
-> Map SlotNo (Map CoreNodeId NodeRestart)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(SlotNo {unSlotNo :: Word64
unSlotNo = Word64
37},[(CoreNodeId, NodeRestart)] -> Map CoreNodeId NodeRestart
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
4,NodeRestart
NodeRekey)])])
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"mkDelegationEnvironment uses currentSlot not latestSlot" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
      -- After rekeying, node 2 continues to emit its dlg cert tx. This an ugly
      -- implementation detail of rekeying, but as a nice surprise it found a
      -- bug!
      --
      -- In slot 40, node 1 forged a block that included the now-/expired/ dlg
      -- cert tx (cf @WrongEpoch@). This happened because the Byron transaction
      -- validation logic was using the slot of the latest block (i.e. 39) as
      -- the current slot (i.e. actually 40), so the transaction wasn't
      -- identified as expired until it was already inside a block.
      Property -> Property
forall prop. Testable prop => prop -> Property
once (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      let ncn :: NumCoreNodes
ncn = Word64 -> NumCoreNodes
NumCoreNodes Word64
3 in
      TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
        { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
NoEBBs
        , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
2
        , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
          { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn
          , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
41
          , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn
          , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
          }
        , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = NumCoreNodes -> NodeJoinPlan
trivialNodeJoinPlan NumCoreNodes
ncn
        , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts
NodeRestarts (Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts)
-> Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts
forall a b. (a -> b) -> a -> b
$ SlotNo
-> Map CoreNodeId NodeRestart
-> Map SlotNo (Map CoreNodeId NodeRestart)
forall k a. k -> a -> Map k a
Map.singleton (Word64 -> SlotNo
SlotNo Word64
30) (Map CoreNodeId NodeRestart
 -> Map SlotNo (Map CoreNodeId NodeRestart))
-> Map CoreNodeId NodeRestart
-> Map SlotNo (Map CoreNodeId NodeRestart)
forall a b. (a -> b) -> a -> b
$ CoreNodeId -> NodeRestart -> Map CoreNodeId NodeRestart
forall k a. k -> a -> Map k a
Map.singleton (Word64 -> CoreNodeId
CoreNodeId Word64
2) NodeRestart
NodeRekey
        , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
        }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"delayed message corner case" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          Property -> Property
forall prop. Testable prop => prop -> Property
once (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          let ncn :: NumCoreNodes
ncn = Word64 -> NumCoreNodes
NumCoreNodes Word64
2 in
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
NoEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
7
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
10
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan ([(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
0,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
0}),(Word64 -> CoreNodeId
CoreNodeId Word64
1,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
1})])
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = NodeRestarts
noRestarts
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"mkUpdateLabels anticipates instant confirmation" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          -- caught a bug in 'mkUpdateLabels' where it didn't anticipate that
          -- node c0 can confirm the proposal as soon as it joins when quorum
          -- == 1
          let ncn :: NumCoreNodes
ncn = Word64 -> NumCoreNodes
NumCoreNodes Word64
3 in
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
NoEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
9
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
1
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = NumCoreNodes -> NodeJoinPlan
trivialNodeJoinPlan NumCoreNodes
ncn
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = NodeRestarts
noRestarts
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"have nodes add transactions as promptly as possible, as expected by proposal tracking" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          -- this repro requires that changes to the ledger point triggers the
          -- nearly oracular wallet to attempt to add its proposal vote again
          --
          -- Without that, node c1's own vote is not included in the block it
          -- forges in the last slot, because it attempts to add the vote
          -- before the proposal arrives from c0. With the trigger, the arrival
          -- of c0's block triggers it. In particular, the ledger *slot*
          -- doesn't change in this repro, since the new block and its
          -- predecessor both inhabit slot 0. EBBeeeeeees!
          let ncn :: NumCoreNodes
ncn = Word64 -> NumCoreNodes
NumCoreNodes Word64
4 in
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
NoEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
8
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
2
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = NumCoreNodes -> NodeJoinPlan
trivialNodeJoinPlan NumCoreNodes
ncn
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = NodeRestarts
noRestarts
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"track proposals even when c0 is not the first to lead" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          -- requires prompt and accurate vote tracking when c0 is not the
          -- first node to lead
          --
          -- The necessary promptness trigger in this case is the arrival of
          -- the proposal transaction.
          let ncn :: NumCoreNodes
ncn = Word64 -> NumCoreNodes
NumCoreNodes Word64
4 in
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
NoEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
5
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
5
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan (Map CoreNodeId SlotNo -> NodeJoinPlan)
-> Map CoreNodeId SlotNo -> NodeJoinPlan
forall a b. (a -> b) -> a -> b
$ [(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Word64 -> CoreNodeId
CoreNodeId Word64
0, Word64 -> SlotNo
SlotNo Word64
2) , (Word64 -> CoreNodeId
CoreNodeId Word64
1, Word64 -> SlotNo
SlotNo Word64
3) , (Word64 -> CoreNodeId
CoreNodeId Word64
2, Word64 -> SlotNo
SlotNo Word64
4) , (Word64 -> CoreNodeId
CoreNodeId Word64
3, Word64 -> SlotNo
SlotNo Word64
4) ]
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = NodeRestarts
noRestarts
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"cardano-ledger-byron checks for proposal confirmation before it checks for expiry" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          -- must check for quorum before checking for expiration
          let ncn :: NumCoreNodes
ncn = Word64 -> NumCoreNodes
NumCoreNodes Word64
5 in
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
NoEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
10
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
12
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan (Map CoreNodeId SlotNo -> NodeJoinPlan)
-> Map CoreNodeId SlotNo -> NodeJoinPlan
forall a b. (a -> b) -> a -> b
$ [(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Word64 -> CoreNodeId
CoreNodeId Word64
0, Word64 -> SlotNo
SlotNo Word64
0) , (Word64 -> CoreNodeId
CoreNodeId Word64
1, Word64 -> SlotNo
SlotNo Word64
0) , (Word64 -> CoreNodeId
CoreNodeId Word64
2, Word64 -> SlotNo
SlotNo Word64
10) , (Word64 -> CoreNodeId
CoreNodeId Word64
3, Word64 -> SlotNo
SlotNo Word64
10) , (Word64 -> CoreNodeId
CoreNodeId Word64
4, Word64 -> SlotNo
SlotNo Word64
10) ]
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = NodeRestarts
noRestarts
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"repropose an expired proposal" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          -- the proposal expires in slot 10, but then c0 reintroduces it in
          -- slot 11 and it is eventually confirmed
          let ncn :: NumCoreNodes
ncn = Word64 -> NumCoreNodes
NumCoreNodes Word64
5 in
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
NoEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
10
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
17
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan (Map CoreNodeId SlotNo -> NodeJoinPlan)
-> Map CoreNodeId SlotNo -> NodeJoinPlan
forall a b. (a -> b) -> a -> b
$ [(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
              [(Word64 -> CoreNodeId
CoreNodeId Word64
0, Word64 -> SlotNo
SlotNo Word64
0)
              ,(Word64 -> CoreNodeId
CoreNodeId Word64
1, Word64 -> SlotNo
SlotNo Word64
10)
              ,(Word64 -> CoreNodeId
CoreNodeId Word64
2, Word64 -> SlotNo
SlotNo Word64
11)
              ,(Word64 -> CoreNodeId
CoreNodeId Word64
3, Word64 -> SlotNo
SlotNo Word64
11)
              ,(Word64 -> CoreNodeId
CoreNodeId Word64
4, Word64 -> SlotNo
SlotNo Word64
16)
              ]
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = NodeRestarts
noRestarts
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"only expect EBBs if the reference simulator does" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          -- In this repro, block in the 20th slot is wasted since c2 just
          -- joined. As a result, the final chains won't include that EBB.
          let ncn :: NumCoreNodes
ncn = Word64 -> NumCoreNodes
NumCoreNodes Word64
3 in
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
ProduceEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
2
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = NumCoreNodes
ncn
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
21
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
ncn
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan (Map CoreNodeId SlotNo -> NodeJoinPlan)
-> Map CoreNodeId SlotNo -> NodeJoinPlan
forall a b. (a -> b) -> a -> b
$ [(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
              [ (Word64 -> CoreNodeId
CoreNodeId Word64
0,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
0})
              , (Word64 -> CoreNodeId
CoreNodeId Word64
1,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
0})
              , (Word64 -> CoreNodeId
CoreNodeId Word64
2,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
20})
              ]
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = NodeRestarts
noRestarts
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"only check updates for mesh topologies" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          -- This repro exercises
          -- 'Test.ThreadNet.Byron.TrackUpdates.checkTopo'.
          --
          -- The predicted slot outcomes are
          --
          -- > leader 01234
          -- >    s0  NAAAA
          -- >    s5  NAAAA
          -- >    s10 NWN
          --
          -- The votes of c1, c3, and c4 arrive to c2 during s11 via TxSub
          -- /before/ the block containing the proposal does, so c2's mempool
          -- rejects them as invalid. When it then forges in s12, it only
          -- includes its own vote, which doesn't meet quota (3 = 5 * 0.6) and
          -- so the proposal then expires (TTL 10 slots, but only after an
          -- endorsement; see Issue 749 in cardano-ledger-byron).
          --
          -- "Test.ThreadNet.Byron.TrackUpdates" does not otherwise
          -- correctly anticipate such races, so it makes no requirement for
          -- non-mesh topologies.
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
NoEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
10
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = Word64 -> NumCoreNodes
NumCoreNodes Word64
5
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
13
              , nodeTopology :: NodeTopology
nodeTopology = Map CoreNodeId (Set CoreNodeId) -> NodeTopology
NodeTopology (Map CoreNodeId (Set CoreNodeId) -> NodeTopology)
-> Map CoreNodeId (Set CoreNodeId) -> NodeTopology
forall a b. (a -> b) -> a -> b
$ [(CoreNodeId, Set CoreNodeId)] -> Map CoreNodeId (Set CoreNodeId)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                               -- mesh except for 0 <-> 2
                [ (Word64 -> CoreNodeId
CoreNodeId Word64
0, [CoreNodeId] -> Set CoreNodeId
forall a. Ord a => [a] -> Set a
Set.fromList [])
                , (Word64 -> CoreNodeId
CoreNodeId Word64
1, [CoreNodeId] -> Set CoreNodeId
forall a. Ord a => [a] -> Set a
Set.fromList [Word64 -> CoreNodeId
CoreNodeId Word64
0])
                , (Word64 -> CoreNodeId
CoreNodeId Word64
2, [CoreNodeId] -> Set CoreNodeId
forall a. Ord a => [a] -> Set a
Set.fromList [Word64 -> CoreNodeId
CoreNodeId Word64
1])
                , (Word64 -> CoreNodeId
CoreNodeId Word64
3, [CoreNodeId] -> Set CoreNodeId
forall a. Ord a => [a] -> Set a
Set.fromList [Word64 -> CoreNodeId
CoreNodeId Word64
0, Word64 -> CoreNodeId
CoreNodeId Word64
1, Word64 -> CoreNodeId
CoreNodeId Word64
2])
                , (Word64 -> CoreNodeId
CoreNodeId Word64
4, [CoreNodeId] -> Set CoreNodeId
forall a. Ord a => [a] -> Set a
Set.fromList [Word64 -> CoreNodeId
CoreNodeId Word64
0, Word64 -> CoreNodeId
CoreNodeId Word64
1, Word64 -> CoreNodeId
CoreNodeId Word64
2, Word64 -> CoreNodeId
CoreNodeId Word64
3])
              ]
              , initSeed :: Seed
initSeed = Int -> Seed
Seed Int
0
            }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan (Map CoreNodeId SlotNo -> NodeJoinPlan)
-> Map CoreNodeId SlotNo -> NodeJoinPlan
forall a b. (a -> b) -> a -> b
$ [(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
              [ (Word64 -> CoreNodeId
CoreNodeId Word64
0, Word64 -> SlotNo
SlotNo Word64
0)
              , (Word64 -> CoreNodeId
CoreNodeId Word64
1, Word64 -> SlotNo
SlotNo Word64
11)
              , (Word64 -> CoreNodeId
CoreNodeId Word64
2, Word64 -> SlotNo
SlotNo Word64
11)
              , (Word64 -> CoreNodeId
CoreNodeId Word64
3, Word64 -> SlotNo
SlotNo Word64
11)
              , (Word64 -> CoreNodeId
CoreNodeId Word64
4, Word64 -> SlotNo
SlotNo Word64
11)
              ]
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = NodeRestarts
noRestarts
            , setupSlotLength :: SlotLength
setupSlotLength   = SlotLength
defaultSlotLength
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"HeaderProtocolError prevents JIT EBB emission" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          -- "extra" EBB generated in anticipation of a block that ends up
          -- being PBftExceededSignThreshold
          --
          -- PR 1942 reduced the input of blockProduction from ExtLedgerState
          -- to just LedgerState, but that does not provide enough information
          -- to fully anticipate the block's invalidity, since it excludes
          -- protocol-level validation
          --
          -- Remark: this particular repro involves a peculiar phenomenon
          -- apparent for k=8 n=3 in which the nodes' steady-state behavior
          -- involves a regularly occurring 'PBftExceededSignThreshold'
          Property -> Property
forall prop. Testable prop => prop -> Property
once (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
ProduceEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
8
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = Word64 -> NumCoreNodes
NumCoreNodes Word64
3
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
81
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology (Word64 -> NumCoreNodes
NumCoreNodes Word64
3)
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan ([(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
0,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
2}),(Word64 -> CoreNodeId
CoreNodeId Word64
1,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
6}),(Word64 -> CoreNodeId
CoreNodeId Word64
2,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
9})])
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = NodeRestarts
noRestarts
            , setupSlotLength :: SlotLength
setupSlotLength   = Integer -> SlotLength
slotLengthFromSec Integer
20
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"WallClock must handle PastHorizon by exactly slotLength delay" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          -- Previously, 'PastTimeHorizon' put the node to sleep for 60s. That
          -- had caused it to be offline for slots it shouldn't miss.
          Property -> Property
forall prop. Testable prop => prop -> Property
once (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
ProduceEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
2
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = Word64 -> NumCoreNodes
NumCoreNodes Word64
2
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
39
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology (Word64 -> NumCoreNodes
NumCoreNodes Word64
2)
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan ([(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
0,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
0}),(Word64 -> CoreNodeId
CoreNodeId Word64
1,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
33})])
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = NodeRestarts
noRestarts
            , setupSlotLength :: SlotLength
setupSlotLength   = Integer -> SlotLength
slotLengthFromSec Integer
20
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> Property -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"systemTimeCurrent must not answer once clock is exhausted" (Property -> TestTree) -> Property -> TestTree
forall a b. (a -> b) -> a -> b
$
          -- This test would pass (before fixing the bug) if I moved both the
          -- end of the test and also the last node's join slot ahead by 3
          -- slots. So I think to the epoch boundary may be involved, likely
          -- via its effect on the 'SafeZone'.
          --
          -- The failure is due to the following sequence. The node joins with
          -- an empty chain. The existing nodes disconnect from it. The new
          -- node blocks due to 'PastTimeHorizon', and so syncs the whole chain.
          -- Then the new node leads. But the old nodes don't get its new
          -- block. Then the test ends.
          --
          -- The new node should not have been able to create a block in that
          -- slot. The 'PastTimeHorizon' should cause the node to sleep for an
          -- entire slot duration, so it should have missed it's chance to
          -- lead.
          --
          -- This failure clarified that 'OracularClock.systemTimeCurrent' should not provide
          -- a time after the clock is exhausted.
          Property -> Property
forall prop. Testable prop => prop -> Property
once (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
            { setupEBBs :: ProduceEBBs
setupEBBs       = ProduceEBBs
NoEBBs
            , setupK :: SecurityParam
setupK          = Word64 -> SecurityParam
SecurityParam Word64
2
            , setupTestConfig :: TestConfig
setupTestConfig = TestConfig
              { numCoreNodes :: NumCoreNodes
numCoreNodes = Word64 -> NumCoreNodes
NumCoreNodes Word64
3
              , numSlots :: NumSlots
numSlots     = Word64 -> NumSlots
NumSlots Word64
21
              , nodeTopology :: NodeTopology
nodeTopology = NumCoreNodes -> NodeTopology
meshNodeTopology (Word64 -> NumCoreNodes
NumCoreNodes Word64
3)
              , initSeed :: Seed
initSeed     = Int -> Seed
Seed Int
0
              }
            , setupNodeJoinPlan :: NodeJoinPlan
setupNodeJoinPlan = Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan ([(CoreNodeId, SlotNo)] -> Map CoreNodeId SlotNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word64 -> CoreNodeId
CoreNodeId Word64
0,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
0}),(Word64 -> CoreNodeId
CoreNodeId Word64
1,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
0}),(Word64 -> CoreNodeId
CoreNodeId Word64
2,SlotNo {unSlotNo :: Word64
unSlotNo = Word64
20})])
            , setupNodeRestarts :: NodeRestarts
setupNodeRestarts = NodeRestarts
noRestarts
            , setupSlotLength :: SlotLength
setupSlotLength   = Integer -> SlotLength
slotLengthFromSec Integer
20
            , setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion
forall a. Bounded a => a
minBound, BlockNodeToNodeVersion ByronBlock
ByronNodeToNodeVersion
ByronNodeToNodeVersion1)
            }
    , [Char] -> (TestSetup -> Property) -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"simple convergence" ((TestSetup -> Property) -> TestTree)
-> (TestSetup -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ \TestSetup
setup ->
        TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
setup
    ]
  where
    defaultSlotLength :: SlotLength
    defaultSlotLength :: SlotLength
defaultSlotLength = Integer -> SlotLength
slotLengthFromSec Integer
1

prop_deterministicPlan :: PBftParams -> NumSlots -> NumCoreNodes -> Property
prop_deterministicPlan :: PBftParams -> NumSlots -> NumCoreNodes -> Property
prop_deterministicPlan PBftParams
params NumSlots
numSlots NumCoreNodes
numCoreNodes =
    Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ case HasCallStack => PBftParams -> NodeJoinPlan -> NumSlots -> Result
PBftParams -> NodeJoinPlan -> NumSlots -> Result
Ref.simulate PBftParams
params NodeJoinPlan
njp NumSlots
numSlots of
      Ref.Forked{}         -> Bool
False
      Ref.Outcomes{}       -> Bool
True
      Result
Ref.Nondeterministic -> Bool
False
  where
    njp :: NodeJoinPlan
njp = NumCoreNodes -> NodeJoinPlan
trivialNodeJoinPlan NumCoreNodes
numCoreNodes

expectedCannotForge ::
     SecurityParam
  -> NumCoreNodes
  -> NodeRestarts
  -> SlotNo
  -> NodeId
  -> WrapCannotForge ByronBlock
  -> Bool
expectedCannotForge :: SecurityParam
-> NumCoreNodes
-> NodeRestarts
-> SlotNo
-> NodeId
-> WrapCannotForge ByronBlock
-> Bool
expectedCannotForge
  SecurityParam
k NumCoreNodes
numCoreNodes (NodeRestarts Map SlotNo (Map CoreNodeId NodeRestart)
nrs)
  SlotNo
s (CoreId (CoreNodeId Word64
i)) (WrapCannotForge CannotForge ByronBlock
cl)
  = case CannotForge ByronBlock
cl of
    PBftCannotForgeThresholdExceeded{} ->
        -- TODO validate this against Ref implementation?
        Bool
True
    PBftCannotForgeInvalidDelegation {} ->
        -- only if it rekeyed within before a restarts latest possible
        -- maturation
        Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([()] -> Bool) -> [()] -> Bool
forall a b. (a -> b) -> a -> b
$
        [ ()
        | (SlotNo
restartSlot, Map CoreNodeId NodeRestart
nrs') <- Map SlotNo (Map CoreNodeId NodeRestart)
-> [(SlotNo, Map CoreNodeId NodeRestart)]
forall k a. Map k a -> [(k, a)]
Map.toList Map SlotNo (Map CoreNodeId NodeRestart)
nrs
        , SlotNo
restartSlot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo
s
            Bool -> Bool -> Bool
&& SlotNo
s SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SecurityParam -> NumCoreNodes -> SlotNo -> SlotNo
latestPossibleDlgMaturation SecurityParam
k NumCoreNodes
numCoreNodes SlotNo
restartSlot
        , (CoreNodeId Word64
i', NodeRestart
NodeRekey) <- Map CoreNodeId NodeRestart -> [(CoreNodeId, NodeRestart)]
forall k a. Map k a -> [(k, a)]
Map.toList Map CoreNodeId NodeRestart
nrs'
        , Word64
i' Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
i
        ]
expectedCannotForge SecurityParam
_ NumCoreNodes
_ NodeRestarts
_ SlotNo
_ NodeId
_ WrapCannotForge ByronBlock
_ = Bool
False

-- | If we rekey in slot rekeySlot, it is in general possible that the leader
-- of rekeySlot will include our delegation transaction in its new block.
-- However, in the current test infrastructure, it will consistently have
-- already forged its new block before receiving our new transaction.
--
-- Thus the first leader to forge a valid block in one of the slots rekeySlot+1
-- through rekeySlot+N will include our new transaction in its new block. There
-- are two reasons that those leaders (excepting the last) may fail to forge a
-- valid block.
--
-- * The rekeyed node might be the scheduled leader, and so it'll immediately
--   reject its new block as invalid (since its delegation cannot have already
--   matured).
--
-- * The PBFT threshold may already be saturated for that node.
--
-- See @genNodeRekeys@ for the logic that ensures at least one of those slots'
-- leaders will be able to lead.
latestPossibleDlgMaturation ::
     SecurityParam -> NumCoreNodes -> SlotNo -> SlotNo
latestPossibleDlgMaturation :: SecurityParam -> NumCoreNodes -> SlotNo -> SlotNo
latestPossibleDlgMaturation
  (SecurityParam Word64
k) (NumCoreNodes Word64
n) (SlotNo Word64
rekeySlot) =
    Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ Word64
rekeySlot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
n Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
k

prop_simple_real_pbft_convergence :: TestSetup -> Property
prop_simple_real_pbft_convergence :: TestSetup -> Property
prop_simple_real_pbft_convergence TestSetup
  { setupEBBs :: TestSetup -> ProduceEBBs
setupEBBs         = ProduceEBBs
produceEBBs
  , setupK :: TestSetup -> SecurityParam
setupK            = SecurityParam
k
  , setupTestConfig :: TestSetup -> TestConfig
setupTestConfig   = TestConfig
testConfig
  , setupNodeJoinPlan :: TestSetup -> NodeJoinPlan
setupNodeJoinPlan = NodeJoinPlan
nodeJoinPlan
  , setupNodeRestarts :: TestSetup -> NodeRestarts
setupNodeRestarts = NodeRestarts
nodeRestarts
  , setupSlotLength :: TestSetup -> SlotLength
setupSlotLength   = SlotLength
slotLength
  , setupVersion :: TestSetup -> (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
setupVersion      = (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
version
  } =
    [Char] -> [[Char]] -> Property -> Property
forall prop.
Testable prop =>
[Char] -> [[Char]] -> prop -> Property
tabulate [Char]
"produce EBBs" [ProduceEBBs -> [Char]
forall a. Show a => a -> [Char]
show ProduceEBBs
produceEBBs] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Char] -> [[Char]] -> Property -> Property
forall prop.
Testable prop =>
[Char] -> [[Char]] -> prop -> Property
tabulate [Char]
"Ref.PBFT result" [Result -> [Char]
Ref.resultConstrName Result
refResult] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Char] -> [[Char]] -> Property -> Property
forall prop.
Testable prop =>
[Char] -> [[Char]] -> prop -> Property
tabulate [Char]
"proposed protocol version was adopted" [Bool -> [Char]
forall a. Show a => a -> [Char]
show Bool
aPvuRequired] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Char] -> [[Char]] -> Property -> Property
forall prop.
Testable prop =>
[Char] -> [[Char]] -> prop -> Property
tabulate [Char]
"proposed software version was adopted" [Bool -> [Char]
forall a. Show a => a -> [Char]
show Bool
aSvuRequired] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"params: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> PBftParams -> [Char]
forall a. Show a => a -> [Char]
show PBftParams
params) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Ref.PBFT result: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Result -> [Char]
forall a. Show a => a -> [Char]
show Result
refResult) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample
      ([Char]
"delegation certificates: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [(NodeId, [(SlotNumber, [ACertificate ByteString])])] -> [Char]
forall a. Show a => a -> [Char]
show [
            (,) NodeId
nid ([(SlotNumber, [ACertificate ByteString])]
 -> (NodeId, [(SlotNumber, [ACertificate ByteString])]))
-> [(SlotNumber, [ACertificate ByteString])]
-> (NodeId, [(SlotNumber, [ACertificate ByteString])])
forall a b. (a -> b) -> a -> b
$
            (Maybe (SlotNumber, [ACertificate ByteString])
 -> Maybe (SlotNumber, [ACertificate ByteString]))
-> [Maybe (SlotNumber, [ACertificate ByteString])]
-> [(SlotNumber, [ACertificate ByteString])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe (SlotNumber, [ACertificate ByteString])
-> ((SlotNumber, [ACertificate ByteString])
    -> Maybe (SlotNumber, [ACertificate ByteString]))
-> Maybe (SlotNumber, [ACertificate ByteString])
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \x :: (SlotNumber, [ACertificate ByteString])
x@(SlotNumber
_, [ACertificate ByteString]
dlgs) -> if [ACertificate ByteString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ACertificate ByteString]
dlgs then Maybe (SlotNumber, [ACertificate ByteString])
forall a. Maybe a
Nothing else (SlotNumber, [ACertificate ByteString])
-> Maybe (SlotNumber, [ACertificate ByteString])
forall a. a -> Maybe a
Just (SlotNumber, [ACertificate ByteString])
x) ([Maybe (SlotNumber, [ACertificate ByteString])]
 -> [(SlotNumber, [ACertificate ByteString])])
-> [Maybe (SlotNumber, [ACertificate ByteString])]
-> [(SlotNumber, [ACertificate ByteString])]
forall a b. (a -> b) -> a -> b
$
            [ case ByronBlock -> ABlockOrBoundary ByteString
Byron.byronBlockRaw ByronBlock
blk of
                Block.ABOBBlock ABlock ByteString
b    -> (SlotNumber, [ACertificate ByteString])
-> Maybe (SlotNumber, [ACertificate ByteString])
forall a. a -> Maybe a
Just (ABlock ByteString -> SlotNumber
forall a. ABlock a -> SlotNumber
Block.blockSlot ABlock ByteString
b, APayload ByteString -> [ACertificate ByteString]
forall a. APayload a -> [ACertificate a]
Delegation.getPayload (APayload ByteString -> [ACertificate ByteString])
-> APayload ByteString -> [ACertificate ByteString]
forall a b. (a -> b) -> a -> b
$ ABlock ByteString -> APayload ByteString
forall a. ABlock a -> APayload a
Block.blockDlgPayload ABlock ByteString
b)
                Block.ABOBBoundary ABoundaryBlock ByteString
_ -> Maybe (SlotNumber, [ACertificate ByteString])
forall a. Maybe a
Nothing
            | ByronBlock
blk <- Chain ByronBlock -> [ByronBlock]
forall block. Chain block -> [block]
Chain.chainToList Chain ByronBlock
ch
            ]
          | (NodeId
nid, Chain ByronBlock
ch) <- [(NodeId, Chain ByronBlock)]
finalChains
          ]) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    PropGeneralArgs ByronBlock -> TestOutput ByronBlock -> Property
forall blk.
(Condense blk, Condense (HeaderHash blk), Eq blk, RunNode blk) =>
PropGeneralArgs blk -> TestOutput blk -> Property
prop_general PropGeneralArgs
      { pgaBlockProperty :: ByronBlock -> Property
pgaBlockProperty       = Property -> ByronBlock -> Property
forall a b. a -> b -> a
const (Property -> ByronBlock -> Property)
-> Property -> ByronBlock -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
      , pgaCountTxs :: ByronBlock -> Word64
pgaCountTxs            = ByronBlock -> Word64
Byron.countByronGenTxs
      , pgaExpectedCannotForge :: SlotNo -> NodeId -> WrapCannotForge ByronBlock -> Bool
pgaExpectedCannotForge = SecurityParam
-> NumCoreNodes
-> NodeRestarts
-> SlotNo
-> NodeId
-> WrapCannotForge ByronBlock
-> Bool
expectedCannotForge SecurityParam
k NumCoreNodes
numCoreNodes NodeRestarts
nodeRestarts
      , pgaFirstBlockNo :: BlockNo
pgaFirstBlockNo        = BlockNo
1
      , pgaFixedMaxForkLength :: Maybe NumBlocks
pgaFixedMaxForkLength  =
          NumBlocks -> Maybe NumBlocks
forall a. a -> Maybe a
Just (NumBlocks -> Maybe NumBlocks) -> NumBlocks -> Maybe NumBlocks
forall a b. (a -> b) -> a -> b
$ Word64 -> NumBlocks
NumBlocks (Word64 -> NumBlocks) -> Word64 -> NumBlocks
forall a b. (a -> b) -> a -> b
$ case Result
refResult of
            Ref.Forked{} -> Word64
1
            Result
_            -> Word64
0
      , pgaFixedSchedule :: Maybe LeaderSchedule
pgaFixedSchedule       =
          LeaderSchedule -> Maybe LeaderSchedule
forall a. a -> Maybe a
Just (LeaderSchedule -> Maybe LeaderSchedule)
-> LeaderSchedule -> Maybe LeaderSchedule
forall a b. (a -> b) -> a -> b
$ NumCoreNodes -> NumSlots -> LeaderSchedule
roundRobinLeaderSchedule NumCoreNodes
numCoreNodes NumSlots
numSlots
      , pgaSecurityParam :: SecurityParam
pgaSecurityParam       = SecurityParam
k
      , pgaTestConfig :: TestConfig
pgaTestConfig          = TestConfig
testConfig
      , pgaTestConfigB :: TestConfigB ByronBlock
pgaTestConfigB         = TestConfigB ByronBlock
testConfigB
      }
      TestOutput ByronBlock
testOutput Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
    Property
prop_pvu Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
    Property
prop_svu Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
    Bool -> Bool
not (((NodeId, Chain ByronBlock) -> Bool)
-> [(NodeId, Chain ByronBlock)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Chain ByronBlock -> Bool
forall block. Chain block -> Bool
Chain.null (Chain ByronBlock -> Bool)
-> ((NodeId, Chain ByronBlock) -> Chain ByronBlock)
-> (NodeId, Chain ByronBlock)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeId, Chain ByronBlock) -> Chain ByronBlock
forall a b. (a, b) -> b
snd) [(NodeId, Chain ByronBlock)]
finalChains) Bool -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
    case Result
refResult of
      Ref.Outcomes [Outcome]
outcomes ->
          [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin (((NodeId, Chain ByronBlock) -> Property)
-> [(NodeId, Chain ByronBlock)] -> [Property]
forall a b. (a -> b) -> [a] -> [b]
map (SecurityParam
-> ProduceEBBs
-> [Outcome]
-> (NodeId, Chain ByronBlock)
-> Property
hasAllEBBs SecurityParam
k ProduceEBBs
produceEBBs [Outcome]
outcomes) [(NodeId, Chain ByronBlock)]
finalChains)
      Result
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
  where
    TestConfig
      { NodeTopology
nodeTopology :: TestConfig -> NodeTopology
nodeTopology :: NodeTopology
nodeTopology
      , NumCoreNodes
numCoreNodes :: TestConfig -> NumCoreNodes
numCoreNodes :: NumCoreNodes
numCoreNodes
      , NumSlots
numSlots :: TestConfig -> NumSlots
numSlots :: NumSlots
numSlots
      , Seed
initSeed :: TestConfig -> Seed
initSeed :: Seed
initSeed
      } = TestConfig
testConfig

    testConfigB :: TestConfigB ByronBlock
testConfigB = TestConfigB
      { forgeEbbEnv :: Maybe (ForgeEbbEnv ByronBlock)
forgeEbbEnv = case ProduceEBBs
produceEBBs of
          ProduceEBBs
NoEBBs      -> Maybe (ForgeEbbEnv ByronBlock)
forall a. Maybe a
Nothing
          ProduceEBBs
ProduceEBBs -> ForgeEbbEnv ByronBlock -> Maybe (ForgeEbbEnv ByronBlock)
forall a. a -> Maybe a
Just ForgeEbbEnv ByronBlock
byronForgeEbbEnv
      , future :: Future
future       = SlotLength -> EpochSize -> Future
singleEraFuture SlotLength
slotLength EpochSize
epochSize
      , messageDelay :: CalcMessageDelay ByronBlock
messageDelay = CalcMessageDelay ByronBlock
forall blk. CalcMessageDelay blk
noCalcMessageDelay
      , NodeJoinPlan
nodeJoinPlan :: NodeJoinPlan
nodeJoinPlan :: NodeJoinPlan
nodeJoinPlan
      , NodeRestarts
nodeRestarts :: NodeRestarts
nodeRestarts :: NodeRestarts
nodeRestarts
      , txGenExtra :: TxGenExtra ByronBlock
txGenExtra   = ()
      , version :: (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
version      = (NodeToNodeVersion, BlockNodeToNodeVersion ByronBlock)
version
      }

    testOutput :: TestOutput ByronBlock
testOutput =
        TestConfig
-> TestConfigB ByronBlock
-> (forall (m :: * -> *). IOLike m => TestConfigMB m ByronBlock)
-> TestOutput ByronBlock
forall blk.
(RunNode blk, TxGen blk, TracingConstraints blk, HasCallStack) =>
TestConfig
-> TestConfigB blk
-> (forall (m :: * -> *). IOLike m => TestConfigMB m blk)
-> TestOutput blk
runTestNetwork TestConfig
testConfig TestConfigB ByronBlock
testConfigB TestConfigMB
            { nodeInfo :: CoreNodeId -> TestNodeInitialization m ByronBlock
nodeInfo = \CoreNodeId
nid ->
                PBftParams
-> CoreNodeId
-> Config
-> GeneratedSecrets
-> ProtocolVersion
-> TestNodeInitialization m ByronBlock
forall (m :: * -> *).
(Monad m, HasCallStack) =>
PBftParams
-> CoreNodeId
-> Config
-> GeneratedSecrets
-> ProtocolVersion
-> TestNodeInitialization m ByronBlock
mkProtocolByronAndHardForkTxs
                  PBftParams
params CoreNodeId
nid Config
genesisConfig GeneratedSecrets
genesisSecrets
                  ProtocolVersion
theProposedProtocolVersion
            , mkRekeyM :: Maybe (m (RekeyM m ByronBlock))
mkRekeyM = m (RekeyM m ByronBlock) -> Maybe (m (RekeyM m ByronBlock))
forall a. a -> Maybe a
Just (m (RekeyM m ByronBlock) -> Maybe (m (RekeyM m ByronBlock)))
-> m (RekeyM m ByronBlock) -> Maybe (m (RekeyM m ByronBlock))
forall a b. (a -> b) -> a -> b
$ Rekeying m ByronBlock -> m (RekeyM m ByronBlock)
forall (m :: * -> *) blk.
IOLike m =>
Rekeying m blk -> m (RekeyM m blk)
fromRekeyingToRekeyM Rekeying
              { rekeyOracle :: CoreNodeId -> SlotNo -> Maybe SlotNo
rekeyOracle   = \CoreNodeId
cid SlotNo
s ->
                  let nominalSlots :: Set SlotNo
nominalSlots = case Result
refResult of
                        Ref.Forked{}           -> Set SlotNo
forall a. Set a
Set.empty
                        Ref.Outcomes [Outcome]
outcomes  ->
                          [SlotNo] -> Set SlotNo
forall a. Ord a => [a] -> Set a
Set.fromList ([SlotNo] -> Set SlotNo) -> [SlotNo] -> Set SlotNo
forall a b. (a -> b) -> a -> b
$
                          [ SlotNo
s'
                          | (Outcome
Ref.Nominal, SlotNo
s') <- [Outcome] -> [SlotNo] -> [(Outcome, SlotNo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Outcome]
outcomes [SlotNo
0..]
                            -- ignore the 'Ref.Nominal's disrupted by the
                            -- rekey; see comment on 'refResult'
                          , CoreNodeId
cid CoreNodeId -> CoreNodeId -> Bool
forall a. Eq a => a -> a -> Bool
/= PBftParams -> SlotNo -> CoreNodeId
Ref.mkLeaderOf PBftParams
params SlotNo
s'
                          ]
                        Ref.Nondeterministic{} -> Set SlotNo
forall a. Set a
Set.empty
                  in SlotNo -> Set SlotNo -> Maybe SlotNo
forall a. Ord a => a -> Set a -> Maybe a
Set.lookupGT SlotNo
s Set SlotNo
nominalSlots
              , rekeyUpd :: CoreNodeId
-> ProtocolInfo ByronBlock
-> m [BlockForging m ByronBlock]
-> EpochNo
-> SignKeyDSIGN ByronDSIGN
-> m (Maybe (TestNodeInitialization m ByronBlock))
rekeyUpd      = Config
-> GeneratedSecrets
-> CoreNodeId
-> ProtocolInfo ByronBlock
-> m [BlockForging m ByronBlock]
-> EpochNo
-> SignKeyDSIGN ByronDSIGN
-> m (Maybe (TestNodeInitialization m ByronBlock))
forall (m :: * -> *).
Monad m =>
Config
-> GeneratedSecrets
-> CoreNodeId
-> ProtocolInfo ByronBlock
-> m [BlockForging m ByronBlock]
-> EpochNo
-> SignKeyDSIGN ByronDSIGN
-> m (Maybe (TestNodeInitialization m ByronBlock))
mkRekeyUpd Config
genesisConfig GeneratedSecrets
genesisSecrets
              , rekeyFreshSKs :: Stream (SignKeyDSIGN ByronDSIGN)
rekeyFreshSKs =
                  let prj :: SignKeyDSIGN (PBftDSIGN PBftByronCrypto)
-> PBftVerKeyHash PBftByronCrypto
prj  = VerKeyDSIGN (PBftDSIGN PBftByronCrypto)
-> PBftVerKeyHash PBftByronCrypto
forall c.
PBftCrypto c =>
VerKeyDSIGN (PBftDSIGN c) -> PBftVerKeyHash c
Crypto.hashVerKey (VerKeyDSIGN (PBftDSIGN PBftByronCrypto)
 -> PBftVerKeyHash PBftByronCrypto)
-> (SignKeyDSIGN (PBftDSIGN PBftByronCrypto)
    -> VerKeyDSIGN (PBftDSIGN PBftByronCrypto))
-> SignKeyDSIGN (PBftDSIGN PBftByronCrypto)
-> PBftVerKeyHash PBftByronCrypto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignKeyDSIGN (PBftDSIGN PBftByronCrypto)
-> VerKeyDSIGN (PBftDSIGN PBftByronCrypto)
forall v. DSIGNAlgorithm v => SignKeyDSIGN v -> VerKeyDSIGN v
Crypto.deriveVerKeyDSIGN
                      acc0 :: Set KeyHash
acc0 =   -- the VKs of the operational keys at genesis
                        [KeyHash] -> Set KeyHash
forall a. Ord a => [a] -> Set a
Set.fromList ([KeyHash] -> Set KeyHash) -> [KeyHash] -> Set KeyHash
forall a b. (a -> b) -> a -> b
$
                        (Certificate -> KeyHash) -> [Certificate] -> [KeyHash]
forall a b. (a -> b) -> [a] -> [b]
map (VerificationKey -> KeyHash
Common.hashKey (VerificationKey -> KeyHash)
-> (Certificate -> VerificationKey) -> Certificate -> KeyHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Certificate -> VerificationKey
forall a. ACertificate a -> VerificationKey
Delegation.delegateVK) ([Certificate] -> [KeyHash]) -> [Certificate] -> [KeyHash]
forall a b. (a -> b) -> a -> b
$
                        Map KeyHash Certificate -> [Certificate]
forall k a. Map k a -> [a]
Map.elems (Map KeyHash Certificate -> [Certificate])
-> Map KeyHash Certificate -> [Certificate]
forall a b. (a -> b) -> a -> b
$
                        GenesisDelegation -> Map KeyHash Certificate
Genesis.unGenesisDelegation (GenesisDelegation -> Map KeyHash Certificate)
-> GenesisDelegation -> Map KeyHash Certificate
forall a b. (a -> b) -> a -> b
$
                        GenesisData -> GenesisDelegation
Genesis.gdHeavyDelegation (GenesisData -> GenesisDelegation)
-> GenesisData -> GenesisDelegation
forall a b. (a -> b) -> a -> b
$
                        Config -> GenesisData
Genesis.configGenesisData Config
genesisConfig
                      genKeyDSIGNRandom :: Gen (SignKeyDSIGN ByronDSIGN)
genKeyDSIGNRandom = do
                        Seed -> SignKeyDSIGN ByronDSIGN
forall v. DSIGNAlgorithm v => Seed -> SignKeyDSIGN v
Crypto.genKeyDSIGN (Seed -> SignKeyDSIGN ByronDSIGN)
-> ([Word8] -> Seed) -> [Word8] -> SignKeyDSIGN ByronDSIGN
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Seed
mkSeedFromBytes (ByteString -> Seed) -> ([Word8] -> ByteString) -> [Word8] -> Seed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack
                          ([Word8] -> SignKeyDSIGN ByronDSIGN)
-> Gen [Word8] -> Gen (SignKeyDSIGN ByronDSIGN)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Word8 -> Gen [Word8]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
32 Gen Word8
forall a. Arbitrary a => Gen a
arbitrary
                  in
                  (SignKeyDSIGN ByronDSIGN -> KeyHash)
-> Set KeyHash
-> Stream (SignKeyDSIGN ByronDSIGN)
-> Stream (SignKeyDSIGN ByronDSIGN)
forall b a. Ord b => (a -> b) -> Set b -> Stream a -> Stream a
Stream.nubOrdBy SignKeyDSIGN (PBftDSIGN PBftByronCrypto)
-> PBftVerKeyHash PBftByronCrypto
SignKeyDSIGN ByronDSIGN -> KeyHash
prj Set KeyHash
acc0 (Stream (SignKeyDSIGN ByronDSIGN)
 -> Stream (SignKeyDSIGN ByronDSIGN))
-> Stream (SignKeyDSIGN ByronDSIGN)
-> Stream (SignKeyDSIGN ByronDSIGN)
forall a b. (a -> b) -> a -> b
$
                    Seed
-> Gen (Stream (SignKeyDSIGN ByronDSIGN))
-> Stream (SignKeyDSIGN ByronDSIGN)
forall a. Seed -> Gen a -> a
runGen Seed
initSeed (Gen (Stream (SignKeyDSIGN ByronDSIGN))
 -> Stream (SignKeyDSIGN ByronDSIGN))
-> Gen (Stream (SignKeyDSIGN ByronDSIGN))
-> Stream (SignKeyDSIGN ByronDSIGN)
forall a b. (a -> b) -> a -> b
$   -- seems fine to reuse seed for this
                      Stream (Gen (SignKeyDSIGN ByronDSIGN))
-> Gen (Stream (SignKeyDSIGN ByronDSIGN))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => Stream (m a) -> m (Stream a)
sequence (Stream (Gen (SignKeyDSIGN ByronDSIGN))
 -> Gen (Stream (SignKeyDSIGN ByronDSIGN)))
-> Stream (Gen (SignKeyDSIGN ByronDSIGN))
-> Gen (Stream (SignKeyDSIGN ByronDSIGN))
forall a b. (a -> b) -> a -> b
$ let ms :: Stream (Gen (SignKeyDSIGN ByronDSIGN))
ms = Gen (SignKeyDSIGN ByronDSIGN)
genKeyDSIGNRandom Gen (SignKeyDSIGN ByronDSIGN)
-> Stream (Gen (SignKeyDSIGN ByronDSIGN))
-> Stream (Gen (SignKeyDSIGN ByronDSIGN))
forall a. a -> Stream a -> Stream a
Stream.:< Stream (Gen (SignKeyDSIGN ByronDSIGN))
ms in Stream (Gen (SignKeyDSIGN ByronDSIGN))
ms
              }
            }

    -- Byron has a hard-coded relation between k and the size of an epoch
    epochSize :: EpochSize
    epochSize :: EpochSize
epochSize = EpochSlots -> EpochSize
fromByronEpochSlots (EpochSlots -> EpochSize) -> EpochSlots -> EpochSize
forall a b. (a -> b) -> a -> b
$ BlockCount -> EpochSlots
kEpochSlots (SecurityParam -> BlockCount
toByronBlockCount SecurityParam
k)

    -- NOTE: If a node is rekeying, then the 'Ref.Outcome' case will include
    -- some 'Ref.Nominal' outcomes that should actually be 'Ref.Unable'.
    refResult :: Ref.Result
    refResult :: Result
refResult = HasCallStack => PBftParams -> NodeJoinPlan -> NumSlots -> Result
PBftParams -> NodeJoinPlan -> NumSlots -> Result
Ref.simulate PBftParams
params NodeJoinPlan
nodeJoinPlan NumSlots
numSlots

    finalChains :: [(NodeId, Chain ByronBlock)]
    finalChains :: [(NodeId, Chain ByronBlock)]
finalChains = Map NodeId (Chain ByronBlock) -> [(NodeId, Chain ByronBlock)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map NodeId (Chain ByronBlock) -> [(NodeId, Chain ByronBlock)])
-> Map NodeId (Chain ByronBlock) -> [(NodeId, Chain ByronBlock)]
forall a b. (a -> b) -> a -> b
$ NodeOutput ByronBlock -> Chain ByronBlock
forall blk. NodeOutput blk -> Chain blk
nodeOutputFinalChain (NodeOutput ByronBlock -> Chain ByronBlock)
-> Map NodeId (NodeOutput ByronBlock)
-> Map NodeId (Chain ByronBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestOutput ByronBlock -> Map NodeId (NodeOutput ByronBlock)
forall blk. TestOutput blk -> Map NodeId (NodeOutput blk)
testOutputNodes TestOutput ByronBlock
testOutput

    finalLedgers :: [(NodeId, Byron.LedgerState ByronBlock)]
    finalLedgers :: [(NodeId, LedgerState ByronBlock)]
finalLedgers = Map NodeId (LedgerState ByronBlock)
-> [(NodeId, LedgerState ByronBlock)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map NodeId (LedgerState ByronBlock)
 -> [(NodeId, LedgerState ByronBlock)])
-> Map NodeId (LedgerState ByronBlock)
-> [(NodeId, LedgerState ByronBlock)]
forall a b. (a -> b) -> a -> b
$ NodeOutput ByronBlock -> LedgerState ByronBlock
forall blk. NodeOutput blk -> LedgerState blk
nodeOutputFinalLedger (NodeOutput ByronBlock -> LedgerState ByronBlock)
-> Map NodeId (NodeOutput ByronBlock)
-> Map NodeId (LedgerState ByronBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestOutput ByronBlock -> Map NodeId (NodeOutput ByronBlock)
forall blk. TestOutput blk -> Map NodeId (NodeOutput blk)
testOutputNodes TestOutput ByronBlock
testOutput

    pvuLabels :: [(NodeId, ProtocolVersionUpdateLabel)]
    pvuLabels :: [(NodeId, ProtocolVersionUpdateLabel)]
pvuLabels = ((NodeId, (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel))
 -> (NodeId, ProtocolVersionUpdateLabel))
-> [(NodeId,
     (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel))]
-> [(NodeId, ProtocolVersionUpdateLabel)]
forall a b. (a -> b) -> [a] -> [b]
map (((ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel)
 -> ProtocolVersionUpdateLabel)
-> (NodeId,
    (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel))
-> (NodeId, ProtocolVersionUpdateLabel)
forall a b. (a -> b) -> (NodeId, a) -> (NodeId, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel)
-> ProtocolVersionUpdateLabel
forall a b. (a, b) -> a
fst) [(NodeId,
  (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel))]
updLabels

    svuLabels :: [(NodeId, SoftwareVersionUpdateLabel)]
    svuLabels :: [(NodeId, SoftwareVersionUpdateLabel)]
svuLabels = ((NodeId, (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel))
 -> (NodeId, SoftwareVersionUpdateLabel))
-> [(NodeId,
     (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel))]
-> [(NodeId, SoftwareVersionUpdateLabel)]
forall a b. (a -> b) -> [a] -> [b]
map (((ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel)
 -> SoftwareVersionUpdateLabel)
-> (NodeId,
    (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel))
-> (NodeId, SoftwareVersionUpdateLabel)
forall a b. (a -> b) -> (NodeId, a) -> (NodeId, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel)
-> SoftwareVersionUpdateLabel
forall a b. (a, b) -> b
snd) [(NodeId,
  (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel))]
updLabels

    updLabels
      :: [(NodeId, (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel))]
    updLabels :: [(NodeId,
  (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel))]
updLabels =
        [ (,) NodeId
cid ((ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel)
 -> (NodeId,
     (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel)))
-> (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel)
-> (NodeId,
    (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel))
forall a b. (a -> b) -> a -> b
$
          PBftParams
-> NumSlots
-> Config
-> NodeJoinPlan
-> NodeTopology
-> Result
-> LedgerState ByronBlock
-> (ProtocolVersionUpdateLabel, SoftwareVersionUpdateLabel)
mkUpdateLabels
            PBftParams
params
            NumSlots
numSlots
            Config
genesisConfig
            NodeJoinPlan
nodeJoinPlan
            NodeTopology
nodeTopology
            Result
refResult
            LedgerState ByronBlock
ldgr
        | (NodeId
cid, LedgerState ByronBlock
ldgr) <- [(NodeId, LedgerState ByronBlock)]
finalLedgers
        ]

    -- whether the proposed protocol version was required to have been adopted
    -- in one of the chains
    aPvuRequired :: Bool
    aPvuRequired :: Bool
aPvuRequired =
        [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
        [ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Bool
pvuRequired
        | (NodeId
_, ProtocolVersionUpdateLabel{Maybe Bool
pvuRequired :: Maybe Bool
pvuRequired :: ProtocolVersionUpdateLabel -> Maybe Bool
pvuRequired}) <- [(NodeId, ProtocolVersionUpdateLabel)]
pvuLabels
        ]

    -- whether the proposed software version was required to have been adopted in
    -- one of the chains
    aSvuRequired :: Bool
    aSvuRequired :: Bool
aSvuRequired =
        [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
        [ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Bool
svuRequired
        | (NodeId
_, SoftwareVersionUpdateLabel{Maybe Bool
svuRequired :: Maybe Bool
svuRequired :: SoftwareVersionUpdateLabel -> Maybe Bool
svuRequired}) <- [(NodeId, SoftwareVersionUpdateLabel)]
svuLabels
        ]

    -- check whether the proposed protocol version should have been and if so
    -- was adopted
    prop_pvu :: Property
    prop_pvu :: Property
prop_pvu =
        [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([(NodeId, ProtocolVersionUpdateLabel)] -> [Char]
forall a. Show a => a -> [Char]
show [(NodeId, ProtocolVersionUpdateLabel)]
pvuLabels) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
        [ [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ((NodeId, ProtocolVersionUpdateLabel) -> [Char]
forall a. Show a => a -> [Char]
show (NodeId
cid, ProtocolVersionUpdateLabel
pvuLabel)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          let ProtocolVersionUpdateLabel
                { Bool
pvuObserved :: Bool
pvuObserved :: ProtocolVersionUpdateLabel -> Bool
pvuObserved
                , Maybe Bool
pvuRequired :: ProtocolVersionUpdateLabel -> Maybe Bool
pvuRequired :: Maybe Bool
pvuRequired
                } = ProtocolVersionUpdateLabel
pvuLabel
          in
          Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ case Maybe Bool
pvuRequired of
            Just Bool
b  -> Bool
b Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
pvuObserved
            Maybe Bool
Nothing -> Bool
True
        | (NodeId
cid, ProtocolVersionUpdateLabel
pvuLabel) <- [(NodeId, ProtocolVersionUpdateLabel)]
pvuLabels
        ]

    -- check whether the proposed software version should have been and if so
    -- was adopted
    prop_svu :: Property
    prop_svu :: Property
prop_svu =
        [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([(NodeId, SoftwareVersionUpdateLabel)] -> [Char]
forall a. Show a => a -> [Char]
show [(NodeId, SoftwareVersionUpdateLabel)]
svuLabels) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin
        [ [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ((NodeId, SoftwareVersionUpdateLabel) -> [Char]
forall a. Show a => a -> [Char]
show (NodeId
cid, SoftwareVersionUpdateLabel
svuLabel)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
          let SoftwareVersionUpdateLabel
                { Bool
svuObserved :: Bool
svuObserved :: SoftwareVersionUpdateLabel -> Bool
svuObserved
                , Maybe Bool
svuRequired :: SoftwareVersionUpdateLabel -> Maybe Bool
svuRequired :: Maybe Bool
svuRequired
                } = SoftwareVersionUpdateLabel
svuLabel
          in
          Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ case Maybe Bool
svuRequired of
            Just Bool
b  -> Bool
b Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
svuObserved
            Maybe Bool
Nothing -> Bool
True
        | (NodeId
cid, SoftwareVersionUpdateLabel
svuLabel) <- [(NodeId, SoftwareVersionUpdateLabel)]
svuLabels
        ]

    params :: PBftParams
    params :: PBftParams
params = SecurityParam -> NumCoreNodes -> PBftParams
byronPBftParams SecurityParam
k NumCoreNodes
numCoreNodes

    genesisConfig  :: Genesis.Config
    genesisSecrets :: Genesis.GeneratedSecrets
    (Config
genesisConfig, GeneratedSecrets
genesisSecrets) = SlotLength -> PBftParams -> (Config, GeneratedSecrets)
generateGenesisConfig SlotLength
slotLength PBftParams
params

byronForgeEbbEnv :: ForgeEbbEnv ByronBlock
byronForgeEbbEnv :: ForgeEbbEnv ByronBlock
byronForgeEbbEnv = ForgeEbbEnv
    { forgeEBB :: TopLevelConfig ByronBlock
-> SlotNo -> BlockNo -> ChainHash ByronBlock -> ByronBlock
forgeEBB = BlockConfig ByronBlock
-> SlotNo -> BlockNo -> ChainHash ByronBlock -> ByronBlock
Byron.forgeEBB (BlockConfig ByronBlock
 -> SlotNo -> BlockNo -> ChainHash ByronBlock -> ByronBlock)
-> (TopLevelConfig ByronBlock -> BlockConfig ByronBlock)
-> TopLevelConfig ByronBlock
-> SlotNo
-> BlockNo
-> ChainHash ByronBlock
-> ByronBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevelConfig ByronBlock -> BlockConfig ByronBlock
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock
    }

-- | Whether to produce EBBs in the tests or not
--
-- TODO add a case to generate EBBs upto some epoch, like on mainnet
data ProduceEBBs
  = NoEBBs
    -- ^ No EBBs are produced in the tests. The node will still automatically
    -- produce its own genesis EBB.
  | ProduceEBBs
    -- ^ In addition to the genesis EBB the node generates itself, the tests
    -- also produce an EBB at the start of each subsequent epoch.
  deriving (ProduceEBBs -> ProduceEBBs -> Bool
(ProduceEBBs -> ProduceEBBs -> Bool)
-> (ProduceEBBs -> ProduceEBBs -> Bool) -> Eq ProduceEBBs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProduceEBBs -> ProduceEBBs -> Bool
== :: ProduceEBBs -> ProduceEBBs -> Bool
$c/= :: ProduceEBBs -> ProduceEBBs -> Bool
/= :: ProduceEBBs -> ProduceEBBs -> Bool
Eq, Int -> ProduceEBBs -> ShowS
[ProduceEBBs] -> ShowS
ProduceEBBs -> [Char]
(Int -> ProduceEBBs -> ShowS)
-> (ProduceEBBs -> [Char])
-> ([ProduceEBBs] -> ShowS)
-> Show ProduceEBBs
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ProduceEBBs -> ShowS
showsPrec :: Int -> ProduceEBBs -> ShowS
$cshow :: ProduceEBBs -> [Char]
show :: ProduceEBBs -> [Char]
$cshowList :: [ProduceEBBs] -> ShowS
showList :: [ProduceEBBs] -> ShowS
Show)

-- | Exported alias for 'NoEBBs'.
--
noEBBs :: ProduceEBBs
noEBBs :: ProduceEBBs
noEBBs = ProduceEBBs
NoEBBs

instance Arbitrary ProduceEBBs where
  arbitrary :: Gen ProduceEBBs
arbitrary = [ProduceEBBs] -> Gen ProduceEBBs
forall a. HasCallStack => [a] -> Gen a
elements [ProduceEBBs
NoEBBs, ProduceEBBs
ProduceEBBs]
  shrink :: ProduceEBBs -> [ProduceEBBs]
shrink ProduceEBBs
NoEBBs      = []
  shrink ProduceEBBs
ProduceEBBs = [ProduceEBBs
NoEBBs]

hasAllEBBs :: SecurityParam
           -> ProduceEBBs
           -> [Ref.Outcome]
           -> (NodeId, Chain ByronBlock)
           -> Property
hasAllEBBs :: SecurityParam
-> ProduceEBBs
-> [Outcome]
-> (NodeId, Chain ByronBlock)
-> Property
hasAllEBBs SecurityParam
k ProduceEBBs
produceEBBs [Outcome]
outcomes (NodeId
nid, Chain ByronBlock
c) =
    [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Missing or unexpected EBBs in " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> (NodeId, Chain ByronBlock) -> [Char]
forall a. Condense a => a -> [Char]
condense (NodeId
nid, Chain ByronBlock
c)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [EpochNo]
actual [EpochNo] -> [EpochNo] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [EpochNo]
expected
  where
    expected :: [EpochNo]
    expected :: [EpochNo]
expected = case ProduceEBBs
produceEBBs of
      ProduceEBBs
NoEBBs      -> [EpochNo
0]
      ProduceEBBs
ProduceEBBs -> case [SlotNo] -> [SlotNo]
forall a. [a] -> [a]
reverse [ SlotNo
s :: SlotNo | (Outcome
Ref.Nominal, SlotNo
s) <- [Outcome] -> [SlotNo] -> [(Outcome, SlotNo)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Outcome]
outcomes [SlotNo
0..] ] of
          []  -> [EpochNo
0]
          SlotNo
s:[SlotNo]
_ -> [Word64] -> [EpochNo]
forall a b. Coercible a b => a -> b
coerce [Word64
0 .. Word64
hi]
            where
              hi :: Word64
              hi :: Word64
hi = SlotNo -> Word64
unSlotNo SlotNo
s Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
denom
              denom :: Word64
denom = EpochSlots -> Word64
unEpochSlots (EpochSlots -> Word64) -> EpochSlots -> Word64
forall a b. (a -> b) -> a -> b
$ BlockCount -> EpochSlots
kEpochSlots (BlockCount -> EpochSlots) -> BlockCount -> EpochSlots
forall a b. (a -> b) -> a -> b
$ SecurityParam -> BlockCount
forall a b. Coercible a b => a -> b
coerce SecurityParam
k

    actual :: [EpochNo]
actual   = (ByronBlock -> Maybe EpochNo) -> [ByronBlock] -> [EpochNo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ByronBlock -> Maybe EpochNo
forall blk. GetHeader blk => blk -> Maybe EpochNo
blockIsEBB ([ByronBlock] -> [EpochNo]) -> [ByronBlock] -> [EpochNo]
forall a b. (a -> b) -> a -> b
$ Chain ByronBlock -> [ByronBlock]
forall block. Chain block -> [block]
Chain.toOldestFirst Chain ByronBlock
c

{-------------------------------------------------------------------------------
  Generating node join plans that ensure sufficiently dense chains
-------------------------------------------------------------------------------}

genSlot :: SlotNo -> SlotNo -> Gen SlotNo
genSlot :: SlotNo -> SlotNo -> Gen SlotNo
genSlot SlotNo
lo SlotNo
hi = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Gen Word64 -> Gen SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (SlotNo -> Word64
unSlotNo SlotNo
lo, SlotNo -> Word64
unSlotNo SlotNo
hi)

-- | As 'genNodeJoinPlan', but ensures an additional invariant
--
-- INVARIANT this 'NodeJoinPlan' ensures that -- under \"ideal circumstances\"
-- -- the chain includes at least @k@ blocks within every @2k@-slot window.
--
-- Note that there is only one chain: at any slot onset, the net's fork only
-- has one tine.
--
genByronNodeJoinPlan :: PBftParams -> NumSlots -> Gen NodeJoinPlan
genByronNodeJoinPlan :: PBftParams -> NumSlots -> Gen NodeJoinPlan
genByronNodeJoinPlan PBftParams
params numSlots :: NumSlots
numSlots@(NumSlots Word64
t)
  | Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
0 Bool -> Bool -> Bool
|| Word64
t Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
1 = [Char] -> Gen NodeJoinPlan
forall a. HasCallStack => [Char] -> a
error ([Char] -> Gen NodeJoinPlan) -> [Char] -> Gen NodeJoinPlan
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot generate Byron NodeJoinPlan: "
    [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (PBftParams, NumSlots) -> [Char]
forall a. Show a => a -> [Char]
show (PBftParams
params, NumSlots
numSlots)
  | Bool
otherwise      =
    NodeJoinPlan -> State -> Gen NodeJoinPlan
go (Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan Map CoreNodeId SlotNo
forall k a. Map k a
Map.empty) State
Ref.emptyState
      Gen NodeJoinPlan -> (NodeJoinPlan -> Bool) -> Gen NodeJoinPlan
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (\NodeJoinPlan
njp -> PBftParams -> Result -> Bool
Ref.definitelyEnoughBlocks PBftParams
params (Result -> Bool) -> Result -> Bool
forall a b. (a -> b) -> a -> b
$
                          HasCallStack => PBftParams -> NodeJoinPlan -> NumSlots -> Result
PBftParams -> NodeJoinPlan -> NumSlots -> Result
Ref.simulate PBftParams
params NodeJoinPlan
njp NumSlots
numSlots)

        -- This suchThat might loop a few times, but it should always
        -- eventually succeed, since the plan where all nodes join immediately
        -- satisfies it.
        --
        -- In a run of 7000 successful Byron tests, this 'suchThat' retried:
        --
        -- 486 retried once
        -- 100 retried twice
        -- 10 retried 3 times
        -- 4 retried 4 times
        -- 4 retried 5 times
        -- 1 retried 6 times
  where
    PBftParams{NumCoreNodes
pbftNumNodes :: NumCoreNodes
pbftNumNodes :: PBftParams -> NumCoreNodes
pbftNumNodes} = PBftParams
params
    NumCoreNodes Word64
n           = NumCoreNodes
pbftNumNodes

    sentinel :: SlotNo
sentinel = Word64 -> SlotNo
SlotNo Word64
t
    lastSlot :: SlotNo
lastSlot = SlotNo -> SlotNo
forall a. Enum a => a -> a
pred SlotNo
sentinel   -- note the t guard above

    go ::
         NodeJoinPlan
         -- ^ an /incomplete/ and /viable/ node join plan
      -> Ref.State
         -- ^ a state whose 'Ref.nextSlot' is <= the last join slot in given
         -- plan (or 0 if the plan is empty)
      -> Gen NodeJoinPlan
    go :: NodeJoinPlan -> State -> Gen NodeJoinPlan
go nodeJoinPlan :: NodeJoinPlan
nodeJoinPlan@(NodeJoinPlan Map CoreNodeId SlotNo
m) State
st
      | Word64
i Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
n    = NodeJoinPlan -> Gen NodeJoinPlan
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeJoinPlan -> Gen NodeJoinPlan)
-> NodeJoinPlan -> Gen NodeJoinPlan
forall a b. (a -> b) -> a -> b
$ Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan Map CoreNodeId SlotNo
m
      | Bool
otherwise = do
            -- @True@ if this join slot for @nid@ is viable
            --
            -- /Viable/ means the desired chain density invariant remains
            -- satisfiable, at the very least the nodes after @nid@ may need to
            -- also join in this same slot.
            --
            -- Assuming @nodeJoinPlan@ is indeed viable and @st@ is indeed not
            -- ahead of it, then we should be able to find a join slot for
            -- @nid@ that is also viable: the viability of @nodeJoinPlan@ means
            -- @nid@ can at least join \"immediately\" wrt to @nodeJoinPlan@.
            --
            -- The base case is that the empty join plan and empty state are
            -- viable, which assumes that the invariant would be satisfied if
            -- all nodes join in slot 0. For uninterrupted round-robin, that
            -- merely requires @n * floor (k * t) >= k@. (TODO Does that
            -- __always__ suffice?)
        let check :: SlotNo -> Bool
check SlotNo
s' =
                PBftParams -> SlotNo -> NodeJoinPlan -> State -> Bool
Ref.viable PBftParams
params SlotNo
sentinel
                    (Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan (CoreNodeId
-> SlotNo -> Map CoreNodeId SlotNo -> Map CoreNodeId SlotNo
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CoreNodeId
nid SlotNo
s' Map CoreNodeId SlotNo
m))
                    State
st
            lo :: SlotNo
lo = State -> SlotNo
Ref.nextSlot State
st

            -- @check@ is downward-closed, but 'searchFromTo' requires
            -- upward-closed, so we search in dualized range
            inn :: SlotNo -> Word64
inn = (Word64
forall a. Bounded a => a
maxBound Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
-) (Word64 -> Word64) -> (SlotNo -> Word64) -> SlotNo -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> Word64
unSlotNo
            out :: Word64 -> SlotNo
out = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> (Word64 -> Word64) -> Word64 -> SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64
forall a. Bounded a => a
maxBound Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
-)
        SlotNo
s' <- case Word64 -> SlotNo
out (Word64 -> SlotNo) -> Maybe Word64 -> Maybe SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64 -> Bool) -> Word64 -> Word64 -> Maybe Word64
forall a. Integral a => (a -> Bool) -> a -> a -> Maybe a
searchFromTo (SlotNo -> Bool
check (SlotNo -> Bool) -> (Word64 -> SlotNo) -> Word64 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> SlotNo
out) (SlotNo -> Word64
inn SlotNo
lastSlot) (SlotNo -> Word64
inn SlotNo
lo) of
            Just SlotNo
hi -> SlotNo -> SlotNo -> Gen SlotNo
genSlot SlotNo
lo SlotNo
hi
            Maybe SlotNo
Nothing -> [Char] -> Gen SlotNo
forall a. HasCallStack => [Char] -> a
error ([Char] -> Gen SlotNo) -> [Char] -> Gen SlotNo
forall a b. (a -> b) -> a -> b
$
                [Char]
"Cannot find viable Byron NodeJoinPlan: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
                (PBftParams, NumSlots, NodeJoinPlan, State) -> [Char]
forall a. Show a => a -> [Char]
show (PBftParams
params, NumSlots
numSlots, NodeJoinPlan
nodeJoinPlan, State
st)

        let m' :: Map CoreNodeId SlotNo
m'  = CoreNodeId
-> SlotNo -> Map CoreNodeId SlotNo -> Map CoreNodeId SlotNo
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CoreNodeId
nid SlotNo
s' Map CoreNodeId SlotNo
m

            -- optimization: avoid simulating from the same inputs multiple
            -- times
            --
            -- We've decided that @nid@ joins in @s'@, so advance the state to
            -- /just/ /before/ @s'@, since we might want @nid+1@ to also join
            -- in @s'@.
            --
            -- NOTE @m@ is congruent to @m'@ for all slots prior to @s'@
            st' :: State
st' = PBftParams -> NodeJoinPlan -> State -> SlotNo -> State
Ref.advanceUpTo PBftParams
params NodeJoinPlan
nodeJoinPlan State
st SlotNo
s'
        NodeJoinPlan -> State -> Gen NodeJoinPlan
go (Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan Map CoreNodeId SlotNo
m') State
st'
      where
        -- the next node to be added to the incomplete join plan
        nid :: CoreNodeId
nid = Word64 -> CoreNodeId
CoreNodeId Word64
i
        i :: Word64
i   = case (CoreNodeId, SlotNo) -> CoreNodeId
forall a b. (a, b) -> a
fst ((CoreNodeId, SlotNo) -> CoreNodeId)
-> Maybe (CoreNodeId, SlotNo) -> Maybe CoreNodeId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map CoreNodeId SlotNo -> Maybe (CoreNodeId, SlotNo)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax Map CoreNodeId SlotNo
m of
            Maybe CoreNodeId
Nothing             -> Word64
0
            Just (CoreNodeId Word64
h) -> Word64 -> Word64
forall a. Enum a => a -> a
succ Word64
h

-- | Possibly promote some 'NodeRestart's to 'NodeRekey's
--
-- POSTCONDITION No node will rekey multiple times in a single epoch.
-- (Ouroboros allows at most one delegation per epoch, while each rekey and
-- also genesis itself all count as a delegation.)
--
-- POSTCONDITION Each rekey takes at least 2k slots, and the node can't lead
-- until it's finished. Therefore, at most one node will be rekeying at a time,
-- since otherwise its inability to lead may spoil the invariants established
-- by 'genByronNodeJoinPlan'.
--
genNodeRekeys ::
     PBftParams
  -> NodeJoinPlan
  -> NodeTopology
  -> NumSlots
  -> NodeRestarts
  -> Gen NodeRestarts
genNodeRekeys :: PBftParams
-> NodeJoinPlan
-> NodeTopology
-> NumSlots
-> NodeRestarts
-> Gen NodeRestarts
genNodeRekeys PBftParams
params NodeJoinPlan
nodeJoinPlan NodeTopology
nodeTopology numSlots :: NumSlots
numSlots@(NumSlots Word64
t)
  nodeRestarts :: NodeRestarts
nodeRestarts@(NodeRestarts Map SlotNo (Map CoreNodeId NodeRestart)
nrs)
  | Word64
t Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
0    = NodeRestarts -> Gen NodeRestarts
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeRestarts
nodeRestarts
  | Bool
otherwise =
    -- The necessary conditions are relatively rare, so favor adding a
    -- 'NodeRekey' when we can. But not always.
    (\Gen NodeRestarts
x -> [(Int, Gen NodeRestarts)] -> Gen NodeRestarts
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
2, NodeRestarts -> Gen NodeRestarts
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeRestarts
nodeRestarts), (Int
8, Gen NodeRestarts
x)]) (Gen NodeRestarts -> Gen NodeRestarts)
-> Gen NodeRestarts -> Gen NodeRestarts
forall a b. (a -> b) -> a -> b
$
    -- TODO rekey nodes other than the last
    -- TODO rekey more than one node
    -- TODO rekey a node in a slot other than its join slot
    case Map CoreNodeId SlotNo -> Maybe (CoreNodeId, SlotNo)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax Map CoreNodeId SlotNo
njp of
      Just (CoreNodeId
cid, SlotNo
jslot)
            -- last node joins after first epoch, ...
          | SlotNo
jslot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
beginSecondEpoch
            -- ... and could instead join unproblematically at the latest time
            -- the delegation certificate would mature ...
          , SecurityParam -> NumCoreNodes -> SlotNo -> SlotNo
latestPossibleDlgMaturation SecurityParam
pbftSecurityParam NumCoreNodes
numCoreNodes SlotNo
jslot
              SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
sentinel
          , let nodeJoinPlan' :: NodeJoinPlan
nodeJoinPlan' =
                  Map CoreNodeId SlotNo -> NodeJoinPlan
NodeJoinPlan (Map CoreNodeId SlotNo -> NodeJoinPlan)
-> Map CoreNodeId SlotNo -> NodeJoinPlan
forall a b. (a -> b) -> a -> b
$ CoreNodeId
-> SlotNo -> Map CoreNodeId SlotNo -> Map CoreNodeId SlotNo
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CoreNodeId
cid (SlotNo
jslot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
twoK) Map CoreNodeId SlotNo
njp
          , PBftParams -> Result -> Bool
Ref.definitelyEnoughBlocks PBftParams
params (Result -> Bool) -> Result -> Bool
forall a b. (a -> b) -> a -> b
$
            HasCallStack => PBftParams -> NodeJoinPlan -> NumSlots -> Result
PBftParams -> NodeJoinPlan -> NumSlots -> Result
Ref.simulate PBftParams
params NodeJoinPlan
nodeJoinPlan' NumSlots
numSlots
            -- ... and does not join in the same slot as the leader of the next
            -- slot unless they are neighbors (otherwise the dlg cert tx might
            -- not reach it soon enough)
          , let nextLeader :: CoreNodeId
nextLeader = PBftParams -> SlotNo -> CoreNodeId
Ref.mkLeaderOf PBftParams
params (SlotNo -> CoreNodeId) -> SlotNo -> CoreNodeId
forall a b. (a -> b) -> a -> b
$ SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
jslot
          , SlotNo
jslot SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
/= HasCallStack => NodeJoinPlan -> CoreNodeId -> SlotNo
NodeJoinPlan -> CoreNodeId -> SlotNo
coreNodeIdJoinSlot NodeJoinPlan
nodeJoinPlan CoreNodeId
nextLeader Bool -> Bool -> Bool
||
            CoreNodeId
cid CoreNodeId -> [CoreNodeId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` HasCallStack => NodeTopology -> CoreNodeId -> [CoreNodeId]
NodeTopology -> CoreNodeId -> [CoreNodeId]
coreNodeIdNeighbors NodeTopology
nodeTopology CoreNodeId
nextLeader
          -> NodeRestarts -> Gen NodeRestarts
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NodeRestarts -> Gen NodeRestarts)
-> NodeRestarts -> Gen NodeRestarts
forall a b. (a -> b) -> a -> b
$ Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts
NodeRestarts (Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts)
-> Map SlotNo (Map CoreNodeId NodeRestart) -> NodeRestarts
forall a b. (a -> b) -> a -> b
$
             -- We discard any 'NodeRestart's also scheduled for this slot.
             -- 'NodeRestart's are less interesting, so it's fine.
             --
             -- TODO retain those coincident node restarts as long as they
             -- don't include every other node, since that risks forgetting
             -- some relevant blocks.
             SlotNo
-> Map CoreNodeId NodeRestart
-> Map SlotNo (Map CoreNodeId NodeRestart)
-> Map SlotNo (Map CoreNodeId NodeRestart)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert SlotNo
jslot (CoreNodeId -> NodeRestart -> Map CoreNodeId NodeRestart
forall k a. k -> a -> Map k a
Map.singleton CoreNodeId
cid NodeRestart
NodeRekey) Map SlotNo (Map CoreNodeId NodeRestart)
nrs
      Maybe (CoreNodeId, SlotNo)
_ -> NodeRestarts -> Gen NodeRestarts
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NodeRestarts
nodeRestarts
  where
    PBftParams{SecurityParam
pbftSecurityParam :: SecurityParam
pbftSecurityParam :: PBftParams -> SecurityParam
pbftSecurityParam} = PBftParams
params
    k :: Word64
k = SecurityParam -> Word64
maxRollbacks SecurityParam
pbftSecurityParam
    sentinel :: SlotNo
sentinel = Word64 -> SlotNo
SlotNo Word64
t
    numCoreNodes :: NumCoreNodes
numCoreNodes = Word64 -> NumCoreNodes
NumCoreNodes (Word64 -> NumCoreNodes) -> Word64 -> NumCoreNodes
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ Map CoreNodeId SlotNo -> Int
forall k a. Map k a -> Int
Map.size Map CoreNodeId SlotNo
njp

    NodeJoinPlan Map CoreNodeId SlotNo
njp = NodeJoinPlan
nodeJoinPlan

    twoK :: SlotNo
twoK             = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
k
    beginSecondEpoch :: SlotNo
beginSecondEpoch = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ Word64
10 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
k   -- c.f. Genesis.configEpochSlots

{-------------------------------------------------------------------------------
  Updating operational keys
-------------------------------------------------------------------------------}

-- | Overwrite the 'ProtocolInfo''s operational key, if any, and provide a
-- transaction for its new delegation certificate
--
mkRekeyUpd ::
     Monad m
  => Genesis.Config
  -> Genesis.GeneratedSecrets
  -> CoreNodeId
  -> ProtocolInfo ByronBlock
  -> m [BlockForging m ByronBlock]
  -> EpochNo
  -> Crypto.SignKeyDSIGN Crypto.ByronDSIGN
  -> m (Maybe (TestNodeInitialization m ByronBlock))
mkRekeyUpd :: forall (m :: * -> *).
Monad m =>
Config
-> GeneratedSecrets
-> CoreNodeId
-> ProtocolInfo ByronBlock
-> m [BlockForging m ByronBlock]
-> EpochNo
-> SignKeyDSIGN ByronDSIGN
-> m (Maybe (TestNodeInitialization m ByronBlock))
mkRekeyUpd Config
genesisConfig GeneratedSecrets
genesisSecrets CoreNodeId
cid ProtocolInfo ByronBlock
pInfo m [BlockForging m ByronBlock]
blockForging EpochNo
eno SignKeyDSIGN ByronDSIGN
newSK = do
  m [BlockForging m ByronBlock]
blockForging m [BlockForging m ByronBlock]
-> ([BlockForging m ByronBlock]
    -> Maybe (TestNodeInitialization m ByronBlock))
-> m (Maybe (TestNodeInitialization m ByronBlock))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    []    -> Maybe (TestNodeInitialization m ByronBlock)
forall a. Maybe a
Nothing
    (BlockForging m ByronBlock
_:[BlockForging m ByronBlock]
_) ->
      let genSK :: SignKeyDSIGN ByronDSIGN
genSK = Config -> GeneratedSecrets -> CoreNodeId -> SignKeyDSIGN ByronDSIGN
genesisSecretFor Config
genesisConfig GeneratedSecrets
genesisSecrets CoreNodeId
cid
          creds' :: ByronLeaderCredentials
creds' = SignKeyDSIGN ByronDSIGN
-> BlockConfig ByronBlock
-> CoreNodeId
-> EpochNumber
-> SignKeyDSIGN ByronDSIGN
-> ByronLeaderCredentials
updSignKey SignKeyDSIGN ByronDSIGN
genSK BlockConfig ByronBlock
bcfg CoreNodeId
cid (EpochNo -> EpochNumber
forall a b. Coercible a b => a -> b
coerce EpochNo
eno) SignKeyDSIGN ByronDSIGN
newSK
          blockForging' :: BlockForging m ByronBlock
blockForging' = ByronLeaderCredentials -> BlockForging m ByronBlock
forall (m :: * -> *).
Monad m =>
ByronLeaderCredentials -> BlockForging m ByronBlock
byronBlockForging ByronLeaderCredentials
creds'

      in TestNodeInitialization m ByronBlock
-> Maybe (TestNodeInitialization m ByronBlock)
forall a. a -> Maybe a
Just TestNodeInitialization
        { tniCrucialTxs :: [GenTx ByronBlock]
tniCrucialTxs = [Certificate -> GenTx ByronBlock
dlgTx (ByronLeaderCredentials -> Certificate
blcDlgCert ByronLeaderCredentials
creds')]
        , tniProtocolInfo :: ProtocolInfo ByronBlock
tniProtocolInfo = ProtocolInfo ByronBlock
pInfo
        , tniBlockForging :: m [BlockForging m ByronBlock]
tniBlockForging = [BlockForging m ByronBlock] -> m [BlockForging m ByronBlock]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [BlockForging m ByronBlock
blockForging']
        }
  where
    bcfg :: BlockConfig ByronBlock
bcfg = TopLevelConfig ByronBlock -> BlockConfig ByronBlock
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock (ProtocolInfo ByronBlock -> TopLevelConfig ByronBlock
forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig ProtocolInfo ByronBlock
pInfo)

-- | The secret key for a node index
--
genesisSecretFor ::
     Genesis.Config
  -> Genesis.GeneratedSecrets
  -> CoreNodeId
  -> Crypto.SignKeyDSIGN Crypto.ByronDSIGN
genesisSecretFor :: Config -> GeneratedSecrets -> CoreNodeId -> SignKeyDSIGN ByronDSIGN
genesisSecretFor Config
genesisConfig GeneratedSecrets
genesisSecrets CoreNodeId
cid =
    case [SigningKey]
hits of
        [SigningKey
sec] -> SigningKey -> SignKeyDSIGN ByronDSIGN
Crypto.SignKeyByronDSIGN SigningKey
sec
        [SigningKey]
_     -> [Char] -> SignKeyDSIGN ByronDSIGN
forall a. HasCallStack => [Char] -> a
error ([Char] -> SignKeyDSIGN ByronDSIGN)
-> [Char] -> SignKeyDSIGN ByronDSIGN
forall a b. (a -> b) -> a -> b
$ [Char]
"Not exactly one genesis key " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> (CoreNodeId, [SigningKey]) -> [Char]
forall a. Show a => a -> [Char]
show (CoreNodeId
cid, [SigningKey]
hits)
  where
    hits :: [Crypto.SigningKey]
    hits :: [SigningKey]
hits =
        (SigningKey -> Bool) -> [SigningKey] -> [SigningKey]
forall a. (a -> Bool) -> [a] -> [a]
filter
            ((CoreNodeId -> Maybe CoreNodeId
forall a. a -> Maybe a
Just CoreNodeId
cid Maybe CoreNodeId -> Maybe CoreNodeId -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe CoreNodeId -> Bool)
-> (SigningKey -> Maybe CoreNodeId) -> SigningKey -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey -> Maybe CoreNodeId
gkToIdx)
            (GeneratedSecrets -> [SigningKey]
Genesis.gsDlgIssuersSecrets GeneratedSecrets
genesisSecrets)

    gkToIdx :: Crypto.SigningKey -> Maybe CoreNodeId
    gkToIdx :: SigningKey -> Maybe CoreNodeId
gkToIdx =
        Config -> VerKeyDSIGN ByronDSIGN -> Maybe CoreNodeId
genesisKeyCoreNodeId Config
genesisConfig
      (VerKeyDSIGN ByronDSIGN -> Maybe CoreNodeId)
-> (SigningKey -> VerKeyDSIGN ByronDSIGN)
-> SigningKey
-> Maybe CoreNodeId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VerificationKey -> VerKeyDSIGN ByronDSIGN
Crypto.VerKeyByronDSIGN (VerificationKey -> VerKeyDSIGN ByronDSIGN)
-> (SigningKey -> VerificationKey)
-> SigningKey
-> VerKeyDSIGN ByronDSIGN
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SigningKey -> VerificationKey
Crypto.toVerification

-- | Create new 'ByronLeaderCredentials' by generating a new delegation
-- certificate for the given new operational key.
--
updSignKey ::
     Crypto.SignKeyDSIGN Crypto.ByronDSIGN
  -> BlockConfig ByronBlock
  -> CoreNodeId
  -> EpochNumber
  -> Crypto.SignKeyDSIGN Crypto.ByronDSIGN
  -> ByronLeaderCredentials
updSignKey :: SignKeyDSIGN ByronDSIGN
-> BlockConfig ByronBlock
-> CoreNodeId
-> EpochNumber
-> SignKeyDSIGN ByronDSIGN
-> ByronLeaderCredentials
updSignKey SignKeyDSIGN ByronDSIGN
genSK BlockConfig ByronBlock
extCfg CoreNodeId
cid EpochNumber
eno SignKeyDSIGN ByronDSIGN
newSK =
    ByronLeaderCredentials {
        $sel:blcSignKey:ByronLeaderCredentials :: SigningKey
blcSignKey    = SigningKey
sk'
      , $sel:blcDlgCert:ByronLeaderCredentials :: Certificate
blcDlgCert    = Certificate
newCert
      , $sel:blcCoreNodeId:ByronLeaderCredentials :: CoreNodeId
blcCoreNodeId = CoreNodeId
cid
      , $sel:blcLabel:ByronLeaderCredentials :: Text
blcLabel      = Text
"Updated Byron credentials"
      }
  where
    newCert :: Certificate
newCert =
        ProtocolMagicId
-> VerificationKey -> EpochNumber -> SafeSigner -> Certificate
Delegation.signCertificate
            (BlockConfig ByronBlock -> ProtocolMagicId
Byron.byronProtocolMagicId BlockConfig ByronBlock
extCfg)
            (SigningKey -> VerificationKey
Crypto.toVerification SigningKey
sk')
            EpochNumber
eno
            (SigningKey -> SafeSigner
Crypto.noPassSafeSigner SigningKey
gsk')

    Crypto.SignKeyByronDSIGN SigningKey
gsk' = SignKeyDSIGN ByronDSIGN
genSK
    Crypto.SignKeyByronDSIGN SigningKey
sk'  = SignKeyDSIGN ByronDSIGN
newSK

-- | Map a delegation certificate to a delegation transaction
--
dlgTx :: Delegation.Certificate -> Byron.GenTx ByronBlock
dlgTx :: Certificate -> GenTx ByronBlock
dlgTx Certificate
cert =
    let ann :: ByteString
ann = Certificate -> ByteString
forall a. ToCBOR a => a -> ByteString
Plain.serialize' (Certificate
cert :: Delegation.Certificate)
        cert' :: ACertificate ByteString
cert' = Certificate
cert
          { Delegation.aEpoch     =
              reAnnotate byronProtVer (Delegation.aEpoch cert)
          , Delegation.annotation = ann
          }
    in CertificateId -> ACertificate ByteString -> GenTx ByronBlock
Byron.ByronDlg (ACertificate ByteString -> CertificateId
Delegation.recoverCertificateId ACertificate ByteString
cert') ACertificate ByteString
cert'