{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}

module Test.ThreadNet.Cardano (tests) where

import qualified Cardano.Chain.Block as CC
import qualified Cardano.Chain.Common as CC.Common
import qualified Cardano.Chain.Genesis as CC.Genesis
import           Cardano.Chain.ProtocolConstants (kEpochSlots)
import           Cardano.Chain.Slotting (unEpochSlots)
import qualified Cardano.Chain.Update as CC.Update
import qualified Cardano.Chain.Update.Validation.Interface as CC
import qualified Cardano.Ledger.Api.Era as L
import qualified Cardano.Ledger.BaseTypes as SL
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Ledger.Shelley.Core as SL
import qualified Cardano.Protocol.TPraos.OCert as SL
import           Cardano.Slotting.Slot (EpochSize (..), SlotNo (..))
import           Control.Exception (assert)
import           Control.Monad (replicateM)
import qualified Data.Map.Strict as Map
import           Data.Maybe (maybeToList)
import           Data.Proxy (Proxy (..))
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Word (Word64)
import           Lens.Micro
import           Ouroboros.Consensus.Block.Forging (BlockForging)
import           Ouroboros.Consensus.BlockchainTime
import           Ouroboros.Consensus.Byron.Ledger (LedgerState (..))
import           Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock)
import           Ouroboros.Consensus.Byron.Ledger.Conversions
import           Ouroboros.Consensus.Byron.Node
import           Ouroboros.Consensus.Cardano.Block
import           Ouroboros.Consensus.Cardano.Condense ()
import           Ouroboros.Consensus.Config.SecurityParam
import           Ouroboros.Consensus.HardFork.Combinator
import           Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common
                     (isHardForkNodeToNodeEnabled)
import           Ouroboros.Consensus.HardFork.Combinator.State (Current (..))
import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..))
import           Ouroboros.Consensus.Ledger.SupportsMempool (extractTxs)
import           Ouroboros.Consensus.Node.NetworkProtocolVersion
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.NodeId
import           Ouroboros.Consensus.Protocol.PBFT
import           Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()
import           Ouroboros.Consensus.Shelley.Node
import           Ouroboros.Consensus.Util.IOLike (IOLike)
import           Test.Consensus.Cardano.ProtocolInfo
                     (hardForkOnDefaultProtocolVersions, mkTestProtocolInfo)
import           Test.QuickCheck
import           Test.Tasty
import           Test.Tasty.QuickCheck
import           Test.ThreadNet.General
import qualified Test.ThreadNet.Infra.Byron as Byron
import qualified Test.ThreadNet.Infra.Shelley as Shelley
import           Test.ThreadNet.Infra.TwoEras
import           Test.ThreadNet.Network (NodeOutput (..),
                     TestNodeInitialization (..))
import           Test.ThreadNet.TxGen.Cardano (CardanoTxGenExtra (..))
import           Test.ThreadNet.Util.Expectations (NumBlocks (..))
import           Test.ThreadNet.Util.NodeJoinPlan (trivialNodeJoinPlan)
import           Test.ThreadNet.Util.NodeRestarts (noRestarts)
import           Test.ThreadNet.Util.NodeToNodeVersion (genVersionFiltered)
import           Test.ThreadNet.Util.Seed (runGen)
import qualified Test.Util.BoolProps as BoolProps
import           Test.Util.HardFork.Future
import           Test.Util.Orphans.Arbitrary ()
import           Test.Util.Slots (NumSlots (..))
import           Test.Util.TestEnv

-- | Use 'MockCryptoCompatByron' so that bootstrap addresses and
-- bootstrap witnesses are supported.
type Crypto = StandardCrypto

-- | The varying data of this test
--
-- Note: The Byron nodes in this test all join, propose an update, vote for it,
-- and endorse it literally as soon as possible. Therefore, if the test reaches
-- the end of the first epoch, the proposal will be adopted.
data TestSetup = TestSetup
  { TestSetup -> DecentralizationParam
setupD                 :: Shelley.DecentralizationParam
  , TestSetup -> Bool
setupHardFork          :: Bool
    -- ^ whether the proposal should trigger a hard fork or not
  , TestSetup -> Nonce
setupInitialNonce      :: SL.Nonce
    -- ^ the initial Shelley 'SL.ticknStateEpochNonce'
    --
    -- We vary it to ensure we explore different leader schedules.
  , TestSetup -> SecurityParam
setupK                 :: SecurityParam
  , TestSetup -> Partition
setupPartition         :: Partition
  , TestSetup -> SlotLength
setupSlotLengthByron   :: SlotLength
  , TestSetup -> SlotLength
setupSlotLengthShelley :: SlotLength
  , TestSetup -> TestConfig
setupTestConfig        :: TestConfig
  , TestSetup
-> (NodeToNodeVersion,
    BlockNodeToNodeVersion (CardanoBlock StandardCrypto))
setupVersion           :: (NodeToNodeVersion, BlockNodeToNodeVersion (CardanoBlock Crypto))
  }
  deriving (Int -> TestSetup -> ShowS
[TestSetup] -> ShowS
TestSetup -> String
(Int -> TestSetup -> ShowS)
-> (TestSetup -> String)
-> ([TestSetup] -> ShowS)
-> Show TestSetup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestSetup -> ShowS
showsPrec :: Int -> TestSetup -> ShowS
$cshow :: TestSetup -> String
show :: TestSetup -> String
$cshowList :: [TestSetup] -> ShowS
showList :: [TestSetup] -> ShowS
Show)

instance Arbitrary TestSetup where
  arbitrary :: Gen TestSetup
arbitrary = do
    DecentralizationParam
setupD <- Gen DecentralizationParam
forall a. Arbitrary a => Gen a
arbitrary
                -- The decentralization parameter cannot be 0 in the first
                -- Shelley epoch, since stake pools can only be created and
                -- delegated to via Shelley transactions.
                Gen DecentralizationParam
-> (DecentralizationParam -> Bool) -> Gen DecentralizationParam
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` ((Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
/= Rational
0) (Rational -> Bool)
-> (DecentralizationParam -> Rational)
-> DecentralizationParam
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecentralizationParam -> Rational
Shelley.decentralizationParamToRational)
    SecurityParam
setupK <- 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
8, Word64
10)
                -- If k < 8, common prefix violations become too likely in
                -- Praos mode for thin overlay schedules (ie low d), even for
                -- f=0.2.

    Nonce
setupInitialNonce <- Gen Nonce
genNonce

    SlotLength
setupSlotLengthByron   <- Gen SlotLength
forall a. Arbitrary a => Gen a
arbitrary
    SlotLength
setupSlotLengthShelley <- Gen SlotLength
forall a. Arbitrary a => Gen a
arbitrary

    TestConfig
setupTestConfig <- SecurityParam -> (EpochSize, EpochSize) -> Gen TestConfig
genTestConfig
                         SecurityParam
setupK
                         ( Word64 -> EpochSize
EpochSize (Word64 -> EpochSize) -> Word64 -> EpochSize
forall a b. (a -> b) -> a -> b
$ SecurityParam -> Word64
byronEpochSize SecurityParam
setupK
                         , Word64 -> EpochSize
EpochSize (Word64 -> EpochSize) -> Word64 -> EpochSize
forall a b. (a -> b) -> a -> b
$ SecurityParam -> Word64
shelleyEpochSize SecurityParam
setupK
                         )

    let TestConfig{NumCoreNodes
numCoreNodes :: NumCoreNodes
numCoreNodes :: TestConfig -> NumCoreNodes
numCoreNodes, NumSlots
numSlots :: NumSlots
numSlots :: TestConfig -> NumSlots
numSlots} = TestConfig
setupTestConfig

    Bool
setupHardFork        <- [(Int, Gen Bool)] -> Gen Bool
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
49, Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True), (Int
1, Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)]
    Partition
setupPartition       <- NumCoreNodes -> NumSlots -> SecurityParam -> Gen Partition
genPartition NumCoreNodes
numCoreNodes NumSlots
numSlots SecurityParam
setupK

    (NodeToNodeVersion,
 HardForkNodeToNodeVersion
   (ByronBlock : CardanoShelleyEras StandardCrypto))
setupVersion         <- (BlockNodeToNodeVersion (CardanoBlock StandardCrypto) -> Bool)
-> Proxy (CardanoBlock StandardCrypto)
-> Gen
     (NodeToNodeVersion,
      BlockNodeToNodeVersion (CardanoBlock StandardCrypto))
forall blk.
SupportedNetworkProtocolVersion blk =>
(BlockNodeToNodeVersion blk -> Bool)
-> Proxy blk -> Gen (NodeToNodeVersion, BlockNodeToNodeVersion blk)
genVersionFiltered
                              BlockNodeToNodeVersion (CardanoBlock StandardCrypto) -> Bool
HardForkNodeToNodeVersion
  (ByronBlock : CardanoShelleyEras StandardCrypto)
-> Bool
forall (xs :: [*]). HardForkNodeToNodeVersion xs -> Bool
isHardForkNodeToNodeEnabled
                              (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(CardanoBlock Crypto))

    TestSetup -> Gen TestSetup
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestSetup
      { DecentralizationParam
setupD :: DecentralizationParam
setupD :: DecentralizationParam
setupD
      , Bool
setupHardFork :: Bool
setupHardFork :: Bool
setupHardFork
      , Nonce
setupInitialNonce :: Nonce
setupInitialNonce :: Nonce
setupInitialNonce
      , SecurityParam
setupK :: SecurityParam
setupK :: SecurityParam
setupK
      , Partition
setupPartition :: Partition
setupPartition :: Partition
setupPartition
      , SlotLength
setupSlotLengthByron :: SlotLength
setupSlotLengthByron :: SlotLength
setupSlotLengthByron
      , SlotLength
setupSlotLengthShelley :: SlotLength
setupSlotLengthShelley :: SlotLength
setupSlotLengthShelley
      , TestConfig
setupTestConfig :: TestConfig
setupTestConfig :: TestConfig
setupTestConfig
      , (NodeToNodeVersion,
 BlockNodeToNodeVersion (CardanoBlock StandardCrypto))
(NodeToNodeVersion,
 HardForkNodeToNodeVersion
   (ByronBlock : CardanoShelleyEras StandardCrypto))
setupVersion :: (NodeToNodeVersion,
 BlockNodeToNodeVersion (CardanoBlock StandardCrypto))
setupVersion :: (NodeToNodeVersion,
 HardForkNodeToNodeVersion
   (ByronBlock : CardanoShelleyEras StandardCrypto))
setupVersion
      }

  -- TODO shrink

tests :: TestTree
tests :: TestTree
tests = String -> [TestTree] -> TestTree
testGroup String
"Cardano ThreadNet" [
          let name :: String
name = String
"simple convergence" in
          (TestEnv -> TestTree) -> TestTree
askTestEnv ((TestEnv -> TestTree) -> TestTree)
-> (TestEnv -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ TestTree -> TestEnv -> TestTree
adjustTestMode (TestTree -> TestEnv -> TestTree)
-> TestTree -> TestEnv -> TestTree
forall a b. (a -> b) -> a -> b
$
            String -> (TestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
name TestSetup -> Property
prop_simple_cardano_convergence
    ]
    where
      adjustTestMode :: TestTree -> TestEnv ->  TestTree
      adjustTestMode :: TestTree -> TestEnv -> TestTree
adjustTestMode TestTree
tree = \case
        TestEnv
Nightly -> TestTree
tree
        TestEnv
_       -> (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (\Int
n -> (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) TestTree
tree

prop_simple_cardano_convergence :: TestSetup -> Property
prop_simple_cardano_convergence :: TestSetup -> Property
prop_simple_cardano_convergence TestSetup
  { DecentralizationParam
setupD :: TestSetup -> DecentralizationParam
setupD :: DecentralizationParam
setupD
  , Bool
setupHardFork :: TestSetup -> Bool
setupHardFork :: Bool
setupHardFork
  , Nonce
setupInitialNonce :: TestSetup -> Nonce
setupInitialNonce :: Nonce
setupInitialNonce
  , SecurityParam
setupK :: TestSetup -> SecurityParam
setupK :: SecurityParam
setupK
  , Partition
setupPartition :: TestSetup -> Partition
setupPartition :: Partition
setupPartition
  , SlotLength
setupSlotLengthByron :: TestSetup -> SlotLength
setupSlotLengthByron :: SlotLength
setupSlotLengthByron
  , SlotLength
setupSlotLengthShelley :: TestSetup -> SlotLength
setupSlotLengthShelley :: SlotLength
setupSlotLengthShelley
  , TestConfig
setupTestConfig :: TestSetup -> TestConfig
setupTestConfig :: TestConfig
setupTestConfig
  , (NodeToNodeVersion,
 BlockNodeToNodeVersion (CardanoBlock StandardCrypto))
setupVersion :: TestSetup
-> (NodeToNodeVersion,
    BlockNodeToNodeVersion (CardanoBlock StandardCrypto))
setupVersion :: (NodeToNodeVersion,
 BlockNodeToNodeVersion (CardanoBlock StandardCrypto))
setupVersion
  } =
    PropGeneralArgs (CardanoBlock StandardCrypto)
-> TestOutput (CardanoBlock StandardCrypto) -> Property
forall blk.
(Condense blk, Condense (HeaderHash blk), Eq blk, RunNode blk) =>
PropGeneralArgs blk -> TestOutput blk -> Property
prop_general_semisync PropGeneralArgs (CardanoBlock StandardCrypto)
pga TestOutput (CardanoBlock StandardCrypto)
testOutput Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
    TestOutput (CardanoBlock StandardCrypto) -> Property
forall blk. HasHeader blk => TestOutput blk -> Property
prop_inSync TestOutput (CardanoBlock StandardCrypto)
testOutput Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
    ReachesEra2 -> Property
prop_ReachesEra2 ReachesEra2
reachesEra2 Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
    Property
prop_noCPViolation Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
    ( String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"ReachesEra2 label" [ReachesEra2 -> String
label_ReachesEra2 ReachesEra2
reachesEra2] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
"Observed forge during a non-overlay Shelley slot"
        [TestOutput (CardanoBlock StandardCrypto) -> Set SlotNo -> String
forall era (eras :: [*]).
TestOutput (HardForkBlock (era : eras)) -> Set SlotNo -> String
label_hadActiveNonOverlaySlots TestOutput (CardanoBlock StandardCrypto)
testOutput Set SlotNo
overlaySlots] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      SecurityParam -> Partition -> Property -> Property
tabulatePartitionDuration SecurityParam
setupK Partition
setupPartition (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      SecurityParam -> NumBlocks -> String -> Property -> Property
tabulateFinalIntersectionDepth
        SecurityParam
setupK
        (Word64 -> NumBlocks
NumBlocks Word64
finalIntersectionDepth)
        String
finalBlockEra (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      NumSlots -> Partition -> Bool -> Property -> Property
tabulatePartitionPosition
        (Word64 -> NumSlots
NumSlots Word64
numByronSlots)
        Partition
setupPartition
        (ReachesEra2 -> Bool
ledgerReachesEra2 ReachesEra2
reachesEra2) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
    )
  where
    TestConfig
      { Seed
initSeed :: Seed
initSeed :: TestConfig -> Seed
initSeed
      , NumCoreNodes
numCoreNodes :: TestConfig -> NumCoreNodes
numCoreNodes :: NumCoreNodes
numCoreNodes
      , NumSlots
numSlots :: TestConfig -> NumSlots
numSlots :: NumSlots
numSlots
      } = TestConfig
setupTestConfig

    pga :: PropGeneralArgs (CardanoBlock StandardCrypto)
pga = PropGeneralArgs
        { pgaBlockProperty :: CardanoBlock StandardCrypto -> Property
pgaBlockProperty       = Property -> CardanoBlock StandardCrypto -> Property
forall a b. a -> b -> a
const (Property -> CardanoBlock StandardCrypto -> Property)
-> Property -> CardanoBlock StandardCrypto -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
        , pgaCountTxs :: CardanoBlock StandardCrypto -> Word64
pgaCountTxs            = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64)
-> (CardanoBlock StandardCrypto -> Int)
-> CardanoBlock StandardCrypto
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenTx (CardanoBlock StandardCrypto)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([GenTx (CardanoBlock StandardCrypto)] -> Int)
-> (CardanoBlock StandardCrypto
    -> [GenTx (CardanoBlock StandardCrypto)])
-> CardanoBlock StandardCrypto
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoBlock StandardCrypto
-> [GenTx (CardanoBlock StandardCrypto)]
forall blk. HasTxs blk => blk -> [GenTx blk]
extractTxs
        , pgaExpectedCannotForge :: SlotNo
-> NodeId -> WrapCannotForge (CardanoBlock StandardCrypto) -> Bool
pgaExpectedCannotForge = SlotNo
-> NodeId -> WrapCannotForge (CardanoBlock StandardCrypto) -> Bool
forall blk. SlotNo -> NodeId -> WrapCannotForge blk -> Bool
noExpectedCannotForges
        , pgaFirstBlockNo :: BlockNo
pgaFirstBlockNo        = BlockNo
1
        , pgaFixedMaxForkLength :: Maybe NumBlocks
pgaFixedMaxForkLength  = NumBlocks -> Maybe NumBlocks
forall a. a -> Maybe a
Just NumBlocks
maxForkLength
        , pgaFixedSchedule :: Maybe LeaderSchedule
pgaFixedSchedule       =
            -- the leader schedule isn't fixed because the Shelley leader
            -- schedule is (at least ideally) unpredictable
            Maybe LeaderSchedule
forall a. Maybe a
Nothing
        , pgaSecurityParam :: SecurityParam
pgaSecurityParam       = SecurityParam
setupK
        , pgaTestConfig :: TestConfig
pgaTestConfig          = TestConfig
setupTestConfig
        , pgaTestConfigB :: TestConfigB (CardanoBlock StandardCrypto)
pgaTestConfigB         = TestConfigB (CardanoBlock StandardCrypto)
testConfigB
        }

    testConfigB :: TestConfigB (CardanoBlock StandardCrypto)
testConfigB = TestConfigB
      { forgeEbbEnv :: Maybe (ForgeEbbEnv (CardanoBlock StandardCrypto))
forgeEbbEnv  = Maybe (ForgeEbbEnv (CardanoBlock StandardCrypto))
forall a. Maybe a
Nothing
      , future :: Future
future       =
          if Bool
setupHardFork
          then
          -- In this case the PVU will trigger the transition to Shelley.
          --
          -- By FACT (B), the PVU is always successful if we reach the second
          -- era.
          SlotLength -> EpochSize -> EraSize -> Future -> Future
EraCons  SlotLength
setupSlotLengthByron   EpochSize
epochSizeByron   EraSize
eraSizeByron (Future -> Future) -> Future -> Future
forall a b. (a -> b) -> a -> b
$
          SlotLength -> EpochSize -> Future
EraFinal SlotLength
setupSlotLengthShelley EpochSize
epochSizeShelley
          else
          SlotLength -> EpochSize -> Future
EraFinal SlotLength
setupSlotLengthByron   EpochSize
epochSizeByron
      , messageDelay :: CalcMessageDelay (CardanoBlock StandardCrypto)
messageDelay = Partition -> CalcMessageDelay (CardanoBlock StandardCrypto)
forall blk. Partition -> CalcMessageDelay blk
mkMessageDelay Partition
setupPartition
      , nodeJoinPlan :: NodeJoinPlan
nodeJoinPlan = NumCoreNodes -> NodeJoinPlan
trivialNodeJoinPlan NumCoreNodes
numCoreNodes
      , nodeRestarts :: NodeRestarts
nodeRestarts = NodeRestarts
noRestarts
      , txGenExtra :: TxGenExtra (CardanoBlock StandardCrypto)
txGenExtra   = CardanoTxGenExtra
        { ctgeByronGenesisKeys :: GeneratedSecrets
ctgeByronGenesisKeys = GeneratedSecrets
generatedSecrets
        , ctgeNetworkMagic :: NetworkMagic
ctgeNetworkMagic     =
            AProtocolMagic () -> NetworkMagic
forall a. AProtocolMagic a -> NetworkMagic
CC.Common.makeNetworkMagic (AProtocolMagic () -> NetworkMagic)
-> AProtocolMagic () -> NetworkMagic
forall a b. (a -> b) -> a -> b
$
            Config -> AProtocolMagic ()
CC.Genesis.configProtocolMagic Config
genesisByron
        , ctgeShelleyCoreNodes :: [CoreNode StandardCrypto]
ctgeShelleyCoreNodes = [CoreNode StandardCrypto]
coreNodes
        }
      , version :: (NodeToNodeVersion,
 BlockNodeToNodeVersion (CardanoBlock StandardCrypto))
version      = (NodeToNodeVersion,
 BlockNodeToNodeVersion (CardanoBlock StandardCrypto))
setupVersion
      }

    testOutput :: TestOutput (CardanoBlock Crypto)
    testOutput :: TestOutput (CardanoBlock StandardCrypto)
testOutput =
        TestConfig
-> TestConfigB (CardanoBlock StandardCrypto)
-> (forall (m :: * -> *).
    IOLike m =>
    TestConfigMB m (CardanoBlock StandardCrypto))
-> TestOutput (CardanoBlock StandardCrypto)
forall blk.
(RunNode blk, TxGen blk, TracingConstraints blk, HasCallStack) =>
TestConfig
-> TestConfigB blk
-> (forall (m :: * -> *). IOLike m => TestConfigMB m blk)
-> TestOutput blk
runTestNetwork TestConfig
setupTestConfig TestConfigB (CardanoBlock StandardCrypto)
testConfigB TestConfigMB
            { nodeInfo :: CoreNodeId
-> TestNodeInitialization m (CardanoBlock StandardCrypto)
nodeInfo = \coreNodeId :: CoreNodeId
coreNodeId@(CoreNodeId Word64
nid) ->
                PBftParams
-> CoreNodeId
-> Config
-> GeneratedSecrets
-> ProtocolVersion
-> ShelleyGenesis StandardCrypto
-> Nonce
-> CoreNode StandardCrypto
-> TestNodeInitialization m (CardanoBlock StandardCrypto)
forall c (m :: * -> *).
(IOLike m, c ~ StandardCrypto) =>
PBftParams
-> CoreNodeId
-> Config
-> GeneratedSecrets
-> ProtocolVersion
-> ShelleyGenesis c
-> Nonce
-> CoreNode c
-> TestNodeInitialization m (CardanoBlock c)
mkProtocolCardanoAndHardForkTxs
                  PBftParams
pbftParams
                  CoreNodeId
coreNodeId
                  Config
genesisByron
                  GeneratedSecrets
generatedSecrets
                  ProtocolVersion
propPV
                  ShelleyGenesis StandardCrypto
genesisShelley
                  Nonce
setupInitialNonce
                  ([CoreNode StandardCrypto]
coreNodes [CoreNode StandardCrypto] -> Int -> CoreNode StandardCrypto
forall a. HasCallStack => [a] -> Int -> a
!! Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
nid)
            , mkRekeyM :: Maybe (m (RekeyM m (CardanoBlock StandardCrypto)))
mkRekeyM = Maybe (m (RekeyM m (CardanoBlock StandardCrypto)))
forall a. Maybe a
Nothing
            }

    maxForkLength :: NumBlocks
    maxForkLength :: NumBlocks
maxForkLength = Word64 -> NumBlocks
NumBlocks (Word64 -> NumBlocks) -> Word64 -> NumBlocks
forall a b. (a -> b) -> a -> b
$
        if ReachesEra2 -> Bool
rsEra2Blocks ReachesEra2
reachesEra2
        then
          -- Shelley inherently creates small forks, but we haven't yet seen a
          -- Common Prefix violation in this test even though @k@ is small
          --
          -- TODO I'd value having a repro that demonstrates a violation of
          -- this typical limit, so I'm leaving it in for now. If it never
          -- fails, we should figure out why not. Even with @k=2 ncn=5 d=0.1@
          -- fixed the deepest fork I'm seeing is ~2.5% @k-1@
          -- 'finalIntersectionDepth'.
          SecurityParam -> Word64
maxRollbacks SecurityParam
setupK
        else
          -- Recall that all nodes join ASAP, so the partition is the only
          -- potential cause for a fork during Byron. See the reasoning in
          -- 'genPartition' for the motivation of this limit.
          Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
div Word64
partitionDuration Word64
2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
mod Word64
partitionDuration Word64
2

    partitionDuration :: Word64
    partitionDuration :: Word64
partitionDuration = Word64
dur
      where
        Partition SlotNo
_ (NumSlots Word64
dur) = Partition
setupPartition

    -- Byron

    pbftParams :: PBftParams
    pbftParams :: PBftParams
pbftParams = SecurityParam -> NumCoreNodes -> PBftParams
Byron.byronPBftParams SecurityParam
setupK NumCoreNodes
numCoreNodes

    -- the Byron ledger is designed to use a fixed epoch size, so this test
    -- does not randomize it
    epochSizeByron :: EpochSize
    epochSizeByron :: EpochSize
epochSizeByron =
        EpochSlots -> EpochSize
fromByronEpochSlots (EpochSlots -> EpochSize) -> EpochSlots -> EpochSize
forall a b. (a -> b) -> a -> b
$ Config -> EpochSlots
CC.Genesis.configEpochSlots Config
genesisByron

    eraSizeByron :: EraSize
    eraSizeByron :: EraSize
eraSizeByron = Word64 -> EraSize
EraSize Word64
forall a. Num a => a
numFirstEraEpochs

    genesisByron     :: CC.Genesis.Config
    generatedSecrets :: CC.Genesis.GeneratedSecrets
    (Config
genesisByron, GeneratedSecrets
generatedSecrets) =
        SlotLength -> PBftParams -> (Config, GeneratedSecrets)
Byron.generateGenesisConfig SlotLength
setupSlotLengthByron PBftParams
pbftParams

    -- Shelley

    initialKESPeriod :: SL.KESPeriod
    initialKESPeriod :: KESPeriod
initialKESPeriod = Word -> KESPeriod
SL.KESPeriod Word
0

    coreNodes :: [Shelley.CoreNode Crypto]
    coreNodes :: [CoreNode StandardCrypto]
coreNodes = Seed -> Gen [CoreNode StandardCrypto] -> [CoreNode StandardCrypto]
forall a. Seed -> Gen a -> a
runGen Seed
initSeed (Gen [CoreNode StandardCrypto] -> [CoreNode StandardCrypto])
-> Gen [CoreNode StandardCrypto] -> [CoreNode StandardCrypto]
forall a b. (a -> b) -> a -> b
$
        Int
-> Gen (CoreNode StandardCrypto) -> Gen [CoreNode StandardCrypto]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n) (Gen (CoreNode StandardCrypto) -> Gen [CoreNode StandardCrypto])
-> Gen (CoreNode StandardCrypto) -> Gen [CoreNode StandardCrypto]
forall a b. (a -> b) -> a -> b
$
          KESPeriod -> Gen (CoreNode StandardCrypto)
forall c. PraosCrypto c => KESPeriod -> Gen (CoreNode c)
Shelley.genCoreNode KESPeriod
initialKESPeriod
      where
        NumCoreNodes Word64
n = NumCoreNodes
numCoreNodes

    -- Same value as for mainnet. Must be larger than the amount of Lovelace in
    -- circulation in the Byron ledger. Since this is the maximum value of
    -- lovelace, this is guaranteed to be the case.
    maxLovelaceSupply :: Word64
    maxLovelaceSupply :: Word64
maxLovelaceSupply = Word64
45000000000000000

    genesisShelley :: ShelleyGenesis Crypto
    genesisShelley :: ShelleyGenesis StandardCrypto
genesisShelley =
        ProtVer
-> SecurityParam
-> Rational
-> DecentralizationParam
-> Word64
-> SlotLength
-> KesConfig
-> [CoreNode StandardCrypto]
-> ShelleyGenesis StandardCrypto
forall c.
PraosCrypto c =>
ProtVer
-> SecurityParam
-> Rational
-> DecentralizationParam
-> Word64
-> SlotLength
-> KesConfig
-> [CoreNode c]
-> ShelleyGenesis c
Shelley.mkGenesisConfig
          (Version -> Natural -> ProtVer
SL.ProtVer Version
shelleyMajorVersion Natural
0)
          SecurityParam
setupK
          Rational
activeSlotCoeff
          DecentralizationParam
setupD
          Word64
maxLovelaceSupply
          SlotLength
setupSlotLengthShelley
          (Proxy StandardCrypto -> NumSlots -> KesConfig
forall (proxy :: * -> *) c.
Crypto c =>
proxy c -> NumSlots -> KesConfig
Shelley.mkKesConfig (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @Crypto) NumSlots
numSlots)
          [CoreNode StandardCrypto]
coreNodes

    -- the Shelley ledger is designed to use a fixed epoch size, so this test
    -- does not randomize it
    epochSizeShelley :: EpochSize
    epochSizeShelley :: EpochSize
epochSizeShelley = ShelleyGenesis StandardCrypto -> EpochSize
forall c. ShelleyGenesis c -> EpochSize
sgEpochLength ShelleyGenesis StandardCrypto
genesisShelley

    -- the protocol version of the Byron era proposal
    --
    -- FACT (B) This proposal is always adopted at the first epoch boundary.
    --
    -- o 'genTestConfig' ensures the test reaches the epoch boundary unless
    --   there's a fatal error during execution. Specifically, 'rsEra1Slots'
    --   will always be 'Enabled'.
    --
    -- o 'genPartition' limits the partition duration to at most @2k-2@ slots.
    --   This leaves at least @10k - (2k-2) = 8k+2@ slots in the epoch
    --   unaffected by the partition. Moreover, the blocks forged during the
    --   partition do make some progress, even though it's not full progress.
    --   So @8k+2@ is conservative.
    --
    -- o As " crucial transactions ", the proposal and vote are added to the
    --   chain eventually and ASAP, even if they are initially placed on the
    --   losing partition class's chain.
    --
    -- o Thus, within the first two of the @8k+2@ unaffected slots, the
    --   proposal has been confirmed. Similar reasoning ensures that it is then
    --   stably confirmed, endorsed, and stably endorsed, before the epoch
    --   boundary and @SafeZone@. IE @2 + 2k + q + 2k + 2k < 8k+2@, since the
    --   quorum @q@ is ~60% of 'numCoreNodes' and so @q < 2k@, since
    --   'numCoreNodes' is at most 5 and @k@ is at least @2@. (Also recall that
    --   @8k+2@ is conservative.)
    propPV :: CC.Update.ProtocolVersion
    propPV :: ProtocolVersion
propPV =
      if Bool
setupHardFork
      then
        -- this new version must induce the hard fork if accepted
        Word16 -> Word16 -> Word8 -> ProtocolVersion
CC.Update.ProtocolVersion (Version -> Word16
forall i. Integral i => Version -> i
SL.getVersion Version
shelleyMajorVersion) Word16
0 Word8
0
      else
        -- this new version must not induce the hard fork if accepted
        Word16 -> Word16 -> Word8 -> ProtocolVersion
CC.Update.ProtocolVersion
          Word16
forall a. Integral a => a
byronMajorVersion (Word16
forall a. Num a => a
byronInitialMinorVersion Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
1) Word8
0

    -- Classifying test cases

    reachesEra2 :: ReachesEra2
    reachesEra2 :: ReachesEra2
reachesEra2 = ReachesEra2
      { rsEra1Slots :: Prereq
rsEra1Slots    =
          Bool -> Prereq
BoolProps.enabledIf (Bool -> Prereq) -> Bool -> Prereq
forall a b. (a -> b) -> a -> b
$ Word64
t Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
numByronSlots
      , rsPV :: Prereq
rsPV            = Bool -> Prereq
BoolProps.enabledIf Bool
setupHardFork
      , rsEra2Blocks :: Bool
rsEra2Blocks =
          [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$
          [ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CardanoBlock StandardCrypto -> Bool
forall era (eras :: [*]). HardForkBlock (era : eras) -> Bool
isFirstEraBlock CardanoBlock StandardCrypto
blk
          | (NodeId
_nid, NodeOutput (CardanoBlock StandardCrypto)
no) <- Map NodeId (NodeOutput (CardanoBlock StandardCrypto))
-> [(NodeId, NodeOutput (CardanoBlock StandardCrypto))]
forall k a. Map k a -> [(k, a)]
Map.toList Map NodeId (NodeOutput (CardanoBlock StandardCrypto))
testOutputNodes
          , let NodeOutput{Map SlotNo (CardanoBlock StandardCrypto)
nodeOutputForges :: Map SlotNo (CardanoBlock StandardCrypto)
nodeOutputForges :: forall blk. NodeOutput blk -> Map SlotNo blk
nodeOutputForges} = NodeOutput (CardanoBlock StandardCrypto)
no
          , (CardanoBlock StandardCrypto
blk, Map SlotNo (CardanoBlock StandardCrypto)
_m) <- Maybe
  (CardanoBlock StandardCrypto,
   Map SlotNo (CardanoBlock StandardCrypto))
-> [(CardanoBlock StandardCrypto,
     Map SlotNo (CardanoBlock StandardCrypto))]
forall a. Maybe a -> [a]
maybeToList (Maybe
   (CardanoBlock StandardCrypto,
    Map SlotNo (CardanoBlock StandardCrypto))
 -> [(CardanoBlock StandardCrypto,
      Map SlotNo (CardanoBlock StandardCrypto))])
-> Maybe
     (CardanoBlock StandardCrypto,
      Map SlotNo (CardanoBlock StandardCrypto))
-> [(CardanoBlock StandardCrypto,
     Map SlotNo (CardanoBlock StandardCrypto))]
forall a b. (a -> b) -> a -> b
$ Map SlotNo (CardanoBlock StandardCrypto)
-> Maybe
     (CardanoBlock StandardCrypto,
      Map SlotNo (CardanoBlock StandardCrypto))
forall k a. Map k a -> Maybe (a, Map k a)
Map.maxView Map SlotNo (CardanoBlock StandardCrypto)
nodeOutputForges
                -- the last block the node forged
          ]
      , rsEra2Slots :: Requirement
rsEra2Slots  =
          Bool -> Requirement -> Requirement
forall a. HasCallStack => Bool -> a -> a
assert (Word64
w Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
k) (Requirement -> Requirement) -> Requirement -> Requirement
forall a b. (a -> b) -> a -> b
$
          Bool -> Requirement
BoolProps.requiredIf (Bool -> Requirement) -> Bool -> Requirement
forall a b. (a -> b) -> a -> b
$
          -- The active slots in the first two Shelley epochs are all overlay
          -- slots, so the first Shelley block will arise from one of those.
          Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set SlotNo -> Bool
forall a. Set a -> Bool
Set.null (Set SlotNo -> Bool) -> Set SlotNo -> Bool
forall a b. (a -> b) -> a -> b
$ Set SlotNo
overlaySlots
      }
      where
        NumSlots Word64
t                  = NumSlots
numSlots
        TestOutput{Map NodeId (NodeOutput (CardanoBlock StandardCrypto))
testOutputNodes :: Map NodeId (NodeOutput (CardanoBlock StandardCrypto))
testOutputNodes :: forall blk. TestOutput blk -> Map NodeId (NodeOutput blk)
testOutputNodes} = TestOutput (CardanoBlock StandardCrypto)
testOutput

        k :: Word64
        k :: Word64
k = SecurityParam -> Word64
maxRollbacks SecurityParam
setupK

        coeff :: SL.ActiveSlotCoeff
        coeff :: ActiveSlotCoeff
coeff = ShelleyGenesis StandardCrypto -> ActiveSlotCoeff
forall c. ShelleyGenesis c -> ActiveSlotCoeff
SL.sgActiveSlotCoeff ShelleyGenesis StandardCrypto
genesisShelley

        w :: Word64
        w :: Word64
w = Word64 -> ActiveSlotCoeff -> Word64
SL.computeStabilityWindow Word64
k ActiveSlotCoeff
coeff

    overlaySlots :: Set SlotNo
    overlaySlots :: Set SlotNo
overlaySlots =
        NumSlots -> NumSlots -> UnitInterval -> EpochSize -> Set SlotNo
secondEraOverlaySlots
          NumSlots
numSlots
          (Word64 -> NumSlots
NumSlots Word64
numByronSlots)
          (ShelleyGenesis StandardCrypto
-> PParams (ShelleyEra StandardCrypto)
forall c. ShelleyGenesis c -> PParams (ShelleyEra c)
sgProtocolParams ShelleyGenesis StandardCrypto
genesisShelley PParams (ShelleyEra StandardCrypto)
-> Getting
     UnitInterval (PParams (ShelleyEra StandardCrypto)) UnitInterval
-> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting
  UnitInterval (PParams (ShelleyEra StandardCrypto)) UnitInterval
forall era.
(EraPParams era, ProtVerAtMost era 6) =>
Lens' (PParams era) UnitInterval
Lens' (PParams (ShelleyEra StandardCrypto)) UnitInterval
SL.ppDL)
          EpochSize
epochSizeShelley

    numByronSlots :: Word64
    numByronSlots :: Word64
numByronSlots = Word64
forall a. Num a => a
numFirstEraEpochs Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* EpochSize -> Word64
unEpochSize EpochSize
epochSizeByron

    finalBlockEra :: String
    finalBlockEra :: String
finalBlockEra =
        if ReachesEra2 -> Bool
rsEra2Blocks ReachesEra2
reachesEra2 then String
"Shelley" else String
"Byron"

    finalIntersectionDepth :: Word64
    finalIntersectionDepth :: Word64
finalIntersectionDepth = Word64
depth
      where
        NumBlocks Word64
depth = PropGeneralArgs (CardanoBlock StandardCrypto)
-> TestOutput (CardanoBlock StandardCrypto) -> NumBlocks
forall blk.
HasHeader blk =>
PropGeneralArgs blk -> TestOutput blk -> NumBlocks
calcFinalIntersectionDepth PropGeneralArgs (CardanoBlock StandardCrypto)
pga TestOutput (CardanoBlock StandardCrypto)
testOutput

    prop_noCPViolation :: Property
    prop_noCPViolation :: Property
prop_noCPViolation =
        String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
          ( String
"finalChains: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
            Map NodeId (Chain (CardanoBlock StandardCrypto)) -> String
forall a. Show a => a -> String
show (NodeOutput (CardanoBlock StandardCrypto)
-> Chain (CardanoBlock StandardCrypto)
forall blk. NodeOutput blk -> Chain blk
nodeOutputFinalChain (NodeOutput (CardanoBlock StandardCrypto)
 -> Chain (CardanoBlock StandardCrypto))
-> Map NodeId (NodeOutput (CardanoBlock StandardCrypto))
-> Map NodeId (Chain (CardanoBlock StandardCrypto))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestOutput (CardanoBlock StandardCrypto)
-> Map NodeId (NodeOutput (CardanoBlock StandardCrypto))
forall blk. TestOutput blk -> Map NodeId (NodeOutput blk)
testOutputNodes TestOutput (CardanoBlock StandardCrypto)
testOutput)
          ) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"CP violation in final chains!" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ SecurityParam -> Word64
maxRollbacks SecurityParam
setupK Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
finalIntersectionDepth

mkProtocolCardanoAndHardForkTxs ::
     forall c m. (IOLike m, c ~ StandardCrypto)
     -- Byron
  => PBftParams
  -> CoreNodeId
  -> CC.Genesis.Config
  -> CC.Genesis.GeneratedSecrets
  -> CC.Update.ProtocolVersion
     -- Shelley
  -> ShelleyGenesis c
  -> SL.Nonce
  -> Shelley.CoreNode c
  -> TestNodeInitialization m (CardanoBlock c)
mkProtocolCardanoAndHardForkTxs :: forall c (m :: * -> *).
(IOLike m, c ~ StandardCrypto) =>
PBftParams
-> CoreNodeId
-> Config
-> GeneratedSecrets
-> ProtocolVersion
-> ShelleyGenesis c
-> Nonce
-> CoreNode c
-> TestNodeInitialization m (CardanoBlock c)
mkProtocolCardanoAndHardForkTxs
    PBftParams
pbftParams CoreNodeId
coreNodeId Config
genesisByron GeneratedSecrets
generatedSecretsByron ProtocolVersion
propPV
    ShelleyGenesis c
genesisShelley Nonce
initialNonce CoreNode c
coreNodeShelley
  =
    TestNodeInitialization
      { tniCrucialTxs :: [GenTx (CardanoBlock c)]
tniCrucialTxs   = [GenTx (CardanoBlock c)]
crucialTxs
      , tniProtocolInfo :: ProtocolInfo (CardanoBlock c)
tniProtocolInfo = ProtocolInfo (CardanoBlock c)
protocolInfo
      , tniBlockForging :: m [BlockForging m (CardanoBlock c)]
tniBlockForging = m [BlockForging m (CardanoBlock c)]
blockForging
      }
  where
    crucialTxs :: [GenTx (CardanoBlock c)]
    crucialTxs :: [GenTx (CardanoBlock c)]
crucialTxs =
        GenTx ByronBlock -> GenTx (CardanoBlock c)
forall c. GenTx ByronBlock -> CardanoGenTx c
GenTxByron (GenTx ByronBlock -> GenTx (CardanoBlock c))
-> [GenTx ByronBlock] -> [GenTx (CardanoBlock c)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestNodeInitialization m ByronBlock -> [GenTx ByronBlock]
forall (m :: * -> *) blk.
TestNodeInitialization m blk -> [GenTx blk]
tniCrucialTxs TestNodeInitialization m ByronBlock
tniByron
      where
        -- reuse the Byron logic for generating the crucial txs, ie the
        -- proposal and votes
        tniByron :: TestNodeInitialization m ByronBlock
        tniByron :: TestNodeInitialization m ByronBlock
tniByron =
            PBftParams
-> CoreNodeId
-> Config
-> GeneratedSecrets
-> ProtocolVersion
-> TestNodeInitialization m ByronBlock
forall (m :: * -> *).
(Monad m, HasCallStack) =>
PBftParams
-> CoreNodeId
-> Config
-> GeneratedSecrets
-> ProtocolVersion
-> TestNodeInitialization m ByronBlock
Byron.mkProtocolByronAndHardForkTxs
              PBftParams
pbftParams
              CoreNodeId
coreNodeId
              Config
genesisByron
              GeneratedSecrets
generatedSecretsByron
              ProtocolVersion
propPV

    protocolInfo :: ProtocolInfo (CardanoBlock c)
    blockForging :: m [BlockForging m (CardanoBlock c)]
    (ProtocolInfo (CardanoBlock c) -> ProtocolInfo (CardanoBlock c)
forall c.
ProtocolInfo (CardanoBlock c) -> ProtocolInfo (CardanoBlock c)
setByronProtVer -> ProtocolInfo (CardanoBlock c)
protocolInfo, m [BlockForging m (CardanoBlock c)]
blockForging) =
      (CoreNodeId, CoreNode c)
-> ShelleyGenesis c
-> ProtocolVersion
-> Nonce
-> Config
-> GeneratedSecrets
-> Maybe PBftSignatureThreshold
-> ProtVer
-> CardanoHardForkTriggers
-> (ProtocolInfo (CardanoBlock c),
    m [BlockForging m (CardanoBlock c)])
forall (m :: * -> *) c.
(CardanoHardForkConstraints c, IOLike m, c ~ StandardCrypto) =>
(CoreNodeId, CoreNode c)
-> ShelleyGenesis c
-> ProtocolVersion
-> Nonce
-> Config
-> GeneratedSecrets
-> Maybe PBftSignatureThreshold
-> ProtVer
-> CardanoHardForkTriggers
-> (ProtocolInfo (CardanoBlock c),
    m [BlockForging m (CardanoBlock c)])
mkTestProtocolInfo
        (CoreNodeId
coreNodeId, CoreNode c
coreNodeShelley)
        ShelleyGenesis c
genesisShelley
        ProtocolVersion
propPV
        Nonce
initialNonce
        Config
genesisByron
        GeneratedSecrets
generatedSecretsByron
        (PBftSignatureThreshold -> Maybe PBftSignatureThreshold
forall a. a -> Maybe a
Just (PBftSignatureThreshold -> Maybe PBftSignatureThreshold)
-> PBftSignatureThreshold -> Maybe PBftSignatureThreshold
forall a b. (a -> b) -> a -> b
$ Double -> PBftSignatureThreshold
PBftSignatureThreshold Double
1) -- Trivialize the PBFT signature
                                          -- window so that the forks induced by
                                          -- the network partition are as deep
                                          -- as possible.
        -- This test only enters the Shelley era.
        (Version -> Natural -> ProtVer
SL.ProtVer Version
shelleyMajorVersion Natural
0)
        CardanoHardForkTriggers
hardForkOnDefaultProtocolVersions

{-------------------------------------------------------------------------------
  Constants
-------------------------------------------------------------------------------}

-- | The major protocol version of the Byron era in this test.
byronMajorVersion :: Integral a => a
byronMajorVersion :: forall a. Integral a => a
byronMajorVersion = Version -> a
forall i. Integral i => Version -> i
SL.getVersion Version
shelleyMajorVersion a -> a -> a
forall a. Num a => a -> a -> a
- a
1

byronInitialMinorVersion :: Num a => a
byronInitialMinorVersion :: forall a. Num a => a
byronInitialMinorVersion = a
0

-- | The (first) major protocol version of the Shelley era, as used by
-- 'hardForkOnDefaultProtocolVersions'.
shelleyMajorVersion :: SL.Version
shelleyMajorVersion :: Version
shelleyMajorVersion = forall era. Era era => Version
L.eraProtVerLow @(ShelleyEra StandardCrypto)

{-------------------------------------------------------------------------------
  Miscellany
-------------------------------------------------------------------------------}

byronEpochSize :: SecurityParam -> Word64
byronEpochSize :: SecurityParam -> Word64
byronEpochSize (SecurityParam Word64
k) =
    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
CC.Common.BlockCount Word64
k

-- | By default, the initial major Byron protocol version is @0@, but we want to
-- set it to 'byronMajorVersion'.
setByronProtVer :: ProtocolInfo (CardanoBlock c) -> ProtocolInfo (CardanoBlock c)
setByronProtVer :: forall c.
ProtocolInfo (CardanoBlock c) -> ProtocolInfo (CardanoBlock c)
setByronProtVer =
    (ExtLedgerState (CardanoBlock c)
 -> ExtLedgerState (CardanoBlock c))
-> ProtocolInfo (CardanoBlock c) -> ProtocolInfo (CardanoBlock c)
forall {b}.
(ExtLedgerState b -> ExtLedgerState b)
-> ProtocolInfo b -> ProtocolInfo b
modifyInitLedger ((ExtLedgerState (CardanoBlock c)
  -> ExtLedgerState (CardanoBlock c))
 -> ProtocolInfo (CardanoBlock c) -> ProtocolInfo (CardanoBlock c))
-> (ExtLedgerState (CardanoBlock c)
    -> ExtLedgerState (CardanoBlock c))
-> ProtocolInfo (CardanoBlock c)
-> ProtocolInfo (CardanoBlock c)
forall a b. (a -> b) -> a -> b
$ (LedgerState (CardanoBlock c) -> LedgerState (CardanoBlock c))
-> ExtLedgerState (CardanoBlock c)
-> ExtLedgerState (CardanoBlock c)
forall {blk}.
(LedgerState blk -> LedgerState blk)
-> ExtLedgerState blk -> ExtLedgerState blk
modifyExtLedger ((LedgerState (CardanoBlock c) -> LedgerState (CardanoBlock c))
 -> ExtLedgerState (CardanoBlock c)
 -> ExtLedgerState (CardanoBlock c))
-> (LedgerState (CardanoBlock c) -> LedgerState (CardanoBlock c))
-> ExtLedgerState (CardanoBlock c)
-> ExtLedgerState (CardanoBlock c)
forall a b. (a -> b) -> a -> b
$ (LedgerState ByronBlock -> LedgerState ByronBlock)
-> LedgerState (CardanoBlock c) -> LedgerState (CardanoBlock c)
forall x (xs :: [*]).
(LedgerState x -> LedgerState x)
-> LedgerState (HardForkBlock (x : xs))
-> LedgerState (HardForkBlock (x : xs))
modifyHFLedgerState ((LedgerState ByronBlock -> LedgerState ByronBlock)
 -> LedgerState (CardanoBlock c) -> LedgerState (CardanoBlock c))
-> (LedgerState ByronBlock -> LedgerState ByronBlock)
-> LedgerState (CardanoBlock c)
-> LedgerState (CardanoBlock c)
forall a b. (a -> b) -> a -> b
$ \LedgerState ByronBlock
st ->
      let cvs :: ChainValidationState
cvs = LedgerState ByronBlock -> ChainValidationState
byronLedgerState LedgerState ByronBlock
st
          us :: State
us  = (ChainValidationState -> State
CC.cvsUpdateState ChainValidationState
cvs) {
              CC.adoptedProtocolVersion =
                CC.Update.ProtocolVersion byronMajorVersion byronInitialMinorVersion 0
            }
       in LedgerState ByronBlock
st { byronLedgerState = cvs { CC.cvsUpdateState = us } }
  where
    modifyInitLedger :: (ExtLedgerState b -> ExtLedgerState b)
-> ProtocolInfo b -> ProtocolInfo b
modifyInitLedger ExtLedgerState b -> ExtLedgerState b
f ProtocolInfo b
pinfo = ProtocolInfo b
pinfo { pInfoInitLedger = f (pInfoInitLedger pinfo) }
    modifyExtLedger :: (LedgerState blk -> LedgerState blk)
-> ExtLedgerState blk -> ExtLedgerState blk
modifyExtLedger LedgerState blk -> LedgerState blk
f ExtLedgerState blk
elgr = ExtLedgerState blk
elgr { ledgerState = f (ledgerState elgr ) }

    modifyHFLedgerState ::
         (LedgerState x -> LedgerState x)
      -> LedgerState (HardForkBlock (x : xs))
      -> LedgerState (HardForkBlock (x : xs))
    modifyHFLedgerState :: forall x (xs :: [*]).
(LedgerState x -> LedgerState x)
-> LedgerState (HardForkBlock (x : xs))
-> LedgerState (HardForkBlock (x : xs))
modifyHFLedgerState LedgerState x -> LedgerState x
f (HardForkLedgerState (HardForkState (TZ Current LedgerState x
st))) =
        HardForkState LedgerState (x : xs)
-> LedgerState (HardForkBlock (x : xs))
forall (xs :: [*]).
HardForkState LedgerState xs -> LedgerState (HardForkBlock xs)
HardForkLedgerState (Telescope (K Past) (Current LedgerState) (x : xs)
-> HardForkState LedgerState (x : xs)
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState (Current LedgerState x
-> Telescope (K Past) (Current LedgerState) (x : xs)
forall {k} (f :: k -> *) (x :: k) (g :: k -> *) (xs1 :: [k]).
f x -> Telescope g f (x : xs1)
TZ Current LedgerState x
st {currentState = f (currentState st)}))
    modifyHFLedgerState LedgerState x -> LedgerState x
_ LedgerState (HardForkBlock (x : xs))
st = LedgerState (HardForkBlock (x : xs))
st