{-# 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 [Char] -> m (Tracer m (TraceEvent blk))
tracerTestBlock Tracer m [Char]
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 = ([Char] -> m ()) -> Tracer m [Char]
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (([Char] -> m ()) -> Tracer m [Char])
-> ([Char] -> m ()) -> Tracer m [Char]
forall a b. (a -> b) -> a -> b
$ \[Char]
msg -> do
        time <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
        tickTime <- readTVarIO tickTimeVar
        let timeHeader = Time -> [Char]
prettyTime Time
time [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" "
            prefix =
              if Time
time Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
/= Time
tickTime
                then [Char]
timeHeader
                else Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate ([Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
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 [Char] -> Tracer m [Char] -> TraceEvent blk -> m ()
traceEventTestBlockWith Time -> m ()
setTickTime Tracer m [Char]
tracer0 Tracer m [Char]
tracer = \case
  TraceSchedulerEvent TraceSchedulerEvent blk
traceEvent -> (Time -> m ())
-> Tracer m [Char]
-> Tracer m [Char]
-> TraceSchedulerEvent blk
-> m ()
forall blk (m :: * -> *).
(MonadMonotonicTime m, HasHeader (Header blk),
 Condense (NodeState blk), Terse blk, Typeable blk) =>
(Time -> m ())
-> Tracer m [Char]
-> Tracer m [Char]
-> TraceSchedulerEvent blk
-> m ()
traceSchedulerEventTestBlockWith Time -> m ()
setTickTime Tracer m [Char]
tracer0 Tracer m [Char]
tracer TraceSchedulerEvent blk
traceEvent
  TraceScheduledChainSyncServerEvent PeerId
peerId TraceScheduledChainSyncServerEvent (NodeState blk) blk
traceEvent -> Tracer m [Char]
-> PeerId
-> TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> m ()
forall blk (m :: * -> *).
(Condense (NodeState blk), Terse blk) =>
Tracer m [Char]
-> PeerId
-> TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> m ()
traceScheduledChainSyncServerEventTestBlockWith Tracer m [Char]
tracer PeerId
peerId TraceScheduledChainSyncServerEvent (NodeState blk) blk
traceEvent
  TraceScheduledBlockFetchServerEvent PeerId
peerId TraceScheduledBlockFetchServerEvent (NodeState blk) blk
traceEvent -> Tracer m [Char]
-> PeerId
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> m ()
forall blk (m :: * -> *).
(Condense (NodeState blk), Terse blk) =>
Tracer m [Char]
-> PeerId
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> m ()
traceScheduledBlockFetchServerEventTestBlockWith Tracer m [Char]
tracer PeerId
peerId TraceScheduledBlockFetchServerEvent (NodeState blk) blk
traceEvent
  TraceChainDBEvent TraceEvent blk
traceEvent -> Tracer m [Char] -> TraceEvent blk -> m ()
forall (m :: * -> *) blk.
(Monad m, Terse blk) =>
Tracer m [Char] -> TraceEvent blk -> m ()
traceChainDBEventTestBlockWith Tracer m [Char]
tracer TraceEvent blk
traceEvent
  TraceChainSyncClientEvent PeerId
peerId TraceChainSyncClientEvent blk
traceEvent -> PeerId -> Tracer m [Char] -> TraceChainSyncClientEvent blk -> m ()
forall blk (m :: * -> *).
(HasHeader (Header blk), Terse blk, Typeable blk) =>
PeerId -> Tracer m [Char] -> TraceChainSyncClientEvent blk -> m ()
traceChainSyncClientEventTestBlockWith PeerId
peerId Tracer m [Char]
tracer TraceChainSyncClientEvent blk
traceEvent
  TraceChainSyncClientTerminationEvent PeerId
peerId TraceChainSyncClientTerminationEvent
traceEvent -> PeerId
-> Tracer m [Char] -> TraceChainSyncClientTerminationEvent -> m ()
forall (m :: * -> *).
PeerId
-> Tracer m [Char] -> TraceChainSyncClientTerminationEvent -> m ()
traceChainSyncClientTerminationEventTestBlockWith PeerId
peerId Tracer m [Char]
tracer TraceChainSyncClientTerminationEvent
traceEvent
  TraceBlockFetchClientTerminationEvent PeerId
peerId TraceBlockFetchClientTerminationEvent
traceEvent -> PeerId
-> Tracer m [Char] -> TraceBlockFetchClientTerminationEvent -> m ()
forall (m :: * -> *).
PeerId
-> Tracer m [Char] -> TraceBlockFetchClientTerminationEvent -> m ()
traceBlockFetchClientTerminationEventTestBlockWith PeerId
peerId Tracer m [Char]
tracer TraceBlockFetchClientTerminationEvent
traceEvent
  TraceGenesisDDEvent TraceGDDEvent PeerId blk
gddEvent -> Tracer m [Char] -> [Char] -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m [Char]
tracer (TraceGDDEvent PeerId blk -> [Char]
forall blk.
(HasHeader (Header blk), Terse blk) =>
TraceGDDEvent PeerId blk -> [Char]
terseGDDEvent TraceGDDEvent PeerId blk
gddEvent)
  TraceChainSyncSendRecvEvent PeerId
peerId [Char]
peerType TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))
traceEvent -> PeerId
-> [Char]
-> Tracer m [Char]
-> TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))
-> m ()
forall (m :: * -> *) blk.
(Applicative m, Terse blk) =>
PeerId
-> [Char]
-> Tracer m [Char]
-> TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))
-> m ()
traceChainSyncSendRecvEventTestBlockWith PeerId
peerId [Char]
peerType Tracer m [Char]
tracer TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))
traceEvent
  TraceDbfEvent TraceEventDbf PeerId
traceEvent -> Tracer m [Char] -> TraceEventDbf PeerId -> m ()
forall (m :: * -> *).
Tracer m [Char] -> TraceEventDbf PeerId -> m ()
traceDbjEventWith Tracer m [Char]
tracer TraceEventDbf PeerId
traceEvent
  TraceCsjEvent PeerId
peerId TraceEventCsj PeerId blk
traceEvent -> PeerId -> Tracer m [Char] -> TraceEventCsj PeerId blk -> m ()
forall blk (m :: * -> *).
Terse blk =>
PeerId -> Tracer m [Char] -> TraceEventCsj PeerId blk -> m ()
traceCsjEventWith PeerId
peerId Tracer m [Char]
tracer TraceEventCsj PeerId blk
traceEvent
  TraceOther [Char]
msg -> Tracer m [Char] -> [Char] -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m [Char]
tracer [Char]
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 [Char]
-> Tracer m [Char]
-> TraceSchedulerEvent blk
-> m ()
traceSchedulerEventTestBlockWith Time -> m ()
setTickTime Tracer m [Char]
tracer0 Tracer m [Char]
tracer = \case
  TraceSchedulerEvent blk
TraceBeginningOfTime ->
    Tracer m [Char] -> [Char] -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m [Char]
tracer0 [Char]
"Running point schedule ..."
  TraceSchedulerEvent blk
TraceEndOfTime ->
    Tracer m [Char] -> [[Char]] -> m ()
forall (m :: * -> *). Tracer m [Char] -> [[Char]] -> m ()
traceLinesWith
      Tracer m [Char]
tracer0
      [ [Char]
"╶──────────────────────────────────────────────────────────────────────────────╴"
      , [Char]
"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 [Char] -> [Char] -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m [Char]
tracer ([Char]
"  Initiating node shutdown with immutable tip at slot " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ WithOrigin SlotNo -> [Char]
forall a. Condense a => a -> [Char]
condense WithOrigin SlotNo
immTip)
  TraceSchedulerEvent blk
TraceNodeShutdownComplete ->
    Tracer m [Char] -> [Char] -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m [Char]
tracer [Char]
"  Node shutdown complete"
  TraceSchedulerEvent blk
TraceNodeStartupStart ->
    Tracer m [Char] -> [Char] -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m [Char]
tracer [Char]
"  Initiating node startup"
  TraceNodeStartupComplete AnchoredFragment (Header blk)
selection ->
    Tracer m [Char] -> [Char] -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m [Char]
tracer ([Char]
"  Node startup complete with selection " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AnchoredFragment (Header blk) -> [Char]
forall blk. Terse blk => AnchoredFragment (Header blk) -> [Char]
terseHFragment AnchoredFragment (Header blk)
selection)
 where
  traceJumpingStates :: forall n. [(PeerId, ChainSyncJumpingState n blk)] -> String
  traceJumpingStates :: forall (n :: * -> *).
[(PeerId, ChainSyncJumpingState n blk)] -> [Char]
traceJumpingStates = [[Char]] -> [Char]
unlines ([[Char]] -> [Char])
-> ([(PeerId, ChainSyncJumpingState n blk)] -> [[Char]])
-> [(PeerId, ChainSyncJumpingState n blk)]
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PeerId, ChainSyncJumpingState n blk) -> [Char])
-> [(PeerId, ChainSyncJumpingState n blk)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\(PeerId
pid, ChainSyncJumpingState n blk
state) -> [Char]
"    " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PeerId -> [Char]
forall a. Condense a => a -> [Char]
condense PeerId
pid [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ChainSyncJumpingState n blk -> [Char]
forall (n :: * -> *). ChainSyncJumpingState n blk -> [Char]
traceJumpingState ChainSyncJumpingState n blk
state)

  traceJumpingState :: forall n. ChainSyncJumpingState n blk -> String
  traceJumpingState :: forall (n :: * -> *). ChainSyncJumpingState n blk -> [Char]
traceJumpingState = \case
    Dynamo DynamoInitState blk
initState WithOrigin SlotNo
lastJump ->
      let showInitState :: [Char]
showInitState = case DynamoInitState blk
initState of
            DynamoStarting JumpInfo blk
ji -> [Char]
"(DynamoStarting " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ JumpInfo blk -> [Char]
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> [Char]
terseJumpInfo JumpInfo blk
ji [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
            DynamoInitState blk
DynamoStarted -> [Char]
"DynamoStarted"
       in [[Char]] -> [Char]
unwords [[Char]
"Dynamo", [Char]
showInitState, (SlotNo -> [Char]) -> WithOrigin SlotNo -> [Char]
forall a. (a -> [Char]) -> WithOrigin a -> [Char]
terseWithOrigin SlotNo -> [Char]
forall a. Show a => a -> [Char]
show WithOrigin SlotNo
lastJump]
    Objector ObjectorInitState
initState JumpInfo blk
goodJumpInfo Point (Header blk)
badPoint ->
      [[Char]] -> [Char]
unwords
        [ [Char]
"Objector"
        , ObjectorInitState -> [Char]
forall a. Show a => a -> [Char]
show ObjectorInitState
initState
        , JumpInfo blk -> [Char]
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> [Char]
terseJumpInfo JumpInfo blk
goodJumpInfo
        , forall blk. Terse blk => Point blk -> [Char]
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 -> [Char]
"Disengaged " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DisengagedInitState -> [Char]
forall a. Show a => a -> [Char]
show DisengagedInitState
initState
    Jumper StrictTVar n (Maybe (JumpInfo blk))
_ ChainSyncJumpingJumperState blk
st -> [Char]
"Jumper _ " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ChainSyncJumpingJumperState blk -> [Char]
traceJumperState ChainSyncJumpingJumperState blk
st

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

traceScheduledServerHandlerEventTestBlockWith ::
  Condense (NodeState blk) =>
  Tracer m String ->
  String ->
  TraceScheduledServerHandlerEvent (NodeState blk) blk ->
  m ()
traceScheduledServerHandlerEventTestBlockWith :: forall blk (m :: * -> *).
Condense (NodeState blk) =>
Tracer m [Char]
-> [Char]
-> TraceScheduledServerHandlerEvent (NodeState blk) blk
-> m ()
traceScheduledServerHandlerEventTestBlockWith Tracer m [Char]
tracer [Char]
unit = \case
  TraceHandling [Char]
handler NodeState blk
state ->
    [[Char]] -> m ()
traceLines
      [ [Char]
"handling " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
handler
      , [Char]
"  state is " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NodeState blk -> [Char]
forall a. Condense a => a -> [Char]
condense NodeState blk
state
      ]
  TraceRestarting [Char]
_ ->
    [Char] -> m ()
trace [Char]
"  cannot serve at this point; waiting for node state and starting again"
  TraceDoneHandling [Char]
handler ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"done handling " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
handler
 where
  trace :: [Char] -> m ()
trace = Tracer m [Char] -> [Char] -> [Char] -> m ()
forall (m :: * -> *). Tracer m [Char] -> [Char] -> [Char] -> m ()
traceUnitWith Tracer m [Char]
tracer [Char]
unit
  traceLines :: [[Char]] -> m ()
traceLines = Tracer m [Char] -> [Char] -> [[Char]] -> m ()
forall (m :: * -> *). Tracer m [Char] -> [Char] -> [[Char]] -> m ()
traceUnitLinesWith Tracer m [Char]
tracer [Char]
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 [Char]
-> PeerId
-> TraceScheduledChainSyncServerEvent (NodeState blk) blk
-> m ()
traceScheduledChainSyncServerEventTestBlockWith Tracer m [Char]
tracer PeerId
peerId = \case
  TraceHandlerEventCS TraceScheduledServerHandlerEvent (NodeState blk) blk
traceEvent -> Tracer m [Char]
-> [Char]
-> TraceScheduledServerHandlerEvent (NodeState blk) blk
-> m ()
forall blk (m :: * -> *).
Condense (NodeState blk) =>
Tracer m [Char]
-> [Char]
-> TraceScheduledServerHandlerEvent (NodeState blk) blk
-> m ()
traceScheduledServerHandlerEventTestBlockWith Tracer m [Char]
tracer [Char]
unit TraceScheduledServerHandlerEvent (NodeState blk) blk
traceEvent
  TraceLastIntersection Point blk
point ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  last intersection is " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Point blk -> [Char]
forall blk. Terse blk => Point blk -> [Char]
tersePoint Point blk
point
  TraceScheduledChainSyncServerEvent (NodeState blk) blk
TraceClientIsDone ->
    [Char] -> m ()
trace [Char]
"received MsgDoneClient"
  TraceScheduledChainSyncServerEvent (NodeState blk) blk
TraceIntersectionNotFound ->
    [Char] -> m ()
trace [Char]
"  no intersection found"
  TraceIntersectionFound Point blk
point ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  intersection found: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Point blk -> [Char]
forall blk. Terse blk => Point blk -> [Char]
tersePoint Point blk
point
  TraceRollForward Header blk
header Tip blk
tip ->
    [[Char]] -> m ()
traceLines
      [ [Char]
"  gotta serve " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Header blk -> [Char]
forall blk. Terse blk => Header blk -> [Char]
terseHeader Header blk
header
      , [Char]
"  tip is      " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Tip blk -> [Char]
forall blk. Terse blk => Tip blk -> [Char]
terseTip Tip blk
tip
      ]
  TraceRollBackward Point blk
point Tip blk
tip ->
    [[Char]] -> m ()
traceLines
      [ [Char]
"  gotta roll back to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Point blk -> [Char]
forall blk. Terse blk => Point blk -> [Char]
tersePoint Point blk
point
      , [Char]
"  new tip is      " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Tip blk -> [Char]
forall blk. Terse blk => Tip blk -> [Char]
terseTip Tip blk
tip
      ]
  TraceScheduledChainSyncServerEvent (NodeState blk) blk
TraceChainIsFullyServed ->
    [Char] -> m ()
trace [Char]
"  chain has been fully served"
  TraceScheduledChainSyncServerEvent (NodeState blk) blk
TraceIntersectionIsHeaderPoint ->
    [Char] -> m ()
trace [Char]
"  intersection is exactly our header point"
  TraceIntersectionIsStrictAncestorOfHeaderPoint AnchoredFragment blk
fragment ->
    [[Char]] -> m ()
traceLines
      [ [Char]
"  intersection is before our header point"
      , [Char]
"  fragment ahead: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AnchoredFragment blk -> [Char]
forall blk. Terse blk => AnchoredFragment blk -> [Char]
terseFragment AnchoredFragment blk
fragment
      ]
  TraceScheduledChainSyncServerEvent (NodeState blk) blk
TraceIntersectionIsStrictDescendentOfHeaderPoint ->
    [Char] -> m ()
trace [Char]
"  intersection is further than our header point"
 where
  unit :: [Char]
unit = [Char]
"ChainSyncServer " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PeerId -> [Char]
forall a. Condense a => a -> [Char]
condense PeerId
peerId
  trace :: [Char] -> m ()
trace = Tracer m [Char] -> [Char] -> [Char] -> m ()
forall (m :: * -> *). Tracer m [Char] -> [Char] -> [Char] -> m ()
traceUnitWith Tracer m [Char]
tracer [Char]
unit
  traceLines :: [[Char]] -> m ()
traceLines = Tracer m [Char] -> [Char] -> [[Char]] -> m ()
forall (m :: * -> *). Tracer m [Char] -> [Char] -> [[Char]] -> m ()
traceUnitLinesWith Tracer m [Char]
tracer [Char]
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 [Char]
-> PeerId
-> TraceScheduledBlockFetchServerEvent (NodeState blk) blk
-> m ()
traceScheduledBlockFetchServerEventTestBlockWith Tracer m [Char]
tracer PeerId
peerId = \case
  TraceHandlerEventBF TraceScheduledServerHandlerEvent (NodeState blk) blk
traceEvent -> Tracer m [Char]
-> [Char]
-> TraceScheduledServerHandlerEvent (NodeState blk) blk
-> m ()
forall blk (m :: * -> *).
Condense (NodeState blk) =>
Tracer m [Char]
-> [Char]
-> TraceScheduledServerHandlerEvent (NodeState blk) blk
-> m ()
traceScheduledServerHandlerEventTestBlockWith Tracer m [Char]
tracer [Char]
unit TraceScheduledServerHandlerEvent (NodeState blk) blk
traceEvent
  TraceScheduledBlockFetchServerEvent (NodeState blk) blk
TraceNoBlocks ->
    [Char] -> m ()
trace [Char]
"  no blocks available"
  TraceStartingBatch AnchoredFragment blk
fragment ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Starting batch for slice " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AnchoredFragment blk -> [Char]
forall blk. Terse blk => AnchoredFragment blk -> [Char]
terseFragment AnchoredFragment blk
fragment
  TraceWaitingForRange Point blk
pointFrom Point blk
pointTo ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Waiting for next tick for range: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Point blk -> [Char]
forall blk. Terse blk => Point blk -> [Char]
tersePoint Point blk
pointFrom [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" -> " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Point blk -> [Char]
forall blk. Terse blk => Point blk -> [Char]
tersePoint Point blk
pointTo
  TraceSendingBlock blk
block ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Sending " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ blk -> [Char]
forall blk. Terse blk => blk -> [Char]
terseBlock blk
block
  TraceScheduledBlockFetchServerEvent (NodeState blk) blk
TraceBatchIsDone ->
    [Char] -> m ()
trace [Char]
"Batch is done"
  TraceScheduledBlockFetchServerEvent (NodeState blk) blk
TraceBlockPointIsBehind ->
    [Char] -> m ()
trace [Char]
"BP is behind"
 where
  unit :: [Char]
unit = [Char]
"BlockFetchServer " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PeerId -> [Char]
forall a. Condense a => a -> [Char]
condense PeerId
peerId
  trace :: [Char] -> m ()
trace = Tracer m [Char] -> [Char] -> [Char] -> m ()
forall (m :: * -> *). Tracer m [Char] -> [Char] -> [Char] -> m ()
traceUnitWith Tracer m [Char]
tracer [Char]
unit

traceChainDBEventTestBlockWith ::
  Monad m =>
  Terse blk =>
  Tracer m String ->
  ChainDB.TraceEvent blk ->
  m ()
traceChainDBEventTestBlockWith :: forall (m :: * -> *) blk.
(Monad m, Terse blk) =>
Tracer m [Char] -> TraceEvent blk -> m ()
traceChainDBEventTestBlockWith Tracer m [Char]
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
_ ->
        [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Added to current chain; now: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AnchoredFragment (Header blk) -> [Char]
forall blk. Terse blk => AnchoredFragment (Header blk) -> [Char]
terseHFragment AnchoredFragment (Header blk)
newFragment
      SwitchedToAFork [LedgerEvent blk]
_ SelectionChangedInfo blk
_ AnchoredFragment (Header blk)
_ AnchoredFragment (Header blk)
newFragment ReasonForSwitch' blk
_ ->
        [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Switched to a fork; now: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AnchoredFragment (Header blk) -> [Char]
forall blk. Terse blk => AnchoredFragment (Header blk) -> [Char]
terseHFragment AnchoredFragment (Header blk)
newFragment
      StoreButDontChange RealPoint blk
point ->
        [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Did not select block due to LoE: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RealPoint blk -> [Char]
forall blk. Terse blk => RealPoint blk -> [Char]
terseRealPoint RealPoint blk
point
      IgnoreBlockOlderThanImmTip RealPoint blk
point ->
        [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Ignored block older than imm tip: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RealPoint blk -> [Char]
forall blk. Terse blk => RealPoint blk -> [Char]
terseRealPoint RealPoint blk
point
      ChainSelectionLoEDebug AnchoredFragment (Header blk)
curChain (LoEEnabled AnchoredFragment (Header blk)
loeFrag0) -> do
        [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Current chain: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AnchoredFragment (Header blk) -> [Char]
forall blk. Terse blk => AnchoredFragment (Header blk) -> [Char]
terseHFragment AnchoredFragment (Header blk)
curChain
        [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"LoE fragment: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AnchoredFragment (Header blk) -> [Char]
forall blk. Terse blk => AnchoredFragment (Header blk) -> [Char]
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 ->
        [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Requesting ChainSel run..."
      AddedReprocessLoEBlocksToQueue FallingEdgeWith{} ->
        [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"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) ->
    [Char] -> m ()
trace [Char]
"ChainSel starvation started"
  ChainDB.TraceChainSelStarvationEvent (ChainDB.ChainSelStarvation (FallingEdgeWith RealPoint blk
pt)) ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"ChainSel starvation ended thanks to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ RealPoint blk -> [Char]
forall blk. Terse blk => RealPoint blk -> [Char]
terseRealPoint RealPoint blk
pt
  TraceEvent blk
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  trace :: [Char] -> m ()
trace = Tracer m [Char] -> [Char] -> [Char] -> m ()
forall (m :: * -> *). Tracer m [Char] -> [Char] -> [Char] -> m ()
traceUnitWith Tracer m [Char]
tracer [Char]
"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 [Char] -> TraceChainSyncClientEvent blk -> m ()
traceChainSyncClientEventTestBlockWith PeerId
pid Tracer m [Char]
tracer = \case
  TraceRolledBack Point blk
point ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Rolled back to: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Point blk -> [Char]
forall blk. Terse blk => Point blk -> [Char]
tersePoint Point blk
point
  TraceFoundIntersection Point blk
point Our (Tip blk)
_ourTip Their (Tip blk)
_theirTip ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Found intersection at: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Point blk -> [Char]
forall blk. Terse blk => Point blk -> [Char]
tersePoint Point blk
point
  TraceWaitingBeyondForecastHorizon SlotNo
slot ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Waiting for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SlotNo -> [Char]
forall a. Show a => a -> [Char]
show SlotNo
slot [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" beyond forecast horizon"
  TraceAccessingForecastHorizon SlotNo
slot ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Accessing " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SlotNo -> [Char]
forall a. Show a => a -> [Char]
show SlotNo
slot [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", previously beyond forecast horizon"
  TraceValidatedHeader Header blk
header ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Validated header: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Header blk -> [Char]
forall blk. Terse blk => Header blk -> [Char]
terseHeader Header blk
header
  TraceDownloadedHeader Header blk
header ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Downloaded header: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Header blk -> [Char]
forall blk. Terse blk => Header blk -> [Char]
terseHeader Header blk
header
  TraceGaveLoPToken Bool
didGive Header blk
header BlockNo
bestBlockNo ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$
      (if Bool
didGive then [Char]
"Gave" else [Char]
"Did not give")
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" LoP token to "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Header blk -> [Char]
forall blk. Terse blk => Header blk -> [Char]
terseHeader Header blk
header
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" compared to "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ BlockNo -> [Char]
forall a. Show a => a -> [Char]
show BlockNo
bestBlockNo
  TraceException ChainSyncClientException
exception ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Threw an exception: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ChainSyncClientException -> [Char]
forall a. Show a => a -> [Char]
show ChainSyncClientException
exception
  TraceTermination ChainSyncClientResult
result ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Terminated with result: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ChainSyncClientResult -> [Char]
forall a. Show a => a -> [Char]
show ChainSyncClientResult
result
  TraceOfferJump Point blk
point ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Offering jump to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Point blk -> [Char]
forall blk. Terse blk => Point blk -> [Char]
tersePoint Point blk
point
  TraceJumpResult (AcceptedJump (JumpTo JumpInfo blk
ji)) ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Accepted jump to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ JumpInfo blk -> [Char]
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> [Char]
terseJumpInfo JumpInfo blk
ji
  TraceJumpResult (RejectedJump (JumpTo JumpInfo blk
ji)) ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Rejected jump to " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ JumpInfo blk -> [Char]
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> [Char]
terseJumpInfo JumpInfo blk
ji
  TraceJumpResult (AcceptedJump (JumpToGoodPoint JumpInfo blk
ji)) ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Accepted jump to good point: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ JumpInfo blk -> [Char]
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> [Char]
terseJumpInfo JumpInfo blk
ji
  TraceJumpResult (RejectedJump (JumpToGoodPoint JumpInfo blk
ji)) ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Rejected jump to good point: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ JumpInfo blk -> [Char]
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> [Char]
terseJumpInfo JumpInfo blk
ji
  TraceChainSyncClientEvent blk
TraceJumpingWaitingForNextInstruction ->
    [Char] -> m ()
trace [Char]
"Waiting for next instruction from the jumping governor"
  TraceJumpingInstructionIs Instruction blk
instr ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Received instruction: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Instruction blk -> [Char]
showInstr Instruction blk
instr
  TraceDrainingThePipe Nat n
n ->
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Draining the pipe, remaining messages: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Nat n -> [Char]
forall a. Show a => a -> [Char]
show Nat n
n
 where
  trace :: [Char] -> m ()
trace = Tracer m [Char] -> [Char] -> [Char] -> m ()
forall (m :: * -> *). Tracer m [Char] -> [Char] -> [Char] -> m ()
traceUnitWith Tracer m [Char]
tracer ([Char]
"ChainSyncClient " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PeerId -> [Char]
forall a. Condense a => a -> [Char]
condense PeerId
pid)

  showInstr :: Instruction blk -> String
  showInstr :: Instruction blk -> [Char]
showInstr = \case
    JumpInstruction (JumpTo JumpInfo blk
ji) -> [Char]
"JumpTo " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ JumpInfo blk -> [Char]
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> [Char]
terseJumpInfo JumpInfo blk
ji
    JumpInstruction (JumpToGoodPoint JumpInfo blk
ji) -> [Char]
"JumpToGoodPoint " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ JumpInfo blk -> [Char]
forall blk.
(HasHeader (Header blk), Terse blk, Typeable blk) =>
JumpInfo blk -> [Char]
terseJumpInfo JumpInfo blk
ji
    Instruction blk
RunNormally -> [Char]
"RunNormally"
    Instruction blk
Restart -> [Char]
"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 -> [Char]
terseJumpInfo JumpInfo blk
ji = forall blk. Terse blk => Point blk -> [Char]
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 [Char] -> TraceChainSyncClientTerminationEvent -> m ()
traceChainSyncClientTerminationEventTestBlockWith PeerId
pid Tracer m [Char]
tracer = \case
  TraceChainSyncClientTerminationEvent
TraceExceededSizeLimitCS ->
    [Char] -> m ()
trace [Char]
"Terminated because of size limit exceeded."
  TraceChainSyncClientTerminationEvent
TraceExceededTimeLimitCS ->
    [Char] -> m ()
trace [Char]
"Terminated because of time limit exceeded."
  TraceChainSyncClientTerminationEvent
TraceTerminatedByGDDGovernor ->
    [Char] -> m ()
trace [Char]
"Terminated by the GDD governor."
  TraceChainSyncClientTerminationEvent
TraceTerminatedByLoP ->
    [Char] -> m ()
trace [Char]
"Terminated by the limit on patience."
 where
  trace :: [Char] -> m ()
trace = Tracer m [Char] -> [Char] -> [Char] -> m ()
forall (m :: * -> *). Tracer m [Char] -> [Char] -> [Char] -> m ()
traceUnitWith Tracer m [Char]
tracer ([Char]
"ChainSyncClient " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PeerId -> [Char]
forall a. Condense a => a -> [Char]
condense PeerId
pid)

traceBlockFetchClientTerminationEventTestBlockWith ::
  PeerId ->
  Tracer m String ->
  TraceBlockFetchClientTerminationEvent ->
  m ()
traceBlockFetchClientTerminationEventTestBlockWith :: forall (m :: * -> *).
PeerId
-> Tracer m [Char] -> TraceBlockFetchClientTerminationEvent -> m ()
traceBlockFetchClientTerminationEventTestBlockWith PeerId
pid Tracer m [Char]
tracer = \case
  TraceBlockFetchClientTerminationEvent
TraceExceededSizeLimitBF ->
    [Char] -> m ()
trace [Char]
"Terminated because of size limit exceeded."
  TraceBlockFetchClientTerminationEvent
TraceExceededTimeLimitBF ->
    [Char] -> m ()
trace [Char]
"Terminated because of time limit exceeded."
 where
  trace :: [Char] -> m ()
trace = Tracer m [Char] -> [Char] -> [Char] -> m ()
forall (m :: * -> *). Tracer m [Char] -> [Char] -> [Char] -> m ()
traceUnitWith Tracer m [Char]
tracer ([Char]
"BlockFetchClient " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PeerId -> [Char]
forall a. Condense a => a -> [Char]
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
-> [Char]
-> Tracer m [Char]
-> TraceSendRecv (ChainSync (Header blk) (Point blk) (Tip blk))
-> m ()
traceChainSyncSendRecvEventTestBlockWith PeerId
pid [Char]
ptp Tracer m [Char]
tracer = \case
  TraceSendMsg AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))
amsg -> [Char]
-> AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))
-> m ()
traceMsg [Char]
"send" AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))
amsg
  TraceRecvMsg AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))
amsg -> [Char]
-> AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))
-> m ()
traceMsg [Char]
"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 :: [Char] -> m ()
trace = (\PeerId
_ [Char]
_ Tracer m [Char]
_ -> m () -> [Char] -> 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 [Char]
ptp Tracer m [Char]
tracer
  traceMsg :: [Char]
-> AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))
-> m ()
traceMsg [Char]
kd AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))
amsg =
    [Char] -> m ()
trace ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$
      [Char]
kd [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
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 -> [Char]
"MsgRequestNext"
          Message (ChainSync (Header blk) (Point blk) (Tip blk)) st st'
R:MessageChainSyncfromto (Header blk) (Point blk) (Tip blk) st st'
MsgAwaitReply -> [Char]
"MsgAwaitReply"
          MsgRollForward Header blk
header Tip blk
tip -> [Char]
"MsgRollForward " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Header blk -> [Char]
forall blk. Terse blk => Header blk -> [Char]
terseHeader Header blk
header [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Tip blk -> [Char]
forall blk. Terse blk => Tip blk -> [Char]
terseTip Tip blk
tip
          MsgRollBackward Point blk
point Tip blk
tip -> [Char]
"MsgRollBackward " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Point blk -> [Char]
forall blk. Terse blk => Point blk -> [Char]
tersePoint Point blk
point [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Tip blk -> [Char]
forall blk. Terse blk => Tip blk -> [Char]
terseTip Tip blk
tip
          MsgFindIntersect [Point blk]
points -> [Char]
"MsgFindIntersect [" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
unwords ((Point blk -> [Char]) -> [Point blk] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Point blk -> [Char]
forall blk. Terse blk => Point blk -> [Char]
tersePoint [Point blk]
points) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]"
          MsgIntersectFound Point blk
point Tip blk
tip -> [Char]
"MsgIntersectFound " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Point blk -> [Char]
forall blk. Terse blk => Point blk -> [Char]
tersePoint Point blk
point [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Tip blk -> [Char]
forall blk. Terse blk => Tip blk -> [Char]
terseTip Tip blk
tip
          MsgIntersectNotFound Tip blk
tip -> [Char]
"MsgIntersectNotFound " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Tip blk -> [Char]
forall blk. Terse blk => Tip blk -> [Char]
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 -> [Char]
"MsgDone"

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

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

  g :: TraceCsjReason -> [Char]
g = \case
    TraceCsjReason
BecauseCsjDisconnect -> [Char]
"disconnected"
    TraceCsjReason
BecauseCsjDisengage -> [Char]
"disengaged"

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

  replacing :: Maybe PeerId -> [Char]
replacing = \case
    Maybe PeerId
Nothing -> [Char]
""
    Just PeerId
old -> [Char]
", replacing: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PeerId -> [Char]
forall a. Condense a => a -> [Char]
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)] -> [[Char]]
prettyDensityBounds [(PeerId, DensityBounds blk)]
bounds =
  [(PeerId, [Char])] -> [[Char]]
showPeers ((DensityBounds blk -> [Char])
-> (PeerId, DensityBounds blk) -> (PeerId, [Char])
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 -> [Char]
showBounds ((PeerId, DensityBounds blk) -> (PeerId, [Char]))
-> [(PeerId, DensityBounds blk)] -> [(PeerId, [Char])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, DensityBounds blk)]
bounds)
 where
  showBounds :: DensityBounds blk -> [Char]
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 -> [Char]
forall a. Show a => a -> [Char]
show Word64
lowerBound
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/"
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
upperBound
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"["
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
more
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"], "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
lastPoint
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"latest: "
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ WithOrigin SlotNo -> [Char]
showLatestSlot WithOrigin SlotNo
latestSlot
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
block
        [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
showIdling
     where
      more :: [Char]
more = if Bool
offersMoreThanK then [Char]
"+" else [Char]
" "

      block :: [Char]
block = if Bool
hasBlockAfter then [Char]
", has header after sgen" else [Char]
" "

      -- 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 :: [Char]
lastPoint =
        [Char]
"point: "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Point blk -> [Char]
forall blk. Terse blk => Point blk -> [Char]
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))
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", "

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

      showIdling :: [Char]
showIdling
        | Bool
idling = [Char]
", idling"
        | Bool
otherwise = [Char]
""

showPeers :: [(PeerId, String)] -> [String]
showPeers :: [(PeerId, [Char])] -> [[Char]]
showPeers = ((PeerId, [Char]) -> [Char]) -> [(PeerId, [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\(PeerId
peer, [Char]
v) -> [Char]
"        " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PeerId -> [Char]
forall a. Condense a => a -> [Char]
condense PeerId
peer [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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 -> [Char]
terseGDDEvent = \case
  TraceGDDDisconnected NonEmpty PeerId
peers -> [Char]
"GDD | Disconnected " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [PeerId] -> [Char]
forall a. Show a => a -> [Char]
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
      } ->
      [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
        [ [Char]
"GDD | Window: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> Anchor (Header blk) -> [Char]
forall {block}. Word64 -> Anchor block -> [Char]
window Word64
sgen Anchor (Header blk)
loeHead
        , [Char]
"      Selection: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ AnchoredFragment (Header blk) -> [Char]
forall blk. Terse blk => AnchoredFragment (Header blk) -> [Char]
terseHFragment AnchoredFragment (Header blk)
curChain
        , [Char]
"      Candidates:"
        ]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [(PeerId, [Char])] -> [[Char]]
showPeers ((AnchoredFragment (Header blk) -> [Char])
-> (PeerId, AnchoredFragment (Header blk)) -> (PeerId, [Char])
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 -> [Char]
tersePoint @blk (Point blk -> [Char])
-> (AnchoredFragment (Header blk) -> Point blk)
-> AnchoredFragment (Header blk)
-> [Char]
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, [Char]))
-> [(PeerId, AnchoredFragment (Header blk))] -> [(PeerId, [Char])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, AnchoredFragment (Header blk))]
candidates)
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [ [Char]
"      Candidate suffixes (bounds):"
             ]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [(PeerId, [Char])] -> [[Char]]
showPeers ((DensityBounds blk -> [Char])
-> (PeerId, DensityBounds blk) -> (PeerId, [Char])
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) -> [Char]
forall blk. Terse blk => AnchoredFragment (Header blk) -> [Char]
terseHFragment (AnchoredFragment (Header blk) -> [Char])
-> (DensityBounds blk -> AnchoredFragment (Header blk))
-> DensityBounds blk
-> [Char]
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, [Char]))
-> [(PeerId, DensityBounds blk)] -> [(PeerId, [Char])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, DensityBounds blk)]
bounds)
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"      Density bounds:"]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [(PeerId, DensityBounds blk)] -> [[Char]]
forall blk.
(HasHeader (Header blk), Terse blk) =>
[(PeerId, DensityBounds blk)] -> [[Char]]
prettyDensityBounds [(PeerId, DensityBounds blk)]
bounds
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"      New candidate tips:"]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [(PeerId, [Char])] -> [[Char]]
showPeers ((AnchoredFragment (Header blk) -> [Char])
-> (PeerId, AnchoredFragment (Header blk)) -> (PeerId, [Char])
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 -> [Char]
tersePoint @blk (Point blk -> [Char])
-> (AnchoredFragment (Header blk) -> Point blk)
-> AnchoredFragment (Header blk)
-> [Char]
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, [Char]))
-> [(PeerId, AnchoredFragment (Header blk))] -> [(PeerId, [Char])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PeerId, AnchoredFragment (Header blk))]
candidateSuffixes)
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [ [Char]
"      Losing peers: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [PeerId] -> [Char]
forall a. Show a => a -> [Char]
show [PeerId]
losingPeers
             , [Char]
"      Setting loeFrag: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ forall blk. Terse blk => Anchor blk -> [Char]
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 -> [Char]
window Word64
sgen Anchor block
loeHead =
    Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
winStart [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" -> " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word64 -> [Char]
forall a. Show a => a -> [Char]
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 -> [Char]
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 [Char] -> Integer -> Integer -> Integer -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%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 [Char] -> [[Char]] -> m ()
traceLinesWith Tracer m [Char]
tracer = Tracer m [Char] -> [Char] -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m [Char]
tracer ([Char] -> m ()) -> ([[Char]] -> [Char]) -> [[Char]] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> [Char]
forall a. Monoid a => [a] -> a
mconcat ([[Char]] -> [Char])
-> ([[Char]] -> [[Char]]) -> [[Char]] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
intersperse [Char]
"\n"

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

padUnit :: String -> String
padUnit :: [Char] -> [Char]
padUnit [Char]
unit = [Char]
unit [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int
maxUnitLength Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
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 [Char] -> [Char] -> [[Char]] -> m ()
traceUnitLinesWith Tracer m [Char]
tracer [Char]
unit [[Char]]
msgs =
  Tracer m [Char] -> [[Char]] -> m ()
forall (m :: * -> *). Tracer m [Char] -> [[Char]] -> m ()
traceLinesWith Tracer m [Char]
tracer ([[Char]] -> m ()) -> [[Char]] -> m ()
forall a b. (a -> b) -> a -> b
$ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%s | %s" ([Char] -> [Char] -> [Char]) -> [Char] -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
padUnit [Char]
unit) [[Char]]
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 [Char] -> [Char] -> [Char] -> m ()
traceUnitWith Tracer m [Char]
tracer [Char]
unit [Char]
msg = Tracer m [Char] -> [Char] -> [[Char]] -> m ()
forall (m :: * -> *). Tracer m [Char] -> [Char] -> [[Char]] -> m ()
traceUnitLinesWith Tracer m [Char]
tracer [Char]
unit [[Char]
msg]