WIP: CSJ happy path test

ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal

@@ -219,6 +219,7 @@ test-suite consensus-test
     Test.Consensus.Genesis.Setup.Classifiers
     Test.Consensus.Genesis.Setup.GenChains
     Test.Consensus.Genesis.Tests
+    Test.Consensus.Genesis.Tests.CSJ
     Test.Consensus.Genesis.Tests.DensityDisconnect
     Test.Consensus.Genesis.Tests.LoE
     Test.Consensus.Genesis.Tests.LongRangeAttack

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests.hs

@@ -1,5 +1,6 @@
 module Test.Consensus.Genesis.Tests (tests) where
 
+import qualified Test.Consensus.Genesis.Tests.CSJ as CSJ
 import qualified Test.Consensus.Genesis.Tests.DensityDisconnect as GDD
 import qualified Test.Consensus.Genesis.Tests.LoE as LoE
 import qualified Test.Consensus.Genesis.Tests.LongRangeAttack as LongRangeAttack
@@ -9,7 +10,8 @@ import           Test.Tasty
 
 tests :: TestTree
 tests = testGroup "Genesis tests"
-    [ GDD.tests
+    [ CSJ.tests
+    , GDD.tests
     , LongRangeAttack.tests
     , LoE.tests
     , LoP.tests

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/CSJ.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE NamedFieldPuns        #-}
+
+module Test.Consensus.Genesis.Tests.CSJ (tests) where
+
+import           Control.Monad (replicateM)
+import           Data.Functor (($>))
+import           Test.Consensus.Genesis.Setup
+import           Test.Consensus.Genesis.Tests.Uniform (genUniformSchedulePoints)
+import           Test.Consensus.PeerSimulator.Run (SchedulerConfig (..),
+                     defaultSchedulerConfig)
+import           Test.Consensus.PeerSimulator.StateView
+import           Test.Consensus.PointSchedule
+import           Test.Consensus.PointSchedule.Peers (Peers (..), Peer(..), mkPeers)
+import           Test.Consensus.PointSchedule.Shrinking (shrinkPeerSchedules)
+import           Test.Tasty
+import           Test.Tasty.QuickCheck
+import           Test.Util.Orphans.IOLike ()
+import           Test.Util.TestBlock (TestBlock)
+
+tests :: TestTree
+tests =
+  testGroup
+    "CSJ"
+    [ testProperty "\"Happy Path\" synchronous scenario only speaks to one peer" $ prop_happyPath True
+    , testProperty "\"Happy Path\" asynchronous scenario only speaks to one peer" $ prop_happyPath False
+    ]
+
+prop_happyPath :: Bool -> Property
+prop_happyPath synchronized =
+  forAllGenesisTest
+    ( do
+        gt <- genChains $ pure 0
+        honest <- genHonestSchedule gt
+        numOthers <- choose (0, 3)
+        otherHonests <- if synchronized
+          then pure $ replicate numOthers honest
+          else replicateM numOthers (genHonestSchedule gt)
+        pure $ gt $> mkPeers honest otherHonests
+    )
+    ( defaultSchedulerConfig
+      { scEnableCSJ = True
+      , scEnableLoE = True
+      , scEnableLoP = True
+      }
+    )
+    shrinkPeerSchedules
+    ( \_ stateView -> (undefined :: Bool) -- do magic
+    )
+  where
+    -- | This might seem wasteful, as we discard generated adversarial schedules.
+    -- It actually isn't, since we call it on trees that have no branches besides
+    -- the trunk, so no adversaries are generated.
+    genHonestSchedule :: GenesisTest TestBlock () -> Gen (PeerSchedule TestBlock)
+    genHonestSchedule gt = do
+      ps <- genUniformSchedulePoints gt
+      pure $ value $ honest ps
+

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs

@@ -11,7 +11,10 @@
 -- block tree with the right age (roughly @k@ blocks from the tip). Contrary to
 -- other tests cases (eg. long range attack), the schedules are not particularly
 -- biased towards a specific situation.
-module Test.Consensus.Genesis.Tests.Uniform (tests) where
+module Test.Consensus.Genesis.Tests.Uniform
+  ( genUniformSchedulePoints
+  , tests
+  ) where
 
 import           Cardano.Slotting.Slot (SlotNo (SlotNo), WithOrigin (..))
 import           Control.Monad (replicateM)

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/StateView.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE LambdaCase           #-}
 {-# LANGUAGE NamedFieldPuns       #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Test.Consensus.PeerSimulator.StateView (

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs

@@ -343,6 +343,8 @@ traceChainSyncClientEventTestBlockWith pid tracer = \case
       trace "Waiting for next instruction from the jumping governor"
     TraceJumpingInstructionIs instr ->
       trace $ "Received instruction: " ++ show instr
+    TraceJumpingState tag ->
+      trace $ "Changed jumping state: " ++ show tag
   where
     trace = traceUnitWith tracer ("ChainSyncClient " ++ condense pid)
 

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs

@@ -2130,6 +2130,9 @@ data TraceChainSyncClientEvent blk =
   |
     TraceJumpingInstructionIs (Jumping.Instruction blk)
     -- ^ ChainSync Jumping -- the ChainSync client got its next instruction.
+  |
+    TraceJumpingState (ChainSyncJumpingTag blk)
+    -- ^ ChainSync Jumping -- the ChainSync client changes its jumping state
 
 deriving instance
   ( BlockSupportsProtocol blk

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client/State.hs

@@ -9,13 +9,15 @@ module Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State (
     ChainSyncClientHandle (..)
   , ChainSyncJumpingJumperState (..)
   , ChainSyncJumpingState (..)
+  , ChainSyncJumpingTag (..)
   , ChainSyncState (..)
   , Restart (..)
+  , toTag
   ) where
 
 import           Cardano.Slotting.Slot (SlotNo, WithOrigin)
 import           GHC.Generics (Generic)
-import           Ouroboros.Consensus.Block (HasHeader, Header, Point)
+import           Ouroboros.Consensus.Block (BlockSupportsProtocol, HasHeader, Header, Point)
 import           Ouroboros.Consensus.Util.IOLike (IOLike, NoThunks, StrictTVar)
 import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
 
@@ -141,3 +143,45 @@ data ChainSyncJumpingJumperState blk
   deriving (Generic)
 
 deriving anyclass instance (HasHeader blk, NoThunks (Header blk)) => NoThunks (ChainSyncJumpingJumperState blk)
+
+deriving instance
+  ( BlockSupportsProtocol blk
+  , Eq (Header blk)
+  )
+  => Eq (ChainSyncJumpingJumperState blk)
+
+deriving instance
+  ( BlockSupportsProtocol blk
+  , Show (Header blk)
+  )
+  => Show (ChainSyncJumpingJumperState blk)
+
+-- | A version of `ChainSyncJumpingState` without TVars, for tracing purposes
+data ChainSyncJumpingTag blk
+  = TagDynamo
+      !(WithOrigin SlotNo)
+  | TagObjector
+      !(Point (Header blk))
+  | TagDisengaged
+  | TagJumper
+      !(Point (Header blk))
+      !(ChainSyncJumpingJumperState blk)
+  deriving (Generic)
+
+deriving instance
+  ( BlockSupportsProtocol blk
+  , Eq (Header blk)
+  )
+  => Eq (ChainSyncJumpingTag blk)
+
+deriving instance
+  ( BlockSupportsProtocol blk
+  , Show (Header blk)
+  )
+  => Show (ChainSyncJumpingTag blk)
+
+toTag :: ChainSyncJumpingState m blk -> ChainSyncJumpingTag blk
+toTag (Dynamo s)     = TagDynamo s
+toTag (Objector p)   = TagObjector p
+toTag (Disengaged)   = TagDisengaged
+toTag (Jumper _ p s) = TagJumper p s