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

module Test.ThreadNet.LeaderSchedule (tests) where

import Cardano.Ledger.BaseTypes (nonZero)
import Control.Monad (replicateM)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
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.PraosRule
import Ouroboros.Consensus.Mock.Protocol.LeaderSchedule
import Ouroboros.Consensus.Mock.Protocol.Praos
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.NodeId
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 (..))

data TestSetup = TestSetup
  { TestSetup -> SecurityParam
setupK :: SecurityParam
  , TestSetup -> TestConfig
setupTestConfig :: TestConfig
  , TestSetup -> EpochSize
setupEpochSize :: EpochSize
  -- ^ Note: we don't think this value actually matters, since this test
  -- overrides the leader schedule.
  , TestSetup -> NodeJoinPlan
setupNodeJoinPlan :: NodeJoinPlan
  , TestSetup -> LeaderSchedule
setupLeaderSchedule :: LeaderSchedule
  , TestSetup -> SlotLength
setupSlotLength :: SlotLength
  }
  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

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

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

    nodeJoinPlan <- genNodeJoinPlan numCoreNodes numSlots
    leaderSchedule <- genLeaderSchedule k numSlots numCoreNodes nodeJoinPlan

    pure $
      TestSetup
        k
        testConfig
        epochSize
        nodeJoinPlan
        leaderSchedule
        slotLength

-- TODO shrink

tests :: TestTree
tests :: TestTree
tests =
  String -> [TestTree] -> TestTree
testGroup
    String
"LeaderSchedule"
    [ 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_leader_schedule_convergence TestSetup
setup
    ]

prop_simple_leader_schedule_convergence :: TestSetup -> Property
prop_simple_leader_schedule_convergence :: TestSetup -> Property
prop_simple_leader_schedule_convergence
  TestSetup
    { setupK :: TestSetup -> SecurityParam
setupK = SecurityParam
k
    , setupTestConfig :: TestSetup -> TestConfig
setupTestConfig = TestConfig
testConfig
    , setupEpochSize :: TestSetup -> EpochSize
setupEpochSize = EpochSize
epochSize
    , setupNodeJoinPlan :: TestSetup -> NodeJoinPlan
setupNodeJoinPlan = NodeJoinPlan
nodeJoinPlan
    , setupLeaderSchedule :: TestSetup -> LeaderSchedule
setupLeaderSchedule = LeaderSchedule
schedule
    , setupSlotLength :: TestSetup -> SlotLength
setupSlotLength = SlotLength
slotLength
    } =
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (Map
  NodeId
  (NodeOutput
     (SimpleBlock'
        SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt))
-> String
forall b.
(GetPrevHash b, HasCreator b) =>
Map NodeId (NodeOutput b) -> String
tracesToDot Map
  NodeId
  (NodeOutput
     (SimpleBlock'
        SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt))
testOutputNodes) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
      PropGeneralArgs
  (SimpleBlock'
     SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
-> TestOutput
     (SimpleBlock'
        SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
-> Property
forall blk.
(Condense blk, Condense (HeaderHash blk), Eq blk, RunNode blk) =>
PropGeneralArgs blk -> TestOutput blk -> Property
prop_general
        PropGeneralArgs
          { pgaBlockProperty :: SimpleBlock' SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt
-> Property
pgaBlockProperty = SimpleBlock' SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt
-> Property
forall c ext ext'.
(SimpleCrypto c, Typeable ext, Typeable ext') =>
SimpleBlock' c ext ext' -> Property
prop_validSimpleBlock
          , pgaCountTxs :: SimpleBlock' SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt
-> Word64
pgaCountTxs = SimpleBlock' SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt
-> Word64
forall c ext. SimpleBlock c ext -> Word64
countSimpleGenTxs
          , pgaExpectedCannotForge :: SlotNo
-> NodeId
-> WrapCannotForge
     (SimpleBlock'
        SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
-> Bool
pgaExpectedCannotForge = SlotNo
-> NodeId
-> WrapCannotForge
     (SimpleBlock'
        SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
-> 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 = LeaderSchedule -> Maybe LeaderSchedule
forall a. a -> Maybe a
Just LeaderSchedule
schedule
          , pgaSecurityParam :: SecurityParam
pgaSecurityParam = SecurityParam
k
          , pgaTestConfig :: TestConfig
pgaTestConfig = TestConfig
testConfig
          , pgaTestConfigB :: TestConfigB
  (SimpleBlock'
     SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
pgaTestConfigB = TestConfigB
  (SimpleBlock'
     SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
testConfigB
          }
        TestOutput
  (SimpleBlock'
     SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
testOutput
   where
    TestConfig{NumCoreNodes
numCoreNodes :: TestConfig -> NumCoreNodes
numCoreNodes :: NumCoreNodes
numCoreNodes} = TestConfig
testConfig

    testConfigB :: TestConfigB
  (SimpleBlock'
     SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
testConfigB =
      TestConfigB
        { forgeEbbEnv :: Maybe
  (ForgeEbbEnv
     (SimpleBlock'
        SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt))
forgeEbbEnv = Maybe
  (ForgeEbbEnv
     (SimpleBlock'
        SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt))
forall a. Maybe a
Nothing
        , future :: Future
future = SlotLength -> EpochSize -> Future
singleEraFuture SlotLength
slotLength EpochSize
epochSize
        , messageDelay :: CalcMessageDelay
  (SimpleBlock'
     SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
messageDelay = CalcMessageDelay
  (SimpleBlock'
     SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
forall blk. CalcMessageDelay blk
noCalcMessageDelay
        , NodeJoinPlan
nodeJoinPlan :: NodeJoinPlan
nodeJoinPlan :: NodeJoinPlan
nodeJoinPlan
        , nodeRestarts :: NodeRestarts
nodeRestarts = NodeRestarts
noRestarts
        , txGenExtra :: TxGenExtra
  (SimpleBlock'
     SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
txGenExtra = ()
        , version :: (NodeToNodeVersion,
 BlockNodeToNodeVersion
   (SimpleBlock'
      SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt))
version = Proxy
  (SimpleBlock'
     SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
-> (NodeToNodeVersion,
    BlockNodeToNodeVersion
      (SimpleBlock'
         SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt))
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> (NodeToNodeVersion, BlockNodeToNodeVersion blk)
newestVersion (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @MockPraosRuleBlock)
        }

    -- this is entirely ignored because of the 'WithLeaderSchedule' combinator
    dummyF :: Double
dummyF = Double
0.5

    testOutput :: TestOutput
  (SimpleBlock'
     SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
testOutput@TestOutput{Map
  NodeId
  (NodeOutput
     (SimpleBlock'
        SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt))
testOutputNodes :: Map
  NodeId
  (NodeOutput
     (SimpleBlock'
        SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt))
testOutputNodes :: forall blk. TestOutput blk -> Map NodeId (NodeOutput blk)
testOutputNodes} =
      TestConfig
-> TestConfigB
     (SimpleBlock'
        SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
-> (forall (m :: * -> *).
    IOLike m =>
    TestConfigMB
      m
      (SimpleBlock'
         SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt))
-> TestOutput
     (SimpleBlock'
        SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
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 SimplePraosRuleExt SimplePraosRuleExt)
testConfigB
        TestConfigMB
          { nodeInfo :: CoreNodeId
-> TestNodeInitialization
     m
     (SimpleBlock'
        SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
nodeInfo = \CoreNodeId
nid ->
              ProtocolInfo
  (SimpleBlock'
     SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
-> m [BlockForging
        m
        (SimpleBlock'
           SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)]
-> TestNodeInitialization
     m
     (SimpleBlock'
        SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
forall blk (m :: * -> *).
ProtocolInfo blk
-> m [BlockForging m blk] -> TestNodeInitialization m blk
plainTestNodeInitialization
                ( NumCoreNodes
-> CoreNodeId
-> PraosParams
-> EraParams
-> LeaderSchedule
-> PraosEvolvingStake
-> ProtocolInfo
     (SimpleBlock'
        SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)
protocolInfoPraosRule
                    NumCoreNodes
numCoreNodes
                    CoreNodeId
nid
                    PraosParams
                      { praosSecurityParam :: SecurityParam
praosSecurityParam = SecurityParam
k
                      , praosSlotsPerEpoch :: Word64
praosSlotsPerEpoch = EpochSize -> Word64
unEpochSize EpochSize
epochSize
                      , praosLeaderF :: Double
praosLeaderF = Double
dummyF
                      }
                    (SecurityParam -> SlotLength -> EraParams
HardFork.defaultEraParams SecurityParam
k SlotLength
slotLength)
                    LeaderSchedule
schedule
                    PraosEvolvingStake
emptyPraosEvolvingStake
                )
                ([BlockForging
   m
   (SimpleBlock'
      SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)]
-> m [BlockForging
        m
        (SimpleBlock'
           SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [BlockForging
   m
   (SimpleBlock'
      SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)]
forall (m :: * -> *).
Monad m =>
[BlockForging
   m
   (SimpleBlock'
      SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)]
blockForgingPraosRule)
          , mkRekeyM :: Maybe
  (m (RekeyM
        m
        (SimpleBlock'
           SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)))
mkRekeyM = Maybe
  (m (RekeyM
        m
        (SimpleBlock'
           SimpleMockCrypto SimplePraosRuleExt SimplePraosRuleExt)))
forall a. Maybe a
Nothing
          }

{-------------------------------------------------------------------------------
  Dependent generation and shrinking of leader schedules
-------------------------------------------------------------------------------}

genLeaderSchedule ::
  SecurityParam ->
  NumSlots ->
  NumCoreNodes ->
  NodeJoinPlan ->
  Gen LeaderSchedule
genLeaderSchedule :: SecurityParam
-> NumSlots -> NumCoreNodes -> NodeJoinPlan -> Gen LeaderSchedule
genLeaderSchedule SecurityParam
k (NumSlots Word64
numSlots) NumCoreNodes
numCoreNodes NodeJoinPlan
nodeJoinPlan =
  (Gen LeaderSchedule
 -> (LeaderSchedule -> Bool) -> Gen LeaderSchedule)
-> (LeaderSchedule -> Bool)
-> Gen LeaderSchedule
-> Gen LeaderSchedule
forall a b c. (a -> b -> c) -> b -> a -> c
flip Gen LeaderSchedule
-> (LeaderSchedule -> Bool) -> Gen LeaderSchedule
forall a. Gen a -> (a -> Bool) -> Gen a
suchThat (SecurityParam -> NodeJoinPlan -> LeaderSchedule -> Bool
consensusExpected SecurityParam
k NodeJoinPlan
nodeJoinPlan) (Gen LeaderSchedule -> Gen LeaderSchedule)
-> Gen LeaderSchedule -> Gen LeaderSchedule
forall a b. (a -> b) -> a -> b
$ do
    leaders <-
      Int -> Gen [CoreNodeId] -> Gen [[CoreNodeId]]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
numSlots) (Gen [CoreNodeId] -> Gen [[CoreNodeId]])
-> Gen [CoreNodeId] -> Gen [[CoreNodeId]]
forall a b. (a -> b) -> a -> b
$
        [(Int, Gen [CoreNodeId])] -> Gen [CoreNodeId]
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
          [ (Int
4, Int -> Gen [CoreNodeId]
pick Int
0)
          , (Int
2, Int -> Gen [CoreNodeId]
pick Int
1)
          , (Int
1, Int -> Gen [CoreNodeId]
pick Int
2)
          , (Int
1, Int -> Gen [CoreNodeId]
pick Int
3)
          ]
    return $ LeaderSchedule $ Map.fromList $ zip [0 ..] leaders
 where
  pick :: Int -> Gen [CoreNodeId]
  pick :: Int -> Gen [CoreNodeId]
pick = [CoreNodeId] -> Int -> Gen [CoreNodeId]
go (NumCoreNodes -> [CoreNodeId]
enumCoreNodes NumCoreNodes
numCoreNodes)
   where
    go :: [CoreNodeId] -> Int -> Gen [CoreNodeId]
    go :: [CoreNodeId] -> Int -> Gen [CoreNodeId]
go [] Int
_ = [CoreNodeId] -> Gen [CoreNodeId]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    go [CoreNodeId]
_ Int
0 = [CoreNodeId] -> Gen [CoreNodeId]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    go [CoreNodeId]
nids Int
n = do
      nid <- [CoreNodeId] -> Gen CoreNodeId
forall a. HasCallStack => [a] -> Gen a
elements [CoreNodeId]
nids
      xs <- go (filter (/= nid) nids) (n - 1)
      return $ nid : xs

_shrinkLeaderSchedule :: NumSlots -> LeaderSchedule -> [LeaderSchedule]
_shrinkLeaderSchedule :: NumSlots -> LeaderSchedule -> [LeaderSchedule]
_shrinkLeaderSchedule (NumSlots Word64
numSlots) (LeaderSchedule Map SlotNo [CoreNodeId]
m) =
  [ Map SlotNo [CoreNodeId] -> LeaderSchedule
LeaderSchedule Map SlotNo [CoreNodeId]
m'
  | SlotNo
slot <- [SlotNo
0 .. Word64 -> SlotNo
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
numSlots SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
- SlotNo
1]
  , Map SlotNo [CoreNodeId]
m' <- SlotNo -> Map SlotNo [CoreNodeId] -> [Map SlotNo [CoreNodeId]]
reduceSlot SlotNo
slot Map SlotNo [CoreNodeId]
m
  ]
 where
  reduceSlot :: SlotNo -> Map SlotNo [CoreNodeId] -> [Map SlotNo [CoreNodeId]]
  reduceSlot :: SlotNo -> Map SlotNo [CoreNodeId] -> [Map SlotNo [CoreNodeId]]
reduceSlot SlotNo
s Map SlotNo [CoreNodeId]
m' = [SlotNo
-> [CoreNodeId]
-> Map SlotNo [CoreNodeId]
-> Map SlotNo [CoreNodeId]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert SlotNo
s [CoreNodeId]
xs Map SlotNo [CoreNodeId]
m' | [CoreNodeId]
xs <- [CoreNodeId] -> [[CoreNodeId]]
forall a. [a] -> [[a]]
reduceList ([CoreNodeId] -> [[CoreNodeId]]) -> [CoreNodeId] -> [[CoreNodeId]]
forall a b. (a -> b) -> a -> b
$ Map SlotNo [CoreNodeId]
m' Map SlotNo [CoreNodeId] -> SlotNo -> [CoreNodeId]
forall k a. Ord k => Map k a -> k -> a
Map.! SlotNo
s]

  reduceList :: [a] -> [[a]]
  reduceList :: forall a. [a] -> [[a]]
reduceList [] = []
  reduceList [a
_] = []
  reduceList (a
x : [a]
xs) = [a]
xs [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: ([a] -> [a]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> [a] -> [b]
map (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [[a]]
forall a. [a] -> [[a]]
reduceList [a]
xs)