{-# 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)