{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

module Test.Ouroboros.Network.Testnet.Node
  ( -- * run a node
    Node.BlockGeneratorArgs (..)
  , Node.LimitsAndTimeouts (..)
  , Interfaces (..)
  , Arguments (..)
  , run
    -- * node types
  , NtNAddr
  , NtNFD
  , NtCAddr
  , NtCFD
    -- * extra types used by the node
  , AcceptedConnectionsLimit (..)
  , DiffusionMode (..)
  , PeerAdvertise (..)
  , PeerSelectionTargets (..)
    -- * configuration constants
  , config_REPROMOTE_DELAY
  ) where

import Control.Applicative (Alternative)
import Control.Concurrent.Class.MonadMVar (MonadMVar)
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad ((>=>))
import Control.Monad.Class.MonadAsync (MonadAsync (wait, withAsync))
import Control.Monad.Class.MonadFork (MonadFork)
import Control.Monad.Class.MonadSay
import Control.Monad.Class.MonadST (MonadST)
import Control.Monad.Class.MonadThrow (MonadEvaluate, MonadMask, MonadThrow,
           SomeException)
import Control.Monad.Class.MonadTime.SI (DiffTime, MonadTime)
import Control.Monad.Class.MonadTimer.SI (MonadDelay, MonadTimer)
import Control.Monad.Fix (MonadFix)
import Control.Tracer (Tracer (..), nullTracer)

import Data.Foldable as Foldable (foldl')
import Data.IP (IP (..))
import Data.Map (Map)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Void (Void)
import System.Random (StdGen, split)

import Codec.CBOR.Term qualified as CBOR

import Network.DNS (Domain, TTL)

import Ouroboros.Network.Mock.Chain (Chain, toAnchoredFragment, toOldestFirst)
import Ouroboros.Network.Mock.ConcreteBlock (Block (..), BlockHeader (..),
           convertSlotToTimeForTestsAssumingNoHardFork)
import Ouroboros.Network.Mock.ProducerState (ChainProducerState (..))

import Ouroboros.Network.AnchoredFragment qualified as AF
import Ouroboros.Network.Block (MaxSlotNo (..), maxSlotNoFromWithOrigin,
           pointSlot)
import Ouroboros.Network.BlockFetch
import Ouroboros.Network.ConnectionManager.Types (DataFlow (..))
import Ouroboros.Network.ConsensusMode
import Ouroboros.Network.Diffusion qualified as Diff
import Ouroboros.Network.Diffusion.P2P qualified as Diff.P2P
import Ouroboros.Network.ExitPolicy (RepromoteDelay (..))
import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..))
import Ouroboros.Network.PeerSelection.Governor (ConsensusModePeerTargets,
           PeerSelectionTargets (..), PublicPeerSelectionState (..))
import Ouroboros.Network.PeerSelection.PeerMetric
           (PeerMetricsConfiguration (..), newPeerMetric)
import Ouroboros.Network.Protocol.Handshake (HandshakeArguments (..))
import Ouroboros.Network.Protocol.Handshake.Codec (VersionDataCodec (..),
           noTimeLimitsHandshake, timeLimitsHandshake)
import Ouroboros.Network.Protocol.Handshake.Unversioned
           (unversionedHandshakeCodec, unversionedProtocolDataCodec)
import Ouroboros.Network.Protocol.Handshake.Version (Accept (Accept))
import Ouroboros.Network.RethrowPolicy (ErrorCommand (ShutdownNode),
           ioErrorRethrowPolicy, mkRethrowPolicy, muxErrorRethrowPolicy)
import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..))
import Ouroboros.Network.Snocket (MakeBearer, Snocket, TestAddress (..),
           invalidFileDescriptor)

import Ouroboros.Network.Testing.Data.Script (Script (..), stepScriptSTM')

import Simulation.Network.Snocket (AddressType (..), FD)

import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers)
import Ouroboros.Network.PeerSelection.LedgerPeers.Type
           (LedgerPeersConsensusInterface,
           MinBigLedgerPeersForTrustedState (..), UseLedgerPeers)
import Ouroboros.Network.PeerSelection.LocalRootPeers (OutboundConnectionsState)
import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..))
import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..))
import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable)
import Ouroboros.Network.PeerSelection.RelayAccessPoint (DomainAccessPoint,
           RelayAccessPoint)
import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions (DNSLookupType)
import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency,
           WarmValency)
import Test.Ouroboros.Network.PeerSelection.RootPeersDNS (DNSLookupDelay,
           DNSTimeout, mockDNSActions)
import Test.Ouroboros.Network.Testnet.Node.ChainDB (addBlock, getBlockPointSet)
import Test.Ouroboros.Network.Testnet.Node.Kernel (NodeKernel (..), NtCAddr,
           NtCVersion, NtCVersionData, NtNAddr, NtNVersion, NtNVersionData (..))
import Test.Ouroboros.Network.Testnet.Node.Kernel qualified as Node
import Test.Ouroboros.Network.Testnet.Node.MiniProtocols qualified as Node


data Interfaces m = Interfaces
    { forall (m :: * -> *). Interfaces m -> Snocket m (NtNFD m) NtNAddr
iNtnSnocket        :: Snocket m (NtNFD m) NtNAddr
    , forall (m :: * -> *). Interfaces m -> MakeBearer m (NtNFD m)
iNtnBearer         :: MakeBearer m (NtNFD m)
    , forall (m :: * -> *).
Interfaces m
-> NtNVersionData -> NtNVersionData -> Accept NtNVersionData
iAcceptVersion     :: NtNVersionData -> NtNVersionData -> Accept NtNVersionData
    , forall (m :: * -> *).
Interfaces m
-> DNSLookupType
-> [DomainAccessPoint]
-> m (Map DomainAccessPoint (Set NtNAddr))
iNtnDomainResolver :: DNSLookupType -> [DomainAccessPoint] -> m (Map DomainAccessPoint (Set NtNAddr))
    , forall (m :: * -> *). Interfaces m -> Snocket m (NtCFD m) NtCAddr
iNtcSnocket        :: Snocket m (NtCFD m) NtCAddr
    , forall (m :: * -> *). Interfaces m -> MakeBearer m (NtCFD m)
iNtcBearer         :: MakeBearer m (NtCFD m)
    , forall (m :: * -> *). Interfaces m -> StdGen
iRng               :: StdGen
    , forall (m :: * -> *).
Interfaces m -> StrictTVar m (Map Domain [(IP, TTL)])
iDomainMap         :: StrictTVar m (Map Domain [(IP, TTL)])
    , forall (m :: * -> *).
Interfaces m -> LedgerPeersConsensusInterface m
iLedgerPeersConsensusInterface
                         :: LedgerPeersConsensusInterface m
    , forall (m :: * -> *).
Interfaces m -> OutboundConnectionsState -> STM m ()
iUpdateOutboundConnectionsState
                         :: OutboundConnectionsState -> STM m ()
    }

type NtNFD m = FD m NtNAddr
type NtCFD m = FD m NtCAddr

data Arguments m = Arguments
    { forall (m :: * -> *). Arguments m -> NtNAddr
aIPAddress            :: NtNAddr
    , forall (m :: * -> *). Arguments m -> AcceptedConnectionsLimit
aAcceptedLimits       :: AcceptedConnectionsLimit
    , forall (m :: * -> *). Arguments m -> DiffusionMode
aDiffusionMode        :: DiffusionMode
    , forall (m :: * -> *). Arguments m -> DiffTime
aKeepAliveInterval    :: DiffTime
    , forall (m :: * -> *). Arguments m -> DiffTime
aPingPongInterval     :: DiffTime
    , forall (m :: * -> *). Arguments m -> BlockHeader -> m Bool
aShouldChainSyncExit  :: BlockHeader -> m Bool
    , forall (m :: * -> *). Arguments m -> Bool
aChainSyncEarlyExit   :: Bool

    , forall (m :: * -> *). Arguments m -> ConsensusModePeerTargets
aPeerTargets          :: ConsensusModePeerTargets
    , forall (m :: * -> *).
Arguments m
-> STM
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
aReadLocalRootPeers   :: STM m [( HotValency
                                      , WarmValency
                                      , Map RelayAccessPoint ( PeerAdvertise
                                                             , PeerTrustable))]
    , forall (m :: * -> *).
Arguments m -> STM m (Map RelayAccessPoint PeerAdvertise)
aReadPublicRootPeers  :: STM m (Map RelayAccessPoint PeerAdvertise)
    , forall (m :: * -> *). Arguments m -> Script UseBootstrapPeers
aReadUseBootstrapPeers :: Script UseBootstrapPeers
    , forall (m :: * -> *). Arguments m -> ConsensusMode
aConsensusMode        :: ConsensusMode
    , forall (m :: * -> *). Arguments m -> PeerSharing
aOwnPeerSharing       :: PeerSharing
    , forall (m :: * -> *). Arguments m -> STM m UseLedgerPeers
aReadUseLedgerPeers   :: STM m UseLedgerPeers
    , forall (m :: * -> *). Arguments m -> DiffTime
aProtocolIdleTimeout  :: DiffTime
    , forall (m :: * -> *). Arguments m -> DiffTime
aTimeWaitTimeout      :: DiffTime
    , forall (m :: * -> *). Arguments m -> Script DNSTimeout
aDNSTimeoutScript     :: Script DNSTimeout
    , forall (m :: * -> *). Arguments m -> Script DNSLookupDelay
aDNSLookupDelayScript :: Script DNSLookupDelay
    , forall (m :: * -> *). Arguments m -> Tracer m String
aDebugTracer          :: Tracer m String
    }

-- The 'mockDNSActions' is not using \/ specifying 'resolverException', thus we
-- set it to 'SomeException'.
--
type ResolverException = SomeException

run :: forall resolver m.
       ( Alternative (STM m)
       , MonadAsync       m
       , MonadDelay       m
       , MonadEvaluate    m
       , MonadFix         m
       , MonadFork        m
       , MonadLabelledSTM m
       , MonadTraceSTM    m
       , MonadMask        m
       , MonadSay         m
       , MonadST          m
       , MonadTime        m
       , MonadTimer       m
       , MonadThrow       (STM m)
       , MonadMVar        m

       , resolver ~ ()
       , forall a. Semigroup a => Semigroup (m a)
       )
    => Node.BlockGeneratorArgs Block StdGen
    -> Node.LimitsAndTimeouts BlockHeader Block
    -> Interfaces m
    -> Arguments m
    -> Diff.P2P.TracersExtra NtNAddr NtNVersion NtNVersionData
                             NtCAddr NtCVersion NtCVersionData
                             ResolverException m
    -> Tracer m (TraceLabelPeer NtNAddr (TraceFetchClientState BlockHeader))
    -> m Void
run :: forall resolver (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadEvaluate m,
 MonadFix m, MonadFork m, MonadLabelledSTM m, MonadTraceSTM m,
 MonadMask m, MonadSay m, MonadST m, MonadTime m, MonadTimer m,
 MonadThrow (STM m), MonadMVar m, resolver ~ (),
 forall a. Semigroup a => Semigroup (m a)) =>
BlockGeneratorArgs Block StdGen
-> LimitsAndTimeouts BlockHeader Block
-> Interfaces m
-> Arguments m
-> TracersExtra
     NtNAddr
     NtNVersion
     NtNVersionData
     NtCAddr
     NtNVersion
     NtCVersionData
     ResolverException
     m
-> Tracer
     m (TraceLabelPeer NtNAddr (TraceFetchClientState BlockHeader))
-> m Void
run BlockGeneratorArgs Block StdGen
blockGeneratorArgs LimitsAndTimeouts BlockHeader Block
limits Interfaces m
ni Arguments m
na TracersExtra
  NtNAddr
  NtNVersion
  NtNVersionData
  NtCAddr
  NtNVersion
  NtCVersionData
  ResolverException
  m
tracersExtra Tracer
  m (TraceLabelPeer NtNAddr (TraceFetchClientState BlockHeader))
tracerBlockFetch =
    BlockGeneratorArgs Block StdGen
-> (NodeKernel BlockHeader Block StdGen m
    -> Async m Void -> m Void)
-> m Void
forall block header (m :: * -> *) seed a.
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 MonadThrow (STM m), HasFullHeader block, RandomGen seed) =>
BlockGeneratorArgs block seed
-> (NodeKernel header block seed m -> Async m Void -> m a) -> m a
Node.withNodeKernelThread BlockGeneratorArgs Block StdGen
blockGeneratorArgs
      ((NodeKernel BlockHeader Block StdGen m -> Async m Void -> m Void)
 -> m Void)
-> (NodeKernel BlockHeader Block StdGen m
    -> Async m Void -> m Void)
-> m Void
forall a b. (a -> b) -> a -> b
$ \ NodeKernel BlockHeader Block StdGen m
nodeKernel Async m Void
nodeKernelThread -> do
        dnsTimeoutScriptVar <- Script DNSTimeout -> m (StrictTVar m (Script DNSTimeout))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO (Arguments m -> Script DNSTimeout
forall (m :: * -> *). Arguments m -> Script DNSTimeout
aDNSTimeoutScript Arguments m
na)
        dnsLookupDelayScriptVar <- newTVarIO (aDNSLookupDelayScript na)
        useBootstrapPeersScriptVar <- newTVarIO (aReadUseBootstrapPeers na)
        peerMetrics <- newPeerMetric PeerMetricsConfiguration { maxEntriesToTrack = 180 }

        let -- diffusion interfaces
            interfaces :: Diff.P2P.Interfaces (NtNFD m) NtNAddr NtNVersion NtNVersionData
                                              (NtCFD m) NtCAddr NtCVersion NtCVersionData
                                              resolver ResolverException
                                              m
            interfaces = Diff.P2P.Interfaces
              { diNtnSnocket :: Snocket m (NtNFD m) NtNAddr
Diff.P2P.diNtnSnocket            = Interfaces m -> Snocket m (NtNFD m) NtNAddr
forall (m :: * -> *). Interfaces m -> Snocket m (NtNFD m) NtNAddr
iNtnSnocket Interfaces m
ni
              , diNtnBearer :: MakeBearer m (NtNFD m)
Diff.P2P.diNtnBearer             = Interfaces m -> MakeBearer m (NtNFD m)
forall (m :: * -> *). Interfaces m -> MakeBearer m (NtNFD m)
iNtnBearer Interfaces m
ni
              , diNtnConfigureSocket :: NtNFD m -> Maybe NtNAddr -> m ()
Diff.P2P.diNtnConfigureSocket    = \NtNFD m
_ Maybe NtNAddr
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              , diNtnConfigureSystemdSocket :: NtNFD m -> NtNAddr -> m ()
Diff.P2P.diNtnConfigureSystemdSocket
                                                 = \NtNFD m
_ NtNAddr
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              , diNtnHandshakeArguments :: HandshakeArguments
  (ConnectionId NtNAddr) NtNVersion NtNVersionData m
Diff.P2P.diNtnHandshakeArguments =
                  HandshakeArguments
                    { haHandshakeTracer :: Tracer
  m
  (WithBearer
     (ConnectionId NtNAddr) (TraceSendRecv (Handshake NtNVersion Term)))
haHandshakeTracer      = Tracer
  m
  (WithBearer
     (ConnectionId NtNAddr) (TraceSendRecv (Handshake NtNVersion Term)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
                    , haHandshakeCodec :: Codec (Handshake NtNVersion Term) DeserialiseFailure m ByteString
haHandshakeCodec       = Codec (Handshake NtNVersion Term) DeserialiseFailure m ByteString
forall (m :: * -> *).
MonadST m =>
Codec (Handshake NtNVersion Term) DeserialiseFailure m ByteString
unversionedHandshakeCodec
                    , haVersionDataCodec :: VersionDataCodec Term NtNVersion NtNVersionData
haVersionDataCodec     = VersionDataCodec Term NtNVersion NtNVersionData
ntnUnversionedDataCodec
                    , haAcceptVersion :: NtNVersionData -> NtNVersionData -> Accept NtNVersionData
haAcceptVersion        = Interfaces m
-> NtNVersionData -> NtNVersionData -> Accept NtNVersionData
forall (m :: * -> *).
Interfaces m
-> NtNVersionData -> NtNVersionData -> Accept NtNVersionData
iAcceptVersion Interfaces m
ni
                    , haQueryVersion :: NtNVersionData -> Bool
haQueryVersion         = Bool -> NtNVersionData -> Bool
forall a b. a -> b -> a
const Bool
False
                    , haTimeLimits :: ProtocolTimeLimits (Handshake NtNVersion Term)
haTimeLimits           = ProtocolTimeLimits (Handshake NtNVersion Term)
forall {k} (vNumber :: k).
ProtocolTimeLimits (Handshake vNumber Term)
timeLimitsHandshake
                    }
              , diNtnAddressType :: NtNAddr -> Maybe AddressType
Diff.P2P.diNtnAddressType    = NtNAddr -> Maybe AddressType
ntnAddressType
              , diNtnDataFlow :: NtNVersionData -> DataFlow
Diff.P2P.diNtnDataFlow       = \NtNVersionData { DiffusionMode
ntnDiffusionMode :: DiffusionMode
ntnDiffusionMode :: NtNVersionData -> DiffusionMode
ntnDiffusionMode } ->
                  case DiffusionMode
ntnDiffusionMode of
                    DiffusionMode
InitiatorOnlyDiffusionMode         -> DataFlow
Unidirectional
                    DiffusionMode
InitiatorAndResponderDiffusionMode -> DataFlow
Duplex
              , diNtnPeerSharing :: NtNVersionData -> PeerSharing
Diff.P2P.diNtnPeerSharing        = NtNVersionData -> PeerSharing
ntnPeerSharing
              , diNtnToPeerAddr :: IP -> PortNumber -> NtNAddr
Diff.P2P.diNtnToPeerAddr         = \IP
a PortNumber
b -> NtNAddr_ -> NtNAddr
forall addr. addr -> TestAddress addr
TestAddress (IP -> PortNumber -> NtNAddr_
Node.IPAddr IP
a PortNumber
b)
              , diNtcSnocket :: Snocket m (NtCFD m) NtCAddr
Diff.P2P.diNtcSnocket            = Interfaces m -> Snocket m (NtCFD m) NtCAddr
forall (m :: * -> *). Interfaces m -> Snocket m (NtCFD m) NtCAddr
iNtcSnocket Interfaces m
ni
              , diNtcBearer :: MakeBearer m (NtCFD m)
Diff.P2P.diNtcBearer             = Interfaces m -> MakeBearer m (NtCFD m)
forall (m :: * -> *). Interfaces m -> MakeBearer m (NtCFD m)
iNtcBearer Interfaces m
ni
              , diNtcHandshakeArguments :: HandshakeArguments
  (ConnectionId NtCAddr) NtNVersion NtCVersionData m
Diff.P2P.diNtcHandshakeArguments =
                  HandshakeArguments
                    { haHandshakeTracer :: Tracer
  m
  (WithBearer
     (ConnectionId NtCAddr) (TraceSendRecv (Handshake NtNVersion Term)))
haHandshakeTracer      = Tracer
  m
  (WithBearer
     (ConnectionId NtCAddr) (TraceSendRecv (Handshake NtNVersion Term)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
                    , haHandshakeCodec :: Codec (Handshake NtNVersion Term) DeserialiseFailure m ByteString
haHandshakeCodec       = Codec (Handshake NtNVersion Term) DeserialiseFailure m ByteString
forall (m :: * -> *).
MonadST m =>
Codec (Handshake NtNVersion Term) DeserialiseFailure m ByteString
unversionedHandshakeCodec
                    , haVersionDataCodec :: VersionDataCodec Term NtNVersion NtCVersionData
haVersionDataCodec     = VersionDataCodec Term NtNVersion NtCVersionData
unversionedProtocolDataCodec
                    , haAcceptVersion :: NtCVersionData -> NtCVersionData -> Accept NtCVersionData
haAcceptVersion        = \NtCVersionData
_ NtCVersionData
v -> NtCVersionData -> Accept NtCVersionData
forall vData. vData -> Accept vData
Accept NtCVersionData
v
                    , haQueryVersion :: NtCVersionData -> Bool
haQueryVersion         = Bool -> NtCVersionData -> Bool
forall a b. a -> b -> a
const Bool
False
                    , haTimeLimits :: ProtocolTimeLimits (Handshake NtNVersion Term)
haTimeLimits           = ProtocolTimeLimits (Handshake NtNVersion Term)
forall {k} (vNumber :: k).
ProtocolTimeLimits (Handshake vNumber Term)
noTimeLimitsHandshake
                    }
              , diNtcGetFileDescriptor :: NtCFD m -> m FileDescriptor
Diff.P2P.diNtcGetFileDescriptor  = \NtCFD m
_ -> FileDescriptor -> m FileDescriptor
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileDescriptor
invalidFileDescriptor
              , diRng :: StdGen
Diff.P2P.diRng                   = StdGen
diffStgGen
              , diInstallSigUSR1Handler :: forall (mode :: Mode) x y.
NodeToNodeConnectionManager
  mode (NtNFD m) NtNAddr NtNVersionData NtNVersion m x y
-> StrictTVar
     m
     (PeerSelectionState
        NtNAddr
        (NodeToNodePeerConnectionHandle mode NtNAddr NtNVersionData m x y))
-> PeerMetrics m NtNAddr
-> m ()
Diff.P2P.diInstallSigUSR1Handler = \NodeToNodeConnectionManager
  mode (NtNFD m) NtNAddr NtNVersionData NtNVersion m x y
_ StrictTVar
  m
  (PeerSelectionState
     NtNAddr
     (NodeToNodePeerConnectionHandle mode NtNAddr NtNVersionData m x y))
_ PeerMetrics m NtNAddr
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
              , diDnsActions :: DNSLookupType -> DNSActions () ResolverException m
Diff.P2P.diDnsActions            = DNSActions () ResolverException m
-> DNSLookupType -> DNSActions () ResolverException m
forall a b. a -> b -> a
const (StrictTVar m (Map Domain [(IP, TTL)])
-> StrictTVar m (Script DNSTimeout)
-> StrictTVar m (Script DNSLookupDelay)
-> DNSActions () ResolverException m
forall exception (m :: * -> *).
(MonadDelay m, MonadTimer m) =>
StrictTVar m (Map Domain [(IP, TTL)])
-> StrictTVar m (Script DNSTimeout)
-> StrictTVar m (Script DNSLookupDelay)
-> DNSActions () exception m
mockDNSActions
                                                     (Interfaces m -> StrictTVar m (Map Domain [(IP, TTL)])
forall (m :: * -> *).
Interfaces m -> StrictTVar m (Map Domain [(IP, TTL)])
iDomainMap Interfaces m
ni)
                                                     StrictTVar m (Script DNSTimeout)
dnsTimeoutScriptVar
                                                     StrictTVar m (Script DNSLookupDelay)
dnsLookupDelayScriptVar)
              }

            appsExtra :: Diff.P2P.ApplicationsExtra NtNAddr m ()
            appsExtra = Diff.P2P.ApplicationsExtra
              { -- TODO: simulation errors should be critical
                daRethrowPolicy :: RethrowPolicy
Diff.P2P.daRethrowPolicy          =
                     RethrowPolicy
muxErrorRethrowPolicy
                  RethrowPolicy -> RethrowPolicy -> RethrowPolicy
forall a. Semigroup a => a -> a -> a
<> RethrowPolicy
ioErrorRethrowPolicy

                -- we are not using local connections, so we can make all the
                -- errors fatal.
              , daLocalRethrowPolicy :: RethrowPolicy
Diff.P2P.daLocalRethrowPolicy     =
                     (ErrorContext -> ResolverException -> ErrorCommand)
-> RethrowPolicy
forall e.
Exception e =>
(ErrorContext -> e -> ErrorCommand) -> RethrowPolicy
mkRethrowPolicy
                       (\ ErrorContext
_ (ResolverException
_ :: SomeException) -> ErrorCommand
ShutdownNode)
              , daPeerMetrics :: PeerMetrics m NtNAddr
Diff.P2P.daPeerMetrics            = PeerMetrics m NtNAddr
peerMetrics
                -- fetch mode is not used (no block-fetch mini-protocol)
              , daBlockFetchMode :: STM m FetchMode
Diff.P2P.daBlockFetchMode         = FetchMode -> STM m FetchMode
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FetchMode
FetchModeDeadline
              , daReturnPolicy :: ReturnPolicy ()
Diff.P2P.daReturnPolicy           = \()
_ -> RepromoteDelay
config_REPROMOTE_DELAY
              , daPeerSharingRegistry :: PeerSharingRegistry NtNAddr m
Diff.P2P.daPeerSharingRegistry    = NodeKernel BlockHeader Block StdGen m
-> PeerSharingRegistry NtNAddr m
forall header block s (m :: * -> *).
NodeKernel header block s m -> PeerSharingRegistry NtNAddr m
nkPeerSharingRegistry NodeKernel BlockHeader Block StdGen m
nodeKernel
              }

        let apps = Tracer m String
-> NodeKernel BlockHeader Block StdGen m
-> Codecs NtNAddr BlockHeader Block m
-> LimitsAndTimeouts BlockHeader Block
-> AppArgs BlockHeader Block m
-> (Block -> BlockHeader)
-> Applications
     NtNAddr
     NtNVersion
     NtNVersionData
     NtCAddr
     NtNVersion
     NtCVersionData
     m
     ()
forall block header s (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadFork m, MonadMask m,
 MonadMVar m, MonadSay m, MonadThrow m, MonadTime m, MonadTimer m,
 MonadThrow (STM m), HasHeader header, HasHeader block,
 HeaderHash header ~ HeaderHash block, Show block, ShowProxy block,
 ShowProxy header, RandomGen s) =>
Tracer m String
-> NodeKernel header block s m
-> Codecs NtNAddr header block m
-> LimitsAndTimeouts header block
-> AppArgs header block m
-> (block -> header)
-> Applications
     NtNAddr
     NtNVersion
     NtNVersionData
     NtCAddr
     NtNVersion
     NtCVersionData
     m
     ()
Node.applications (Arguments m -> Tracer m String
forall (m :: * -> *). Arguments m -> Tracer m String
aDebugTracer Arguments m
na) NodeKernel BlockHeader Block StdGen m
nodeKernel Codecs NtNAddr BlockHeader Block m
forall (m :: * -> *).
MonadST m =>
Codecs NtNAddr BlockHeader Block m
Node.cborCodecs LimitsAndTimeouts BlockHeader Block
limits AppArgs BlockHeader Block m
appArgs Block -> BlockHeader
blockHeader

        withAsync
           (Diff.P2P.runM interfaces
                          Diff.nullTracers
                          tracersExtra
                          (mkArgs (nkPublicPeerSelectionVar nodeKernel))
                          (mkArgsExtra useBootstrapPeersScriptVar) apps appsExtra)
           $ \ Async m Void
diffusionThread ->
               m Void -> (Async m Void -> m Void) -> m Void
forall a b. m a -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync (NodeKernel BlockHeader Block StdGen m -> m Void
forall s. NodeKernel BlockHeader Block s m -> m Void
blockFetch NodeKernel BlockHeader Block StdGen m
nodeKernel) ((Async m Void -> m Void) -> m Void)
-> (Async m Void -> m Void) -> m Void
forall a b. (a -> b) -> a -> b
$ \Async m Void
blockFetchLogicThread ->
                 Async m Void -> m Void
forall a. Async m a -> m a
forall (m :: * -> *) a. MonadAsync m => Async m a -> m a
wait Async m Void
diffusionThread
              m Void -> m Void -> m Void
forall a. Semigroup a => a -> a -> a
<> Async m Void -> m Void
forall a. Async m a -> m a
forall (m :: * -> *) a. MonadAsync m => Async m a -> m a
wait Async m Void
blockFetchLogicThread
              m Void -> m Void -> m Void
forall a. Semigroup a => a -> a -> a
<> Async m Void -> m Void
forall a. Async m a -> m a
forall (m :: * -> *) a. MonadAsync m => Async m a -> m a
wait Async m Void
nodeKernelThread
  where
    blockFetch :: NodeKernel BlockHeader Block s m
               -> m Void
    blockFetch :: forall s. NodeKernel BlockHeader Block s m -> m Void
blockFetch NodeKernel BlockHeader Block s m
nodeKernel = do
      Tracer
  m [TraceLabelPeer NtNAddr (FetchDecision [Point BlockHeader])]
-> Tracer
     m (TraceLabelPeer NtNAddr (TraceFetchClientState BlockHeader))
-> BlockFetchConsensusInterface NtNAddr BlockHeader Block m
-> FetchClientRegistry NtNAddr BlockHeader Block m
-> BlockFetchConfiguration
-> m Void
forall addr header block (m :: * -> *).
(HasHeader header, HasHeader block,
 HeaderHash header ~ HeaderHash block, MonadDelay m, MonadSTM m,
 Ord addr, Hashable addr) =>
Tracer m [TraceLabelPeer addr (FetchDecision [Point header])]
-> Tracer m (TraceLabelPeer addr (TraceFetchClientState header))
-> BlockFetchConsensusInterface addr header block m
-> FetchClientRegistry addr header block m
-> BlockFetchConfiguration
-> m Void
blockFetchLogic
        Tracer
  m [TraceLabelPeer NtNAddr (FetchDecision [Point BlockHeader])]
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
        Tracer
  m (TraceLabelPeer NtNAddr (TraceFetchClientState BlockHeader))
tracerBlockFetch
        (NodeKernel BlockHeader Block s m
-> BlockFetchConsensusInterface NtNAddr BlockHeader Block m
forall s.
NodeKernel BlockHeader Block s m
-> BlockFetchConsensusInterface NtNAddr BlockHeader Block m
blockFetchPolicy NodeKernel BlockHeader Block s m
nodeKernel)
        (NodeKernel BlockHeader Block s m
-> FetchClientRegistry NtNAddr BlockHeader Block m
forall header block s (m :: * -> *).
NodeKernel header block s m
-> FetchClientRegistry NtNAddr header block m
nkFetchClientRegistry NodeKernel BlockHeader Block s m
nodeKernel)
        (BlockFetchConfiguration {
          bfcMaxConcurrencyBulkSync :: Word
bfcMaxConcurrencyBulkSync = Word
1,
          bfcMaxConcurrencyDeadline :: Word
bfcMaxConcurrencyDeadline = Word
2,
          bfcMaxRequestsInflight :: Word
bfcMaxRequestsInflight    = Word
10,
          bfcDecisionLoopInterval :: DiffTime
bfcDecisionLoopInterval   = DiffTime
0.01,
          bfcSalt :: Int
bfcSalt                   = Int
0
        })

    blockFetchPolicy :: NodeKernel BlockHeader Block s m
                     -> BlockFetchConsensusInterface NtNAddr BlockHeader Block m
    blockFetchPolicy :: forall s.
NodeKernel BlockHeader Block s m
-> BlockFetchConsensusInterface NtNAddr BlockHeader Block m
blockFetchPolicy NodeKernel BlockHeader Block s m
nodeKernel =
        BlockFetchConsensusInterface {
          readCandidateChains :: STM m (Map NtNAddr (AnchoredFragment BlockHeader))
readCandidateChains    = StrictTVar m (Map NtNAddr (StrictTVar m (Chain BlockHeader)))
-> STM m (Map NtNAddr (StrictTVar m (Chain BlockHeader)))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (NodeKernel BlockHeader Block s m
-> StrictTVar m (Map NtNAddr (StrictTVar m (Chain BlockHeader)))
forall header block s (m :: * -> *).
NodeKernel header block s m
-> StrictTVar m (Map NtNAddr (StrictTVar m (Chain header)))
nkClientChains NodeKernel BlockHeader Block s m
nodeKernel)
                                   STM m (Map NtNAddr (StrictTVar m (Chain BlockHeader)))
-> (Map NtNAddr (StrictTVar m (Chain BlockHeader))
    -> STM m (Map NtNAddr (AnchoredFragment BlockHeader)))
-> STM m (Map NtNAddr (AnchoredFragment BlockHeader))
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (StrictTVar m (Chain BlockHeader)
 -> STM m (AnchoredFragment BlockHeader))
-> Map NtNAddr (StrictTVar m (Chain BlockHeader))
-> STM m (Map NtNAddr (AnchoredFragment BlockHeader))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map NtNAddr a -> f (Map NtNAddr b)
traverse (StrictTVar m (Chain BlockHeader) -> STM m (Chain BlockHeader)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar
                                       (StrictTVar m (Chain BlockHeader) -> STM m (Chain BlockHeader))
-> (Chain BlockHeader -> STM m (AnchoredFragment BlockHeader))
-> StrictTVar m (Chain BlockHeader)
-> STM m (AnchoredFragment BlockHeader)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (AnchoredFragment BlockHeader
-> STM m (AnchoredFragment BlockHeader)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnchoredFragment BlockHeader
 -> STM m (AnchoredFragment BlockHeader))
-> (Chain BlockHeader -> AnchoredFragment BlockHeader)
-> Chain BlockHeader
-> STM m (AnchoredFragment BlockHeader)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain BlockHeader -> AnchoredFragment BlockHeader
forall block.
HasHeader block =>
Chain block -> AnchoredFragment block
toAnchoredFragment)),
          readCurrentChain :: STM m (AnchoredFragment BlockHeader)
readCurrentChain       = StrictTVar m (ChainProducerState Block)
-> STM m (ChainProducerState Block)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar (NodeKernel BlockHeader Block s m
-> StrictTVar m (ChainProducerState Block)
forall header block s (m :: * -> *).
NodeKernel header block s m
-> StrictTVar m (ChainProducerState block)
nkChainProducerState NodeKernel BlockHeader Block s m
nodeKernel)
                                   STM m (ChainProducerState Block)
-> (ChainProducerState Block
    -> STM m (AnchoredFragment BlockHeader))
-> STM m (AnchoredFragment BlockHeader)
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (AnchoredFragment BlockHeader
-> STM m (AnchoredFragment BlockHeader)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnchoredFragment BlockHeader
 -> STM m (AnchoredFragment BlockHeader))
-> (ChainProducerState Block -> AnchoredFragment BlockHeader)
-> ChainProducerState Block
-> STM m (AnchoredFragment BlockHeader)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain Block -> AnchoredFragment BlockHeader
toAnchoredFragmentHeader (Chain Block -> AnchoredFragment BlockHeader)
-> (ChainProducerState Block -> Chain Block)
-> ChainProducerState Block
-> AnchoredFragment BlockHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainProducerState Block -> Chain Block
forall block. ChainProducerState block -> Chain block
chainState),
          readFetchMode :: STM m FetchMode
readFetchMode          = FetchMode -> STM m FetchMode
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return FetchMode
FetchModeBulkSync,
          readFetchedBlocks :: STM m (Point Block -> Bool)
readFetchedBlocks      = (Point Block -> Set (Point Block) -> Bool)
-> Set (Point Block) -> Point Block -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Point Block -> Set (Point Block) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (Set (Point Block) -> Point Block -> Bool)
-> STM m (Set (Point Block)) -> STM m (Point Block -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB Block m -> STM m (Set (Point Block))
forall (m :: * -> *) block.
(MonadSTM m, HasHeader block) =>
ChainDB block m -> STM m (Set (Point block))
getBlockPointSet (NodeKernel BlockHeader Block s m -> ChainDB Block m
forall header block s (m :: * -> *).
NodeKernel header block s m -> ChainDB block m
nkChainDB NodeKernel BlockHeader Block s m
nodeKernel),
          readFetchedMaxSlotNo :: STM m MaxSlotNo
readFetchedMaxSlotNo   = (MaxSlotNo -> MaxSlotNo -> MaxSlotNo)
-> MaxSlotNo -> [MaxSlotNo] -> MaxSlotNo
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' MaxSlotNo -> MaxSlotNo -> MaxSlotNo
forall a. Ord a => a -> a -> a
max MaxSlotNo
NoMaxSlotNo ([MaxSlotNo] -> MaxSlotNo)
-> (Set (Point Block) -> [MaxSlotNo])
-> Set (Point Block)
-> MaxSlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                   (Point Block -> MaxSlotNo) -> [Point Block] -> [MaxSlotNo]
forall a b. (a -> b) -> [a] -> [b]
map (WithOrigin SlotNo -> MaxSlotNo
maxSlotNoFromWithOrigin (WithOrigin SlotNo -> MaxSlotNo)
-> (Point Block -> WithOrigin SlotNo) -> Point Block -> MaxSlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point Block -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot) ([Point Block] -> [MaxSlotNo])
-> (Set (Point Block) -> [Point Block])
-> Set (Point Block)
-> [MaxSlotNo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                   Set (Point Block) -> [Point Block]
forall a. Set a -> [a]
Set.elems (Set (Point Block) -> MaxSlotNo)
-> STM m (Set (Point Block)) -> STM m MaxSlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                   ChainDB Block m -> STM m (Set (Point Block))
forall (m :: * -> *) block.
(MonadSTM m, HasHeader block) =>
ChainDB block m -> STM m (Set (Point block))
getBlockPointSet (NodeKernel BlockHeader Block s m -> ChainDB Block m
forall header block s (m :: * -> *).
NodeKernel header block s m -> ChainDB block m
nkChainDB NodeKernel BlockHeader Block s m
nodeKernel),
          mkAddFetchedBlock :: STM m (Point Block -> Block -> m ())
mkAddFetchedBlock        =
              (Point Block -> Block -> m ())
-> STM m (Point Block -> Block -> m ())
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Point Block -> Block -> m ())
 -> STM m (Point Block -> Block -> m ()))
-> (Point Block -> Block -> m ())
-> STM m (Point Block -> Block -> m ())
forall a b. (a -> b) -> a -> b
$ \Point Block
_p Block
b ->
                STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Block -> ChainDB Block m -> STM m ()
forall (m :: * -> *) block.
(MonadSTM m, HasFullHeader block) =>
block -> ChainDB block m -> STM m ()
addBlock Block
b (NodeKernel BlockHeader Block s m -> ChainDB Block m
forall header block s (m :: * -> *).
NodeKernel header block s m -> ChainDB block m
nkChainDB NodeKernel BlockHeader Block s m
nodeKernel)),

          HasCallStack =>
AnchoredFragment BlockHeader
-> AnchoredFragment BlockHeader -> Bool
AnchoredFragment BlockHeader
-> AnchoredFragment BlockHeader -> Bool
forall {block} {block}.
(HasHeader block, HasHeader block) =>
AnchoredFragment block -> AnchoredFragment block -> Bool
plausibleCandidateChain :: forall {block} {block}.
(HasHeader block, HasHeader block) =>
AnchoredFragment block -> AnchoredFragment block -> Bool
plausibleCandidateChain :: HasCallStack =>
AnchoredFragment BlockHeader
-> AnchoredFragment BlockHeader -> Bool
plausibleCandidateChain,
          HasCallStack =>
AnchoredFragment BlockHeader
-> AnchoredFragment BlockHeader -> Ordering
AnchoredFragment BlockHeader
-> AnchoredFragment BlockHeader -> Ordering
forall {block} {block}.
(HasHeader block, HasHeader block) =>
AnchoredFragment block -> AnchoredFragment block -> Ordering
compareCandidateChains :: forall {block} {block}.
(HasHeader block, HasHeader block) =>
AnchoredFragment block -> AnchoredFragment block -> Ordering
compareCandidateChains :: HasCallStack =>
AnchoredFragment BlockHeader
-> AnchoredFragment BlockHeader -> Ordering
compareCandidateChains,

          blockFetchSize :: BlockHeader -> SizeInBytes
blockFetchSize         = \BlockHeader
_ -> SizeInBytes
1000,
          blockMatchesHeader :: BlockHeader -> Block -> Bool
blockMatchesHeader     = \BlockHeader
_ Block
_ -> Bool
True,

          FromConsensus BlockHeader -> STM m UTCTime
forall {f :: * -> *}.
Applicative f =>
FromConsensus BlockHeader -> f UTCTime
headerForgeUTCTime :: forall {f :: * -> *}.
Applicative f =>
FromConsensus BlockHeader -> f UTCTime
headerForgeUTCTime :: FromConsensus BlockHeader -> STM m UTCTime
headerForgeUTCTime,
          blockForgeUTCTime :: FromConsensus Block -> STM m UTCTime
blockForgeUTCTime      = FromConsensus BlockHeader -> STM m UTCTime
forall {f :: * -> *}.
Applicative f =>
FromConsensus BlockHeader -> f UTCTime
headerForgeUTCTime (FromConsensus BlockHeader -> STM m UTCTime)
-> (FromConsensus Block -> FromConsensus BlockHeader)
-> FromConsensus Block
-> STM m UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block -> BlockHeader)
-> FromConsensus Block -> FromConsensus BlockHeader
forall a b. (a -> b) -> FromConsensus a -> FromConsensus b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Block -> BlockHeader
blockHeader
        }
      where
        plausibleCandidateChain :: AnchoredFragment block -> AnchoredFragment block -> Bool
plausibleCandidateChain AnchoredFragment block
cur AnchoredFragment block
candidate =
            AnchoredFragment block -> WithOrigin BlockNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin BlockNo
AF.headBlockNo AnchoredFragment block
candidate WithOrigin BlockNo -> WithOrigin BlockNo -> Bool
forall a. Ord a => a -> a -> Bool
> AnchoredFragment block -> WithOrigin BlockNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin BlockNo
AF.headBlockNo AnchoredFragment block
cur

        headerForgeUTCTime :: FromConsensus BlockHeader -> f UTCTime
headerForgeUTCTime (FromConsensus BlockHeader
hdr) =
            UTCTime -> f UTCTime
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTCTime -> f UTCTime) -> UTCTime -> f UTCTime
forall a b. (a -> b) -> a -> b
$
            SlotNo -> UTCTime
convertSlotToTimeForTestsAssumingNoHardFork (BlockHeader -> SlotNo
headerSlot BlockHeader
hdr)

        compareCandidateChains :: AnchoredFragment block -> AnchoredFragment block -> Ordering
compareCandidateChains AnchoredFragment block
c1 AnchoredFragment block
c2 =
          AnchoredFragment block -> WithOrigin BlockNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin BlockNo
AF.headBlockNo AnchoredFragment block
c1 WithOrigin BlockNo -> WithOrigin BlockNo -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` AnchoredFragment block -> WithOrigin BlockNo
forall block.
HasHeader block =>
AnchoredFragment block -> WithOrigin BlockNo
AF.headBlockNo AnchoredFragment block
c2

        -- | Convert a 'Chain' to an 'AnchoredFragment' with an header.
        --
        -- The anchor of the fragment will be 'Chain.genesisPoint'.
        toAnchoredFragmentHeader :: Chain Block -> AF.AnchoredFragment BlockHeader
        toAnchoredFragmentHeader :: Chain Block -> AnchoredFragment BlockHeader
toAnchoredFragmentHeader = Anchor BlockHeader -> [BlockHeader] -> AnchoredFragment BlockHeader
forall v a b. Anchorable v a b => a -> [b] -> AnchoredSeq v a b
AF.fromOldestFirst Anchor BlockHeader
forall block. Anchor block
AF.AnchorGenesis
                                 ([BlockHeader] -> AnchoredFragment BlockHeader)
-> (Chain Block -> [BlockHeader])
-> Chain Block
-> AnchoredFragment BlockHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block -> BlockHeader) -> [Block] -> [BlockHeader]
forall a b. (a -> b) -> [a] -> [b]
map Block -> BlockHeader
blockHeader
                                 ([Block] -> [BlockHeader])
-> (Chain Block -> [Block]) -> Chain Block -> [BlockHeader]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chain Block -> [Block]
forall block. Chain block -> [block]
toOldestFirst

    ntnAddressType :: NtNAddr -> Maybe AddressType
    ntnAddressType :: NtNAddr -> Maybe AddressType
ntnAddressType (TestAddress (Node.EphemeralIPv4Addr Natural
_)) = AddressType -> Maybe AddressType
forall a. a -> Maybe a
Just AddressType
IPv4Address
    ntnAddressType (TestAddress (Node.EphemeralIPv6Addr Natural
_)) = AddressType -> Maybe AddressType
forall a. a -> Maybe a
Just AddressType
IPv6Address
    ntnAddressType (TestAddress (Node.IPAddr (IPv4 IPv4
_) PortNumber
_))   = AddressType -> Maybe AddressType
forall a. a -> Maybe a
Just AddressType
IPv4Address
    ntnAddressType (TestAddress (Node.IPAddr (IPv6 IPv6
_) PortNumber
_))   = AddressType -> Maybe AddressType
forall a. a -> Maybe a
Just AddressType
IPv6Address

    -- various pseudo random generators
    (StdGen
diffStgGen, StdGen
keepAliveStdGen) = StdGen -> (StdGen, StdGen)
forall g. RandomGen g => g -> (g, g)
split (Interfaces m -> StdGen
forall (m :: * -> *). Interfaces m -> StdGen
iRng Interfaces m
ni)

    ntnUnversionedDataCodec :: VersionDataCodec CBOR.Term NtNVersion NtNVersionData
    ntnUnversionedDataCodec :: VersionDataCodec Term NtNVersion NtNVersionData
ntnUnversionedDataCodec = VersionDataCodec { NtNVersion -> NtNVersionData -> Term
forall {p}. p -> NtNVersionData -> Term
encodeData :: forall {p}. p -> NtNVersionData -> Term
encodeData :: NtNVersion -> NtNVersionData -> Term
encodeData, NtNVersion -> Term -> Either Text NtNVersionData
forall {p}. p -> Term -> Either Text NtNVersionData
decodeData :: forall {p}. p -> Term -> Either Text NtNVersionData
decodeData :: NtNVersion -> Term -> Either Text NtNVersionData
decodeData }
      where
        encodeData :: p -> NtNVersionData -> Term
encodeData p
_ NtNVersionData { DiffusionMode
ntnDiffusionMode :: NtNVersionData -> DiffusionMode
ntnDiffusionMode :: DiffusionMode
ntnDiffusionMode, PeerSharing
ntnPeerSharing :: NtNVersionData -> PeerSharing
ntnPeerSharing :: PeerSharing
ntnPeerSharing } =
          let peerSharing :: Int
peerSharing = case PeerSharing
ntnPeerSharing of
                PeerSharing
PeerSharingDisabled -> Int
0
                PeerSharing
PeerSharingEnabled  -> Int
1
           in case DiffusionMode
ntnDiffusionMode of
             DiffusionMode
InitiatorOnlyDiffusionMode         ->
               [Term] -> Term
CBOR.TList [Bool -> Term
CBOR.TBool Bool
False, Int -> Term
CBOR.TInt Int
peerSharing]
             DiffusionMode
InitiatorAndResponderDiffusionMode ->
               [Term] -> Term
CBOR.TList [Bool -> Term
CBOR.TBool Bool
True, Int -> Term
CBOR.TInt Int
peerSharing]

        toPeerSharing :: Int -> Either Text PeerSharing
        toPeerSharing :: Int -> Either Text PeerSharing
toPeerSharing Int
0 = PeerSharing -> Either Text PeerSharing
forall a b. b -> Either a b
Right PeerSharing
PeerSharingDisabled
        toPeerSharing Int
1 = PeerSharing -> Either Text PeerSharing
forall a b. b -> Either a b
Right PeerSharing
PeerSharingEnabled
        toPeerSharing Int
_ = Text -> Either Text PeerSharing
forall a b. a -> Either a b
Left Text
"toPeerSharing: out of bounds"

        decodeData :: p -> Term -> Either Text NtNVersionData
decodeData p
_ (CBOR.TList [CBOR.TBool Bool
False, CBOR.TInt Int
a]) = DiffusionMode -> PeerSharing -> NtNVersionData
NtNVersionData DiffusionMode
InitiatorOnlyDiffusionMode (PeerSharing -> NtNVersionData)
-> Either Text PeerSharing -> Either Text NtNVersionData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Either Text PeerSharing
toPeerSharing Int
a)
        decodeData p
_ (CBOR.TList [CBOR.TBool Bool
True, CBOR.TInt Int
a])  = DiffusionMode -> PeerSharing -> NtNVersionData
NtNVersionData DiffusionMode
InitiatorAndResponderDiffusionMode (PeerSharing -> NtNVersionData)
-> Either Text PeerSharing -> Either Text NtNVersionData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Either Text PeerSharing
toPeerSharing Int
a)
        decodeData p
_ Term
_                                            = Text -> Either Text NtNVersionData
forall a b. a -> Either a b
Left (String -> Text
Text.pack String
"unversionedDataCodec: unexpected term")

    mkArgs :: StrictTVar m (PublicPeerSelectionState NtNAddr)
           -> Diff.Arguments m (NtNFD m) NtNAddr (NtCFD m) NtCAddr
    mkArgs :: StrictTVar m (PublicPeerSelectionState NtNAddr)
-> Arguments m (NtNFD m) NtNAddr (NtCFD m) NtCAddr
mkArgs StrictTVar m (PublicPeerSelectionState NtNAddr)
daPublicPeerSelectionVar = Diff.Arguments
      { daIPv4Address :: Maybe (Either (NtNFD m) NtNAddr)
Diff.daIPv4Address   = NtNAddr -> Either (NtNFD m) NtNAddr
forall a b. b -> Either a b
Right (NtNAddr -> Either (NtNFD m) NtNAddr)
-> Maybe NtNAddr -> Maybe (Either (NtNFD m) NtNAddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NtNAddr -> Maybe NtNAddr
ntnToIPv4 (NtNAddr -> Maybe NtNAddr)
-> (Arguments m -> NtNAddr) -> Arguments m -> Maybe NtNAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arguments m -> NtNAddr
forall (m :: * -> *). Arguments m -> NtNAddr
aIPAddress) Arguments m
na
      , daIPv6Address :: Maybe (Either (NtNFD m) NtNAddr)
Diff.daIPv6Address   = NtNAddr -> Either (NtNFD m) NtNAddr
forall a b. b -> Either a b
Right (NtNAddr -> Either (NtNFD m) NtNAddr)
-> Maybe NtNAddr -> Maybe (Either (NtNFD m) NtNAddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NtNAddr -> Maybe NtNAddr
ntnToIPv6 (NtNAddr -> Maybe NtNAddr)
-> (Arguments m -> NtNAddr) -> Arguments m -> Maybe NtNAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arguments m -> NtNAddr
forall (m :: * -> *). Arguments m -> NtNAddr
aIPAddress) Arguments m
na
      , daLocalAddress :: Maybe (Either (NtCFD m) NtCAddr)
Diff.daLocalAddress  = Maybe (Either (NtCFD m) NtCAddr)
forall a. Maybe a
Nothing
      , daAcceptedConnectionsLimit :: AcceptedConnectionsLimit
Diff.daAcceptedConnectionsLimit
                             = Arguments m -> AcceptedConnectionsLimit
forall (m :: * -> *). Arguments m -> AcceptedConnectionsLimit
aAcceptedLimits Arguments m
na
      , daMode :: DiffusionMode
Diff.daMode          = Arguments m -> DiffusionMode
forall (m :: * -> *). Arguments m -> DiffusionMode
aDiffusionMode Arguments m
na
      , StrictTVar m (PublicPeerSelectionState NtNAddr)
daPublicPeerSelectionVar :: StrictTVar m (PublicPeerSelectionState NtNAddr)
daPublicPeerSelectionVar :: StrictTVar m (PublicPeerSelectionState NtNAddr)
Diff.daPublicPeerSelectionVar
      }

    mkArgsExtra :: StrictTVar m (Script UseBootstrapPeers)
                -> Diff.P2P.ArgumentsExtra m
    mkArgsExtra :: StrictTVar m (Script UseBootstrapPeers) -> ArgumentsExtra m
mkArgsExtra StrictTVar m (Script UseBootstrapPeers)
ubpVar = Diff.P2P.ArgumentsExtra
      { daPeerTargets :: ConsensusModePeerTargets
Diff.P2P.daPeerTargets            = Arguments m -> ConsensusModePeerTargets
forall (m :: * -> *). Arguments m -> ConsensusModePeerTargets
aPeerTargets Arguments m
na
      , daReadLocalRootPeers :: STM
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
Diff.P2P.daReadLocalRootPeers     = Arguments m
-> STM
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
forall (m :: * -> *).
Arguments m
-> STM
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
aReadLocalRootPeers Arguments m
na
      , daReadPublicRootPeers :: STM m (Map RelayAccessPoint PeerAdvertise)
Diff.P2P.daReadPublicRootPeers    = Arguments m -> STM m (Map RelayAccessPoint PeerAdvertise)
forall (m :: * -> *).
Arguments m -> STM m (Map RelayAccessPoint PeerAdvertise)
aReadPublicRootPeers Arguments m
na
      , daReadUseBootstrapPeers :: STM m UseBootstrapPeers
Diff.P2P.daReadUseBootstrapPeers  = StrictTVar m (Script UseBootstrapPeers) -> STM m UseBootstrapPeers
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m (Script a) -> STM m a
stepScriptSTM' StrictTVar m (Script UseBootstrapPeers)
ubpVar
      , daOwnPeerSharing :: PeerSharing
Diff.P2P.daOwnPeerSharing         = Arguments m -> PeerSharing
forall (m :: * -> *). Arguments m -> PeerSharing
aOwnPeerSharing Arguments m
na
      , daReadUseLedgerPeers :: STM m UseLedgerPeers
Diff.P2P.daReadUseLedgerPeers     = Arguments m -> STM m UseLedgerPeers
forall (m :: * -> *). Arguments m -> STM m UseLedgerPeers
aReadUseLedgerPeers Arguments m
na
      , daProtocolIdleTimeout :: DiffTime
Diff.P2P.daProtocolIdleTimeout    = Arguments m -> DiffTime
forall (m :: * -> *). Arguments m -> DiffTime
aProtocolIdleTimeout Arguments m
na
      , daTimeWaitTimeout :: DiffTime
Diff.P2P.daTimeWaitTimeout        = Arguments m -> DiffTime
forall (m :: * -> *). Arguments m -> DiffTime
aTimeWaitTimeout Arguments m
na
      , daDeadlineChurnInterval :: DiffTime
Diff.P2P.daDeadlineChurnInterval  = DiffTime
3300
      , daBulkChurnInterval :: DiffTime
Diff.P2P.daBulkChurnInterval      = DiffTime
300
      , daReadLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot)
Diff.P2P.daReadLedgerPeerSnapshot = Maybe LedgerPeerSnapshot -> STM m (Maybe LedgerPeerSnapshot)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LedgerPeerSnapshot
forall a. Maybe a
Nothing -- ^ tested independently
      , daConsensusMode :: ConsensusMode
Diff.P2P.daConsensusMode          = Arguments m -> ConsensusMode
forall (m :: * -> *). Arguments m -> ConsensusMode
aConsensusMode Arguments m
na
      , daMinBigLedgerPeersForTrustedState :: MinBigLedgerPeersForTrustedState
Diff.P2P.daMinBigLedgerPeersForTrustedState
          = Int -> MinBigLedgerPeersForTrustedState
MinBigLedgerPeersForTrustedState Int
0 -- ^ todo: fix
      }

    appArgs :: Node.AppArgs BlockHeader Block m
    appArgs :: AppArgs BlockHeader Block m
appArgs = Node.AppArgs
      { aaLedgerPeersConsensusInterface :: LedgerPeersConsensusInterface m
Node.aaLedgerPeersConsensusInterface
                                        = Interfaces m -> LedgerPeersConsensusInterface m
forall (m :: * -> *).
Interfaces m -> LedgerPeersConsensusInterface m
iLedgerPeersConsensusInterface Interfaces m
ni
      , aaKeepAliveStdGen :: StdGen
Node.aaKeepAliveStdGen          = StdGen
keepAliveStdGen
      , aaDiffusionMode :: DiffusionMode
Node.aaDiffusionMode            = Arguments m -> DiffusionMode
forall (m :: * -> *). Arguments m -> DiffusionMode
aDiffusionMode Arguments m
na
      , aaKeepAliveInterval :: DiffTime
Node.aaKeepAliveInterval        = Arguments m -> DiffTime
forall (m :: * -> *). Arguments m -> DiffTime
aKeepAliveInterval Arguments m
na
      , aaPingPongInterval :: DiffTime
Node.aaPingPongInterval         = Arguments m -> DiffTime
forall (m :: * -> *). Arguments m -> DiffTime
aPingPongInterval Arguments m
na
      , aaShouldChainSyncExit :: BlockHeader -> m Bool
Node.aaShouldChainSyncExit      = Arguments m -> BlockHeader -> m Bool
forall (m :: * -> *). Arguments m -> BlockHeader -> m Bool
aShouldChainSyncExit Arguments m
na
      , aaChainSyncEarlyExit :: Bool
Node.aaChainSyncEarlyExit       = Arguments m -> Bool
forall (m :: * -> *). Arguments m -> Bool
aChainSyncEarlyExit Arguments m
na
      , aaOwnPeerSharing :: PeerSharing
Node.aaOwnPeerSharing           = Arguments m -> PeerSharing
forall (m :: * -> *). Arguments m -> PeerSharing
aOwnPeerSharing Arguments m
na
      , aaUpdateOutboundConnectionsState :: OutboundConnectionsState -> STM m ()
Node.aaUpdateOutboundConnectionsState =
          Interfaces m -> OutboundConnectionsState -> STM m ()
forall (m :: * -> *).
Interfaces m -> OutboundConnectionsState -> STM m ()
iUpdateOutboundConnectionsState Interfaces m
ni
      }

--- Utils

ntnToIPv4 :: NtNAddr -> Maybe NtNAddr
ntnToIPv4 :: NtNAddr -> Maybe NtNAddr
ntnToIPv4 ntnAddr :: NtNAddr
ntnAddr@(TestAddress (Node.EphemeralIPv4Addr Natural
_)) = NtNAddr -> Maybe NtNAddr
forall a. a -> Maybe a
Just NtNAddr
ntnAddr
ntnToIPv4 ntnAddr :: NtNAddr
ntnAddr@(TestAddress (Node.IPAddr (IPv4 IPv4
_) PortNumber
_))   = NtNAddr -> Maybe NtNAddr
forall a. a -> Maybe a
Just NtNAddr
ntnAddr
ntnToIPv4 (TestAddress NtNAddr_
_)                                  = Maybe NtNAddr
forall a. Maybe a
Nothing

ntnToIPv6 :: NtNAddr -> Maybe NtNAddr
ntnToIPv6 :: NtNAddr -> Maybe NtNAddr
ntnToIPv6 ntnAddr :: NtNAddr
ntnAddr@(TestAddress (Node.EphemeralIPv6Addr Natural
_)) = NtNAddr -> Maybe NtNAddr
forall a. a -> Maybe a
Just NtNAddr
ntnAddr
ntnToIPv6 ntnAddr :: NtNAddr
ntnAddr@(TestAddress (Node.IPAddr (IPv6 IPv6
_) PortNumber
_))   = NtNAddr -> Maybe NtNAddr
forall a. a -> Maybe a
Just NtNAddr
ntnAddr
ntnToIPv6 (TestAddress NtNAddr_
_)                                  = Maybe NtNAddr
forall a. Maybe a
Nothing

--
-- Constants
--

config_REPROMOTE_DELAY :: RepromoteDelay
config_REPROMOTE_DELAY :: RepromoteDelay
config_REPROMOTE_DELAY = RepromoteDelay
10