{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Consensus.PeerSimulator.StateView
  ( PeerSimulatorComponent (..)
  , PeerSimulatorComponentResult (..)
  , PeerSimulatorResult (..)
  , StateView (..)
  , StateViewTracers (..)
  , collectDisconnectedPeers
  , defaultStateViewTracers
  , exceptionsByComponent
  , pscrToException
  , snapshotStateView
  , stateViewTracersWithInitial
  ) where

import Control.Tracer (Tracer, traceWith)
import Data.Containers.ListUtils (nubOrd)
import Data.Foldable (for_)
import Data.List (sort)
import Data.Maybe (mapMaybe)
import Network.TypedProtocol.Codec (AnyMessage)
import Ouroboros.Consensus.Block (Header, Point)
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client as CSClient
import Ouroboros.Consensus.Storage.ChainDB (ChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
import Ouroboros.Consensus.Util.Condense
  ( Condense (..)
  , CondenseList (..)
  , PaddingDirection (..)
  , padListWith
  )
import Ouroboros.Consensus.Util.IOLike
  ( IOLike
  , SomeException
  , atomically
  )
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import Ouroboros.Network.Block (StandardHash, Tip)
import Ouroboros.Network.Protocol.BlockFetch.Type (BlockFetch)
import Ouroboros.Network.Protocol.ChainSync.Type (ChainSync)
import Test.Consensus.PeerSimulator.Trace (TraceEvent)
import Test.Consensus.PointSchedule.Peers (PeerId)
import Test.Util.TersePrinting
  ( terseBlock
  , terseHFragment
  , terseMaybe
  )
import Test.Util.TestBlock (TestBlock)
import Test.Util.Tracer (recordingTracerTVar)

-- | A record to associate an exception thrown by a thread
-- running a component of the peer simulator with the peer
-- that it was running for.
data PeerSimulatorResult blk = PeerSimulatorResult
  { forall blk. PeerSimulatorResult blk -> PeerId
psePeerId :: PeerId
  , forall blk.
PeerSimulatorResult blk -> PeerSimulatorComponentResult blk
pseResult :: PeerSimulatorComponentResult blk
  }
  deriving (PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool
(PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool)
-> (PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool)
-> Eq (PeerSimulatorResult blk)
forall blk.
PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool
== :: PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool
$c/= :: forall blk.
PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool
/= :: PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool
Eq, Eq (PeerSimulatorResult blk)
Eq (PeerSimulatorResult blk) =>
(PeerSimulatorResult blk -> PeerSimulatorResult blk -> Ordering)
-> (PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool)
-> (PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool)
-> (PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool)
-> (PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool)
-> (PeerSimulatorResult blk
    -> PeerSimulatorResult blk -> PeerSimulatorResult blk)
-> (PeerSimulatorResult blk
    -> PeerSimulatorResult blk -> PeerSimulatorResult blk)
-> Ord (PeerSimulatorResult blk)
PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool
PeerSimulatorResult blk -> PeerSimulatorResult blk -> Ordering
PeerSimulatorResult blk
-> PeerSimulatorResult blk -> PeerSimulatorResult blk
forall blk. Eq (PeerSimulatorResult blk)
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall blk.
PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool
forall blk.
PeerSimulatorResult blk -> PeerSimulatorResult blk -> Ordering
forall blk.
PeerSimulatorResult blk
-> PeerSimulatorResult blk -> PeerSimulatorResult blk
$ccompare :: forall blk.
PeerSimulatorResult blk -> PeerSimulatorResult blk -> Ordering
compare :: PeerSimulatorResult blk -> PeerSimulatorResult blk -> Ordering
$c< :: forall blk.
PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool
< :: PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool
$c<= :: forall blk.
PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool
<= :: PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool
$c> :: forall blk.
PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool
> :: PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool
$c>= :: forall blk.
PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool
>= :: PeerSimulatorResult blk -> PeerSimulatorResult blk -> Bool
$cmax :: forall blk.
PeerSimulatorResult blk
-> PeerSimulatorResult blk -> PeerSimulatorResult blk
max :: PeerSimulatorResult blk
-> PeerSimulatorResult blk -> PeerSimulatorResult blk
$cmin :: forall blk.
PeerSimulatorResult blk
-> PeerSimulatorResult blk -> PeerSimulatorResult blk
min :: PeerSimulatorResult blk
-> PeerSimulatorResult blk -> PeerSimulatorResult blk
Ord)

data PeerSimulatorComponent
  = ChainSyncClient
  | ChainSyncServer
  | BlockFetchClient
  | BlockFetchServer
  deriving (PeerSimulatorComponent -> PeerSimulatorComponent -> Bool
(PeerSimulatorComponent -> PeerSimulatorComponent -> Bool)
-> (PeerSimulatorComponent -> PeerSimulatorComponent -> Bool)
-> Eq PeerSimulatorComponent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PeerSimulatorComponent -> PeerSimulatorComponent -> Bool
== :: PeerSimulatorComponent -> PeerSimulatorComponent -> Bool
$c/= :: PeerSimulatorComponent -> PeerSimulatorComponent -> Bool
/= :: PeerSimulatorComponent -> PeerSimulatorComponent -> Bool
Eq, Eq PeerSimulatorComponent
Eq PeerSimulatorComponent =>
(PeerSimulatorComponent -> PeerSimulatorComponent -> Ordering)
-> (PeerSimulatorComponent -> PeerSimulatorComponent -> Bool)
-> (PeerSimulatorComponent -> PeerSimulatorComponent -> Bool)
-> (PeerSimulatorComponent -> PeerSimulatorComponent -> Bool)
-> (PeerSimulatorComponent -> PeerSimulatorComponent -> Bool)
-> (PeerSimulatorComponent
    -> PeerSimulatorComponent -> PeerSimulatorComponent)
-> (PeerSimulatorComponent
    -> PeerSimulatorComponent -> PeerSimulatorComponent)
-> Ord PeerSimulatorComponent
PeerSimulatorComponent -> PeerSimulatorComponent -> Bool
PeerSimulatorComponent -> PeerSimulatorComponent -> Ordering
PeerSimulatorComponent
-> PeerSimulatorComponent -> PeerSimulatorComponent
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PeerSimulatorComponent -> PeerSimulatorComponent -> Ordering
compare :: PeerSimulatorComponent -> PeerSimulatorComponent -> Ordering
$c< :: PeerSimulatorComponent -> PeerSimulatorComponent -> Bool
< :: PeerSimulatorComponent -> PeerSimulatorComponent -> Bool
$c<= :: PeerSimulatorComponent -> PeerSimulatorComponent -> Bool
<= :: PeerSimulatorComponent -> PeerSimulatorComponent -> Bool
$c> :: PeerSimulatorComponent -> PeerSimulatorComponent -> Bool
> :: PeerSimulatorComponent -> PeerSimulatorComponent -> Bool
$c>= :: PeerSimulatorComponent -> PeerSimulatorComponent -> Bool
>= :: PeerSimulatorComponent -> PeerSimulatorComponent -> Bool
$cmax :: PeerSimulatorComponent
-> PeerSimulatorComponent -> PeerSimulatorComponent
max :: PeerSimulatorComponent
-> PeerSimulatorComponent -> PeerSimulatorComponent
$cmin :: PeerSimulatorComponent
-> PeerSimulatorComponent -> PeerSimulatorComponent
min :: PeerSimulatorComponent
-> PeerSimulatorComponent -> PeerSimulatorComponent
Ord)

data PeerSimulatorComponentResult blk
  = SomeChainSyncClientResult
      ( Either
          SomeException
          ( CSClient.ChainSyncClientResult
          , Maybe (ChainSyncResult blk)
          )
      )
  | SomeChainSyncServerResult
      ( Either
          SomeException
          (Maybe (ChainSyncResult blk))
      )
  | SomeBlockFetchClientResult
      ( Either
          SomeException
          (Maybe (BlockFetchResult blk))
      )
  | SomeBlockFetchServerResult
      ( Either
          SomeException
          (Maybe (BlockFetchResult blk))
      )

toComponent :: PeerSimulatorComponentResult blk -> PeerSimulatorComponent
toComponent :: forall blk.
PeerSimulatorComponentResult blk -> PeerSimulatorComponent
toComponent (SomeChainSyncClientResult Either
  SomeException (ChainSyncClientResult, Maybe (ChainSyncResult blk))
_) = PeerSimulatorComponent
ChainSyncClient
toComponent (SomeChainSyncServerResult Either SomeException (Maybe (ChainSyncResult blk))
_) = PeerSimulatorComponent
ChainSyncServer
toComponent (SomeBlockFetchClientResult Either SomeException (Maybe (BlockFetchResult blk))
_) = PeerSimulatorComponent
BlockFetchClient
toComponent (SomeBlockFetchServerResult Either SomeException (Maybe (BlockFetchResult blk))
_) = PeerSimulatorComponent
BlockFetchServer

pscrToException :: PeerSimulatorComponentResult blk -> Maybe SomeException
pscrToException :: forall blk. PeerSimulatorComponentResult blk -> Maybe SomeException
pscrToException (SomeChainSyncClientResult (Left SomeException
exn)) = SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
exn
pscrToException (SomeChainSyncServerResult (Left SomeException
exn)) = SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
exn
pscrToException (SomeBlockFetchClientResult (Left SomeException
exn)) = SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
exn
pscrToException (SomeBlockFetchServerResult (Left SomeException
exn)) = SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
exn
pscrToException PeerSimulatorComponentResult blk
_ = Maybe SomeException
forall a. Maybe a
Nothing

instance Eq (PeerSimulatorComponentResult blk) where
  == :: PeerSimulatorComponentResult blk
-> PeerSimulatorComponentResult blk -> Bool
(==) PeerSimulatorComponentResult blk
a PeerSimulatorComponentResult blk
b = PeerSimulatorComponentResult blk -> PeerSimulatorComponent
forall blk.
PeerSimulatorComponentResult blk -> PeerSimulatorComponent
toComponent PeerSimulatorComponentResult blk
a PeerSimulatorComponent -> PeerSimulatorComponent -> Bool
forall a. Eq a => a -> a -> Bool
== PeerSimulatorComponentResult blk -> PeerSimulatorComponent
forall blk.
PeerSimulatorComponentResult blk -> PeerSimulatorComponent
toComponent PeerSimulatorComponentResult blk
b

instance Ord (PeerSimulatorComponentResult blk) where
  compare :: PeerSimulatorComponentResult blk
-> PeerSimulatorComponentResult blk -> Ordering
compare PeerSimulatorComponentResult blk
a PeerSimulatorComponentResult blk
b = PeerSimulatorComponent -> PeerSimulatorComponent -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (PeerSimulatorComponentResult blk -> PeerSimulatorComponent
forall blk.
PeerSimulatorComponentResult blk -> PeerSimulatorComponent
toComponent PeerSimulatorComponentResult blk
a) (PeerSimulatorComponentResult blk -> PeerSimulatorComponent
forall blk.
PeerSimulatorComponentResult blk -> PeerSimulatorComponent
toComponent PeerSimulatorComponentResult blk
b)

instance (StandardHash blk, Show blk, Show (Header blk)) => Condense (PeerSimulatorComponentResult blk) where
  condense :: PeerSimulatorComponentResult blk -> String
condense (SomeChainSyncClientResult (Left SomeException
exn)) =
    String
"(ChainSyncClient  - Interrupted) : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
exn
  condense (SomeChainSyncServerResult (Left SomeException
exn)) =
    String
"(ChainSyncServer  - Interrupted) : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
exn
  condense (SomeBlockFetchClientResult (Left SomeException
exn)) =
    String
"(BlockFetchClient - Interrupted) : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
exn
  condense (SomeBlockFetchServerResult (Left SomeException
exn)) =
    String
"(BlockFetchServer - Interrupted) : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
exn
  condense (SomeChainSyncClientResult (Right (ChainSyncClientResult, Maybe (ChainSyncResult blk))
res)) =
    String
"(ChainSyncClient  - Success)     : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (ChainSyncClientResult, Maybe (ChainSyncResult blk)) -> String
forall a. Show a => a -> String
show (ChainSyncClientResult, Maybe (ChainSyncResult blk))
res
  condense (SomeChainSyncServerResult (Right Maybe (ChainSyncResult blk)
res)) =
    String
"(ChainSyncServer  - Success)     : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe (ChainSyncResult blk) -> String
forall a. Show a => a -> String
show Maybe (ChainSyncResult blk)
res
  condense (SomeBlockFetchClientResult (Right Maybe (BlockFetchResult blk)
res)) =
    String
"(BlockFetchClient - Success)     : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe (BlockFetchResult blk) -> String
forall a. Show a => a -> String
show Maybe (BlockFetchResult blk)
res
  condense (SomeBlockFetchServerResult (Right Maybe (BlockFetchResult blk)
res)) =
    String
"(BlockFetchServer - Success)     : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe (BlockFetchResult blk) -> String
forall a. Show a => a -> String
show Maybe (BlockFetchResult blk)
res

type ChainSyncResult blk = AnyMessage (ChainSync (Header blk) (Point blk) (Tip blk))
type BlockFetchResult blk = AnyMessage (BlockFetch blk (Point blk))

instance (StandardHash blk, Show blk, Show (Header blk)) => Condense (PeerSimulatorResult blk) where
  condense :: PeerSimulatorResult blk -> String
condense PeerSimulatorResult{PeerId
psePeerId :: forall blk. PeerSimulatorResult blk -> PeerId
psePeerId :: PeerId
psePeerId, PeerSimulatorComponentResult blk
pseResult :: forall blk.
PeerSimulatorResult blk -> PeerSimulatorComponentResult blk
pseResult :: PeerSimulatorComponentResult blk
pseResult} =
    PeerId -> String
forall a. Condense a => a -> String
condense PeerId
psePeerId String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PeerSimulatorComponentResult blk -> String
forall a. Condense a => a -> String
condense PeerSimulatorComponentResult blk
pseResult

instance (StandardHash blk, Show blk, Show (Header blk)) => CondenseList (PeerSimulatorResult blk) where
  condenseList :: [PeerSimulatorResult blk] -> [String]
condenseList [PeerSimulatorResult blk]
results =
    (String -> String -> String) -> [String] -> [String] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
      (\String
peerId String
result -> String
peerId String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
result)
      (PaddingDirection -> [String] -> [String]
padListWith PaddingDirection
PadRight ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (PeerSimulatorResult blk -> String)
-> [PeerSimulatorResult blk] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (PeerId -> String
forall a. Show a => a -> String
show (PeerId -> String)
-> (PeerSimulatorResult blk -> PeerId)
-> PeerSimulatorResult blk
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerSimulatorResult blk -> PeerId
forall blk. PeerSimulatorResult blk -> PeerId
psePeerId) [PeerSimulatorResult blk]
results)
      (PaddingDirection -> [String] -> [String]
padListWith PaddingDirection
PadRight ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (PeerSimulatorResult blk -> String)
-> [PeerSimulatorResult blk] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (PeerSimulatorComponentResult blk -> String
forall a. Condense a => a -> String
condense (PeerSimulatorComponentResult blk -> String)
-> (PeerSimulatorResult blk -> PeerSimulatorComponentResult blk)
-> PeerSimulatorResult blk
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PeerSimulatorResult blk -> PeerSimulatorComponentResult blk
forall blk.
PeerSimulatorResult blk -> PeerSimulatorComponentResult blk
pseResult) [PeerSimulatorResult blk]
results)

-- | A state view is a partial view of the state of the whole peer simulator.
-- This includes information about the part of the code that is being tested
-- (for instance the fragment that is selected by the ChainDB) but also
-- information about the mocked peers (for instance the exceptions raised in the
-- mocked ChainSync server threads).
data StateView blk = StateView
  { forall blk. StateView blk -> AnchoredFragment (Header blk)
svSelectedChain :: AnchoredFragment (Header blk)
  , forall blk. StateView blk -> [PeerSimulatorResult blk]
svPeerSimulatorResults :: [PeerSimulatorResult blk]
  , forall blk. StateView blk -> Maybe blk
svTipBlock :: Maybe blk
  -- ^ This field holds the most recent point in the selection (incl. anchor)
  -- for which we have a full block (not just a header).
  , forall blk. StateView blk -> [TraceEvent blk]
svTrace :: [TraceEvent blk]
  -- ^ List of all TraceEvent that have been sent during the simulation.
  }

instance Condense (StateView TestBlock) where
  condense :: StateView TestBlock -> String
condense StateView{AnchoredFragment (Header TestBlock)
svSelectedChain :: forall blk. StateView blk -> AnchoredFragment (Header blk)
svSelectedChain :: AnchoredFragment (Header TestBlock)
svSelectedChain, [PeerSimulatorResult TestBlock]
svPeerSimulatorResults :: forall blk. StateView blk -> [PeerSimulatorResult blk]
svPeerSimulatorResults :: [PeerSimulatorResult TestBlock]
svPeerSimulatorResults, Maybe TestBlock
svTipBlock :: forall blk. StateView blk -> Maybe blk
svTipBlock :: Maybe TestBlock
svTipBlock} =
    String
"SelectedChain: "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ AnchoredFragment (Header TestBlock) -> String
terseHFragment AnchoredFragment (Header TestBlock)
svSelectedChain
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"TipBlock: "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ (TestBlock -> String) -> Maybe TestBlock -> String
forall a. (a -> String) -> Maybe a -> String
terseMaybe TestBlock -> String
terseBlock Maybe TestBlock
svTipBlock
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"PeerSimulatorResults:\n"
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
"  - " String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [PeerSimulatorResult TestBlock] -> [String]
forall a. CondenseList a => [a] -> [String]
condenseList ([PeerSimulatorResult TestBlock] -> [String])
-> [PeerSimulatorResult TestBlock] -> [String]
forall a b. (a -> b) -> a -> b
$ [PeerSimulatorResult TestBlock] -> [PeerSimulatorResult TestBlock]
forall a. Ord a => [a] -> [a]
sort [PeerSimulatorResult TestBlock]
svPeerSimulatorResults)

-- | Return the list of peer ids for all peers whose ChainSync thread or
-- BlockFetch thread was terminated.
collectDisconnectedPeers :: StateView blk -> [PeerId]
collectDisconnectedPeers :: forall blk. StateView blk -> [PeerId]
collectDisconnectedPeers StateView blk
stateView =
  [PeerId] -> [PeerId]
forall a. Ord a => [a] -> [a]
nubOrd ([PeerId] -> [PeerId]) -> [PeerId] -> [PeerId]
forall a b. (a -> b) -> a -> b
$
    (PeerSimulatorResult blk -> PeerId)
-> [PeerSimulatorResult blk] -> [PeerId]
forall a b. (a -> b) -> [a] -> [b]
map PeerSimulatorResult blk -> PeerId
forall blk. PeerSimulatorResult blk -> PeerId
psePeerId (StateView blk -> [PeerSimulatorResult blk]
forall blk. StateView blk -> [PeerSimulatorResult blk]
svPeerSimulatorResults StateView blk
stateView)

-- | State view tracers are a lightweight mechanism to record information that
-- can later be used to produce a state view. This mechanism relies on
-- contra-tracers which we already use in a pervasives way.
data StateViewTracers blk m = StateViewTracers
  { forall blk (m :: * -> *).
StateViewTracers blk m -> Tracer m (PeerSimulatorResult blk)
svtPeerSimulatorResultsTracer :: Tracer m (PeerSimulatorResult blk)
  , forall blk (m :: * -> *).
StateViewTracers blk m -> m [PeerSimulatorResult blk]
svtGetPeerSimulatorResults :: m [PeerSimulatorResult blk]
  , forall blk (m :: * -> *).
StateViewTracers blk m -> Tracer m (TraceEvent blk)
svtTraceTracer :: Tracer m (TraceEvent blk)
  , forall blk (m :: * -> *).
StateViewTracers blk m -> m [TraceEvent blk]
svtGetTracerTrace :: m [TraceEvent blk]
  }

-- | Helper to get exceptions from a StateView.
exceptionsByComponent ::
  PeerSimulatorComponent ->
  StateView blk ->
  [SomeException]
exceptionsByComponent :: forall blk.
PeerSimulatorComponent -> StateView blk -> [SomeException]
exceptionsByComponent PeerSimulatorComponent
component StateView{[PeerSimulatorResult blk]
svPeerSimulatorResults :: forall blk. StateView blk -> [PeerSimulatorResult blk]
svPeerSimulatorResults :: [PeerSimulatorResult blk]
svPeerSimulatorResults} =
  (PeerSimulatorComponentResult blk -> Maybe SomeException)
-> [PeerSimulatorComponentResult blk] -> [SomeException]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PeerSimulatorComponent
-> PeerSimulatorComponentResult blk -> Maybe SomeException
forall blk.
PeerSimulatorComponent
-> PeerSimulatorComponentResult blk -> Maybe SomeException
matchComponent PeerSimulatorComponent
component) ([PeerSimulatorComponentResult blk] -> [SomeException])
-> [PeerSimulatorComponentResult blk] -> [SomeException]
forall a b. (a -> b) -> a -> b
$ PeerSimulatorResult blk -> PeerSimulatorComponentResult blk
forall blk.
PeerSimulatorResult blk -> PeerSimulatorComponentResult blk
pseResult (PeerSimulatorResult blk -> PeerSimulatorComponentResult blk)
-> [PeerSimulatorResult blk] -> [PeerSimulatorComponentResult blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PeerSimulatorResult blk]
svPeerSimulatorResults
 where
  matchComponent :: PeerSimulatorComponent -> PeerSimulatorComponentResult blk -> Maybe SomeException
  matchComponent :: forall blk.
PeerSimulatorComponent
-> PeerSimulatorComponentResult blk -> Maybe SomeException
matchComponent = \case
    PeerSimulatorComponent
ChainSyncClient -> \case
      SomeChainSyncClientResult (Left SomeException
exn) -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
exn
      PeerSimulatorComponentResult blk
_ -> Maybe SomeException
forall a. Maybe a
Nothing
    PeerSimulatorComponent
ChainSyncServer -> \case
      SomeChainSyncServerResult (Left SomeException
exn) -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
exn
      PeerSimulatorComponentResult blk
_ -> Maybe SomeException
forall a. Maybe a
Nothing
    PeerSimulatorComponent
BlockFetchClient -> \case
      SomeBlockFetchClientResult (Left SomeException
exn) -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
exn
      PeerSimulatorComponentResult blk
_ -> Maybe SomeException
forall a. Maybe a
Nothing
    PeerSimulatorComponent
BlockFetchServer -> \case
      SomeBlockFetchServerResult (Left SomeException
exn) -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
exn
      PeerSimulatorComponentResult blk
_ -> Maybe SomeException
forall a. Maybe a
Nothing

-- | Make default state view tracers. The tracers are all freshly initialised
-- and contain no information.
defaultStateViewTracers ::
  IOLike m =>
  m (StateViewTracers blk m)
defaultStateViewTracers :: forall (m :: * -> *) blk. IOLike m => m (StateViewTracers blk m)
defaultStateViewTracers = do
  (svtPeerSimulatorResultsTracer, svtGetPeerSimulatorResults) <- m (Tracer m (PeerSimulatorResult blk), m [PeerSimulatorResult blk])
forall (m :: * -> *) ev. MonadSTM m => m (Tracer m ev, m [ev])
recordingTracerTVar
  (svtTraceTracer, svtGetTracerTrace) <- recordingTracerTVar
  pure
    StateViewTracers
      { svtPeerSimulatorResultsTracer
      , svtGetPeerSimulatorResults
      , svtTraceTracer
      , svtGetTracerTrace
      }

-- | Call 'defaultStateViewTracers' and add the provided results.
stateViewTracersWithInitial ::
  IOLike m =>
  [PeerSimulatorResult blk] ->
  m (StateViewTracers blk m)
stateViewTracersWithInitial :: forall (m :: * -> *) blk.
IOLike m =>
[PeerSimulatorResult blk] -> m (StateViewTracers blk m)
stateViewTracersWithInitial [PeerSimulatorResult blk]
initial = do
  svt <- m (StateViewTracers blk m)
forall (m :: * -> *) blk. IOLike m => m (StateViewTracers blk m)
defaultStateViewTracers
  for_ initial (traceWith (svtPeerSimulatorResultsTracer svt))
  pure svt

-- | Use the state view tracers as well as some extra information to produce a
-- state view. This mostly consists in reading and storing the current state of
-- the tracers.
snapshotStateView ::
  IOLike m =>
  StateViewTracers blk m ->
  ChainDB m blk ->
  m (StateView blk)
snapshotStateView :: forall (m :: * -> *) blk.
IOLike m =>
StateViewTracers blk m -> ChainDB m blk -> m (StateView blk)
snapshotStateView StateViewTracers{m [PeerSimulatorResult blk]
svtGetPeerSimulatorResults :: forall blk (m :: * -> *).
StateViewTracers blk m -> m [PeerSimulatorResult blk]
svtGetPeerSimulatorResults :: m [PeerSimulatorResult blk]
svtGetPeerSimulatorResults, m [TraceEvent blk]
svtGetTracerTrace :: forall blk (m :: * -> *).
StateViewTracers blk m -> m [TraceEvent blk]
svtGetTracerTrace :: m [TraceEvent blk]
svtGetTracerTrace} ChainDB m blk
chainDb = do
  svPeerSimulatorResults <- m [PeerSimulatorResult blk]
svtGetPeerSimulatorResults
  svTrace <- svtGetTracerTrace
  svSelectedChain <- atomically $ ChainDB.getCurrentChain chainDb
  svTipBlock <- ChainDB.getTipBlock chainDb
  pure StateView{svSelectedChain, svPeerSimulatorResults, svTipBlock, svTrace}