{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}

-- | A test for the consensus-specific parts of the BlockFetch client.
--
-- When adding a block to the ChainDB, we allocate potential punishments, which
-- are later invoked after block validation, crucially allowing us to kill the
-- BlockFetch client and hence disconnect from malicious peers.
--
-- This test spins up several BlockFetch clients, which download randomly
-- generated chains and add them to the ChainDB, which will enact these
-- punishments on validation. Right now, we only ensure that doing so for chains
-- originating from honest behavior do not cause any disconnects, but we plan to
-- also model malicious/erroneous behavior.
module Test.Consensus.MiniProtocol.BlockFetch.Client (tests) where

import           Cardano.Ledger.BaseTypes (knownNonZeroBounded)
import           Control.Monad (replicateM)
import           Control.Monad.Class.MonadTime
import           Control.Monad.Class.MonadTimer.SI (MonadTimer)
import           Control.Monad.IOSim (runSimOrThrow)
import           Control.ResourceRegistry
import           Control.Tracer (Tracer (..), nullTracer, traceWith)
import           Data.Bifunctor (first)
import           Data.Hashable (Hashable)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Traversable (for)
import           Network.TypedProtocol.Channel (createConnectedChannels)
import           Network.TypedProtocol.Codec (AnyMessage (..))
import           Network.TypedProtocol.Core (PeerRole (..))
import qualified Network.TypedProtocol.Driver.Simple as Driver
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime)
import qualified Ouroboros.Consensus.MiniProtocol.BlockFetch.ClientInterface as BlockFetchClientInterface
import           Ouroboros.Consensus.Node.ProtocolInfo (NumCoreNodes (..))
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDBImpl
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB
import           Ouroboros.Consensus.Util.Condense (Condense (..))
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.STM (blockUntilJust,
                     forkLinkedWatcher)
import           Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.BlockFetch (BlockFetchConfiguration (..),
                     BlockFetchConsensusInterface (..), FetchMode (..),
                     GenesisBlockFetchConfiguration (..), blockFetchLogic,
                     bracketFetchClient, bracketKeepAliveClient,
                     bracketSyncWithFetchClient, newFetchClientRegistry)
import           Ouroboros.Network.BlockFetch.Client (blockFetchClient)
import           Ouroboros.Network.BlockFetch.ConsensusInterface
                     (PraosFetchMode (..))
import           Ouroboros.Network.ControlMessage (ControlMessage (..))
import           Ouroboros.Network.Mock.Chain (Chain)
import qualified Ouroboros.Network.Mock.Chain as Chain
import           Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion)
import           Ouroboros.Network.Protocol.BlockFetch.Codec (codecBlockFetchId)
import           Ouroboros.Network.Protocol.BlockFetch.Server
                     (BlockFetchBlockSender (SendMsgNoBlocks, SendMsgStartBatch),
                     BlockFetchSendBlocks (SendMsgBatchDone, SendMsgBlock),
                     BlockFetchServer (..), blockFetchServerPeer)
import           Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch,
                     ChainRange (..), Message (MsgBlock))
import           Test.QuickCheck
import           Test.Tasty
import           Test.Tasty.QuickCheck
import           Test.Util.ChainDB
import           Test.Util.ChainUpdates
import           Test.Util.Header (attachSlotTime)
import qualified Test.Util.LogicalClock as LogicalClock
import           Test.Util.LogicalClock (Tick (..))
import           Test.Util.Orphans.IOLike ()
import           Test.Util.Schedule
import           Test.Util.TestBlock
import           Test.Util.Tracer (recordingTracerTVar)

tests :: TestTree
tests :: TestTree
tests = String -> [TestTree] -> TestTree
testGroup String
"BlockFetchClient"
    [ String -> (BlockFetchClientTestSetup -> Property) -> TestTree
forall a. Testable a => String -> a -> TestTree
testProperty String
"blockFetch" BlockFetchClientTestSetup -> Property
prop_blockFetch
    ]

prop_blockFetch :: BlockFetchClientTestSetup -> Property
prop_blockFetch :: BlockFetchClientTestSetup -> Property
prop_blockFetch bfcts :: BlockFetchClientTestSetup
bfcts@BlockFetchClientTestSetup{Map PeerId (Schedule ChainUpdate)
DiffusionPipeliningSupport
FetchMode
BlockFetchConfiguration
peerUpdates :: Map PeerId (Schedule ChainUpdate)
blockFetchMode :: FetchMode
blockFetchCfg :: BlockFetchConfiguration
blockFetchPipelining :: DiffusionPipeliningSupport
blockFetchPipelining :: BlockFetchClientTestSetup -> DiffusionPipeliningSupport
blockFetchCfg :: BlockFetchClientTestSetup -> BlockFetchConfiguration
blockFetchMode :: BlockFetchClientTestSetup -> FetchMode
peerUpdates :: BlockFetchClientTestSetup -> Map PeerId (Schedule ChainUpdate)
..} =
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Trace:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unlines ((Tick, String) -> String
ppTrace ((Tick, String) -> String) -> [(Tick, String)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Tick, String)]
bfcoTrace)) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (BlockFetchClientTestSetup -> String
forall a. Condense a => a -> String
condense BlockFetchClientTestSetup
bfcts) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin ([Property] -> Property) -> [Property] -> Property
forall a b. (a -> b) -> a -> b
$
      [ String -> Either SomeException () -> Property
forall {e}. Exception e => String -> Either e () -> Property
noException (String
"BlockFetch client " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PeerId -> String
forall a. Condense a => a -> String
condense PeerId
peerId) Either SomeException ()
res
      | (PeerId
peerId, Either SomeException ()
res) <- Map PeerId (Either SomeException ())
-> [(PeerId, Either SomeException ())]
forall k a. Map k a -> [(k, a)]
Map.toList Map PeerId (Either SomeException ())
bfcoBlockFetchResults
      ] [Property] -> [Property] -> [Property]
forall a. Semigroup a => a -> a -> a
<>
      [ Map PeerId (Either SomeException ()) -> Set PeerId
forall k a. Map k a -> Set k
Map.keysSet Map PeerId (Either SomeException ())
bfcoBlockFetchResults Set PeerId -> Set PeerId -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Map PeerId (Schedule ChainUpdate) -> Set PeerId
forall k a. Map k a -> Set k
Map.keysSet Map PeerId (Schedule ChainUpdate)
peerUpdates
      , String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Fetched blocks per peer: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Map PeerId Word -> String
forall a. Condense a => a -> String
condense Map PeerId Word
bfcoFetchedBlocks) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
        Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ case FetchMode
blockFetchMode of
          PraosFetchMode PraosFetchMode
FetchModeDeadline -> (Word -> Bool) -> Map PeerId Word -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
0) Map PeerId Word
bfcoFetchedBlocks
          PraosFetchMode PraosFetchMode
FetchModeBulkSync -> (Word -> Bool) -> Map PeerId Word -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
0) Map PeerId Word
bfcoFetchedBlocks
          FetchMode
FetchModeGenesis                 -> (Word -> Bool) -> Map PeerId Word -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
> Word
0) Map PeerId Word
bfcoFetchedBlocks
      ]
  where
    BlockFetchClientOutcome{[(Tick, String)]
Map PeerId Word
Map PeerId (Either SomeException ())
bfcoTrace :: [(Tick, String)]
bfcoBlockFetchResults :: Map PeerId (Either SomeException ())
bfcoFetchedBlocks :: Map PeerId Word
bfcoTrace :: BlockFetchClientOutcome -> [(Tick, String)]
bfcoFetchedBlocks :: BlockFetchClientOutcome -> Map PeerId Word
bfcoBlockFetchResults :: BlockFetchClientOutcome -> Map PeerId (Either SomeException ())
..} = (forall s. IOSim s BlockFetchClientOutcome)
-> BlockFetchClientOutcome
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s BlockFetchClientOutcome)
 -> BlockFetchClientOutcome)
-> (forall s. IOSim s BlockFetchClientOutcome)
-> BlockFetchClientOutcome
forall a b. (a -> b) -> a -> b
$ BlockFetchClientTestSetup -> IOSim s BlockFetchClientOutcome
forall (m :: * -> *).
(IOLike m, MonadTime m, MonadTimer m) =>
BlockFetchClientTestSetup -> m BlockFetchClientOutcome
runBlockFetchTest BlockFetchClientTestSetup
bfcts

    noException :: String -> Either e () -> Property
noException String
msg = \case
      Right () -> () -> Property
forall prop. Testable prop => prop -> Property
property ()
      Left e
ex  ->
        String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
msg String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": exception: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> e -> String
forall e. Exception e => e -> String
displayException e
ex) Bool
False

    ppTrace :: (Tick, String) -> String
ppTrace (Tick Word64
tick, String
ev) = Word64 -> String
forall a. Show a => a -> String
show Word64
tick String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
ev

{-------------------------------------------------------------------------------
  Running a test involving the consensus BlockFetch interface
-------------------------------------------------------------------------------}

data BlockFetchClientOutcome = BlockFetchClientOutcome {
    BlockFetchClientOutcome -> Map PeerId (Either SomeException ())
bfcoBlockFetchResults :: Map PeerId (Either SomeException ())
  , BlockFetchClientOutcome -> Map PeerId Word
bfcoFetchedBlocks     :: Map PeerId Word
  , BlockFetchClientOutcome -> [(Tick, String)]
bfcoTrace             :: [(Tick, String)]
  }

runBlockFetchTest ::
     forall m.
     (IOLike m, MonadTime m, MonadTimer m)
  => BlockFetchClientTestSetup
  -> m BlockFetchClientOutcome
runBlockFetchTest :: forall (m :: * -> *).
(IOLike m, MonadTime m, MonadTimer m) =>
BlockFetchClientTestSetup -> m BlockFetchClientOutcome
runBlockFetchTest BlockFetchClientTestSetup{Map PeerId (Schedule ChainUpdate)
DiffusionPipeliningSupport
FetchMode
BlockFetchConfiguration
blockFetchPipelining :: BlockFetchClientTestSetup -> DiffusionPipeliningSupport
blockFetchCfg :: BlockFetchClientTestSetup -> BlockFetchConfiguration
blockFetchMode :: BlockFetchClientTestSetup -> FetchMode
peerUpdates :: BlockFetchClientTestSetup -> Map PeerId (Schedule ChainUpdate)
peerUpdates :: Map PeerId (Schedule ChainUpdate)
blockFetchMode :: FetchMode
blockFetchCfg :: BlockFetchConfiguration
blockFetchPipelining :: DiffusionPipeliningSupport
..} = (ResourceRegistry m -> m BlockFetchClientOutcome)
-> m BlockFetchClientOutcome
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry \ResourceRegistry m
registry -> do
    varChains           <- Map PeerId (Chain TestBlock)
-> m (StrictTVar m (Map PeerId (Chain TestBlock)))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM Map PeerId (Chain TestBlock)
forall k a. Map k a
Map.empty
    varControlMessage   <- uncheckedNewTVarM Continue
    varFetchedBlocks    <- uncheckedNewTVarM (0 <$ peerUpdates)

    fetchClientRegistry <- newFetchClientRegistry
    clock               <- LogicalClock.new registry $
      LogicalClock.sufficientTimeFor $ lastTick <$> Map.elems peerUpdates
    (tracer, getTrace)  <-
      first (LogicalClock.tickTracer clock) <$> recordingTracerTVar
    chainDbView         <- mkChainDbView registry tracer

    let getCandidates = (Chain TestBlock -> AnchoredFragment TestBlock)
-> Map PeerId (Chain TestBlock)
-> Map PeerId (AnchoredFragment TestBlock)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Chain TestBlock -> AnchoredFragment TestBlock
forall blk. HasHeader blk => Chain blk -> AnchoredFragment blk
chainToAnchoredFragment (Map PeerId (Chain TestBlock)
 -> Map PeerId (AnchoredFragment TestBlock))
-> STM m (Map PeerId (Chain TestBlock))
-> STM m (Map PeerId (AnchoredFragment TestBlock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Map PeerId (Chain TestBlock))
-> STM m (Map PeerId (Chain TestBlock))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Map PeerId (Chain TestBlock))
varChains

        blockFetchConsensusInterface =
          STM m (Map PeerId (AnchoredFragment (HeaderWithTime TestBlock)))
-> ChainDbView m TestBlock
-> BlockFetchConsensusInterface
     PeerId (HeaderWithTime TestBlock) TestBlock m
mkTestBlockFetchConsensusInterface
            ((AnchoredFragment TestBlock
 -> AnchoredFragment (HeaderWithTime TestBlock))
-> Map PeerId (AnchoredFragment TestBlock)
-> Map PeerId (AnchoredFragment (HeaderWithTime TestBlock))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
                 ((TestBlock -> HeaderWithTime TestBlock)
-> AnchoredFragment TestBlock
-> AnchoredFragment (HeaderWithTime TestBlock)
forall block2 block1.
(HasHeader block2, HeaderHash block1 ~ HeaderHash block2) =>
(block1 -> block2)
-> AnchoredFragment block1 -> AnchoredFragment block2
AF.mapAnchoredFragment (TopLevelConfig TestBlock
-> Header TestBlock -> HeaderWithTime TestBlock
forall blk.
(HasHeader (Header blk), ImmutableEraParams blk) =>
TopLevelConfig blk -> Header blk -> HeaderWithTime blk
attachSlotTime TopLevelConfig TestBlock
topLevelConfig (Header TestBlock -> HeaderWithTime TestBlock)
-> (TestBlock -> Header TestBlock)
-> TestBlock
-> HeaderWithTime TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestBlock -> Header TestBlock
forall blk. GetHeader blk => blk -> Header blk
getHeader))
             (Map PeerId (AnchoredFragment TestBlock)
 -> Map PeerId (AnchoredFragment (HeaderWithTime TestBlock)))
-> STM m (Map PeerId (AnchoredFragment TestBlock))
-> STM m (Map PeerId (AnchoredFragment (HeaderWithTime TestBlock)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (Map PeerId (AnchoredFragment TestBlock))
getCandidates
            )
            ChainDbView m TestBlock
chainDbView

    _ <- forkLinkedThread registry "BlockFetchLogic" $
      blockFetchLogic
        nullTracer
        nullTracer
        blockFetchConsensusInterface
        fetchClientRegistry
        blockFetchCfg

    let runBlockFetchClient PeerId
peerId =
          FetchClientRegistry PeerId (HeaderWithTime TestBlock) TestBlock m
-> NodeToNodeVersion
-> PeerId
-> (FetchClientContext (HeaderWithTime TestBlock) TestBlock m
    -> m ())
-> m ()
forall (m :: * -> *) a peer header block version.
(MonadFork m, MonadMask m, MonadTimer m, Ord peer) =>
FetchClientRegistry peer header block m
-> version
-> peer
-> (FetchClientContext header block m -> m a)
-> m a
bracketFetchClient FetchClientRegistry PeerId (HeaderWithTime TestBlock) TestBlock m
fetchClientRegistry NodeToNodeVersion
ntnVersion PeerId
peerId \FetchClientContext (HeaderWithTime TestBlock) TestBlock m
clientCtx -> do
            let bfClient :: ClientPipelined
  (BlockFetch TestBlock (Point TestBlock)) 'BFIdle m ()
bfClient = NodeToNodeVersion
-> ControlMessageSTM m
-> FetchedMetricsTracer m
-> FetchClientContext (HeaderWithTime TestBlock) TestBlock m
-> ClientPipelined
     (BlockFetch TestBlock (Point TestBlock)) 'BFIdle m ()
forall header block versionNumber (m :: * -> *).
(MonadSTM m, MonadThrow m, MonadTime m, MonadMonotonicTime m,
 HasHeader header, HasHeader block,
 HeaderHash header ~ HeaderHash block) =>
versionNumber
-> ControlMessageSTM m
-> FetchedMetricsTracer m
-> FetchClientContext header block m
-> ClientPipelined (BlockFetch block (Point block)) 'BFIdle m ()
blockFetchClient
                    NodeToNodeVersion
ntnVersion
                    (StrictTVar m ControlMessage -> ControlMessageSTM m
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m ControlMessage
varControlMessage)
                    FetchedMetricsTracer m
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
                    FetchClientContext (HeaderWithTime TestBlock) TestBlock m
clientCtx
                bfServer :: Server
  (BlockFetch TestBlock (Point TestBlock)) 'NonPipelined 'BFIdle m ()
bfServer =
                    BlockFetchServer TestBlock (Point TestBlock) m ()
-> Server
     (BlockFetch TestBlock (Point TestBlock)) 'NonPipelined 'BFIdle m ()
forall block point (m :: * -> *) a.
Functor m =>
BlockFetchServer block point m a
-> Server (BlockFetch block point) 'NonPipelined 'BFIdle m a
blockFetchServerPeer (BlockFetchServer TestBlock (Point TestBlock) m ()
 -> Server
      (BlockFetch TestBlock (Point TestBlock))
      'NonPipelined
      'BFIdle
      m
      ())
-> BlockFetchServer TestBlock (Point TestBlock) m ()
-> Server
     (BlockFetch TestBlock (Point TestBlock)) 'NonPipelined 'BFIdle m ()
forall a b. (a -> b) -> a -> b
$ m (AnchoredFragment TestBlock)
-> BlockFetchServer TestBlock (Point TestBlock) m ()
forall (m :: * -> *) blk.
(Monad m, HasHeader blk) =>
m (AnchoredFragment blk) -> BlockFetchServer blk (Point blk) m ()
mockBlockFetchServer m (AnchoredFragment TestBlock)
getCurrentChain
                  where
                    getCurrentChain :: m (AnchoredFragment TestBlock)
getCurrentChain = STM m (AnchoredFragment TestBlock)
-> m (AnchoredFragment TestBlock)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (AnchoredFragment TestBlock)
 -> m (AnchoredFragment TestBlock))
-> STM m (AnchoredFragment TestBlock)
-> m (AnchoredFragment TestBlock)
forall a b. (a -> b) -> a -> b
$ (Map PeerId (AnchoredFragment TestBlock)
-> PeerId -> AnchoredFragment TestBlock
forall k a. Ord k => Map k a -> k -> a
Map.! PeerId
peerId) (Map PeerId (AnchoredFragment TestBlock)
 -> AnchoredFragment TestBlock)
-> STM m (Map PeerId (AnchoredFragment TestBlock))
-> STM m (AnchoredFragment TestBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (Map PeerId (AnchoredFragment TestBlock))
getCandidates

                blockFetchTracer :: Tracer m (PeerRole, Driver.TraceSendRecv (BlockFetch TestBlock (Point TestBlock)))
                blockFetchTracer :: Tracer
  m
  (PeerRole, TraceSendRecv (BlockFetch TestBlock (Point TestBlock)))
blockFetchTracer = ((PeerRole, TraceSendRecv (BlockFetch TestBlock (Point TestBlock)))
 -> m ())
-> Tracer
     m
     (PeerRole, TraceSendRecv (BlockFetch TestBlock (Point TestBlock)))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer \case
                    (PeerRole
AsClient, TraceSendRecv (BlockFetch TestBlock (Point TestBlock))
ev) -> do
                      STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically case TraceSendRecv (BlockFetch TestBlock (Point TestBlock))
ev of
                        Driver.TraceRecvMsg (AnyMessage (MsgBlock TestBlock
_)) ->
                           StrictTVar m (Map PeerId Word)
-> (Map PeerId Word -> Map PeerId Word) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Map PeerId Word)
varFetchedBlocks ((Map PeerId Word -> Map PeerId Word) -> STM m ())
-> (Map PeerId Word -> Map PeerId Word) -> STM m ()
forall a b. (a -> b) -> a -> b
$ (Word -> Word) -> PeerId -> Map PeerId Word -> Map PeerId Word
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1) PeerId
peerId
                        TraceSendRecv (BlockFetch TestBlock (Point TestBlock))
_ -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                      Tracer m String -> String -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m String
tracer (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
                        PeerId -> String
forall a. Show a => a -> String
show PeerId
peerId String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": BlockFetchClient: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TraceSendRecv (BlockFetch TestBlock (Point TestBlock)) -> String
forall a. Show a => a -> String
show TraceSendRecv (BlockFetch TestBlock (Point TestBlock))
ev
                    (PeerRole, TraceSendRecv (BlockFetch TestBlock (Point TestBlock)))
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            ((), ()) -> ()
forall a b. (a, b) -> a
fst (((), ()) -> ()) -> m ((), ()) -> m ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Channel m (AnyMessage (BlockFetch TestBlock (Point TestBlock))),
   Channel m (AnyMessage (BlockFetch TestBlock (Point TestBlock))))
-> Tracer
     m
     (PeerRole, TraceSendRecv (BlockFetch TestBlock (Point TestBlock)))
-> Codec
     (BlockFetch TestBlock (Point TestBlock))
     CodecFailure
     m
     (AnyMessage (BlockFetch TestBlock (Point TestBlock)))
-> ClientPipelined
     (BlockFetch TestBlock (Point TestBlock)) 'BFIdle m ()
-> Peer
     (BlockFetch TestBlock (Point TestBlock))
     (FlipAgency 'AsClient)
     'NonPipelined
     'BFIdle
     m
     ()
-> m ((), ())
forall (m :: * -> *) failure bytes ps (pr :: PeerRole) (st :: ps) a
       b.
(MonadAsync m, MonadCatch m, Exception failure) =>
m (Channel m bytes, Channel m bytes)
-> Tracer m (PeerRole, TraceSendRecv ps)
-> Codec ps failure m bytes
-> PeerPipelined ps pr st m a
-> Peer ps (FlipAgency pr) 'NonPipelined st m b
-> m (a, b)
Driver.runConnectedPeersPipelined
              m (Channel m (AnyMessage (BlockFetch TestBlock (Point TestBlock))),
   Channel m (AnyMessage (BlockFetch TestBlock (Point TestBlock))))
forall (m :: * -> *) a.
(MonadLabelledSTM m, MonadTraceSTM m, Show a) =>
m (Channel m a, Channel m a)
createConnectedChannels
              Tracer
  m
  (PeerRole, TraceSendRecv (BlockFetch TestBlock (Point TestBlock)))
blockFetchTracer
              Codec
  (BlockFetch TestBlock (Point TestBlock))
  CodecFailure
  m
  (AnyMessage (BlockFetch TestBlock (Point TestBlock)))
forall block point (m :: * -> *).
Monad m =>
Codec
  (BlockFetch block point)
  CodecFailure
  m
  (AnyMessage (BlockFetch block point))
codecBlockFetchId
              ClientPipelined
  (BlockFetch TestBlock (Point TestBlock)) 'BFIdle m ()
bfClient
              Peer
  (BlockFetch TestBlock (Point TestBlock))
  (FlipAgency 'AsClient)
  'NonPipelined
  'BFIdle
  m
  ()
Server
  (BlockFetch TestBlock (Point TestBlock)) 'NonPipelined 'BFIdle m ()
bfServer

        -- On every tick, we schedule updates to the shared chain fragment
        -- (mocking ChainSync).
        forkTicking PeerId
peerId =
            ResourceRegistry m
-> String -> Watcher m Tick Tick -> m (Thread m Void)
forall (m :: * -> *) a fp.
(IOLike m, Eq fp, HasCallStack) =>
ResourceRegistry m -> String -> Watcher m a fp -> m (Thread m Void)
forkLinkedWatcher ResourceRegistry m
registry (String
"TickWatcher " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PeerId -> String
forall a. Condense a => a -> String
condense PeerId
peerId) (Watcher m Tick Tick -> m (Thread m Void))
-> Watcher m Tick Tick -> m (Thread m Void)
forall a b. (a -> b) -> a -> b
$
              LogicalClock m -> (Tick -> m ()) -> Watcher m Tick Tick
forall (m :: * -> *).
LogicalClock m -> (Tick -> m ()) -> Watcher m Tick Tick
LogicalClock.tickWatcher LogicalClock m
clock \Tick
tick -> STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically do
                let updates :: [ChainUpdate TestBlock TestBlock]
updates = [ChainUpdate] -> [ChainUpdate TestBlock TestBlock]
toChainUpdates ([ChainUpdate] -> [ChainUpdate TestBlock TestBlock])
-> [ChainUpdate] -> [ChainUpdate TestBlock TestBlock]
forall a b. (a -> b) -> a -> b
$
                      [ChainUpdate] -> Tick -> Map Tick [ChainUpdate] -> [ChainUpdate]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Tick
tick (Map Tick [ChainUpdate] -> [ChainUpdate])
-> Map Tick [ChainUpdate] -> [ChainUpdate]
forall a b. (a -> b) -> a -> b
$
                        Schedule ChainUpdate -> Map Tick [ChainUpdate]
forall a. Schedule a -> Map Tick [a]
getSchedule (Schedule ChainUpdate -> Map Tick [ChainUpdate])
-> Schedule ChainUpdate -> Map Tick [ChainUpdate]
forall a b. (a -> b) -> a -> b
$ Map PeerId (Schedule ChainUpdate)
peerUpdates Map PeerId (Schedule ChainUpdate) -> PeerId -> Schedule ChainUpdate
forall k a. Ord k => Map k a -> k -> a
Map.! PeerId
peerId
                    updateChain :: Chain TestBlock -> Chain TestBlock
updateChain Chain TestBlock
chain =
                      case [ChainUpdate TestBlock TestBlock]
-> Chain TestBlock -> Maybe (Chain TestBlock)
forall block.
HasHeader block =>
[ChainUpdate block block] -> Chain block -> Maybe (Chain block)
Chain.applyChainUpdates [ChainUpdate TestBlock TestBlock]
updates Chain TestBlock
chain of
                        Just Chain TestBlock
chain' -> Chain TestBlock
chain'
                        Maybe (Chain TestBlock)
Nothing     -> String -> Chain TestBlock
forall a. HasCallStack => String -> a
error String
"Chain update failed"
                -- Block until our "ChainSync" thread registered itself to the
                -- FetchClientRegistry, see 'forkChainSync' below.
                _ <- STM m (Maybe (Chain TestBlock)) -> STM m (Chain TestBlock)
forall (m :: * -> *) a. MonadSTM m => STM m (Maybe a) -> STM m a
blockUntilJust (STM m (Maybe (Chain TestBlock)) -> STM m (Chain TestBlock))
-> STM m (Maybe (Chain TestBlock)) -> STM m (Chain TestBlock)
forall a b. (a -> b) -> a -> b
$ PeerId -> Map PeerId (Chain TestBlock) -> Maybe (Chain TestBlock)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PeerId
peerId (Map PeerId (Chain TestBlock) -> Maybe (Chain TestBlock))
-> STM m (Map PeerId (Chain TestBlock))
-> STM m (Maybe (Chain TestBlock))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Map PeerId (Chain TestBlock))
-> STM m (Map PeerId (Chain TestBlock))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Map PeerId (Chain TestBlock))
varChains
                modifyTVar varChains $ Map.adjust updateChain peerId

        forkChainSync PeerId
peerId =
          ResourceRegistry m -> String -> m Void -> m (Thread m Void)
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry (String
"BracketSync" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PeerId -> String
forall a. Condense a => a -> String
condense PeerId
peerId) (m Void -> m (Thread m Void)) -> m Void -> m (Thread m Void)
forall a b. (a -> b) -> a -> b
$
            FetchClientRegistry PeerId (HeaderWithTime TestBlock) TestBlock m
-> PeerId -> m Void -> m Void
forall (m :: * -> *) a peer header block.
(MonadSTM m, MonadFork m, MonadCatch m, Ord peer) =>
FetchClientRegistry peer header block m -> peer -> m a -> m a
bracketSyncWithFetchClient FetchClientRegistry PeerId (HeaderWithTime TestBlock) TestBlock m
fetchClientRegistry PeerId
peerId (m Void -> m Void) -> m Void -> m Void
forall a b. (a -> b) -> a -> b
$ do
              let modifyChains :: (Map PeerId (Chain TestBlock) -> Map PeerId (Chain TestBlock))
-> m ()
modifyChains = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ())
-> ((Map PeerId (Chain TestBlock) -> Map PeerId (Chain TestBlock))
    -> STM m ())
-> (Map PeerId (Chain TestBlock) -> Map PeerId (Chain TestBlock))
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictTVar m (Map PeerId (Chain TestBlock))
-> (Map PeerId (Chain TestBlock) -> Map PeerId (Chain TestBlock))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m (Map PeerId (Chain TestBlock))
varChains
              m () -> m () -> m Void -> m Void
forall a b c. m a -> m b -> m c -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> m b -> m c -> m c
bracket_
                ((Map PeerId (Chain TestBlock) -> Map PeerId (Chain TestBlock))
-> m ()
modifyChains ((Map PeerId (Chain TestBlock) -> Map PeerId (Chain TestBlock))
 -> m ())
-> (Map PeerId (Chain TestBlock) -> Map PeerId (Chain TestBlock))
-> m ()
forall a b. (a -> b) -> a -> b
$ PeerId
-> Chain TestBlock
-> Map PeerId (Chain TestBlock)
-> Map PeerId (Chain TestBlock)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PeerId
peerId Chain TestBlock
forall block. Chain block
Chain.Genesis)
                ((Map PeerId (Chain TestBlock) -> Map PeerId (Chain TestBlock))
-> m ()
modifyChains ((Map PeerId (Chain TestBlock) -> Map PeerId (Chain TestBlock))
 -> m ())
-> (Map PeerId (Chain TestBlock) -> Map PeerId (Chain TestBlock))
-> m ()
forall a b. (a -> b) -> a -> b
$ PeerId
-> Map PeerId (Chain TestBlock) -> Map PeerId (Chain TestBlock)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete PeerId
peerId)
                (PeerId -> m (Thread m Void)
forkTicking PeerId
peerId m (Thread m Void) -> (Thread m Void -> m Void) -> m Void
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Thread m Void -> m Void
forall (m :: * -> *) a. MonadAsync m => Thread m a -> m a
waitThread)

        -- The BlockFetch logic requires initializing the KeepAlive
        -- miniprotocol, even if it does not do anything.
        forkKeepAlive PeerId
peerId =
          ResourceRegistry m -> String -> m Any -> m (Thread m Any)
forall (m :: * -> *) a.
(MonadAsync m, MonadFork m, MonadMask m, HasCallStack) =>
ResourceRegistry m -> String -> m a -> m (Thread m a)
forkLinkedThread ResourceRegistry m
registry String
"KeepAlive" (m Any -> m (Thread m Any)) -> m Any -> m (Thread m Any)
forall a b. (a -> b) -> a -> b
$
            FetchClientRegistry PeerId (HeaderWithTime TestBlock) TestBlock m
-> PeerId -> (StrictTVar m (Map PeerId PeerGSV) -> m Any) -> m Any
forall (m :: * -> *) a peer header block.
(MonadSTM m, MonadFork m, MonadMask m, Ord peer) =>
FetchClientRegistry peer header block m
-> peer -> (StrictTVar m (Map peer PeerGSV) -> m a) -> m a
bracketKeepAliveClient FetchClientRegistry PeerId (HeaderWithTime TestBlock) TestBlock m
fetchClientRegistry PeerId
peerId \StrictTVar m (Map PeerId PeerGSV)
_ ->
              m Any
forall (m :: * -> *) a. MonadSTM m => m a
infiniteDelay

    blockFetchThreads <- Map.fromList <$> for peerIds \PeerId
peerId -> do
      _ <- PeerId -> m (Thread m Void)
forkChainSync PeerId
peerId
      _ <- forkKeepAlive peerId
      fmap (peerId,) $
        forkThread registry ("BlockFetch " <> condense peerId) $
          try $ runBlockFetchClient peerId

    LogicalClock.waitUntilDone clock
    atomically $ writeTVar varControlMessage Terminate

    bfcoBlockFetchResults <- traverse waitThread blockFetchThreads
    bfcoFetchedBlocks     <- readTVarIO varFetchedBlocks
    bfcoTrace             <- getTrace
    pure BlockFetchClientOutcome {..}
  where
    peerIds :: [PeerId]
peerIds = Map PeerId (Schedule ChainUpdate) -> [PeerId]
forall k a. Map k a -> [k]
Map.keys Map PeerId (Schedule ChainUpdate)
peerUpdates

    numCoreNodes :: NumCoreNodes
numCoreNodes = Word64 -> NumCoreNodes
NumCoreNodes (Word64 -> NumCoreNodes) -> Word64 -> NumCoreNodes
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ Map PeerId (Schedule ChainUpdate) -> Int
forall k a. Map k a -> Int
Map.size Map PeerId (Schedule ChainUpdate)
peerUpdates Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

    -- Needs to be larger than any chain length in this test, to ensure that
    -- switching to any chain is never too deep.
    securityParam :: SecurityParam
securityParam  = NonZero Word64 -> SecurityParam
SecurityParam (NonZero Word64 -> SecurityParam)
-> NonZero Word64 -> SecurityParam
forall a b. (a -> b) -> a -> b
$ forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @1000
    topLevelConfig :: TopLevelConfig TestBlock
topLevelConfig = SecurityParam -> TopLevelConfig TestBlock
singleNodeTestConfigWithK SecurityParam
securityParam

    mkChainDbView ::
         ResourceRegistry m
      -> Tracer m String
      -> m (BlockFetchClientInterface.ChainDbView m TestBlock)
    mkChainDbView :: ResourceRegistry m
-> Tracer m String -> m (ChainDbView m TestBlock)
mkChainDbView ResourceRegistry m
registry Tracer m String
tracer = do
        chainDbArgs <- do
          nodeDBs <- m (NodeDBs (StrictTMVar m MockFS))
forall (m :: * -> *).
MonadSTM m =>
m (NodeDBs (StrictTMVar m MockFS))
emptyNodeDBs
          let args = MinimalChainDbArgs m TestBlock -> ChainDbArgs Identity m TestBlock
forall (m :: * -> *) blk.
(MonadThrow m, MonadSTM m, ConsensusProtocol (BlockProtocol blk),
 PrimMonad m) =>
MinimalChainDbArgs m blk -> Complete ChainDbArgs m blk
fromMinimalChainDbArgs (MinimalChainDbArgs m TestBlock
 -> ChainDbArgs Identity m TestBlock)
-> MinimalChainDbArgs m TestBlock
-> ChainDbArgs Identity m TestBlock
forall a b. (a -> b) -> a -> b
$ MinimalChainDbArgs {
                  mcdbTopLevelConfig :: TopLevelConfig TestBlock
mcdbTopLevelConfig = TopLevelConfig TestBlock
topLevelConfig
                , mcdbChunkInfo :: ChunkInfo
mcdbChunkInfo = TopLevelConfig TestBlock -> ChunkInfo
mkTestChunkInfo TopLevelConfig TestBlock
topLevelConfig
                , mcdbInitLedger :: ExtLedgerState TestBlock ValuesMK
mcdbInitLedger = ExtLedgerState TestBlock ValuesMK
testInitExtLedger
                , mcdbRegistry :: ResourceRegistry m
mcdbRegistry = ResourceRegistry m
registry
                , mcdbNodeDBs :: NodeDBs (StrictTMVar m MockFS)
mcdbNodeDBs = NodeDBs (StrictTMVar m MockFS)
nodeDBs
                }
          pure $ ChainDB.updateTracer cdbTracer args
        (_, (chainDB, ChainDBImpl.Internal{intAddBlockRunner})) <-
          allocate
            registry
            (\ResourceId
_ -> ChainDbArgs Identity m TestBlock
-> Bool -> m (ChainDB m TestBlock, Internal m TestBlock)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk,
 BlockSupportsDiffusionPipelining blk, InspectLedger blk,
 HasHardForkHistory blk, ConvertRawHash blk,
 SerialiseDiskConstraints blk, HasCallStack,
 LedgerSupportsLedgerDB blk) =>
Complete ChainDbArgs m blk
-> Bool -> m (ChainDB m blk, Internal m blk)
ChainDBImpl.openDBInternal ChainDbArgs Identity m TestBlock
chainDbArgs Bool
False)
            (ChainDB.closeDB . fst)
        _ <- forkLinkedThread registry "AddBlockRunner" intAddBlockRunner

        let -- Always return the empty chain such that the BlockFetch logic
            -- downloads all chains.
            getCurrentChain           = AnchoredSeq
  (WithOrigin SlotNo) (Anchor (Header TestBlock)) (Header TestBlock)
-> STM
     m
     (AnchoredSeq
        (WithOrigin SlotNo) (Anchor (Header TestBlock)) (Header TestBlock))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnchoredSeq
   (WithOrigin SlotNo) (Anchor (Header TestBlock)) (Header TestBlock)
 -> STM
      m
      (AnchoredSeq
         (WithOrigin SlotNo)
         (Anchor (Header TestBlock))
         (Header TestBlock)))
-> AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header TestBlock)) (Header TestBlock)
-> STM
     m
     (AnchoredSeq
        (WithOrigin SlotNo) (Anchor (Header TestBlock)) (Header TestBlock))
forall a b. (a -> b) -> a -> b
$ Anchor (Header TestBlock)
-> AnchoredSeq
     (WithOrigin SlotNo) (Anchor (Header TestBlock)) (Header TestBlock)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (Header TestBlock)
forall block. Anchor block
AF.AnchorGenesis
            getCurrentChainWithTime   = AnchoredFragment (HeaderWithTime TestBlock)
-> STM m (AnchoredFragment (HeaderWithTime TestBlock))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AnchoredFragment (HeaderWithTime TestBlock)
 -> STM m (AnchoredFragment (HeaderWithTime TestBlock)))
-> AnchoredFragment (HeaderWithTime TestBlock)
-> STM m (AnchoredFragment (HeaderWithTime TestBlock))
forall a b. (a -> b) -> a -> b
$ Anchor (HeaderWithTime TestBlock)
-> AnchoredFragment (HeaderWithTime TestBlock)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor (HeaderWithTime TestBlock)
forall block. Anchor block
AF.AnchorGenesis
            getIsFetched              = ChainDB m TestBlock -> STM m (Point TestBlock -> Bool)
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (Point blk -> Bool)
ChainDB.getIsFetched ChainDB m TestBlock
chainDB
            getMaxSlotNo              = ChainDB m TestBlock -> STM m MaxSlotNo
forall (m :: * -> *) blk. ChainDB m blk -> STM m MaxSlotNo
ChainDB.getMaxSlotNo ChainDB m TestBlock
chainDB
            addBlockAsync         = ChainDB m TestBlock
-> InvalidBlockPunishment m
-> TestBlock
-> m (AddBlockPromise m TestBlock)
forall (m :: * -> *) blk.
ChainDB m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
ChainDB.addBlockAsync ChainDB m TestBlock
chainDB
            getChainSelStarvation = ChainDB m TestBlock -> STM m ChainSelStarvation
forall (m :: * -> *) blk. ChainDB m blk -> STM m ChainSelStarvation
ChainDB.getChainSelStarvation ChainDB m TestBlock
chainDB
        pure BlockFetchClientInterface.ChainDbView {..}
      where
        cdbTracer :: Tracer m (TraceEvent TestBlock)
cdbTracer = (TraceEvent TestBlock -> m ()) -> Tracer m (TraceEvent TestBlock)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer \case
            ChainDBImpl.TraceAddBlockEvent TraceAddBlockEvent TestBlock
ev ->
              Tracer m String -> String -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m String
tracer (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"ChainDB: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TraceAddBlockEvent TestBlock -> String
forall a. Show a => a -> String
show TraceAddBlockEvent TestBlock
ev
            TraceEvent TestBlock
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    mkTestBlockFetchConsensusInterface ::
         STM m (Map PeerId (AnchoredFragment (HeaderWithTime TestBlock)))
      -> BlockFetchClientInterface.ChainDbView m TestBlock
      -> BlockFetchConsensusInterface PeerId (HeaderWithTime TestBlock) TestBlock m
    mkTestBlockFetchConsensusInterface :: STM m (Map PeerId (AnchoredFragment (HeaderWithTime TestBlock)))
-> ChainDbView m TestBlock
-> BlockFetchConsensusInterface
     PeerId (HeaderWithTime TestBlock) TestBlock m
mkTestBlockFetchConsensusInterface STM m (Map PeerId (AnchoredFragment (HeaderWithTime TestBlock)))
getCandidates ChainDbView m TestBlock
chainDbView =
        (forall (m :: * -> *) peer blk.
(IOLike m, BlockSupportsDiffusionPipelining blk, Ord peer,
 LedgerSupportsProtocol blk, ConfigSupportsNode blk) =>
Tracer m (TraceEventDbf peer)
-> BlockConfig blk
-> ChainDbView m blk
-> ChainSyncClientHandleCollection peer m blk
-> (Header blk -> SizeInBytes)
-> STM m FetchMode
-> DiffusionPipeliningSupport
-> BlockFetchConsensusInterface peer (HeaderWithTime blk) blk m
BlockFetchClientInterface.mkBlockFetchConsensusInterface @m @PeerId
          Tracer m (TraceEventDbf PeerId)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
          (NumCoreNodes -> BlockConfig TestBlock
forall ptype. NumCoreNodes -> BlockConfig (TestBlockWith ptype)
TestBlockConfig NumCoreNodes
numCoreNodes)
          ChainDbView m TestBlock
chainDbView
          (String -> ChainSyncClientHandleCollection PeerId m TestBlock
forall a. HasCallStack => String -> a
error String
"ChainSyncClientHandleCollection not provided to mkBlockFetchConsensusInterface")
          (\Header TestBlock
_hdr -> SizeInBytes
1000) -- header size, only used for peer prioritization
          (FetchMode -> STM m FetchMode
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FetchMode
blockFetchMode)
          DiffusionPipeliningSupport
blockFetchPipelining)
            { readCandidateChains          = getCandidates
            , demoteChainSyncJumpingDynamo = const (pure ())
            }

mockBlockFetchServer ::
     forall m blk.
     (Monad m, HasHeader blk)
  => m (AnchoredFragment blk)
  -> BlockFetchServer blk (Point blk) m ()
mockBlockFetchServer :: forall (m :: * -> *) blk.
(Monad m, HasHeader blk) =>
m (AnchoredFragment blk) -> BlockFetchServer blk (Point blk) m ()
mockBlockFetchServer m (AnchoredFragment blk)
getCurrentChain = BlockFetchServer blk (Point blk) m ()
idle
  where
    idle :: BlockFetchServer blk (Point blk) m ()
    idle :: BlockFetchServer blk (Point blk) m ()
idle = ((ChainRange (Point blk)
  -> m (BlockFetchBlockSender blk (Point blk) m ()))
 -> () -> BlockFetchServer blk (Point blk) m ())
-> ()
-> (ChainRange (Point blk)
    -> m (BlockFetchBlockSender blk (Point blk) m ()))
-> BlockFetchServer blk (Point blk) m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ChainRange (Point blk)
 -> m (BlockFetchBlockSender blk (Point blk) m ()))
-> () -> BlockFetchServer blk (Point blk) m ()
forall point (m :: * -> *) block a.
(ChainRange point -> m (BlockFetchBlockSender block point m a))
-> a -> BlockFetchServer block point m a
BlockFetchServer () \(ChainRange Point blk
from Point blk
to) -> do
        curChain <- m (AnchoredFragment blk)
getCurrentChain
        pure case AF.sliceRange curChain from to of
          Maybe (AnchoredFragment blk)
Nothing    -> m (BlockFetchServer blk (Point blk) m ())
-> BlockFetchBlockSender blk (Point blk) m ()
forall (m :: * -> *) block point a.
m (BlockFetchServer block point m a)
-> BlockFetchBlockSender block point m a
SendMsgNoBlocks (BlockFetchServer blk (Point blk) m ()
-> m (BlockFetchServer blk (Point blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlockFetchServer blk (Point blk) m ()
idle)
          Just AnchoredFragment blk
slice -> m (BlockFetchSendBlocks blk (Point blk) m ())
-> BlockFetchBlockSender blk (Point blk) m ()
forall (m :: * -> *) block point a.
m (BlockFetchSendBlocks block point m a)
-> BlockFetchBlockSender block point m a
SendMsgStartBatch (m (BlockFetchSendBlocks blk (Point blk) m ())
 -> BlockFetchBlockSender blk (Point blk) m ())
-> m (BlockFetchSendBlocks blk (Point blk) m ())
-> BlockFetchBlockSender blk (Point blk) m ()
forall a b. (a -> b) -> a -> b
$ [blk] -> m (BlockFetchSendBlocks blk (Point blk) m ())
sendBlocks (AnchoredFragment blk -> [blk]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment blk
slice)

    sendBlocks :: [blk] -> m (BlockFetchSendBlocks blk (Point blk) m ())
    sendBlocks :: [blk] -> m (BlockFetchSendBlocks blk (Point blk) m ())
sendBlocks = BlockFetchSendBlocks blk (Point blk) m ()
-> m (BlockFetchSendBlocks blk (Point blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockFetchSendBlocks blk (Point blk) m ()
 -> m (BlockFetchSendBlocks blk (Point blk) m ()))
-> ([blk] -> BlockFetchSendBlocks blk (Point blk) m ())
-> [blk]
-> m (BlockFetchSendBlocks blk (Point blk) m ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      []         -> m (BlockFetchServer blk (Point blk) m ())
-> BlockFetchSendBlocks blk (Point blk) m ()
forall (m :: * -> *) block point a.
m (BlockFetchServer block point m a)
-> BlockFetchSendBlocks block point m a
SendMsgBatchDone (BlockFetchServer blk (Point blk) m ()
-> m (BlockFetchServer blk (Point blk) m ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlockFetchServer blk (Point blk) m ()
idle)
      blk
blk : [blk]
blks -> blk
-> m (BlockFetchSendBlocks blk (Point blk) m ())
-> BlockFetchSendBlocks blk (Point blk) m ()
forall block (m :: * -> *) point a.
block
-> m (BlockFetchSendBlocks block point m a)
-> BlockFetchSendBlocks block point m a
SendMsgBlock blk
blk ([blk] -> m (BlockFetchSendBlocks blk (Point blk) m ())
sendBlocks [blk]
blks)

ntnVersion :: NodeToNodeVersion
ntnVersion :: NodeToNodeVersion
ntnVersion = NodeToNodeVersion
forall a. Bounded a => a
maxBound

{-------------------------------------------------------------------------------
  BlockFetchClientTestSetup
-------------------------------------------------------------------------------}

data BlockFetchClientTestSetup = BlockFetchClientTestSetup {
    -- | A 'Schedule' of 'ChainUpdate's for every peer. This emulates
    -- the candidate fragments provided by the ChainSync client.
    BlockFetchClientTestSetup -> Map PeerId (Schedule ChainUpdate)
peerUpdates          :: Map PeerId (Schedule ChainUpdate)
    -- | BlockFetch 'FetchMode'
  , BlockFetchClientTestSetup -> FetchMode
blockFetchMode       :: FetchMode
  , BlockFetchClientTestSetup -> BlockFetchConfiguration
blockFetchCfg        :: BlockFetchConfiguration
  , BlockFetchClientTestSetup -> DiffusionPipeliningSupport
blockFetchPipelining :: DiffusionPipeliningSupport
  }
  deriving stock (Int -> BlockFetchClientTestSetup -> String -> String
[BlockFetchClientTestSetup] -> String -> String
BlockFetchClientTestSetup -> String
(Int -> BlockFetchClientTestSetup -> String -> String)
-> (BlockFetchClientTestSetup -> String)
-> ([BlockFetchClientTestSetup] -> String -> String)
-> Show BlockFetchClientTestSetup
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> BlockFetchClientTestSetup -> String -> String
showsPrec :: Int -> BlockFetchClientTestSetup -> String -> String
$cshow :: BlockFetchClientTestSetup -> String
show :: BlockFetchClientTestSetup -> String
$cshowList :: [BlockFetchClientTestSetup] -> String -> String
showList :: [BlockFetchClientTestSetup] -> String -> String
Show)

instance Condense BlockFetchClientTestSetup where
  condense :: BlockFetchClientTestSetup -> String
condense BlockFetchClientTestSetup{Map PeerId (Schedule ChainUpdate)
DiffusionPipeliningSupport
FetchMode
BlockFetchConfiguration
blockFetchPipelining :: BlockFetchClientTestSetup -> DiffusionPipeliningSupport
blockFetchCfg :: BlockFetchClientTestSetup -> BlockFetchConfiguration
blockFetchMode :: BlockFetchClientTestSetup -> FetchMode
peerUpdates :: BlockFetchClientTestSetup -> Map PeerId (Schedule ChainUpdate)
peerUpdates :: Map PeerId (Schedule ChainUpdate)
blockFetchMode :: FetchMode
blockFetchCfg :: BlockFetchConfiguration
blockFetchPipelining :: DiffusionPipeliningSupport
..} = [String] -> String
unlines
      [ String
"Number of peers: "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Map PeerId (Schedule ChainUpdate) -> Int
forall k a. Map k a -> Int
Map.size Map PeerId (Schedule ChainUpdate)
peerUpdates)
      , String
"Chain updates:\n"
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Map PeerId (Schedule ChainUpdate) -> String
forall {a} {a}. (Condense a, Show a) => Map a a -> String
ppPerPeer Map PeerId (Schedule ChainUpdate)
peerUpdates
      , String
"BlockFetch mode: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> FetchMode -> String
forall a. Show a => a -> String
show FetchMode
blockFetchMode
      , String
"BlockFetch pipelining " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> DiffusionPipeliningSupport -> String
forall a. Show a => a -> String
show DiffusionPipeliningSupport
blockFetchPipelining
      , String
"BlockFetch cfg: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> BlockFetchConfiguration -> String
forall a. Show a => a -> String
show BlockFetchConfiguration
blockFetchCfg
      ]
    where
      ppPerPeer :: Map a a -> String
ppPerPeer Map a a
peerMap = [String] -> String
unlines
        [ String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
peerId String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
valLine
        | (a
peerId, a
val) <- Map a a -> [(a, a)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map a a
peerMap
        , String
valLine       <- String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Condense a => a -> String
condense a
val
        ]

instance Arbitrary BlockFetchClientTestSetup where
  arbitrary :: Gen BlockFetchClientTestSetup
arbitrary = do
      numPeers <- (Int, Int) -> Gen Int
chooseInt (Int
1, Int
3)
      let peerIds = Int -> PeerId
PeerId (Int -> PeerId) -> [Int] -> [PeerId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
1 .. Int
numPeers]
      blockFetchPipelining <-
        elements [DiffusionPipeliningOn, DiffusionPipeliningOff]
      peerUpdates <-
            Map.fromList . zip peerIds
        <$> replicateM numPeers (genUpdateSchedule blockFetchPipelining)
      blockFetchMode <- elements
        [ PraosFetchMode FetchModeBulkSync
        , PraosFetchMode FetchModeDeadline
        , FetchModeGenesis
        ]
      blockFetchCfg  <- do
        let -- ensure that we can download blocks from all peers
            bfcMaxConcurrencyBulkSync = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numPeers
            bfcMaxConcurrencyDeadline = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numPeers
            -- This is used to introduce a minimal delay between BlockFetch
            -- logic iterations in case the monitored state vars change too
            -- fast, which we don't have to worry about in this test.
            bfcDecisionLoopIntervalGenesis = DiffTime
0
            bfcDecisionLoopIntervalPraos = DiffTime
0
        bfcMaxRequestsInflight <- chooseEnum (2, 10)
        bfcSalt                <- arbitrary
        gbfcGracePeriod <- fromIntegral <$> chooseInteger (5, 60)
        let bfcGenesisBFConfig = GenesisBlockFetchConfiguration {DiffTime
gbfcGracePeriod :: DiffTime
gbfcGracePeriod :: DiffTime
..}
        pure BlockFetchConfiguration {..}
      pure BlockFetchClientTestSetup {..}
    where
      genUpdateSchedule :: DiffusionPipeliningSupport -> Gen (Schedule ChainUpdate)
genUpdateSchedule DiffusionPipeliningSupport
diffusionPipelining =
          UpdateBehavior -> SecurityParam -> Int -> Gen [ChainUpdate]
genChainUpdates UpdateBehavior
behavior SecurityParam
maxRollback Int
20 Gen [ChainUpdate]
-> ([ChainUpdate] -> Gen (Schedule ChainUpdate))
-> Gen (Schedule ChainUpdate)
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ChainUpdate] -> Gen (Schedule ChainUpdate)
forall a. [a] -> Gen (Schedule a)
genSchedule
        where
          behavior :: UpdateBehavior
behavior = case DiffusionPipeliningSupport
diffusionPipelining of
            DiffusionPipeliningSupport
DiffusionPipeliningOn  -> UpdateBehavior
TentativeChainBehavior
            DiffusionPipeliningSupport
DiffusionPipeliningOff -> UpdateBehavior
SelectedChainBehavior

      -- Only use a small k to avoid rolling forward by a big chain.
      maxRollback :: SecurityParam
maxRollback = NonZero Word64 -> SecurityParam
SecurityParam (NonZero Word64 -> SecurityParam)
-> NonZero Word64 -> SecurityParam
forall a b. (a -> b) -> a -> b
$ forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @5

  shrink :: BlockFetchClientTestSetup -> [BlockFetchClientTestSetup]
shrink BlockFetchClientTestSetup{Map PeerId (Schedule ChainUpdate)
DiffusionPipeliningSupport
FetchMode
BlockFetchConfiguration
blockFetchPipelining :: BlockFetchClientTestSetup -> DiffusionPipeliningSupport
blockFetchCfg :: BlockFetchClientTestSetup -> BlockFetchConfiguration
blockFetchMode :: BlockFetchClientTestSetup -> FetchMode
peerUpdates :: BlockFetchClientTestSetup -> Map PeerId (Schedule ChainUpdate)
peerUpdates :: Map PeerId (Schedule ChainUpdate)
blockFetchMode :: FetchMode
blockFetchCfg :: BlockFetchConfiguration
blockFetchPipelining :: DiffusionPipeliningSupport
..} =
      -- If we have multiple peers, check if removing the peer still
      -- yields an error
      [ BlockFetchClientTestSetup {
            peerUpdates :: Map PeerId (Schedule ChainUpdate)
peerUpdates = PeerId
-> Map PeerId (Schedule ChainUpdate)
-> Map PeerId (Schedule ChainUpdate)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete PeerId
peerId Map PeerId (Schedule ChainUpdate)
peerUpdates
          , DiffusionPipeliningSupport
FetchMode
BlockFetchConfiguration
blockFetchPipelining :: DiffusionPipeliningSupport
blockFetchCfg :: BlockFetchConfiguration
blockFetchMode :: FetchMode
blockFetchMode :: FetchMode
blockFetchCfg :: BlockFetchConfiguration
blockFetchPipelining :: DiffusionPipeliningSupport
..
          }
      | [PeerId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PeerId]
peerIds Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
      , PeerId
peerId <- [PeerId]
peerIds
      ] [BlockFetchClientTestSetup]
-> [BlockFetchClientTestSetup] -> [BlockFetchClientTestSetup]
forall a. Semigroup a => a -> a -> a
<>
      -- Shrink the schedules for all peers simultaneously
      [ BlockFetchClientTestSetup {
            peerUpdates :: Map PeerId (Schedule ChainUpdate)
peerUpdates = PeerId
-> Schedule ChainUpdate
-> Map PeerId (Schedule ChainUpdate)
-> Map PeerId (Schedule ChainUpdate)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PeerId
peerId Schedule ChainUpdate
updates Map PeerId (Schedule ChainUpdate)
peerUpdates
          , DiffusionPipeliningSupport
FetchMode
BlockFetchConfiguration
blockFetchPipelining :: DiffusionPipeliningSupport
blockFetchCfg :: BlockFetchConfiguration
blockFetchMode :: FetchMode
blockFetchMode :: FetchMode
blockFetchCfg :: BlockFetchConfiguration
blockFetchPipelining :: DiffusionPipeliningSupport
..
          }
      | PeerId
peerId <- [PeerId]
peerIds
      , Schedule ChainUpdate
updates <-
          (Schedule ChainUpdate -> Bool)
-> [Schedule ChainUpdate] -> [Schedule ChainUpdate]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (Schedule ChainUpdate -> Bool) -> Schedule ChainUpdate -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ChainUpdate] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([ChainUpdate] -> Bool)
-> (Schedule ChainUpdate -> [ChainUpdate])
-> Schedule ChainUpdate
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schedule ChainUpdate -> [ChainUpdate]
forall a. Schedule a -> [a]
joinSchedule) ([Schedule ChainUpdate] -> [Schedule ChainUpdate])
-> [Schedule ChainUpdate] -> [Schedule ChainUpdate]
forall a b. (a -> b) -> a -> b
$
            Schedule ChainUpdate -> [Schedule ChainUpdate]
forall a. Schedule a -> [Schedule a]
shrinkSchedule (Map PeerId (Schedule ChainUpdate)
peerUpdates Map PeerId (Schedule ChainUpdate) -> PeerId -> Schedule ChainUpdate
forall k a. Ord k => Map k a -> k -> a
Map.! PeerId
peerId)
      ]
    where
      peerIds :: [PeerId]
peerIds = Map PeerId (Schedule ChainUpdate) -> [PeerId]
forall k a. Map k a -> [k]
Map.keys Map PeerId (Schedule ChainUpdate)
peerUpdates

newtype PeerId = PeerId Int
  deriving stock (Int -> PeerId -> String -> String
[PeerId] -> String -> String
PeerId -> String
(Int -> PeerId -> String -> String)
-> (PeerId -> String)
-> ([PeerId] -> String -> String)
-> Show PeerId
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> PeerId -> String -> String
showsPrec :: Int -> PeerId -> String -> String
$cshow :: PeerId -> String
show :: PeerId -> String
$cshowList :: [PeerId] -> String -> String
showList :: [PeerId] -> String -> String
Show, PeerId -> PeerId -> Bool
(PeerId -> PeerId -> Bool)
-> (PeerId -> PeerId -> Bool) -> Eq PeerId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PeerId -> PeerId -> Bool
== :: PeerId -> PeerId -> Bool
$c/= :: PeerId -> PeerId -> Bool
/= :: PeerId -> PeerId -> Bool
Eq, Eq PeerId
Eq PeerId =>
(PeerId -> PeerId -> Ordering)
-> (PeerId -> PeerId -> Bool)
-> (PeerId -> PeerId -> Bool)
-> (PeerId -> PeerId -> Bool)
-> (PeerId -> PeerId -> Bool)
-> (PeerId -> PeerId -> PeerId)
-> (PeerId -> PeerId -> PeerId)
-> Ord PeerId
PeerId -> PeerId -> Bool
PeerId -> PeerId -> Ordering
PeerId -> PeerId -> PeerId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PeerId -> PeerId -> Ordering
compare :: PeerId -> PeerId -> Ordering
$c< :: PeerId -> PeerId -> Bool
< :: PeerId -> PeerId -> Bool
$c<= :: PeerId -> PeerId -> Bool
<= :: PeerId -> PeerId -> Bool
$c> :: PeerId -> PeerId -> Bool
> :: PeerId -> PeerId -> Bool
$c>= :: PeerId -> PeerId -> Bool
>= :: PeerId -> PeerId -> Bool
$cmax :: PeerId -> PeerId -> PeerId
max :: PeerId -> PeerId -> PeerId
$cmin :: PeerId -> PeerId -> PeerId
min :: PeerId -> PeerId -> PeerId
Ord)
  deriving newtype (PeerId -> String
(PeerId -> String) -> Condense PeerId
forall a. (a -> String) -> Condense a
$ccondense :: PeerId -> String
condense :: PeerId -> String
Condense, Eq PeerId
Eq PeerId =>
(Int -> PeerId -> Int) -> (PeerId -> Int) -> Hashable PeerId
Int -> PeerId -> Int
PeerId -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> PeerId -> Int
hashWithSalt :: Int -> PeerId -> Int
$chash :: PeerId -> Int
hash :: PeerId -> Int
Hashable, Int -> PeerId
PeerId -> Int
PeerId -> [PeerId]
PeerId -> PeerId
PeerId -> PeerId -> [PeerId]
PeerId -> PeerId -> PeerId -> [PeerId]
(PeerId -> PeerId)
-> (PeerId -> PeerId)
-> (Int -> PeerId)
-> (PeerId -> Int)
-> (PeerId -> [PeerId])
-> (PeerId -> PeerId -> [PeerId])
-> (PeerId -> PeerId -> [PeerId])
-> (PeerId -> PeerId -> PeerId -> [PeerId])
-> Enum PeerId
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: PeerId -> PeerId
succ :: PeerId -> PeerId
$cpred :: PeerId -> PeerId
pred :: PeerId -> PeerId
$ctoEnum :: Int -> PeerId
toEnum :: Int -> PeerId
$cfromEnum :: PeerId -> Int
fromEnum :: PeerId -> Int
$cenumFrom :: PeerId -> [PeerId]
enumFrom :: PeerId -> [PeerId]
$cenumFromThen :: PeerId -> PeerId -> [PeerId]
enumFromThen :: PeerId -> PeerId -> [PeerId]
$cenumFromTo :: PeerId -> PeerId -> [PeerId]
enumFromTo :: PeerId -> PeerId -> [PeerId]
$cenumFromThenTo :: PeerId -> PeerId -> PeerId -> [PeerId]
enumFromThenTo :: PeerId -> PeerId -> PeerId -> [PeerId]
Enum, PeerId
PeerId -> PeerId -> Bounded PeerId
forall a. a -> a -> Bounded a
$cminBound :: PeerId
minBound :: PeerId
$cmaxBound :: PeerId
maxBound :: PeerId
Bounded)

{-------------------------------------------------------------------------------
  Utilities
-------------------------------------------------------------------------------}

infiniteDelay :: MonadSTM m => m a
infiniteDelay :: forall (m :: * -> *) a. MonadSTM m => m a
infiniteDelay = STM m a -> m a
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m a
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry

chainToAnchoredFragment :: HasHeader blk => Chain blk -> AnchoredFragment blk
chainToAnchoredFragment :: forall blk. HasHeader blk => Chain blk -> AnchoredFragment blk
chainToAnchoredFragment =
    Anchor blk
-> [blk] -> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
AF.fromOldestFirst Anchor blk
forall block. Anchor block
AF.AnchorGenesis ([blk] -> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk)
-> (Chain blk -> [blk])
-> Chain blk
-> AnchoredSeq (WithOrigin SlotNo) (Anchor blk) blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain blk -> [blk]
forall block. Chain block -> [block]
Chain.toOldestFirst