{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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 Data.Typeable (Typeable)
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
  , 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
  ( Terse (..)
  , terseAnchor
  , terseBlock
  , terseFragment
  , terseHFragment
  , terseHeader
  , tersePoint
  , terseRealPoint
  , terseTip
  , terseWithOrigin
  )
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
  , AF.HasHeader blk
  , AF.HasHeader (Header blk)
  , Condense (NodeState blk)
  , Terse blk
  ) =>
  Tracer m String ->
  m (Tracer m (TraceEvent blk))
tracerTestBlock :: forall (m :: * -> *) blk.
(IOLike m, HasHeader blk, HasHeader (Header blk),
 Condense (NodeState blk), Terse blk) =>
Tracer m String -> m (Tracer m (TraceEvent blk))
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 blk) ->
  Tracer m (TraceGDDEvent PeerId blk)
mkGDDTracerTestBlock :: forall (m :: * -> *) blk.
Tracer m (TraceEvent blk) -> Tracer m (TraceGDDEvent PeerId blk)
mkGDDTracerTestBlock = (TraceGDDEvent PeerId blk -> TraceEvent blk)
-> Tracer m (TraceEvent blk) -> Tracer m (TraceGDDEvent PeerId blk)
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 blk -> TraceEvent blk
forall blk. TraceGDDEvent PeerId blk -> TraceEvent blk
TraceGenesisDDEvent

traceEventTestBlockWith ::
  ( MonadMonotonicTime m
  , AF.HasHeader blk
  , AF.HasHeader (Header blk)
  , Condense (NodeState blk)
  , Terse blk
  ) =>
  (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 blk ->
  m ()
traceEventTestBlockWith :: forall (m :: * -> *) blk.
(MonadMonotonicTime m, HasHeader blk, HasHeader (Header blk),
 Condense (NodeState blk), Terse blk) =>
(Time -> m ())
-> Tracer m String -> Tracer m String -> TraceEvent blk -> m ()
traceEventTestBlockWith Time -> m ()
setTickTime Tracer m String
tracer0 Tracer m String
tracer = \case
  TraceSchedulerEvent TraceSchedulerEvent blk
traceEvent -> (Time -> m ())
-> Tracer m String
-> Tracer m String
-> TraceSchedulerEvent blk
-> m ()
forall blk (m :: * -> *).
(MonadMonotonicTime m, HasHeader (Header blk),
 Condense (NodeState blk), Terse blk, Typeable blk) =>
(Time -> m ())
-> Tracer m String
-> Tracer m String
-> TraceSchedulerEvent blk
-> m ()
traceSchedulerEventTestBlockWith Time -> m ()
setTickTime Tracer m String
tracer0 Tracer m String
tracer TraceSchedulerEvent blk
traceEvent
  TraceScheduledChainSyncServerEvent PeerId
peerId TraceScheduledChainSyncServerEvent (NodeState blk) blk
traceEvent -> Tracer m String
-> PeerId
-> TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> m ()
forall blk (m :: * -> *).
(Condense (NodeState blk), Terse blk) =>
Tracer m String
-> PeerId
-> TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> m ()
traceScheduledChainSyncServerEventTestBlockWith Tracer m String
tracer PeerId
peerId TraceScheduledChainSyncServerEvent (NodeState blk) blk
traceEvent
  TraceScheduledBlockFetchServerEvent PeerId
peerId TraceScheduledBlockFetchServerEvent (NodeState blk) blk
traceEvent -> Tracer m String
-> PeerId
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> m ()
forall blk (m :: * -> *).
(Condense (NodeState blk), Terse blk) =>
Tracer m String
-> PeerId
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> m ()
traceScheduledBlockFetchServerEventTestBlockWith Tracer m String
tracer PeerId
peerId TraceScheduledBlockFetchServerEvent (NodeState blk) blk
traceEvent
  TraceChainDBEvent TraceEvent blk
traceEvent -> Tracer m String -> TraceEvent blk -> m ()
forall (m :: * -> *) blk.
(Monad m, Terse blk) =>
Tracer m String -> TraceEvent blk -> m ()
traceChainDBEventTestBlockWith Tracer m String
tracer TraceEvent blk
traceEvent
  TraceChainSyncClientEvent PeerId
peerId TraceChainSyncClientEvent blk
traceEvent -> PeerId -> Tracer m String -> TraceChainSyncClientEvent blk -> m ()
forall blk (m :: * -> *).
(HasHeader (Header blk), Terse blk, Typeable blk) =>
PeerId -> Tracer m String -> TraceChainSyncClientEvent blk -> m ()
traceChainSyncClientEventTestBlockWith PeerId
peerId Tracer m String
tracer TraceChainSyncClientEvent blk
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 blk
gddEvent -> Tracer m String -> String -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m String
tracer (TraceGDDEvent PeerId blk -> String
forall blk.
(HasHeader (Header blk), Terse blk) =>
TraceGDDEvent PeerId blk -> String
terseGDDEvent TraceGDDEvent PeerId blk
gddEvent)
  TraceChainSyncSendRecvEvent PeerId
peerId String
peerType TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))
traceEvent -> PeerId
-> String
-> Tracer m String
-> TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))
-> m ()
forall (m :: * -> *) blk.
(Applicative m, Terse blk) =>
PeerId
-> String
-> Tracer m String
-> TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))
-> m ()
traceChainSyncSendRecvEventTestBlockWith PeerId
peerId String
peerType Tracer m String
tracer TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))
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 blk
traceEvent -> PeerId -> Tracer m String -> TraceEventCsj PeerId blk -> m ()
forall blk (m :: * -> *).
Terse blk =>
PeerId -> Tracer m String -> TraceEventCsj PeerId blk -> m ()
traceCsjEventWith PeerId
peerId Tracer m String
tracer TraceEventCsj PeerId blk
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 ::
  forall blk m.
  ( MonadMonotonicTime m
  , AF.HasHeader (Header blk)
  , Condense (NodeState blk)
  , Terse blk
  , Typeable blk
  ) =>
  (Time -> m ()) ->
  Tracer m String ->
  Tracer m String ->
  TraceSchedulerEvent blk ->
  m ()
traceSchedulerEventTestBlockWith :: forall blk (m :: * -> *).
(MonadMonotonicTime m, HasHeader (Header blk),
 Condense (NodeState blk), Terse blk, Typeable blk) =>
(Time -> m ())
-> Tracer m String
-> Tracer m String
-> TraceSchedulerEvent blk
-> m ()
traceSchedulerEventTestBlockWith Time -> m ()
setTickTime Tracer m String
tracer0 Tracer m String
tracer = \case
  TraceSchedulerEvent blk
TraceBeginningOfTime ->
    Tracer m String -> String -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m String
tracer0 String
"Running point schedule ..."
  TraceSchedulerEvent blk
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 blk
state) AnchoredFragment (Header blk)
currentChain Maybe (AnchoredFragment (Header blk))
mCandidateFrag [(PeerId, ChainSyncJumpingState m blk)]
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 blk
TraceNodeShutdownComplete ->
    Tracer m String -> String -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m String
tracer String
"  Node shutdown complete"
  TraceSchedulerEvent blk
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 blk)
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 blk) -> String
forall blk. Terse blk => AnchoredFragment (Header blk) -> String
terseHFragment AnchoredFragment (Header blk)
selection)
 where
  traceJumpingStates :: forall n. [(PeerId, ChainSyncJumpingState n blk)] -> String
  traceJumpingStates :: forall (n :: * -> *).
[(PeerId, ChainSyncJumpingState n blk)] -> String
traceJumpingStates = [String] -> String
unlines ([String] -> String)
-> ([(PeerId, ChainSyncJumpingState n blk)] -> [String])
-> [(PeerId, ChainSyncJumpingState n blk)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PeerId, ChainSyncJumpingState n blk) -> String)
-> [(PeerId, ChainSyncJumpingState n blk)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(PeerId
pid, ChainSyncJumpingState n blk
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 n blk -> String
forall (n :: * -> *). ChainSyncJumpingState n blk -> String
traceJumpingState ChainSyncJumpingState n blk
state)

  traceJumpingState :: forall n. ChainSyncJumpingState n blk -> String
  traceJumpingState :: forall (n :: * -> *). ChainSyncJumpingState n blk -> String
traceJumpingState = \case
    Dynamo DynamoInitState blk
initState WithOrigin SlotNo
lastJump ->
      let showInitState :: String
showInitState = case DynamoInitState blk
initState of
            DynamoStarting JumpInfo blk
ji -> String
"(DynamoStarting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ JumpInfo blk -> String
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> String
terseJumpInfo JumpInfo blk
ji String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
            DynamoInitState blk
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 blk
goodJumpInfo Point (Header blk)
badPoint ->
      [String] -> String
unwords
        [ String
"Objector"
        , ObjectorInitState -> String
forall a. Show a => a -> String
show ObjectorInitState
initState
        , JumpInfo blk -> String
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> String
terseJumpInfo JumpInfo blk
goodJumpInfo
        , forall blk. Terse blk => Point blk -> String
tersePoint @blk (Point (Header blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point (Header blk)
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 n (Maybe (JumpInfo blk))
_ ChainSyncJumpingJumperState blk
st -> String
"Jumper _ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ChainSyncJumpingJumperState blk -> String
traceJumperState ChainSyncJumpingJumperState blk
st

  traceJumperState :: ChainSyncJumpingJumperState blk -> String
  traceJumperState :: ChainSyncJumpingJumperState blk -> String
traceJumperState = \case
    Happy JumperInitState
initState Maybe (JumpInfo blk)
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 blk -> String) -> Maybe (JumpInfo blk) -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"Nothing" JumpInfo blk -> String
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> String
terseJumpInfo Maybe (JumpInfo blk)
mGoodJumpInfo
    FoundIntersection ObjectorInitState
initState JumpInfo blk
goodJumpInfo Point (Header blk)
point ->
      [String] -> String
unwords
        [ String
"(FoundIntersection"
        , ObjectorInitState -> String
forall a. Show a => a -> String
show ObjectorInitState
initState
        , JumpInfo blk -> String
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> String
terseJumpInfo JumpInfo blk
goodJumpInfo
        , forall blk. Terse blk => Point blk -> String
tersePoint @blk (Point blk -> String) -> Point blk -> String
forall a b. (a -> b) -> a -> b
$ Point (Header blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint Point (Header blk)
point
        , String
")"
        ]
    LookingForIntersection JumpInfo blk
goodJumpInfo JumpInfo blk
badJumpInfo ->
      [String] -> String
unwords
        [String
"(LookingForIntersection", JumpInfo blk -> String
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> String
terseJumpInfo JumpInfo blk
goodJumpInfo, JumpInfo blk -> String
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> String
terseJumpInfo JumpInfo blk
badJumpInfo, String
")"]

traceScheduledServerHandlerEventTestBlockWith ::
  Condense (NodeState blk) =>
  Tracer m String ->
  String ->
  TraceScheduledServerHandlerEvent (NodeState blk) blk ->
  m ()
traceScheduledServerHandlerEventTestBlockWith :: forall blk (m :: * -> *).
Condense (NodeState blk) =>
Tracer m String
-> String
-> TraceScheduledServerHandlerEvent (NodeState blk) blk
-> m ()
traceScheduledServerHandlerEventTestBlockWith Tracer m String
tracer String
unit = \case
  TraceHandling String
handler NodeState blk
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 blk -> String
forall a. Condense a => a -> String
condense NodeState blk
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 ::
  ( Condense (NodeState blk)
  , Terse blk
  ) =>
  Tracer m String ->
  PeerId ->
  TraceScheduledChainSyncServerEvent (NodeState blk) blk ->
  m ()
traceScheduledChainSyncServerEventTestBlockWith :: forall blk (m :: * -> *).
(Condense (NodeState blk), Terse blk) =>
Tracer m String
-> PeerId
-> TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> m ()
traceScheduledChainSyncServerEventTestBlockWith Tracer m String
tracer PeerId
peerId = \case
  TraceHandlerEventCS TraceScheduledServerHandlerEvent (NodeState blk) blk
traceEvent -> Tracer m String
-> String
-> TraceScheduledServerHandlerEvent (NodeState blk) blk
-> m ()
forall blk (m :: * -> *).
Condense (NodeState blk) =>
Tracer m String
-> String
-> TraceScheduledServerHandlerEvent (NodeState blk) blk
-> m ()
traceScheduledServerHandlerEventTestBlockWith Tracer m String
tracer String
unit TraceScheduledServerHandlerEvent (NodeState blk) blk
traceEvent
  TraceLastIntersection Point blk
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 blk -> String
forall blk. Terse blk => Point blk -> String
tersePoint Point blk
point
  TraceScheduledChainSyncServerEvent (NodeState blk) blk
TraceClientIsDone ->
    String -> m ()
trace String
"received MsgDoneClient"
  TraceScheduledChainSyncServerEvent (NodeState blk) blk
TraceIntersectionNotFound ->
    String -> m ()
trace String
"  no intersection found"
  TraceIntersectionFound Point blk
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 blk -> String
forall blk. Terse blk => Point blk -> String
tersePoint Point blk
point
  TraceRollForward Header blk
header Tip blk
tip ->
    [String] -> m ()
traceLines
      [ String
"  gotta serve " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Header blk -> String
forall blk. Terse blk => Header blk -> String
terseHeader Header blk
header
      , String
"  tip is      " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Tip blk -> String
forall blk. Terse blk => Tip blk -> String
terseTip Tip blk
tip
      ]
  TraceRollBackward Point blk
point Tip blk
tip ->
    [String] -> m ()
traceLines
      [ String
"  gotta roll back to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point blk -> String
forall blk. Terse blk => Point blk -> String
tersePoint Point blk
point
      , String
"  new tip is      " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Tip blk -> String
forall blk. Terse blk => Tip blk -> String
terseTip Tip blk
tip
      ]
  TraceScheduledChainSyncServerEvent (NodeState blk) blk
TraceChainIsFullyServed ->
    String -> m ()
trace String
"  chain has been fully served"
  TraceScheduledChainSyncServerEvent (NodeState blk) blk
TraceIntersectionIsHeaderPoint ->
    String -> m ()
trace String
"  intersection is exactly our header point"
  TraceIntersectionIsStrictAncestorOfHeaderPoint AnchoredFragment blk
fragment ->
    [String] -> m ()
traceLines
      [ String
"  intersection is before our header point"
      , String
"  fragment ahead: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredFragment blk -> String
forall blk. Terse blk => AnchoredFragment blk -> String
terseFragment AnchoredFragment blk
fragment
      ]
  TraceScheduledChainSyncServerEvent (NodeState blk) blk
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 ::
  ( Condense (NodeState blk)
  , Terse blk
  ) =>
  Tracer m String ->
  PeerId ->
  TraceScheduledBlockFetchServerEvent (NodeState blk) blk ->
  m ()
traceScheduledBlockFetchServerEventTestBlockWith :: forall blk (m :: * -> *).
(Condense (NodeState blk), Terse blk) =>
Tracer m String
-> PeerId
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> m ()
traceScheduledBlockFetchServerEventTestBlockWith Tracer m String
tracer PeerId
peerId = \case
  TraceHandlerEventBF TraceScheduledServerHandlerEvent (NodeState blk) blk
traceEvent -> Tracer m String
-> String
-> TraceScheduledServerHandlerEvent (NodeState blk) blk
-> m ()
forall blk (m :: * -> *).
Condense (NodeState blk) =>
Tracer m String
-> String
-> TraceScheduledServerHandlerEvent (NodeState blk) blk
-> m ()
traceScheduledServerHandlerEventTestBlockWith Tracer m String
tracer String
unit TraceScheduledServerHandlerEvent (NodeState blk) blk
traceEvent
  TraceScheduledBlockFetchServerEvent (NodeState blk) blk
TraceNoBlocks ->
    String -> m ()
trace String
"  no blocks available"
  TraceStartingBatch AnchoredFragment blk
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 blk -> String
forall blk. Terse blk => AnchoredFragment blk -> String
terseFragment AnchoredFragment blk
fragment
  TraceWaitingForRange Point blk
pointFrom Point blk
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 blk -> String
forall blk. Terse blk => Point blk -> String
tersePoint Point blk
pointFrom String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point blk -> String
forall blk. Terse blk => Point blk -> String
tersePoint Point blk
pointTo
  TraceSendingBlock blk
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]
++ blk -> String
forall blk. Terse blk => blk -> String
terseBlock blk
block
  TraceScheduledBlockFetchServerEvent (NodeState blk) blk
TraceBatchIsDone ->
    String -> m ()
trace String
"Batch is done"
  TraceScheduledBlockFetchServerEvent (NodeState blk) blk
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 =>
  Terse blk =>
  Tracer m String ->
  ChainDB.TraceEvent blk ->
  m ()
traceChainDBEventTestBlockWith :: forall (m :: * -> *) blk.
(Monad m, Terse blk) =>
Tracer m String -> TraceEvent blk -> m ()
traceChainDBEventTestBlockWith Tracer m String
tracer = \case
  ChainDB.TraceAddBlockEvent TraceAddBlockEvent blk
event ->
    case TraceAddBlockEvent blk
event of
      AddedToCurrentChain [LedgerEvent blk]
_ SelectionChangedInfo blk
_ AnchoredFragment (Header blk)
_ AnchoredFragment (Header blk)
newFragment ReasonForSwitch' blk
_ ->
        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 blk) -> String
forall blk. Terse blk => AnchoredFragment (Header blk) -> String
terseHFragment AnchoredFragment (Header blk)
newFragment
      SwitchedToAFork [LedgerEvent blk]
_ SelectionChangedInfo blk
_ AnchoredFragment (Header blk)
_ AnchoredFragment (Header blk)
newFragment ReasonForSwitch' blk
_ ->
        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 blk) -> String
forall blk. Terse blk => AnchoredFragment (Header blk) -> String
terseHFragment AnchoredFragment (Header blk)
newFragment
      StoreButDontChange RealPoint blk
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 blk -> String
forall blk. Terse blk => RealPoint blk -> String
terseRealPoint RealPoint blk
point
      IgnoreBlockOlderThanImmTip RealPoint blk
point ->
        String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Ignored block older than imm tip: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ RealPoint blk -> String
forall blk. Terse blk => RealPoint blk -> String
terseRealPoint RealPoint blk
point
      ChainSelectionLoEDebug AnchoredFragment (Header blk)
curChain (LoEEnabled AnchoredFragment (Header blk)
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 blk) -> String
forall blk. Terse blk => AnchoredFragment (Header blk) -> String
terseHFragment AnchoredFragment (Header blk)
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 blk) -> String
forall blk. Terse blk => AnchoredFragment (Header blk) -> String
terseHFragment AnchoredFragment (Header blk)
loeFrag0
      ChainSelectionLoEDebug AnchoredFragment (Header blk)
_ LoE (AnchoredFragment (Header blk))
LoEDisabled ->
        () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      AddedReprocessLoEBlocksToQueue Enclosing' Word
RisingEdge ->
        String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Requesting ChainSel run..."
      AddedReprocessLoEBlocksToQueue FallingEdgeWith{} ->
        String -> m ()
trace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"Requested ChainSel run"
      TraceAddBlockEvent blk
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  ChainDB.TraceChainSelStarvationEvent (ChainDB.ChainSelStarvation Enclosing' (RealPoint blk)
RisingEdge) ->
    String -> m ()
trace String
"ChainSel starvation started"
  ChainDB.TraceChainSelStarvationEvent (ChainDB.ChainSelStarvation (FallingEdgeWith RealPoint blk
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 blk -> String
forall blk. Terse blk => RealPoint blk -> String
terseRealPoint RealPoint blk
pt
  TraceEvent blk
_ -> () -> 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 ::
  forall blk m.
  ( AF.HasHeader (Header blk)
  , Terse blk
  , Typeable blk
  ) =>
  PeerId ->
  Tracer m String ->
  TraceChainSyncClientEvent blk ->
  m ()
traceChainSyncClientEventTestBlockWith :: forall blk (m :: * -> *).
(HasHeader (Header blk), Terse blk, Typeable blk) =>
PeerId -> Tracer m String -> TraceChainSyncClientEvent blk -> m ()
traceChainSyncClientEventTestBlockWith PeerId
pid Tracer m String
tracer = \case
  TraceRolledBack Point blk
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 blk -> String
forall blk. Terse blk => Point blk -> String
tersePoint Point blk
point
  TraceFoundIntersection Point blk
point Our (Tip blk)
_ourTip Their (Tip blk)
_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 blk -> String
forall blk. Terse blk => Point blk -> String
tersePoint Point blk
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 blk
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 blk -> String
forall blk. Terse blk => Header blk -> String
terseHeader Header blk
header
  TraceDownloadedHeader Header blk
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 blk -> String
forall blk. Terse blk => Header blk -> String
terseHeader Header blk
header
  TraceGaveLoPToken Bool
didGive Header blk
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 blk -> String
forall blk. Terse blk => Header blk -> String
terseHeader Header blk
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 blk
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 blk -> String
forall blk. Terse blk => Point blk -> String
tersePoint Point blk
point
  TraceJumpResult (AcceptedJump (JumpTo JumpInfo blk
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 blk -> String
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> String
terseJumpInfo JumpInfo blk
ji
  TraceJumpResult (RejectedJump (JumpTo JumpInfo blk
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 blk -> String
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> String
terseJumpInfo JumpInfo blk
ji
  TraceJumpResult (AcceptedJump (JumpToGoodPoint JumpInfo blk
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 blk -> String
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> String
terseJumpInfo JumpInfo blk
ji
  TraceJumpResult (RejectedJump (JumpToGoodPoint JumpInfo blk
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 blk -> String
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> String
terseJumpInfo JumpInfo blk
ji
  TraceChainSyncClientEvent blk
TraceJumpingWaitingForNextInstruction ->
    String -> m ()
trace String
"Waiting for next instruction from the jumping governor"
  TraceJumpingInstructionIs Instruction blk
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 blk -> String
showInstr Instruction blk
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 blk -> String
  showInstr :: Instruction blk -> String
showInstr = \case
    JumpInstruction (JumpTo JumpInfo blk
ji) -> String
"JumpTo " String -> String -> String
forall a. [a] -> [a] -> [a]
++ JumpInfo blk -> String
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> String
terseJumpInfo JumpInfo blk
ji
    JumpInstruction (JumpToGoodPoint JumpInfo blk
ji) -> String
"JumpToGoodPoint " String -> String -> String
forall a. [a] -> [a] -> [a]
++ JumpInfo blk -> String
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> String
terseJumpInfo JumpInfo blk
ji
    Instruction blk
RunNormally -> String
"RunNormally"
    Instruction blk
Restart -> String
"Restart"

terseJumpInfo ::
  forall blk. (AF.HasHeader (Header blk), Terse blk, Typeable blk) => JumpInfo blk -> String
terseJumpInfo :: forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> String
terseJumpInfo JumpInfo blk
ji = forall blk. Terse blk => Point blk -> String
tersePoint @blk (Point (HeaderWithTime blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (HeaderWithTime blk) -> Point blk)
-> Point (HeaderWithTime blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (HeaderWithTime blk) -> Point (HeaderWithTime blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
headPoint (AnchoredFragment (HeaderWithTime blk)
 -> Point (HeaderWithTime blk))
-> AnchoredFragment (HeaderWithTime blk)
-> Point (HeaderWithTime blk)
forall a b. (a -> b) -> a -> b
$ JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
forall blk. JumpInfo blk -> AnchoredFragment (HeaderWithTime blk)
jTheirFragment JumpInfo blk
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 =>
  Terse blk =>
  PeerId ->
  String ->
  Tracer m String ->
  TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk)) ->
  m ()
traceChainSyncSendRecvEventTestBlockWith :: forall (m :: * -> *) blk.
(Applicative m, Terse blk) =>
PeerId
-> String
-> Tracer m String
-> TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))
-> m ()
traceChainSyncSendRecvEventTestBlockWith PeerId
pid String
ptp Tracer m String
tracer = \case
  TraceSendMsg AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))
amsg -> String
-> AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))
-> m ()
traceMsg String
"send" AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))
amsg
  TraceRecvMsg AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))
amsg -> String
-> AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))
-> m ()
traceMsg String
"recv" AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))
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 blk) (Point blk) (Tip blk))
-> m ()
traceMsg String
kd AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))
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 blk) (Point blk) (Tip blk))
amsg of
        AnyMessage Message (ChainSync (Header blk) (Point blk) (Tip blk)) st st'
msg -> case Message (ChainSync (Header blk) (Point blk) (Tip blk)) st st'
msg of
          Message (ChainSync (Header blk) (Point blk) (Tip blk)) st st'
R:MessageChainSyncfromto (Header blk) (Point blk) (Tip blk) st st'
MsgRequestNext -> String
"MsgRequestNext"
          Message (ChainSync (Header blk) (Point blk) (Tip blk)) st st'
R:MessageChainSyncfromto (Header blk) (Point blk) (Tip blk) st st'
MsgAwaitReply -> String
"MsgAwaitReply"
          MsgRollForward Header blk
header Tip blk
tip -> String
"MsgRollForward " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Header blk -> String
forall blk. Terse blk => Header blk -> String
terseHeader Header blk
header String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Tip blk -> String
forall blk. Terse blk => Tip blk -> String
terseTip Tip blk
tip
          MsgRollBackward Point blk
point Tip blk
tip -> String
"MsgRollBackward " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point blk -> String
forall blk. Terse blk => Point blk -> String
tersePoint Point blk
point String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Tip blk -> String
forall blk. Terse blk => Tip blk -> String
terseTip Tip blk
tip
          MsgFindIntersect [Point blk]
points -> String
"MsgFindIntersect [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((Point blk -> String) -> [Point blk] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Point blk -> String
forall blk. Terse blk => Point blk -> String
tersePoint [Point blk]
points) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
          MsgIntersectFound Point blk
point Tip blk
tip -> String
"MsgIntersectFound " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point blk -> String
forall blk. Terse blk => Point blk -> String
tersePoint Point blk
point String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Tip blk -> String
forall blk. Terse blk => Tip blk -> String
terseTip Tip blk
tip
          MsgIntersectNotFound Tip blk
tip -> String
"MsgIntersectNotFound " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Tip blk -> String
forall blk. Terse blk => Tip blk -> String
terseTip Tip blk
tip
          Message (ChainSync (Header blk) (Point blk) (Tip blk)) st st'
R:MessageChainSyncfromto (Header blk) (Point blk) (Tip blk) 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 ::
  Terse blk =>
  PeerId ->
  Tracer m String ->
  TraceEventCsj PeerId blk ->
  m ()
traceCsjEventWith :: forall blk (m :: * -> *).
Terse blk =>
PeerId -> Tracer m String -> TraceEventCsj PeerId blk -> m ()
traceCsjEventWith PeerId
peer Tracer m String
tracer =
  String -> m ()
f (String -> m ())
-> (TraceEventCsj PeerId blk -> String)
-> TraceEventCsj PeerId blk
-> 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 blk
BlockedOnJump -> String
"is a happy Jumper blocked on the next CSJ instruction"
    TraceEventCsj PeerId blk
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 blk
p -> String
"instructed Jumpers to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Point blk -> String
forall blk. Terse blk => Point blk -> String
tersePoint Point blk
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 ::
  forall blk. (AF.HasHeader (Header blk), Terse blk) => [(PeerId, DensityBounds blk)] -> [String]
prettyDensityBounds :: forall blk.
(HasHeader (Header blk), Terse blk) =>
[(PeerId, DensityBounds blk)] -> [String]
prettyDensityBounds [(PeerId, DensityBounds blk)]
bounds =
  [(PeerId, String)] -> [String]
showPeers ((DensityBounds blk -> String)
-> (PeerId, DensityBounds blk) -> (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 blk -> String
showBounds ((PeerId, DensityBounds blk) -> (PeerId, String))
-> [(PeerId, DensityBounds blk)] -> [(PeerId, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, DensityBounds blk)]
bounds)
 where
  showBounds :: DensityBounds blk -> String
showBounds
    DensityBounds
      { AnchoredFragment (Header blk)
clippedFragment :: AnchoredFragment (Header blk)
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 blk -> String
forall blk. Terse blk => Point blk -> 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 blk) @blk (AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.lastPoint AnchoredFragment (Header blk)
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 ::
  forall blk. (AF.HasHeader (Header blk), Terse blk) => TraceGDDEvent PeerId blk -> String
terseGDDEvent :: forall blk.
(HasHeader (Header blk), Terse blk) =>
TraceGDDEvent PeerId blk -> 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 blk)
curChain :: AnchoredFragment (Header blk)
curChain :: forall peer blk.
GDDDebugInfo peer blk -> AnchoredFragment (Header blk)
curChain
      , [(PeerId, DensityBounds blk)]
bounds :: [(PeerId, DensityBounds blk)]
bounds :: forall peer blk.
GDDDebugInfo peer blk -> [(peer, DensityBounds blk)]
bounds
      , [(PeerId, AnchoredFragment (Header blk))]
candidates :: [(PeerId, AnchoredFragment (Header blk))]
candidates :: forall peer blk.
GDDDebugInfo peer blk -> [(peer, AnchoredFragment (Header blk))]
candidates
      , [(PeerId, AnchoredFragment (Header blk))]
candidateSuffixes :: [(PeerId, AnchoredFragment (Header blk))]
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 blk)
loeHead :: Anchor (Header blk)
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 blk) -> String
forall {block}. Word64 -> Anchor block -> String
window Word64
sgen Anchor (Header blk)
loeHead
        , String
"      Selection: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredFragment (Header blk) -> String
forall blk. Terse blk => AnchoredFragment (Header blk) -> String
terseHFragment AnchoredFragment (Header blk)
curChain
        , String
"      Candidates:"
        ]
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [(PeerId, String)] -> [String]
showPeers ((AnchoredFragment (Header blk) -> String)
-> (PeerId, AnchoredFragment (Header blk)) -> (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 (forall blk. Terse blk => Point blk -> String
tersePoint @blk (Point blk -> String)
-> (AnchoredFragment (Header blk) -> Point blk)
-> AnchoredFragment (Header blk)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point (Header blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header blk) -> Point blk)
-> (AnchoredFragment (Header blk) -> Point (Header blk))
-> AnchoredFragment (Header blk)
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint) ((PeerId, AnchoredFragment (Header blk)) -> (PeerId, String))
-> [(PeerId, AnchoredFragment (Header blk))] -> [(PeerId, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, AnchoredFragment (Header blk))]
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 blk -> String)
-> (PeerId, DensityBounds blk) -> (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 blk) -> String
forall blk. Terse blk => AnchoredFragment (Header blk) -> String
terseHFragment (AnchoredFragment (Header blk) -> String)
-> (DensityBounds blk -> AnchoredFragment (Header blk))
-> DensityBounds blk
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DensityBounds blk -> AnchoredFragment (Header blk)
forall blk. DensityBounds blk -> AnchoredFragment (Header blk)
clippedFragment) ((PeerId, DensityBounds blk) -> (PeerId, String))
-> [(PeerId, DensityBounds blk)] -> [(PeerId, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, DensityBounds blk)]
bounds)
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"      Density bounds:"]
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [(PeerId, DensityBounds blk)] -> [String]
forall blk.
(HasHeader (Header blk), Terse blk) =>
[(PeerId, DensityBounds blk)] -> [String]
prettyDensityBounds [(PeerId, DensityBounds blk)]
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 blk) -> String)
-> (PeerId, AnchoredFragment (Header blk)) -> (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 (forall blk. Terse blk => Point blk -> String
tersePoint @blk (Point blk -> String)
-> (AnchoredFragment (Header blk) -> Point blk)
-> AnchoredFragment (Header blk)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point (Header blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header blk) -> Point blk)
-> (AnchoredFragment (Header blk) -> Point (Header blk))
-> AnchoredFragment (Header blk)
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint) ((PeerId, AnchoredFragment (Header blk)) -> (PeerId, String))
-> [(PeerId, AnchoredFragment (Header blk))] -> [(PeerId, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, AnchoredFragment (Header blk))]
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]
++ forall blk. Terse blk => Anchor blk -> String
terseAnchor @blk (Anchor (Header blk) -> Anchor blk
forall a b. (HeaderHash a ~ HeaderHash b) => Anchor a -> Anchor b
AF.castAnchor Anchor (Header blk)
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]