{-# 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 Control.Tracer (nullTracer)
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 System.FS.API (SomeHasFS (..))
import qualified System.FS.Sim.MockFS as MockFS
import qualified System.FS.Sim.STM as Sim
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 -> [Char]
(Int -> TestSetup -> ShowS)
-> (TestSetup -> [Char])
-> ([TestSetup] -> ShowS)
-> Show TestSetup
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestSetup -> ShowS
showsPrec :: Int -> TestSetup -> ShowS
$cshow :: TestSetup -> [Char]
show :: TestSetup -> [Char]
$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 :: Ratio Integer
activeSlotCoeff = Ratio Integer
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 -> [Char]
(Int -> NightlyTestSetup -> ShowS)
-> (NightlyTestSetup -> [Char])
-> ([NightlyTestSetup] -> ShowS)
-> Show NightlyTestSetup
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NightlyTestSetup -> ShowS
showsPrec :: Int -> NightlyTestSetup -> ShowS
$cshow :: NightlyTestSetup -> [Char]
show :: NightlyTestSetup -> [Char]
$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 -> Ratio Integer -> EpochSize
mkEpochSize SecurityParam
setupK Ratio Integer
activeSlotCoeff)

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

tests :: TestTree
tests :: TestTree
tests =
  [Char] -> [TestTree] -> TestTree
testGroup
    [Char]
"Shelley ThreadNet"
    [ let name :: [Char]
name = [Char]
"simple convergence"
       in (TestEnv -> TestTree) -> TestTree
askTestEnv ((TestEnv -> TestTree) -> TestTree)
-> (TestEnv -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \case
            TestEnv
Nightly -> [Char] -> (NightlyTestSetup -> Property) -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
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
$ [Char] -> (TestSetup -> Property) -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
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
    } =
    [Char] -> [Char] -> Property -> Property
countertabulate
      [Char]
"Epoch number of last slot"
      ( Word64 -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> [Char]) -> Word64 -> [Char]
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
$ [Char] -> [Char] -> Property -> Property
countertabulate
        [Char]
"Updating d"
        ( if Bool -> Bool
not Bool
dShouldUpdate
            then [Char]
"No"
            else
              [Char]
"Yes, " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Ordering -> [Char]
forall a. Show a => a -> [Char]
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
$ [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample (SecurityParam -> [Char]
forall a. Show a => a -> [Char]
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 :: [Char] -> [Char] -> Property -> Property
countertabulate [Char]
lbl [Char]
s =
      [Char] -> [[Char]] -> Property -> Property
forall prop.
Testable prop =>
[Char] -> [[Char]] -> prop -> Property
tabulate [Char]
lbl [[Char]
s] (Property -> Property)
-> (Property -> Property) -> Property -> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
lbl [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
": " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
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, MonadKESAgent 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, MonadKESAgent m) =>
    TestConfigMB m blk)
-> TestOutput blk
runTestNetwork
        TestConfig
setupTestConfig
        TestConfigB (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
testConfigB
        TestConfigMB
          { nodeInfo :: CoreNodeId
-> m (TestNodeInitialization
        m (ShelleyBlock (TPraos MockCrypto) ShelleyEra))
nodeInfo = \(CoreNodeId Word64
nid) -> do
              fs <- HasFS m HandleMock -> SomeHasFS m
forall h (m :: * -> *). Eq h => HasFS m h -> SomeHasFS m
SomeHasFS (HasFS m HandleMock -> SomeHasFS m)
-> m (HasFS m HandleMock) -> m (SomeHasFS m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MockFS -> m (HasFS m HandleMock)
forall (m :: * -> *).
(MonadSTM m, MonadMask m, PrimMonad m) =>
MockFS -> m (HasFS m HandleMock)
Sim.simHasFS' MockFS
MockFS.empty
              (protocolInfo, blockForging) <-
                mkProtocolShelley
                  fs
                  genesisConfig
                  setupInitialNonce
                  nextProtVer
                  (coreNodes !! fromIntegral nid)
              pure $
                TestNodeInitialization
                  { tniProtocolInfo = protocolInfo
                  , tniCrucialTxs =
                      if not includingDUpdateTx
                        then []
                        else
                          mkSetDecentralizationParamTxs
                            coreNodes
                            nextProtVer
                            sentinel -- Does not expire during test
                            setupD2
                  , tniBlockForging = blockForging nullTracer
                  }
          , 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
-> Ratio Integer
-> DecentralizationParam
-> Word64
-> SlotLength
-> KesConfig
-> [CoreNode MockCrypto]
-> ShelleyGenesis
forall c.
PraosCrypto c =>
ProtVer
-> SecurityParam
-> Ratio Integer
-> DecentralizationParam
-> Word64
-> SlotLength
-> KesConfig
-> [CoreNode c]
-> ShelleyGenesis
mkGenesisConfig
        ProtVer
genesisProtVer
        SecurityParam
setupK
        Ratio Integer
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 -> Word32 -> ProtVer
SL.ProtVer Version
SL.shelleyProtVer Word32
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 -> *) blk.
IsLedger l blk =>
ComputeLedgerEvents
-> LedgerCfg l blk
-> SlotNo
-> l blk EmptyMK
-> Ticked l blk DiffMK
applyChainTick ComputeLedgerEvents
OmitLedgerEvents LedgerCfg LedgerState (ShelleyBlock (TPraos MockCrypto) ShelleyEra)
ledgerConfig SlotNo
sentinel LedgerState (ShelleyBlock (TPraos MockCrypto) ShelleyEra) EmptyMK
lsUnticked

              msg :: [Char]
msg =
                [Char]
"The ticked final ledger state of "
                  [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> NodeId -> [Char]
forall a. Show a => a -> [Char]
show NodeId
nid
                  [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" 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 [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"unticked " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> LedgerState (ShelleyBlock (TPraos MockCrypto) ShelleyEra) EmptyMK
-> [Char]
forall a. Show a => a -> [Char]
show LedgerState (ShelleyBlock (TPraos MockCrypto) ShelleyEra) EmptyMK
lsUnticked)
                (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"ticked   " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> NewEpochState ShelleyEra -> [Char]
forall a. Show a => a -> [Char]
show NewEpochState ShelleyEra
ls)
                (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"(d,d2) = " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> (DecentralizationParam, DecentralizationParam) -> [Char]
forall a. Show a => a -> [Char]
show (DecentralizationParam
setupD, DecentralizationParam
setupD2))
                (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample
                  ( [Char]
"(dUpdatedAsOf, dShouldUpdate) = "
                      [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> (SlotNo, Bool) -> [Char]
forall a. Show a => a -> [Char]
show (SlotNo
dUpdatedAsOf, Bool
dShouldUpdate)
                  )
                (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
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 -> Ratio Integer
forall r. BoundedRational r => r -> Ratio Integer
SL.unboundRational UnitInterval
actual
                    Ratio Integer -> Ratio Integer -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== DecentralizationParam -> Ratio Integer
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)