{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | Helpers for tracing used by the peer simulator.
module Test.Consensus.PeerSimulator.Trace (
    TraceBlockFetchClientTerminationEvent (..)
  , TraceChainSyncClientTerminationEvent (..)
  , TraceEvent (..)
  , TraceScheduledBlockFetchServerEvent (..)
  , TraceScheduledChainSyncServerEvent (..)
  , TraceScheduledServerHandlerEvent (..)
  , TraceSchedulerEvent (..)
  , mkGDDTracerTestBlock
  , prettyDensityBounds
  , traceLinesWith
  , tracerTestBlock
  ) where

import           Control.Tracer (Tracer (Tracer), contramap, traceWith)
import           Data.Bifunctor (second)
import           Data.List (intersperse)
import qualified Data.List.NonEmpty as NE
import           Data.Time.Clock (DiffTime, diffTimeToPicoseconds)
import           Network.TypedProtocol.Codec (AnyMessage (..))
import           Ouroboros.Consensus.Block (GenesisWindow (..), Header, Point,
                     WithOrigin (NotOrigin, Origin), succWithOrigin)
import           Ouroboros.Consensus.Genesis.Governor (DensityBounds (..),
                     GDDDebugInfo (..), TraceGDDEvent (..))
import           Ouroboros.Consensus.HeaderValidation (HeaderWithTime (..))
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                     (TraceChainSyncClientEvent (..))
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping
                     (Instruction (..), JumpInstruction (..), JumpResult (..),
                     TraceCsjReason (..), TraceEventCsj (..),
                     TraceEventDbf (..))
import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State
                     (ChainSyncJumpingJumperState (..),
                     ChainSyncJumpingState (..), DynamoInitState (..),
                     JumpInfo (..))
import           Ouroboros.Consensus.Storage.ChainDB.API (LoE (..))
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB
import           Ouroboros.Consensus.Storage.ChainDB.Impl.Types
                     (TraceAddBlockEvent (..))
import           Ouroboros.Consensus.Util.Condense (condense)
import           Ouroboros.Consensus.Util.Enclose
import           Ouroboros.Consensus.Util.IOLike (IOLike, MonadMonotonicTime,
                     Time (Time), atomically, getMonotonicTime, readTVarIO,
                     uncheckedNewTVarM, writeTVar)
import           Ouroboros.Network.AnchoredFragment (AnchoredFragment,
                     headPoint)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block (SlotNo (SlotNo), Tip, castPoint)
import           Ouroboros.Network.Driver.Simple (TraceSendRecv (..))
import           Ouroboros.Network.Protocol.ChainSync.Type (ChainSync,
                     Message (..))
import           Test.Consensus.PointSchedule.NodeState (NodeState)
import           Test.Consensus.PointSchedule.Peers (Peer (Peer), PeerId)
import           Test.Util.TersePrinting (terseAnchor, terseBlock,
                     terseFragment, terseHFragment, terseHWTFragment,
                     terseHeader, tersePoint, terseRealPoint, terseTip,
                     terseWithOrigin)
import           Test.Util.TestBlock (TestBlock)
import           Text.Printf (printf)

-- * Trace events for the peer simulator

-- | Trace messages sent by the scheduler.
data TraceSchedulerEvent blk
  = -- | Right before running the first tick (at time @0@) of the schedule.
    TraceBeginningOfTime
  | -- | Right after running the last tick of the schedule.
    TraceEndOfTime
  | -- | An extra optional delay to keep the simulation running
    TraceExtraDelay DiffTime
  | -- | When beginning a new tick. Contains the tick number (counting from
    -- @0@), the duration of the tick, the states, the current chain, the
    -- candidate fragment, and the jumping states.
    forall m. TraceNewTick
      Int
      DiffTime
      (Peer (NodeState blk))
      (AnchoredFragment (Header blk))
      (Maybe (AnchoredFragment (Header blk)))
      [(PeerId, ChainSyncJumpingState m blk)]
  | TraceNodeShutdownStart (WithOrigin SlotNo)
  | TraceNodeShutdownComplete
  | TraceNodeStartupStart
  | TraceNodeStartupComplete (AnchoredFragment (Header blk))

type HandlerName = String

data TraceScheduledServerHandlerEvent state blk
  = TraceHandling HandlerName state
  | TraceRestarting HandlerName
  | TraceDoneHandling HandlerName

data TraceScheduledChainSyncServerEvent state blk
  = TraceHandlerEventCS (TraceScheduledServerHandlerEvent state blk)
  | TraceLastIntersection (Point blk)
  | TraceClientIsDone
  | TraceIntersectionFound (Point blk)
  | TraceIntersectionNotFound
  | TraceRollForward (Header blk) (Tip blk)
  | TraceRollBackward (Point blk) (Tip blk)
  | TraceChainIsFullyServed
  | TraceIntersectionIsHeaderPoint
  | TraceIntersectionIsStrictAncestorOfHeaderPoint (AnchoredFragment blk)
  | TraceIntersectionIsStrictDescendentOfHeaderPoint

data TraceScheduledBlockFetchServerEvent state blk
  = TraceHandlerEventBF (TraceScheduledServerHandlerEvent state blk)
  | TraceNoBlocks
  | TraceStartingBatch (AnchoredFragment blk)
  | TraceWaitingForRange (Point blk) (Point blk)
  | TraceSendingBlock blk
  | TraceBatchIsDone
  | TraceBlockPointIsBehind

data TraceChainSyncClientTerminationEvent
  = TraceExceededSizeLimitCS
  | TraceExceededTimeLimitCS
  | TraceTerminatedByGDDGovernor
  | TraceTerminatedByLoP

data TraceBlockFetchClientTerminationEvent
  = TraceExceededSizeLimitBF
  | TraceExceededTimeLimitBF

data TraceEvent blk
  = TraceSchedulerEvent (TraceSchedulerEvent blk)
  | TraceScheduledChainSyncServerEvent PeerId (TraceScheduledChainSyncServerEvent (NodeState blk) blk)
  | TraceScheduledBlockFetchServerEvent PeerId (TraceScheduledBlockFetchServerEvent (NodeState blk) blk)
  | TraceChainDBEvent (ChainDB.TraceEvent blk)
  | TraceChainSyncClientEvent PeerId (TraceChainSyncClientEvent blk)
  | TraceChainSyncClientTerminationEvent PeerId TraceChainSyncClientTerminationEvent
  | TraceBlockFetchClientTerminationEvent PeerId TraceBlockFetchClientTerminationEvent
  | TraceGenesisDDEvent (TraceGDDEvent PeerId blk)
  | TraceChainSyncSendRecvEvent PeerId String (TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)))
  | TraceDbfEvent (TraceEventDbf PeerId)
  | TraceCsjEvent PeerId (TraceEventCsj PeerId blk)
  | TraceOther String

-- * 'TestBlock'-specific tracers for the peer simulator

tracerTestBlock ::
  (IOLike m) =>
  Tracer m String ->
  m (Tracer m (TraceEvent TestBlock))
tracerTestBlock :: forall (m :: * -> *).
IOLike m =>
Tracer m String -> m (Tracer m (TraceEvent TestBlock))
tracerTestBlock Tracer m String
tracer0 = do
  -- NOTE: Mostly, we read the traces on a per-tick basis, so it is important
  -- that ticks are visually separated. Also, giving the time on each line can
  -- get quite verbose when most of the time is the same as the beginning of the
  -- tick (in IOSim anyways). So we keep track of the tick time and we prefix
  -- lines by the time only if they differ. This allows seeing the time-based
  -- events (timeouts, LoP) better while keeping the interface uncluttered, and
  -- it behaves well in IO (where it prefixes all lines by the time).
  tickTimeVar <- Time -> m (StrictTVar m Time)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
uncheckedNewTVarM (Time -> m (StrictTVar m Time)) -> Time -> m (StrictTVar m Time)
forall a b. (a -> b) -> a -> b
$ DiffTime -> Time
Time (-DiffTime
1)
  let setTickTime = 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 ()) -> (Time -> STM m ()) -> Time -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictTVar m Time -> Time -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m Time
tickTimeVar
      tracer = (String -> m ()) -> Tracer m String
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((String -> m ()) -> Tracer m String)
-> (String -> m ()) -> Tracer m String
forall a b. (a -> b) -> a -> b
$ \String
msg -> do
        time <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
        tickTime <- readTVarIO tickTimeVar
        let timeHeader = Time -> String
prettyTime Time
time String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
            prefix = if Time
time Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
/= Time
tickTime
              then String
timeHeader
              else Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
timeHeader) Char
' '
        traceWith tracer0 $ concat $ intersperse "\n" $ map (prefix ++) $ lines msg
  pure $ Tracer $ traceEventTestBlockWith setTickTime tracer0 tracer

mkGDDTracerTestBlock ::
  Tracer m (TraceEvent TestBlock) ->
  Tracer m (TraceGDDEvent PeerId TestBlock)
mkGDDTracerTestBlock :: forall (m :: * -> *).
Tracer m (TraceEvent TestBlock)
-> Tracer m (TraceGDDEvent PeerId TestBlock)
mkGDDTracerTestBlock = (TraceGDDEvent PeerId TestBlock -> TraceEvent TestBlock)
-> Tracer m (TraceEvent TestBlock)
-> Tracer m (TraceGDDEvent PeerId TestBlock)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap TraceGDDEvent PeerId TestBlock -> TraceEvent TestBlock
forall blk. TraceGDDEvent PeerId blk -> TraceEvent blk
TraceGenesisDDEvent

traceEventTestBlockWith ::
  (MonadMonotonicTime m) =>
  (Time -> m ()) ->
  Tracer m String ->
  -- ^ Underlying, non-time- and tick-aware tracer. To be used only with lines
  -- that should not be prefixed by time.
  Tracer m String ->
  -- ^ Normal, time- and tick-aware tracer. Should be used by default.
  TraceEvent TestBlock ->
  m ()
traceEventTestBlockWith :: forall (m :: * -> *).
MonadMonotonicTime m =>
(Time -> m ())
-> Tracer m String
-> Tracer m String
-> TraceEvent TestBlock
-> m ()
traceEventTestBlockWith Time -> m ()
setTickTime Tracer m String
tracer0 Tracer m String
tracer = \case
    TraceSchedulerEvent TraceSchedulerEvent TestBlock
traceEvent -> (Time -> m ())
-> Tracer m String
-> Tracer m String
-> TraceSchedulerEvent TestBlock
-> m ()
forall (m :: * -> *).
MonadMonotonicTime m =>
(Time -> m ())
-> Tracer m String
-> Tracer m String
-> TraceSchedulerEvent TestBlock
-> m ()
traceSchedulerEventTestBlockWith Time -> m ()
setTickTime Tracer m String
tracer0 Tracer m String
tracer TraceSchedulerEvent TestBlock
traceEvent
    TraceScheduledChainSyncServerEvent PeerId
peerId TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
traceEvent -> Tracer m String
-> PeerId
-> TraceScheduledChainSyncServerEvent
     (NodeState TestBlock) TestBlock
-> m ()
forall (m :: * -> *).
Tracer m String
-> PeerId
-> TraceScheduledChainSyncServerEvent
     (NodeState TestBlock) TestBlock
-> m ()
traceScheduledChainSyncServerEventTestBlockWith Tracer m String
tracer PeerId
peerId TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
traceEvent
    TraceScheduledBlockFetchServerEvent PeerId
peerId TraceScheduledBlockFetchServerEvent (NodeState TestBlock) TestBlock
traceEvent -> Tracer m String
-> PeerId
-> TraceScheduledBlockFetchServerEvent
     (NodeState TestBlock) TestBlock
-> m ()
forall (m :: * -> *).
Tracer m String
-> PeerId
-> TraceScheduledBlockFetchServerEvent
     (NodeState TestBlock) TestBlock
-> m ()
traceScheduledBlockFetchServerEventTestBlockWith Tracer m String
tracer PeerId
peerId TraceScheduledBlockFetchServerEvent (NodeState TestBlock) TestBlock
traceEvent
    TraceChainDBEvent TraceEvent TestBlock
traceEvent -> Tracer m String -> TraceEvent TestBlock -> m ()
forall (m :: * -> *).
Monad m =>
Tracer m String -> TraceEvent TestBlock -> m ()
traceChainDBEventTestBlockWith Tracer m String
tracer TraceEvent TestBlock
traceEvent
    TraceChainSyncClientEvent PeerId
peerId TraceChainSyncClientEvent TestBlock
traceEvent -> PeerId
-> Tracer m String -> TraceChainSyncClientEvent TestBlock -> m ()
forall (m :: * -> *).
PeerId
-> Tracer m String -> TraceChainSyncClientEvent TestBlock -> m ()
traceChainSyncClientEventTestBlockWith PeerId
peerId Tracer m String
tracer TraceChainSyncClientEvent TestBlock
traceEvent
    TraceChainSyncClientTerminationEvent PeerId
peerId TraceChainSyncClientTerminationEvent
traceEvent -> PeerId
-> Tracer m String -> TraceChainSyncClientTerminationEvent -> m ()
forall (m :: * -> *).
PeerId
-> Tracer m String -> TraceChainSyncClientTerminationEvent -> m ()
traceChainSyncClientTerminationEventTestBlockWith PeerId
peerId Tracer m String
tracer TraceChainSyncClientTerminationEvent
traceEvent
    TraceBlockFetchClientTerminationEvent PeerId
peerId TraceBlockFetchClientTerminationEvent
traceEvent -> PeerId
-> Tracer m String -> TraceBlockFetchClientTerminationEvent -> m ()
forall (m :: * -> *).
PeerId
-> Tracer m String -> TraceBlockFetchClientTerminationEvent -> m ()
traceBlockFetchClientTerminationEventTestBlockWith PeerId
peerId Tracer m String
tracer TraceBlockFetchClientTerminationEvent
traceEvent
    TraceGenesisDDEvent TraceGDDEvent PeerId TestBlock
gddEvent -> Tracer m String -> String -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m String
tracer (TraceGDDEvent PeerId TestBlock -> String
terseGDDEvent TraceGDDEvent PeerId TestBlock
gddEvent)
    TraceChainSyncSendRecvEvent PeerId
peerId String
peerType TraceSendRecv
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
traceEvent -> PeerId
-> String
-> Tracer m String
-> TraceSendRecv
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
-> m ()
forall (m :: * -> *).
Applicative m =>
PeerId
-> String
-> Tracer m String
-> TraceSendRecv
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
-> m ()
traceChainSyncSendRecvEventTestBlockWith PeerId
peerId String
peerType Tracer m String
tracer TraceSendRecv
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
traceEvent
    TraceDbfEvent TraceEventDbf PeerId
traceEvent -> Tracer m String -> TraceEventDbf PeerId -> m ()
forall (m :: * -> *).
Tracer m String -> TraceEventDbf PeerId -> m ()
traceDbjEventWith Tracer m String
tracer TraceEventDbf PeerId
traceEvent
    TraceCsjEvent PeerId
peerId TraceEventCsj PeerId TestBlock
traceEvent -> PeerId -> Tracer m String -> TraceEventCsj PeerId TestBlock -> m ()
forall (m :: * -> *).
PeerId -> Tracer m String -> TraceEventCsj PeerId TestBlock -> m ()
traceCsjEventWith PeerId
peerId Tracer m String
tracer TraceEventCsj PeerId TestBlock
traceEvent
    TraceOther String
msg -> Tracer m String -> String -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m String
tracer String
msg

traceSchedulerEventTestBlockWith ::
  (MonadMonotonicTime m) =>
  (Time -> m ()) ->
  Tracer m String ->
  Tracer m String ->
  TraceSchedulerEvent TestBlock ->
  m ()
traceSchedulerEventTestBlockWith :: forall (m :: * -> *).
MonadMonotonicTime m =>
(Time -> m ())
-> Tracer m String
-> Tracer m String
-> TraceSchedulerEvent TestBlock
-> m ()
traceSchedulerEventTestBlockWith Time -> m ()
setTickTime Tracer m String
tracer0 Tracer m String
tracer = \case
    TraceSchedulerEvent TestBlock
TraceBeginningOfTime ->
      Tracer m String -> String -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m String
tracer0 String
"Running point schedule ..."
    TraceSchedulerEvent TestBlock
TraceEndOfTime ->
      Tracer m String -> [String] -> m ()
forall (m :: * -> *). Tracer m String -> [String] -> m ()
traceLinesWith Tracer m String
tracer0
        [ String
"╶──────────────────────────────────────────────────────────────────────────────╴",
          String
"Finished running point schedule"
        ]
    TraceExtraDelay DiffTime
delay -> do
      time <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
      traceLinesWith tracer0
        [ "┌──────────────────────────────────────────────────────────────────────────────┐",
          "└─ " ++ prettyTime time,
          "Waiting an extra delay to keep the simulation running for: " ++ prettyTime (Time delay)
        ]
    TraceNewTick Int
number DiffTime
duration (Peer PeerId
pid NodeState TestBlock
state) AnchoredFragment (Header TestBlock)
currentChain Maybe (AnchoredFragment (Header TestBlock))
mCandidateFrag [(PeerId, ChainSyncJumpingState m TestBlock)]
jumpingStates -> do
      time <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
      setTickTime time
      traceLinesWith tracer0
        [ "┌──────────────────────────────────────────────────────────────────────────────┐",
          "└─ " ++ prettyTime time,
          "Tick:",
          "  number: " ++ show number,
          "  duration: " ++ show duration,
          "  peer: " ++ condense pid,
          "  state: " ++ condense state,
          "  current chain: " ++ terseHFragment currentChain,
          "  candidate fragment: " ++ maybe "Nothing" terseHFragment mCandidateFrag,
          "  jumping states:\n" ++ traceJumpingStates jumpingStates
        ]
    TraceNodeShutdownStart WithOrigin SlotNo
immTip ->
      Tracer m String -> String -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m String
tracer (String
"  Initiating node shutdown with immutable tip at slot " String -> String -> String
forall a. [a] -> [a] -> [a]
++ WithOrigin SlotNo -> String
forall a. Condense a => a -> String
condense WithOrigin SlotNo
immTip)
    TraceSchedulerEvent TestBlock
TraceNodeShutdownComplete ->
      Tracer m String -> String -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m String
tracer String
"  Node shutdown complete"
    TraceSchedulerEvent TestBlock
TraceNodeStartupStart ->
      Tracer m String -> String -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m String
tracer String
"  Initiating node startup"
    TraceNodeStartupComplete AnchoredFragment (Header TestBlock)
selection ->
      Tracer m String -> String -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m String
tracer (String
"  Node startup complete with selection " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredFragment (Header TestBlock) -> String
terseHFragment AnchoredFragment (Header TestBlock)
selection)

  where
    traceJumpingStates :: [(PeerId, ChainSyncJumpingState m TestBlock)] -> String
    traceJumpingStates :: forall (m :: * -> *).
[(PeerId, ChainSyncJumpingState m TestBlock)] -> String
traceJumpingStates = [String] -> String
unlines ([String] -> String)
-> ([(PeerId, ChainSyncJumpingState m TestBlock)] -> [String])
-> [(PeerId, ChainSyncJumpingState m TestBlock)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PeerId, ChainSyncJumpingState m TestBlock) -> String)
-> [(PeerId, ChainSyncJumpingState m TestBlock)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(PeerId
pid, ChainSyncJumpingState m TestBlock
state) -> String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PeerId -> String
forall a. Condense a => a -> String
condense PeerId
pid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ChainSyncJumpingState m TestBlock -> String
forall (m :: * -> *). ChainSyncJumpingState m TestBlock -> String
traceJumpingState ChainSyncJumpingState m TestBlock
state)

    traceJumpingState :: ChainSyncJumpingState m TestBlock -> String
    traceJumpingState :: forall (m :: * -> *). ChainSyncJumpingState m TestBlock -> String
traceJumpingState = \case
      Dynamo DynamoInitState TestBlock
initState WithOrigin SlotNo
lastJump ->
        let showInitState :: String
showInitState = case DynamoInitState TestBlock
initState of
              DynamoStarting JumpInfo TestBlock
ji -> String
"(DynamoStarting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ JumpInfo TestBlock -> String
terseJumpInfo JumpInfo TestBlock
ji String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
              DynamoInitState TestBlock
DynamoStarted     -> String
"DynamoStarted"
         in [String] -> String
unwords [String
"Dynamo", String
showInitState, (SlotNo -> String) -> WithOrigin SlotNo -> String
forall a. (a -> String) -> WithOrigin a -> String
terseWithOrigin SlotNo -> String
forall a. Show a => a -> String
show WithOrigin SlotNo
lastJump]
      Objector ObjectorInitState
initState JumpInfo TestBlock
goodJumpInfo Point (Header TestBlock)
badPoint -> [String] -> String
unwords
          [ String
"Objector"
          , ObjectorInitState -> String
forall a. Show a => a -> String
show ObjectorInitState
initState
          , JumpInfo TestBlock -> String
terseJumpInfo JumpInfo TestBlock
goodJumpInfo
          , Point TestBlock -> String
tersePoint (Point (Header TestBlock) -> Point TestBlock
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point (Header TestBlock)
badPoint)
          ]
      Disengaged DisengagedInitState
initState -> String
"Disengaged " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DisengagedInitState -> String
forall a. Show a => a -> String
show DisengagedInitState
initState
      Jumper StrictTVar m (Maybe (JumpInfo TestBlock))
_ ChainSyncJumpingJumperState TestBlock
st -> String
"Jumper _ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ChainSyncJumpingJumperState TestBlock -> String
traceJumperState ChainSyncJumpingJumperState TestBlock
st

    traceJumperState :: ChainSyncJumpingJumperState TestBlock -> String
    traceJumperState :: ChainSyncJumpingJumperState TestBlock -> String
traceJumperState = \case
      Happy JumperInitState
initState Maybe (JumpInfo TestBlock)
mGoodJumpInfo ->
        String
"Happy " String -> String -> String
forall a. [a] -> [a] -> [a]
++ JumperInitState -> String
forall a. Show a => a -> String
show JumperInitState
initState String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
-> (JumpInfo TestBlock -> String)
-> Maybe (JumpInfo TestBlock)
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"Nothing" JumpInfo TestBlock -> String
terseJumpInfo Maybe (JumpInfo TestBlock)
mGoodJumpInfo
      FoundIntersection ObjectorInitState
initState JumpInfo TestBlock
goodJumpInfo Point (Header TestBlock)
point -> [String] -> String
unwords
        [ String
"(FoundIntersection"
        , ObjectorInitState -> String
forall a. Show a => a -> String
show ObjectorInitState
initState
        , JumpInfo TestBlock -> String
terseJumpInfo JumpInfo TestBlock
goodJumpInfo
        , Point TestBlock -> String
tersePoint (Point TestBlock -> String) -> Point TestBlock -> String
forall a b. (a -> b) -> a -> b
$ Point (Header TestBlock) -> Point TestBlock
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point (Header TestBlock)
point, String
")"
        ]
      LookingForIntersection JumpInfo TestBlock
goodJumpInfo JumpInfo TestBlock
badJumpInfo -> [String] -> String
unwords
        [String
"(LookingForIntersection", JumpInfo TestBlock -> String
terseJumpInfo JumpInfo TestBlock
goodJumpInfo, JumpInfo TestBlock -> String
terseJumpInfo JumpInfo TestBlock
badJumpInfo, String
")"]

traceScheduledServerHandlerEventTestBlockWith ::
  Tracer m String ->
  String ->
  TraceScheduledServerHandlerEvent (NodeState TestBlock) TestBlock ->
  m ()
traceScheduledServerHandlerEventTestBlockWith :: forall (m :: * -> *).
Tracer m String
-> String
-> TraceScheduledServerHandlerEvent (NodeState TestBlock) TestBlock
-> m ()
traceScheduledServerHandlerEventTestBlockWith Tracer m String
tracer String
unit = \case
    TraceHandling String
handler NodeState TestBlock
state ->
      [String] -> m ()
traceLines
        [ String
"handling " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
handler,
          String
"  state is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NodeState TestBlock -> String
forall a. Condense a => a -> String
condense NodeState TestBlock
state
        ]
    TraceRestarting String
_->
      String -> m ()
trace String
"  cannot serve at this point; waiting for node state and starting again"
    TraceDoneHandling String
handler ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"done handling " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
handler
  where
    trace :: String -> m ()
trace = Tracer m String -> String -> String -> m ()
forall (m :: * -> *). Tracer m String -> String -> String -> m ()
traceUnitWith Tracer m String
tracer String
unit
    traceLines :: [String] -> m ()
traceLines = Tracer m String -> String -> [String] -> m ()
forall (m :: * -> *). Tracer m String -> String -> [String] -> m ()
traceUnitLinesWith Tracer m String
tracer String
unit

traceScheduledChainSyncServerEventTestBlockWith ::
  Tracer m String ->
  PeerId ->
  TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock ->
  m ()
traceScheduledChainSyncServerEventTestBlockWith :: forall (m :: * -> *).
Tracer m String
-> PeerId
-> TraceScheduledChainSyncServerEvent
     (NodeState TestBlock) TestBlock
-> m ()
traceScheduledChainSyncServerEventTestBlockWith Tracer m String
tracer PeerId
peerId = \case
    TraceHandlerEventCS TraceScheduledServerHandlerEvent (NodeState TestBlock) TestBlock
traceEvent -> Tracer m String
-> String
-> TraceScheduledServerHandlerEvent (NodeState TestBlock) TestBlock
-> m ()
forall (m :: * -> *).
Tracer m String
-> String
-> TraceScheduledServerHandlerEvent (NodeState TestBlock) TestBlock
-> m ()
traceScheduledServerHandlerEventTestBlockWith Tracer m String
tracer String
unit TraceScheduledServerHandlerEvent (NodeState TestBlock) TestBlock
traceEvent
    TraceLastIntersection Point TestBlock
point ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"  last intersection is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point TestBlock -> String
tersePoint Point TestBlock
point
    TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
TraceClientIsDone ->
      String -> m ()
trace String
"received MsgDoneClient"
    TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
TraceIntersectionNotFound ->
      String -> m ()
trace String
"  no intersection found"
    TraceIntersectionFound Point TestBlock
point ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"  intersection found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point TestBlock -> String
tersePoint Point TestBlock
point
    TraceRollForward Header TestBlock
header Tip TestBlock
tip ->
      [String] -> m ()
traceLines [
        String
"  gotta serve " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Header TestBlock -> String
terseHeader Header TestBlock
header,
        String
"  tip is      " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Tip TestBlock -> String
terseTip Tip TestBlock
tip
      ]
    TraceRollBackward Point TestBlock
point Tip TestBlock
tip ->
      [String] -> m ()
traceLines [
        String
"  gotta roll back to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point TestBlock -> String
tersePoint Point TestBlock
point,
        String
"  new tip is      " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Tip TestBlock -> String
terseTip Tip TestBlock
tip
      ]
    TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
TraceChainIsFullyServed ->
      String -> m ()
trace String
"  chain has been fully served"
    TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
TraceIntersectionIsHeaderPoint ->
      String -> m ()
trace String
"  intersection is exactly our header point"
    TraceIntersectionIsStrictAncestorOfHeaderPoint AnchoredFragment TestBlock
fragment ->
      [String] -> m ()
traceLines
        [ String
"  intersection is before our header point",
          String
"  fragment ahead: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredFragment TestBlock -> String
terseFragment AnchoredFragment TestBlock
fragment
        ]
    TraceScheduledChainSyncServerEvent (NodeState TestBlock) TestBlock
TraceIntersectionIsStrictDescendentOfHeaderPoint ->
      String -> m ()
trace String
"  intersection is further than our header point"
  where
    unit :: String
unit = String
"ChainSyncServer " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PeerId -> String
forall a. Condense a => a -> String
condense PeerId
peerId
    trace :: String -> m ()
trace = Tracer m String -> String -> String -> m ()
forall (m :: * -> *). Tracer m String -> String -> String -> m ()
traceUnitWith Tracer m String
tracer String
unit
    traceLines :: [String] -> m ()
traceLines = Tracer m String -> String -> [String] -> m ()
forall (m :: * -> *). Tracer m String -> String -> [String] -> m ()
traceUnitLinesWith Tracer m String
tracer String
unit

traceScheduledBlockFetchServerEventTestBlockWith ::
  Tracer m String ->
  PeerId ->
  TraceScheduledBlockFetchServerEvent (NodeState TestBlock) TestBlock ->
  m ()
traceScheduledBlockFetchServerEventTestBlockWith :: forall (m :: * -> *).
Tracer m String
-> PeerId
-> TraceScheduledBlockFetchServerEvent
     (NodeState TestBlock) TestBlock
-> m ()
traceScheduledBlockFetchServerEventTestBlockWith Tracer m String
tracer PeerId
peerId = \case
    TraceHandlerEventBF TraceScheduledServerHandlerEvent (NodeState TestBlock) TestBlock
traceEvent -> Tracer m String
-> String
-> TraceScheduledServerHandlerEvent (NodeState TestBlock) TestBlock
-> m ()
forall (m :: * -> *).
Tracer m String
-> String
-> TraceScheduledServerHandlerEvent (NodeState TestBlock) TestBlock
-> m ()
traceScheduledServerHandlerEventTestBlockWith Tracer m String
tracer String
unit TraceScheduledServerHandlerEvent (NodeState TestBlock) TestBlock
traceEvent
    TraceScheduledBlockFetchServerEvent (NodeState TestBlock) TestBlock
TraceNoBlocks ->
      String -> m ()
trace String
"  no blocks available"
    TraceStartingBatch AnchoredFragment TestBlock
fragment ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Starting batch for slice " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredFragment TestBlock -> String
terseFragment AnchoredFragment TestBlock
fragment
    TraceWaitingForRange Point TestBlock
pointFrom Point TestBlock
pointTo ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Waiting for next tick for range: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point TestBlock -> String
tersePoint Point TestBlock
pointFrom String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point TestBlock -> String
tersePoint Point TestBlock
pointTo
    TraceSendingBlock TestBlock
block ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Sending " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TestBlock -> String
terseBlock TestBlock
block
    TraceScheduledBlockFetchServerEvent (NodeState TestBlock) TestBlock
TraceBatchIsDone ->
      String -> m ()
trace String
"Batch is done"
    TraceScheduledBlockFetchServerEvent (NodeState TestBlock) TestBlock
TraceBlockPointIsBehind ->
      String -> m ()
trace String
"BP is behind"
  where
    unit :: String
unit = String
"BlockFetchServer " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PeerId -> String
forall a. Condense a => a -> String
condense PeerId
peerId
    trace :: String -> m ()
trace = Tracer m String -> String -> String -> m ()
forall (m :: * -> *). Tracer m String -> String -> String -> m ()
traceUnitWith Tracer m String
tracer String
unit

traceChainDBEventTestBlockWith ::
  (Monad m) =>
  Tracer m String ->
  ChainDB.TraceEvent TestBlock ->
  m ()
traceChainDBEventTestBlockWith :: forall (m :: * -> *).
Monad m =>
Tracer m String -> TraceEvent TestBlock -> m ()
traceChainDBEventTestBlockWith Tracer m String
tracer = \case
    ChainDB.TraceAddBlockEvent TraceAddBlockEvent TestBlock
event ->
      case TraceAddBlockEvent TestBlock
event of
        AddedToCurrentChain [LedgerEvent TestBlock]
_ SelectionChangedInfo TestBlock
_ AnchoredFragment (Header TestBlock)
_ AnchoredFragment (Header TestBlock)
newFragment ->
          String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Added to current chain; now: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredFragment (Header TestBlock) -> String
terseHFragment AnchoredFragment (Header TestBlock)
newFragment
        SwitchedToAFork [LedgerEvent TestBlock]
_ SelectionChangedInfo TestBlock
_ AnchoredFragment (Header TestBlock)
_ AnchoredFragment (Header TestBlock)
newFragment ->
          String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Switched to a fork; now: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredFragment (Header TestBlock) -> String
terseHFragment AnchoredFragment (Header TestBlock)
newFragment
        StoreButDontChange RealPoint TestBlock
point ->
          String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Did not select block due to LoE: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RealPoint TestBlock -> String
terseRealPoint RealPoint TestBlock
point
        IgnoreBlockOlderThanK RealPoint TestBlock
point ->
          String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Ignored block older than k: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RealPoint TestBlock -> String
terseRealPoint RealPoint TestBlock
point
        ChainSelectionLoEDebug AnchoredFragment (Header TestBlock)
curChain (LoEEnabled AnchoredFragment (Header TestBlock)
loeFrag0) -> do
          String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Current chain: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredFragment (Header TestBlock) -> String
terseHFragment AnchoredFragment (Header TestBlock)
curChain
          String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"LoE fragment: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredFragment (Header TestBlock) -> String
terseHFragment AnchoredFragment (Header TestBlock)
loeFrag0
        ChainSelectionLoEDebug AnchoredFragment (Header TestBlock)
_ LoE (AnchoredFragment (Header TestBlock))
LoEDisabled ->
          () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        TraceAddBlockEvent TestBlock
AddedReprocessLoEBlocksToQueue ->
          String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Requested ChainSel run"
        TraceAddBlockEvent TestBlock
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    ChainDB.TraceChainSelStarvationEvent (ChainDB.ChainSelStarvation Enclosing' (RealPoint TestBlock)
RisingEdge) ->
      String -> m ()
trace String
"ChainSel starvation started"
    ChainDB.TraceChainSelStarvationEvent (ChainDB.ChainSelStarvation (FallingEdgeWith RealPoint TestBlock
pt)) ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"ChainSel starvation ended thanks to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RealPoint TestBlock -> String
terseRealPoint RealPoint TestBlock
pt
    TraceEvent TestBlock
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    trace :: String -> m ()
trace = Tracer m String -> String -> String -> m ()
forall (m :: * -> *). Tracer m String -> String -> String -> m ()
traceUnitWith Tracer m String
tracer String
"ChainDB"

traceChainSyncClientEventTestBlockWith ::
  PeerId ->
  Tracer m String ->
  TraceChainSyncClientEvent TestBlock ->
  m ()
traceChainSyncClientEventTestBlockWith :: forall (m :: * -> *).
PeerId
-> Tracer m String -> TraceChainSyncClientEvent TestBlock -> m ()
traceChainSyncClientEventTestBlockWith PeerId
pid Tracer m String
tracer = \case
    TraceRolledBack Point TestBlock
point ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Rolled back to: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point TestBlock -> String
tersePoint Point TestBlock
point
    TraceFoundIntersection Point TestBlock
point Our (Tip TestBlock)
_ourTip Their (Tip TestBlock)
_theirTip ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Found intersection at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point TestBlock -> String
tersePoint Point TestBlock
point
    TraceWaitingBeyondForecastHorizon SlotNo
slot ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Waiting for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SlotNo -> String
forall a. Show a => a -> String
show SlotNo
slot String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" beyond forecast horizon"
    TraceAccessingForecastHorizon SlotNo
slot ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Accessing " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SlotNo -> String
forall a. Show a => a -> String
show SlotNo
slot String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", previously beyond forecast horizon"
    TraceValidatedHeader Header TestBlock
header ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Validated header: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Header TestBlock -> String
terseHeader Header TestBlock
header
    TraceDownloadedHeader Header TestBlock
header ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Downloaded header: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Header TestBlock -> String
terseHeader Header TestBlock
header
    TraceGaveLoPToken Bool
didGive Header TestBlock
header BlockNo
bestBlockNo ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
        (if Bool
didGive then String
"Gave" else String
"Did not give")
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" LoP token to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Header TestBlock -> String
terseHeader Header TestBlock
header
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" compared to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ BlockNo -> String
forall a. Show a => a -> String
show BlockNo
bestBlockNo
    TraceException ChainSyncClientException
exception ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Threw an exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ChainSyncClientException -> String
forall a. Show a => a -> String
show ChainSyncClientException
exception
    TraceTermination ChainSyncClientResult
result ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Terminated with result: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ChainSyncClientResult -> String
forall a. Show a => a -> String
show ChainSyncClientResult
result
    TraceOfferJump Point TestBlock
point ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Offering jump to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point TestBlock -> String
tersePoint Point TestBlock
point
    TraceJumpResult (AcceptedJump (JumpTo JumpInfo TestBlock
ji)) ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Accepted jump to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ JumpInfo TestBlock -> String
terseJumpInfo JumpInfo TestBlock
ji
    TraceJumpResult (RejectedJump (JumpTo JumpInfo TestBlock
ji)) ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Rejected jump to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ JumpInfo TestBlock -> String
terseJumpInfo JumpInfo TestBlock
ji
    TraceJumpResult (AcceptedJump (JumpToGoodPoint JumpInfo TestBlock
ji)) ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Accepted jump to good point: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ JumpInfo TestBlock -> String
terseJumpInfo JumpInfo TestBlock
ji
    TraceJumpResult (RejectedJump (JumpToGoodPoint JumpInfo TestBlock
ji)) ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Rejected jump to good point: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ JumpInfo TestBlock -> String
terseJumpInfo JumpInfo TestBlock
ji
    TraceChainSyncClientEvent TestBlock
TraceJumpingWaitingForNextInstruction ->
      String -> m ()
trace String
"Waiting for next instruction from the jumping governor"
    TraceJumpingInstructionIs Instruction TestBlock
instr ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Received instruction: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Instruction TestBlock -> String
showInstr Instruction TestBlock
instr
    TraceDrainingThePipe Nat n
n ->
      String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Draining the pipe, remaining messages: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Nat n -> String
forall a. Show a => a -> String
show Nat n
n
  where
    trace :: String -> m ()
trace = Tracer m String -> String -> String -> m ()
forall (m :: * -> *). Tracer m String -> String -> String -> m ()
traceUnitWith Tracer m String
tracer (String
"ChainSyncClient " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PeerId -> String
forall a. Condense a => a -> String
condense PeerId
pid)

    showInstr :: Instruction TestBlock -> String
    showInstr :: Instruction TestBlock -> String
showInstr = \case
      JumpInstruction (JumpTo JumpInfo TestBlock
ji) -> String
"JumpTo " String -> String -> String
forall a. [a] -> [a] -> [a]
++ JumpInfo TestBlock -> String
terseJumpInfo JumpInfo TestBlock
ji
      JumpInstruction (JumpToGoodPoint JumpInfo TestBlock
ji) -> String
"JumpToGoodPoint " String -> String -> String
forall a. [a] -> [a] -> [a]
++ JumpInfo TestBlock -> String
terseJumpInfo JumpInfo TestBlock
ji
      Instruction TestBlock
RunNormally -> String
"RunNormally"
      Instruction TestBlock
Restart -> String
"Restart"

terseJumpInfo :: JumpInfo TestBlock -> String
terseJumpInfo :: JumpInfo TestBlock -> String
terseJumpInfo JumpInfo TestBlock
ji = Point TestBlock -> String
tersePoint (Point (HeaderWithTime TestBlock) -> Point TestBlock
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (HeaderWithTime TestBlock) -> Point TestBlock)
-> Point (HeaderWithTime TestBlock) -> Point TestBlock
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (HeaderWithTime TestBlock)
-> Point (HeaderWithTime TestBlock)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
headPoint (AnchoredFragment (HeaderWithTime TestBlock)
 -> Point (HeaderWithTime TestBlock))
-> AnchoredFragment (HeaderWithTime TestBlock)
-> Point (HeaderWithTime TestBlock)
forall a b. (a -> b) -> a -> b
$ JumpInfo TestBlock -> AnchoredFragment (HeaderWithTime TestBlock)
forall blk. JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
jTheirFragment JumpInfo TestBlock
ji)

traceChainSyncClientTerminationEventTestBlockWith ::
  PeerId ->
  Tracer m String ->
  TraceChainSyncClientTerminationEvent ->
  m ()
traceChainSyncClientTerminationEventTestBlockWith :: forall (m :: * -> *).
PeerId
-> Tracer m String -> TraceChainSyncClientTerminationEvent -> m ()
traceChainSyncClientTerminationEventTestBlockWith PeerId
pid Tracer m String
tracer = \case
    TraceChainSyncClientTerminationEvent
TraceExceededSizeLimitCS ->
      String -> m ()
trace String
"Terminated because of size limit exceeded."
    TraceChainSyncClientTerminationEvent
TraceExceededTimeLimitCS ->
      String -> m ()
trace String
"Terminated because of time limit exceeded."
    TraceChainSyncClientTerminationEvent
TraceTerminatedByGDDGovernor ->
      String -> m ()
trace String
"Terminated by the GDD governor."
    TraceChainSyncClientTerminationEvent
TraceTerminatedByLoP ->
      String -> m ()
trace String
"Terminated by the limit on patience."
  where
    trace :: String -> m ()
trace = Tracer m String -> String -> String -> m ()
forall (m :: * -> *). Tracer m String -> String -> String -> m ()
traceUnitWith Tracer m String
tracer (String
"ChainSyncClient " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PeerId -> String
forall a. Condense a => a -> String
condense PeerId
pid)

traceBlockFetchClientTerminationEventTestBlockWith ::
  PeerId ->
  Tracer m String ->
  TraceBlockFetchClientTerminationEvent ->
  m ()
traceBlockFetchClientTerminationEventTestBlockWith :: forall (m :: * -> *).
PeerId
-> Tracer m String -> TraceBlockFetchClientTerminationEvent -> m ()
traceBlockFetchClientTerminationEventTestBlockWith PeerId
pid Tracer m String
tracer = \case
    TraceBlockFetchClientTerminationEvent
TraceExceededSizeLimitBF ->
      String -> m ()
trace String
"Terminated because of size limit exceeded."
    TraceBlockFetchClientTerminationEvent
TraceExceededTimeLimitBF ->
      String -> m ()
trace String
"Terminated because of time limit exceeded."
  where
    trace :: String -> m ()
trace = Tracer m String -> String -> String -> m ()
forall (m :: * -> *). Tracer m String -> String -> String -> m ()
traceUnitWith Tracer m String
tracer (String
"BlockFetchClient " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PeerId -> String
forall a. Condense a => a -> String
condense PeerId
pid)

-- | Trace all the SendRecv events of the ChainSync mini-protocol.
traceChainSyncSendRecvEventTestBlockWith ::
  Applicative m =>
  PeerId ->
  String ->
  Tracer m String ->
  TraceSendRecv (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock)) ->
  m ()
traceChainSyncSendRecvEventTestBlockWith :: forall (m :: * -> *).
Applicative m =>
PeerId
-> String
-> Tracer m String
-> TraceSendRecv
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
-> m ()
traceChainSyncSendRecvEventTestBlockWith PeerId
pid String
ptp Tracer m String
tracer = \case
    TraceSendMsg AnyMessage
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
amsg -> String
-> AnyMessage
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
-> m ()
traceMsg String
"send" AnyMessage
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
amsg
    TraceRecvMsg AnyMessage
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
amsg -> String
-> AnyMessage
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
-> m ()
traceMsg String
"recv" AnyMessage
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
amsg
  where
    -- This can be very verbose and is only useful in rare situations, so it
    -- does nothing by default.
    -- trace = traceUnitWith tracer ("ChainSync " ++ condense pid) . ((ptp ++ " ") ++)
    trace :: String -> m ()
trace = (\PeerId
_ String
_ Tracer m String
_ -> m () -> String -> m ()
forall a b. a -> b -> a
const (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())) PeerId
pid String
ptp Tracer m String
tracer
    traceMsg :: String
-> AnyMessage
     (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
-> m ()
traceMsg String
kd AnyMessage
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
amsg = String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
kd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ case AnyMessage
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
amsg of
      AnyMessage Message
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
  st
  st'
msg -> case Message
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
  st
  st'
msg of
        Message
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
  st
  st'
R:MessageChainSyncfromto
  (Header TestBlock) (Point TestBlock) (Tip TestBlock) st st'
MsgRequestNext -> String
"MsgRequestNext"
        Message
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
  st
  st'
R:MessageChainSyncfromto
  (Header TestBlock) (Point TestBlock) (Tip TestBlock) st st'
MsgAwaitReply -> String
"MsgAwaitReply"
        MsgRollForward Header TestBlock
header Tip TestBlock
tip -> String
"MsgRollForward " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Header TestBlock -> String
terseHeader Header TestBlock
header String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Tip TestBlock -> String
terseTip Tip TestBlock
tip
        MsgRollBackward Point TestBlock
point Tip TestBlock
tip -> String
"MsgRollBackward " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point TestBlock -> String
tersePoint Point TestBlock
point String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Tip TestBlock -> String
terseTip Tip TestBlock
tip
        MsgFindIntersect [Point TestBlock]
points -> String
"MsgFindIntersect [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((Point TestBlock -> String) -> [Point TestBlock] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Point TestBlock -> String
tersePoint [Point TestBlock]
points) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
        MsgIntersectFound Point TestBlock
point Tip TestBlock
tip -> String
"MsgIntersectFound " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point TestBlock -> String
tersePoint Point TestBlock
point String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Tip TestBlock -> String
terseTip Tip TestBlock
tip
        MsgIntersectNotFound Tip TestBlock
tip -> String
"MsgIntersectNotFound " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Tip TestBlock -> String
terseTip Tip TestBlock
tip
        Message
  (ChainSync (Header TestBlock) (Point TestBlock) (Tip TestBlock))
  st
  st'
R:MessageChainSyncfromto
  (Header TestBlock) (Point TestBlock) (Tip TestBlock) st st'
MsgDone -> String
"MsgDone"

traceDbjEventWith ::
  Tracer m String ->
  TraceEventDbf PeerId ->
  m ()
traceDbjEventWith :: forall (m :: * -> *).
Tracer m String -> TraceEventDbf PeerId -> m ()
traceDbjEventWith Tracer m String
tracer = Tracer m String -> String -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m String
tracer (String -> m ())
-> (TraceEventDbf PeerId -> String) -> TraceEventDbf PeerId -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    RotatedDynamo PeerId
old PeerId
new -> String
"Rotated dynamo from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PeerId -> String
forall a. Condense a => a -> String
condense PeerId
old String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PeerId -> String
forall a. Condense a => a -> String
condense PeerId
new

traceCsjEventWith ::
  PeerId ->
  Tracer m String ->
  TraceEventCsj PeerId TestBlock ->
  m ()
traceCsjEventWith :: forall (m :: * -> *).
PeerId -> Tracer m String -> TraceEventCsj PeerId TestBlock -> m ()
traceCsjEventWith PeerId
peer Tracer m String
tracer = String -> m ()
f (String -> m ())
-> (TraceEventCsj PeerId TestBlock -> String)
-> TraceEventCsj PeerId TestBlock
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    BecomingObjector Maybe PeerId
mbOld -> String
"is now the Objector" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe PeerId -> String
replacing Maybe PeerId
mbOld
    TraceEventCsj PeerId TestBlock
BlockedOnJump -> String
"is a happy Jumper blocked on the next CSJ instruction"
    TraceEventCsj PeerId TestBlock
InitializedAsDynamo -> String
"initialized as the Dynamo"
    NoLongerDynamo Maybe PeerId
mbNew TraceCsjReason
reason -> TraceCsjReason -> String
g TraceCsjReason
reason String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and so is no longer the Dynamo" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe PeerId -> String
replacedBy Maybe PeerId
mbNew
    NoLongerObjector Maybe PeerId
mbNew TraceCsjReason
reason -> TraceCsjReason -> String
g TraceCsjReason
reason String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and so is no longer the Objector" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe PeerId -> String
replacedBy Maybe PeerId
mbNew
    SentJumpInstruction Point TestBlock
p -> String
"instructed Jumpers to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point TestBlock -> String
tersePoint Point TestBlock
p
  where
    f :: String -> m ()
f = Tracer m String -> String -> String -> m ()
forall (m :: * -> *). Tracer m String -> String -> String -> m ()
traceUnitWith Tracer m String
tracer (String
"CSJ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PeerId -> String
forall a. Condense a => a -> String
condense PeerId
peer)

    g :: TraceCsjReason -> String
g = \case
      TraceCsjReason
BecauseCsjDisconnect -> String
"disconnected"
      TraceCsjReason
BecauseCsjDisengage  -> String
"disengaged"

    replacedBy :: Maybe PeerId -> String
replacedBy = \case
      Maybe PeerId
Nothing -> String
""
      Just PeerId
new -> String
", replaced by: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PeerId -> String
forall a. Condense a => a -> String
condense PeerId
new

    replacing :: Maybe PeerId -> String
replacing = \case
      Maybe PeerId
Nothing -> String
""
      Just PeerId
old -> String
", replacing: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PeerId -> String
forall a. Condense a => a -> String
condense PeerId
old

prettyDensityBounds :: [(PeerId, DensityBounds TestBlock)] -> [String]
prettyDensityBounds :: [(PeerId, DensityBounds TestBlock)] -> [String]
prettyDensityBounds [(PeerId, DensityBounds TestBlock)]
bounds =
  [(PeerId, String)] -> [String]
showPeers ((DensityBounds TestBlock -> String)
-> (PeerId, DensityBounds TestBlock) -> (PeerId, String)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second DensityBounds TestBlock -> String
showBounds ((PeerId, DensityBounds TestBlock) -> (PeerId, String))
-> [(PeerId, DensityBounds TestBlock)] -> [(PeerId, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, DensityBounds TestBlock)]
bounds)
  where
    showBounds :: DensityBounds TestBlock -> String
showBounds DensityBounds {AnchoredFragment (HeaderWithTime TestBlock)
clippedFragment :: AnchoredFragment (HeaderWithTime TestBlock)
clippedFragment :: forall blk.
DensityBounds blk -> AnchoredFragment (HeaderWithTime blk)
clippedFragment, Bool
offersMoreThanK :: Bool
offersMoreThanK :: forall blk. DensityBounds blk -> Bool
offersMoreThanK, Word64
lowerBound :: Word64
lowerBound :: forall blk. DensityBounds blk -> Word64
lowerBound, Word64
upperBound :: Word64
upperBound :: forall blk. DensityBounds blk -> Word64
upperBound, Bool
hasBlockAfter :: Bool
hasBlockAfter :: forall blk. DensityBounds blk -> Bool
hasBlockAfter, WithOrigin SlotNo
latestSlot :: WithOrigin SlotNo
latestSlot :: forall blk. DensityBounds blk -> WithOrigin SlotNo
latestSlot, Bool
idling :: Bool
idling :: forall blk. DensityBounds blk -> Bool
idling} =
      Word64 -> String
forall a. Show a => a -> String
show Word64
lowerBound String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
upperBound String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
more String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"], " String -> String -> String
forall a. [a] -> [a] -> [a]
++
      String
lastPoint String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"latest: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ WithOrigin SlotNo -> String
showLatestSlot WithOrigin SlotNo
latestSlot String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
block String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
showIdling
      where
        more :: String
more = if Bool
offersMoreThanK then String
"+" else String
" "

        block :: String
block = if Bool
hasBlockAfter then String
", has header after sgen" else String
" "

        -- Note: At some point, I changed this to use @headPoint@ erroneously, so to be clear about what this signifies:
        -- The first point after the anchor (which is returned by @lastPoint@, clearly) is used for the condition that
        -- the density comparison should not be applied to two peers if they share any headers after the LoE fragment.
        lastPoint :: String
lastPoint =
          String
"point: " String -> String -> String
forall a. [a] -> [a] -> [a]
++
          Point TestBlock -> String
tersePoint (forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint @(HeaderWithTime TestBlock) @TestBlock (AnchoredFragment (HeaderWithTime TestBlock)
-> Point (HeaderWithTime TestBlock)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.lastPoint AnchoredFragment (HeaderWithTime TestBlock)
clippedFragment)) String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String
", "

        showLatestSlot :: WithOrigin SlotNo -> String
showLatestSlot = \case
          WithOrigin SlotNo
Origin -> String
"unknown"
          NotOrigin (SlotNo Word64
slot) -> Word64 -> String
forall a. Show a => a -> String
show Word64
slot

        showIdling :: String
showIdling | Bool
idling = String
", idling"
                   | Bool
otherwise = String
""

showPeers :: [(PeerId, String)] -> [String]
showPeers :: [(PeerId, String)] -> [String]
showPeers = ((PeerId, String) -> String) -> [(PeerId, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ (PeerId
peer, String
v) -> String
"        " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PeerId -> String
forall a. Condense a => a -> String
condense PeerId
peer String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v)

-- * Other utilities
terseGDDEvent :: TraceGDDEvent PeerId TestBlock -> String
terseGDDEvent :: TraceGDDEvent PeerId TestBlock -> String
terseGDDEvent = \case
  TraceGDDDisconnected NonEmpty PeerId
peers -> String
"GDD | Disconnected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [PeerId] -> String
forall a. Show a => a -> String
show (NonEmpty PeerId -> [PeerId]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty PeerId
peers)
  TraceGDDDebug GDDDebugInfo {
      sgen :: forall peer blk. GDDDebugInfo peer blk -> GenesisWindow
sgen = GenesisWindow Word64
sgen
    , AnchoredFragment (HeaderWithTime TestBlock)
curChain :: AnchoredFragment (HeaderWithTime TestBlock)
curChain :: forall peer blk.
GDDDebugInfo peer blk -> AnchoredFragment (HeaderWithTime blk)
curChain, [(PeerId, DensityBounds TestBlock)]
bounds :: [(PeerId, DensityBounds TestBlock)]
bounds :: forall peer blk.
GDDDebugInfo peer blk -> [(peer, DensityBounds blk)]
bounds
    , [(PeerId, AnchoredFragment (Header TestBlock))]
candidates :: [(PeerId, AnchoredFragment (Header TestBlock))]
candidates :: forall peer blk.
GDDDebugInfo peer blk -> [(peer, AnchoredFragment (Header blk))]
candidates
    , [(PeerId, AnchoredFragment (Header TestBlock))]
candidateSuffixes :: [(PeerId, AnchoredFragment (Header TestBlock))]
candidateSuffixes :: forall peer blk.
GDDDebugInfo peer blk -> [(peer, AnchoredFragment (Header blk))]
candidateSuffixes
    , [PeerId]
losingPeers :: [PeerId]
losingPeers :: forall peer blk. GDDDebugInfo peer blk -> [peer]
losingPeers
    , Anchor (Header TestBlock)
loeHead :: Anchor (Header TestBlock)
loeHead :: forall peer blk. GDDDebugInfo peer blk -> Anchor (Header blk)
loeHead
    } ->
    [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [
      String
"GDD | Window: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> Anchor (Header TestBlock) -> String
forall {block}. Word64 -> Anchor block -> String
window Word64
sgen Anchor (Header TestBlock)
loeHead,
      String
"      Selection: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredFragment (HeaderWithTime TestBlock) -> String
terseHWTFragment AnchoredFragment (HeaderWithTime TestBlock)
curChain,
      String
"      Candidates:"
      ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
      [(PeerId, String)] -> [String]
showPeers ((AnchoredFragment (Header TestBlock) -> String)
-> (PeerId, AnchoredFragment (Header TestBlock))
-> (PeerId, String)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Point TestBlock -> String
tersePoint (Point TestBlock -> String)
-> (AnchoredFragment (Header TestBlock) -> Point TestBlock)
-> AnchoredFragment (Header TestBlock)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point (Header TestBlock) -> Point TestBlock
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header TestBlock) -> Point TestBlock)
-> (AnchoredFragment (Header TestBlock)
    -> Point (Header TestBlock))
-> AnchoredFragment (Header TestBlock)
-> Point TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment (Header TestBlock) -> Point (Header TestBlock)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint) ((PeerId, AnchoredFragment (Header TestBlock)) -> (PeerId, String))
-> [(PeerId, AnchoredFragment (Header TestBlock))]
-> [(PeerId, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, AnchoredFragment (Header TestBlock))]
candidates) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
      [
      String
"      Candidate suffixes (bounds):"
      ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
      [(PeerId, String)] -> [String]
showPeers ((DensityBounds TestBlock -> String)
-> (PeerId, DensityBounds TestBlock) -> (PeerId, String)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (AnchoredFragment (HeaderWithTime TestBlock) -> String
terseHWTFragment (AnchoredFragment (HeaderWithTime TestBlock) -> String)
-> (DensityBounds TestBlock
    -> AnchoredFragment (HeaderWithTime TestBlock))
-> DensityBounds TestBlock
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DensityBounds TestBlock
-> AnchoredFragment (HeaderWithTime TestBlock)
forall blk.
DensityBounds blk -> AnchoredFragment (HeaderWithTime blk)
clippedFragment) ((PeerId, DensityBounds TestBlock) -> (PeerId, String))
-> [(PeerId, DensityBounds TestBlock)] -> [(PeerId, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, DensityBounds TestBlock)]
bounds) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
      [String
"      Density bounds:"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
      [(PeerId, DensityBounds TestBlock)] -> [String]
prettyDensityBounds [(PeerId, DensityBounds TestBlock)]
bounds [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
      [String
"      New candidate tips:"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
      [(PeerId, String)] -> [String]
showPeers ((AnchoredFragment (Header TestBlock) -> String)
-> (PeerId, AnchoredFragment (Header TestBlock))
-> (PeerId, String)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Point TestBlock -> String
tersePoint (Point TestBlock -> String)
-> (AnchoredFragment (Header TestBlock) -> Point TestBlock)
-> AnchoredFragment (Header TestBlock)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point (Header TestBlock) -> Point TestBlock
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header TestBlock) -> Point TestBlock)
-> (AnchoredFragment (Header TestBlock)
    -> Point (Header TestBlock))
-> AnchoredFragment (Header TestBlock)
-> Point TestBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment (Header TestBlock) -> Point (Header TestBlock)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint) ((PeerId, AnchoredFragment (Header TestBlock)) -> (PeerId, String))
-> [(PeerId, AnchoredFragment (Header TestBlock))]
-> [(PeerId, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, AnchoredFragment (Header TestBlock))]
candidateSuffixes) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
      [
        String
"      Losing peers: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [PeerId] -> String
forall a. Show a => a -> String
show [PeerId]
losingPeers,
      String
"      Setting loeFrag: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Anchor TestBlock -> String
terseAnchor (Anchor (Header TestBlock) -> Anchor TestBlock
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Anchor b
AF.castAnchor Anchor (Header TestBlock)
loeHead)
      ]
  where

    window :: Word64 -> Anchor block -> String
window Word64
sgen Anchor block
loeHead =
      Word64 -> String
forall a. Show a => a -> String
show Word64
winStart String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
winEnd
      where
        winEnd :: Word64
winEnd = Word64
winStart Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
sgen Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
1
        SlotNo Word64
winStart = WithOrigin SlotNo -> SlotNo
forall t. (Bounded t, Enum t) => WithOrigin t -> t
succWithOrigin (Anchor block -> WithOrigin SlotNo
forall block. Anchor block -> WithOrigin SlotNo
AF.anchorToSlotNo Anchor block
loeHead)

prettyTime :: Time -> String
prettyTime :: Time -> String
prettyTime (Time DiffTime
time) =
  let ps :: Integer
ps = DiffTime -> Integer
diffTimeToPicoseconds DiffTime
time
      milliseconds :: Integer
milliseconds = Integer
ps Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`quot` Integer
1_000_000_000
      seconds :: Integer
seconds = Integer
milliseconds Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`quot` Integer
1_000
      minutes :: Integer
minutes = Integer
seconds Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`quot` Integer
60
  in String -> Integer -> Integer -> Integer -> String
forall r. PrintfType r => String -> r
printf String
"%02d:%02d.%03d" Integer
minutes (Integer
seconds Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`rem` Integer
60) (Integer
milliseconds Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`rem` Integer
1_000)

traceLinesWith ::
  Tracer m String ->
  [String] ->
  m ()
traceLinesWith :: forall (m :: * -> *). Tracer m String -> [String] -> m ()
traceLinesWith Tracer m String
tracer = Tracer m String -> String -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m String
tracer (String -> m ()) -> ([String] -> String) -> [String] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. Monoid a => [a] -> a
mconcat ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"\n"

-- Not really the maximum length, just a quick hack for a smoother display
maxUnitLength :: Int
maxUnitLength :: Int
maxUnitLength = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
"BlockFetchServer adversary 9"

padUnit :: String -> String
padUnit :: String -> String
padUnit String
unit = String
unit String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
maxUnitLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
unit) Char
' '

-- | Trace using the given tracer, printing the current time (typically the time
-- of the simulation) and the unit name.
traceUnitLinesWith :: Tracer m String -> String -> [String] -> m ()
traceUnitLinesWith :: forall (m :: * -> *). Tracer m String -> String -> [String] -> m ()
traceUnitLinesWith Tracer m String
tracer String
unit [String]
msgs =
  Tracer m String -> [String] -> m ()
forall (m :: * -> *). Tracer m String -> [String] -> m ()
traceLinesWith Tracer m String
tracer ([String] -> m ()) -> [String] -> m ()
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%s | %s" (String -> String -> String) -> String -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
padUnit String
unit) [String]
msgs

-- | Trace using the given tracer, printing the current time (typically the time
-- of the simulation) and the unit name.
traceUnitWith :: Tracer m String -> String -> String -> m ()
traceUnitWith :: forall (m :: * -> *). Tracer m String -> String -> String -> m ()
traceUnitWith Tracer m String
tracer String
unit String
msg = Tracer m String -> String -> [String] -> m ()
forall (m :: * -> *). Tracer m String -> String -> [String] -> m ()
traceUnitLinesWith Tracer m String
tracer String
unit [String
msg]