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

module Test.ThreadNet.Shelley (tests) where

import           Cardano.Crypto.Hash (ShortHash)
import qualified Cardano.Ledger.BaseTypes as SL (UnitInterval,
                     mkNonceFromNumber, shelleyProtVer, unboundRational)
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.Eras (EraCrypto)
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           Test.Consensus.Shelley.MockCrypto (MockCrypto, MockShelley)
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

type Era   = MockShelley ShortHash
type Proto = TPraos (MockCrypto ShortHash)

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 Proto Era))
setupVersion      :: (NodeToNodeVersion, BlockNodeToNodeVersion (ShelleyBlock Proto Era))
  }
  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
      DecentralizationParam
setupD  <- Gen DecentralizationParam
forall a. Arbitrary a => Gen a
arbitrary
      DecentralizationParam
setupD2 <- Gen DecentralizationParam
forall a. Arbitrary a => Gen a
arbitrary

      Nonce
setupInitialNonce <- [(Int, Gen Nonce)] -> Gen Nonce
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
        [ (Int
1, Nonce -> Gen Nonce
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Nonce
SL.NeutralNonce)
        , (Int
9, Word64 -> Nonce
SL.mkNonceFromNumber (Word64 -> Nonce) -> Gen Word64 -> Gen Nonce
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word64
forall a. Arbitrary a => Gen a
arbitrary)
        ]

      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
minK, Word64
maxK)

      TestConfig
setupTestConfig <- Gen TestConfig
forall a. Arbitrary a => Gen a
arbitrary

      (NodeToNodeVersion, ShelleyNodeToNodeVersion)
setupVersion <- Proxy (ShelleyBlock Proto Era)
-> Gen
     (NodeToNodeVersion,
      BlockNodeToNodeVersion (ShelleyBlock Proto Era))
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> Gen (NodeToNodeVersion, BlockNodeToNodeVersion blk)
genVersion (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(ShelleyBlock Proto Era))

      TestSetup -> Gen TestSetup
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestSetup
        { DecentralizationParam
setupD :: DecentralizationParam
setupD :: DecentralizationParam
setupD
        , DecentralizationParam
setupD2 :: DecentralizationParam
setupD2 :: DecentralizationParam
setupD2
        , Nonce
setupInitialNonce :: Nonce
setupInitialNonce :: Nonce
setupInitialNonce
        , SecurityParam
setupK :: SecurityParam
setupK :: SecurityParam
setupK
        , TestConfig
setupTestConfig :: TestConfig
setupTestConfig :: TestConfig
setupTestConfig
        , (NodeToNodeVersion,
 BlockNodeToNodeVersion (ShelleyBlock Proto Era))
(NodeToNodeVersion, ShelleyNodeToNodeVersion)
setupVersion :: (NodeToNodeVersion,
 BlockNodeToNodeVersion (ShelleyBlock Proto Era))
setupVersion :: (NodeToNodeVersion, ShelleyNodeToNodeVersion)
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
      TestSetup
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.
      Bool
moreEpochs <- [(Int, Gen Bool)] -> Gen Bool
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
3, Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False), (Int
1, Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)]

      TestSetup -> NightlyTestSetup
NightlyTestSetup (TestSetup -> NightlyTestSetup)
-> Gen TestSetup -> Gen NightlyTestSetup
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Bool -> Bool
not Bool
moreEpochs then TestSetup -> Gen TestSetup
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestSetup
setup else do
        let TestSetup
              { SecurityParam
setupK :: TestSetup -> SecurityParam
setupK :: SecurityParam
setupK
              , TestConfig
setupTestConfig :: TestSetup -> TestConfig
setupTestConfig :: TestConfig
setupTestConfig
              } = TestSetup
setup
            TestConfig
              { NumSlots
numSlots :: NumSlots
numSlots :: TestConfig -> NumSlots
numSlots
              } = TestConfig
setupTestConfig
            NumSlots Word64
t = NumSlots
numSlots

        -- run for multiple epochs
        Word64
factor <- (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
1, Word64
2)
        let t' :: Word64
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)

        TestSetup -> Gen TestSetup
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestSetup
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 Proto Era))
setupVersion :: TestSetup
-> (NodeToNodeVersion,
    BlockNodeToNodeVersion (ShelleyBlock Proto Era))
setupVersion :: (NodeToNodeVersion,
 BlockNodeToNodeVersion (ShelleyBlock Proto Era))
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 Proto Era)
-> TestOutput (ShelleyBlock Proto Era) -> Property
forall blk.
(Condense blk, Condense (HeaderHash blk), Eq blk, RunNode blk) =>
PropGeneralArgs blk -> TestOutput blk -> Property
prop_general PropGeneralArgs
      { pgaBlockProperty :: ShelleyBlock Proto Era -> Property
pgaBlockProperty       = Property -> ShelleyBlock Proto Era -> Property
forall a b. a -> b -> a
const (Property -> ShelleyBlock Proto Era -> Property)
-> Property -> ShelleyBlock Proto Era -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
      , pgaCountTxs :: ShelleyBlock Proto Era -> Word64
pgaCountTxs            = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64)
-> (ShelleyBlock Proto Era -> Int)
-> ShelleyBlock Proto Era
-> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenTx (ShelleyBlock Proto Era)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([GenTx (ShelleyBlock Proto Era)] -> Int)
-> (ShelleyBlock Proto Era -> [GenTx (ShelleyBlock Proto Era)])
-> ShelleyBlock Proto Era
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBlock Proto Era -> [GenTx (ShelleyBlock Proto Era)]
forall blk. HasTxs blk => blk -> [GenTx blk]
extractTxs
      , pgaExpectedCannotForge :: SlotNo
-> NodeId -> WrapCannotForge (ShelleyBlock Proto Era) -> Bool
pgaExpectedCannotForge = SlotNo
-> NodeId -> WrapCannotForge (ShelleyBlock Proto Era) -> 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 Proto Era)
pgaTestConfigB         = TestConfigB (ShelleyBlock Proto Era)
testConfigB
      }
      TestOutput (ShelleyBlock Proto Era)
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 Proto Era)
    testConfigB :: TestConfigB (ShelleyBlock Proto Era)
testConfigB = TestConfigB
      { forgeEbbEnv :: Maybe (ForgeEbbEnv (ShelleyBlock Proto Era))
forgeEbbEnv  = Maybe (ForgeEbbEnv (ShelleyBlock Proto Era))
forall a. Maybe a
Nothing
      , future :: Future
future       = SlotLength -> EpochSize -> Future
singleEraFuture SlotLength
tpraosSlotLength EpochSize
epochSize
      , messageDelay :: CalcMessageDelay (ShelleyBlock Proto Era)
messageDelay = CalcMessageDelay (ShelleyBlock Proto Era)
forall blk. CalcMessageDelay blk
noCalcMessageDelay
      , nodeJoinPlan :: NodeJoinPlan
nodeJoinPlan = NumCoreNodes -> NodeJoinPlan
trivialNodeJoinPlan NumCoreNodes
numCoreNodes
      , nodeRestarts :: NodeRestarts
nodeRestarts = NodeRestarts
noRestarts
      , txGenExtra :: TxGenExtra (ShelleyBlock Proto Era)
txGenExtra   = ShelleyTxGenExtra
        { stgeGenEnv :: GenEnv Era
stgeGenEnv          = WhetherToGeneratePPUs
-> [CoreNode (MockCrypto ShortHash)] -> GenEnv Era
forall h.
HashAlgorithm h =>
WhetherToGeneratePPUs
-> [CoreNode (MockCrypto h)] -> GenEnv (MockShelley h)
mkGenEnv WhetherToGeneratePPUs
inclPPUs [CoreNode (EraCrypto Era)]
[CoreNode (MockCrypto ShortHash)]
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 Proto Era))
version      = (NodeToNodeVersion,
 BlockNodeToNodeVersion (ShelleyBlock Proto Era))
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 Proto Era)
testOutput =
        TestConfig
-> TestConfigB (ShelleyBlock Proto Era)
-> (forall (m :: * -> *).
    IOLike m =>
    TestConfigMB m (ShelleyBlock Proto Era))
-> TestOutput (ShelleyBlock Proto Era)
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 Proto Era)
testConfigB TestConfigMB
            { nodeInfo :: CoreNodeId -> TestNodeInitialization m (ShelleyBlock Proto Era)
nodeInfo = \(CoreNodeId Word64
nid) ->
              let (ProtocolInfo (ShelleyBlock Proto Era)
protocolInfo, m [BlockForging m (ShelleyBlock Proto Era)]
blockForging) =
                    ShelleyGenesis (MockCrypto ShortHash)
-> Nonce
-> ProtVer
-> CoreNode (MockCrypto ShortHash)
-> (ProtocolInfo (ShelleyBlock Proto Era),
    m [BlockForging m (ShelleyBlock Proto Era)])
forall (m :: * -> *) c.
(IOLike m, PraosCrypto c,
 ShelleyCompatible (TPraos c) (ShelleyEra c)) =>
ShelleyGenesis c
-> Nonce
-> ProtVer
-> CoreNode c
-> (ProtocolInfo (ShelleyBlock (TPraos c) (ShelleyEra c)),
    m [BlockForging m (ShelleyBlock (TPraos c) (ShelleyEra c))])
mkProtocolShelley
                      ShelleyGenesis (EraCrypto Era)
ShelleyGenesis (MockCrypto ShortHash)
genesisConfig
                      Nonce
setupInitialNonce
                      ProtVer
nextProtVer
                      ([CoreNode (EraCrypto Era)]
[CoreNode (MockCrypto ShortHash)]
coreNodes [CoreNode (MockCrypto ShortHash)]
-> Int -> CoreNode (MockCrypto ShortHash)
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 Proto Era)
tniProtocolInfo = ProtocolInfo (ShelleyBlock Proto Era)
protocolInfo
                    , tniCrucialTxs :: [GenTx (ShelleyBlock Proto Era)]
tniCrucialTxs =
                        if Bool -> Bool
not Bool
includingDUpdateTx then [] else
                        [CoreNode (MockCrypto ShortHash)]
-> ProtVer
-> SlotNo
-> DecentralizationParam
-> [GenTx (ShelleyBlock Proto Era)]
forall c.
ShelleyBasedEra (ShelleyEra c) =>
[CoreNode c]
-> ProtVer
-> SlotNo
-> DecentralizationParam
-> [GenTx (ShelleyBlock (TPraos c) (ShelleyEra c))]
mkSetDecentralizationParamTxs
                          [CoreNode (EraCrypto Era)]
[CoreNode (MockCrypto ShortHash)]
coreNodes
                          ProtVer
nextProtVer
                          SlotNo
sentinel   -- Does not expire during test
                          DecentralizationParam
setupD2
                    , tniBlockForging :: m [BlockForging m (ShelleyBlock Proto Era)]
tniBlockForging = m [BlockForging m (ShelleyBlock Proto Era)]
blockForging
                    }
            , mkRekeyM :: Maybe (m (RekeyM m (ShelleyBlock Proto Era)))
mkRekeyM = Maybe (m (RekeyM m (ShelleyBlock Proto Era)))
forall a. Maybe a
Nothing
            }

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

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

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

    epochSize :: EpochSize
    epochSize :: EpochSize
epochSize = ShelleyGenesis (MockCrypto ShortHash) -> EpochSize
forall c. ShelleyGenesis c -> EpochSize
sgEpochLength ShelleyGenesis (EraCrypto Era)
ShelleyGenesis (MockCrypto ShortHash)
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 Era
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 Proto Era)) -> NewEpochState Era
forall proto era.
Ticked (LedgerState (ShelleyBlock proto era)) -> NewEpochState era
Shelley.tickedShelleyLedgerState (Ticked (LedgerState (ShelleyBlock Proto Era))
 -> NewEpochState Era)
-> Ticked (LedgerState (ShelleyBlock Proto Era))
-> NewEpochState Era
forall a b. (a -> b) -> a -> b
$
                  LedgerCfg (LedgerState (ShelleyBlock Proto Era))
-> SlotNo
-> LedgerState (ShelleyBlock Proto Era)
-> Ticked (LedgerState (ShelleyBlock Proto Era))
forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
applyChainTick LedgerCfg (LedgerState (ShelleyBlock Proto Era))
ledgerConfig SlotNo
sentinel LedgerState (ShelleyBlock Proto Era)
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 Era -> PParams Era
forall era. EraGov era => NewEpochState era -> PParams era
Shelley.getPParams NewEpochState Era
ls PParams Era
-> Getting UnitInterval (PParams Era) UnitInterval -> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (PParams Era) UnitInterval
forall era.
EraPParams era =>
SimpleGetter (PParams era) UnitInterval
SimpleGetter (PParams Era) 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 Proto Era) -> String
forall a. Show a => a -> String
show LedgerState (ShelleyBlock Proto Era)
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 Era -> String
forall a. Show a => a -> String
show NewEpochState Era
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 Proto Era)
lsUnticked) <- [(NodeId, LedgerState (ShelleyBlock Proto Era))]
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 Proto Era))]
        finalLedgers :: [(NodeId, LedgerState (ShelleyBlock Proto Era))]
finalLedgers =
            Map NodeId (LedgerState (ShelleyBlock Proto Era))
-> [(NodeId, LedgerState (ShelleyBlock Proto Era))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map NodeId (LedgerState (ShelleyBlock Proto Era))
 -> [(NodeId, LedgerState (ShelleyBlock Proto Era))])
-> Map NodeId (LedgerState (ShelleyBlock Proto Era))
-> [(NodeId, LedgerState (ShelleyBlock Proto Era))]
forall a b. (a -> b) -> a -> b
$ NodeOutput (ShelleyBlock Proto Era)
-> LedgerState (ShelleyBlock Proto Era)
forall blk. NodeOutput blk -> LedgerState blk
nodeOutputFinalLedger (NodeOutput (ShelleyBlock Proto Era)
 -> LedgerState (ShelleyBlock Proto Era))
-> Map NodeId (NodeOutput (ShelleyBlock Proto Era))
-> Map NodeId (LedgerState (ShelleyBlock Proto Era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestOutput (ShelleyBlock Proto Era)
-> Map NodeId (NodeOutput (ShelleyBlock Proto Era))
forall blk. TestOutput blk -> Map NodeId (NodeOutput blk)
testOutputNodes TestOutput (ShelleyBlock Proto Era)
testOutput

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