{-# 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.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
  , 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 ()) ->
  -- | 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.
  Tracer m String ->
  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 (Header TestBlock)
clippedFragment :: AnchoredFragment (Header TestBlock)
clippedFragment :: forall blk. DensityBounds blk -> AnchoredFragment (Header 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 @(Header TestBlock) @TestBlock (AnchoredFragment (Header TestBlock) -> Point (Header TestBlock)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.lastPoint AnchoredFragment (Header 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 (Header TestBlock)
curChain :: AnchoredFragment (Header TestBlock)
curChain :: forall peer blk.
GDDDebugInfo peer blk -> AnchoredFragment (Header 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 (Header TestBlock) -> String
terseHFragment AnchoredFragment (Header 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 (Header TestBlock) -> String
terseHFragment (AnchoredFragment (Header TestBlock) -> String)
-> (DensityBounds TestBlock -> AnchoredFragment (Header TestBlock))
-> DensityBounds TestBlock
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DensityBounds TestBlock -> AnchoredFragment (Header TestBlock)
forall blk. DensityBounds blk -> AnchoredFragment (Header 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]