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

module Test.ThreadNet.Praos (tests) where

import Cardano.Ledger.BaseTypes (nonZero)
import Control.Monad (replicateM)
import qualified Data.Map.Strict as Map
import Data.Word (Word64)
import Numeric.Natural (Natural)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.BlockchainTime
import Ouroboros.Consensus.Config.SecurityParam
import qualified Ouroboros.Consensus.HardFork.History as HardFork
import Ouroboros.Consensus.Mock.Ledger
import Ouroboros.Consensus.Mock.Node ()
import Ouroboros.Consensus.Mock.Node.Praos
  ( MockPraosBlock
  , blockForgingPraos
  , protocolInfoPraos
  )
import Ouroboros.Consensus.Mock.Protocol.Praos
import Ouroboros.Consensus.Node.ProtocolInfo
  ( NumCoreNodes (NumCoreNodes)
  , enumCoreNodes
  )
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
import Test.ThreadNet.General
import Test.ThreadNet.TxGen.Mock ()
import Test.ThreadNet.Util
import Test.ThreadNet.Util.HasCreator.Mock ()
import Test.ThreadNet.Util.NodeJoinPlan
import Test.ThreadNet.Util.NodeRestarts
import Test.ThreadNet.Util.NodeToNodeVersion
import Test.ThreadNet.Util.SimpleBlock
import Test.Util.HardFork.Future (singleEraFuture)
import Test.Util.Orphans.Arbitrary ()
import Test.Util.Slots (NumSlots (unNumSlots))

data TestSetup = TestSetup
  { TestSetup -> EpochSize
setupEpochSize :: EpochSize
  , TestSetup -> Natural
setupInitialNonce :: Natural
  -- ^ the initial Shelley 'praosInitialEta'
  --
  -- This test varies it too ensure it explores different leader schedules.
  , TestSetup -> SecurityParam
setupK :: SecurityParam
  , TestSetup -> NodeJoinPlan
setupNodeJoinPlan :: NodeJoinPlan
  , TestSetup -> SlotLength
setupSlotLength :: SlotLength
  , TestSetup -> TestConfig
setupTestConfig :: TestConfig
  , TestSetup -> PraosEvolvingStake
setupEvolvingStake :: PraosEvolvingStake
  }
  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

genEvolvingStake :: EpochSize -> TestConfig -> Gen PraosEvolvingStake
genEvolvingStake :: EpochSize -> TestConfig -> Gen PraosEvolvingStake
genEvolvingStake EpochSize
epochSize TestConfig{NumSlots
numSlots :: NumSlots
numSlots :: TestConfig -> NumSlots
numSlots, NumCoreNodes
numCoreNodes :: NumCoreNodes
numCoreNodes :: TestConfig -> NumCoreNodes
numCoreNodes} = do
  chosenEpochs <- [EpochNo] -> Gen [EpochNo]
forall a. [a] -> Gen [a]
sublistOf [EpochNo
0 .. Word64 -> EpochNo
EpochNo (Word64 -> EpochNo) -> Word64 -> EpochNo
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Word64
forall a. Ord a => a -> a -> a
max Word64
1 Word64
maxEpochs Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1]
  let l = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
maxEpochs
  stakeDists <- replicateM l genStakeDist
  return . PraosEvolvingStake . Map.fromList $ zip chosenEpochs stakeDists
 where
  maxEpochs :: Word64
maxEpochs = NumSlots -> Word64
unNumSlots NumSlots
numSlots Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` EpochSize -> Word64
unEpochSize EpochSize
epochSize
  relativeStake :: b -> a -> a -> (a, b)
relativeStake b
ts a
nid a
stk = (a
nid, a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
stk b -> b -> b
forall a. Fractional a => a -> a -> a
/ b
ts)
  genStakeDist :: Gen StakeDist
genStakeDist = do
    stakes <- Int -> Gen [Amount]
forall a. Arbitrary a => Int -> Gen [a]
vector (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
x) Gen [Amount] -> ([Amount] -> Bool) -> Gen [Amount]
forall a. Gen a -> (a -> Bool) -> Gen a
`suchThat` (Amount -> Bool) -> [Amount] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Amount -> Amount -> Bool
forall a. Ord a => a -> a -> Bool
> Amount
0) :: Gen [Amount]
    let totalStake = Amount -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Amount -> Rational) -> Amount -> Rational
forall a b. (a -> b) -> a -> b
$ [Amount] -> Amount
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Amount]
stakes
    return
      . StakeDist
      . Map.fromList
      $ zipWith (relativeStake totalStake) (enumCoreNodes numCoreNodes) stakes
  NumCoreNodes Word64
x = NumCoreNodes
numCoreNodes

instance Arbitrary TestSetup where
  arbitrary :: Gen TestSetup
arbitrary = do
    -- TODO k > 1 as a workaround for Issue #1511.
    k <- NonZero Word64 -> SecurityParam
SecurityParam (NonZero Word64 -> SecurityParam)
-> Gen (NonZero 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
2, Word64
10) Gen Word64
-> (Word64 -> Maybe (NonZero Word64)) -> Gen (NonZero Word64)
forall a b. Gen a -> (a -> Maybe b) -> Gen b
`suchThatMap` Word64 -> Maybe (NonZero Word64)
forall a. HasZero a => a -> Maybe (NonZero a)
nonZero
    epochSize <- EpochSize <$> choose (1, 10)
    slotLength <- arbitrary

    initialNonce <- fromIntegral <$> choose (0, maxBound :: Word64)

    testConfig <- arbitrary
    let TestConfig{numCoreNodes, numSlots} = testConfig

    nodeJoinPlan <- genNodeJoinPlan numCoreNodes numSlots
    evolvingStake <- genEvolvingStake epochSize testConfig

    pure $
      TestSetup
        epochSize
        initialNonce
        k
        nodeJoinPlan
        slotLength
        testConfig
        evolvingStake

-- TODO shrink

tests :: TestTree
tests :: TestTree
tests =
  String -> [TestTree] -> TestTree
testGroup
    String
"Praos"
    [ String -> (TestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"simple convergence" ((TestSetup -> Property) -> TestTree)
-> (TestSetup -> Property) -> TestTree
forall a b. (a -> b) -> a -> b
$ \TestSetup
setup ->
        TestSetup -> Property
prop_simple_praos_convergence TestSetup
setup
    ]

prop_simple_praos_convergence :: TestSetup -> Property
prop_simple_praos_convergence :: TestSetup -> Property
prop_simple_praos_convergence
  TestSetup
    { setupEpochSize :: TestSetup -> EpochSize
setupEpochSize = EpochSize
epochSize
    , setupK :: TestSetup -> SecurityParam
setupK = SecurityParam
k
    , Natural
setupInitialNonce :: TestSetup -> Natural
setupInitialNonce :: Natural
setupInitialNonce
    , setupNodeJoinPlan :: TestSetup -> NodeJoinPlan
setupNodeJoinPlan = NodeJoinPlan
nodeJoinPlan
    , setupSlotLength :: TestSetup -> SlotLength
setupSlotLength = SlotLength
slotLength
    , setupTestConfig :: TestSetup -> TestConfig
setupTestConfig = TestConfig
testConfig
    , setupEvolvingStake :: TestSetup -> PraosEvolvingStake
setupEvolvingStake = PraosEvolvingStake
evolvingStake
    } =
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
flakyTestCopy (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Map
  NodeId
  (NodeOutput
     (SimpleBlock'
        SimpleMockCrypto
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)))
-> String
forall b.
(GetPrevHash b, HasCreator b) =>
Map NodeId (NodeOutput b) -> String
tracesToDot Map
  NodeId
  (NodeOutput
     (SimpleBlock'
        SimpleMockCrypto
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)))
testOutputNodes) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        PropGeneralArgs
  (SimpleBlock'
     SimpleMockCrypto
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
-> TestOutput
     (SimpleBlock'
        SimpleMockCrypto
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
-> Property
forall blk.
(Condense blk, Condense (HeaderHash blk), Eq blk, RunNode blk) =>
PropGeneralArgs blk -> TestOutput blk -> Property
prop_general
          PropGeneralArgs
            { pgaBlockProperty :: SimpleBlock'
  SimpleMockCrypto
  (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
  (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
-> Property
pgaBlockProperty = SimpleBlock'
  SimpleMockCrypto
  (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
  (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
-> Property
forall c ext ext'.
(SimpleCrypto c, Typeable ext, Typeable ext') =>
SimpleBlock' c ext ext' -> Property
prop_validSimpleBlock
            , pgaCountTxs :: SimpleBlock'
  SimpleMockCrypto
  (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
  (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
-> Word64
pgaCountTxs = SimpleBlock'
  SimpleMockCrypto
  (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
  (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
-> Word64
forall c ext. SimpleBlock c ext -> Word64
countSimpleGenTxs
            , pgaExpectedCannotForge :: SlotNo
-> NodeId
-> WrapCannotForge
     (SimpleBlock'
        SimpleMockCrypto
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
-> Bool
pgaExpectedCannotForge = SlotNo
-> NodeId
-> WrapCannotForge
     (SimpleBlock'
        SimpleMockCrypto
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
-> 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
k
            , pgaTestConfig :: TestConfig
pgaTestConfig = TestConfig
testConfig
            , pgaTestConfigB :: TestConfigB
  (SimpleBlock'
     SimpleMockCrypto
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
pgaTestConfigB = TestConfigB
  (SimpleBlock'
     SimpleMockCrypto
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
testConfigB
            }
          TestOutput
  (SimpleBlock'
     SimpleMockCrypto
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
testOutput
   where
    testConfigB :: TestConfigB
  (SimpleBlock'
     SimpleMockCrypto
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
testConfigB =
      TestConfigB
        { forgeEbbEnv :: Maybe
  (ForgeEbbEnv
     (SimpleBlock'
        SimpleMockCrypto
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)))
forgeEbbEnv = Maybe
  (ForgeEbbEnv
     (SimpleBlock'
        SimpleMockCrypto
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)))
forall a. Maybe a
Nothing
        , future :: Future
future = SlotLength -> EpochSize -> Future
singleEraFuture SlotLength
slotLength EpochSize
epochSize
        , messageDelay :: CalcMessageDelay
  (SimpleBlock'
     SimpleMockCrypto
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
messageDelay = CalcMessageDelay
  (SimpleBlock'
     SimpleMockCrypto
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
forall blk. CalcMessageDelay blk
noCalcMessageDelay
        , NodeJoinPlan
nodeJoinPlan :: NodeJoinPlan
nodeJoinPlan :: NodeJoinPlan
nodeJoinPlan
        , nodeRestarts :: NodeRestarts
nodeRestarts = NodeRestarts
noRestarts
        , txGenExtra :: TxGenExtra
  (SimpleBlock'
     SimpleMockCrypto
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
txGenExtra = ()
        , version :: (NodeToNodeVersion,
 BlockNodeToNodeVersion
   (SimpleBlock'
      SimpleMockCrypto
      (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
      (SimplePraosExt SimpleMockCrypto PraosMockCrypto)))
version = Proxy
  (SimpleBlock'
     SimpleMockCrypto
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
-> (NodeToNodeVersion,
    BlockNodeToNodeVersion
      (SimpleBlock'
         SimpleMockCrypto
         (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
         (SimplePraosExt SimpleMockCrypto PraosMockCrypto)))
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> (NodeToNodeVersion, BlockNodeToNodeVersion blk)
newestVersion (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @MockPraosBlock)
        }

    params :: PraosParams
params =
      PraosParams
        { praosSecurityParam :: SecurityParam
praosSecurityParam = SecurityParam
k
        , praosSlotsPerEpoch :: Word64
praosSlotsPerEpoch = EpochSize -> Word64
unEpochSize EpochSize
epochSize
        , praosLeaderF :: Double
praosLeaderF = Double
0.5
        }

    TestConfig{NumCoreNodes
numCoreNodes :: TestConfig -> NumCoreNodes
numCoreNodes :: NumCoreNodes
numCoreNodes} = TestConfig
testConfig

    testOutput :: TestOutput
  (SimpleBlock'
     SimpleMockCrypto
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
testOutput@TestOutput{Map
  NodeId
  (NodeOutput
     (SimpleBlock'
        SimpleMockCrypto
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)))
testOutputNodes :: Map
  NodeId
  (NodeOutput
     (SimpleBlock'
        SimpleMockCrypto
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)))
testOutputNodes :: forall blk. TestOutput blk -> Map NodeId (NodeOutput blk)
testOutputNodes} =
      TestConfig
-> TestConfigB
     (SimpleBlock'
        SimpleMockCrypto
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
-> (forall (m :: * -> *).
    IOLike m =>
    TestConfigMB
      m
      (SimpleBlock'
         SimpleMockCrypto
         (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
         (SimplePraosExt SimpleMockCrypto PraosMockCrypto)))
-> TestOutput
     (SimpleBlock'
        SimpleMockCrypto
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
forall blk.
(RunNode blk, TxGen blk, TracingConstraints blk, HasCallStack) =>
TestConfig
-> TestConfigB blk
-> (forall (m :: * -> *). IOLike m => TestConfigMB m blk)
-> TestOutput blk
runTestNetwork
        TestConfig
testConfig
        TestConfigB
  (SimpleBlock'
     SimpleMockCrypto
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
testConfigB
        TestConfigMB
          { nodeInfo :: CoreNodeId
-> TestNodeInitialization
     m
     (SimpleBlock'
        SimpleMockCrypto
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
nodeInfo = \CoreNodeId
nid ->
              ProtocolInfo
  (SimpleBlock'
     SimpleMockCrypto
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
     (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
-> m [BlockForging
        m
        (SimpleBlock'
           SimpleMockCrypto
           (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
           (SimplePraosExt SimpleMockCrypto PraosMockCrypto))]
-> TestNodeInitialization
     m
     (SimpleBlock'
        SimpleMockCrypto
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
forall blk (m :: * -> *).
ProtocolInfo blk
-> m [BlockForging m blk] -> TestNodeInitialization m blk
plainTestNodeInitialization
                ( NumCoreNodes
-> CoreNodeId
-> PraosParams
-> EraParams
-> Natural
-> PraosEvolvingStake
-> ProtocolInfo
     (SimpleBlock'
        SimpleMockCrypto
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
        (SimplePraosExt SimpleMockCrypto PraosMockCrypto))
protocolInfoPraos
                    NumCoreNodes
numCoreNodes
                    CoreNodeId
nid
                    PraosParams
params
                    ( SecurityParam -> SlotLength -> EraParams
HardFork.defaultEraParams
                        SecurityParam
k
                        SlotLength
slotLength
                    )
                    Natural
setupInitialNonce
                    PraosEvolvingStake
evolvingStake
                )
                (NumCoreNodes
-> CoreNodeId
-> m [BlockForging
        m
        (SimpleBlock'
           SimpleMockCrypto
           (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
           (SimplePraosExt SimpleMockCrypto PraosMockCrypto))]
forall (m :: * -> *).
IOLike m =>
NumCoreNodes
-> CoreNodeId
-> m [BlockForging
        m
        (SimpleBlock'
           SimpleMockCrypto
           (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
           (SimplePraosExt SimpleMockCrypto PraosMockCrypto))]
blockForgingPraos NumCoreNodes
numCoreNodes CoreNodeId
nid)
          , mkRekeyM :: Maybe
  (m (RekeyM
        m
        (SimpleBlock'
           SimpleMockCrypto
           (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
           (SimplePraosExt SimpleMockCrypto PraosMockCrypto))))
mkRekeyM = Maybe
  (m (RekeyM
        m
        (SimpleBlock'
           SimpleMockCrypto
           (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
           (SimplePraosExt SimpleMockCrypto PraosMockCrypto))))
forall a. Maybe a
Nothing
          }

    flakyTestCopy :: String
flakyTestCopy =
      String
"This test may be flaky, and its failure may not be indicative of an actual problem: see https://github.com/IntersectMBO/ouroboros-consensus/issues/1105"