{-# 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 (..)
  , decodePeerAddr
  , encodePeerAddr
  , nodeVersionData
  , defaultNodeUnderTestConfig
  , withNodeUnderTest
  ) where

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.Proxy (Proxy (..))
import qualified Network.Mux as Mux
import Ouroboros.Consensus.BlockchainTime
  ( BackoffDelay (..)
  , BlockchainTime
  , HardForkBlockchainTimeArgs (..)
  , SystemTime
  , hardForkBlockchainTime
  )
import Ouroboros.Consensus.BlockchainTime.WallClock.Default (defaultSystemTime)
import Ouroboros.Consensus.Config
  ( DiffusionPipeliningSupport (..)
  , SecurityParam (..)
  , TopLevelConfig
  , configLedger
  )
import Ouroboros.Consensus.Config.SupportsNode (getNetworkMagic, getSystemStart)
import Ouroboros.Consensus.Ledger.Extended (ledgerState)
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 (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 qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB
import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory (mkInMemoryArgs)
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.TestBlock
import Test.Util.ChainDB (NodeDBs (..))
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
  }

-- | 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
    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 ->
  NodeDBs (StrictTMVar (IOSim s) MockFS) ->
  (NodeUnderTest (IOSim s) -> IOSim s a) ->
  IOSim s a
withNodeUnderTest :: forall s a.
NodeUnderTestConfig
-> NodeDBs (StrictTMVar (IOSim s) MockFS)
-> (NodeUnderTest (IOSim s) -> IOSim s a)
-> IOSim s a
withNodeUnderTest NodeUnderTestConfig
cfg NodeDBs (StrictTMVar (IOSim s) MockFS)
nodeDBs 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
-> 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
-> 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 ()))
            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
              nullTracers
              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
              -- 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
            }

-- | 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