{-# LANGUAGE BlockArguments        #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module Test.Ouroboros.Network.Diffusion.Testnet.Cardano.Simulation
  ( SimArgs (..)
  , renderSimArgs
  , mainnetSimArgs
  , NodeArgs (..)
  , ServiceDomainName (..)
  , DiffusionScript (..)
  , HotDiffusionScript (..)
  , DiffusionSimulationTrace (..)
  , prop_diffusionScript_fixupCommands
  , prop_diffusionScript_commandScript_valid
  , fixupCommands
  , diffusionSimulation
  , Command (..)
    -- * Tracing
  , DiffusionTestTrace (..)
  , ppDiffusionTestTrace
  , iosimTracer
    -- * Re-exports
  , TestAddress (..)
  , RelayAccessPoint (..)
  , Script (..)
  , module PeerSelection
  ) where

import Control.Applicative (Alternative)
import Control.Concurrent.Class.MonadMVar (MonadMVar)
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad (forM, when)
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork
import Control.Monad.Class.MonadSay
import Control.Monad.Class.MonadST
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import Control.Monad.Fix
import Control.Monad.IOSim (IOSim, traceM)
import Control.Tracer (Tracer (..), contramap, nullTracer, traceWith)

import Data.Bifunctor (first)
import Data.Bool (bool)
import Data.ByteString.Char8 qualified as BSC
import Data.ByteString.Lazy qualified as BL
import Data.Either (fromLeft, fromRight)
import Data.Foldable (foldlM)
import Data.List (delete, nub, partition)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe, maybeToList)
import Data.Proxy (Proxy (..))
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Time.Clock (secondsToDiffTime)
import Data.Void (Void)
import Network.DNS (Domain)
import Network.DNS qualified as DNS
import System.Random (StdGen, mkStdGen)
import System.Random qualified as Random

import Network.Mux qualified as Mux
import Network.TypedProtocol.Core
import Network.TypedProtocol.PingPong.Type qualified as PingPong

import Cardano.Network.ConsensusMode
import Cardano.Network.Diffusion.Configuration qualified as Cardano
import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..))
import Cardano.Network.PeerSelection.LocalRootPeers
           (OutboundConnectionsState (..))
import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable)
import Cardano.Network.Types (LedgerStateJudgement (..),
           NumberOfBigLedgerPeers (..))

import Cardano.Network.LedgerPeerConsensusInterface qualified as Cardano
import Cardano.Network.PeerSelection.Churn (ChurnMode (..), TraceChurnMode,
           peerChurnGovernor)
import Cardano.Network.PeerSelection.Churn qualified as Churn
import Cardano.Network.PeerSelection.ExtraRootPeers qualified as Cardano
import Cardano.Network.PeerSelection.Governor.PeerSelectionActions qualified as Cardano
import Cardano.Network.PeerSelection.Governor.PeerSelectionState qualified as Cardano hiding
           (consensusMode)
import Cardano.Network.PeerSelection.Governor.PeerSelectionState qualified as ExtraState
import Cardano.Network.PeerSelection.Governor.Types qualified as Cardano
import Cardano.Network.PeerSelection.Governor.Types qualified as ExtraSizes
import Cardano.Network.PeerSelection.PeerSelectionActions
           (requestPublicRootPeers)
import Ouroboros.Network.PeerSelection.RelayAccessPoint

import Ouroboros.Network.Block (BlockNo)
import Ouroboros.Network.BlockFetch (FetchMode (..), PraosFetchMode (..),
           TraceFetchClientState, TraceLabelPeer (..))
import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace)
import Ouroboros.Network.ConnectionId
import Ouroboros.Network.ConnectionManager.Core qualified as CM
import Ouroboros.Network.ConnectionManager.State qualified as CM
import Ouroboros.Network.ConnectionManager.Types (AbstractTransitionTrace)
import Ouroboros.Network.Diffusion qualified as Diffusion
import Ouroboros.Network.Driver.Limits (ProtocolSizeLimits (..),
           ProtocolTimeLimits (..))
import Ouroboros.Network.Handshake.Acceptable (Acceptable (acceptableVersion))
import Ouroboros.Network.InboundGovernor (RemoteTransitionTrace)
import Ouroboros.Network.InboundGovernor qualified as IG
import Ouroboros.Network.Mux (MiniProtocolLimits (..))
import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..))
import Ouroboros.Network.PeerSelection hiding (peerChurnGovernor,
           requestPublicRootPeers)
import Ouroboros.Network.PeerSelection.Governor qualified as Governor
import Ouroboros.Network.PeerSelection.LedgerPeers (accPoolStake)
import Ouroboros.Network.PeerSelection.RootPeersDNS
import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..),
           LocalRootConfig, WarmValency (..))
import Ouroboros.Network.Protocol.BlockFetch.Codec (byteLimitsBlockFetch,
           timeLimitsBlockFetch)
import Ouroboros.Network.Protocol.ChainSync.Codec (byteLimitsChainSync,
           timeLimitsChainSync)
import Ouroboros.Network.Protocol.KeepAlive.Codec (byteLimitsKeepAlive,
           timeLimitsKeepAlive)
import Ouroboros.Network.Protocol.Limits (shortWait, smallByteLimit)
import Ouroboros.Network.Protocol.PeerSharing.Codec (byteLimitsPeerSharing,
           timeLimitsPeerSharing)
import Ouroboros.Network.Protocol.TxSubmission2.Codec (byteLimitsTxSubmission2,
           timeLimitsTxSubmission2)
import Ouroboros.Network.Server qualified as Server
import Ouroboros.Network.Snocket (Snocket, TestAddress (..))
import Ouroboros.Network.TxSubmission.Inbound.V2.Policy (TxDecisionPolicy)
import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TraceTxLogic,
           TraceTxSubmissionInbound)

import Ouroboros.Network.Mock.ConcreteBlock (Block (..), BlockHeader (..))
import Simulation.Network.Snocket (BearerInfo (..), FD, SnocketTrace,
           WithAddr (..), makeFDBearer, withSnocket)

import Test.Ouroboros.Network.Data.Script
import Test.Ouroboros.Network.Diffusion.Node qualified as Node
import Test.Ouroboros.Network.Diffusion.Node.Kernel (NtCAddr, NtCVersion,
           NtCVersionData, NtNAddr, NtNAddr_ (IPAddr), NtNVersion,
           NtNVersionData, ppNtNAddr)
import Test.Ouroboros.Network.LedgerPeers (LedgerPools (..), cardanoSRVPrefix,
           genLedgerPoolsFrom)
import Test.Ouroboros.Network.PeerSelection.Cardano.Instances ()
import Test.Ouroboros.Network.PeerSelection.Instances qualified as PeerSelection
import Test.Ouroboros.Network.PeerSelection.LocalRootPeers ()
import Test.Ouroboros.Network.PeerSelection.RootPeersDNS (DNSLookupDelay (..),
           DNSTimeout (..), DomainAccessPoint (..), MockDNSMap, genDomainName)
import Test.Ouroboros.Network.PeerSelection.RootPeersDNS qualified as PeerSelection hiding
           (tests)
import Test.Ouroboros.Network.TxSubmission.TxLogic (ArbTxDecisionPolicy (..))
import Test.Ouroboros.Network.TxSubmission.Types (Tx (..))
import Test.Ouroboros.Network.Utils
import Test.QuickCheck

-- | Diffusion Simulator Arguments
--
-- Contains all necessary randomly generated values needed to run diffusion in
-- simulation.
--
data SimArgs =
  SimArgs
    { SimArgs -> DiffTime
saSlot             :: DiffTime
      -- ^ 'randomBlockGenerationArgs' slot duration argument
    , SimArgs -> Int
saQuota            :: Int
      -- ^ 'randomBlockGenerationArgs' quota value
    , SimArgs -> TxDecisionPolicy
saTxDecisionPolicy :: TxDecisionPolicy
      -- ^ Decision policy for tx submission protocol
    }

-- | Render `SimArgs`, ignores `saTxDecisionPolicy`; useful for quickcheck
-- coverage checking.
--
renderSimArgs :: SimArgs -> String
renderSimArgs :: SimArgs -> [Char]
renderSimArgs SimArgs { DiffTime
saSlot :: SimArgs -> DiffTime
saSlot :: DiffTime
saSlot, Int
saQuota :: SimArgs -> Int
saQuota :: Int
saQuota } =
    [Char]
"slotDuration: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DiffTime -> [Char]
forall a. Show a => a -> [Char]
show DiffTime
saSlot [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" quota: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
saQuota

instance Show SimArgs where
    show :: SimArgs -> [Char]
show SimArgs { DiffTime
saSlot :: SimArgs -> DiffTime
saSlot :: DiffTime
saSlot, Int
saQuota :: SimArgs -> Int
saQuota :: Int
saQuota, TxDecisionPolicy
saTxDecisionPolicy :: SimArgs -> TxDecisionPolicy
saTxDecisionPolicy :: TxDecisionPolicy
saTxDecisionPolicy } =
      [[Char]] -> [Char]
unwords [ [Char]
"SimArgs"
              , DiffTime -> [Char]
forall a. Show a => a -> [Char]
show DiffTime
saSlot
              , Int -> [Char]
forall a. Show a => a -> [Char]
show Int
saQuota
              , [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ TxDecisionPolicy -> [Char]
forall a. Show a => a -> [Char]
show TxDecisionPolicy
saTxDecisionPolicy [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
              ]

data ServiceDomainName =
      DomainName Domain
      -- ^ a well configured domain name
    | Misconfigured Domain
      -- ^ a domain name which is advertised but its' IPs are wrong.
    | NoDomainName
  deriving Int -> ServiceDomainName -> [Char] -> [Char]
[ServiceDomainName] -> [Char] -> [Char]
ServiceDomainName -> [Char]
(Int -> ServiceDomainName -> [Char] -> [Char])
-> (ServiceDomainName -> [Char])
-> ([ServiceDomainName] -> [Char] -> [Char])
-> Show ServiceDomainName
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> ServiceDomainName -> [Char] -> [Char]
showsPrec :: Int -> ServiceDomainName -> [Char] -> [Char]
$cshow :: ServiceDomainName -> [Char]
show :: ServiceDomainName -> [Char]
$cshowList :: [ServiceDomainName] -> [Char] -> [Char]
showList :: [ServiceDomainName] -> [Char] -> [Char]
Show

instance Arbitrary ServiceDomainName where
    arbitrary :: Gen ServiceDomainName
arbitrary = [(Int, Gen ServiceDomainName)] -> Gen ServiceDomainName
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [ (Int
8, ServiceDomainName -> Gen ServiceDomainName
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServiceDomainName -> Gen ServiceDomainName)
-> ServiceDomainName -> Gen ServiceDomainName
forall a b. (a -> b) -> a -> b
$ Domain -> ServiceDomainName
DomainName ([Char] -> Domain
BSC.pack [Char]
"iog.io"))
                          , (Int
1, ServiceDomainName -> Gen ServiceDomainName
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServiceDomainName -> Gen ServiceDomainName)
-> ServiceDomainName -> Gen ServiceDomainName
forall a b. (a -> b) -> a -> b
$ Domain -> ServiceDomainName
Misconfigured ([Char] -> Domain
BSC.pack [Char]
"error.iog.io"))
                          , (Int
1, ServiceDomainName -> Gen ServiceDomainName
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServiceDomainName -> Gen ServiceDomainName)
-> ServiceDomainName -> Gen ServiceDomainName
forall a b. (a -> b) -> a -> b
$ ServiceDomainName
NoDomainName)
                          ]
    shrink :: ServiceDomainName -> [ServiceDomainName]
shrink (DomainName Domain
_)    = []
    shrink (Misconfigured Domain
a) = [Domain -> ServiceDomainName
DomainName Domain
a]
    shrink  ServiceDomainName
NoDomainName     = []


-- | Diffusion Simulator Node Arguments
--
-- Contains all necessary randomly generated values needed to run a node in
-- simulation.
--
data NodeArgs =
  NodeArgs
    { NodeArgs -> Int
naSeed                   :: Int
      -- ^ 'randomBlockGenerationArgs' seed argument
    , NodeArgs -> DiffusionMode
naDiffusionMode          :: DiffusionMode
    , NodeArgs -> Map RelayAccessPoint PeerAdvertise
naPublicRoots            :: Map RelayAccessPoint PeerAdvertise
      -- ^ 'Interfaces' relays auxiliary value
    , NodeArgs -> ConsensusMode
naConsensusMode          :: ConsensusMode
    , NodeArgs -> Script UseBootstrapPeers
naBootstrapPeers         :: Script UseBootstrapPeers
      -- ^ 'Interfaces' relays auxiliary value
    , NodeArgs -> NtNAddr
naAddr                   :: NtNAddr
      -- ^ 'Arguments' 'aIPAddress' value
    , NodeArgs -> PeerSharing
naPeerSharing            :: PeerSharing
      -- ^ 'Arguments' 'aPeerSharing' value
    , NodeArgs
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
naLocalRootPeers         :: [( HotValency
                                   , WarmValency
                                   , Map RelayAccessPoint (LocalRootConfig PeerTrustable)
                                   )]
    , NodeArgs -> Script LedgerPools
naLedgerPeers            :: Script LedgerPools
      -- ^ 'Arguments' 'LocalRootPeers' values
    , NodeArgs -> (PeerSelectionTargets, PeerSelectionTargets)
naPeerTargets            :: (PeerSelectionTargets, PeerSelectionTargets)
      -- ^ 'Arguments' 'aLocalSelectionTargets' value
    , NodeArgs -> Script DNSTimeout
naDNSTimeoutScript       :: Script DNSTimeout
      -- ^ 'Arguments' 'aDNSTimeoutScript' value
    , NodeArgs -> Script DNSLookupDelay
naDNSLookupDelayScript   :: Script DNSLookupDelay
      -- ^ 'Arguments' 'aDNSLookupDelayScript' value
    , NodeArgs -> Maybe BlockNo
naChainSyncExitOnBlockNo :: Maybe BlockNo
    , NodeArgs -> Bool
naChainSyncEarlyExit     :: Bool
    , NodeArgs -> Script FetchMode
naFetchModeScript        :: Script FetchMode
    , NodeArgs -> [Tx Int]
naTxs                    :: [Tx Int]
    }

instance Show NodeArgs where
    show :: NodeArgs -> [Char]
show NodeArgs { Int
naSeed :: NodeArgs -> Int
naSeed :: Int
naSeed, DiffusionMode
naDiffusionMode :: NodeArgs -> DiffusionMode
naDiffusionMode :: DiffusionMode
naDiffusionMode, Script UseBootstrapPeers
naBootstrapPeers :: NodeArgs -> Script UseBootstrapPeers
naBootstrapPeers :: Script UseBootstrapPeers
naBootstrapPeers,
                    Map RelayAccessPoint PeerAdvertise
naPublicRoots :: NodeArgs -> Map RelayAccessPoint PeerAdvertise
naPublicRoots :: Map RelayAccessPoint PeerAdvertise
naPublicRoots, NtNAddr
naAddr :: NodeArgs -> NtNAddr
naAddr :: NtNAddr
naAddr, PeerSharing
naPeerSharing :: NodeArgs -> PeerSharing
naPeerSharing :: PeerSharing
naPeerSharing, Script LedgerPools
naLedgerPeers :: NodeArgs -> Script LedgerPools
naLedgerPeers :: Script LedgerPools
naLedgerPeers,
                    [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
naLocalRootPeers :: NodeArgs
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
naLocalRootPeers :: [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
naLocalRootPeers, (PeerSelectionTargets, PeerSelectionTargets)
naPeerTargets :: NodeArgs -> (PeerSelectionTargets, PeerSelectionTargets)
naPeerTargets :: (PeerSelectionTargets, PeerSelectionTargets)
naPeerTargets, Script DNSTimeout
naDNSTimeoutScript :: NodeArgs -> Script DNSTimeout
naDNSTimeoutScript :: Script DNSTimeout
naDNSTimeoutScript,
                    Script DNSLookupDelay
naDNSLookupDelayScript :: NodeArgs -> Script DNSLookupDelay
naDNSLookupDelayScript :: Script DNSLookupDelay
naDNSLookupDelayScript, Maybe BlockNo
naChainSyncExitOnBlockNo :: NodeArgs -> Maybe BlockNo
naChainSyncExitOnBlockNo :: Maybe BlockNo
naChainSyncExitOnBlockNo,
                    Bool
naChainSyncEarlyExit :: NodeArgs -> Bool
naChainSyncEarlyExit :: Bool
naChainSyncEarlyExit, Script FetchMode
naFetchModeScript :: NodeArgs -> Script FetchMode
naFetchModeScript :: Script FetchMode
naFetchModeScript, ConsensusMode
naConsensusMode :: NodeArgs -> ConsensusMode
naConsensusMode :: ConsensusMode
naConsensusMode,
                    [Tx Int]
naTxs :: NodeArgs -> [Tx Int]
naTxs :: [Tx Int]
naTxs } =
      [[Char]] -> [Char]
unwords [ [Char]
"NodeArgs"
              , [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
naSeed [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
              , DiffusionMode -> [Char]
forall a. Show a => a -> [Char]
show DiffusionMode
naDiffusionMode
              , [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Map RelayAccessPoint PeerAdvertise -> [Char]
forall a. Show a => a -> [Char]
show Map RelayAccessPoint PeerAdvertise
naPublicRoots [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
              , ConsensusMode -> [Char]
forall a. Show a => a -> [Char]
show ConsensusMode
naConsensusMode
              , [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Script UseBootstrapPeers -> [Char]
forall a. Show a => a -> [Char]
show Script UseBootstrapPeers
naBootstrapPeers [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
              , [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NtNAddr -> [Char]
forall a. Show a => a -> [Char]
show NtNAddr
naAddr [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
              , PeerSharing -> [Char]
forall a. Show a => a -> [Char]
show PeerSharing
naPeerSharing
              , [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> [Char]
forall a. Show a => a -> [Char]
show [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
naLocalRootPeers
              , [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Script LedgerPools -> [Char]
forall a. Show a => a -> [Char]
show Script LedgerPools
naLedgerPeers [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
              , (PeerSelectionTargets, PeerSelectionTargets) -> [Char]
forall a. Show a => a -> [Char]
show (PeerSelectionTargets, PeerSelectionTargets)
naPeerTargets
              , [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Script DNSTimeout -> [Char]
forall a. Show a => a -> [Char]
show Script DNSTimeout
naDNSTimeoutScript [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
              , [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Script DNSLookupDelay -> [Char]
forall a. Show a => a -> [Char]
show Script DNSLookupDelay
naDNSLookupDelayScript [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
              , [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe BlockNo -> [Char]
forall a. Show a => a -> [Char]
show Maybe BlockNo
naChainSyncExitOnBlockNo [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
              , Bool -> [Char]
forall a. Show a => a -> [Char]
show Bool
naChainSyncEarlyExit
              , [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Script FetchMode -> [Char]
forall a. Show a => a -> [Char]
show Script FetchMode
naFetchModeScript [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"
              , [Tx Int] -> [Char]
forall a. Show a => a -> [Char]
show [Tx Int]
naTxs
              ]

data Command = JoinNetwork DiffTime
             | Kill DiffTime
             | Reconfigure DiffTime
                           [( HotValency
                            , WarmValency
                            , Map RelayAccessPoint (LocalRootConfig PeerTrustable)
                            )]
             | Skip DiffTime
  deriving Command -> Command -> Bool
(Command -> Command -> Bool)
-> (Command -> Command -> Bool) -> Eq Command
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
/= :: Command -> Command -> Bool
Eq

instance Show Command where
    showsPrec :: Int -> Command -> [Char] -> [Char]
showsPrec Int
d (JoinNetwork DiffTime
delay)             = [Char] -> [Char] -> [Char]
showString [Char]
"JoinNetwork "
                                                ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DiffTime -> [Char] -> [Char]
forall a. Show a => Int -> a -> [Char] -> [Char]
showsPrec Int
d DiffTime
delay
    showsPrec Int
d (Kill DiffTime
delay)                    = [Char] -> [Char] -> [Char]
showString [Char]
"Kill "
                                                ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DiffTime -> [Char] -> [Char]
forall a. Show a => Int -> a -> [Char] -> [Char]
showsPrec Int
d DiffTime
delay
    showsPrec Int
d (Reconfigure DiffTime
delay [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
localRoots)  = [Char] -> [Char] -> [Char]
showString [Char]
"Reconfigure "
                                                ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DiffTime -> [Char] -> [Char]
forall a. Show a => Int -> a -> [Char] -> [Char]
showsPrec Int
d DiffTime
delay
                                                ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString [Char]
" "
                                                ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> [Char]
-> [Char]
forall a. Show a => Int -> a -> [Char] -> [Char]
showsPrec Int
d [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
localRoots
    showsPrec Int
d (Skip DiffTime
delay)                    = [Char] -> [Char] -> [Char]
showString [Char]
"Skip"
                                                ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DiffTime -> [Char] -> [Char]
forall a. Show a => Int -> a -> [Char] -> [Char]
showsPrec Int
d DiffTime
delay
                                                ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
showString [Char]
" "

genCommands :: [( HotValency
                , WarmValency
                , Map RelayAccessPoint (LocalRootConfig PeerTrustable)
                )]
            -> Gen [Command]
genCommands :: [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> Gen [Command]
genCommands [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
localRoots = (Int -> Gen [Command]) -> Gen [Command]
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen [Command]) -> Gen [Command])
-> (Int -> Gen [Command]) -> Gen [Command]
forall a b. (a -> b) -> a -> b
$ \Int
size -> do
  commands <- Int -> Gen Command -> Gen [Command]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
size ([(Int, Gen Command)] -> Gen Command
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [ (Int
10, DiffTime -> Command
JoinNetwork (DiffTime -> Command) -> Gen DiffTime -> Gen Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen DiffTime
delay)
                                       , (Int
6, DiffTime
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> Command
Reconfigure
                                              (DiffTime
 -> [(HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
 -> Command)
-> Gen DiffTime
-> Gen
     ([(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
      -> Command)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen DiffTime
delay
                                              Gen
  ([(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
   -> Command)
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> Gen Command
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
subLocalRootPeers)
                                       , (Int
3, DiffTime -> Command
Kill (DiffTime -> Command) -> Gen DiffTime -> Gen Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen DiffTime
delay)
                                       ])
  return (fixupCommands commands)
  where
    subLocalRootPeers :: Gen [( HotValency
                              , WarmValency
                              , Map RelayAccessPoint (LocalRootConfig PeerTrustable)
                              )]
    subLocalRootPeers :: Gen
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
subLocalRootPeers = do
      subLRP <- [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
forall a. [a] -> Gen [a]
sublistOf [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
localRoots
      mapM (\(HotValency
h, WarmValency
w, Map RelayAccessPoint (LocalRootConfig PeerTrustable)
g) -> (HotValency
h, WarmValency
w,) (Map RelayAccessPoint (LocalRootConfig PeerTrustable)
 -> (HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable)))
-> Gen (Map RelayAccessPoint (LocalRootConfig PeerTrustable))
-> Gen
     (HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig PeerTrustable))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (([(RelayAccessPoint, LocalRootConfig PeerTrustable)]
 -> Map RelayAccessPoint (LocalRootConfig PeerTrustable))
-> Gen [(RelayAccessPoint, LocalRootConfig PeerTrustable)]
-> Gen (Map RelayAccessPoint (LocalRootConfig PeerTrustable))
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(RelayAccessPoint, LocalRootConfig PeerTrustable)]
-> Map RelayAccessPoint (LocalRootConfig PeerTrustable)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (Gen [(RelayAccessPoint, LocalRootConfig PeerTrustable)]
 -> Gen (Map RelayAccessPoint (LocalRootConfig PeerTrustable)))
-> (Map RelayAccessPoint (LocalRootConfig PeerTrustable)
    -> Gen [(RelayAccessPoint, LocalRootConfig PeerTrustable)])
-> Map RelayAccessPoint (LocalRootConfig PeerTrustable)
-> Gen (Map RelayAccessPoint (LocalRootConfig PeerTrustable))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RelayAccessPoint, LocalRootConfig PeerTrustable)]
-> Gen [(RelayAccessPoint, LocalRootConfig PeerTrustable)]
forall a. [a] -> Gen [a]
sublistOf ([(RelayAccessPoint, LocalRootConfig PeerTrustable)]
 -> Gen [(RelayAccessPoint, LocalRootConfig PeerTrustable)])
-> (Map RelayAccessPoint (LocalRootConfig PeerTrustable)
    -> [(RelayAccessPoint, LocalRootConfig PeerTrustable)])
-> Map RelayAccessPoint (LocalRootConfig PeerTrustable)
-> Gen [(RelayAccessPoint, LocalRootConfig PeerTrustable)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map RelayAccessPoint (LocalRootConfig PeerTrustable)
-> [(RelayAccessPoint, LocalRootConfig PeerTrustable)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map RelayAccessPoint (LocalRootConfig PeerTrustable)
 -> Gen (Map RelayAccessPoint (LocalRootConfig PeerTrustable)))
-> Map RelayAccessPoint (LocalRootConfig PeerTrustable)
-> Gen (Map RelayAccessPoint (LocalRootConfig PeerTrustable))
forall a b. (a -> b) -> a -> b
$ Map RelayAccessPoint (LocalRootConfig PeerTrustable)
g)) subLRP

    delay :: Gen DiffTime
delay = [(Int, Gen DiffTime)] -> Gen DiffTime
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [ (Int
3, Integer -> Gen DiffTime
genDelayWithPrecision Integer
65)
                      , (Int
1, (DiffTime -> DiffTime -> DiffTime
forall a. Fractional a => a -> a -> a
/ DiffTime
10) (DiffTime -> DiffTime) -> Gen DiffTime -> Gen DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Gen DiffTime
genDelayWithPrecision Integer
60)
                      ]

fixupCommands :: [Command] -> [Command]
fixupCommands :: [Command] -> [Command]
fixupCommands [] = []
fixupCommands (jn :: Command
jn@(JoinNetwork DiffTime
_):[Command]
t) = Command
jn Command -> [Command] -> [Command]
forall a. a -> [a] -> [a]
: Command -> DiffTime -> [Command] -> [Command]
go Command
jn DiffTime
0 [Command]
t
  where
    go :: Command -> DiffTime -> [Command] -> [Command]
    go :: Command -> DiffTime -> [Command] -> [Command]
go Command
_ DiffTime
_ [] = []
    go Command
prev DiffTime
accDelay (Command
cmd:[Command]
cmds) =
      case (Command
prev, Command
cmd) of
        (JoinNetwork DiffTime
_   , JoinNetwork DiffTime
_   ) -> Command -> DiffTime -> [Command] -> [Command]
go Command
prev DiffTime
accDelay [Command]
cmds
        (Kill DiffTime
_          , Kill DiffTime
_          ) -> Command -> DiffTime -> [Command] -> [Command]
go Command
prev DiffTime
accDelay [Command]
cmds
        (Kill DiffTime
_          , Reconfigure DiffTime
_ [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
_ ) -> Command -> DiffTime -> [Command] -> [Command]
go Command
prev DiffTime
accDelay [Command]
cmds
        (Reconfigure DiffTime
_ [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
_ , JoinNetwork DiffTime
_   ) -> Command -> DiffTime -> [Command] -> [Command]
go Command
prev DiffTime
accDelay [Command]
cmds
        (Command
_               , Skip DiffTime
d          ) -> Command -> DiffTime -> [Command] -> [Command]
go Command
prev (DiffTime
d DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
accDelay) [Command]
cmds
        (Command
_               , JoinNetwork DiffTime
d   ) -> DiffTime -> Command
JoinNetwork (DiffTime
d DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
accDelay) Command -> [Command] -> [Command]
forall a. a -> [a] -> [a]
: Command -> DiffTime -> [Command] -> [Command]
go Command
cmd DiffTime
0 [Command]
cmds
        (Command
_               , Kill DiffTime
d          ) -> DiffTime -> Command
Kill (DiffTime
d DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
accDelay) Command -> [Command] -> [Command]
forall a. a -> [a] -> [a]
: Command -> DiffTime -> [Command] -> [Command]
go Command
cmd DiffTime
0 [Command]
cmds
        (Command
_               , Reconfigure DiffTime
d [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
c ) -> DiffTime
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> Command
Reconfigure (DiffTime
d DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
accDelay) [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
c Command -> [Command] -> [Command]
forall a. a -> [a] -> [a]
: Command -> DiffTime -> [Command] -> [Command]
go Command
cmd DiffTime
0 [Command]
cmds
fixupCommands (Command
_:[Command]
t) = [Command] -> [Command]
fixupCommands [Command]
t

-- | Simulation arguments.
--
-- Slot length needs to be greater than 0 else we get a livelock on the IOSim.
--
-- Quota values matches mainnet, so a slot length of 1s and 1 / 20 chance that
-- someone gets to make a block.
--
mainnetSimArgs :: Int
               -> TxDecisionPolicy
               -> SimArgs
mainnetSimArgs :: Int -> TxDecisionPolicy -> SimArgs
mainnetSimArgs Int
numberOfNodes TxDecisionPolicy
txDecisionPolicy =
  SimArgs {
      saSlot :: DiffTime
saSlot  = Integer -> DiffTime
secondsToDiffTime Integer
1,
      saQuota :: Int
saQuota = if Int
numberOfNodes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
                then Int
20 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
numberOfNodes
                else Int
100,
      saTxDecisionPolicy :: TxDecisionPolicy
saTxDecisionPolicy = TxDecisionPolicy
txDecisionPolicy
    }


newtype SmallPeerSelectionTargets = SmallTargets PeerSelectionTargets

instance Arbitrary SmallPeerSelectionTargets where
  arbitrary :: Gen SmallPeerSelectionTargets
arbitrary = (Int -> Gen SmallPeerSelectionTargets)
-> Gen SmallPeerSelectionTargets
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen SmallPeerSelectionTargets)
 -> Gen SmallPeerSelectionTargets)
-> (Int -> Gen SmallPeerSelectionTargets)
-> Gen SmallPeerSelectionTargets
forall a b. (a -> b) -> a -> b
$ \Int
size -> do
    targetNumberOfKnownPeers       <- NonNegative Int -> Int
forall a. NonNegative a -> a
getNonNegative (NonNegative Int -> Int) -> Gen (NonNegative Int) -> Gen Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen (NonNegative Int) -> Gen (NonNegative Int)
forall a. HasCallStack => Int -> Gen a -> Gen a
resize Int
size Gen (NonNegative Int)
forall a. Arbitrary a => Gen a
arbitrary
    targetNumberOfRootPeers        <- choose (0, targetNumberOfKnownPeers)
    targetNumberOfEstablishedPeers <- choose (0, targetNumberOfKnownPeers)
    targetNumberOfActivePeers      <- choose (0, targetNumberOfEstablishedPeers)

    targetNumberOfKnownBigLedgerPeers
      <- getNonNegative <$> resize size arbitrary
    targetNumberOfEstablishedBigLedgerPeers
      <- choose (0 , targetNumberOfKnownBigLedgerPeers)
    targetNumberOfActiveBigLedgerPeers
      <- choose (0, targetNumberOfEstablishedBigLedgerPeers)

    return $ SmallTargets $ PeerSelectionTargets {
      targetNumberOfRootPeers,
      targetNumberOfKnownPeers,
      targetNumberOfEstablishedPeers,
      targetNumberOfActivePeers,
      targetNumberOfKnownBigLedgerPeers,
      targetNumberOfEstablishedBigLedgerPeers,
      targetNumberOfActiveBigLedgerPeers
    }

  shrink :: SmallPeerSelectionTargets -> [SmallPeerSelectionTargets]
shrink (SmallTargets (PeerSelectionTargets Int
r Int
k Int
e Int
a Int
kb Int
eb Int
ab)) =
    [ PeerSelectionTargets -> SmallPeerSelectionTargets
SmallTargets PeerSelectionTargets
targets'
    | (Int
r',Int
k',Int
e',Int
a',Int
kb',Int
eb',Int
ab') <- (Int, Int, Int, Int, Int, Int, Int)
-> [(Int, Int, Int, Int, Int, Int, Int)]
forall a. Arbitrary a => a -> [a]
shrink (Int
r,Int
k,Int
e,Int
a,Int
kb,Int
eb,Int
ab)
    , let targets' :: PeerSelectionTargets
targets' = Int
-> Int -> Int -> Int -> Int -> Int -> Int -> PeerSelectionTargets
PeerSelectionTargets Int
r' Int
k' Int
e' Int
a' Int
kb' Int
eb' Int
ab'
    , PeerSelectionTargets -> Bool
Governor.sanePeerSelectionTargets PeerSelectionTargets
targets'
    ]


-- | Given a NtNAddr generate the necessary things to run a node in
-- Simulation
genNodeArgs :: [TestnetRelayInfo]
            -> Int
            -> [(HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
            -> TestnetRelayInfo
            -> [Tx Int]
            -> Gen NodeArgs
genNodeArgs :: [TestnetRelayInfo]
-> Int
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> TestnetRelayInfo
-> [Tx Int]
-> Gen NodeArgs
genNodeArgs [TestnetRelayInfo]
relays Int
minConnected [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
localRootPeers TestnetRelayInfo
self [Tx Int]
txs = (Gen NodeArgs -> (NodeArgs -> Bool) -> Gen NodeArgs)
-> (NodeArgs -> Bool) -> Gen NodeArgs -> Gen NodeArgs
forall a b c. (a -> b -> c) -> b -> a -> c
flip Gen NodeArgs -> (NodeArgs -> Bool) -> Gen NodeArgs
forall a. Gen a -> (a -> Bool) -> Gen a
suchThat NodeArgs -> Bool
hasUpstream (Gen NodeArgs -> Gen NodeArgs) -> Gen NodeArgs -> Gen NodeArgs
forall a b. (a -> b) -> a -> b
$ do
  -- Slot length needs to be greater than 0 else we get a livelock on
  -- the IOSim.
  --
  -- Quota values matches mainnet, so a slot length of 1s and 1 / 20
  -- chance that someone gets to make a block
  seed <- Gen Int
forall a. Arbitrary a => Gen a
arbitrary

  -- Generating an InitiatorResponderMode node is 3 times more likely since we
  -- want our tests to cover more this case.
  -- diffusionMode <- frequency [ (1, pure InitiatorOnlyDiffusionMode)
  --                            , (3, pure InitiatorAndResponderDiffusionMode)
  --                            ]
  -- TODO: 'cm & ig enforce timeouts' fails in 'InitiatorOnlyDiffusionMode'
  -- so we pin it to this
  let diffusionMode = DiffusionMode
InitiatorAndResponderDiffusionMode

  -- Make sure our targets for active peers cover the maximum of peers
  -- one generated
  SmallTargets deadlineTargets <- resize (length relays * 2) arbitrary
                                       `suchThat` hasActive
  SmallTargets syncTargets <- resize (length relays * 2) arbitrary
                                       `suchThat` hasActive
  let peerTargets = (PeerSelectionTargets
deadlineTargets, PeerSelectionTargets
syncTargets)
  dnsTimeout <- arbitrary
  dnsLookupDelay <- arbitrary
  chainSyncExitOnBlockNo
    <- frequency [ (1,      Just . fromIntegral . getPositive
                        <$> (arbitrary :: Gen (Positive Int))
                            `suchThat` (\(Positive Int
a) -> Int
a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
5))
                 , (4, pure Nothing)
                 ]

  chainSyncEarlyExit <- frequency [ (1, pure True)
                                  , (9, pure False)
                                  ]

  peerSharing <- arbitrary

  let ledgerPeersRelays, publicRootsRelays :: [TestnetRelayInfo]
      (ledgerPeersRelays, publicRootsRelays) =
        splitAt (length relays `div` 2) relays
      publicRoots :: Map RelayAccessPoint PeerAdvertise
      publicRoots =
        [(RelayAccessPoint, PeerAdvertise)]
-> Map RelayAccessPoint PeerAdvertise
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Domain -> LedgerRelayAccessPoint -> RelayAccessPoint
prefixLedgerRelayAccessPoint Domain
cardanoSRVPrefix LedgerRelayAccessPoint
relayAccessPoint, PeerAdvertise
advertise)
                     | TestnetRelayInfo
pubRelay <- [TestnetRelayInfo]
publicRootsRelays
                     , TestnetRelayInfo
pubRelay TestnetRelayInfo -> TestnetRelayInfo -> Bool
forall a. Eq a => a -> a -> Bool
/= TestnetRelayInfo
self
                     , let (LedgerRelayAccessPoint
relayAccessPoint, IP
_, PortNumber
_, PeerAdvertise
advertise) = TestnetRelayInfo
pubRelay
                     ]

  ledgerPeers :: [[NonEmpty LedgerRelayAccessPoint]]
     <- listOf1 (listOf1 (sublistOf1 (NonEmpty.fromList $ makeRelayAccessPoint <$> ledgerPeersRelays)))
  ledgerPeersScript_ <- traverse genLedgerPoolsFrom ledgerPeers
  let ledgerPeersScript = NonEmpty LedgerPools -> Script LedgerPools
forall a. NonEmpty a -> Script a
Script ([LedgerPools] -> NonEmpty LedgerPools
forall a. HasCallStack => [a] -> NonEmpty a
NonEmpty.fromList [LedgerPools]
ledgerPeersScript_)

  fetchModeScript <- fmap (PraosFetchMode . bool FetchModeBulkSync FetchModeDeadline) <$> arbitrary

  naConsensusMode <- arbitrary
  bootstrapPeersDomain <-
    case naConsensusMode of
      ConsensusMode
GenesisMode -> Script UseBootstrapPeers -> Gen (Script UseBootstrapPeers)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Script UseBootstrapPeers -> Gen (Script UseBootstrapPeers))
-> (UseBootstrapPeers -> Script UseBootstrapPeers)
-> UseBootstrapPeers
-> Gen (Script UseBootstrapPeers)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UseBootstrapPeers -> Script UseBootstrapPeers
forall a. a -> Script a
singletonScript (UseBootstrapPeers -> Gen (Script UseBootstrapPeers))
-> UseBootstrapPeers -> Gen (Script UseBootstrapPeers)
forall a b. (a -> b) -> a -> b
$ UseBootstrapPeers
DontUseBootstrapPeers
      ConsensusMode
PraosMode   -> NonEmpty UseBootstrapPeers -> Script UseBootstrapPeers
forall a. NonEmpty a -> Script a
Script (NonEmpty UseBootstrapPeers -> Script UseBootstrapPeers)
-> ([UseBootstrapPeers] -> NonEmpty UseBootstrapPeers)
-> [UseBootstrapPeers]
-> Script UseBootstrapPeers
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UseBootstrapPeers] -> NonEmpty UseBootstrapPeers
forall a. HasCallStack => [a] -> NonEmpty a
NonEmpty.fromList ([UseBootstrapPeers] -> Script UseBootstrapPeers)
-> Gen [UseBootstrapPeers] -> Gen (Script UseBootstrapPeers)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen UseBootstrapPeers -> Gen [UseBootstrapPeers]
forall a. Gen a -> Gen [a]
listOf1 Gen UseBootstrapPeers
forall a. Arbitrary a => Gen a
arbitrary

  return
   $ NodeArgs
      { naSeed                   = seed
      , naDiffusionMode          = diffusionMode
      , naPublicRoots            = publicRoots
        -- TODO: we haven't been using public root peers so far because we set
        -- `UseLedgerPeers 0`!
      , naConsensusMode
      , naBootstrapPeers         = bootstrapPeersDomain
      , naAddr                   = TestAddress ((\(LedgerRelayAccessPoint
_, IP
ip, PortNumber
port, PeerAdvertise
_) -> IP -> PortNumber -> NtNAddr_
IPAddr IP
ip PortNumber
port) self)
      , naLocalRootPeers         = localRootPeers
      , naLedgerPeers            = ledgerPeersScript
      , naPeerTargets            = peerTargets
      , naDNSTimeoutScript       = dnsTimeout
      , naDNSLookupDelayScript   = dnsLookupDelay
      , naChainSyncExitOnBlockNo = chainSyncExitOnBlockNo
      , naChainSyncEarlyExit     = chainSyncEarlyExit
      , naPeerSharing            = peerSharing
      , naFetchModeScript        = fetchModeScript
      , naTxs                    = txs
      }
  where
    makeRelayAccessPoint :: (a, b, c, d) -> a
makeRelayAccessPoint (a
relay, b
_, c
_, d
_) = a
relay

    hasActive :: SmallPeerSelectionTargets -> Bool
    hasActive :: SmallPeerSelectionTargets -> Bool
hasActive (SmallTargets (PeerSelectionTargets {
                 targetNumberOfActivePeers :: PeerSelectionTargets -> Int
targetNumberOfActivePeers = Int
y,
                 targetNumberOfActiveBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfActiveBigLedgerPeers = Int
z
               })) =
      Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
z Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
minConnected

    hasUpstream :: NodeArgs -> Bool
    hasUpstream :: NodeArgs -> Bool
hasUpstream NodeArgs { NtNAddr
naAddr :: NodeArgs -> NtNAddr
naAddr :: NtNAddr
naAddr, Map RelayAccessPoint PeerAdvertise
naPublicRoots :: NodeArgs -> Map RelayAccessPoint PeerAdvertise
naPublicRoots :: Map RelayAccessPoint PeerAdvertise
naPublicRoots, [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
naLocalRootPeers :: NodeArgs
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
naLocalRootPeers :: [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
naLocalRootPeers } =
         Bool -> Bool
not (Map RelayAccessPoint PeerAdvertise -> Bool
forall k a. Map k a -> Bool
Map.null (Map RelayAccessPoint PeerAdvertise -> Bool)
-> Map RelayAccessPoint PeerAdvertise -> Bool
forall a b. (a -> b) -> a -> b
$ Map RelayAccessPoint PeerAdvertise
naPublicRoots
                         Map RelayAccessPoint PeerAdvertise
-> Set RelayAccessPoint -> Map RelayAccessPoint PeerAdvertise
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.withoutKeys`
                         [RelayAccessPoint] -> Set RelayAccessPoint
forall a. Ord a => [a] -> Set a
Set.fromList (Maybe RelayAccessPoint -> [RelayAccessPoint]
forall a. Maybe a -> [a]
maybeToList (NtNAddr -> Maybe RelayAccessPoint
Node.ntnAddrToRelayAccessPoint NtNAddr
naAddr)))
      Bool -> Bool -> Bool
|| (Bool -> Bool) -> [Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Bool -> Bool
forall a. a -> a
id [ Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Bool -> Bool
not (Map RelayAccessPoint (LocalRootConfig PeerTrustable) -> Bool
forall k a. Map k a -> Bool
Map.null Map RelayAccessPoint (LocalRootConfig PeerTrustable)
m)
                | (HotValency Int
v, WarmValency
_, Map RelayAccessPoint (LocalRootConfig PeerTrustable)
m) <- [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
naLocalRootPeers
                ]

--
-- DomainMapScript
--

-- 'DomainMapScript' describes evolution of domain name resolution.
--
type DomainMapScript = TimedScript MockDNSMap


-- | Make sure that the final domain map can resolve all the domains correctly.
--
fixupDomainMapScript :: MockDNSMap -> DomainMapScript -> DomainMapScript
fixupDomainMapScript :: MockDNSMap -> DomainMapScript -> DomainMapScript
fixupDomainMapScript MockDNSMap
mockMap (Script (a :: (MockDNSMap, ScriptDelay)
a@(MockDNSMap
_, ScriptDelay
delay) :| [(MockDNSMap, ScriptDelay)]
as)) =
    case [(MockDNSMap, ScriptDelay)] -> [(MockDNSMap, ScriptDelay)]
forall a. [a] -> [a]
reverse [(MockDNSMap, ScriptDelay)]
as of
      []                  -> NonEmpty (MockDNSMap, ScriptDelay) -> DomainMapScript
forall a. NonEmpty a -> Script a
Script (NonEmpty (MockDNSMap, ScriptDelay) -> DomainMapScript)
-> NonEmpty (MockDNSMap, ScriptDelay) -> DomainMapScript
forall a b. (a -> b) -> a -> b
$ (MockDNSMap
mockMap, ScriptDelay
delay) (MockDNSMap, ScriptDelay)
-> [(MockDNSMap, ScriptDelay)]
-> NonEmpty (MockDNSMap, ScriptDelay)
forall a. a -> [a] -> NonEmpty a
:| [(MockDNSMap, ScriptDelay)]
as
      ((MockDNSMap
_, ScriptDelay
delay') : [(MockDNSMap, ScriptDelay)]
as') -> NonEmpty (MockDNSMap, ScriptDelay) -> DomainMapScript
forall a. NonEmpty a -> Script a
Script (NonEmpty (MockDNSMap, ScriptDelay) -> DomainMapScript)
-> NonEmpty (MockDNSMap, ScriptDelay) -> DomainMapScript
forall a b. (a -> b) -> a -> b
$ (MockDNSMap, ScriptDelay)
a (MockDNSMap, ScriptDelay)
-> [(MockDNSMap, ScriptDelay)]
-> NonEmpty (MockDNSMap, ScriptDelay)
forall a. a -> [a] -> NonEmpty a
:| [(MockDNSMap, ScriptDelay)] -> [(MockDNSMap, ScriptDelay)]
forall a. [a] -> [a]
reverse ((MockDNSMap
mockMap, ScriptDelay
delay') (MockDNSMap, ScriptDelay)
-> [(MockDNSMap, ScriptDelay)] -> [(MockDNSMap, ScriptDelay)]
forall a. a -> [a] -> [a]
: [(MockDNSMap, ScriptDelay)]
as')

-- | Generate a `DomainMapScript`.  Each step contains modification of the full
-- dns map with at most 20% entries removed and 20% entries modified.  The last
-- scripted value is the full dns map which ensures that eventually all dns
-- names resolve to correct ip addresses.
--
genDomainMapScript :: TestnetRelayInfos -> Gen DomainMapScript
genDomainMapScript :: TestnetRelayInfos -> Gen DomainMapScript
genDomainMapScript TestnetRelayInfos
relays = do
  mockMap <- Gen MockDNSMap
dnsMapGen
  fixupDomainMapScript mockMap <$>
    arbitraryScriptOf 10 ((,) <$> alterDomainMap mockMap <*> arbitrary)
  where
    dnsType :: TYPE
dnsType = case TestnetRelayInfos
relays of
      TestnetRelays4 {} -> TYPE
DNS.A
      TestnetRelays6 {} -> TYPE
DNS.AAAA

    alterDomainMap :: MockDNSMap -> Gen MockDNSMap
alterDomainMap MockDNSMap
mockMap = do
      let dnsAssoc :: [((Domain, TYPE),
  Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
dnsAssoc = MockDNSMap
-> [((Domain, TYPE),
     Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
forall k a. Map k a -> [(k, a)]
Map.toList MockDNSMap
mockMap
      rm <- [(Domain, TYPE)] -> Gen [(Domain, TYPE)]
forall a. [a] -> Gen [a]
removedDomains (((Domain, TYPE),
 Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
-> (Domain, TYPE)
forall a b. (a, b) -> a
fst (((Domain, TYPE),
  Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
 -> (Domain, TYPE))
-> [((Domain, TYPE),
     Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
-> [(Domain, TYPE)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [((Domain, TYPE),
  Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
dnsAssoc)
      md <- modifiedDomains dnsAssoc
      return $ Map.fromList md `Map.union` foldr Map.delete mockMap rm

    removedDomains :: [b] -> Gen [b]
removedDomains [b]
domains = do
        as <- Int -> Gen [Bool]
tosses ([b] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
domains)
        return $ map fst . filter snd $ zip domains as

    modifiedDomains :: [((Domain, TYPE),
  Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
-> Gen
     [((Domain, TYPE),
       Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
modifiedDomains [((Domain, TYPE),
  Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
assoc = do
        mask' <- Int -> Gen [Bool]
tosses ([((Domain, TYPE),
  Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [((Domain, TYPE),
  Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
assoc)
        let picked = ((((Domain, TYPE),
   Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]),
  Bool)
 -> ((Domain, TYPE),
     Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]))
-> [(((Domain, TYPE),
      Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]),
     Bool)]
-> [((Domain, TYPE),
     Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
forall a b. (a -> b) -> [a] -> [b]
map (((Domain, TYPE),
  Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]),
 Bool)
-> ((Domain, TYPE),
    Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
forall a b. (a, b) -> a
fst ([(((Domain, TYPE),
    Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]),
   Bool)]
 -> [((Domain, TYPE),
      Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])])
-> ([(((Domain, TYPE),
       Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]),
      Bool)]
    -> [(((Domain, TYPE),
          Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]),
         Bool)])
-> [(((Domain, TYPE),
      Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]),
     Bool)]
-> [((Domain, TYPE),
     Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((((Domain, TYPE),
   Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]),
  Bool)
 -> Bool)
-> [(((Domain, TYPE),
      Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]),
     Bool)]
-> [(((Domain, TYPE),
      Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]),
     Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (((Domain, TYPE),
  Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]),
 Bool)
-> Bool
forall a b. (a, b) -> b
snd ([(((Domain, TYPE),
    Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]),
   Bool)]
 -> [((Domain, TYPE),
      Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])])
-> [(((Domain, TYPE),
      Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]),
     Bool)]
-> [((Domain, TYPE),
     Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
forall a b. (a -> b) -> a -> b
$ [((Domain, TYPE),
  Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
-> [Bool]
-> [(((Domain, TYPE),
      Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]),
     Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [((Domain, TYPE),
  Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
assoc [Bool]
mask'
            singleton a
x = [a
x]
        forM picked \((Domain, TYPE)
k, Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
v) ->
          case Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
v of
            Left [(IP, TTL)]
_ipsttls -> case TestnetRelayInfos
relays of
              TestnetRelays4 {} ->
                ((Domain, TYPE)
k,) (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
 -> ((Domain, TYPE),
     Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]))
-> (IP
    -> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
-> IP
-> ((Domain, TYPE),
    Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(IP, TTL)]
-> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
forall a b. a -> Either a b
Left ([(IP, TTL)]
 -> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
-> (IP -> [(IP, TTL)])
-> IP
-> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IP, TTL) -> [(IP, TTL)]
forall {a}. a -> [a]
singleton ((IP, TTL) -> [(IP, TTL)])
-> (IP -> (IP, TTL)) -> IP -> [(IP, TTL)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, TTL
ttl) (IP
 -> ((Domain, TYPE),
     Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]))
-> Gen IP
-> Gen
     ((Domain, TYPE),
      Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen IP
PeerSelection.genIPv4
              TestnetRelays6 {} ->
                ((Domain, TYPE)
k,) (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
 -> ((Domain, TYPE),
     Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]))
-> (IP
    -> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
-> IP
-> ((Domain, TYPE),
    Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(IP, TTL)]
-> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
forall a b. a -> Either a b
Left ([(IP, TTL)]
 -> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
-> (IP -> [(IP, TTL)])
-> IP
-> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IP, TTL) -> [(IP, TTL)]
forall {a}. a -> [a]
singleton ((IP, TTL) -> [(IP, TTL)])
-> (IP -> (IP, TTL)) -> IP -> [(IP, TTL)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (, TTL
ttl) (IP
 -> ((Domain, TYPE),
     Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]))
-> Gen IP
-> Gen
     ((Domain, TYPE),
      Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen IP
PeerSelection.genIPv6
            Right [(Domain, Word16, Word16, PortNumber)]
doms -> do
              ((Domain, TYPE)
k,) (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
 -> ((Domain, TYPE),
     Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]))
-> ((Domain, Word16, Word16, PortNumber)
    -> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
-> (Domain, Word16, Word16, PortNumber)
-> ((Domain, TYPE),
    Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Domain, Word16, Word16, PortNumber)]
-> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
forall a b. b -> Either a b
Right ([(Domain, Word16, Word16, PortNumber)]
 -> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
-> ((Domain, Word16, Word16, PortNumber)
    -> [(Domain, Word16, Word16, PortNumber)])
-> (Domain, Word16, Word16, PortNumber)
-> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Domain, Word16, Word16, PortNumber)
-> [(Domain, Word16, Word16, PortNumber)]
forall {a}. a -> [a]
singleton ((Domain, Word16, Word16, PortNumber)
 -> ((Domain, TYPE),
     Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]))
-> Gen (Domain, Word16, Word16, PortNumber)
-> Gen
     ((Domain, TYPE),
      Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                case [(Domain, Word16, Word16, PortNumber)]
-> Maybe (Domain, Word16, Word16, PortNumber)
forall a. [a] -> Maybe a
listToMaybe [(Domain, Word16, Word16, PortNumber)]
doms of
                  Just (Domain
_, Word16
prio, Word16
wt, PortNumber
port) -> (, Word16
prio, Word16
wt, PortNumber
port) (Domain -> (Domain, Word16, Word16, PortNumber))
-> Gen Domain -> Gen (Domain, Word16, Word16, PortNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Domain
genDomainName
                  Maybe (Domain, Word16, Word16, PortNumber)
Nothing -> [Char] -> Gen (Domain, Word16, Word16, PortNumber)
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible!"

    tosses :: Int -> Gen [Bool]
tosses Int
count = Int -> Gen Bool -> Gen [Bool]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
count ([(Int, Gen Bool)] -> Gen Bool
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [(Int
4, Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True), (Int
1, Bool -> Gen Bool
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)])

    dnsMapGen :: Gen MockDNSMap
    dnsMapGen :: Gen MockDNSMap
dnsMapGen = do
      let srvs, nonsrvs :: [(RelayAccessPoint, IP, PortNumber, PeerAdvertise)]
          ([(RelayAccessPoint, IP, PortNumber, PeerAdvertise)]
srvs, [(RelayAccessPoint, IP, PortNumber, PeerAdvertise)]
nonsrvs) = ((RelayAccessPoint, IP, PortNumber, PeerAdvertise) -> Bool)
-> [(RelayAccessPoint, IP, PortNumber, PeerAdvertise)]
-> ([(RelayAccessPoint, IP, PortNumber, PeerAdvertise)],
    [(RelayAccessPoint, IP, PortNumber, PeerAdvertise)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (RelayAccessPoint, IP, PortNumber, PeerAdvertise) -> Bool
forall {b} {c} {d}. (RelayAccessPoint, b, c, d) -> Bool
isSRV
                            -- we need to add the `_cardano._tcp` prefix
                          ([(RelayAccessPoint, IP, PortNumber, PeerAdvertise)]
 -> ([(RelayAccessPoint, IP, PortNumber, PeerAdvertise)],
     [(RelayAccessPoint, IP, PortNumber, PeerAdvertise)]))
-> (TestnetRelayInfos
    -> [(RelayAccessPoint, IP, PortNumber, PeerAdvertise)])
-> TestnetRelayInfos
-> ([(RelayAccessPoint, IP, PortNumber, PeerAdvertise)],
    [(RelayAccessPoint, IP, PortNumber, PeerAdvertise)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestnetRelayInfo
 -> (RelayAccessPoint, IP, PortNumber, PeerAdvertise))
-> [TestnetRelayInfo]
-> [(RelayAccessPoint, IP, PortNumber, PeerAdvertise)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(LedgerRelayAccessPoint
lrap, IP
ip, PortNumber
port, PeerAdvertise
adv) ->
                                   ( Domain -> LedgerRelayAccessPoint -> RelayAccessPoint
prefixLedgerRelayAccessPoint Domain
cardanoSRVPrefix LedgerRelayAccessPoint
lrap
                                   , IP
ip
                                   , PortNumber
port
                                   , PeerAdvertise
adv
                                   ))
                          ([TestnetRelayInfo]
 -> [(RelayAccessPoint, IP, PortNumber, PeerAdvertise)])
-> (TestnetRelayInfos -> [TestnetRelayInfo])
-> TestnetRelayInfos
-> [(RelayAccessPoint, IP, PortNumber, PeerAdvertise)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestnetRelayInfos -> [TestnetRelayInfo]
unTestnetRelays
                          (TestnetRelayInfos
 -> ([(RelayAccessPoint, IP, PortNumber, PeerAdvertise)],
     [(RelayAccessPoint, IP, PortNumber, PeerAdvertise)]))
-> TestnetRelayInfos
-> ([(RelayAccessPoint, IP, PortNumber, PeerAdvertise)],
    [(RelayAccessPoint, IP, PortNumber, PeerAdvertise)])
forall a b. (a -> b) -> a -> b
$ TestnetRelayInfos
relays
          srvs' :: [(Int, Domain, IP, PortNumber)]
srvs' =
                  [(Int
k, Domain
d, IP
ip, PortNumber
port)
                  | ((RelayAccessPoint, IP, PortNumber, PeerAdvertise)
relay, Int
k) <- [(RelayAccessPoint, IP, PortNumber, PeerAdvertise)]
-> [Int]
-> [((RelayAccessPoint, IP, PortNumber, PeerAdvertise), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(RelayAccessPoint, IP, PortNumber, PeerAdvertise)]
srvs [Int
0..]
                  , let (RelayAccessSRVDomain Domain
d, IP
ip, PortNumber
port, PeerAdvertise
_) = (RelayAccessPoint, IP, PortNumber, PeerAdvertise)
relay]
      srvMap <- (MockDNSMap -> (Int, Domain, IP, PortNumber) -> Gen MockDNSMap)
-> MockDNSMap -> [(Int, Domain, IP, PortNumber)] -> Gen MockDNSMap
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM MockDNSMap -> (Int, Domain, IP, PortNumber) -> Gen MockDNSMap
stepSRV MockDNSMap
forall k a. Map k a
Map.empty [(Int, Domain, IP, PortNumber)]
srvs'
      let nonSRVMap = (MockDNSMap
 -> (RelayAccessPoint, IP, PortNumber, PeerAdvertise) -> MockDNSMap)
-> MockDNSMap
-> [(RelayAccessPoint, IP, PortNumber, PeerAdvertise)]
-> MockDNSMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl MockDNSMap
-> (RelayAccessPoint, IP, PortNumber, PeerAdvertise) -> MockDNSMap
stepNonSRV MockDNSMap
forall k a. Map k a
Map.empty [(RelayAccessPoint, IP, PortNumber, PeerAdvertise)]
nonsrvs
      return $ Map.union srvMap nonSRVMap

    isSRV :: (RelayAccessPoint, b, c, d) -> Bool
isSRV = \case
      (RelayAccessSRVDomain {}, b
_, c
_, d
_) -> Bool
True
      (RelayAccessPoint, b, c, d)
_otherwise -> Bool
False

    stepSRV :: MockDNSMap -> (Int, Domain, IP, PortNumber) -> Gen MockDNSMap
stepSRV MockDNSMap
m (Int
k, Domain
d, IP
ip, PortNumber
port) = do
      i <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
1, Int
5)
      subordinates <- zipWith addTag [0 :: Int ..] <$> vectorOf i genDomainName
      (_, subs) <- head' <$> PeerSelection.genGroupSrvs [(d, subordinates)]
      let fixupPort = ((Domain, Word16, Word16, PortNumber)
 -> (Domain, Word16, Word16, PortNumber))
-> [(Domain, Word16, Word16, PortNumber)]
-> [(Domain, Word16, Word16, PortNumber)]
forall a b. (a -> b) -> [a] -> [b]
map (Domain, Word16, Word16, PortNumber)
-> (Domain, Word16, Word16, PortNumber)
relayPort [(Domain, Word16, Word16, PortNumber)]
subs
          lookupSequence =
            [((Domain, TYPE),
  Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
-> MockDNSMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([((Domain, TYPE),
   Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
 -> MockDNSMap)
-> [((Domain, TYPE),
     Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
-> MockDNSMap
forall a b. (a -> b) -> a -> b
$
              ((Domain
d, TYPE
DNS.SRV), [(Domain, Word16, Word16, PortNumber)]
-> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
forall a b. b -> Either a b
Right [(Domain, Word16, Word16, PortNumber)]
fixupPort)
              ((Domain, TYPE),
 Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
-> [((Domain, TYPE),
     Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
-> [((Domain, TYPE),
     Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])]
forall a. a -> [a] -> [a]
: [((Domain
sub, TYPE
dnsType), [(IP, TTL)]
-> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
forall a b. a -> Either a b
Left [(IP
ip, TTL
ttl)])
                | (Domain
sub, Word16
_, Word16
_, PortNumber
_) <- [(Domain, Word16, Word16, PortNumber)]
subs]
      return $ Map.union lookupSequence m

      where
        head' :: [a] -> a
head' (a
x : [a]
_xs) = a
x
        head' []        = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible!"
        relayPort :: (Domain, Word16, Word16, PortNumber)
-> (Domain, Word16, Word16, PortNumber)
relayPort (Domain
a, Word16
b, Word16
c', PortNumber
_d) = (Domain
a, Word16
b, Word16
c', PortNumber
port)
        c :: Int -> Domain
c = [Char] -> Domain
BSC.pack ([Char] -> Domain) -> (Int -> [Char]) -> Int -> Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show
        addTag :: Int -> Domain -> Domain
addTag Int
i Domain
dom = Domain
dom Domain -> Domain -> Domain
forall a. Semigroup a => a -> a -> a
<> Domain
"_" Domain -> Domain -> Domain
forall a. Semigroup a => a -> a -> a
<> Int -> Domain
c Int
k Domain -> Domain -> Domain
forall a. Semigroup a => a -> a -> a
<> Domain
"_" Domain -> Domain -> Domain
forall a. Semigroup a => a -> a -> a
<> Int -> Domain
c Int
i


    stepNonSRV :: MockDNSMap
-> (RelayAccessPoint, IP, PortNumber, PeerAdvertise) -> MockDNSMap
stepNonSRV MockDNSMap
b (RelayAccessPoint
relay, IP
ip, PortNumber
_port, PeerAdvertise
_advAndTrust) = do
      case RelayAccessPoint
relay of
        RelayAccessAddress {}  -> MockDNSMap
b
        RelayAccessDomain Domain
d PortNumber
_p -> (Maybe (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
 -> Maybe
      (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]))
-> (Domain, TYPE) -> MockDNSMap -> MockDNSMap
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
-> Maybe
     (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
fa (Domain
d, TYPE
dnsType) MockDNSMap
b
        RelayAccessSRVDomain Domain
_ -> [Char] -> MockDNSMap
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible!"
      where
        fa :: Maybe (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
-> Maybe
     (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
fa Maybe (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
Nothing               = Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
-> Maybe
     (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
forall a. a -> Maybe a
Just (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
 -> Maybe
      (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]))
-> ([(IP, TTL)]
    -> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
-> [(IP, TTL)]
-> Maybe
     (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(IP, TTL)]
-> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
forall a b. a -> Either a b
Left ([(IP, TTL)]
 -> Maybe
      (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]))
-> [(IP, TTL)]
-> Maybe
     (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
forall a b. (a -> b) -> a -> b
$ [(IP
ip, TTL
ttl)]
        fa (Just (Left [(IP, TTL)]
ipsttls)) = Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
-> Maybe
     (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
forall a. a -> Maybe a
Just (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
 -> Maybe
      (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]))
-> ([(IP, TTL)]
    -> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
-> [(IP, TTL)]
-> Maybe
     (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(IP, TTL)]
-> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
forall a b. a -> Either a b
Left ([(IP, TTL)]
 -> Maybe
      (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]))
-> [(IP, TTL)]
-> Maybe
     (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
forall a b. (a -> b) -> a -> b
$ (IP
ip, TTL
ttl) (IP, TTL) -> [(IP, TTL)] -> [(IP, TTL)]
forall a. a -> [a] -> [a]
: [(IP, TTL)]
ipsttls
        fa Maybe (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
_                     = [Char]
-> Maybe
     (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible!"

    ttl :: TTL
ttl = TTL
300

--
-- DiffusionScript
--

-- | Multinode Diffusion Simulator Script
--
-- 'SimArgs' with all the values needed for running the simulation, followed
-- by a list of 'NodeArgs' where each element represents one running node and
-- respective 'Command's.
--
data DiffusionScript = DiffusionScript
                         SimArgs
                         DomainMapScript
                         [(NodeArgs, [Command])]

instance Show DiffusionScript where
    show :: DiffusionScript -> [Char]
show (DiffusionScript SimArgs
args DomainMapScript
dnsScript [(NodeArgs, [Command])]
nodes) =
      [Char]
"DiffusionScript (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SimArgs -> [Char]
forall a. Show a => a -> [Char]
show SimArgs
args [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DomainMapScript -> [Char]
forall a. Show a => a -> [Char]
show DomainMapScript
dnsScript [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [(NodeArgs, [Command])] -> [Char]
forall a. Show a => a -> [Char]
show [(NodeArgs, [Command])]
nodes

genDiffusionScript :: (   [TestnetRelayInfo]
                       -> TestnetRelayInfo
                       -> Gen [( HotValency
                                , WarmValency
                                , Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
                   -> TestnetRelayInfos
                   -> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genDiffusionScript :: ([TestnetRelayInfo]
 -> TestnetRelayInfo
 -> Gen
      [(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> TestnetRelayInfos
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genDiffusionScript [TestnetRelayInfo]
-> TestnetRelayInfo
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
genLocalRootPeers
                   TestnetRelayInfos
relays
                   = do
    ArbTxDecisionPolicy txDecisionPolicy <- Gen ArbTxDecisionPolicy
forall a. Arbitrary a => Gen a
arbitrary
    let simArgs = Int -> TxDecisionPolicy -> SimArgs
mainnetSimArgs ([TestnetRelayInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestnetRelayInfo]
relays') TxDecisionPolicy
txDecisionPolicy
    dnsMapScript <- genDomainMapScript relays
    txs <- makeUniqueIds 0
       <$> vectorOf (length relays') (choose (10, 100) >>= \Int
c -> Int -> Gen (Tx Int) -> Gen [Tx Int]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
c Gen (Tx Int)
forall a. Arbitrary a => Gen a
arbitrary)
    nodesWithCommands <- mapM go (zip relays' txs)
    return (simArgs, dnsMapScript, nodesWithCommands)
  where
    relays' :: [TestnetRelayInfo]
relays' = TestnetRelayInfos -> [TestnetRelayInfo]
unTestnetRelays TestnetRelayInfos
relays

    makeUniqueIds :: Int -> [[Tx Int]] -> [[Tx Int]]
    makeUniqueIds :: Int -> [[Tx Int]] -> [[Tx Int]]
makeUniqueIds Int
_ [] = []
    makeUniqueIds Int
i ([Tx Int]
l:[[Tx Int]]
ls) =
      let ([Tx Int]
r, Int
i') = [Tx Int] -> Int -> ([Tx Int], Int)
makeUniqueIds' [Tx Int]
l Int
i
       in [Tx Int]
r [Tx Int] -> [[Tx Int]] -> [[Tx Int]]
forall a. a -> [a] -> [a]
: Int -> [[Tx Int]] -> [[Tx Int]]
makeUniqueIds Int
i' [[Tx Int]]
ls

    makeUniqueIds' :: [Tx Int] -> Int -> ([Tx Int], Int)
    makeUniqueIds' :: [Tx Int] -> Int -> ([Tx Int], Int)
makeUniqueIds' [Tx Int]
l Int
i = ( ((Tx Int, Int) -> Tx Int) -> [(Tx Int, Int)] -> [Tx Int]
forall a b. (a -> b) -> [a] -> [b]
map (\(Tx Int
tx, Int
x) -> Tx Int
tx {getTxId = x}) ([Tx Int] -> [Int] -> [(Tx Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Tx Int]
l [Int
i..])
                         , Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Tx Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Tx Int]
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                         )

    go :: (TestnetRelayInfo, [Tx Int]) -> Gen (NodeArgs, [Command])
    go :: (TestnetRelayInfo, [Tx Int]) -> Gen (NodeArgs, [Command])
go (TestnetRelayInfo
relay, [Tx Int]
txs) = do
      let otherRelays :: [TestnetRelayInfo]
otherRelays  = TestnetRelayInfo
relay TestnetRelayInfo -> [TestnetRelayInfo] -> [TestnetRelayInfo]
forall a. Eq a => a -> [a] -> [a]
`delete` [TestnetRelayInfo]
relays'
          minConnected :: Int
minConnected = Int
3 Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` ([TestnetRelayInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestnetRelayInfo]
relays' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) -- ^ TODO is this ever different from 3?
                                                      -- since we generate {2,3} relays?
      localRts <- [TestnetRelayInfo]
-> TestnetRelayInfo
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
genLocalRootPeers [TestnetRelayInfo]
otherRelays TestnetRelayInfo
relay
      nodeArgs <- genNodeArgs relays' minConnected localRts relay txs
      commands <- genCommands localRts
      return (nodeArgs, commands)


-- | Multinode Diffusion Simulator Script
--
-- Tries to generate a reasonable looking network with at most 3 nodes that can
-- or can not be connected to one another. These nodes can also randomly die or
-- have their local configuration changed.
--
genNonHotDiffusionScript :: TestnetRelayInfos
                         -> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genNonHotDiffusionScript :: TestnetRelayInfos
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genNonHotDiffusionScript = ([TestnetRelayInfo]
 -> TestnetRelayInfo
 -> Gen
      [(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> TestnetRelayInfos
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genDiffusionScript [TestnetRelayInfo]
-> TestnetRelayInfo
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
genLocalRootPeers
  where
    -- | Generate Local Root Peers
    --
    genLocalRootPeers :: [TestnetRelayInfo]
                      -> TestnetRelayInfo
                      -> Gen [( HotValency
                              , WarmValency
                              , Map RelayAccessPoint (LocalRootConfig PeerTrustable)
                              )]
    genLocalRootPeers :: [TestnetRelayInfo]
-> TestnetRelayInfo
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
genLocalRootPeers [TestnetRelayInfo]
others TestnetRelayInfo
_self = (Gen
   [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
 -> ([(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
     -> Bool)
 -> Gen
      [(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> ([(HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
    -> Bool)
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Gen
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> ([(HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
    -> Bool)
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
forall a. Gen a -> (a -> Bool) -> Gen a
suchThat [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> Bool
hasUpstream (Gen
   [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
 -> Gen
      [(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
forall a b. (a -> b) -> a -> b
$ do
      nrGroups <- (Int, Int) -> Gen Int
chooseInt (Int
1, Int
3)
      -- Remove self from local root peers
      let size = [TestnetRelayInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestnetRelayInfo]
others
          sizePerGroup = (Int
size Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
nrGroups) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

      localRootConfigs <- vectorOf size arbitrary
      let relaysAdv = (TestnetRelayInfo
 -> LocalRootConfig PeerTrustable
 -> (LedgerRelayAccessPoint, LocalRootConfig PeerTrustable))
-> [TestnetRelayInfo]
-> [LocalRootConfig PeerTrustable]
-> [(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(LedgerRelayAccessPoint
lrap, IP
_ip, PortNumber
_port, PeerAdvertise
_advertise) LocalRootConfig PeerTrustable
lrc ->
                                (LedgerRelayAccessPoint
lrap, LocalRootConfig PeerTrustable
lrc))
                              [TestnetRelayInfo]
others
                              [LocalRootConfig PeerTrustable]
localRootConfigs
          relayGroups :: [[(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]]
          relayGroups = Int
-> [(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
-> [[(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]]
forall a. Int -> [a] -> [[a]]
divvy Int
sizePerGroup [(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
relaysAdv
          relayGroupsMap =  [(RelayAccessPoint, LocalRootConfig PeerTrustable)]
-> Map RelayAccessPoint (LocalRootConfig PeerTrustable)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                            -- add cardano prefix
                         ([(RelayAccessPoint, LocalRootConfig PeerTrustable)]
 -> Map RelayAccessPoint (LocalRootConfig PeerTrustable))
-> ([(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
    -> [(RelayAccessPoint, LocalRootConfig PeerTrustable)])
-> [(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
-> Map RelayAccessPoint (LocalRootConfig PeerTrustable)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  ((LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)
 -> (RelayAccessPoint, LocalRootConfig PeerTrustable))
-> [(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
-> [(RelayAccessPoint, LocalRootConfig PeerTrustable)]
forall a b. (a -> b) -> [a] -> [b]
map ((LedgerRelayAccessPoint -> RelayAccessPoint)
-> (LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)
-> (RelayAccessPoint, LocalRootConfig PeerTrustable)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Domain -> LedgerRelayAccessPoint -> RelayAccessPoint
prefixLedgerRelayAccessPoint Domain
cardanoSRVPrefix))
                        ([(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
 -> Map RelayAccessPoint (LocalRootConfig PeerTrustable))
-> [[(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]]
-> [Map RelayAccessPoint (LocalRootConfig PeerTrustable)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]]
relayGroups

      target <- forM relayGroups
                    (\[(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
x -> if [(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
x
                           then (HotValency, WarmValency) -> Gen (HotValency, WarmValency)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HotValency
0, WarmValency
0)
                           else Int -> Gen (HotValency, WarmValency)
genTargets ([(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
x))

      let lrpGroups = ((HotValency, WarmValency)
 -> Map RelayAccessPoint (LocalRootConfig PeerTrustable)
 -> (HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable)))
-> [(HotValency, WarmValency)]
-> [Map RelayAccessPoint (LocalRootConfig PeerTrustable)]
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(HotValency
h, WarmValency
w) Map RelayAccessPoint (LocalRootConfig PeerTrustable)
g -> (HotValency
h, WarmValency
w, Map RelayAccessPoint (LocalRootConfig PeerTrustable)
g))
                              [(HotValency, WarmValency)]
target
                              [Map RelayAccessPoint (LocalRootConfig PeerTrustable)]
relayGroupsMap

      return lrpGroups

    genTargets :: Int -> Gen (HotValency, WarmValency)
    genTargets :: Int -> Gen (HotValency, WarmValency)
genTargets Int
l = do
      warmValency <- Int -> WarmValency
WarmValency (Int -> WarmValency) -> Gen Int -> Gen WarmValency
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
forall a. Enum a => (a, a) -> Gen a
chooseEnum (Int
1, Int
l)
      hotValency <- HotValency <$> chooseEnum (1, getWarmValency warmValency)
      return (hotValency, warmValency)

    hasUpstream :: [( HotValency
                    , WarmValency
                    , Map RelayAccessPoint (LocalRootConfig PeerTrustable)
                    )]
                -> Bool
    hasUpstream :: [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> Bool
hasUpstream [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
localRootPeers =
      [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Bool -> Bool
not (Map RelayAccessPoint (LocalRootConfig PeerTrustable) -> Bool
forall k a. Map k a -> Bool
Map.null Map RelayAccessPoint (LocalRootConfig PeerTrustable)
m)
         | (HotValency Int
v, WarmValency
_, Map RelayAccessPoint (LocalRootConfig PeerTrustable)
m) <- [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
localRootPeers
         ]

-- | there's some duplication of information, but saves some silly pattern
-- matches where we don't care about the particular value of RelayAccessPoint
--
type TestnetRelayInfo = (LedgerRelayAccessPoint, IP, PortNumber, PeerAdvertise)
data TestnetRelayInfos = TestnetRelays4 { TestnetRelayInfos -> [TestnetRelayInfo]
unTestnetRelays :: [TestnetRelayInfo] }
                       | TestnetRelays6 { unTestnetRelays :: [TestnetRelayInfo] }

instance Arbitrary TestnetRelayInfos where
  arbitrary :: Gen TestnetRelayInfos
arbitrary = [Gen TestnetRelayInfos] -> Gen TestnetRelayInfos
forall a. HasCallStack => [Gen a] -> Gen a
oneof [ [TestnetRelayInfo] -> TestnetRelayInfos
TestnetRelays4 ([TestnetRelayInfo] -> TestnetRelayInfos)
-> Gen [TestnetRelayInfo] -> Gen TestnetRelayInfos
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen IP -> Gen [TestnetRelayInfo]
forall {a}.
Arbitrary a =>
Gen IP -> Gen [(LedgerRelayAccessPoint, IP, PortNumber, a)]
gen Gen IP
PeerSelection.genIPv4
                    , [TestnetRelayInfo] -> TestnetRelayInfos
TestnetRelays6 ([TestnetRelayInfo] -> TestnetRelayInfos)
-> Gen [TestnetRelayInfo] -> Gen TestnetRelayInfos
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen IP -> Gen [TestnetRelayInfo]
forall {a}.
Arbitrary a =>
Gen IP -> Gen [(LedgerRelayAccessPoint, IP, PortNumber, a)]
gen Gen IP
PeerSelection.genIPv6
                    ]
    where
      uniqueIps :: [(a, b, a, d)] -> Bool
uniqueIps [(a, b, a, d)]
xs =
        let ips :: [a]
ips = (\(a
_, b
_, a
c, d
_) -> a
c) ((a, b, a, d) -> a) -> [(a, b, a, d)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, b, a, d)]
xs
        in [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> [a]
forall a. Eq a => [a] -> [a]
nub [a]
ips) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ips

      gen :: Gen IP -> Gen [(LedgerRelayAccessPoint, IP, PortNumber, a)]
gen Gen IP
genIP = do
        i <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
2,Int
3)
        (vectorOf i arbitrary >>= traverse (uncurry $ extractOrGen genIP)) `suchThat` uniqueIps

      extractOrGen :: Gen IP
-> t
-> LedgerRelayAccessPoint
-> Gen (LedgerRelayAccessPoint, IP, PortNumber, t)
extractOrGen Gen IP
genIP t
peerAdvertise = \case
        raa :: LedgerRelayAccessPoint
raa@(LedgerRelayAccessAddress IP
ip PortNumber
port) -> (LedgerRelayAccessPoint, IP, PortNumber, t)
-> Gen (LedgerRelayAccessPoint, IP, PortNumber, t)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LedgerRelayAccessPoint
raa, IP
ip, PortNumber
port, t
peerAdvertise)
        rad :: LedgerRelayAccessPoint
rad@(LedgerRelayAccessDomain Domain
_d PortNumber
port) -> (LedgerRelayAccessPoint
rad,, PortNumber
port, t
peerAdvertise) (IP -> (LedgerRelayAccessPoint, IP, PortNumber, t))
-> Gen IP -> Gen (LedgerRelayAccessPoint, IP, PortNumber, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen IP
genIP
        ras :: LedgerRelayAccessPoint
ras@(LedgerRelayAccessSRVDomain Domain
_d) -> (LedgerRelayAccessPoint
ras,,, t
peerAdvertise) (IP -> PortNumber -> (LedgerRelayAccessPoint, IP, PortNumber, t))
-> Gen IP
-> Gen (PortNumber -> (LedgerRelayAccessPoint, IP, PortNumber, t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen IP
genIP Gen (PortNumber -> (LedgerRelayAccessPoint, IP, PortNumber, t))
-> Gen PortNumber
-> Gen (LedgerRelayAccessPoint, IP, PortNumber, t)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen PortNumber
forall a. Arbitrary a => Gen a
arbitrary

  shrink :: TestnetRelayInfos -> [TestnetRelayInfos]
shrink = \case
    TestnetRelays4 [TestnetRelayInfo]
infos -> [TestnetRelayInfo] -> TestnetRelayInfos
TestnetRelays4 ([TestnetRelayInfo] -> TestnetRelayInfos)
-> [[TestnetRelayInfo]] -> [TestnetRelayInfos]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TestnetRelayInfo] -> [[TestnetRelayInfo]]
forall {a}. [a] -> [[a]]
go [TestnetRelayInfo]
infos
    TestnetRelays6 [TestnetRelayInfo]
infos -> [TestnetRelayInfo] -> TestnetRelayInfos
TestnetRelays6 ([TestnetRelayInfo] -> TestnetRelayInfos)
-> [[TestnetRelayInfo]] -> [TestnetRelayInfos]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TestnetRelayInfo] -> [[TestnetRelayInfo]]
forall {a}. [a] -> [[a]]
go [TestnetRelayInfo]
infos
    where
      go :: [a] -> [[a]]
go [a]
infos = [[a]
candidate
                 | [a]
candidate <- (a -> [a]) -> [a] -> [[a]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([a] -> a -> [a]
forall a b. a -> b -> a
const []) [a]
infos
                 , [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
candidate Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
                 ]

-- | Multinode Hot Diffusion Simulator Script
--
-- Tries to generate a network with at most 2 nodes that should
-- be connected to one another. This generator tries to obtain high ratios of
-- active peers so we can test the miniprotocols that run when we have such
-- active connections. These nodes can not randomly die or have their local
-- configuration changed. Their local root peers consist of a single group.
--
genHotDiffusionScript :: TestnetRelayInfos
                      -> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genHotDiffusionScript :: TestnetRelayInfos
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genHotDiffusionScript = ([TestnetRelayInfo]
 -> TestnetRelayInfo
 -> Gen
      [(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> TestnetRelayInfos
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genDiffusionScript [TestnetRelayInfo]
-> TestnetRelayInfo
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
genLocalRootPeers
    where
      -- | Generate Local Root Peers.  This only generates 1 group
      --
      genLocalRootPeers :: [TestnetRelayInfo]
                        -> TestnetRelayInfo
                        -> Gen [( HotValency
                                , WarmValency
                                , Map RelayAccessPoint (LocalRootConfig PeerTrustable)
                                )]
      genLocalRootPeers :: [TestnetRelayInfo]
-> TestnetRelayInfo
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
genLocalRootPeers [TestnetRelayInfo]
others TestnetRelayInfo
_self = (Gen
   [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
 -> ([(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
     -> Bool)
 -> Gen
      [(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> ([(HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
    -> Bool)
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Gen
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> ([(HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
    -> Bool)
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
forall a. Gen a -> (a -> Bool) -> Gen a
suchThat [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> Bool
hasUpstream (Gen
   [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
 -> Gen
      [(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
forall a b. (a -> b) -> a -> b
$ do
        localRootConfigs <- Int
-> Gen (LocalRootConfig PeerTrustable)
-> Gen [LocalRootConfig PeerTrustable]
forall a. Int -> Gen a -> Gen [a]
vectorOf ([TestnetRelayInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TestnetRelayInfo]
others) Gen (LocalRootConfig PeerTrustable)
forall a. Arbitrary a => Gen a
arbitrary
        let relaysAdv = (TestnetRelayInfo
 -> LocalRootConfig PeerTrustable
 -> (LedgerRelayAccessPoint, LocalRootConfig PeerTrustable))
-> [TestnetRelayInfo]
-> [LocalRootConfig PeerTrustable]
-> [(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(LedgerRelayAccessPoint
lrap, IP
_ip, PortNumber
_port, PeerAdvertise
_advertise) LocalRootConfig PeerTrustable
lrc ->
                                  (LedgerRelayAccessPoint
lrap, LocalRootConfig PeerTrustable
lrc))
                              [TestnetRelayInfo]
others
                              [LocalRootConfig PeerTrustable]
localRootConfigs
            relayGroupsMap = [(RelayAccessPoint, LocalRootConfig PeerTrustable)]
-> Map RelayAccessPoint (LocalRootConfig PeerTrustable)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                           ([(RelayAccessPoint, LocalRootConfig PeerTrustable)]
 -> Map RelayAccessPoint (LocalRootConfig PeerTrustable))
-> ([(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
    -> [(RelayAccessPoint, LocalRootConfig PeerTrustable)])
-> [(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
-> Map RelayAccessPoint (LocalRootConfig PeerTrustable)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)
 -> (RelayAccessPoint, LocalRootConfig PeerTrustable))
-> [(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
-> [(RelayAccessPoint, LocalRootConfig PeerTrustable)]
forall a b. (a -> b) -> [a] -> [b]
map ((LedgerRelayAccessPoint -> RelayAccessPoint)
-> (LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)
-> (RelayAccessPoint, LocalRootConfig PeerTrustable)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Domain -> LedgerRelayAccessPoint -> RelayAccessPoint
prefixLedgerRelayAccessPoint Domain
cardanoSRVPrefix))
                           ([(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
 -> Map RelayAccessPoint (LocalRootConfig PeerTrustable))
-> [(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
-> Map RelayAccessPoint (LocalRootConfig PeerTrustable)
forall a b. (a -> b) -> a -> b
$ [(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
relaysAdv
            warmTarget     = [(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(LedgerRelayAccessPoint, LocalRootConfig PeerTrustable)]
relaysAdv

        hotTarget <- choose (0 , warmTarget)

        return [( HotValency hotTarget
                , WarmValency warmTarget
                , relayGroupsMap
                )]

      hasUpstream :: [( HotValency
                      , WarmValency
                      , Map RelayAccessPoint (LocalRootConfig PeerTrustable)
                      )]
                  -> Bool
      hasUpstream :: [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> Bool
hasUpstream [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
localRootPeers =
        [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Bool -> Bool
not (Map RelayAccessPoint (LocalRootConfig PeerTrustable) -> Bool
forall k a. Map k a -> Bool
Map.null Map RelayAccessPoint (LocalRootConfig PeerTrustable)
m)
           | (HotValency Int
v, WarmValency
_, Map RelayAccessPoint (LocalRootConfig PeerTrustable)
m) <- [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
localRootPeers
           ]


instance Arbitrary DiffusionScript where
  arbitrary :: Gen DiffusionScript
arbitrary = (\(SimArgs
a,DomainMapScript
b,[(NodeArgs, [Command])]
c) -> SimArgs
-> DomainMapScript -> [(NodeArgs, [Command])] -> DiffusionScript
DiffusionScript SimArgs
a DomainMapScript
b [(NodeArgs, [Command])]
c)
              ((SimArgs, DomainMapScript, [(NodeArgs, [Command])])
 -> DiffusionScript)
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
-> Gen DiffusionScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Int, Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])]))]
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [ (Int
1, Gen TestnetRelayInfos
forall a. Arbitrary a => Gen a
arbitrary Gen TestnetRelayInfos
-> (TestnetRelayInfos
    -> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])]))
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TestnetRelayInfos
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genNonHotDiffusionScript)
                            , (Int
1, Gen TestnetRelayInfos
forall a. Arbitrary a => Gen a
arbitrary Gen TestnetRelayInfos
-> (TestnetRelayInfos
    -> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])]))
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TestnetRelayInfos
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genHotDiffusionScript)]
  -- TODO: shrink dns map
  shrink :: DiffusionScript -> [DiffusionScript]
shrink (DiffusionScript SimArgs
sargs DomainMapScript
dnsScript0 [(NodeArgs, [Command])]
players0) =
    [SimArgs
-> DomainMapScript -> [(NodeArgs, [Command])] -> DiffusionScript
DiffusionScript SimArgs
sargs DomainMapScript
dnsScript0 [(NodeArgs, [Command])]
players
    | [(NodeArgs, [Command])]
players <- [(NodeArgs, [Command])] -> [[(NodeArgs, [Command])]]
forall {t}. [(t, [Command])] -> [[(t, [Command])]]
shrinkPlayers [(NodeArgs, [Command])]
players0
    ] [DiffusionScript] -> [DiffusionScript] -> [DiffusionScript]
forall a. Semigroup a => a -> a -> a
<>
    [SimArgs
-> DomainMapScript -> [(NodeArgs, [Command])] -> DiffusionScript
DiffusionScript SimArgs
sargs DomainMapScript
dnsScript [(NodeArgs, [Command])]
players0
    | DomainMapScript
dnsScript <-
        (DomainMapScript -> Maybe DomainMapScript)
-> [DomainMapScript] -> [DomainMapScript]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
          -- make sure `fixupDomainMapScript` didn't return something that's
          -- equal to the original `script`
          ((\DomainMapScript
dnsScript' -> if DomainMapScript
dnsScript0 DomainMapScript -> DomainMapScript -> Bool
forall a. Eq a => a -> a -> Bool
== DomainMapScript
dnsScript' then Maybe DomainMapScript
forall a. Maybe a
Nothing else DomainMapScript -> Maybe DomainMapScript
forall a. a -> Maybe a
Just DomainMapScript
dnsScript')
           (DomainMapScript -> Maybe DomainMapScript)
-> (DomainMapScript -> DomainMapScript)
-> DomainMapScript
-> Maybe DomainMapScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  MockDNSMap -> DomainMapScript -> DomainMapScript
fixupDomainMapScript (DomainMapScript -> MockDNSMap
forall {a} {b}. Script (a, b) -> a
getLast DomainMapScript
dnsScript0))
          ([DomainMapScript] -> [DomainMapScript])
-> [DomainMapScript] -> [DomainMapScript]
forall a b. (a -> b) -> a -> b
$ ((MockDNSMap, ScriptDelay) -> [(MockDNSMap, ScriptDelay)])
-> DomainMapScript -> [DomainMapScript]
forall a. (a -> [a]) -> Script a -> [Script a]
shrinkScriptWith ((MockDNSMap -> [MockDNSMap])
-> (ScriptDelay -> [ScriptDelay])
-> (MockDNSMap, ScriptDelay)
-> [(MockDNSMap, ScriptDelay)]
forall a b. (a -> [a]) -> (b -> [b]) -> (a, b) -> [(a, b)]
forall (f :: * -> * -> *) a b.
Arbitrary2 f =>
(a -> [a]) -> (b -> [b]) -> f a b -> [f a b]
liftShrink2 MockDNSMap -> [MockDNSMap]
forall a b. Ord a => Map a b -> [Map a b]
shrinkMap_ ScriptDelay -> [ScriptDelay]
forall a. Arbitrary a => a -> [a]
shrink) DomainMapScript
dnsScript0
    ]
    where
      getLast :: Script (a, b) -> a
getLast (Script NonEmpty (a, b)
ne) = (a, b) -> a
forall a b. (a, b) -> a
fst ((a, b) -> a) -> (a, b) -> a
forall a b. (a -> b) -> a -> b
$ NonEmpty (a, b) -> (a, b)
forall a. NonEmpty a -> a
NonEmpty.last NonEmpty (a, b)
ne

      shrinkMap_ :: Ord a => Map a b -> [Map a b]
      shrinkMap_ :: forall a b. Ord a => Map a b -> [Map a b]
shrinkMap_ = ([(a, b)] -> Map a b) -> [[(a, b)]] -> [Map a b]
forall a b. (a -> b) -> [a] -> [b]
map [(a, b)] -> Map a b
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([[(a, b)]] -> [Map a b])
-> (Map a b -> [[(a, b)]]) -> Map a b -> [Map a b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> [(a, b)]) -> [(a, b)] -> [[(a, b)]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([(a, b)] -> (a, b) -> [(a, b)]
forall a b. a -> b -> a
const []) ([(a, b)] -> [[(a, b)]])
-> (Map a b -> [(a, b)]) -> Map a b -> [[(a, b)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map a b -> [(a, b)]
forall k a. Map k a -> [(k, a)]
Map.toList

      -- the easiest failure to analyze is the one with the least number of nodes participating.
      -- Currently we use up to three nodes, but in case we increase the number in the future
      -- this will be even more useful.
      shrinkPlayers :: [(t, [Command])] -> [[(t, [Command])]]
shrinkPlayers =
        ([(t, [Command])] -> Bool)
-> [[(t, [Command])]] -> [[(t, [Command])]]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Int -> Bool)
-> ([(t, [Command])] -> Int) -> [(t, [Command])] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(t, [Command])] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) ([[(t, [Command])]] -> [[(t, [Command])]])
-> ([(t, [Command])] -> [[(t, [Command])]])
-> [(t, [Command])]
-> [[(t, [Command])]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((t, [Command]) -> [(t, [Command])])
-> [(t, [Command])] -> [[(t, [Command])]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (t, [Command]) -> [(t, [Command])]
forall {t}. (t, [Command]) -> [(t, [Command])]
shrinkPlayer

      shrinkPlayer :: (t, [Command]) -> [(t, [Command])]
shrinkPlayer (t
nargs, [Command]
cmds) =
        ([Command] -> (t, [Command])) -> [[Command]] -> [(t, [Command])]
forall a b. (a -> b) -> [a] -> [b]
map (t
nargs,) ([[Command]] -> [(t, [Command])])
-> ([[Command]] -> [[Command]]) -> [[Command]] -> [(t, [Command])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Command] -> Bool) -> [[Command]] -> [[Command]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Command] -> [Command] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Command]
cmds) ([[Command]] -> [(t, [Command])])
-> [[Command]] -> [(t, [Command])]
forall a b. (a -> b) -> a -> b
$ [Command] -> [Command]
fixupCommands ([Command] -> [Command]) -> [[Command]] -> [[Command]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Command -> [Command]) -> [Command] -> [[Command]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList Command -> [Command]
shrinkCommand [Command]
cmds
        where
          shrinkDelay :: DiffTime -> [DiffTime]
shrinkDelay = (Rational -> DiffTime) -> [Rational] -> [DiffTime]
forall a b. (a -> b) -> [a] -> [b]
map Rational -> DiffTime
forall a. Fractional a => Rational -> a
fromRational ([Rational] -> [DiffTime])
-> (DiffTime -> [Rational]) -> DiffTime -> [DiffTime]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> [Rational]
forall a. Arbitrary a => a -> [a]
shrink (Rational -> [Rational])
-> (DiffTime -> Rational) -> DiffTime -> [Rational]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> Rational
forall a. Real a => a -> Rational
toRational

          -- A failing network with the least nodes active at a particular time is the simplest to analyze,
          -- if for no other reason other than for having the least amount of traces for us to read.
          -- A dead node is its simplest configuration as that can't contribute to its failure,
          -- So we shrink to that first to see at least if a failure occurs somewhere else still.
          -- Otherwise we know that this node has to be running for sure while the exchange is happening.
          shrinkCommand :: Command -> [Command]
          shrinkCommand :: Command -> [Command]
shrinkCommand (JoinNetwork DiffTime
d)     = DiffTime -> Command
JoinNetwork (DiffTime -> Command) -> [DiffTime] -> [Command]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DiffTime -> [DiffTime]
shrinkDelay DiffTime
d
          shrinkCommand (Kill DiffTime
d)            = DiffTime -> Command
Kill (DiffTime -> Command) -> [DiffTime] -> [Command]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DiffTime -> [DiffTime]
shrinkDelay DiffTime
d
          shrinkCommand (Reconfigure DiffTime
d [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
lrp) =   DiffTime -> Command
Skip DiffTime
d
                                              Command -> [Command] -> [Command]
forall a. a -> [a] -> [a]
: (DiffTime
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> Command
Reconfigure (DiffTime
 -> [(HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
 -> Command)
-> [DiffTime]
-> [[(HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
    -> Command]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DiffTime -> [DiffTime]
shrinkDelay DiffTime
d
                                                             [[(HotValency, WarmValency,
   Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
 -> Command]
-> [[(HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig PeerTrustable))]]
-> [Command]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> [[(HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig PeerTrustable))]]
forall {a}. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
lrp)
          shrinkCommand (Skip DiffTime
_d)           = []


-- | Multinode Hot Diffusion Simulator Script
--
-- List of 'SimArgs'. Each element of the list represents one running node.
--
data HotDiffusionScript = HotDiffusionScript
                            SimArgs
                            DomainMapScript
                            [(NodeArgs, [Command])]
  deriving Int -> HotDiffusionScript -> [Char] -> [Char]
[HotDiffusionScript] -> [Char] -> [Char]
HotDiffusionScript -> [Char]
(Int -> HotDiffusionScript -> [Char] -> [Char])
-> (HotDiffusionScript -> [Char])
-> ([HotDiffusionScript] -> [Char] -> [Char])
-> Show HotDiffusionScript
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> HotDiffusionScript -> [Char] -> [Char]
showsPrec :: Int -> HotDiffusionScript -> [Char] -> [Char]
$cshow :: HotDiffusionScript -> [Char]
show :: HotDiffusionScript -> [Char]
$cshowList :: [HotDiffusionScript] -> [Char] -> [Char]
showList :: [HotDiffusionScript] -> [Char] -> [Char]
Show

instance Arbitrary HotDiffusionScript where
  arbitrary :: Gen HotDiffusionScript
arbitrary = (\(SimArgs
a,DomainMapScript
b,[(NodeArgs, [Command])]
c) -> SimArgs
-> DomainMapScript -> [(NodeArgs, [Command])] -> HotDiffusionScript
HotDiffusionScript SimArgs
a DomainMapScript
b [(NodeArgs, [Command])]
c) ((SimArgs, DomainMapScript, [(NodeArgs, [Command])])
 -> HotDiffusionScript)
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
-> Gen HotDiffusionScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Gen TestnetRelayInfos
forall a. Arbitrary a => Gen a
arbitrary Gen TestnetRelayInfos
-> (TestnetRelayInfos
    -> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])]))
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TestnetRelayInfos
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genHotDiffusionScript)
  shrink :: HotDiffusionScript -> [HotDiffusionScript]
shrink (HotDiffusionScript SimArgs
sargs DomainMapScript
dnsMap [(NodeArgs, [Command])]
hds) =
    [ SimArgs
-> DomainMapScript -> [(NodeArgs, [Command])] -> HotDiffusionScript
HotDiffusionScript SimArgs
sa DomainMapScript
dnsMap' [(NodeArgs, [Command])]
ds
    | DiffusionScript SimArgs
sa DomainMapScript
dnsMap' [(NodeArgs, [Command])]
ds <- DiffusionScript -> [DiffusionScript]
forall a. Arbitrary a => a -> [a]
shrink (SimArgs
-> DomainMapScript -> [(NodeArgs, [Command])] -> DiffusionScript
DiffusionScript SimArgs
sargs DomainMapScript
dnsMap [(NodeArgs, [Command])]
hds) ]

-- Tests if the fixupCommand is idempotent.
-- Note that the generator for DiffusionScript already fixups the Command list.
--
prop_diffusionScript_fixupCommands :: DiffusionScript -> Property
prop_diffusionScript_fixupCommands :: DiffusionScript -> Property
prop_diffusionScript_fixupCommands (DiffusionScript SimArgs
_ DomainMapScript
_ []) = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
prop_diffusionScript_fixupCommands (DiffusionScript SimArgs
sa DomainMapScript
dnsMap ((NodeArgs
_, [Command]
cmds): [(NodeArgs, [Command])]
t)) =
  [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Failed with cmds: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Command] -> [Char]
forall a. Show a => a -> [Char]
show [Command]
cmds [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"fixupCommands cmds = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Command] -> [Char]
forall a. Show a => a -> [Char]
show ([Command] -> [Command]
fixupCommands [Command]
cmds)
                 ) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
  [Command] -> [Command]
fixupCommands [Command]
cmds [Command] -> [Command] -> Bool
forall a. Eq a => a -> a -> Bool
== [Command]
cmds
  Bool -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. DiffusionScript -> Property
prop_diffusionScript_fixupCommands (SimArgs
-> DomainMapScript -> [(NodeArgs, [Command])] -> DiffusionScript
DiffusionScript SimArgs
sa DomainMapScript
dnsMap [(NodeArgs, [Command])]
t)

-- Tests if the fixupCommand outputs valid command scripts.
--
-- Note that the generator for DiffusionScript already fixups the Command list.
--
prop_diffusionScript_commandScript_valid :: DiffusionScript -> Property
prop_diffusionScript_commandScript_valid :: DiffusionScript -> Property
prop_diffusionScript_commandScript_valid (DiffusionScript SimArgs
_ DomainMapScript
_ []) = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
prop_diffusionScript_commandScript_valid (DiffusionScript SimArgs
sa DomainMapScript
dnsMap ((NodeArgs
_, [Command]
cmds): [(NodeArgs, [Command])]
t)) =
  [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Failed with cmds: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Command] -> [Char]
forall a. Show a => a -> [Char]
show [Command]
cmds) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
  [Command] -> Property
isValid [Command]
cmds
  Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. DiffusionScript -> Property
prop_diffusionScript_commandScript_valid (SimArgs
-> DomainMapScript -> [(NodeArgs, [Command])] -> DiffusionScript
DiffusionScript SimArgs
sa DomainMapScript
dnsMap [(NodeArgs, [Command])]
t)
  where
    isValid :: [Command] -> Property
    isValid :: [Command] -> Property
isValid [] = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
    isValid [Command
_] = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
    isValid (Command
x:Command
y:[Command]
xs) =
      case (Command
x, Command
y) of
        (JoinNetwork DiffTime
_, JoinNetwork DiffTime
_)   ->
          [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Invalid sequence: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Command -> [Char]
forall a. Show a => a -> [Char]
show Command
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Command -> [Char]
forall a. Show a => a -> [Char]
show Command
y) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
        (Kill DiffTime
_, Kill DiffTime
_)                 ->
          [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Invalid sequence: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Command -> [Char]
forall a. Show a => a -> [Char]
show Command
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Command -> [Char]
forall a. Show a => a -> [Char]
show Command
y) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
        (Kill DiffTime
_, Reconfigure DiffTime
_ [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
_)        ->
          [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Invalid sequence: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Command -> [Char]
forall a. Show a => a -> [Char]
show Command
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Command -> [Char]
forall a. Show a => a -> [Char]
show Command
y) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
        (Reconfigure DiffTime
_ [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
_, JoinNetwork DiffTime
_) ->
          [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"Invalid sequence: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Command -> [Char]
forall a. Show a => a -> [Char]
show Command
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Command -> [Char]
forall a. Show a => a -> [Char]
show Command
y) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
        (Command, Command)
_                                -> [Command] -> Property
isValid (Command
yCommand -> [Command] -> [Command]
forall a. a -> [a] -> [a]
:[Command]
xs)

-- | Diffusion Simulation Trace so we know what command is concurrently
-- running
--
data DiffusionSimulationTrace
  = TrJoiningNetwork
  | TrKillingNode
  | TrReconfiguringNode
  | TrUpdatingDNS
  | TrRunning
  | TrErrored SomeException
  | TrTerminated
  | TrSay String
  deriving Int -> DiffusionSimulationTrace -> [Char] -> [Char]
[DiffusionSimulationTrace] -> [Char] -> [Char]
DiffusionSimulationTrace -> [Char]
(Int -> DiffusionSimulationTrace -> [Char] -> [Char])
-> (DiffusionSimulationTrace -> [Char])
-> ([DiffusionSimulationTrace] -> [Char] -> [Char])
-> Show DiffusionSimulationTrace
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> DiffusionSimulationTrace -> [Char] -> [Char]
showsPrec :: Int -> DiffusionSimulationTrace -> [Char] -> [Char]
$cshow :: DiffusionSimulationTrace -> [Char]
show :: DiffusionSimulationTrace -> [Char]
$cshowList :: [DiffusionSimulationTrace] -> [Char] -> [Char]
showList :: [DiffusionSimulationTrace] -> [Char] -> [Char]
Show

-- Warning: be careful with writing properties that rely
-- on trace events from multiple components environment.
-- These events typically occur in separate threads and
-- so are not casually ordered. It is ok to use them for
-- timeout/eventually properties, but not for properties
-- that check conditions synchronously.
--
data DiffusionTestTrace =
      DiffusionLocalRootPeerTrace (TraceLocalRootPeers PeerTrustable NtNAddr)
    | DiffusionPublicRootPeerTrace TracePublicRootPeers
    | DiffusionLedgerPeersTrace TraceLedgerPeers
    | DiffusionPeerSelectionTrace (Governor.TracePeerSelection Cardano.ExtraState PeerTrustable (Cardano.ExtraPeers NtNAddr) NtNAddr)
    | DiffusionPeerSelectionActionsTrace (PeerSelectionActionsTrace NtNAddr NtNVersion)
    | DiffusionDebugPeerSelectionTrace (DebugPeerSelection Cardano.ExtraState PeerTrustable (Cardano.ExtraPeers NtNAddr) NtNAddr)
    | DiffusionConnectionManagerTrace
        (CM.Trace NtNAddr
          (ConnectionHandlerTrace NtNVersion NtNVersionData))
    | DiffusionSimulationTrace DiffusionSimulationTrace
    | DiffusionConnectionManagerTransitionTrace
        (AbstractTransitionTrace CM.ConnStateId)
    | DiffusionInboundGovernorTransitionTrace
        (RemoteTransitionTrace NtNAddr)
    | DiffusionInboundGovernorTrace (IG.Trace NtNAddr)
    | DiffusionServerTrace (Server.Trace NtNAddr)
    | DiffusionFetchTrace (TraceFetchClientState BlockHeader)
    | DiffusionChurnModeTrace TraceChurnMode
    | DiffusionTxSubmissionInbound (TraceTxSubmissionInbound Int (Tx Int))
    | DiffusionTxLogic (TraceTxLogic NtNAddr Int (Tx Int))
    | DiffusionDebugTrace String
    | DiffusionDNSTrace DNSTrace
    | DiffusionMuxTrace (Mux.WithBearer (ConnectionId NtNAddr) Mux.Trace)
    deriving Int -> DiffusionTestTrace -> [Char] -> [Char]
[DiffusionTestTrace] -> [Char] -> [Char]
DiffusionTestTrace -> [Char]
(Int -> DiffusionTestTrace -> [Char] -> [Char])
-> (DiffusionTestTrace -> [Char])
-> ([DiffusionTestTrace] -> [Char] -> [Char])
-> Show DiffusionTestTrace
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> DiffusionTestTrace -> [Char] -> [Char]
showsPrec :: Int -> DiffusionTestTrace -> [Char] -> [Char]
$cshow :: DiffusionTestTrace -> [Char]
show :: DiffusionTestTrace -> [Char]
$cshowList :: [DiffusionTestTrace] -> [Char] -> [Char]
showList :: [DiffusionTestTrace] -> [Char] -> [Char]
Show


ppDiffusionTestTrace :: DiffusionTestTrace -> String
ppDiffusionTestTrace :: DiffusionTestTrace -> [Char]
ppDiffusionTestTrace (DiffusionLocalRootPeerTrace TraceLocalRootPeers PeerTrustable NtNAddr
tr)               = TraceLocalRootPeers PeerTrustable NtNAddr -> [Char]
forall a. Show a => a -> [Char]
show TraceLocalRootPeers PeerTrustable NtNAddr
tr
ppDiffusionTestTrace (DiffusionPublicRootPeerTrace TracePublicRootPeers
tr)              = TracePublicRootPeers -> [Char]
forall a. Show a => a -> [Char]
show TracePublicRootPeers
tr
ppDiffusionTestTrace (DiffusionLedgerPeersTrace TraceLedgerPeers
tr)                 = TraceLedgerPeers -> [Char]
forall a. Show a => a -> [Char]
show TraceLedgerPeers
tr
ppDiffusionTestTrace (DiffusionPeerSelectionTrace TracePeerSelection
  ExtraState PeerTrustable (ExtraPeers NtNAddr) NtNAddr
tr)               = TracePeerSelection
  ExtraState PeerTrustable (ExtraPeers NtNAddr) NtNAddr
-> [Char]
forall a. Show a => a -> [Char]
show TracePeerSelection
  ExtraState PeerTrustable (ExtraPeers NtNAddr) NtNAddr
tr
ppDiffusionTestTrace (DiffusionPeerSelectionActionsTrace PeerSelectionActionsTrace NtNAddr NtNVersion
tr)        = PeerSelectionActionsTrace NtNAddr NtNVersion -> [Char]
forall a. Show a => a -> [Char]
show PeerSelectionActionsTrace NtNAddr NtNVersion
tr
ppDiffusionTestTrace (DiffusionDebugPeerSelectionTrace DebugPeerSelection
  ExtraState PeerTrustable (ExtraPeers NtNAddr) NtNAddr
tr)          = DebugPeerSelection
  ExtraState PeerTrustable (ExtraPeers NtNAddr) NtNAddr
-> [Char]
forall a. Show a => a -> [Char]
show DebugPeerSelection
  ExtraState PeerTrustable (ExtraPeers NtNAddr) NtNAddr
tr
ppDiffusionTestTrace (DiffusionConnectionManagerTrace Trace NtNAddr (ConnectionHandlerTrace NtNVersion NtNVersionData)
tr)           = Trace NtNAddr (ConnectionHandlerTrace NtNVersion NtNVersionData)
-> [Char]
forall a. Show a => a -> [Char]
show Trace NtNAddr (ConnectionHandlerTrace NtNVersion NtNVersionData)
tr
ppDiffusionTestTrace (DiffusionSimulationTrace DiffusionSimulationTrace
tr)                  = DiffusionSimulationTrace -> [Char]
forall a. Show a => a -> [Char]
show DiffusionSimulationTrace
tr
ppDiffusionTestTrace (DiffusionConnectionManagerTransitionTrace AbstractTransitionTrace ConnStateId
tr) = AbstractTransitionTrace ConnStateId -> [Char]
forall a. Show a => a -> [Char]
show AbstractTransitionTrace ConnStateId
tr
ppDiffusionTestTrace (DiffusionInboundGovernorTrace Trace NtNAddr
tr)             = Trace NtNAddr -> [Char]
forall a. Show a => a -> [Char]
show Trace NtNAddr
tr
ppDiffusionTestTrace (DiffusionInboundGovernorTransitionTrace RemoteTransitionTrace NtNAddr
tr)   = RemoteTransitionTrace NtNAddr -> [Char]
forall a. Show a => a -> [Char]
show RemoteTransitionTrace NtNAddr
tr
ppDiffusionTestTrace (DiffusionServerTrace Trace NtNAddr
tr)                      = Trace NtNAddr -> [Char]
forall a. Show a => a -> [Char]
show Trace NtNAddr
tr
ppDiffusionTestTrace (DiffusionFetchTrace TraceFetchClientState BlockHeader
tr)                       = TraceFetchClientState BlockHeader -> [Char]
forall a. Show a => a -> [Char]
show TraceFetchClientState BlockHeader
tr
ppDiffusionTestTrace (DiffusionChurnModeTrace TraceChurnMode
tr)                   = TraceChurnMode -> [Char]
forall a. Show a => a -> [Char]
show TraceChurnMode
tr
ppDiffusionTestTrace (DiffusionTxSubmissionInbound TraceTxSubmissionInbound Int (Tx Int)
tr)              = TraceTxSubmissionInbound Int (Tx Int) -> [Char]
forall a. Show a => a -> [Char]
show TraceTxSubmissionInbound Int (Tx Int)
tr
ppDiffusionTestTrace (DiffusionTxLogic TraceTxLogic NtNAddr Int (Tx Int)
tr)                          = TraceTxLogic NtNAddr Int (Tx Int) -> [Char]
forall a. Show a => a -> [Char]
show TraceTxLogic NtNAddr Int (Tx Int)
tr
ppDiffusionTestTrace (DiffusionDebugTrace [Char]
tr)                       =      [Char]
tr
ppDiffusionTestTrace (DiffusionDNSTrace DNSTrace
tr)                         = DNSTrace -> [Char]
forall a. Show a => a -> [Char]
show DNSTrace
tr
ppDiffusionTestTrace (DiffusionMuxTrace WithBearer (ConnectionId NtNAddr) Trace
tr)                         = WithBearer (ConnectionId NtNAddr) Trace -> [Char]
forall a. Show a => a -> [Char]
show WithBearer (ConnectionId NtNAddr) Trace
tr


-- | A debug tracer which embeds events in DiffusionTestTrace.
--
iosimTracer :: forall s.
               Tracer (IOSim s) (WithTime (WithName NtNAddr DiffusionTestTrace))
iosimTracer :: forall s.
Tracer (IOSim s) (WithTime (WithName NtNAddr DiffusionTestTrace))
iosimTracer =
     (WithTime (WithName NtNAddr DiffusionTestTrace) -> IOSim s ())
-> Tracer
     (IOSim s) (WithTime (WithName NtNAddr DiffusionTestTrace))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer WithTime (WithName NtNAddr DiffusionTestTrace) -> IOSim s ()
forall a s. Typeable a => a -> IOSim s ()
traceM
  Tracer (IOSim s) (WithTime (WithName NtNAddr DiffusionTestTrace))
-> Tracer
     (IOSim s) (WithTime (WithName NtNAddr DiffusionTestTrace))
-> Tracer
     (IOSim s) (WithTime (WithName NtNAddr DiffusionTestTrace))
forall a. Semigroup a => a -> a -> a
<> (WithTime (WithName NtNAddr DiffusionTestTrace) -> IOSim s ())
-> Tracer
     (IOSim s) (WithTime (WithName NtNAddr DiffusionTestTrace))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (\WithTime { wtEvent :: forall event. WithTime event -> event
wtEvent = WithName { NtNAddr
wnName :: NtNAddr
wnName :: forall name event. WithName name event -> name
wnName, DiffusionTestTrace
wnEvent :: DiffusionTestTrace
wnEvent :: forall name event. WithName name event -> event
wnEvent } } ->
              -- don't log time, it's in the trace
              [Char] -> IOSim s ()
forall (m :: * -> *). MonadSay m => [Char] -> m ()
say ([Char] -> IOSim s ()) -> [Char] -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ NtNAddr -> [Char]
ppNtNAddr NtNAddr
wnName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" @ " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DiffusionTestTrace -> [Char]
ppDiffusionTestTrace DiffusionTestTrace
wnEvent)

-- | Run an arbitrary topology
diffusionSimulation
  :: forall m. ( Alternative (STM m)
               , MonadAsync       m
               , MonadDelay       m
               , MonadFix         m
               , MonadFork        m
               , MonadSay         m
               , MonadST          m
               , MonadEvaluate    m
               , MonadLabelledSTM m
               , MonadTraceSTM    m
               , MonadMask        m
               , MonadTime        m
               , MonadTimer       m
               , MonadThrow  (STM m)
               , MonadMVar        m
               , forall a. Semigroup a => Semigroup (m a)
               )
  => BearerInfo
  -> DiffusionScript
  -> Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
  -- ^ timed trace of nodes in the system
  -> m Void
diffusionSimulation :: forall (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadFix m,
 MonadFork m, MonadSay m, MonadST m, MonadEvaluate m,
 MonadLabelledSTM m, MonadTraceSTM m, MonadMask m, MonadTime m,
 MonadTimer m, MonadThrow (STM m), MonadMVar m,
 forall a. Semigroup a => Semigroup (m a)) =>
BearerInfo
-> DiffusionScript
-> Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
-> m Void
diffusionSimulation
  BearerInfo
defaultBearerInfo
  (DiffusionScript SimArgs
simArgs DomainMapScript
dnsMapScript [(NodeArgs, [Command])]
nodeArgs)
  Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
nodeTracer = do
    connStateIdSupply <- STM m (ConnStateIdSupply m) -> m (ConnStateIdSupply m)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ConnStateIdSupply m) -> m (ConnStateIdSupply m))
-> STM m (ConnStateIdSupply m) -> m (ConnStateIdSupply m)
forall a b. (a -> b) -> a -> b
$ Proxy m -> STM m (ConnStateIdSupply m)
forall (m :: * -> *).
MonadSTM m =>
Proxy m -> STM m (ConnStateIdSupply m)
CM.newConnStateIdSupply Proxy m
forall {k} (t :: k). Proxy t
Proxy
    -- TODO: we should use `snocket` per node, this will allow us to set up
    -- bearer info per node
    withSnocket netSimTracer defaultBearerInfo Map.empty
      $ \Snocket m (FD m NtNAddr) NtNAddr
ntnSnocket m (ObservableNetworkState NtNAddr)
_ ->
        Tracer
  m (WithAddr (TestAddress Int) (SnocketTrace m (TestAddress Int)))
-> BearerInfo
-> Map (NormalisedId (TestAddress Int)) (Script BearerInfo)
-> (Snocket m (FD m (TestAddress Int)) (TestAddress Int)
    -> m (ObservableNetworkState (TestAddress Int)) -> m Void)
-> m Void
forall (m :: * -> *) peerAddr a.
(Alternative (STM m), MonadDelay m, MonadLabelledSTM m,
 MonadMask m, MonadTimer m, MonadThrow (STM m),
 GlobalAddressScheme peerAddr, Ord peerAddr, Typeable peerAddr,
 Show peerAddr) =>
Tracer
  m
  (WithAddr
     (TestAddress peerAddr) (SnocketTrace m (TestAddress peerAddr)))
-> BearerInfo
-> Map (NormalisedId (TestAddress peerAddr)) (Script BearerInfo)
-> (Snocket m (FD m (TestAddress peerAddr)) (TestAddress peerAddr)
    -> m (ObservableNetworkState (TestAddress peerAddr)) -> m a)
-> m a
withSnocket Tracer
  m (WithAddr (TestAddress Int) (SnocketTrace m (TestAddress Int)))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer BearerInfo
defaultBearerInfo Map (NormalisedId (TestAddress Int)) (Script BearerInfo)
forall k a. Map k a
Map.empty
      ((Snocket m (FD m (TestAddress Int)) (TestAddress Int)
  -> m (ObservableNetworkState (TestAddress Int)) -> m Void)
 -> m Void)
-> (Snocket m (FD m (TestAddress Int)) (TestAddress Int)
    -> m (ObservableNetworkState (TestAddress Int)) -> m Void)
-> m Void
forall a b. (a -> b) -> a -> b
$ \Snocket m (FD m (TestAddress Int)) (TestAddress Int)
ntcSnocket m (ObservableNetworkState (TestAddress Int))
_ -> do
        dnsMapVar <- LazyTVar m MockDNSMap -> StrictTVar m MockDNSMap
forall (m :: * -> *) a. LazyTVar m a -> StrictTVar m a
fromLazyTVar (LazyTVar m MockDNSMap -> StrictTVar m MockDNSMap)
-> m (LazyTVar m MockDNSMap) -> m (StrictTVar m MockDNSMap)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer m MockDNSMap -> DomainMapScript -> m (LazyTVar m MockDNSMap)
forall (m :: * -> *) a.
(MonadAsync m, MonadDelay m) =>
Tracer m a -> TimedScript a -> m (TVar m a)
playTimedScript Tracer m MockDNSMap
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer DomainMapScript
dnsMapScript
        withAsyncAll
          (zipWith
            (\(NodeArgs
args, [Command]
commands) Int
i -> do
              [Char] -> m ()
forall (m :: * -> *). MonadThread m => [Char] -> m ()
labelThisThread ([Char]
"ctrl-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NtNAddr -> [Char]
ppNtNAddr (NodeArgs -> NtNAddr
naAddr NodeArgs
args))
              Snocket m (FD m NtNAddr) NtNAddr
-> Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> StrictTVar m MockDNSMap
-> SimArgs
-> NodeArgs
-> ConnStateIdSupply m
-> Int
-> Maybe
     (Async m Void,
      StrictTVar
        m
        [(HotValency, WarmValency,
          Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> [Command]
-> m Void
runCommand Snocket m (FD m NtNAddr) NtNAddr
ntnSnocket Snocket m (FD m (TestAddress Int)) (TestAddress Int)
ntcSnocket StrictTVar m MockDNSMap
dnsMapVar SimArgs
simArgs NodeArgs
args ConnStateIdSupply m
connStateIdSupply Int
i Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
forall a. Maybe a
Nothing [Command]
commands)
            nodeArgs
            [1..])
          $ \[Async m Void]
nodes -> do
            (_, x) <- [Async m Void] -> m (Async m Void, Void)
forall a. [Async m a] -> m (Async m a, a)
forall (m :: * -> *) a.
MonadAsync m =>
[Async m a] -> m (Async m a, a)
waitAny [Async m Void]
nodes
            return x
  where
    netSimTracer :: Tracer m (WithAddr NtNAddr (SnocketTrace m NtNAddr))
    netSimTracer :: Tracer m (WithAddr NtNAddr (SnocketTrace m NtNAddr))
netSimTracer = (\(WithAddr Maybe NtNAddr
l Maybe NtNAddr
_ SnocketTrace m NtNAddr
a) -> NtNAddr -> [Char] -> WithName NtNAddr [Char]
forall name event. name -> event -> WithName name event
WithName (NtNAddr -> Maybe NtNAddr -> NtNAddr
forall a. a -> Maybe a -> a
fromMaybe (NtNAddr_ -> NtNAddr
forall addr. addr -> TestAddress addr
TestAddress (NtNAddr_ -> NtNAddr) -> NtNAddr_ -> NtNAddr
forall a b. (a -> b) -> a -> b
$ IP -> PortNumber -> NtNAddr_
IPAddr ([Char] -> IP
forall a. Read a => [Char] -> a
read [Char]
"0.0.0.0") PortNumber
0) Maybe NtNAddr
l) (SnocketTrace m NtNAddr -> [Char]
forall a. Show a => a -> [Char]
show SnocketTrace m NtNAddr
a))
       (WithAddr NtNAddr (SnocketTrace m NtNAddr)
 -> WithName NtNAddr [Char])
-> Tracer m (WithName NtNAddr [Char])
-> Tracer m (WithAddr NtNAddr (SnocketTrace m NtNAddr))
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer m (WithTime (WithName NtNAddr [Char]))
-> Tracer m (WithName NtNAddr [Char])
forall (m :: * -> *) a.
MonadMonotonicTime m =>
Tracer m (WithTime a) -> Tracer m a
tracerWithTime Tracer m (WithTime (WithName NtNAddr [Char]))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer

    -- | Runs a single node according to a list of commands.
    runCommand
      :: Snocket m (FD m NtNAddr) NtNAddr
        -- ^ Node to node Snocket
      -> Snocket m (FD m NtCAddr) NtCAddr
        -- ^ Node to client Snocket
      -> StrictTVar m MockDNSMap
        -- ^ Map of domain map TVars to be updated in case a node changes its IP
      -> SimArgs -- ^ Simulation arguments needed in order to run a simulation
      -> NodeArgs -- ^ Simulation arguments needed in order to run a single node
      -> CM.ConnStateIdSupply m
      -> Int
      -> Maybe ( Async m Void
               , StrictTVar m [( HotValency
                               , WarmValency
                               , Map RelayAccessPoint (LocalRootConfig PeerTrustable)
                               )])
         -- ^ If the node is running and corresponding local root configuration
         -- TVar.
      -> [Command] -- ^ List of commands/actions to perform for a single node
      -> m Void
    runCommand :: Snocket m (FD m NtNAddr) NtNAddr
-> Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> StrictTVar m MockDNSMap
-> SimArgs
-> NodeArgs
-> ConnStateIdSupply m
-> Int
-> Maybe
     (Async m Void,
      StrictTVar
        m
        [(HotValency, WarmValency,
          Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> [Command]
-> m Void
runCommand Snocket m (FD m NtNAddr) NtNAddr
ntnSocket Snocket m (FD m (TestAddress Int)) (TestAddress Int)
ntcSocket StrictTVar m MockDNSMap
dnsMapVar SimArgs
sArgs nArgs :: NodeArgs
nArgs@NodeArgs { NtNAddr
naAddr :: NodeArgs -> NtNAddr
naAddr :: NtNAddr
naAddr }
               ConnStateIdSupply m
connStateIdSupply Int
i Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
hostAndLRP [Command]
cmds = do
      Tracer m DiffusionSimulationTrace
-> DiffusionSimulationTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (NtNAddr -> Tracer m DiffusionSimulationTrace
diffSimTracer NtNAddr
naAddr) (DiffusionSimulationTrace -> m ())
-> ([Char] -> DiffusionSimulationTrace) -> [Char] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> DiffusionSimulationTrace
TrSay ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"node-" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i
      Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> [Command] -> m Void
runCommand' Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
hostAndLRP [Command]
cmds
      where
        runCommand' :: Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> [Command] -> m Void
runCommand' Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
Nothing [] = do
          DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
3600
          Tracer m DiffusionSimulationTrace
-> DiffusionSimulationTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (NtNAddr -> Tracer m DiffusionSimulationTrace
diffSimTracer NtNAddr
naAddr) DiffusionSimulationTrace
TrRunning
          Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> [Command] -> m Void
runCommand' Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
forall a. Maybe a
Nothing []
        runCommand' (Just (Async m Void
_, StrictTVar
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
_)) [] = do
          -- We shouldn't block this thread waiting
          -- on the async since this will lead to a deadlock
          -- as thread returns 'Void'.
          DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
3600
          Tracer m DiffusionSimulationTrace
-> DiffusionSimulationTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (NtNAddr -> Tracer m DiffusionSimulationTrace
diffSimTracer NtNAddr
naAddr) DiffusionSimulationTrace
TrRunning
          Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> [Command] -> m Void
runCommand' Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
forall a. Maybe a
Nothing []
        runCommand' Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
Nothing
                   (JoinNetwork DiffTime
delay :[Command]
cs) = do
          DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
delay
          Tracer m DiffusionSimulationTrace
-> DiffusionSimulationTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (NtNAddr -> Tracer m DiffusionSimulationTrace
diffSimTracer NtNAddr
naAddr) DiffusionSimulationTrace
TrJoiningNetwork
          lrpVar <- [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> m (StrictTVar
        m
        [(HotValency, WarmValency,
          Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO ([(HotValency, WarmValency,
   Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
 -> m (StrictTVar
         m
         [(HotValency, WarmValency,
           Map RelayAccessPoint (LocalRootConfig PeerTrustable))]))
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> m (StrictTVar
        m
        [(HotValency, WarmValency,
          Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
forall a b. (a -> b) -> a -> b
$ NodeArgs
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
naLocalRootPeers NodeArgs
nArgs
          withAsync (runNode sArgs nArgs ntnSocket ntcSocket connStateIdSupply lrpVar dnsMapVar i) $ \Async m Void
nodeAsync ->
            Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> [Command] -> m Void
runCommand' ((Async m Void,
 StrictTVar
   m
   [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> Maybe
     (Async m Void,
      StrictTVar
        m
        [(HotValency, WarmValency,
          Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
forall a. a -> Maybe a
Just (Async m Void
nodeAsync, StrictTVar
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
lrpVar)) [Command]
cs
        runCommand' Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
_ (JoinNetwork DiffTime
_:[Command]
_) =
          [Char] -> m Void
forall a. HasCallStack => [Char] -> a
error [Char]
"runCommand: Impossible happened"
        runCommand' (Just (Async m Void
async_, StrictTVar
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
_))
                    (Kill DiffTime
delay:[Command]
cs) = do
          DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
delay
          Tracer m DiffusionSimulationTrace
-> DiffusionSimulationTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (NtNAddr -> Tracer m DiffusionSimulationTrace
diffSimTracer NtNAddr
naAddr) DiffusionSimulationTrace
TrKillingNode
          Async m Void -> m ()
forall a. Async m a -> m ()
forall (m :: * -> *) a. MonadAsync m => Async m a -> m ()
cancel Async m Void
async_
          Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> [Command] -> m Void
runCommand' Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
forall a. Maybe a
Nothing [Command]
cs
        runCommand' Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
_ (Kill DiffTime
_:[Command]
_) = do
          [Char] -> m Void
forall a. HasCallStack => [Char] -> a
error [Char]
"runCommand: Impossible happened"
        runCommand' Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
Nothing (Reconfigure DiffTime
_ [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
_:[Command]
_) =
          [Char] -> m Void
forall a. HasCallStack => [Char] -> a
error [Char]
"runCommand: Impossible happened"
        runCommand' (Just (Async m Void
async_, StrictTVar
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
lrpVar))
                    (Reconfigure DiffTime
delay [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
newLrp:[Command]
cs) = do
          DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
delay
          Tracer m DiffusionSimulationTrace
-> DiffusionSimulationTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (NtNAddr -> Tracer m DiffusionSimulationTrace
diffSimTracer NtNAddr
naAddr) DiffusionSimulationTrace
TrReconfiguringNode
          _ <- STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
lrpVar [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
newLrp
          runCommand' (Just (async_, lrpVar))
                     cs
        runCommand' Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
_ (Skip DiffTime
_ : [Command]
_) =
          [Char] -> m Void
forall a. HasCallStack => [Char] -> a
error [Char]
"runCommand: Impossible happened"

    runNode :: SimArgs
            -> NodeArgs
            -> Snocket m (FD m NtNAddr) NtNAddr
            -> Snocket m (FD m NtCAddr) NtCAddr
            -> CM.ConnStateIdSupply m
            -> StrictTVar m [( HotValency
                             , WarmValency
                             , Map RelayAccessPoint (LocalRootConfig PeerTrustable)
                             )]
            -> StrictTVar m MockDNSMap
            -> Int
            -> m Void
    runNode :: SimArgs
-> NodeArgs
-> Snocket m (FD m NtNAddr) NtNAddr
-> Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> ConnStateIdSupply m
-> StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> StrictTVar m MockDNSMap
-> Int
-> m Void
runNode SimArgs
            { saSlot :: SimArgs -> DiffTime
saSlot                  = DiffTime
bgaSlotDuration
            , saQuota :: SimArgs -> Int
saQuota                 = Int
quota
            , saTxDecisionPolicy :: SimArgs -> TxDecisionPolicy
saTxDecisionPolicy      = TxDecisionPolicy
txDecisionPolicy
            }
            NodeArgs
            { naSeed :: NodeArgs -> Int
naSeed                   = Int
seed
            , naPublicRoots :: NodeArgs -> Map RelayAccessPoint PeerAdvertise
naPublicRoots            = Map RelayAccessPoint PeerAdvertise
publicRoots
            , naConsensusMode :: NodeArgs -> ConsensusMode
naConsensusMode          = ConsensusMode
consensusMode
            , naBootstrapPeers :: NodeArgs -> Script UseBootstrapPeers
naBootstrapPeers         = Script UseBootstrapPeers
bootstrapPeers
            , naAddr :: NodeArgs -> NtNAddr
naAddr                   = NtNAddr
addr
            , naLedgerPeers :: NodeArgs -> Script LedgerPools
naLedgerPeers            = Script LedgerPools
ledgerPeers
            , naPeerTargets :: NodeArgs -> (PeerSelectionTargets, PeerSelectionTargets)
naPeerTargets            = (PeerSelectionTargets, PeerSelectionTargets)
peerTargets
            , naDNSTimeoutScript :: NodeArgs -> Script DNSTimeout
naDNSTimeoutScript       = Script DNSTimeout
dnsTimeout
            , naDNSLookupDelayScript :: NodeArgs -> Script DNSLookupDelay
naDNSLookupDelayScript   = Script DNSLookupDelay
dnsLookupDelay
            , naChainSyncExitOnBlockNo :: NodeArgs -> Maybe BlockNo
naChainSyncExitOnBlockNo = Maybe BlockNo
chainSyncExitOnBlockNo
            , naChainSyncEarlyExit :: NodeArgs -> Bool
naChainSyncEarlyExit     = Bool
chainSyncEarlyExit
            , naPeerSharing :: NodeArgs -> PeerSharing
naPeerSharing            = PeerSharing
peerSharing
            , naDiffusionMode :: NodeArgs -> DiffusionMode
naDiffusionMode          = DiffusionMode
diffusionMode
            , naTxs :: NodeArgs -> [Tx Int]
naTxs                    = [Tx Int]
txs
            }
            Snocket m (FD m NtNAddr) NtNAddr
ntnSnocket
            Snocket m (FD m (TestAddress Int)) (TestAddress Int)
ntcSnocket
            ConnStateIdSupply m
connStateIdSupply
            StrictTVar
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
lrpVar
            StrictTVar m MockDNSMap
dMapVar Int
i = do
      chainSyncExitVar <- Maybe BlockNo -> m (StrictTVar m (Maybe BlockNo))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO Maybe BlockNo
chainSyncExitOnBlockNo
      ledgerPeersVar <- initScript' ledgerPeers
      onlyOutboundConnectionsStateVar <- newTVarIO UntrustedState
      useBootstrapPeersScriptVar <- newTVarIO bootstrapPeers
      churnModeVar <- newTVarIO ChurnModeNormal

      let readUseBootstrapPeers = StrictTVar m (Script UseBootstrapPeers) -> STM m UseBootstrapPeers
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m (Script a) -> STM m a
stepScriptSTM' StrictTVar m (Script UseBootstrapPeers)
useBootstrapPeersScriptVar
          (bgaRng, rng) = Random.split $ mkStdGen seed
          acceptedConnectionsLimit =
            TTL -> TTL -> DiffTime -> AcceptedConnectionsLimit
Node.AcceptedConnectionsLimit TTL
forall a. Bounded a => a
maxBound TTL
forall a. Bounded a => a
maxBound DiffTime
0
          readLocalRootPeers  = StrictTVar
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> STM
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
lrpVar
          readPublicRootPeers = Map RelayAccessPoint PeerAdvertise
-> STM m (Map RelayAccessPoint PeerAdvertise)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Map RelayAccessPoint PeerAdvertise
publicRoots
          readUseLedgerPeers  = UseLedgerPeers -> STM m UseLedgerPeers
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AfterSlot -> UseLedgerPeers
UseLedgerPeers (SlotNo -> AfterSlot
After SlotNo
0))
          acceptVersion = NtNVersionData -> NtNVersionData -> Accept NtNVersionData
forall v. Acceptable v => v -> v -> Accept v
acceptableVersion
          defaultMiniProtocolsLimit :: MiniProtocolLimits
          defaultMiniProtocolsLimit =
            MiniProtocolLimits { maximumIngressQueue :: Int
maximumIngressQueue = Int
64000 }

          blockGeneratorArgs :: Node.BlockGeneratorArgs Block StdGen
          blockGeneratorArgs =
            DiffTime -> StdGen -> Int -> BlockGeneratorArgs Block StdGen
Node.randomBlockGenerationArgs DiffTime
bgaSlotDuration
                                           StdGen
bgaRng
                                           Int
quota

          limitsAndTimeouts :: Node.LimitsAndTimeouts BlockHeader Block
          limitsAndTimeouts
            = Node.LimitsAndTimeouts
                { chainSyncLimits :: MiniProtocolLimits
Node.chainSyncLimits      = MiniProtocolLimits
defaultMiniProtocolsLimit
                , chainSyncSizeLimits :: ProtocolSizeLimits
  (ChainSync BlockHeader (Point Block) (Tip Block)) ByteString
Node.chainSyncSizeLimits  = (ByteString -> Word)
-> ProtocolSizeLimits
     (ChainSync BlockHeader (Point Block) (Tip Block)) ByteString
forall bytes header point tip.
(bytes -> Word)
-> ProtocolSizeLimits (ChainSync header point tip) bytes
byteLimitsChainSync (Int64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word) -> (ByteString -> Int64) -> ByteString -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length)
                , chainSyncTimeLimits :: ProtocolTimeLimitsWithRnd
  (ChainSync BlockHeader (Point Block) (Tip Block))
Node.chainSyncTimeLimits  = ChainSyncIdleTimeout
-> ProtocolTimeLimitsWithRnd
     (ChainSync BlockHeader (Point Block) (Tip Block))
forall header point tip.
ChainSyncIdleTimeout
-> ProtocolTimeLimitsWithRnd (ChainSync header point tip)
timeLimitsChainSync ChainSyncIdleTimeout
Cardano.defaultChainSyncIdleTimeout
                , blockFetchLimits :: MiniProtocolLimits
Node.blockFetchLimits     = MiniProtocolLimits
defaultMiniProtocolsLimit
                , blockFetchSizeLimits :: ProtocolSizeLimits (BlockFetch Block (Point Block)) ByteString
Node.blockFetchSizeLimits = (ByteString -> Word)
-> ProtocolSizeLimits (BlockFetch Block (Point Block)) ByteString
forall bytes block point.
(bytes -> Word)
-> ProtocolSizeLimits (BlockFetch block point) bytes
byteLimitsBlockFetch (Int64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word) -> (ByteString -> Int64) -> ByteString -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length)
                , blockFetchTimeLimits :: ProtocolTimeLimits (BlockFetch Block (Point Block))
Node.blockFetchTimeLimits = ProtocolTimeLimits (BlockFetch Block (Point Block))
forall block point. ProtocolTimeLimits (BlockFetch block point)
timeLimitsBlockFetch
                , keepAliveLimits :: MiniProtocolLimits
Node.keepAliveLimits      = MiniProtocolLimits
defaultMiniProtocolsLimit
                , keepAliveSizeLimits :: ProtocolSizeLimits KeepAlive ByteString
Node.keepAliveSizeLimits  = (ByteString -> Word) -> ProtocolSizeLimits KeepAlive ByteString
forall bytes. (bytes -> Word) -> ProtocolSizeLimits KeepAlive bytes
byteLimitsKeepAlive (Int64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word) -> (ByteString -> Int64) -> ByteString -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length)
                , keepAliveTimeLimits :: ProtocolTimeLimits KeepAlive
Node.keepAliveTimeLimits  = ProtocolTimeLimits KeepAlive
timeLimitsKeepAlive
                , pingPongLimits :: MiniProtocolLimits
Node.pingPongLimits       = MiniProtocolLimits
defaultMiniProtocolsLimit
                , pingPongSizeLimits :: ProtocolSizeLimits PingPong ByteString
Node.pingPongSizeLimits   = ProtocolSizeLimits PingPong ByteString
byteLimitsPingPong
                , pingPongTimeLimits :: ProtocolTimeLimits PingPong
Node.pingPongTimeLimits   = ProtocolTimeLimits PingPong
timeLimitsPingPong
                , handshakeLimits :: MiniProtocolLimits
Node.handshakeLimits      = MiniProtocolLimits
defaultMiniProtocolsLimit
                , handshakeTimeLimits :: ProtocolTimeLimits (Handshake NtNVersion NtNVersionData)
Node.handshakeTimeLimits  =
                    (forall (st :: Handshake NtNVersion NtNVersionData).
 ActiveState st =>
 StateToken st -> Maybe DiffTime)
-> ProtocolTimeLimits (Handshake NtNVersion NtNVersionData)
forall ps.
(forall (st :: ps).
 ActiveState st =>
 StateToken st -> Maybe DiffTime)
-> ProtocolTimeLimits ps
ProtocolTimeLimits (Maybe DiffTime -> SingHandshake st -> Maybe DiffTime
forall a b. a -> b -> a
const Maybe DiffTime
shortWait)
                , handhsakeSizeLimits :: ProtocolSizeLimits (Handshake NtNVersion NtNVersionData) ByteString
Node.handhsakeSizeLimits  =
                    (forall (st :: Handshake NtNVersion NtNVersionData).
 ActiveState st =>
 StateToken st -> Word)
-> (ByteString -> Word)
-> ProtocolSizeLimits
     (Handshake NtNVersion NtNVersionData) ByteString
forall ps bytes.
(forall (st :: ps). ActiveState st => StateToken st -> Word)
-> (bytes -> Word) -> ProtocolSizeLimits ps bytes
ProtocolSizeLimits (Word -> SingHandshake st -> Word
forall a b. a -> b -> a
const (Word
4 Word -> Word -> Word
forall a. Num a => a -> a -> a
* Word
1440))
                                       (Int64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word) -> (ByteString -> Int64) -> ByteString -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length)
                , peerSharingLimits :: MiniProtocolLimits
Node.peerSharingLimits     = MiniProtocolLimits
defaultMiniProtocolsLimit
                , peerSharingTimeLimits :: ProtocolTimeLimits (PeerSharing NtNAddr)
Node.peerSharingTimeLimits =
                    ProtocolTimeLimits (PeerSharing NtNAddr)
forall peerAddress. ProtocolTimeLimits (PeerSharing peerAddress)
timeLimitsPeerSharing
                , peerSharingSizeLimits :: ProtocolSizeLimits (PeerSharing NtNAddr) ByteString
Node.peerSharingSizeLimits =
                    (ByteString -> Word)
-> ProtocolSizeLimits (PeerSharing NtNAddr) ByteString
forall peerAddress bytes.
(bytes -> Word)
-> ProtocolSizeLimits (PeerSharing peerAddress) bytes
byteLimitsPeerSharing (Int64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word) -> (ByteString -> Int64) -> ByteString -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length)
                , txSubmissionLimits :: MiniProtocolLimits
Node.txSubmissionLimits = MiniProtocolLimits
defaultMiniProtocolsLimit
                , txSubmissionTimeLimits :: ProtocolTimeLimits (TxSubmission2 Int (Tx Int))
Node.txSubmissionTimeLimits = ProtocolTimeLimits (TxSubmission2 Int (Tx Int))
forall txid tx. ProtocolTimeLimits (TxSubmission2 txid tx)
timeLimitsTxSubmission2
                , txSubmissionSizeLimits :: ProtocolSizeLimits (TxSubmission2 Int (Tx Int)) ByteString
Node.txSubmissionSizeLimits = (ByteString -> Word)
-> ProtocolSizeLimits (TxSubmission2 Int (Tx Int)) ByteString
forall bytes txid tx.
(bytes -> Word) -> ProtocolSizeLimits (TxSubmission2 txid tx) bytes
byteLimitsTxSubmission2 (Int64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word) -> (ByteString -> Int64) -> ByteString -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length)
                }

          interfaces :: Node.Interfaces (Cardano.LedgerPeersConsensusInterface m) m
          interfaces =
            Node.Interfaces
              { iNtnSnocket :: Snocket m (FD m NtNAddr) NtNAddr
Node.iNtnSnocket        = Snocket m (FD m NtNAddr) NtNAddr
ntnSnocket
              , iNtnBearer :: MakeBearer m (FD m NtNAddr)
Node.iNtnBearer         = MakeBearer m (FD m NtNAddr)
forall addr (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m, MonadThrow m, Show addr) =>
MakeBearer m (FD m (TestAddress addr))
makeFDBearer
              , iAcceptVersion :: NtNVersionData -> NtNVersionData -> Accept NtNVersionData
Node.iAcceptVersion     = NtNVersionData -> NtNVersionData -> Accept NtNVersionData
acceptVersion
              , iNtnDomainResolver :: DNSLookupType
-> [DomainAccessPoint] -> m (Map DomainAccessPoint (Set NtNAddr))
Node.iNtnDomainResolver = StrictTVar m MockDNSMap
-> DNSLookupType
-> [DomainAccessPoint]
-> m (Map DomainAccessPoint (Set NtNAddr))
domainResolver StrictTVar m MockDNSMap
dMapVar
              , iNtcSnocket :: Snocket m (FD m (TestAddress Int)) (TestAddress Int)
Node.iNtcSnocket        = Snocket m (FD m (TestAddress Int)) (TestAddress Int)
ntcSnocket
              , iNtcBearer :: MakeBearer m (FD m (TestAddress Int))
Node.iNtcBearer         = MakeBearer m (FD m (TestAddress Int))
forall addr (m :: * -> *).
(MonadMonotonicTime m, MonadSTM m, MonadThrow m, Show addr) =>
MakeBearer m (FD m (TestAddress addr))
makeFDBearer
              , iRng :: StdGen
Node.iRng               = StdGen
rng
              , iDomainMap :: StrictTVar m MockDNSMap
Node.iDomainMap         = StrictTVar m MockDNSMap
dMapVar
              , iLedgerPeersConsensusInterface :: LedgerPeersConsensusInterface (LedgerPeersConsensusInterface m) m
Node.iLedgerPeersConsensusInterface
                                        =
                  STM m (WithOrigin SlotNo)
-> STM m [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> LedgerPeersConsensusInterface m
-> LedgerPeersConsensusInterface
     (LedgerPeersConsensusInterface m) m
forall extraAPI (m :: * -> *).
STM m (WithOrigin SlotNo)
-> STM m [(PoolStake, NonEmpty LedgerRelayAccessPoint)]
-> extraAPI
-> LedgerPeersConsensusInterface extraAPI m
LedgerPeersConsensusInterface
                    (WithOrigin SlotNo -> STM m (WithOrigin SlotNo)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WithOrigin SlotNo
forall a. Bounded a => a
maxBound)
                    (do
                      ledgerPools <- StrictTVar m (Script LedgerPools) -> STM m LedgerPools
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m (Script a) -> STM m a
stepScriptSTM' StrictTVar m (Script LedgerPools)
ledgerPeersVar
                      return $ Map.elems
                             $ accPoolStake
                             $ getLedgerPools
                               ledgerPools)
                    Cardano.LedgerPeersConsensusInterface {
                      readFetchMode :: STM m FetchMode
Cardano.readFetchMode = FetchMode -> STM m FetchMode
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PraosFetchMode -> FetchMode
PraosFetchMode PraosFetchMode
FetchModeDeadline)
                    , getLedgerStateJudgement :: STM m LedgerStateJudgement
Cardano.getLedgerStateJudgement = LedgerStateJudgement -> STM m LedgerStateJudgement
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerStateJudgement
TooOld
                    , updateOutboundConnectionsState :: OutboundConnectionsState -> STM m ()
Cardano.updateOutboundConnectionsState =
                        \OutboundConnectionsState
a -> do
                          a' <- StrictTVar m OutboundConnectionsState
-> STM m OutboundConnectionsState
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m OutboundConnectionsState
onlyOutboundConnectionsStateVar
                          when (a /= a') $
                            writeTVar onlyOutboundConnectionsStateVar a
                    }
              , iConnStateIdSupply :: ConnStateIdSupply m
Node.iConnStateIdSupply = ConnStateIdSupply m
connStateIdSupply
              }

          shouldChainSyncExit :: StrictTVar m (Maybe BlockNo) -> BlockHeader -> m Bool
          shouldChainSyncExit StrictTVar m (Maybe BlockNo)
v BlockHeader
header = STM m Bool -> m Bool
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m Bool -> m Bool) -> STM m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ do
            mbBlockNo <- StrictTVar m (Maybe BlockNo) -> STM m (Maybe BlockNo)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Maybe BlockNo)
v
            case mbBlockNo of
              Maybe BlockNo
Nothing ->
                Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

              Just BlockNo
blockNo | BlockNo
blockNo BlockNo -> BlockNo -> Bool
forall a. Ord a => a -> a -> Bool
>= BlockHeader -> BlockNo
headerBlockNo BlockHeader
header -> do
                -- next time exit in 10 blocks
                StrictTVar m (Maybe BlockNo) -> Maybe BlockNo -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Maybe BlockNo)
v (BlockNo -> Maybe BlockNo
forall a. a -> Maybe a
Just (BlockNo -> Maybe BlockNo) -> BlockNo -> Maybe BlockNo
forall a b. (a -> b) -> a -> b
$ BlockNo
blockNo BlockNo -> BlockNo -> BlockNo
forall a. Num a => a -> a -> a
+ BlockNo
10)
                Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

                           | Bool
otherwise ->
                Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

          cardanoChurnArgs :: Churn.ExtraArguments m
          cardanoChurnArgs =
            Churn.ExtraArguments {
              modeVar :: StrictTVar m ChurnMode
Churn.modeVar             = StrictTVar m ChurnMode
churnModeVar
            , genesisPeerSelectionTargets :: PeerSelectionTargets
Churn.genesisPeerSelectionTargets
                                        = (PeerSelectionTargets, PeerSelectionTargets)
-> PeerSelectionTargets
forall a b. (a, b) -> b
snd (PeerSelectionTargets, PeerSelectionTargets)
peerTargets
            , readUseBootstrap :: STM m UseBootstrapPeers
Churn.readUseBootstrap    = STM m UseBootstrapPeers
readUseBootstrapPeers
            , consensusMode :: ConsensusMode
Churn.consensusMode       = ConsensusMode
consensusMode
            , tracerChurnMode :: Tracer m TraceChurnMode
Churn.tracerChurnMode     = (\TraceChurnMode
s -> Time
-> WithName NtNAddr DiffusionTestTrace
-> WithTime (WithName NtNAddr DiffusionTestTrace)
forall event. Time -> event -> WithTime event
WithTime (DiffTime -> Time
Time (-DiffTime
1)) (NtNAddr
-> DiffusionTestTrace -> WithName NtNAddr DiffusionTestTrace
forall name event. name -> event -> WithName name event
WithName NtNAddr
addr (TraceChurnMode -> DiffusionTestTrace
DiffusionChurnModeTrace TraceChurnMode
s)))
                                            (TraceChurnMode -> WithTime (WithName NtNAddr DiffusionTestTrace))
-> Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
-> Tracer m TraceChurnMode
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
nodeTracer
            }

          arguments :: Node.Arguments (Churn.ExtraArguments m) PeerTrustable m
          arguments =
            Node.Arguments
              { aIPAddress :: NtNAddr
Node.aIPAddress            = NtNAddr
addr
              , aAcceptedLimits :: AcceptedConnectionsLimit
Node.aAcceptedLimits       = AcceptedConnectionsLimit
acceptedConnectionsLimit
              , aDiffusionMode :: DiffusionMode
Node.aDiffusionMode        = DiffusionMode
diffusionMode
              , aKeepAliveInterval :: DiffTime
Node.aKeepAliveInterval    = DiffTime
10
              , aPingPongInterval :: DiffTime
Node.aPingPongInterval     = DiffTime
10
              , aPeerTargets :: PeerSelectionTargets
Node.aPeerTargets          = (PeerSelectionTargets, PeerSelectionTargets)
-> PeerSelectionTargets
forall a b. (a, b) -> a
fst (PeerSelectionTargets, PeerSelectionTargets)
peerTargets
              , aShouldChainSyncExit :: BlockHeader -> m Bool
Node.aShouldChainSyncExit  = StrictTVar m (Maybe BlockNo) -> BlockHeader -> m Bool
shouldChainSyncExit StrictTVar m (Maybe BlockNo)
chainSyncExitVar
              , aChainSyncEarlyExit :: Bool
Node.aChainSyncEarlyExit   = Bool
chainSyncEarlyExit
              , aReadLocalRootPeers :: STM
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
Node.aReadLocalRootPeers   = STM
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
readLocalRootPeers
              , aReadPublicRootPeers :: STM m (Map RelayAccessPoint PeerAdvertise)
Node.aReadPublicRootPeers  = STM m (Map RelayAccessPoint PeerAdvertise)
readPublicRootPeers
              , aPeerSharing :: PeerSharing
Node.aPeerSharing          = PeerSharing
peerSharing
              , aReadUseLedgerPeers :: STM m UseLedgerPeers
Node.aReadUseLedgerPeers   = STM m UseLedgerPeers
readUseLedgerPeers
              , aProtocolIdleTimeout :: DiffTime
Node.aProtocolIdleTimeout  = DiffTime
5
              , aTimeWaitTimeout :: DiffTime
Node.aTimeWaitTimeout      = DiffTime
30
              , aDNSTimeoutScript :: Script DNSTimeout
Node.aDNSTimeoutScript     = Script DNSTimeout
dnsTimeout
              , aDNSLookupDelayScript :: Script DNSLookupDelay
Node.aDNSLookupDelayScript = Script DNSLookupDelay
dnsLookupDelay
              , aDebugTracer :: Tracer m [Char]
Node.aDebugTracer          = ([Char] -> m ()) -> Tracer m [Char]
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (\[Char]
s -> do
                                              t <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
                                              traceWith nodeTracer $ WithTime t (WithName addr (DiffusionDebugTrace s)))
              , aExtraChurnArgs :: ExtraArguments m
Node.aExtraChurnArgs = ExtraArguments m
cardanoChurnArgs
              , aTxDecisionPolicy :: TxDecisionPolicy
Node.aTxDecisionPolicy     = TxDecisionPolicy
txDecisionPolicy
              , aTxs :: [Tx Int]
Node.aTxs                  = [Tx Int]
txs
              }

          tracers = NtNAddr
-> Int
-> Tracers
     NtNAddr
     NtNVersion
     NtNVersionData
     (TestAddress Int)
     NtNVersion
     NtCVersionData
     ExtraState
     ExtraState
     PeerTrustable
     (ExtraPeers NtNAddr)
     (ExtraPeerSelectionSetsWithSizes NtNAddr)
     m
mkTracers NtNAddr
addr Int
i

          requestPublicRootPeers' =
            Tracer m TracePublicRootPeers
-> STM m UseBootstrapPeers
-> STM m LedgerStateJudgement
-> STM m (Map RelayAccessPoint PeerAdvertise)
-> PeerActionsDNS NtNAddr () m
-> DNSSemaphore m
-> (Map NtNAddr PeerAdvertise -> ExtraPeers NtNAddr)
-> (NumberOfPeers
    -> LedgerPeersKind -> m (Maybe (Set NtNAddr, DiffTime)))
-> LedgerPeersKind
-> StdGen
-> Int
-> m (CardanoPublicRootPeers NtNAddr, DiffTime)
forall (m :: * -> *) peeraddr resolver.
(MonadThrow m, MonadAsync m, Ord peeraddr) =>
Tracer m TracePublicRootPeers
-> STM m UseBootstrapPeers
-> STM m LedgerStateJudgement
-> STM m (Map RelayAccessPoint PeerAdvertise)
-> PeerActionsDNS peeraddr resolver m
-> DNSSemaphore m
-> (Map peeraddr PeerAdvertise -> ExtraPeers peeraddr)
-> (NumberOfPeers
    -> LedgerPeersKind -> m (Maybe (Set peeraddr, DiffTime)))
-> LedgerPeersKind
-> StdGen
-> Int
-> m (CardanoPublicRootPeers peeraddr, DiffTime)
requestPublicRootPeers (Tracers
  NtNAddr
  NtNVersion
  NtNVersionData
  (TestAddress Int)
  NtNVersion
  NtCVersionData
  ExtraState
  ExtraState
  PeerTrustable
  (ExtraPeers NtNAddr)
  (ExtraPeerSelectionSetsWithSizes NtNAddr)
  m
-> Tracer m TracePublicRootPeers
forall ntnAddr ntnVersion ntnVersionData ntcAddr ntcVersion
       ntcVersionData extraState extraDebugState extraFlags extraPeers
       extraCounters (m :: * -> *).
Tracers
  ntnAddr
  ntnVersion
  ntnVersionData
  ntcAddr
  ntcVersion
  ntcVersionData
  extraState
  extraDebugState
  extraFlags
  extraPeers
  extraCounters
  m
-> Tracer m TracePublicRootPeers
Diffusion.dtTracePublicRootPeersTracer Tracers
  NtNAddr
  NtNVersion
  NtNVersionData
  (TestAddress Int)
  NtNVersion
  NtCVersionData
  ExtraState
  ExtraState
  PeerTrustable
  (ExtraPeers NtNAddr)
  (ExtraPeerSelectionSetsWithSizes NtNAddr)
  m
tracers)
                                   STM m UseBootstrapPeers
readUseBootstrapPeers
                                   (LedgerStateJudgement -> STM m LedgerStateJudgement
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerStateJudgement
TooOld)
                                   STM m (Map RelayAccessPoint PeerAdvertise)
readPublicRootPeers

      Node.run blockGeneratorArgs
          limitsAndTimeouts
          interfaces
          arguments
          (ExtraState.empty consensusMode (NumberOfBigLedgerPeers 0))
          ExtraSizes.empty
          Cardano.cardanoPublicRootPeersAPI
          (Cardano.cardanoPeerSelectionGovernorArgs
            (Cardano.ExtraPeerSelectionActions
              (snd peerTargets)
              readUseBootstrapPeers)
          )
          Cardano.cardanoPeerSelectionStatetoCounters
          (flip Cardano.ExtraPeers Set.empty)
          requestPublicRootPeers'
          peerChurnGovernor
          tracers
          ( contramap (DiffusionFetchTrace . (\(TraceLabelPeer NtNAddr
_ TraceFetchClientState BlockHeader
a) -> TraceFetchClientState BlockHeader
a))
          . tracerWithName addr
          . tracerWithTime
          $ nodeTracer)
          ( contramap DiffusionTxSubmissionInbound
          . tracerWithName addr
          . tracerWithTime
          $ nodeTracer)
          ( contramap DiffusionTxLogic
          . tracerWithName addr
          . tracerWithTime
          $ nodeTracer)
        `catch` \SomeException
e -> Tracer m DiffusionSimulationTrace
-> DiffusionSimulationTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (NtNAddr -> Tracer m DiffusionSimulationTrace
diffSimTracer NtNAddr
addr) (SomeException -> DiffusionSimulationTrace
TrErrored SomeException
e)
                   m () -> m Void -> m Void
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> m Void
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO SomeException
e
        m Void -> m () -> m Void
forall a b. m a -> m b -> m a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally`     Tracer m DiffusionSimulationTrace
-> DiffusionSimulationTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (NtNAddr -> Tracer m DiffusionSimulationTrace
diffSimTracer NtNAddr
addr) DiffusionSimulationTrace
TrTerminated

    domainResolver :: StrictTVar m MockDNSMap
                   -> DNSLookupType
                   -> [DomainAccessPoint]
                   -> m (Map DomainAccessPoint (Set NtNAddr))
    -- TODO: we can take into account the `LookupReqs` and return only `IPv4`
    -- / `IPv6` if so requested.  But we should make sure the connectivity graph
    -- is not severely reduced.
    domainResolver :: StrictTVar m MockDNSMap
-> DNSLookupType
-> [DomainAccessPoint]
-> m (Map DomainAccessPoint (Set NtNAddr))
domainResolver StrictTVar m MockDNSMap
dnsMapVar DNSLookupType
_ [DomainAccessPoint]
daps = do
      dnsMap <- StrictTVar m MockDNSMap -> m MockDNSMap
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m MockDNSMap
dnsMapVar
      let mapDomains :: [(DomainAccessPoint, Set NtNAddr)]
          mapDomains =
            [ ( DomainAccessPoint
dap
              , [NtNAddr] -> Set NtNAddr
forall a. Ord a => [a] -> Set a
Set.fromList [ NtNAddr_ -> NtNAddr
forall addr. addr -> TestAddress addr
TestAddress (IP -> PortNumber -> NtNAddr_
IPAddr IP
a PortNumber
p) | (IP
a, PortNumber
p) <- [(IP, PortNumber)]
addrs ]
              )
            | DomainAccessPoint
dap <- [DomainAccessPoint]
daps
            , let addrs :: [(IP, PortNumber)]
addrs = case DomainAccessPoint
dap of
                    DomainAccessPoint Domain
d PortNumber
p -> (,PortNumber
p) (IP -> (IP, PortNumber)) -> [IP] -> [(IP, PortNumber)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MockDNSMap -> Domain -> [IP]
forall {a} {f :: * -> *} {b} {b} {b}.
(Ord a, Semigroup (f (b, b)), Functor f) =>
Map (a, TYPE) (Either (f (b, b)) b) -> a -> f b
retrieveIPs MockDNSMap
dnsMap Domain
d
                    DomainSRVAccessPoint Domain
dSRV ->
                      let subordinates :: Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
subordinates = MockDNSMap
dnsMap MockDNSMap
-> (Domain, TYPE)
-> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
forall k a. Ord k => Map k a -> k -> a
Map.! (Domain
dSRV, TYPE
DNS.SRV)
                          subordinates' :: [(Domain, Word16, Word16, PortNumber)]
subordinates' = [(Domain, Word16, Word16, PortNumber)]
-> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
-> [(Domain, Word16, Word16, PortNumber)]
forall b a. b -> Either a b -> b
fromRight ([Char] -> [(Domain, Word16, Word16, PortNumber)]
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible") Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
subordinates
                       in case [(Domain, Word16, Word16, PortNumber)]
-> Maybe (Domain, Word16, Word16, PortNumber)
forall a. [a] -> Maybe a
listToMaybe [(Domain, Word16, Word16, PortNumber)]
subordinates' of
                            Just (Domain
d, Word16
_, Word16
_, PortNumber
p) -> (,PortNumber
p) (IP -> (IP, PortNumber)) -> [IP] -> [(IP, PortNumber)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MockDNSMap -> Domain -> [IP]
forall {a} {f :: * -> *} {b} {b} {b}.
(Ord a, Semigroup (f (b, b)), Functor f) =>
Map (a, TYPE) (Either (f (b, b)) b) -> a -> f b
retrieveIPs MockDNSMap
dnsMap Domain
d
                            Maybe (Domain, Word16, Word16, PortNumber)
Nothing           -> []
            ]
      return (Map.fromListWith (<>) mapDomains)
      where
        retrieveIPs :: Map (a, TYPE) (Either (f (b, b)) b) -> a -> f b
retrieveIPs Map (a, TYPE) (Either (f (b, b)) b)
dnsMap a
d =
          let ipsttlsI4 :: Either (f (b, b)) b
ipsttlsI4 = Map (a, TYPE) (Either (f (b, b)) b)
dnsMap Map (a, TYPE) (Either (f (b, b)) b)
-> (a, TYPE) -> Either (f (b, b)) b
forall k a. Ord k => Map k a -> k -> a
Map.! (a
d, TYPE
DNS.A)
              ipsttlsI4' :: f (b, b)
ipsttlsI4' = f (b, b) -> Either (f (b, b)) b -> f (b, b)
forall a b. a -> Either a b -> a
fromLeft ([Char] -> f (b, b)
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible") Either (f (b, b)) b
ipsttlsI4
              ipsttlsI6 :: Either (f (b, b)) b
ipsttlsI6 =  Map (a, TYPE) (Either (f (b, b)) b)
dnsMap Map (a, TYPE) (Either (f (b, b)) b)
-> (a, TYPE) -> Either (f (b, b)) b
forall k a. Ord k => Map k a -> k -> a
Map.! (a
d, TYPE
DNS.AAAA)
              ipsttlsI6' :: f (b, b)
ipsttlsI6' = f (b, b) -> Either (f (b, b)) b -> f (b, b)
forall a b. a -> Either a b -> a
fromLeft ([Char] -> f (b, b)
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible") Either (f (b, b)) b
ipsttlsI6
              ipsttls :: f (b, b)
ipsttls = f (b, b)
ipsttlsI4' f (b, b) -> f (b, b) -> f (b, b)
forall a. Semigroup a => a -> a -> a
<> f (b, b)
ipsttlsI6'
           in (b, b) -> b
forall a b. (a, b) -> a
fst ((b, b) -> b) -> f (b, b) -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (b, b)
ipsttls

    diffSimTracer :: NtNAddr -> Tracer m DiffusionSimulationTrace
    diffSimTracer :: NtNAddr -> Tracer m DiffusionSimulationTrace
diffSimTracer NtNAddr
ntnAddr = (DiffusionSimulationTrace -> DiffusionTestTrace)
-> Tracer m DiffusionTestTrace -> Tracer m DiffusionSimulationTrace
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap DiffusionSimulationTrace -> DiffusionTestTrace
DiffusionSimulationTrace
                          (Tracer m DiffusionTestTrace -> Tracer m DiffusionSimulationTrace)
-> (Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
    -> Tracer m DiffusionTestTrace)
-> Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
-> Tracer m DiffusionSimulationTrace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NtNAddr
-> Tracer m (WithName NtNAddr DiffusionTestTrace)
-> Tracer m DiffusionTestTrace
forall name (m :: * -> *) a.
name -> Tracer m (WithName name a) -> Tracer m a
tracerWithName NtNAddr
ntnAddr
                          (Tracer m (WithName NtNAddr DiffusionTestTrace)
 -> Tracer m DiffusionTestTrace)
-> (Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
    -> Tracer m (WithName NtNAddr DiffusionTestTrace))
-> Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
-> Tracer m DiffusionTestTrace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
-> Tracer m (WithName NtNAddr DiffusionTestTrace)
forall (m :: * -> *) a.
MonadMonotonicTime m =>
Tracer m (WithTime a) -> Tracer m a
tracerWithTime
                          (Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
 -> Tracer m DiffusionSimulationTrace)
-> Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
-> Tracer m DiffusionSimulationTrace
forall a b. (a -> b) -> a -> b
$ Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
nodeTracer Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
-> Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
-> Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
forall a. Semigroup a => a -> a -> a
<> Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
forall a (m :: * -> *). (Show a, MonadSay m) => Tracer m a
sayTracer

    mkTracers
      :: NtNAddr
      -> Int
      -> Diffusion.Tracers NtNAddr NtNVersion NtNVersionData
                           NtCAddr NtCVersion NtCVersionData
                           Cardano.ExtraState
                           Cardano.ExtraState PeerTrustable
                           (Cardano.ExtraPeers NtNAddr)
                           (Cardano.ExtraPeerSelectionSetsWithSizes NtNAddr) m
    mkTracers :: NtNAddr
-> Int
-> Tracers
     NtNAddr
     NtNVersion
     NtNVersionData
     (TestAddress Int)
     NtNVersion
     NtCVersionData
     ExtraState
     ExtraState
     PeerTrustable
     (ExtraPeers NtNAddr)
     (ExtraPeerSelectionSetsWithSizes NtNAddr)
     m
mkTracers NtNAddr
ntnAddr Int
i =
      let sayTracer' :: Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
sayTracer' = (WithTime (WithName NtNAddr DiffusionTestTrace) -> m ())
-> Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer \WithTime (WithName NtNAddr DiffusionTestTrace)
msg -> [Char] -> m ()
forall (m :: * -> *). MonadSay m => [Char] -> m ()
say ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"(node-" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
")" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> WithTime (WithName NtNAddr DiffusionTestTrace) -> [Char]
forall a. Show a => a -> [Char]
show WithTime (WithName NtNAddr DiffusionTestTrace)
msg
          -- toggle and uncomment interesting sayTracer' below
          nodeTracer' :: Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
nodeTracer' = if Bool
True then Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
nodeTracer Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
-> Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
-> Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
forall a. Semigroup a => a -> a -> a
<> Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
sayTracer' else Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
nodeTracer in

      Tracers
  NtNAddr
  NtNVersion
  (ZonkAny 6)
  (TestAddress Int)
  NtNVersion
  (ZonkAny 5)
  (ZonkAny 4)
  (ZonkAny 3)
  (ZonkAny 2)
  (ZonkAny 1)
  (ZonkAny 0)
  m
forall (m :: * -> *) ntnAddr ntnVersion ntnVersionData ntcAddr
       ntcVersion ntcVersionData extraState extraDebugState extraFlags
       extraPeers extraCounters.
Applicative m =>
Tracers
  ntnAddr
  ntnVersion
  ntnVersionData
  ntcAddr
  ntcVersion
  ntcVersionData
  extraState
  extraDebugState
  extraFlags
  extraPeers
  extraCounters
  m
Diffusion.nullTracers {
          -- Diffusion.dtMuxTracer = contramap
          --                           DiffusionMuxTrace
          --                       . tracerWithName ntnAddr
          --                       . tracerWithTime
          --                       $ nodeTracer' -- <> sayTracer',
          Diffusion.dtTraceLocalRootPeersTracer  = contramap
                                                     DiffusionLocalRootPeerTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer' -- <> sayTracer'
        , Diffusion.dtTracePublicRootPeersTracer = contramap
                                                     DiffusionPublicRootPeerTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer' -- <> sayTracer'
        , Diffusion.dtTraceLedgerPeersTracer     = contramap
                                                     DiffusionLedgerPeersTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer' -- <> sayTracer'
        , Diffusion.dtTracePeerSelectionTracer   = contramap
                                                     DiffusionPeerSelectionTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer' -- <> sayTracer'
        , Diffusion.dtDebugPeerSelectionInitiatorTracer
                                                 = contramap
                                                     DiffusionDebugPeerSelectionTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer' -- <> sayTracer'
        , Diffusion.dtDebugPeerSelectionInitiatorResponderTracer
                                                 = contramap
                                                     DiffusionDebugPeerSelectionTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer' -- <> sayTracer'
        , Diffusion.dtTracePeerSelectionCounters = nullTracer
        , Diffusion.dtTraceChurnCounters         = nullTracer
        , Diffusion.dtPeerSelectionActionsTracer = contramap
                                                     DiffusionPeerSelectionActionsTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer' -- <> sayTracer'
        , Diffusion.dtConnectionManagerTracer    = contramap
                                                     DiffusionConnectionManagerTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer' -- <> sayTracer'
        , Diffusion.dtConnectionManagerTransitionTracer
                                                 = contramap
                                                     DiffusionConnectionManagerTransitionTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
          -- note: we have two ways getting transition trace:
          -- * through `traceTVar` installed in `newMutableConnState`
          -- * the `dtConnectionManagerTransitionTracer`
                                                 $ nodeTracer' -- <> sayTracer'
        , Diffusion.dtServerTracer          = contramap
                                                DiffusionServerTrace
                                            . tracerWithName ntnAddr
                                            . tracerWithTime
                                            $ nodeTracer' -- <> sayTracer'
        , Diffusion.dtInboundGovernorTracer = contramap
                                                DiffusionInboundGovernorTrace
                                            . tracerWithName ntnAddr
                                            . tracerWithTime
                                            $ nodeTracer' -- <> sayTracer'
        , Diffusion.dtInboundGovernorTransitionTracer
                                                 = contramap
                                                     DiffusionInboundGovernorTransitionTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer' -- <> sayTracer'
        , Diffusion.dtLocalConnectionManagerTracer = nullTracer
        , Diffusion.dtLocalServerTracer            = nullTracer
        , Diffusion.dtLocalInboundGovernorTracer   = nullTracer
        , Diffusion.dtDnsTracer                    = contramap DiffusionDNSTrace
                                                   . tracerWithName ntnAddr
                                                   . tracerWithTime
                                                   $ nodeTracer' -- <> sayTracer'
      }


--
-- PingPong byte & time limits
--

byteLimitsPingPong :: ProtocolSizeLimits PingPong.PingPong BL.ByteString
byteLimitsPingPong :: ProtocolSizeLimits PingPong ByteString
byteLimitsPingPong = (forall (st :: PingPong). ActiveState st => StateToken st -> Word)
-> (ByteString -> Word) -> ProtocolSizeLimits PingPong ByteString
forall ps bytes.
(forall (st :: ps). ActiveState st => StateToken st -> Word)
-> (bytes -> Word) -> ProtocolSizeLimits ps bytes
ProtocolSizeLimits (Word -> SPingPong st -> Word
forall a b. a -> b -> a
const Word
smallByteLimit) (Int64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word) -> (ByteString -> Int64) -> ByteString -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BL.length)

timeLimitsPingPong :: ProtocolTimeLimits PingPong.PingPong
timeLimitsPingPong :: ProtocolTimeLimits PingPong
timeLimitsPingPong = (forall (st :: PingPong).
 ActiveState st =>
 StateToken st -> Maybe DiffTime)
-> ProtocolTimeLimits PingPong
forall ps.
(forall (st :: ps).
 ActiveState st =>
 StateToken st -> Maybe DiffTime)
-> ProtocolTimeLimits ps
ProtocolTimeLimits ((forall (st :: PingPong).
  ActiveState st =>
  StateToken st -> Maybe DiffTime)
 -> ProtocolTimeLimits PingPong)
-> (forall (st :: PingPong).
    ActiveState st =>
    StateToken st -> Maybe DiffTime)
-> ProtocolTimeLimits PingPong
forall a b. (a -> b) -> a -> b
$ \case
    StateToken st
SPingPong st
PingPong.SingIdle   -> Maybe DiffTime
forall a. Maybe a
Nothing
    StateToken st
SPingPong st
PingPong.SingBusy   -> DiffTime -> Maybe DiffTime
forall a. a -> Maybe a
Just DiffTime
60
    a :: StateToken st
a@StateToken st
SPingPong st
PingPong.SingDone -> StateToken 'StDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken st
StateToken 'StDone
a

--
-- Utils
--

withAsyncAll :: MonadAsync m => [m a] -> ([Async m a] -> m b) -> m b
withAsyncAll :: forall (m :: * -> *) a b.
MonadAsync m =>
[m a] -> ([Async m a] -> m b) -> m b
withAsyncAll [m a]
xs0 [Async m a] -> m b
action = [Async m a] -> [m a] -> m b
go [] [m a]
xs0
  where
    go :: [Async m a] -> [m a] -> m b
go [Async m a]
as []     = [Async m a] -> m b
action ([Async m a] -> [Async m a]
forall a. [a] -> [a]
reverse [Async m a]
as)
    go [Async m a]
as (m a
x:[m a]
xs) = m a -> (Async m a -> m b) -> m b
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 m a
x (\Async m a
a -> [Async m a] -> [m a] -> m b
go (Async m a
aAsync m a -> [Async m a] -> [Async m a]
forall a. a -> [a] -> [a]
:[Async m a]
as) [m a]
xs)


-- | Split a list into sub list of at most `n` elements.
--
divvy :: Int -> [a] -> [[a]]
divvy :: forall a. Int -> [a] -> [[a]]
divvy Int
_ [] = []
divvy Int
n [a]
as = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
n [a]
as [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Int -> [a] -> [[a]]
forall a. Int -> [a] -> [[a]]
divvy Int
n (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
n [a]
as)


sublistOf1 :: NonEmpty a -> Gen (NonEmpty a)
sublistOf1 :: forall a. NonEmpty a -> Gen (NonEmpty a)
sublistOf1 NonEmpty a
as = do
    -- boolean mask
    msk <- Int -> Gen Bool -> Gen [Bool]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
len Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
    -- index for which we force `True` in the `msk`
    idx <- chooseInt (0, len - 1)
    let msk' = case Int -> [Bool] -> ([Bool], [Bool])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Bool]
msk of
          ([Bool]
hs, Bool
_:[Bool]
ts) -> [Bool]
hs [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ (Bool
True Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool]
ts)
          ([Bool], [Bool])
_          -> [Char] -> [Bool]
forall a. HasCallStack => [Char] -> a
error [Char]
"sublistOf1: impossible happened"
    return . NonEmpty.fromList
           . fmap snd
           . NonEmpty.filter fst
           . NonEmpty.zip (NonEmpty.fromList msk')
           $ as
  where
    len :: Int
len = NonEmpty a -> Int
forall a. NonEmpty a -> Int
NonEmpty.length NonEmpty a
as