{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}

-- | One real node, the node under test (NUT), and a mocked environment around
-- it. The @nut@ prefix of names here abbreviates it.
--
-- The node is built by the node's own 'initNodeKernel' over a ChainDB on a
-- mocked filesystem, so the code under test is the node's, not a
-- reimplementation of it. Its block is 'LeiosTestBlock'. It does not forge,
-- since the test gives it no block forging.
--
-- The node's node-to-node applications and the versions it offers them at are
-- built by the node's own 'mkNodeToNodeApps' and
-- 'mkNodeToNodeInitiatorResponderVersions', as a running node builds them.
--
-- Everything outside the node is the test's: the environment runs the other
-- end of each of the node's connections itself.
module Test.Consensus.Leios.NodeUnderTest
  ( Blk
  , NodeUnderTest (..)
  , NodeUnderTestConfig (..)
  , NodeVersions
  , PeerAddr (..)
  , Seeds (..)
  , addBlocks
  , addBlocksAfter
  , decodePeerAddr
  , encodePeerAddr
  , nodeVersionData
  , defaultNodeUnderTestConfig
  , maxEbBodySize
  , withNode
  , withNodeCommittee
  , withNodeForecastingOnly
  , withNodeOver
  , withNodeOverDBs
  , withNodeUnderTest
  ) where

import Cardano.Crypto.Leios (LeiosCommittee)
import Cardano.Ledger.BaseTypes (Milliseconds32 (..), UnitInterval, knownNonZeroBounded)
import Cardano.Network.Diffusion.Configuration
  ( defaultChainSyncIdleTimeout
  , defaultTxSubmissionLogicVersion
  )
import Cardano.Network.NodeToNode.Version
  ( DiffusionMode (..)
  , NodeToNodeVersion
  , NodeToNodeVersionData
  , getLocalPerasSupport
  )
import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..))
import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable)
import qualified Codec.CBOR.Decoding as CBOR
import qualified Codec.CBOR.Encoding as CBOR
import Codec.Serialise (Serialise (..))
import Control.DeepSeq (NFData)
import Control.Monad.IOSim (IOSim)
import Control.Monad.State.Strict (evalState, state)
import Control.ResourceRegistry (ResourceRegistry, withRegistry)
import Control.Tracer (nullTracer)
import Data.ByteString.Lazy (ByteString)
import Data.Hashable (Hashable)
import Data.Maybe.Strict (StrictMaybe (SJust))
import Data.Proxy (Proxy (..))
import qualified Network.Mux as Mux
import Ouroboros.Consensus.Block (SlotNo, WithOrigin (..), blockSlot)
import Ouroboros.Consensus.BlockchainTime
  ( BackoffDelay (..)
  , BlockchainTime
  , HardForkBlockchainTimeArgs (..)
  , SystemTime
  , hardForkBlockchainTime
  , slotLengthFromSec
  )
import Ouroboros.Consensus.BlockchainTime.WallClock.Default (defaultSystemTime)
import Ouroboros.Consensus.Config
  ( DiffusionPipeliningSupport (..)
  , SecurityParam (..)
  , TopLevelConfig
  , configLedger
  )
import Ouroboros.Consensus.Config.SupportsNode (getNetworkMagic, getSystemStart)
import qualified Ouroboros.Consensus.HardFork.History as HardFork
import Ouroboros.Consensus.Ledger.Extended (ledgerState)
import Ouroboros.Consensus.Leios.Protocol (LeiosLedgerView (..))
import Ouroboros.Consensus.Leios.Types (BytesSize)
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck as HistoricityCheck
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck
import qualified Ouroboros.Consensus.Network.NodeToNode as NTN
import Ouroboros.Consensus.Node
  ( mkNodeKernelArgs
  , mkNodeToNodeApps
  , mkNodeToNodeInitiatorResponderVersions
  , nodeKernelArgsEnforceInvariants
  , openChainDB
  , stdVersionDataNTN
  )
import Ouroboros.Consensus.Node.ExitPolicy (NodeToNodeInitiatorResult)
import qualified Ouroboros.Consensus.Node.GSM as GSM
import Ouroboros.Consensus.Node.Genesis
  ( disableGenesisConfig
  , mkGenesisNodeKernelArgs
  )
import Ouroboros.Consensus.Node.NetworkProtocolVersion
  ( BlockNodeToNodeVersion
  , supportedNodeToNodeVersions
  )
import Ouroboros.Consensus.Node.Tracers (Tracers, nullTracers)
import Ouroboros.Consensus.NodeKernel
  ( NodeKernel
  , NodeKernelArgs (..)
  , initNodeKernel
  )
import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment (noPunishment)
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB
import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory (mkInMemoryArgs)
import Ouroboros.Consensus.Storage.LeiosDB (LeiosDbHandle, newLeiosDBInMemory)
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Network.ConnectionId (ConnectionId)
import qualified Ouroboros.Network.Diffusion.Policies as Diffusion
import Ouroboros.Network.Hashable (mkUnsafeSalt)
import Ouroboros.Network.Mux (OuroborosBundleWithExpandedCtx)
import Ouroboros.Network.PeerSelection.Governor.Types
  ( makePublicPeerSelectionStateVar
  )
import Ouroboros.Network.PeerSelection.PeerMetric (newPeerMetric)
import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..))
import Ouroboros.Network.Protocol.Handshake.Version (Versions)
import Ouroboros.Network.TxSubmission.Inbound.V1 (TxSubmissionInitDelay (..))
import System.FS.API (SomeHasFS (..))
import System.FS.API.Types (mkFsPath)
import System.FS.Sim.MockFS (MockFS)
import System.FS.Sim.STM (simHasFS)
import System.Random (StdGen, mkStdGen, random, splitGen)
import Test.Consensus.Leios.Committee (testCommittee, testQuorumStakeThreshold)
import Test.Consensus.Leios.TestBlock
import Test.Util.ChainDB (NodeDBs (..), emptyNodeDBs)
import Test.Util.FS.Subdirectory (subdirectoryHasFS)
import Test.Util.Orphans.IOLike ()

type Blk = LeiosTestBlock

-- | What a test can vary about the node.
data NodeUnderTestConfig = NodeUnderTestConfig
  { NodeUnderTestConfig -> SecurityParam
nutcSecurityParam :: SecurityParam
  , NodeUnderTestConfig -> LeiosTestLedgerConfig
nutcLedgerConfig :: LeiosTestLedgerConfig
  , NodeUnderTestConfig -> StdGen
nutcRandomness :: StdGen
  -- ^ The root of all the test's randomness; see 'Seeds'.
  }

defaultNodeUnderTestConfig :: SecurityParam -> LeiosTestLedgerConfig -> NodeUnderTestConfig
defaultNodeUnderTestConfig :: SecurityParam -> LeiosTestLedgerConfig -> NodeUnderTestConfig
defaultNodeUnderTestConfig SecurityParam
nutcSecurityParam LeiosTestLedgerConfig
nutcLedgerConfig =
  NodeUnderTestConfig
    { SecurityParam
nutcSecurityParam :: SecurityParam
nutcSecurityParam :: SecurityParam
nutcSecurityParam
    , LeiosTestLedgerConfig
nutcLedgerConfig :: LeiosTestLedgerConfig
nutcLedgerConfig :: LeiosTestLedgerConfig
nutcLedgerConfig
    , nutcRandomness :: StdGen
nutcRandomness = Int -> StdGen
mkStdGen Int
0
    }

-- | All the randomness of a Leios node-vs-environment test.
data Seeds a = Seeds
  { forall a. Seeds a -> a
seedBlockFetchSalt :: a
  , forall a. Seeds a -> a
seedEnvPeerSharing :: a
  , forall a. Seeds a -> a
seedGsmAntiThunderingHerd :: a
  , forall a. Seeds a -> a
seedKeepAliveAndPeerSharing :: a
  , forall a. Seeds a -> a
seedNodeToNodeApps :: a
  , forall a. Seeds a -> a
seedSnapshotDelay :: a
  -- ^ The ChainDB needs a seed for its snapshot delay whatever its snapshot
  -- policy, so this one is real, like the rest, rather than a dummy that a test
  -- might come to depend on.
  }
  deriving ((forall a b. (a -> b) -> Seeds a -> Seeds b)
-> (forall a b. a -> Seeds b -> Seeds a) -> Functor Seeds
forall a b. a -> Seeds b -> Seeds a
forall a b. (a -> b) -> Seeds a -> Seeds b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Seeds a -> Seeds b
fmap :: forall a b. (a -> b) -> Seeds a -> Seeds b
$c<$ :: forall a b. a -> Seeds b -> Seeds a
<$ :: forall a b. a -> Seeds b -> Seeds a
Functor, (forall m. Monoid m => Seeds m -> m)
-> (forall m a. Monoid m => (a -> m) -> Seeds a -> m)
-> (forall m a. Monoid m => (a -> m) -> Seeds a -> m)
-> (forall a b. (a -> b -> b) -> b -> Seeds a -> b)
-> (forall a b. (a -> b -> b) -> b -> Seeds a -> b)
-> (forall b a. (b -> a -> b) -> b -> Seeds a -> b)
-> (forall b a. (b -> a -> b) -> b -> Seeds a -> b)
-> (forall a. (a -> a -> a) -> Seeds a -> a)
-> (forall a. (a -> a -> a) -> Seeds a -> a)
-> (forall a. Seeds a -> [a])
-> (forall a. Seeds a -> Bool)
-> (forall a. Seeds a -> Int)
-> (forall a. Eq a => a -> Seeds a -> Bool)
-> (forall a. Ord a => Seeds a -> a)
-> (forall a. Ord a => Seeds a -> a)
-> (forall a. Num a => Seeds a -> a)
-> (forall a. Num a => Seeds a -> a)
-> Foldable Seeds
forall a. Eq a => a -> Seeds a -> Bool
forall a. Num a => Seeds a -> a
forall a. Ord a => Seeds a -> a
forall m. Monoid m => Seeds m -> m
forall a. Seeds a -> Bool
forall a. Seeds a -> Int
forall a. Seeds a -> [a]
forall a. (a -> a -> a) -> Seeds a -> a
forall m a. Monoid m => (a -> m) -> Seeds a -> m
forall b a. (b -> a -> b) -> b -> Seeds a -> b
forall a b. (a -> b -> b) -> b -> Seeds a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => Seeds m -> m
fold :: forall m. Monoid m => Seeds m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Seeds a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Seeds a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Seeds a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Seeds a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Seeds a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Seeds a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Seeds a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Seeds a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Seeds a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Seeds a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Seeds a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Seeds a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Seeds a -> a
foldr1 :: forall a. (a -> a -> a) -> Seeds a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Seeds a -> a
foldl1 :: forall a. (a -> a -> a) -> Seeds a -> a
$ctoList :: forall a. Seeds a -> [a]
toList :: forall a. Seeds a -> [a]
$cnull :: forall a. Seeds a -> Bool
null :: forall a. Seeds a -> Bool
$clength :: forall a. Seeds a -> Int
length :: forall a. Seeds a -> Int
$celem :: forall a. Eq a => a -> Seeds a -> Bool
elem :: forall a. Eq a => a -> Seeds a -> Bool
$cmaximum :: forall a. Ord a => Seeds a -> a
maximum :: forall a. Ord a => Seeds a -> a
$cminimum :: forall a. Ord a => Seeds a -> a
minimum :: forall a. Ord a => Seeds a -> a
$csum :: forall a. Num a => Seeds a -> a
sum :: forall a. Num a => Seeds a -> a
$cproduct :: forall a. Num a => Seeds a -> a
product :: forall a. Num a => Seeds a -> a
Foldable, Functor Seeds
Foldable Seeds
(Functor Seeds, Foldable Seeds) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Seeds a -> f (Seeds b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Seeds (f a) -> f (Seeds a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Seeds a -> m (Seeds b))
-> (forall (m :: * -> *) a. Monad m => Seeds (m a) -> m (Seeds a))
-> Traversable Seeds
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Seeds (m a) -> m (Seeds a)
forall (f :: * -> *) a. Applicative f => Seeds (f a) -> f (Seeds a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Seeds a -> m (Seeds b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Seeds a -> f (Seeds b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Seeds a -> f (Seeds b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Seeds a -> f (Seeds b)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Seeds (f a) -> f (Seeds a)
sequenceA :: forall (f :: * -> *) a. Applicative f => Seeds (f a) -> f (Seeds a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Seeds a -> m (Seeds b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Seeds a -> m (Seeds b)
$csequence :: forall (m :: * -> *) a. Monad m => Seeds (m a) -> m (Seeds a)
sequence :: forall (m :: * -> *) a. Monad m => Seeds (m a) -> m (Seeds a)
Traversable)

-- | Every seed is split off the one generator, as a running node splits its own,
-- so no two share a stream.
splitSeeds :: StdGen -> Seeds StdGen
splitSeeds :: StdGen -> Seeds StdGen
splitSeeds = State StdGen (Seeds StdGen) -> StdGen -> Seeds StdGen
forall s a. State s a -> s -> a
evalState ((() -> StateT StdGen Identity StdGen)
-> Seeds () -> State StdGen (Seeds StdGen)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Seeds a -> m (Seeds b)
mapM (\() -> (StdGen -> (StdGen, StdGen)) -> StateT StdGen Identity StdGen
forall a. (StdGen -> (a, StdGen)) -> StateT StdGen Identity a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state StdGen -> (StdGen, StdGen)
forall g. SplitGen g => g -> (g, g)
splitGen) (() -> () -> () -> () -> () -> () -> Seeds ()
forall a. a -> a -> a -> a -> a -> a -> Seeds a
Seeds () () () () () ()))

nodeSeeds :: NodeUnderTestConfig -> Seeds StdGen
nodeSeeds :: NodeUnderTestConfig -> Seeds StdGen
nodeSeeds = StdGen -> Seeds StdGen
splitSeeds (StdGen -> Seeds StdGen)
-> (NodeUnderTestConfig -> StdGen)
-> NodeUnderTestConfig
-> Seeds StdGen
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeUnderTestConfig -> StdGen
nutcRandomness

-- | The peer address these tests use: a peer is just a number.
newtype PeerAddr = PeerAddr Int
  deriving stock (PeerAddr -> PeerAddr -> Bool
(PeerAddr -> PeerAddr -> Bool)
-> (PeerAddr -> PeerAddr -> Bool) -> Eq PeerAddr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PeerAddr -> PeerAddr -> Bool
== :: PeerAddr -> PeerAddr -> Bool
$c/= :: PeerAddr -> PeerAddr -> Bool
/= :: PeerAddr -> PeerAddr -> Bool
Eq, Eq PeerAddr
Eq PeerAddr =>
(PeerAddr -> PeerAddr -> Ordering)
-> (PeerAddr -> PeerAddr -> Bool)
-> (PeerAddr -> PeerAddr -> Bool)
-> (PeerAddr -> PeerAddr -> Bool)
-> (PeerAddr -> PeerAddr -> Bool)
-> (PeerAddr -> PeerAddr -> PeerAddr)
-> (PeerAddr -> PeerAddr -> PeerAddr)
-> Ord PeerAddr
PeerAddr -> PeerAddr -> Bool
PeerAddr -> PeerAddr -> Ordering
PeerAddr -> PeerAddr -> PeerAddr
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 :: PeerAddr -> PeerAddr -> Ordering
compare :: PeerAddr -> PeerAddr -> Ordering
$c< :: PeerAddr -> PeerAddr -> Bool
< :: PeerAddr -> PeerAddr -> Bool
$c<= :: PeerAddr -> PeerAddr -> Bool
<= :: PeerAddr -> PeerAddr -> Bool
$c> :: PeerAddr -> PeerAddr -> Bool
> :: PeerAddr -> PeerAddr -> Bool
$c>= :: PeerAddr -> PeerAddr -> Bool
>= :: PeerAddr -> PeerAddr -> Bool
$cmax :: PeerAddr -> PeerAddr -> PeerAddr
max :: PeerAddr -> PeerAddr -> PeerAddr
$cmin :: PeerAddr -> PeerAddr -> PeerAddr
min :: PeerAddr -> PeerAddr -> PeerAddr
Ord, Int -> PeerAddr -> ShowS
[PeerAddr] -> ShowS
PeerAddr -> String
(Int -> PeerAddr -> ShowS)
-> (PeerAddr -> String) -> ([PeerAddr] -> ShowS) -> Show PeerAddr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PeerAddr -> ShowS
showsPrec :: Int -> PeerAddr -> ShowS
$cshow :: PeerAddr -> String
show :: PeerAddr -> String
$cshowList :: [PeerAddr] -> ShowS
showList :: [PeerAddr] -> ShowS
Show)
  deriving newtype (Eq PeerAddr
Eq PeerAddr =>
(Int -> PeerAddr -> Int) -> (PeerAddr -> Int) -> Hashable PeerAddr
Int -> PeerAddr -> Int
PeerAddr -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> PeerAddr -> Int
hashWithSalt :: Int -> PeerAddr -> Int
$chash :: PeerAddr -> Int
hash :: PeerAddr -> Int
Hashable, PeerAddr -> ()
(PeerAddr -> ()) -> NFData PeerAddr
forall a. (a -> ()) -> NFData a
$crnf :: PeerAddr -> ()
rnf :: PeerAddr -> ()
NFData, Context -> PeerAddr -> IO (Maybe ThunkInfo)
Proxy PeerAddr -> String
(Context -> PeerAddr -> IO (Maybe ThunkInfo))
-> (Context -> PeerAddr -> IO (Maybe ThunkInfo))
-> (Proxy PeerAddr -> String)
-> NoThunks PeerAddr
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> PeerAddr -> IO (Maybe ThunkInfo)
noThunks :: Context -> PeerAddr -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PeerAddr -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PeerAddr -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy PeerAddr -> String
showTypeOf :: Proxy PeerAddr -> String
NoThunks)

-- | A running node, and the handles a test needs on it for its gray-box
-- predicates.
data NodeUnderTest m = NodeUnderTest
  { forall (m :: * -> *). NodeUnderTest m -> ChainDB m LeiosTestBlock
nutChainDB :: ChainDB m Blk
  , forall (m :: * -> *).
NodeUnderTest m -> TopLevelConfig LeiosTestBlock
nutTopLevelConfig :: TopLevelConfig Blk
  , forall (m :: * -> *).
NodeUnderTest m
-> NodeKernel m PeerAddr (ConnectionId ()) LeiosTestBlock
nutKernel :: NodeKernel m PeerAddr (ConnectionId ()) Blk
  , forall (m :: * -> *).
NodeUnderTest m
-> BlockNodeToNodeVersion LeiosTestBlock -> NodeApps m
nutApps :: BlockNodeToNodeVersion Blk -> NodeApps m
  , forall (m :: * -> *). NodeUnderTest m -> NodeVersions m
nutVersions :: NodeVersions m
  , forall (m :: * -> *). NodeUnderTest m -> Seeds StdGen
nutSeeds :: Seeds StdGen
  }

-- | Add a chain to the node's ChainDB, oldest first, starting at genesis
addBlocks :: IOLike m => NodeUnderTest m -> [Blk] -> m ()
addBlocks :: forall (m :: * -> *).
IOLike m =>
NodeUnderTest m -> [LeiosTestBlock] -> m ()
addBlocks NodeUnderTest m
nut = NodeUnderTest m -> WithOrigin SlotNo -> [LeiosTestBlock] -> m ()
forall (m :: * -> *).
IOLike m =>
NodeUnderTest m -> WithOrigin SlotNo -> [LeiosTestBlock] -> m ()
addBlocksAfter NodeUnderTest m
nut WithOrigin SlotNo
forall t. WithOrigin t
Origin

-- | Add a chain to the node's ChainDB, oldest first, given the slot of its
-- first block's predecessor
--
-- A 'LeiosTestBlock''s ledger view is the same at every slot.
addBlocksAfter :: IOLike m => NodeUnderTest m -> WithOrigin SlotNo -> [Blk] -> m ()
addBlocksAfter :: forall (m :: * -> *).
IOLike m =>
NodeUnderTest m -> WithOrigin SlotNo -> [LeiosTestBlock] -> m ()
addBlocksAfter NodeUnderTest m
nut WithOrigin SlotNo
predecessorSlot [LeiosTestBlock]
blks =
  [m ()] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([m ()] -> m ()) -> [m ()] -> m ()
forall a b. (a -> b) -> a -> b
$
    (WithOrigin SlotNo -> LeiosTestBlock -> m ())
-> [WithOrigin SlotNo] -> [LeiosTestBlock] -> [m ()]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
      ( \WithOrigin SlotNo
predSlot ->
          ChainDB m LeiosTestBlock
-> InvalidBlockPunishment m
-> WithOrigin SlotNo
-> StrictMaybe LeiosLedgerView
-> LeiosTestBlock
-> m ()
forall (m :: * -> *) blk.
IOLike m =>
ChainDB m blk
-> InvalidBlockPunishment m
-> WithOrigin SlotNo
-> StrictMaybe LeiosLedgerView
-> blk
-> m ()
ChainDB.addBlock_ (NodeUnderTest m -> ChainDB m LeiosTestBlock
forall (m :: * -> *). NodeUnderTest m -> ChainDB m LeiosTestBlock
nutChainDB NodeUnderTest m
nut) InvalidBlockPunishment m
forall (m :: * -> *). Applicative m => InvalidBlockPunishment m
noPunishment WithOrigin SlotNo
predSlot StrictMaybe LeiosLedgerView
leiosView
      )
      (WithOrigin SlotNo
predecessorSlot WithOrigin SlotNo -> [WithOrigin SlotNo] -> [WithOrigin SlotNo]
forall a. a -> [a] -> [a]
: (LeiosTestBlock -> WithOrigin SlotNo)
-> [LeiosTestBlock] -> [WithOrigin SlotNo]
forall a b. (a -> b) -> [a] -> [b]
map (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin (SlotNo -> WithOrigin SlotNo)
-> (LeiosTestBlock -> SlotNo)
-> LeiosTestBlock
-> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LeiosTestBlock -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot) [LeiosTestBlock]
blks)
      [LeiosTestBlock]
blks
 where
  leiosView :: StrictMaybe LeiosLedgerView
leiosView = LeiosLedgerView -> StrictMaybe LeiosLedgerView
forall a. a -> StrictMaybe a
SJust (LeiosTestLedgerConfig -> LeiosLedgerView
ltlcLeios (TopLevelConfig LeiosTestBlock -> LedgerConfig LeiosTestBlock
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger (NodeUnderTest m -> TopLevelConfig LeiosTestBlock
forall (m :: * -> *).
NodeUnderTest m -> TopLevelConfig LeiosTestBlock
nutTopLevelConfig NodeUnderTest m
nut)))

-- | The node's node-to-node applications, at every mini-protocol's bytes.
type NodeApps m =
  NTN.Apps
    m
    PeerAddr
    ByteString
    ByteString
    ByteString
    ByteString
    ByteString
    ByteString
    ByteString
    ByteString
    ByteString
    NodeToNodeInitiatorResult
    ()

-- | The node's node-to-node applications for each version it supports, as it
-- offers them on a connection where it is both initiator and responder.
type NodeVersions m =
  Versions
    NodeToNodeVersion
    NodeToNodeVersionData
    ( OuroborosBundleWithExpandedCtx
        'Mux.InitiatorResponderMode
        PeerAddr
        PeerTrustable
        ByteString
        m
        NodeToNodeInitiatorResult
        ()
    )

-- | Run the node over the given mocked filesystems, then shut it down.
--
-- As in a node's database directory, the immutable file system holds the
-- ImmutableDB, and the volatile one holds every other database, each in its own
-- subdirectory. The ledger and GSM file systems go unused.
withNodeUnderTest ::
  NodeUnderTestConfig ->
  Tracers (IOSim s) (ConnectionId PeerAddr) (ConnectionId ()) Blk ->
  NodeDBs (StrictTMVar (IOSim s) MockFS) ->
  LeiosDbHandle (IOSim s) ->
  (NodeUnderTest (IOSim s) -> IOSim s a) ->
  IOSim s a
withNodeUnderTest :: forall s a.
NodeUnderTestConfig
-> Tracers
     (IOSim s) (ConnectionId PeerAddr) (ConnectionId ()) LeiosTestBlock
-> NodeDBs (StrictTMVar (IOSim s) MockFS)
-> LeiosDbHandle (IOSim s)
-> (NodeUnderTest (IOSim s) -> IOSim s a)
-> IOSim s a
withNodeUnderTest NodeUnderTestConfig
cfg Tracers
  (IOSim s) (ConnectionId PeerAddr) (ConnectionId ()) LeiosTestBlock
tracers NodeDBs (StrictTMVar (IOSim s) MockFS)
nodeDBs LeiosDbHandle (IOSim s)
leiosDB NodeUnderTest (IOSim s) -> IOSim s a
body = do
  -- What a node with Genesis disabled, the default, runs with.
  (genesisArgs, updateChainDbArgs) <- GenesisConfig
-> IOSim
     s
     (GenesisNodeKernelArgs (IOSim s) LeiosTestBlock,
      Complete ChainDbArgs (IOSim s) LeiosTestBlock
      -> Complete ChainDbArgs (IOSim s) LeiosTestBlock)
forall (m :: * -> *) blk.
(IOLike m, GetHeader blk, Typeable blk) =>
GenesisConfig
-> m (GenesisNodeKernelArgs m blk,
      Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk)
mkGenesisNodeKernelArgs GenesisConfig
disableGenesisConfig
  let seeds = NodeUnderTestConfig -> Seeds StdGen
nodeSeeds NodeUnderTestConfig
cfg
  -- The ChainDB and the node each get their own resource registry. The node's
  -- registry is nested inside the ChainDB's, and the body runs inside both. So
  -- on the way out, the body finishes first, then the node's threads stop, and
  -- only then does the ChainDB close.
  withRegistry $ \ResourceRegistry (IOSim s)
dbRegistry -> do
    IOSim s (ChainDB (IOSim s) LeiosTestBlock)
-> (ChainDB (IOSim s) LeiosTestBlock -> IOSim s ())
-> (ChainDB (IOSim s) LeiosTestBlock -> IOSim s a)
-> IOSim s a
forall a b c.
IOSim s a -> (a -> IOSim s b) -> (a -> IOSim s c) -> IOSim s c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
      ( (ChainDB (IOSim s) LeiosTestBlock,
 Complete ChainDbArgs (IOSim s) LeiosTestBlock)
-> ChainDB (IOSim s) LeiosTestBlock
forall a b. (a, b) -> a
fst
          ((ChainDB (IOSim s) LeiosTestBlock,
  Complete ChainDbArgs (IOSim s) LeiosTestBlock)
 -> ChainDB (IOSim s) LeiosTestBlock)
-> IOSim
     s
     (ChainDB (IOSim s) LeiosTestBlock,
      Complete ChainDbArgs (IOSim s) LeiosTestBlock)
-> IOSim s (ChainDB (IOSim s) LeiosTestBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResourceRegistry (IOSim s)
-> TopLevelConfig LeiosTestBlock
-> ExtLedgerState LeiosTestBlock ValuesMK
-> (RelativeMountPoint -> SomeHasFS (IOSim s))
-> (RelativeMountPoint -> SomeHasFS (IOSim s))
-> StdGen
-> LedgerDbBackendArgs (IOSim s) LeiosTestBlock
-> LeiosDbHandle (IOSim s)
-> Incomplete ChainDbArgs (IOSim s) LeiosTestBlock
-> (Complete ChainDbArgs (IOSim s) LeiosTestBlock
    -> Complete ChainDbArgs (IOSim s) LeiosTestBlock)
-> IOSim
     s
     (ChainDB (IOSim s) LeiosTestBlock,
      Complete ChainDbArgs (IOSim s) LeiosTestBlock)
forall (m :: * -> *) blk.
(RunNode blk, IOLike m) =>
ResourceRegistry m
-> TopLevelConfig blk
-> ExtLedgerState blk ValuesMK
-> (RelativeMountPoint -> SomeHasFS m)
-> (RelativeMountPoint -> SomeHasFS m)
-> StdGen
-> LedgerDbBackendArgs m blk
-> LeiosDbHandle m
-> Incomplete ChainDbArgs m blk
-> (Complete ChainDbArgs m blk -> Complete ChainDbArgs m blk)
-> m (ChainDB m blk, Complete ChainDbArgs m blk)
openChainDB
            ResourceRegistry (IOSim s)
dbRegistry
            (NodeUnderTestConfig -> TopLevelConfig LeiosTestBlock
topLevelConfigOf NodeUnderTestConfig
cfg)
            (LeiosTestLedgerConfig -> ExtLedgerState LeiosTestBlock ValuesMK
leiosTestInitExtLedger (NodeUnderTestConfig -> LeiosTestLedgerConfig
nutcLedgerConfig NodeUnderTestConfig
cfg))
            (StrictTMVar (IOSim s) MockFS
-> RelativeMountPoint -> SomeHasFS (IOSim s)
forall s.
StrictTMVar (IOSim s) MockFS
-> RelativeMountPoint -> SomeHasFS (IOSim s)
mountedIn (NodeDBs (StrictTMVar (IOSim s) MockFS)
-> StrictTMVar (IOSim s) MockFS
forall db. NodeDBs db -> db
nodeDBsImm NodeDBs (StrictTMVar (IOSim s) MockFS)
nodeDBs))
            (StrictTMVar (IOSim s) MockFS
-> RelativeMountPoint -> SomeHasFS (IOSim s)
forall s.
StrictTMVar (IOSim s) MockFS
-> RelativeMountPoint -> SomeHasFS (IOSim s)
mountedIn (NodeDBs (StrictTMVar (IOSim s) MockFS)
-> StrictTMVar (IOSim s) MockFS
forall db. NodeDBs db -> db
nodeDBsVol NodeDBs (StrictTMVar (IOSim s) MockFS)
nodeDBs))
            (Seeds StdGen -> StdGen
forall a. Seeds a -> a
seedSnapshotDelay Seeds StdGen
seeds)
            ((LedgerDbBackendArgs (IOSim s) LeiosTestBlock, ())
-> LedgerDbBackendArgs (IOSim s) LeiosTestBlock
forall a b. (a, b) -> a
fst (() -> (LedgerDbBackendArgs (IOSim s) LeiosTestBlock, ())
forall (m :: * -> *) blk a.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk,
 CanUpgradeLedgerTables LedgerState blk) =>
a -> (LedgerDbBackendArgs m blk, a)
mkInMemoryArgs ()))
            LeiosDbHandle (IOSim s)
leiosDB
            Incomplete ChainDbArgs (IOSim s) LeiosTestBlock
forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk,
 CanUpgradeLedgerTables LedgerState blk) =>
Incomplete ChainDbArgs m blk
ChainDB.defaultArgs
            Complete ChainDbArgs (IOSim s) LeiosTestBlock
-> Complete ChainDbArgs (IOSim s) LeiosTestBlock
updateChainDbArgs
      )
      ChainDB (IOSim s) LeiosTestBlock -> IOSim s ()
forall (m :: * -> *) blk. ChainDB m blk -> m ()
ChainDB.closeDB
      ((ChainDB (IOSim s) LeiosTestBlock -> IOSim s a) -> IOSim s a)
-> (ChainDB (IOSim s) LeiosTestBlock -> IOSim s a) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ \ChainDB (IOSim s) LeiosTestBlock
chainDB -> (ResourceRegistry (IOSim s) -> IOSim s a) -> IOSim s a
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, MonadEvaluate m,
 HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry (IOSim s) -> IOSim s a) -> IOSim s a)
-> (ResourceRegistry (IOSim s) -> IOSim s a) -> IOSim s a
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry (IOSim s)
kernelRegistry -> do
        btime <- NodeUnderTestConfig
-> ResourceRegistry (IOSim s)
-> ChainDB (IOSim s) LeiosTestBlock
-> IOSim s (BlockchainTime (IOSim s))
forall s.
NodeUnderTestConfig
-> ResourceRegistry (IOSim s)
-> ChainDB (IOSim s) LeiosTestBlock
-> IOSim s (BlockchainTime (IOSim s))
mkBlockchainTime NodeUnderTestConfig
cfg ResourceRegistry (IOSim s)
kernelRegistry ChainDB (IOSim s) LeiosTestBlock
chainDB
        publicPeerSelectionStateVar <- makePublicPeerSelectionStateVar
        kernelArgs <-
          nodeKernelArgsEnforceInvariants
            <$> mkNodeKernelArgs
              kernelRegistry
              (mkUnsafeSalt (fst (random (seedBlockFetchSalt seeds))))
              (seedGsmAntiThunderingHerd seeds)
              (seedKeepAliveAndPeerSharing seeds)
              (topLevelConfigOf cfg)
              mempty
              tracers
              btime
              nodeSystemTime
              InFutureCheck.defaultClockSkew
              -- With Genesis disabled, there is no historicity cutoff.
              (\IOSim s GsmState
_getGsmState -> HistoricityCheck (IOSim s) LeiosTestBlock
forall (m :: * -> *) blk. Applicative m => HistoricityCheck m blk
HistoricityCheck.noCheck)
              chainDB
              leiosDB
              -- How long the node stays caught up at least, which does not
              -- matter, since it never leaves.
              0
              -- The node starts caught up, as one that was caught up when it
              -- last shut down does, and never judges its selection too old, so
              -- it stays caught up however far the simulated clock runs ahead of
              -- the test's chain.
              Nothing
              GSM.MarkerFileView
                { GSM.touchMarkerFile = pure ()
                , GSM.removeMarkerFile = pure ()
                , GSM.hasMarkerFile = pure True
                }
              (pure DontUseBootstrapPeers)
              publicPeerSelectionStateVar
              genesisArgs
              DiffusionPipeliningOn
              Nothing
              NoTxSubmissionInitDelay
        kernel <- initNodeKernel kernelArgs
        peerMetrics <- newPeerMetric Diffusion.peerMetricsConfiguration
        let apps =
              StdGen
-> Tracers (IOSim s) PeerAddr LeiosTestBlock DeserialiseFailure
-> ChainSyncIdleTimeout
-> GenesisConfig
-> TxSubmissionLogicVersion
-> NodeKernelArgs
     (IOSim s) PeerAddr (ConnectionId ()) LeiosTestBlock
-> NodeKernel (IOSim s) PeerAddr (ConnectionId ()) LeiosTestBlock
-> PeerMetrics (IOSim s) PeerAddr
-> (NodeToNodeVersion -> PeerAddr -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s PeerAddr)
-> BlockNodeToNodeVersion LeiosTestBlock
-> NodeToNodeApps (IOSim s) PeerAddr
forall (m :: * -> *) addrNTN addrNTC blk.
(RunNode blk, IOLike m, MonadTime m, MonadTimer m, Ord addrNTN,
 Hashable addrNTN, Show addrNTN) =>
StdGen
-> Tracers m addrNTN blk DeserialiseFailure
-> ChainSyncIdleTimeout
-> GenesisConfig
-> TxSubmissionLogicVersion
-> NodeKernelArgs m addrNTN addrNTC blk
-> NodeKernel m addrNTN addrNTC blk
-> PeerMetrics m addrNTN
-> (NodeToNodeVersion -> addrNTN -> Encoding)
-> (NodeToNodeVersion -> forall s. Decoder s addrNTN)
-> BlockNodeToNodeVersion blk
-> NodeToNodeApps m addrNTN
mkNodeToNodeApps
                (Seeds StdGen -> StdGen
forall a. Seeds a -> a
seedNodeToNodeApps Seeds StdGen
seeds)
                Tracers (IOSim s) PeerAddr LeiosTestBlock DeserialiseFailure
forall (m :: * -> *) ntnAddr blk e.
Monad m =>
Tracers m ntnAddr blk e
NTN.nullTracers
                ChainSyncIdleTimeout
defaultChainSyncIdleTimeout
                GenesisConfig
disableGenesisConfig
                TxSubmissionLogicVersion
defaultTxSubmissionLogicVersion
                NodeKernelArgs (IOSim s) PeerAddr (ConnectionId ()) LeiosTestBlock
kernelArgs
                NodeKernel (IOSim s) PeerAddr (ConnectionId ()) LeiosTestBlock
kernel
                PeerMetrics (IOSim s) PeerAddr
peerMetrics
                ((PeerAddr -> Encoding) -> NodeToNodeVersion -> PeerAddr -> Encoding
forall a b. a -> b -> a
const PeerAddr -> Encoding
encodePeerAddr)
                (Decoder s PeerAddr -> NodeToNodeVersion -> Decoder s PeerAddr
forall a b. a -> b -> a
const Decoder s PeerAddr
forall s. Decoder s PeerAddr
decodePeerAddr)
        body
          NodeUnderTest
            { nutChainDB = chainDB
            , nutTopLevelConfig = topLevelConfigOf cfg
            , nutKernel = kernel
            , nutApps = apps
            , nutVersions =
                mkNodeToNodeInitiatorResponderVersions
                  (featureFlags kernelArgs)
                  (miniProtocolParameters kernelArgs)
                  nodeVersionData
                  (supportedNodeToNodeVersions (Proxy @Blk))
                  apps
            , nutSeeds = seeds
            }

-- | A node whose ledger view forecasts further ahead than any test runs.
withNode :: (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
withNode :: forall s a. (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
withNode = SlotNo -> (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
forall s a.
SlotNo -> (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
withNodeForecastingOnly SlotNo
100000

-- | A node whose ledger view forecasts this many slots past its immutable tip.
withNodeForecastingOnly :: SlotNo -> (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
withNodeForecastingOnly :: forall s a.
SlotNo -> (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
withNodeForecastingOnly SlotNo
range NodeUnderTest (IOSim s) -> IOSim s a
body = do
  nodeDBs <- IOSim s (NodeDBs (StrictTMVar (IOSim s) MockFS))
forall (m :: * -> *).
MonadSTM m =>
m (NodeDBs (StrictTMVar m MockFS))
emptyNodeDBs
  leiosDB <- newLeiosDBInMemory
  withNodeUnderTest
    (forecastingOnly testCommittee testQuorumStakeThreshold range)
    nullTracers
    nodeDBs
    leiosDB
    body

-- | 'withNodeForecastingOnly', but with this committee in the node's ledger
-- view, and the largest quorum stake threshold.
withNodeCommittee ::
  LeiosCommittee -> SlotNo -> (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
withNodeCommittee :: forall s a.
LeiosCommittee
-> SlotNo -> (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
withNodeCommittee LeiosCommittee
committee SlotNo
range NodeUnderTest (IOSim s) -> IOSim s a
body = do
  nodeDBs <- IOSim s (NodeDBs (StrictTMVar (IOSim s) MockFS))
forall (m :: * -> *).
MonadSTM m =>
m (NodeDBs (StrictTMVar m MockFS))
emptyNodeDBs
  leiosDB <- newLeiosDBInMemory
  withNodeUnderTest (forecastingOnly committee maxBound range) nullTracers nodeDBs leiosDB body

-- | 'withNode' over the given LeiosDB, which a test can fill before the node
-- starts.
withNodeOver :: LeiosDbHandle (IOSim s) -> (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
withNodeOver :: forall s a.
LeiosDbHandle (IOSim s)
-> (NodeUnderTest (IOSim s) -> IOSim s a) -> IOSim s a
withNodeOver LeiosDbHandle (IOSim s)
leiosDB NodeUnderTest (IOSim s) -> IOSim s a
body = do
  nodeDBs <- IOSim s (NodeDBs (StrictTMVar (IOSim s) MockFS))
forall (m :: * -> *).
MonadSTM m =>
m (NodeDBs (StrictTMVar m MockFS))
emptyNodeDBs
  withNodeOverDBs nodeDBs leiosDB body

-- | 'withNode' over the given databases, which a test can fill before the node
-- starts, or reuse to restart it.
withNodeOverDBs ::
  NodeDBs (StrictTMVar (IOSim s) MockFS) ->
  LeiosDbHandle (IOSim s) ->
  (NodeUnderTest (IOSim s) -> IOSim s a) ->
  IOSim s a
withNodeOverDBs :: forall s a.
NodeDBs (StrictTMVar (IOSim s) MockFS)
-> LeiosDbHandle (IOSim s)
-> (NodeUnderTest (IOSim s) -> IOSim s a)
-> IOSim s a
withNodeOverDBs =
  NodeUnderTestConfig
-> Tracers
     (IOSim s) (ConnectionId PeerAddr) (ConnectionId ()) LeiosTestBlock
-> NodeDBs (StrictTMVar (IOSim s) MockFS)
-> LeiosDbHandle (IOSim s)
-> (NodeUnderTest (IOSim s) -> IOSim s a)
-> IOSim s a
forall s a.
NodeUnderTestConfig
-> Tracers
     (IOSim s) (ConnectionId PeerAddr) (ConnectionId ()) LeiosTestBlock
-> NodeDBs (StrictTMVar (IOSim s) MockFS)
-> LeiosDbHandle (IOSim s)
-> (NodeUnderTest (IOSim s) -> IOSim s a)
-> IOSim s a
withNodeUnderTest
    (LeiosCommittee -> UnitInterval -> SlotNo -> NodeUnderTestConfig
forecastingOnly LeiosCommittee
testCommittee UnitInterval
testQuorumStakeThreshold SlotNo
100000)
    Tracers
  (IOSim s) (ConnectionId PeerAddr) (ConnectionId ()) LeiosTestBlock
forall (m :: * -> *) remotePeer localPeer blk.
Monad m =>
Tracers m remotePeer localPeer blk
nullTracers

-- | The configuration of a node whose ledger view has this committee and quorum
-- stake threshold and forecasts this many slots past its immutable tip.
forecastingOnly :: LeiosCommittee -> UnitInterval -> SlotNo -> NodeUnderTestConfig
forecastingOnly :: LeiosCommittee -> UnitInterval -> SlotNo -> NodeUnderTestConfig
forecastingOnly LeiosCommittee
committee UnitInterval
quorumStakeThreshold SlotNo
range =
  SecurityParam -> LeiosTestLedgerConfig -> NodeUnderTestConfig
defaultNodeUnderTestConfig
    SecurityParam
k
    LeiosTestLedgerConfig
      { ltlcHardForkParams :: EraParams
ltlcHardForkParams =
          SecurityParam -> SlotLength -> PerasEnabled () -> EraParams
HardFork.defaultEraParams SecurityParam
k (Integer -> SlotLength
slotLengthFromSec Integer
1) PerasEnabled ()
forall a. PerasEnabled a
HardFork.NoPerasEnabled
      , ltlcForecastRange :: SlotNo
ltlcForecastRange = SlotNo
range
      , ltlcLeios :: LeiosLedgerView
ltlcLeios =
          MkLeiosLedgerView
            { llvCommittee :: LeiosCommittee
llvCommittee = LeiosCommittee
committee
            , llvQuorumStakeThreshold :: UnitInterval
llvQuorumStakeThreshold = UnitInterval
quorumStakeThreshold
            , llvAnnouncementPeriod :: Milliseconds32
llvAnnouncementPeriod = Word32 -> Milliseconds32
Milliseconds32 Word32
1000
            , llvVotePeriod :: Milliseconds32
llvVotePeriod = Word32 -> Milliseconds32
Milliseconds32 Word32
4000
            , llvDiffusionPeriod :: Milliseconds32
llvDiffusionPeriod = Word32 -> Milliseconds32
Milliseconds32 Word32
1000
            , llvMaxEbBodySize :: Word32
llvMaxEbBodySize = Word32
maxEbBodySize
            , llvMaxEbTxsSize :: Word32
llvMaxEbTxsSize = Word32
maxEbBodySize
            }
      }
 where
  k :: SecurityParam
k = NonZero Word64 -> SecurityParam
SecurityParam (NonZero Word64 -> SecurityParam)
-> NonZero Word64 -> SecurityParam
forall a b. (a -> b) -> a -> b
$ forall (n :: Natural) a.
(KnownNat n, 1 <= n, WithinBounds n a, Num a) =>
NonZero a
knownNonZeroBounded @10

-- | The largest endorser block, and total size of the transactions it
-- references, that the NUT's ledger admits.
maxEbBodySize :: BytesSize
maxEbBodySize :: Word32
maxEbBodySize = Word32
5000

-- | The version data a relay offers: it accepts inbound connections and shares
-- peers.
nodeVersionData :: NodeToNodeVersion -> NodeToNodeVersionData
nodeVersionData :: NodeToNodeVersion -> NodeToNodeVersionData
nodeVersionData NodeToNodeVersion
version =
  NetworkMagic
-> DiffusionMode
-> PeerSharing
-> PerasSupport
-> NodeToNodeVersionData
stdVersionDataNTN
    (BlockConfig LeiosTestBlock -> NetworkMagic
forall blk.
ConfigSupportsNode blk =>
BlockConfig blk -> NetworkMagic
getNetworkMagic BlockConfig LeiosTestBlock
LeiosTestBlockConfig)
    DiffusionMode
InitiatorAndResponderDiffusionMode
    PeerSharing
PeerSharingEnabled
    (Set CardanoFeatureFlag -> NodeToNodeVersion -> PerasSupport
getLocalPerasSupport Set CardanoFeatureFlag
forall a. Monoid a => a
mempty NodeToNodeVersion
version)

encodePeerAddr :: PeerAddr -> CBOR.Encoding
encodePeerAddr :: PeerAddr -> Encoding
encodePeerAddr (PeerAddr Int
n) = Int -> Encoding
forall a. Serialise a => a -> Encoding
encode Int
n

decodePeerAddr :: CBOR.Decoder s PeerAddr
decodePeerAddr :: forall s. Decoder s PeerAddr
decodePeerAddr = Int -> PeerAddr
PeerAddr (Int -> PeerAddr) -> Decoder s Int -> Decoder s PeerAddr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Int
forall s. Decoder s Int
forall a s. Serialise a => Decoder s a
decode

-- | The node's slot clock, derived from the ledger as a real node's is.
mkBlockchainTime ::
  NodeUnderTestConfig ->
  ResourceRegistry (IOSim s) ->
  ChainDB (IOSim s) Blk ->
  IOSim s (BlockchainTime (IOSim s))
mkBlockchainTime :: forall s.
NodeUnderTestConfig
-> ResourceRegistry (IOSim s)
-> ChainDB (IOSim s) LeiosTestBlock
-> IOSim s (BlockchainTime (IOSim s))
mkBlockchainTime NodeUnderTestConfig
cfg ResourceRegistry (IOSim s)
registry ChainDB (IOSim s) LeiosTestBlock
chainDB =
  HardForkBlockchainTimeArgs (IOSim s) LeiosTestBlock
-> IOSim s (BlockchainTime (IOSim s))
forall (m :: * -> *) blk.
(IOLike m, HasHardForkHistory blk, HasCallStack) =>
HardForkBlockchainTimeArgs m blk -> m (BlockchainTime m)
hardForkBlockchainTime
    HardForkBlockchainTimeArgs
      { hfbtBackoffDelay :: IOSim s BackoffDelay
hfbtBackoffDelay = BackoffDelay -> IOSim s BackoffDelay
forall a. a -> IOSim s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NominalDiffTime -> BackoffDelay
BackoffDelay NominalDiffTime
1)
      , hfbtGetLedgerState :: STM (IOSim s) (LedgerState LeiosTestBlock EmptyMK)
hfbtGetLedgerState = ExtLedgerState LeiosTestBlock EmptyMK
-> LedgerState LeiosTestBlock EmptyMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState (ExtLedgerState LeiosTestBlock EmptyMK
 -> LedgerState LeiosTestBlock EmptyMK)
-> STM s (ExtLedgerState LeiosTestBlock EmptyMK)
-> STM s (LedgerState LeiosTestBlock EmptyMK)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB (IOSim s) LeiosTestBlock
-> STM (IOSim s) (ExtLedgerState LeiosTestBlock EmptyMK)
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (ExtLedgerState blk EmptyMK)
ChainDB.getCurrentLedger ChainDB (IOSim s) LeiosTestBlock
chainDB
      , hfbtLedgerConfig :: LedgerConfig LeiosTestBlock
hfbtLedgerConfig = TopLevelConfig LeiosTestBlock -> LedgerConfig LeiosTestBlock
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger (NodeUnderTestConfig -> TopLevelConfig LeiosTestBlock
topLevelConfigOf NodeUnderTestConfig
cfg)
      , hfbtRegistry :: ResourceRegistry (IOSim s)
hfbtRegistry = ResourceRegistry (IOSim s)
registry
      , hfbtSystemTime :: SystemTime (IOSim s)
hfbtSystemTime = SystemTime (IOSim s)
forall s. SystemTime (IOSim s)
nodeSystemTime
      , hfbtTracer :: Tracer (IOSim s) (TraceBlockchainTimeEvent RelativeTime)
hfbtTracer = Tracer (IOSim s) (TraceBlockchainTimeEvent RelativeTime)
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer
      , hfbtMaxClockRewind :: NominalDiffTime
hfbtMaxClockRewind = NominalDiffTime
0
      }

topLevelConfigOf :: NodeUnderTestConfig -> TopLevelConfig Blk
topLevelConfigOf :: NodeUnderTestConfig -> TopLevelConfig LeiosTestBlock
topLevelConfigOf NodeUnderTestConfig{SecurityParam
nutcSecurityParam :: NodeUnderTestConfig -> SecurityParam
nutcSecurityParam :: SecurityParam
nutcSecurityParam, LeiosTestLedgerConfig
nutcLedgerConfig :: NodeUnderTestConfig -> LeiosTestLedgerConfig
nutcLedgerConfig :: LeiosTestLedgerConfig
nutcLedgerConfig} =
  LeiosTestLedgerConfig
-> SecurityParam -> TopLevelConfig LeiosTestBlock
singleNodeLeiosTestConfig LeiosTestLedgerConfig
nutcLedgerConfig SecurityParam
nutcSecurityParam

-- | A node's database directory, mounting each database in its own
-- subdirectory as 'stdMkChainDbHasFS' does, but on a mock file system.
mountedIn :: StrictTMVar (IOSim s) MockFS -> ChainDB.RelativeMountPoint -> SomeHasFS (IOSim s)
mountedIn :: forall s.
StrictTMVar (IOSim s) MockFS
-> RelativeMountPoint -> SomeHasFS (IOSim s)
mountedIn StrictTMVar (IOSim s) MockFS
mockFS (ChainDB.RelativeMountPoint String
path) =
  HasFS (IOSim s) HandleMock -> SomeHasFS (IOSim s)
forall h (m :: * -> *). Eq h => HasFS m h -> SomeHasFS m
SomeHasFS (HasFS (IOSim s) HandleMock -> SomeHasFS (IOSim s))
-> HasFS (IOSim s) HandleMock -> SomeHasFS (IOSim s)
forall a b. (a -> b) -> a -> b
$ FsPath -> HasFS (IOSim s) HandleMock -> HasFS (IOSim s) HandleMock
forall (m :: * -> *) h. FsPath -> HasFS m h -> HasFS m h
subdirectoryHasFS (Context -> FsPath
mkFsPath [String
path]) (StrictTMVar (IOSim s) MockFS -> HasFS (IOSim s) HandleMock
forall (m :: * -> *).
(MonadSTM m, MonadMask m, PrimMonad m) =>
StrictTMVar m MockFS -> HasFS m HandleMock
simHasFS StrictTMVar (IOSim s) MockFS
mockFS)

-- | The node's wall clock, from its block's system start, as a running node's.
nodeSystemTime :: SystemTime (IOSim s)
nodeSystemTime :: forall s. SystemTime (IOSim s)
nodeSystemTime = SystemStart
-> Tracer (IOSim s) (TraceBlockchainTimeEvent UTCTime)
-> SystemTime (IOSim s)
forall (m :: * -> *).
(MonadTime m, MonadDelay m) =>
SystemStart
-> Tracer m (TraceBlockchainTimeEvent UTCTime) -> SystemTime m
defaultSystemTime (BlockConfig LeiosTestBlock -> SystemStart
forall blk.
ConfigSupportsNode blk =>
BlockConfig blk -> SystemStart
getSystemStart BlockConfig LeiosTestBlock
LeiosTestBlockConfig) Tracer (IOSim s) (TraceBlockchainTimeEvent UTCTime)
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer