{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}

module Test.ThreadNet.Shelley (tests) where

import Cardano.Ledger.BaseTypes (nonZero)
import qualified Cardano.Ledger.BaseTypes as SL
  ( UnitInterval
  , mkNonceFromNumber
  , shelleyProtVer
  , unboundRational
  )
import Cardano.Ledger.Shelley (ShelleyEra)
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Ledger.Shelley.Core as SL
import qualified Cardano.Ledger.Shelley.Translation as SL
  ( toFromByronTranslationContext
  )
import qualified Cardano.Protocol.TPraos.OCert as SL
import Cardano.Slotting.EpochInfo (fixedEpochInfo)
import Control.Monad (replicateM)
import qualified Data.Map.Strict as Map
import Data.Word (Word64)
import Lens.Micro ((^.))
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config.SecurityParam
import Ouroboros.Consensus.Ledger.Abstract
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.Ledger (ShelleyBlock)
import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley
import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()
import Ouroboros.Consensus.Shelley.Node
import Ouroboros.Consensus.Shelley.ShelleyHFC ()
import Test.Consensus.Shelley.MockCrypto (MockCrypto)
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.ThreadNet.General
import Test.ThreadNet.Infra.Shelley
import Test.ThreadNet.Network
  ( TestNodeInitialization (..)
  , nodeOutputFinalLedger
  )
import Test.ThreadNet.TxGen.Shelley
import Test.ThreadNet.Util.NodeJoinPlan (trivialNodeJoinPlan)
import Test.ThreadNet.Util.NodeRestarts (noRestarts)
import Test.ThreadNet.Util.NodeToNodeVersion (genVersion)
import Test.ThreadNet.Util.Seed (runGen)
import Test.Util.HardFork.Future (singleEraFuture)
import Test.Util.Orphans.Arbitrary ()
import Test.Util.Slots (NumSlots (..))
import Test.Util.TestEnv

data TestSetup = TestSetup
  { TestSetup -> DecentralizationParam
setupD :: DecentralizationParam
  , TestSetup -> DecentralizationParam
setupD2 :: DecentralizationParam
  -- ^ scheduled value
  --
  -- If not equal to 'setupD', every node immediately (ie slot 0) issues a
  -- protocol update transaction that will change the @d@ protocol parameter
  -- accordingly.
  , TestSetup -> Nonce
setupInitialNonce :: SL.Nonce
  -- ^ the initial Shelley 'SL.ticknStateEpochNonce'
  --
  -- This test varies it too ensure it explores different leader schedules.
  , TestSetup -> SecurityParam
setupK :: SecurityParam
  , TestSetup -> TestConfig
setupTestConfig :: TestConfig
  , TestSetup
-> (NodeToNodeVersion,
    BlockNodeToNodeVersion
      (ShelleyBlock (TPraos MockCrypto) ShelleyEra))
setupVersion ::
      ( NodeToNodeVersion
      , BlockNodeToNodeVersion (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
      )
  }
  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

minK :: Word64
minK :: Word64
minK = Word64
5 -- Less than this increases risk of CP violations

maxK :: Word64
maxK :: Word64
maxK = Word64
10 -- More than this wastes execution time

activeSlotCoeff :: Rational
activeSlotCoeff :: Rational
activeSlotCoeff = Rational
0.5 -- TODO this is high

instance Arbitrary TestSetup where
  arbitrary :: Gen TestSetup
arbitrary = do
    setupD <- Gen DecentralizationParam
forall a. Arbitrary a => Gen a
arbitrary
    setupD2 <- arbitrary

    setupInitialNonce <-
      frequency
        [ (1, pure SL.NeutralNonce)
        , (9, SL.mkNonceFromNumber <$> arbitrary)
        ]

    setupK <- SecurityParam <$> choose (minK, maxK) `suchThatMap` nonZero

    setupTestConfig <- arbitrary

    setupVersion <- genVersion (Proxy @(ShelleyBlock (TPraos MockCrypto) ShelleyEra))

    pure
      TestSetup
        { setupD
        , setupD2
        , setupInitialNonce
        , setupK
        , setupTestConfig
        , setupVersion
        }

-- TODO shrink

-- | We run for more slots at night.
newtype NightlyTestSetup = NightlyTestSetup TestSetup
  deriving Int -> NightlyTestSetup -> ShowS
[NightlyTestSetup] -> ShowS
NightlyTestSetup -> String
(Int -> NightlyTestSetup -> ShowS)
-> (NightlyTestSetup -> String)
-> ([NightlyTestSetup] -> ShowS)
-> Show NightlyTestSetup
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NightlyTestSetup -> ShowS
showsPrec :: Int -> NightlyTestSetup -> ShowS
$cshow :: NightlyTestSetup -> String
show :: NightlyTestSetup -> String
$cshowList :: [NightlyTestSetup] -> ShowS
showList :: [NightlyTestSetup] -> ShowS
Show

instance Arbitrary NightlyTestSetup where
  shrink :: NightlyTestSetup -> [NightlyTestSetup]
shrink (NightlyTestSetup TestSetup
setup) = TestSetup -> NightlyTestSetup
NightlyTestSetup (TestSetup -> NightlyTestSetup)
-> [TestSetup] -> [NightlyTestSetup]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestSetup -> [TestSetup]
forall a. Arbitrary a => a -> [a]
shrink TestSetup
setup

  arbitrary :: Gen NightlyTestSetup
arbitrary = do
    setup <- Gen TestSetup
forall a. Arbitrary a => Gen a
arbitrary

    -- This caused 100 tests to have an expected run time of half an hour on
    -- a Buildkite machine. Note that the Buildkite CI infrastructure is now
    -- deprecated in favour of self-hosted Hydra instances.
    --
    -- 100 extended tests had an average run time of 4643 seconds
    -- 100 unextended tests had an average of 689 seconds
    --
    -- 3/4*689 + 1/4*4643 seconds =~= 28 minutes.
    moreEpochs <- frequency [(3, pure False), (1, pure True)]

    NightlyTestSetup
      <$> if not moreEpochs
        then pure setup
        else do
          let TestSetup
                { setupK
                , setupTestConfig
                } = setup
              TestConfig
                { numSlots
                } = setupTestConfig
              NumSlots t = numSlots

          -- run for multiple epochs
          factor <- choose (1, 2)
          let t' = Word64
t Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
factor Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* EpochSize -> Word64
unEpochSize (SecurityParam -> Rational -> EpochSize
mkEpochSize SecurityParam
setupK Rational
activeSlotCoeff)

          pure
            setup
              { setupTestConfig =
                  setupTestConfig
                    { numSlots = NumSlots t'
                    }
              }

tests :: TestTree
tests :: TestTree
tests =
  String -> [TestTree] -> TestTree
testGroup
    String
"Shelley 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
$ \case
            TestEnv
Nightly -> String -> (NightlyTestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
name ((NightlyTestSetup -> Property) -> TestTree)
-> (NightlyTestSetup -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ \(NightlyTestSetup TestSetup
setup) ->
              TestSetup -> Property
prop_simple_real_tpraos_convergence TestSetup
setup
            TestEnv
_ -> (Int -> Int) -> TestTree -> TestTree
adjustQuickCheckTests (Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5) (TestTree -> TestTree) -> TestTree -> 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_real_tpraos_convergence
    ]

prop_simple_real_tpraos_convergence :: TestSetup -> Property
prop_simple_real_tpraos_convergence :: TestSetup -> Property
prop_simple_real_tpraos_convergence
  TestSetup
    { DecentralizationParam
setupD :: TestSetup -> DecentralizationParam
setupD :: DecentralizationParam
setupD
    , DecentralizationParam
setupD2 :: TestSetup -> DecentralizationParam
setupD2 :: DecentralizationParam
setupD2
    , Nonce
setupInitialNonce :: TestSetup -> Nonce
setupInitialNonce :: Nonce
setupInitialNonce
    , SecurityParam
setupK :: TestSetup -> SecurityParam
setupK :: SecurityParam
setupK
    , TestConfig
setupTestConfig :: TestSetup -> TestConfig
setupTestConfig :: TestConfig
setupTestConfig
    , (NodeToNodeVersion,
 BlockNodeToNodeVersion
   (ShelleyBlock (TPraos MockCrypto) ShelleyEra))
setupVersion :: TestSetup
-> (NodeToNodeVersion,
    BlockNodeToNodeVersion
      (ShelleyBlock (TPraos MockCrypto) ShelleyEra))
setupVersion :: (NodeToNodeVersion,
 BlockNodeToNodeVersion
   (ShelleyBlock (TPraos MockCrypto) ShelleyEra))
setupVersion
    } =
    String -> String -> Property -> Property
countertabulate
      String
"Epoch number of last slot"
      ( Word64 -> String
forall a. Show a => a -> String
show (Word64 -> String) -> Word64 -> String
forall a b. (a -> b) -> a -> b
$
          if Word64
0 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= NumSlots -> Word64
unNumSlots NumSlots
numSlots
            then Word64
0
            else
              (NumSlots -> Word64
unNumSlots NumSlots
numSlots Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` EpochSize -> Word64
unEpochSize EpochSize
epochSize
      )
      (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> String -> Property -> Property
countertabulate
        String
"Updating d"
        ( if Bool -> Bool
not Bool
dShouldUpdate
            then String
"No"
            else
              String
"Yes, " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Ordering -> String
forall a. Show a => a -> String
show (DecentralizationParam -> DecentralizationParam -> Ordering
forall a. Ord a => a -> a -> Ordering
compare DecentralizationParam
setupD DecentralizationParam
setupD2)
        )
      (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (SecurityParam -> String
forall a. Show a => a -> String
show SecurityParam
setupK)
      (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ PropGeneralArgs (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
-> TestOutput (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
-> Property
forall blk.
(Condense blk, Condense (HeaderHash blk), Eq blk, RunNode blk) =>
PropGeneralArgs blk -> TestOutput blk -> Property
prop_general
        PropGeneralArgs
          { pgaBlockProperty :: ShelleyBlock (TPraos MockCrypto) ShelleyEra -> Property
pgaBlockProperty = Property -> ShelleyBlock (TPraos MockCrypto) ShelleyEra -> Property
forall a b. a -> b -> a
const (Property
 -> ShelleyBlock (TPraos MockCrypto) ShelleyEra -> Property)
-> Property
-> ShelleyBlock (TPraos MockCrypto) ShelleyEra
-> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
          , pgaCountTxs :: ShelleyBlock (TPraos MockCrypto) ShelleyEra -> Word64
pgaCountTxs = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64)
-> (ShelleyBlock (TPraos MockCrypto) ShelleyEra -> Int)
-> ShelleyBlock (TPraos MockCrypto) ShelleyEra
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenTx (ShelleyBlock (TPraos MockCrypto) ShelleyEra)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([GenTx (ShelleyBlock (TPraos MockCrypto) ShelleyEra)] -> Int)
-> (ShelleyBlock (TPraos MockCrypto) ShelleyEra
    -> [GenTx (ShelleyBlock (TPraos MockCrypto) ShelleyEra)])
-> ShelleyBlock (TPraos MockCrypto) ShelleyEra
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBlock (TPraos MockCrypto) ShelleyEra
-> [GenTx (ShelleyBlock (TPraos MockCrypto) ShelleyEra)]
forall blk. HasTxs blk => blk -> [GenTx blk]
extractTxs
          , pgaExpectedCannotForge :: SlotNo
-> NodeId
-> WrapCannotForge (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
-> Bool
pgaExpectedCannotForge = SlotNo
-> NodeId
-> WrapCannotForge (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
-> Bool
forall blk. SlotNo -> NodeId -> WrapCannotForge blk -> Bool
noExpectedCannotForges
          , pgaFirstBlockNo :: BlockNo
pgaFirstBlockNo = BlockNo
0
          , pgaFixedMaxForkLength :: Maybe NumBlocks
pgaFixedMaxForkLength = Maybe NumBlocks
forall a. Maybe a
Nothing
          , pgaFixedSchedule :: Maybe LeaderSchedule
pgaFixedSchedule = Maybe LeaderSchedule
forall a. Maybe a
Nothing
          , pgaSecurityParam :: SecurityParam
pgaSecurityParam = SecurityParam
setupK
          , pgaTestConfig :: TestConfig
pgaTestConfig = TestConfig
setupTestConfig
          , pgaTestConfigB :: TestConfigB (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
pgaTestConfigB = TestConfigB (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
testConfigB
          }
        TestOutput (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
testOutput
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Property
prop_checkFinalD
   where
    countertabulate :: String -> String -> Property -> Property
    countertabulate :: String -> String -> Property -> Property
countertabulate String
lbl String
s =
      String -> [String] -> Property -> Property
forall prop.
Testable prop =>
String -> [String] -> prop -> Property
tabulate String
lbl [String
s] (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
lbl String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s)

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

    testConfigB :: TestConfigB (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
    testConfigB :: TestConfigB (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
testConfigB =
      TestConfigB
        { forgeEbbEnv :: Maybe (ForgeEbbEnv (ShelleyBlock (TPraos MockCrypto) ShelleyEra))
forgeEbbEnv = Maybe (ForgeEbbEnv (ShelleyBlock (TPraos MockCrypto) ShelleyEra))
forall a. Maybe a
Nothing
        , future :: Future
future = SlotLength -> EpochSize -> Future
singleEraFuture SlotLength
tpraosSlotLength EpochSize
epochSize
        , messageDelay :: CalcMessageDelay (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
messageDelay = CalcMessageDelay (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
forall blk. CalcMessageDelay blk
noCalcMessageDelay
        , nodeJoinPlan :: NodeJoinPlan
nodeJoinPlan = NumCoreNodes -> NodeJoinPlan
trivialNodeJoinPlan NumCoreNodes
numCoreNodes
        , nodeRestarts :: NodeRestarts
nodeRestarts = NodeRestarts
noRestarts
        , txGenExtra :: TxGenExtra (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
txGenExtra =
            ShelleyTxGenExtra
              { stgeGenEnv :: GenEnv MockCrypto ShelleyEra
stgeGenEnv = WhetherToGeneratePPUs
-> [CoreNode MockCrypto] -> GenEnv MockCrypto ShelleyEra
mkGenEnv WhetherToGeneratePPUs
inclPPUs [CoreNode MockCrypto]
coreNodes
              , stgeStartAt :: SlotNo
stgeStartAt =
                  Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ if Bool
includingDUpdateTx then Word64
1 else Word64
0
                  -- We don't generate any transactions before the transaction
                  -- carrying the proposal because they might consume its inputs
                  -- before it does, thereby rendering it invalid.
              }
        , version :: (NodeToNodeVersion,
 BlockNodeToNodeVersion
   (ShelleyBlock (TPraos MockCrypto) ShelleyEra))
version = (NodeToNodeVersion,
 BlockNodeToNodeVersion
   (ShelleyBlock (TPraos MockCrypto) ShelleyEra))
setupVersion
        }

    inclPPUs :: WhetherToGeneratePPUs
    inclPPUs :: WhetherToGeneratePPUs
inclPPUs =
      -- We don't generate any other updates, since doing so might
      -- accidentally supplant the bespoke update that these tests are
      -- expecting.
      --
      -- The transaction this test introduces causes all nodes to propose the
      -- same parameter update. It'd technically be OK if some nodes then
      -- changed their proposal to a different update, as long as at least
      -- @Quorum@-many nodes were still proposing this test's original update
      -- as of the epoch boundary. However, we keep the test simple and just
      -- avoid introducing any other proposals.
      if Bool
includingDUpdateTx then WhetherToGeneratePPUs
DoNotGeneratePPUs else WhetherToGeneratePPUs
DoGeneratePPUs

    -- The slot immediately after the end of this test.
    sentinel :: SlotNo
    sentinel :: SlotNo
sentinel = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ NumSlots -> Word64
unNumSlots NumSlots
numSlots

    -- We don't create the update proposal etc unless @d@ would change.
    includingDUpdateTx :: Bool
    includingDUpdateTx :: Bool
includingDUpdateTx = DecentralizationParam
setupD DecentralizationParam -> DecentralizationParam -> Bool
forall a. Eq a => a -> a -> Bool
/= DecentralizationParam
setupD2

    -- The ledger state should have an updated @d@ as of this slot.
    dUpdatedAsOf :: SlotNo
    dUpdatedAsOf :: SlotNo
dUpdatedAsOf = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ EpochSize -> Word64
unEpochSize EpochSize
epochSize

    -- Whether we expect @d@ to be updated during this test
    dShouldUpdate :: Bool
    dShouldUpdate :: Bool
dShouldUpdate = Bool
includingDUpdateTx Bool -> Bool -> Bool
&& SlotNo
sentinel SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
dUpdatedAsOf

    testOutput :: TestOutput (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
testOutput =
      TestConfig
-> TestConfigB (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
-> (forall (m :: * -> *).
    IOLike m =>
    TestConfigMB m (ShelleyBlock (TPraos MockCrypto) ShelleyEra))
-> TestOutput (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
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 (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
testConfigB
        TestConfigMB
          { nodeInfo :: CoreNodeId
-> TestNodeInitialization
     m (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
nodeInfo = \(CoreNodeId Word64
nid) ->
              let (ProtocolInfo (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
protocolInfo, m [BlockForging m (ShelleyBlock (TPraos MockCrypto) ShelleyEra)]
blockForging) =
                    ShelleyGenesis
-> Nonce
-> ProtVer
-> CoreNode MockCrypto
-> (ProtocolInfo (ShelleyBlock (TPraos MockCrypto) ShelleyEra),
    m [BlockForging m (ShelleyBlock (TPraos MockCrypto) ShelleyEra)])
forall (m :: * -> *) c.
(IOLike m, ShelleyCompatible (TPraos c) ShelleyEra) =>
ShelleyGenesis
-> Nonce
-> ProtVer
-> CoreNode c
-> (ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra),
    m [BlockForging m (ShelleyBlock (TPraos c) ShelleyEra)])
mkProtocolShelley
                      ShelleyGenesis
genesisConfig
                      Nonce
setupInitialNonce
                      ProtVer
nextProtVer
                      ([CoreNode MockCrypto]
coreNodes [CoreNode MockCrypto] -> Int -> CoreNode MockCrypto
forall a. HasCallStack => [a] -> Int -> a
!! Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
nid)
               in TestNodeInitialization
                    { tniProtocolInfo :: ProtocolInfo (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
tniProtocolInfo = ProtocolInfo (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
protocolInfo
                    , tniCrucialTxs :: [GenTx (ShelleyBlock (TPraos MockCrypto) ShelleyEra)]
tniCrucialTxs =
                        if Bool -> Bool
not Bool
includingDUpdateTx
                          then []
                          else
                            [CoreNode MockCrypto]
-> ProtVer
-> SlotNo
-> DecentralizationParam
-> [GenTx (ShelleyBlock (TPraos MockCrypto) ShelleyEra)]
forall c.
ShelleyBasedEra ShelleyEra =>
[CoreNode c]
-> ProtVer
-> SlotNo
-> DecentralizationParam
-> [GenTx (ShelleyBlock (TPraos c) ShelleyEra)]
mkSetDecentralizationParamTxs
                              [CoreNode MockCrypto]
coreNodes
                              ProtVer
nextProtVer
                              SlotNo
sentinel -- Does not expire during test
                              DecentralizationParam
setupD2
                    , tniBlockForging :: m [BlockForging m (ShelleyBlock (TPraos MockCrypto) ShelleyEra)]
tniBlockForging = m [BlockForging m (ShelleyBlock (TPraos MockCrypto) ShelleyEra)]
blockForging
                    }
          , mkRekeyM :: Maybe (m (RekeyM m (ShelleyBlock (TPraos MockCrypto) ShelleyEra)))
mkRekeyM = Maybe (m (RekeyM m (ShelleyBlock (TPraos MockCrypto) ShelleyEra)))
forall a. Maybe a
Nothing
          }

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

    coreNodes :: [CoreNode MockCrypto]
    coreNodes :: [CoreNode MockCrypto]
coreNodes =
      Seed -> Gen [CoreNode MockCrypto] -> [CoreNode MockCrypto]
forall a. Seed -> Gen a -> a
runGen Seed
initSeed (Gen [CoreNode MockCrypto] -> [CoreNode MockCrypto])
-> Gen [CoreNode MockCrypto] -> [CoreNode MockCrypto]
forall a b. (a -> b) -> a -> b
$
        Int -> Gen (CoreNode MockCrypto) -> Gen [CoreNode MockCrypto]
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 MockCrypto) -> Gen [CoreNode MockCrypto])
-> Gen (CoreNode MockCrypto) -> Gen [CoreNode MockCrypto]
forall a b. (a -> b) -> a -> b
$
          KESPeriod -> Gen (CoreNode MockCrypto)
forall c. Crypto c => KESPeriod -> Gen (CoreNode c)
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 MockCrypto] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreNode MockCrypto]
coreNodes) Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
initialLovelacePerCoreNode

    genesisConfig :: ShelleyGenesis
    genesisConfig :: ShelleyGenesis
genesisConfig =
      ProtVer
-> SecurityParam
-> Rational
-> DecentralizationParam
-> Word64
-> SlotLength
-> KesConfig
-> [CoreNode MockCrypto]
-> ShelleyGenesis
forall c.
PraosCrypto c =>
ProtVer
-> SecurityParam
-> Rational
-> DecentralizationParam
-> Word64
-> SlotLength
-> KesConfig
-> [CoreNode c]
-> ShelleyGenesis
mkGenesisConfig
        ProtVer
genesisProtVer
        SecurityParam
setupK
        Rational
activeSlotCoeff
        DecentralizationParam
setupD
        Word64
maxLovelaceSupply
        SlotLength
tpraosSlotLength
        (Proxy MockCrypto -> NumSlots -> KesConfig
forall (proxy :: * -> *) c.
Crypto c =>
proxy c -> NumSlots -> KesConfig
mkKesConfig (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @MockCrypto) NumSlots
numSlots)
        [CoreNode MockCrypto]
coreNodes

    epochSize :: EpochSize
    epochSize :: EpochSize
epochSize = ShelleyGenesis -> EpochSize
sgEpochLength ShelleyGenesis
genesisConfig

    genesisProtVer :: SL.ProtVer
    genesisProtVer :: ProtVer
genesisProtVer = Version -> Natural -> ProtVer
SL.ProtVer Version
SL.shelleyProtVer Natural
0

    -- Which protocol version to endorse
    nextProtVer :: SL.ProtVer
    nextProtVer :: ProtVer
nextProtVer = ProtVer -> ProtVer
incrementMinorProtVer ProtVer
genesisProtVer

    -- Does the final ledger state have the expected @d@ value when ticked over
    -- to the 'sentinel' slot?
    prop_checkFinalD :: Property
    prop_checkFinalD :: Property
prop_checkFinalD =
      [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$
        [ let ls :: NewEpochState ShelleyEra
ls =
                -- Handle the corner case where the test has enough scheduled
                -- slots to reach the epoch transition but the last several
                -- slots end up empty.
                Ticked
  (LedgerState (ShelleyBlock (TPraos MockCrypto) ShelleyEra)) DiffMK
-> NewEpochState ShelleyEra
forall proto era (mk :: MapKind).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> NewEpochState era
Shelley.tickedShelleyLedgerState (Ticked
   (LedgerState (ShelleyBlock (TPraos MockCrypto) ShelleyEra)) DiffMK
 -> NewEpochState ShelleyEra)
-> Ticked
     (LedgerState (ShelleyBlock (TPraos MockCrypto) ShelleyEra)) DiffMK
-> NewEpochState ShelleyEra
forall a b. (a -> b) -> a -> b
$
                  ComputeLedgerEvents
-> LedgerCfg
     (LedgerState (ShelleyBlock (TPraos MockCrypto) ShelleyEra))
-> SlotNo
-> LedgerState
     (ShelleyBlock (TPraos MockCrypto) ShelleyEra) EmptyMK
-> Ticked
     (LedgerState (ShelleyBlock (TPraos MockCrypto) ShelleyEra)) DiffMK
forall (l :: MapKind -> *).
IsLedger l =>
ComputeLedgerEvents
-> LedgerCfg l -> SlotNo -> l EmptyMK -> Ticked l DiffMK
applyChainTick ComputeLedgerEvents
OmitLedgerEvents LedgerCfg
  (LedgerState (ShelleyBlock (TPraos MockCrypto) ShelleyEra))
ledgerConfig SlotNo
sentinel LedgerState (ShelleyBlock (TPraos MockCrypto) ShelleyEra) EmptyMK
lsUnticked

              msg :: String
msg =
                String
"The ticked final ledger state of "
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> NodeId -> String
forall a. Show a => a -> String
show NodeId
nid
                  String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" has an unexpected value for the d protocol parameter."

              -- The actual final value of @d@
              actual :: SL.UnitInterval
              actual :: UnitInterval
actual = NewEpochState ShelleyEra -> PParams ShelleyEra
forall era. EraGov era => NewEpochState era -> PParams era
Shelley.getPParams NewEpochState ShelleyEra
ls PParams ShelleyEra
-> Getting UnitInterval (PParams ShelleyEra) UnitInterval
-> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams ShelleyEra) UnitInterval
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams ShelleyEra) UnitInterval
SL.ppDG

              -- The expected final value of @d@
              --
              -- NOTE: Not applicable if 'dWasFreeToVary'.
              expected :: DecentralizationParam
              expected :: DecentralizationParam
expected = if Bool
dShouldUpdate then DecentralizationParam
setupD2 else DecentralizationParam
setupD
           in String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"unticked " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> LedgerState (ShelleyBlock (TPraos MockCrypto) ShelleyEra) EmptyMK
-> String
forall a. Show a => a -> String
show LedgerState (ShelleyBlock (TPraos MockCrypto) ShelleyEra) EmptyMK
lsUnticked)
                (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"ticked   " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> NewEpochState ShelleyEra -> String
forall a. Show a => a -> String
show NewEpochState ShelleyEra
ls)
                (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"(d,d2) = " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (DecentralizationParam, DecentralizationParam) -> String
forall a. Show a => a -> String
show (DecentralizationParam
setupD, DecentralizationParam
setupD2))
                (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample
                  ( String
"(dUpdatedAsOf, dShouldUpdate) = "
                      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (SlotNo, Bool) -> String
forall a. Show a => a -> String
show (SlotNo
dUpdatedAsOf, Bool
dShouldUpdate)
                  )
                (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
msg
                (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool
dWasFreeToVary
                  Bool -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.||. UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
SL.unboundRational UnitInterval
actual
                    Rational -> Rational -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== DecentralizationParam -> Rational
decentralizationParamToRational DecentralizationParam
expected
        | (NodeId
nid, LedgerState (ShelleyBlock (TPraos MockCrypto) ShelleyEra) EmptyMK
lsUnticked) <- [(NodeId,
  LedgerState (ShelleyBlock (TPraos MockCrypto) ShelleyEra) EmptyMK)]
finalLedgers
        ]
     where
      -- If the test setup does not introduce a PPU then the normal Shelley
      -- generator might do so, and so we will not know what d to expect at
      -- the end.
      dWasFreeToVary :: Bool
      dWasFreeToVary :: Bool
dWasFreeToVary = case WhetherToGeneratePPUs
inclPPUs of
        WhetherToGeneratePPUs
DoGeneratePPUs -> Bool
True
        WhetherToGeneratePPUs
DoNotGeneratePPUs -> Bool
False

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

      ledgerConfig :: LedgerConfig (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
      ledgerConfig :: LedgerCfg
  (LedgerState (ShelleyBlock (TPraos MockCrypto) ShelleyEra))
ledgerConfig =
        ShelleyGenesis
-> TranslationContext ShelleyEra
-> EpochInfo (Except PastHorizonException)
-> ShelleyLedgerConfig ShelleyEra
forall era.
ShelleyGenesis
-> TranslationContext era
-> EpochInfo (Except PastHorizonException)
-> ShelleyLedgerConfig era
Shelley.mkShelleyLedgerConfig
          ShelleyGenesis
genesisConfig
          (ShelleyGenesis -> FromByronTranslationContext
SL.toFromByronTranslationContext ShelleyGenesis
genesisConfig) -- trivial translation context
          (EpochSize -> SlotLength -> EpochInfo (Except PastHorizonException)
forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo EpochSize
epochSize SlotLength
tpraosSlotLength)