{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.ThreadNet.MaryAlonzo (tests) where

import           Cardano.Crypto.Hash (ShortHash)
import           Cardano.Ledger.Alonzo.Genesis (AlonzoGenesis)
import qualified Cardano.Ledger.Api.Transition as L
import qualified Cardano.Ledger.BaseTypes as SL (Version, getVersion,
                     natVersion)
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.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.SOP.Strict (NP (..))
import           Data.Word (Word64)
import           Lens.Micro
import           Ouroboros.Consensus.BlockchainTime
import           Ouroboros.Consensus.Cardano.Condense ()
import           Ouroboros.Consensus.Cardano.Node (TriggerHardFork (..))
import           Ouroboros.Consensus.Config.SecurityParam
import           Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common
                     (isHardForkNodeToNodeEnabled)
import           Ouroboros.Consensus.Ledger.SupportsMempool (extractTxs)
import           Ouroboros.Consensus.Node.NetworkProtocolVersion
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.NodeId
import           Ouroboros.Consensus.Protocol.TPraos (TPraos)
import           Ouroboros.Consensus.Shelley.Eras
import           Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()
import           Ouroboros.Consensus.Shelley.Node
                     (ProtocolParamsShelleyBased (..), ShelleyGenesis (..))
import qualified Test.Cardano.Ledger.Alonzo.Examples.Consensus as SL
import           Test.Consensus.Shelley.MockCrypto (MockCrypto)
import           Test.QuickCheck
import           Test.Tasty
import           Test.Tasty.QuickCheck
import           Test.ThreadNet.General
import qualified Test.ThreadNet.Infra.Shelley as Shelley
import           Test.ThreadNet.Infra.ShelleyBasedHardFork
import           Test.ThreadNet.Infra.TwoEras
import           Test.ThreadNet.Network (NodeOutput (..),
                     TestNodeInitialization (..))
import           Test.ThreadNet.TxGen
import           Test.ThreadNet.TxGen.Alonzo ()
import           Test.ThreadNet.TxGen.Mary ()
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 (EraSize (..), Future (..))
import           Test.Util.Orphans.Arbitrary ()
import           Test.Util.Slots (NumSlots (..))
import           Test.Util.TestEnv

-- | No Byron era, so our crypto can be trivial.
type Crypto = MockCrypto ShortHash

type MaryAlonzoBlock =
  ShelleyBasedHardForkBlock (TPraos Crypto) (MaryEra Crypto) (TPraos Crypto) (AlonzoEra Crypto)

-- | The varying data of this test
--
-- Note: The Shelley nodes in this test all join, propose an update, 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
setupSlotLength   :: SlotLength
  , TestSetup -> TestConfig
setupTestConfig   :: TestConfig
  , TestSetup
-> (NodeToNodeVersion, BlockNodeToNodeVersion MaryAlonzoBlock)
setupVersion      :: (NodeToNodeVersion, BlockNodeToNodeVersion MaryAlonzoBlock)
  }
  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
setupSlotLength   <- Gen SlotLength
forall a. Arbitrary a => Gen a
arbitrary

    let epochSize :: EpochSize
epochSize = Word64 -> EpochSize
EpochSize (Word64 -> EpochSize) -> Word64 -> EpochSize
forall a b. (a -> b) -> a -> b
$ SecurityParam -> Word64
shelleyEpochSize SecurityParam
setupK
    TestConfig
setupTestConfig <- SecurityParam -> (EpochSize, EpochSize) -> Gen TestConfig
genTestConfig
                         SecurityParam
setupK
                         (EpochSize
epochSize, EpochSize
epochSize)
    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)]

    -- TODO How reliable is the Byron-based partition duration logic when
    -- reused for Shelley?
    Partition
setupPartition <- NumCoreNodes -> NumSlots -> SecurityParam -> Gen Partition
genPartition NumCoreNodes
numCoreNodes NumSlots
numSlots SecurityParam
setupK

    (NodeToNodeVersion,
 HardForkNodeToNodeVersion
   '[ShelleyBlock (TPraos Crypto) (MaryEra Crypto),
     ShelleyBlock (TPraos Crypto) (AlonzoEra Crypto)])
setupVersion   <- (BlockNodeToNodeVersion MaryAlonzoBlock -> Bool)
-> Proxy MaryAlonzoBlock
-> Gen (NodeToNodeVersion, BlockNodeToNodeVersion MaryAlonzoBlock)
forall blk.
SupportedNetworkProtocolVersion blk =>
(BlockNodeToNodeVersion blk -> Bool)
-> Proxy blk -> Gen (NodeToNodeVersion, BlockNodeToNodeVersion blk)
genVersionFiltered
                        BlockNodeToNodeVersion MaryAlonzoBlock -> Bool
HardForkNodeToNodeVersion
  '[ShelleyBlock (TPraos Crypto) (MaryEra Crypto),
    ShelleyBlock (TPraos Crypto) (AlonzoEra Crypto)]
-> Bool
forall (xs :: [*]). HardForkNodeToNodeVersion xs -> Bool
isHardForkNodeToNodeEnabled
                        (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @MaryAlonzoBlock)

    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
setupSlotLength :: SlotLength
setupSlotLength :: SlotLength
setupSlotLength
      , TestConfig
setupTestConfig :: TestConfig
setupTestConfig :: TestConfig
setupTestConfig
      , (NodeToNodeVersion, BlockNodeToNodeVersion MaryAlonzoBlock)
(NodeToNodeVersion,
 HardForkNodeToNodeVersion
   '[ShelleyBlock (TPraos Crypto) (MaryEra Crypto),
     ShelleyBlock (TPraos Crypto) (AlonzoEra Crypto)])
setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion MaryAlonzoBlock)
setupVersion :: (NodeToNodeVersion,
 HardForkNodeToNodeVersion
   '[ShelleyBlock (TPraos Crypto) (MaryEra Crypto),
     ShelleyBlock (TPraos Crypto) (AlonzoEra Crypto)])
setupVersion
      }

  -- TODO shrink

tests :: TestTree
tests :: TestTree
tests = String -> [TestTree] -> TestTree
testGroup String
"MaryAlonzo 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_allegraAlonzo_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 -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
10) TestTree
tree

prop_simple_allegraAlonzo_convergence :: TestSetup -> Property
prop_simple_allegraAlonzo_convergence :: TestSetup -> Property
prop_simple_allegraAlonzo_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
setupSlotLength :: TestSetup -> SlotLength
setupSlotLength :: SlotLength
setupSlotLength
  , TestConfig
setupTestConfig :: TestSetup -> TestConfig
setupTestConfig :: TestConfig
setupTestConfig
  , (NodeToNodeVersion, BlockNodeToNodeVersion MaryAlonzoBlock)
setupVersion :: TestSetup
-> (NodeToNodeVersion, BlockNodeToNodeVersion MaryAlonzoBlock)
setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion MaryAlonzoBlock)
setupVersion
  } =
    PropGeneralArgs MaryAlonzoBlock
-> TestOutput MaryAlonzoBlock -> Property
forall blk.
(Condense blk, Condense (HeaderHash blk), Eq blk, RunNode blk) =>
PropGeneralArgs blk -> TestOutput blk -> Property
prop_general_semisync PropGeneralArgs MaryAlonzoBlock
pga TestOutput MaryAlonzoBlock
testOutput Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
    TestOutput MaryAlonzoBlock -> Property
forall blk. HasHeader blk => TestOutput blk -> Property
prop_inSync TestOutput MaryAlonzoBlock
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 slot in the second era"
        [ TestOutput MaryAlonzoBlock -> Set SlotNo -> String
forall era (eras :: [*]).
TestOutput (HardForkBlock (era : eras)) -> Set SlotNo -> String
label_hadActiveNonOverlaySlots
            TestOutput MaryAlonzoBlock
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
numFirstEraSlots)
        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 MaryAlonzoBlock
pga = PropGeneralArgs
        { pgaBlockProperty :: MaryAlonzoBlock -> Property
pgaBlockProperty       = Property -> MaryAlonzoBlock -> Property
forall a b. a -> b -> a
const (Property -> MaryAlonzoBlock -> Property)
-> Property -> MaryAlonzoBlock -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
        , pgaCountTxs :: MaryAlonzoBlock -> Word64
pgaCountTxs            = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64)
-> (MaryAlonzoBlock -> Int) -> MaryAlonzoBlock -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenTx MaryAlonzoBlock] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([GenTx MaryAlonzoBlock] -> Int)
-> (MaryAlonzoBlock -> [GenTx MaryAlonzoBlock])
-> MaryAlonzoBlock
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaryAlonzoBlock -> [GenTx MaryAlonzoBlock]
forall blk. HasTxs blk => blk -> [GenTx blk]
extractTxs
        , pgaExpectedCannotForge :: SlotNo -> NodeId -> WrapCannotForge MaryAlonzoBlock -> Bool
pgaExpectedCannotForge = SlotNo -> NodeId -> WrapCannotForge MaryAlonzoBlock -> Bool
forall blk. SlotNo -> NodeId -> WrapCannotForge blk -> Bool
noExpectedCannotForges
        , pgaFirstBlockNo :: BlockNo
pgaFirstBlockNo        = BlockNo
0
        , pgaFixedMaxForkLength :: Maybe NumBlocks
pgaFixedMaxForkLength  = NumBlocks -> Maybe NumBlocks
forall a. a -> Maybe a
Just NumBlocks
maxForkLength
          -- the leader schedule isn't fixed because the Shelley leader
          -- schedule is (at least ideally) unpredictable
        , pgaFixedSchedule :: Maybe LeaderSchedule
pgaFixedSchedule       = Maybe LeaderSchedule
forall a. Maybe a
Nothing
        , pgaSecurityParam :: SecurityParam
pgaSecurityParam       = SecurityParam
setupK
        , pgaTestConfig :: TestConfig
pgaTestConfig          = TestConfig
setupTestConfig
        , pgaTestConfigB :: TestConfigB MaryAlonzoBlock
pgaTestConfigB         = TestConfigB MaryAlonzoBlock
testConfigB
        }

    testConfigB :: TestConfigB MaryAlonzoBlock
testConfigB = TestConfigB
      { forgeEbbEnv :: Maybe (ForgeEbbEnv MaryAlonzoBlock)
forgeEbbEnv  = Maybe (ForgeEbbEnv MaryAlonzoBlock)
forall a. Maybe a
Nothing
      , future :: Future
future       =
          if Bool
setupHardFork
          then
          -- In this case the PVU will trigger the transition to the second era
          --
          -- By FACT (B), the PVU is always successful if we reach the second
          -- era.
          SlotLength -> EpochSize -> EraSize -> Future -> Future
EraCons  SlotLength
setupSlotLength EpochSize
epochSize EraSize
firstEraSize (Future -> Future) -> Future -> Future
forall a b. (a -> b) -> a -> b
$
          SlotLength -> EpochSize -> Future
EraFinal SlotLength
setupSlotLength EpochSize
epochSize
          else
          SlotLength -> EpochSize -> Future
EraFinal SlotLength
setupSlotLength EpochSize
epochSize
      , messageDelay :: CalcMessageDelay MaryAlonzoBlock
messageDelay = Partition -> CalcMessageDelay MaryAlonzoBlock
forall blk. Partition -> CalcMessageDelay blk
mkMessageDelay Partition
setupPartition
      , nodeJoinPlan :: NodeJoinPlan
nodeJoinPlan = NumCoreNodes -> NodeJoinPlan
trivialNodeJoinPlan NumCoreNodes
numCoreNodes
      , nodeRestarts :: NodeRestarts
nodeRestarts = NodeRestarts
noRestarts
      , txGenExtra :: TxGenExtra MaryAlonzoBlock
txGenExtra   = TxGenExtra (ShelleyBlock (TPraos Crypto) (MaryEra Crypto))
-> WrapTxGenExtra (ShelleyBlock (TPraos Crypto) (MaryEra Crypto))
forall blk. TxGenExtra blk -> WrapTxGenExtra blk
WrapTxGenExtra () WrapTxGenExtra (ShelleyBlock (TPraos Crypto) (MaryEra Crypto))
-> NP
     WrapTxGenExtra '[ShelleyBlock (TPraos Crypto) (AlonzoEra Crypto)]
-> NP
     WrapTxGenExtra
     '[ShelleyBlock (TPraos Crypto) (MaryEra Crypto),
       ShelleyBlock (TPraos Crypto) (AlonzoEra Crypto)]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* TxGenExtra (ShelleyBlock (TPraos Crypto) (AlonzoEra Crypto))
-> WrapTxGenExtra (ShelleyBlock (TPraos Crypto) (AlonzoEra Crypto))
forall blk. TxGenExtra blk -> WrapTxGenExtra blk
WrapTxGenExtra () WrapTxGenExtra (ShelleyBlock (TPraos Crypto) (AlonzoEra Crypto))
-> NP WrapTxGenExtra '[]
-> NP
     WrapTxGenExtra '[ShelleyBlock (TPraos Crypto) (AlonzoEra Crypto)]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* NP WrapTxGenExtra '[]
forall {k} (f :: k -> *). NP f '[]
Nil
      , version :: (NodeToNodeVersion, BlockNodeToNodeVersion MaryAlonzoBlock)
version      = (NodeToNodeVersion, BlockNodeToNodeVersion MaryAlonzoBlock)
setupVersion
      }

    testOutput :: TestOutput MaryAlonzoBlock
    testOutput :: TestOutput MaryAlonzoBlock
testOutput = TestConfig
-> TestConfigB MaryAlonzoBlock
-> (forall (m :: * -> *).
    IOLike m =>
    TestConfigMB m MaryAlonzoBlock)
-> TestOutput MaryAlonzoBlock
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 MaryAlonzoBlock
testConfigB TestConfigMB {
          nodeInfo :: CoreNodeId -> TestNodeInitialization m MaryAlonzoBlock
nodeInfo = \(CoreNodeId Word64
nid) ->
            let protocolParamsShelleyBased :: ProtocolParamsShelleyBased Crypto
protocolParamsShelleyBased =
                  ProtocolParamsShelleyBased {
                      shelleyBasedInitialNonce :: Nonce
shelleyBasedInitialNonce      = Nonce
setupInitialNonce
                    , shelleyBasedLeaderCredentials :: [ShelleyLeaderCredentials Crypto]
shelleyBasedLeaderCredentials =
                        [CoreNode Crypto -> ShelleyLeaderCredentials Crypto
forall c. PraosCrypto c => CoreNode c -> ShelleyLeaderCredentials c
Shelley.mkLeaderCredentials
                          ([CoreNode Crypto]
coreNodes [CoreNode Crypto] -> Int -> CoreNode Crypto
forall a. HasCallStack => [a] -> Int -> a
!! Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
nid)]
                    }
                hardForkTrigger :: TriggerHardFork
hardForkTrigger =
                  Word16 -> TriggerHardFork
TriggerHardForkAtVersion (Word16 -> TriggerHardFork) -> Word16 -> TriggerHardFork
forall a b. (a -> b) -> a -> b
$ Version -> Word16
forall i. Integral i => Version -> i
SL.getVersion Version
majorVersion2
                (ProtocolInfo MaryAlonzoBlock
protocolInfo, m [BlockForging m MaryAlonzoBlock]
blockForging) =
                  ProtocolParamsShelleyBased (EraCrypto (MaryEra Crypto))
-> ProtVer
-> ProtVer
-> TransitionConfig (AlonzoEra Crypto)
-> TriggerHardFork
-> (ProtocolInfo MaryAlonzoBlock,
    m [BlockForging m MaryAlonzoBlock])
forall (m :: * -> *) proto1 era1 proto2 era2.
(IOLike m,
 ShelleyBasedHardForkConstraints proto1 era1 proto2 era2) =>
ProtocolParamsShelleyBased (EraCrypto era1)
-> ProtVer
-> ProtVer
-> TransitionConfig era2
-> TriggerHardFork
-> (ProtocolInfo
      (ShelleyBasedHardForkBlock proto1 era1 proto2 era2),
    m [BlockForging
         m (ShelleyBasedHardForkBlock proto1 era1 proto2 era2)])
protocolInfoShelleyBasedHardFork
                    ProtocolParamsShelleyBased (EraCrypto (MaryEra Crypto))
ProtocolParamsShelleyBased Crypto
protocolParamsShelleyBased
                    (Version -> Natural -> ProtVer
SL.ProtVer Version
majorVersion1 Natural
0)
                    (Version -> Natural -> ProtVer
SL.ProtVer Version
majorVersion2 Natural
0)
                    ( TranslationContext (AlonzoEra Crypto)
-> TransitionConfig (PreviousEra (AlonzoEra Crypto))
-> TransitionConfig (AlonzoEra Crypto)
forall era.
EraTransition era =>
TranslationContext era
-> TransitionConfig (PreviousEra era) -> TransitionConfig era
L.mkTransitionConfig TranslationContext (AlonzoEra Crypto)
AlonzoGenesis
alonzoGenesis
                    (TransitionConfig (PreviousEra (AlonzoEra Crypto))
 -> TransitionConfig (AlonzoEra Crypto))
-> TransitionConfig (PreviousEra (AlonzoEra Crypto))
-> TransitionConfig (AlonzoEra Crypto)
forall a b. (a -> b) -> a -> b
$ TranslationContext (PreviousEra (AlonzoEra Crypto))
-> TransitionConfig (PreviousEra (PreviousEra (AlonzoEra Crypto)))
-> TransitionConfig (PreviousEra (AlonzoEra Crypto))
forall era.
EraTransition era =>
TranslationContext era
-> TransitionConfig (PreviousEra era) -> TransitionConfig era
L.mkTransitionConfig TranslationContext (PreviousEra (AlonzoEra Crypto))
NoGenesis (MaryEra Crypto)
forall era. NoGenesis era
L.NoGenesis
                    (TransitionConfig (PreviousEra (PreviousEra (AlonzoEra Crypto)))
 -> TransitionConfig (PreviousEra (AlonzoEra Crypto)))
-> TransitionConfig (PreviousEra (PreviousEra (AlonzoEra Crypto)))
-> TransitionConfig (PreviousEra (AlonzoEra Crypto))
forall a b. (a -> b) -> a -> b
$ TranslationContext (PreviousEra (PreviousEra (AlonzoEra Crypto)))
-> TransitionConfig
     (PreviousEra (PreviousEra (PreviousEra (AlonzoEra Crypto))))
-> TransitionConfig (PreviousEra (PreviousEra (AlonzoEra Crypto)))
forall era.
EraTransition era =>
TranslationContext era
-> TransitionConfig (PreviousEra era) -> TransitionConfig era
L.mkTransitionConfig TranslationContext (PreviousEra (PreviousEra (AlonzoEra Crypto)))
NoGenesis (AllegraEra Crypto)
forall era. NoGenesis era
L.NoGenesis
                    (TransitionConfig
   (PreviousEra (PreviousEra (PreviousEra (AlonzoEra Crypto))))
 -> TransitionConfig (PreviousEra (PreviousEra (AlonzoEra Crypto))))
-> TransitionConfig
     (PreviousEra (PreviousEra (PreviousEra (AlonzoEra Crypto))))
-> TransitionConfig (PreviousEra (PreviousEra (AlonzoEra Crypto)))
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis Crypto -> TransitionConfig (ShelleyEra Crypto)
forall c. ShelleyGenesis c -> TransitionConfig (ShelleyEra c)
L.mkShelleyTransitionConfig ShelleyGenesis Crypto
shelleyGenesis
                    )
                    TriggerHardFork
hardForkTrigger
            in
            TestNodeInitialization {
                tniCrucialTxs :: [GenTx MaryAlonzoBlock]
tniCrucialTxs   =
                  if Bool -> Bool
not Bool
setupHardFork then [] else
                  (GenTx (ShelleyBlock (TPraos Crypto) (MaryEra Crypto))
 -> GenTx MaryAlonzoBlock)
-> [GenTx (ShelleyBlock (TPraos Crypto) (MaryEra Crypto))]
-> [GenTx MaryAlonzoBlock]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenTx (ShelleyBlock (TPraos Crypto) (MaryEra Crypto))
-> GenTx MaryAlonzoBlock
forall proto1 era1 proto2 era2.
GenTx (ShelleyBlock proto1 era1)
-> ShelleyBasedHardForkGenTx proto1 era1 proto2 era2
GenTxShelley1 ([GenTx (ShelleyBlock (TPraos Crypto) (MaryEra Crypto))]
 -> [GenTx MaryAlonzoBlock])
-> [GenTx (ShelleyBlock (TPraos Crypto) (MaryEra Crypto))]
-> [GenTx MaryAlonzoBlock]
forall a b. (a -> b) -> a -> b
$
                  [CoreNode (EraCrypto (MaryEra Crypto))]
-> ProtVer
-> SlotNo
-> DecentralizationParam
-> [GenTx (ShelleyBlock (TPraos Crypto) (MaryEra Crypto))]
forall proto era.
(ShelleyBasedEra era, AllegraEraTxBody era, ShelleyEraTxBody era,
 AtMostEra AlonzoEra era) =>
[CoreNode (EraCrypto era)]
-> ProtVer
-> SlotNo
-> DecentralizationParam
-> [GenTx (ShelleyBlock proto era)]
Shelley.mkMASetDecentralizationParamTxs
                    [CoreNode (EraCrypto (MaryEra Crypto))]
[CoreNode Crypto]
coreNodes
                    (Version -> Natural -> ProtVer
SL.ProtVer Version
majorVersion2 Natural
0)
                    (Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ NumSlots -> Word64
unNumSlots NumSlots
numSlots)   -- never expire
                    DecentralizationParam
setupD   -- unchanged
              , tniProtocolInfo :: ProtocolInfo MaryAlonzoBlock
tniProtocolInfo = ProtocolInfo MaryAlonzoBlock
protocolInfo
              , tniBlockForging :: m [BlockForging m MaryAlonzoBlock]
tniBlockForging = m [BlockForging m MaryAlonzoBlock]
blockForging
              }
          , mkRekeyM :: Maybe (m (RekeyM m MaryAlonzoBlock))
mkRekeyM = Maybe (m (RekeyM m MaryAlonzoBlock))
forall a. Maybe a
Nothing
          }

    maxForkLength :: NumBlocks
    maxForkLength :: NumBlocks
maxForkLength = Word64 -> NumBlocks
NumBlocks (Word64 -> NumBlocks) -> Word64 -> NumBlocks
forall a b. (a -> b) -> a -> b
$ SecurityParam -> Word64
maxRollbacks SecurityParam
setupK

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

    coreNodes :: [Shelley.CoreNode Crypto]
    coreNodes :: [CoreNode Crypto]
coreNodes = Seed -> Gen [CoreNode Crypto] -> [CoreNode Crypto]
forall a. Seed -> Gen a -> a
runGen Seed
initSeed (Gen [CoreNode Crypto] -> [CoreNode Crypto])
-> Gen [CoreNode Crypto] -> [CoreNode Crypto]
forall a b. (a -> b) -> a -> b
$
        Int -> Gen (CoreNode Crypto) -> Gen [CoreNode Crypto]
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 Crypto) -> Gen [CoreNode Crypto])
-> Gen (CoreNode Crypto) -> Gen [CoreNode Crypto]
forall a b. (a -> b) -> a -> b
$
          KESPeriod -> Gen (CoreNode Crypto)
forall c. PraosCrypto c => KESPeriod -> Gen (CoreNode c)
Shelley.genCoreNode KESPeriod
initialKESPeriod
      where
        NumCoreNodes Word64
n = NumCoreNodes
numCoreNodes

    maxLovelaceSupply :: Word64
    maxLovelaceSupply :: Word64
maxLovelaceSupply =
      Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([CoreNode Crypto] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreNode Crypto]
coreNodes) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
Shelley.initialLovelacePerCoreNode

    shelleyGenesis :: ShelleyGenesis Crypto
    shelleyGenesis :: ShelleyGenesis Crypto
shelleyGenesis =
        ProtVer
-> SecurityParam
-> Rational
-> DecentralizationParam
-> Word64
-> SlotLength
-> KesConfig
-> [CoreNode Crypto]
-> ShelleyGenesis Crypto
forall c.
PraosCrypto c =>
ProtVer
-> SecurityParam
-> Rational
-> DecentralizationParam
-> Word64
-> SlotLength
-> KesConfig
-> [CoreNode c]
-> ShelleyGenesis c
Shelley.mkGenesisConfig
          (Version -> Natural -> ProtVer
SL.ProtVer Version
majorVersion1 Natural
0)
          SecurityParam
setupK
          Rational
activeSlotCoeff
          DecentralizationParam
setupD
          Word64
maxLovelaceSupply
          SlotLength
setupSlotLength
          (Proxy Crypto -> 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 Crypto]
coreNodes

    alonzoGenesis :: AlonzoGenesis
    alonzoGenesis :: AlonzoGenesis
alonzoGenesis = AlonzoGenesis
SL.exampleAlonzoGenesis

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

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

    -- 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
numFirstEraSlots
      , 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
$ MaryAlonzoBlock -> Bool
forall era (eras :: [*]). HardForkBlock (era : eras) -> Bool
isFirstEraBlock MaryAlonzoBlock
blk
          | (NodeId
_nid, NodeOutput MaryAlonzoBlock
no) <- Map NodeId (NodeOutput MaryAlonzoBlock)
-> [(NodeId, NodeOutput MaryAlonzoBlock)]
forall k a. Map k a -> [(k, a)]
Map.toList Map NodeId (NodeOutput MaryAlonzoBlock)
testOutputNodes
          , let NodeOutput{Map SlotNo MaryAlonzoBlock
nodeOutputForges :: Map SlotNo MaryAlonzoBlock
nodeOutputForges :: forall blk. NodeOutput blk -> Map SlotNo blk
nodeOutputForges} = NodeOutput MaryAlonzoBlock
no
          , (MaryAlonzoBlock
blk, Map SlotNo MaryAlonzoBlock
_m) <- Maybe (MaryAlonzoBlock, Map SlotNo MaryAlonzoBlock)
-> [(MaryAlonzoBlock, Map SlotNo MaryAlonzoBlock)]
forall a. Maybe a -> [a]
maybeToList (Maybe (MaryAlonzoBlock, Map SlotNo MaryAlonzoBlock)
 -> [(MaryAlonzoBlock, Map SlotNo MaryAlonzoBlock)])
-> Maybe (MaryAlonzoBlock, Map SlotNo MaryAlonzoBlock)
-> [(MaryAlonzoBlock, Map SlotNo MaryAlonzoBlock)]
forall a b. (a -> b) -> a -> b
$ Map SlotNo MaryAlonzoBlock
-> Maybe (MaryAlonzoBlock, Map SlotNo MaryAlonzoBlock)
forall k a. Map k a -> Maybe (a, Map k a)
Map.maxView Map SlotNo MaryAlonzoBlock
nodeOutputForges
                -- the last block the node forged
          ]
      , rsEra2Slots :: Requirement
rsEra2Slots  =
          --- TODO this comment and code are wrong

          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
overlaySlots
      }
      where
        NumSlots Word64
t                  = NumSlots
numSlots
        TestOutput{Map NodeId (NodeOutput MaryAlonzoBlock)
testOutputNodes :: Map NodeId (NodeOutput MaryAlonzoBlock)
testOutputNodes :: forall blk. TestOutput blk -> Map NodeId (NodeOutput blk)
testOutputNodes} = TestOutput MaryAlonzoBlock
testOutput

    -- All OBFT overlay slots in the second era.
    overlaySlots :: Set SlotNo
    overlaySlots :: Set SlotNo
overlaySlots =
        NumSlots -> NumSlots -> UnitInterval -> EpochSize -> Set SlotNo
secondEraOverlaySlots
          NumSlots
numSlots
          (Word64 -> NumSlots
NumSlots Word64
numFirstEraSlots)
          (ShelleyGenesis Crypto -> PParams (ShelleyEra Crypto)
forall c. ShelleyGenesis c -> PParams (ShelleyEra c)
sgProtocolParams ShelleyGenesis Crypto
shelleyGenesis PParams (ShelleyEra Crypto)
-> Getting UnitInterval (PParams (ShelleyEra Crypto)) UnitInterval
-> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams (ShelleyEra Crypto)) UnitInterval
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams (ShelleyEra Crypto)) UnitInterval
SL.ppDG)
          EpochSize
epochSize

    numFirstEraSlots :: Word64
    numFirstEraSlots :: Word64
numFirstEraSlots =
        Word64
forall a. Num a => a
numFirstEraEpochs Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* EpochSize -> Word64
unEpochSize EpochSize
epochSize

    finalBlockEra :: String
    finalBlockEra :: String
finalBlockEra =
        if ReachesEra2 -> Bool
rsEra2Blocks ReachesEra2
reachesEra2
        then String
"Mary"
        else String
"Alonzo"

    finalIntersectionDepth :: Word64
    finalIntersectionDepth :: Word64
finalIntersectionDepth = Word64
depth
      where
        NumBlocks Word64
depth = PropGeneralArgs MaryAlonzoBlock
-> TestOutput MaryAlonzoBlock -> NumBlocks
forall blk.
HasHeader blk =>
PropGeneralArgs blk -> TestOutput blk -> NumBlocks
calcFinalIntersectionDepth PropGeneralArgs MaryAlonzoBlock
pga TestOutput MaryAlonzoBlock
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 MaryAlonzoBlock) -> String
forall a. Show a => a -> String
show (NodeOutput MaryAlonzoBlock -> Chain MaryAlonzoBlock
forall blk. NodeOutput blk -> Chain blk
nodeOutputFinalChain (NodeOutput MaryAlonzoBlock -> Chain MaryAlonzoBlock)
-> Map NodeId (NodeOutput MaryAlonzoBlock)
-> Map NodeId (Chain MaryAlonzoBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestOutput MaryAlonzoBlock
-> Map NodeId (NodeOutput MaryAlonzoBlock)
forall blk. TestOutput blk -> Map NodeId (NodeOutput blk)
testOutputNodes TestOutput MaryAlonzoBlock
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

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

-- | The major protocol version of the first era in this test
majorVersion1 :: SL.Version
majorVersion1 :: Version
majorVersion1 = forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
SL.natVersion @1

-- | The major protocol version of the second era in this test
majorVersion2 :: SL.Version
majorVersion2 :: Version
majorVersion2 = forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
SL.natVersion @2