{-# 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],
    -- | 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 -> Maybe blk
svTipBlock             :: Maybe blk,
    -- | List of all TraceEvent that have been sent during the simulation.
    forall blk. StateView blk -> [TraceEvent blk]
svTrace                :: [TraceEvent blk]
  }

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
  (Tracer m (PeerSimulatorResult blk)
svtPeerSimulatorResultsTracer, m [PeerSimulatorResult blk]
svtGetPeerSimulatorResults) <- m (Tracer m (PeerSimulatorResult blk), m [PeerSimulatorResult blk])
forall (m :: * -> *) ev. MonadSTM m => m (Tracer m ev, m [ev])
recordingTracerTVar
  (Tracer m (TraceEvent blk)
svtTraceTracer, m [TraceEvent blk]
svtGetTracerTrace) <- m (Tracer m (TraceEvent blk), m [TraceEvent blk])
forall (m :: * -> *) ev. MonadSTM m => m (Tracer m ev, m [ev])
recordingTracerTVar
  StateViewTracers blk m -> m (StateViewTracers blk m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StateViewTracers
    { Tracer m (PeerSimulatorResult blk)
svtPeerSimulatorResultsTracer :: Tracer m (PeerSimulatorResult blk)
svtPeerSimulatorResultsTracer :: Tracer m (PeerSimulatorResult blk)
svtPeerSimulatorResultsTracer
    , m [PeerSimulatorResult blk]
svtGetPeerSimulatorResults :: m [PeerSimulatorResult blk]
svtGetPeerSimulatorResults :: m [PeerSimulatorResult blk]
svtGetPeerSimulatorResults
    , Tracer m (TraceEvent blk)
svtTraceTracer :: Tracer m (TraceEvent blk)
svtTraceTracer :: Tracer m (TraceEvent blk)
svtTraceTracer
    , m [TraceEvent blk]
svtGetTracerTrace :: m [TraceEvent blk]
svtGetTracerTrace :: m [TraceEvent blk]
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
  StateViewTracers blk m
svt <- m (StateViewTracers blk m)
forall (m :: * -> *) blk. IOLike m => m (StateViewTracers blk m)
defaultStateViewTracers
  [PeerSimulatorResult blk]
-> (PeerSimulatorResult blk -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [PeerSimulatorResult blk]
initial (Tracer m (PeerSimulatorResult blk)
-> PeerSimulatorResult blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (StateViewTracers blk m -> Tracer m (PeerSimulatorResult blk)
forall blk (m :: * -> *).
StateViewTracers blk m -> Tracer m (PeerSimulatorResult blk)
svtPeerSimulatorResultsTracer StateViewTracers blk m
svt))
  StateViewTracers blk m -> m (StateViewTracers blk m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StateViewTracers blk m
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
  [PeerSimulatorResult blk]
svPeerSimulatorResults <- m [PeerSimulatorResult blk]
svtGetPeerSimulatorResults
  [TraceEvent blk]
svTrace <- m [TraceEvent blk]
svtGetTracerTrace
  AnchoredFragment (Header blk)
svSelectedChain <- STM m (AnchoredFragment (Header blk))
-> m (AnchoredFragment (Header blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (AnchoredFragment (Header blk))
 -> m (AnchoredFragment (Header blk)))
-> STM m (AnchoredFragment (Header blk))
-> m (AnchoredFragment (Header blk))
forall a b. (a -> b) -> a -> b
$ ChainDB m blk -> STM m (AnchoredFragment (Header blk))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (Header blk))
ChainDB.getCurrentChain ChainDB m blk
chainDb
  Maybe blk
svTipBlock <- ChainDB m blk -> m (Maybe blk)
forall (m :: * -> *) blk. ChainDB m blk -> m (Maybe blk)
ChainDB.getTipBlock ChainDB m blk
chainDb
  StateView blk -> m (StateView blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure StateView {AnchoredFragment (Header blk)
svSelectedChain :: AnchoredFragment (Header blk)
svSelectedChain :: AnchoredFragment (Header blk)
svSelectedChain, [PeerSimulatorResult blk]
svPeerSimulatorResults :: [PeerSimulatorResult blk]
svPeerSimulatorResults :: [PeerSimulatorResult blk]
svPeerSimulatorResults, Maybe blk
svTipBlock :: Maybe blk
svTipBlock :: Maybe blk
svTipBlock, [TraceEvent blk]
svTrace :: [TraceEvent blk]
svTrace :: [TraceEvent blk]
svTrace}