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

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

module Test.Ouroboros.Network.Diffusion.Testnet.Cardano.Simulation
  ( SimArgs (..)
  , mainnetSimArgs
  , NodeArgs (..)
  , ServiceDomainName (..)
  , DiffusionScript (..)
  , HotDiffusionScript (..)
  , DiffusionSimulationTrace (..)
  , prop_diffusionScript_fixupCommands
  , prop_diffusionScript_commandScript_valid
  , fixupCommands
  , diffusionSimulation
  , Command (..)
    -- * Tracing
  , DiffusionTestTrace (..)
  , 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.Bool (bool)
import Data.ByteString.Char8 qualified as BSC
import Data.ByteString.Lazy qualified as BL
import Data.Function (on)
import Data.IP (IP (..))
import Data.List (delete, nubBy)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (catMaybes, fromMaybe, maybeToList)
import Data.Proxy (Proxy (..))
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Time.Clock (secondsToDiffTime)
import Data.Typeable (Typeable)
import Data.Void (Void)
import System.Random (StdGen, mkStdGen)
import System.Random qualified as Random

import Network.DNS (Domain, TTL)
import Network.TypedProtocol.Core
import Network.TypedProtocol.PingPong.Type qualified as PingPong

import Cardano.Network.ConsensusMode
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 Ouroboros.Cardano.Network.ArgumentsExtra qualified as Cardano
import Ouroboros.Cardano.Network.Diffusion.Configuration
           (defaultNumberOfBigLedgerPeers)
import Ouroboros.Cardano.Network.LedgerPeerConsensusInterface qualified as Cardano
import Ouroboros.Cardano.Network.PeerSelection.Churn.ExtraArguments qualified as Churn
import Ouroboros.Cardano.Network.PeerSelection.Governor.PeerSelectionState qualified as Cardano hiding
           (consensusMode)
import Ouroboros.Cardano.Network.PeerSelection.Governor.PeerSelectionState qualified as ExtraState
import Ouroboros.Cardano.Network.PeerSelection.Governor.Types qualified as Cardano
import Ouroboros.Cardano.Network.PeerSelection.Governor.Types qualified as ExtraSizes
import Ouroboros.Cardano.Network.PublicRootPeers qualified as Cardano
import Ouroboros.Cardano.Network.Types (ChurnMode (..))
import Ouroboros.Cardano.PeerSelection.Churn (peerChurnGovernor)
import Ouroboros.Cardano.PeerSelection.PeerSelectionActions
           (requestPublicRootPeers)

import Ouroboros.Network.Block (BlockNo)
import Ouroboros.Network.BlockFetch (FetchMode (..), PraosFetchMode (..),
           TraceFetchClientState, TraceLabelPeer (..))
import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace)
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 Diff
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.Mock.ConcreteBlock (Block (..), BlockHeader (..))
import Ouroboros.Network.Mux (MiniProtocolLimits (..))
import Ouroboros.Network.PeerSelection.Governor (DebugPeerSelection (..),
           TracePeerSelection)
import Ouroboros.Network.PeerSelection.Governor qualified as PeerSelection
import Ouroboros.Network.PeerSelection.LedgerPeers (AfterSlot (..),
           LedgerPeersConsensusInterface (..), TraceLedgerPeers,
           UseLedgerPeers (..), accPoolStake)
import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing)
import Ouroboros.Network.PeerSelection.PeerStateActions
           (PeerSelectionActionsTrace)
import Ouroboros.Network.PeerSelection.RelayAccessPoint (DomainAccessPoint (..),
           PortNumber, RelayAccessPoint (..))
import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions (DNSLookupType)
import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers
           (TraceLocalRootPeers)
import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers
           (TracePublicRootPeers)
import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..),
           LocalRootConfig, WarmValency (..))
import Ouroboros.Network.Protocol.BlockFetch.Codec (byteLimitsBlockFetch,
           timeLimitsBlockFetch)
import Ouroboros.Network.Protocol.ChainSync.Codec (ChainSyncTimeout (..),
           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.Server qualified as Server
import Ouroboros.Network.Snocket (Snocket, TestAddress (..))

import Simulation.Network.Snocket (BearerInfo (..), FD, SnocketTrace,
           WithAddr (..), makeFDBearer, withSnocket)

import Test.Ouroboros.Network.Data.Script
import Test.Ouroboros.Network.Diffusion.Node as Node
import Test.Ouroboros.Network.LedgerPeers (LedgerPools (..), 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 (..), mockDNSActions)
import Test.Ouroboros.Network.PeerSelection.RootPeersDNS qualified as PeerSelection hiding
           (tests)
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
    }

instance Show SimArgs where
    show :: SimArgs -> String
show SimArgs { DiffTime
saSlot :: SimArgs -> DiffTime
saSlot :: DiffTime
saSlot, Int
saQuota :: SimArgs -> Int
saQuota :: Int
saQuota } =
      [String] -> String
unwords [ String
"SimArgs"
              , DiffTime -> String
forall a. Show a => a -> String
show DiffTime
saSlot
              , Int -> String
forall a. Show a => a -> String
show Int
saQuota
              ]

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 -> ShowS
[ServiceDomainName] -> ShowS
ServiceDomainName -> String
(Int -> ServiceDomainName -> ShowS)
-> (ServiceDomainName -> String)
-> ([ServiceDomainName] -> ShowS)
-> Show ServiceDomainName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServiceDomainName -> ShowS
showsPrec :: Int -> ServiceDomainName -> ShowS
$cshow :: ServiceDomainName -> String
show :: ServiceDomainName -> String
$cshowList :: [ServiceDomainName] -> ShowS
showList :: [ServiceDomainName] -> ShowS
Show

instance Arbitrary ServiceDomainName where
    arbitrary :: Gen ServiceDomainName
arbitrary = [(Int, Gen ServiceDomainName)] -> Gen ServiceDomainName
forall a. [(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 (String -> Domain
BSC.pack String
"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 (String -> Domain
BSC.pack String
"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 -> Maybe DiffTime
naMbTime                 :: Maybe DiffTime
      -- ^ 'LimitsAndTimeouts' argument
    , 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' 'aOwnPeerSharing' 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 PraosFetchMode
naFetchModeScript        :: Script PraosFetchMode
    }

instance Show NodeArgs where
    show :: NodeArgs -> String
show NodeArgs { Int
naSeed :: NodeArgs -> Int
naSeed :: Int
naSeed, DiffusionMode
naDiffusionMode :: NodeArgs -> DiffusionMode
naDiffusionMode :: DiffusionMode
naDiffusionMode, Maybe DiffTime
naMbTime :: NodeArgs -> Maybe DiffTime
naMbTime :: Maybe DiffTime
naMbTime, 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, [(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 PraosFetchMode
naFetchModeScript :: NodeArgs -> Script PraosFetchMode
naFetchModeScript :: Script PraosFetchMode
naFetchModeScript, ConsensusMode
naConsensusMode :: NodeArgs -> ConsensusMode
naConsensusMode :: ConsensusMode
naConsensusMode } =
      [String] -> String
unwords [ String
"NodeArgs"
              , String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
naSeed String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
              , DiffusionMode -> String
forall a. Show a => a -> String
show DiffusionMode
naDiffusionMode
              , ConsensusMode -> String
forall a. Show a => a -> String
show ConsensusMode
naConsensusMode
              , String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe DiffTime -> String
forall a. Show a => a -> String
show Maybe DiffTime
naMbTime String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
              , String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Map RelayAccessPoint PeerAdvertise -> String
forall a. Show a => a -> String
show Map RelayAccessPoint PeerAdvertise
naPublicRoots String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
              , String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Script UseBootstrapPeers -> String
forall a. Show a => a -> String
show Script UseBootstrapPeers
naBootstrapPeers String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
              , String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ NtNAddr -> String
forall a. Show a => a -> String
show NtNAddr
naAddr String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
              , PeerSharing -> String
forall a. Show a => a -> String
show PeerSharing
naPeerSharing
              , [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> String
forall a. Show a => a -> String
show [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
naLocalRootPeers
              , (PeerSelectionTargets, PeerSelectionTargets) -> String
forall a. Show a => a -> String
show (PeerSelectionTargets, PeerSelectionTargets)
naPeerTargets
              , String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Script DNSTimeout -> String
forall a. Show a => a -> String
show Script DNSTimeout
naDNSTimeoutScript String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
              , String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Script DNSLookupDelay -> String
forall a. Show a => a -> String
show Script DNSLookupDelay
naDNSLookupDelayScript String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
              , String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe BlockNo -> String
forall a. Show a => a -> String
show Maybe BlockNo
naChainSyncExitOnBlockNo String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
              , Bool -> String
forall a. Show a => a -> String
show Bool
naChainSyncEarlyExit
              , Script PraosFetchMode -> String
forall a. Show a => a -> String
show Script PraosFetchMode
naFetchModeScript
              , String
"============================================\n"
              ]

data Command = JoinNetwork DiffTime
             | Kill DiffTime
             | Reconfigure DiffTime
                           [( HotValency
                            , WarmValency
                            , Map RelayAccessPoint (LocalRootConfig PeerTrustable)
                            )]
  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 -> ShowS
showsPrec Int
d (JoinNetwork DiffTime
delay)             = String -> ShowS
showString String
"JoinNetwork "
                                                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DiffTime -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
d DiffTime
delay
    showsPrec Int
d (Kill DiffTime
delay)                    = String -> ShowS
showString String
"Kill "
                                                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DiffTime -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
d DiffTime
delay
    showsPrec Int
d (Reconfigure DiffTime
delay [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
localRoots)  = String -> ShowS
showString String
"Reconfigure "
                                                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> DiffTime -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
d DiffTime
delay
                                                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
                                                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
d [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
localRoots

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. [(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. [(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 -> [Command] -> [Command]
go Command
jn [Command]
t
  where
    go :: Command -> [Command] -> [Command]
    go :: Command -> [Command] -> [Command]
go Command
_ [] = []
    go Command
prev (Command
cmd:[Command]
cmds) =
      case (Command
prev, Command
cmd) of
        (JoinNetwork DiffTime
_   , JoinNetwork DiffTime
_   ) -> Command -> [Command] -> [Command]
go Command
prev [Command]
cmds
        (Kill DiffTime
_          , Kill DiffTime
_          ) -> Command -> [Command] -> [Command]
go Command
prev [Command]
cmds
        (Kill DiffTime
_          , Reconfigure DiffTime
_ [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
_ ) -> Command -> [Command] -> [Command]
go Command
prev [Command]
cmds
        (Reconfigure DiffTime
_ [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
_ , JoinNetwork DiffTime
_   ) -> Command -> [Command] -> [Command]
go Command
prev [Command]
cmds
        (Command, Command)
_                                    -> Command
cmd Command -> [Command] -> [Command]
forall a. a -> [a] -> [a]
: Command -> [Command] -> [Command]
go Command
cmd [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 -> SimArgs
mainnetSimArgs :: Int -> SimArgs
mainnetSimArgs Int
numberOfNodes =
  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
    }


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. 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
PeerSelection.sanePeerSelectionTargets PeerSelectionTargets
targets'
    ]


-- | Given a NtNAddr generate the necessary things to run a node in
-- Simulation
genNodeArgs :: [RelayAccessInfo]
            -> Int
            -> [(HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
            -> RelayAccessInfo
            -> Gen NodeArgs
genNodeArgs :: [RelayAccessInfo]
-> Int
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
-> RelayAccessInfo
-> Gen NodeArgs
genNodeArgs [RelayAccessInfo]
relays Int
minConnected [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
localRootPeers RelayAccessInfo
relay = (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)
                             ]

  -- These values approximately correspond to false positive
  -- thresholds for streaks of empty slots with 99% probability,
  -- 99.9% probability up to 99.999% probability.
  -- t = T_s [log (1-Y) / log (1-f)]
  -- Y = [0.99, 0.999...]
  --
  -- T_s = slot length of 1s.
  -- f = 0.05
  -- The timeout is randomly picked per bearer to avoid all bearers
  -- going down at the same time in case of a long streak of empty
  -- slots. TODO: workaround until peer selection governor.
  -- Taken from ouroboros-consensus/src/Ouroboros/Consensus/Node.hs
  mustReplyTimeout <- Just <$> oneof (pure <$> [90, 135, 180, 224, 269])

  -- 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) =
        splitAt (length relays `div` 2) relays
      publicRoots =
        [(RelayAccessPoint, PeerAdvertise)]
-> Map RelayAccessPoint PeerAdvertise
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (RelayAccessInfo -> RelayAccessPoint
makeRelayAccessPoint RelayAccessInfo
relay', PeerAdvertise
advertise)
                     | RelayAccessInfo
relay' <- [RelayAccessInfo]
publicRootsRelays
                     , RelayAccessInfo
relay' RelayAccessInfo -> RelayAccessInfo -> Bool
forall a. Eq a => a -> a -> Bool
/= RelayAccessInfo
relay
                     , let advertise :: PeerAdvertise
advertise = case RelayAccessInfo
relay' of
                             RelayAddrInfo        IP
_ip PortNumber
_port PeerAdvertise
adv -> PeerAdvertise
adv
                             RelayDomainInfo Domain
_dns IP
_ip PortNumber
_port PeerAdvertise
adv -> PeerAdvertise
adv
                     ]
  ledgerPeers <- fmap (map makeRelayAccessPoint) <$> listOf (sublistOf ledgerPeersRelays)
  ledgerPeerPools <- traverse genLedgerPoolsFrom ledgerPeers
  firstLedgerPool <- arbitrary
  let ledgerPeerPoolsScript = NonEmpty LedgerPools -> Script LedgerPools
forall a. NonEmpty a -> Script a
Script (LedgerPools
firstLedgerPool LedgerPools -> [LedgerPools] -> NonEmpty LedgerPools
forall a. a -> [a] -> NonEmpty a
:| [LedgerPools]
ledgerPeerPools)

  fetchModeScript <- fmap (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
      , naMbTime                 = mustReplyTimeout
      , naPublicRoots            = publicRoots
        -- TODO: we haven't been using public root peers so far because we set
        -- `UseLedgerPeers 0`!
      , naConsensusMode
      , naBootstrapPeers         = bootstrapPeersDomain
      , naAddr                   = makeNtNAddr relay
      , naLocalRootPeers         = localRootPeers
      , naLedgerPeers            = ledgerPeerPoolsScript
      , naPeerTargets            = peerTargets
      , naDNSTimeoutScript       = dnsTimeout
      , naDNSLookupDelayScript   = dnsLookupDelay
      , naChainSyncExitOnBlockNo = chainSyncExitOnBlockNo
      , naChainSyncEarlyExit     = chainSyncEarlyExit
      , naPeerSharing            = peerSharing
      , naFetchModeScript        = fetchModeScript
      }
  where
    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 (Map Domain [(IP, TTL)])


-- | Make sure that the final domain map can resolve all the domains correctly.
--
fixupDomainMapScript :: RelayAccessInfos -> DomainMapScript -> DomainMapScript
fixupDomainMapScript :: RelayAccessInfos -> DomainMapScript -> DomainMapScript
fixupDomainMapScript RelayAccessInfos
relays (Script (a :: (Map Domain [(IP, TTL)], ScriptDelay)
a@(Map Domain [(IP, TTL)]
_, ScriptDelay
delay) :| [(Map Domain [(IP, TTL)], ScriptDelay)]
as)) =
    case [(Map Domain [(IP, TTL)], ScriptDelay)]
-> [(Map Domain [(IP, TTL)], ScriptDelay)]
forall a. [a] -> [a]
reverse [(Map Domain [(IP, TTL)], ScriptDelay)]
as of
      []                  -> NonEmpty (Map Domain [(IP, TTL)], ScriptDelay) -> DomainMapScript
forall a. NonEmpty a -> Script a
Script (NonEmpty (Map Domain [(IP, TTL)], ScriptDelay) -> DomainMapScript)
-> NonEmpty (Map Domain [(IP, TTL)], ScriptDelay)
-> DomainMapScript
forall a b. (a -> b) -> a -> b
$ (Map Domain [(IP, TTL)]
dnsMap, ScriptDelay
delay) (Map Domain [(IP, TTL)], ScriptDelay)
-> [(Map Domain [(IP, TTL)], ScriptDelay)]
-> NonEmpty (Map Domain [(IP, TTL)], ScriptDelay)
forall a. a -> [a] -> NonEmpty a
:| [(Map Domain [(IP, TTL)], ScriptDelay)]
as
      ((Map Domain [(IP, TTL)]
_, ScriptDelay
delay') : [(Map Domain [(IP, TTL)], ScriptDelay)]
as') -> NonEmpty (Map Domain [(IP, TTL)], ScriptDelay) -> DomainMapScript
forall a. NonEmpty a -> Script a
Script (NonEmpty (Map Domain [(IP, TTL)], ScriptDelay) -> DomainMapScript)
-> NonEmpty (Map Domain [(IP, TTL)], ScriptDelay)
-> DomainMapScript
forall a b. (a -> b) -> a -> b
$ (Map Domain [(IP, TTL)], ScriptDelay)
a (Map Domain [(IP, TTL)], ScriptDelay)
-> [(Map Domain [(IP, TTL)], ScriptDelay)]
-> NonEmpty (Map Domain [(IP, TTL)], ScriptDelay)
forall a. a -> [a] -> NonEmpty a
:| [(Map Domain [(IP, TTL)], ScriptDelay)]
-> [(Map Domain [(IP, TTL)], ScriptDelay)]
forall a. [a] -> [a]
reverse ((Map Domain [(IP, TTL)]
dnsMap, ScriptDelay
delay') (Map Domain [(IP, TTL)], ScriptDelay)
-> [(Map Domain [(IP, TTL)], ScriptDelay)]
-> [(Map Domain [(IP, TTL)], ScriptDelay)]
forall a. a -> [a] -> [a]
: [(Map Domain [(IP, TTL)], ScriptDelay)]
as')
  where
    dnsMap :: Map Domain [(IP, TTL)]
    dnsMap :: Map Domain [(IP, TTL)]
dnsMap = ([(IP, TTL)] -> [(IP, TTL)] -> [(IP, TTL)])
-> [(Domain, [(IP, TTL)])] -> Map Domain [(IP, TTL)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [(IP, TTL)] -> [(IP, TTL)] -> [(IP, TTL)]
forall a. [a] -> [a] -> [a]
(++)
      [ (Domain
domain, [(IP
ip, TTL
300)])
      | RelayDomainInfo Domain
domain IP
ip PortNumber
_ PeerAdvertise
_ <- RelayAccessInfos -> [RelayAccessInfo]
getRelayAccessInfos RelayAccessInfos
relays
      ]


-- | 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 :: RelayAccessInfos -> Gen DomainMapScript
genDomainMapScript :: RelayAccessInfos -> Gen DomainMapScript
genDomainMapScript RelayAccessInfos
relays = RelayAccessInfos -> DomainMapScript -> DomainMapScript
fixupDomainMapScript RelayAccessInfos
relays
                         (DomainMapScript -> DomainMapScript)
-> Gen DomainMapScript -> Gen DomainMapScript
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> Gen (Map Domain [(IP, TTL)], ScriptDelay) -> Gen DomainMapScript
forall a. Int -> Gen a -> Gen (Script a)
arbitraryScriptOf Int
10
                               ((,) (Map Domain [(IP, TTL)]
 -> ScriptDelay -> (Map Domain [(IP, TTL)], ScriptDelay))
-> Gen (Map Domain [(IP, TTL)])
-> Gen (ScriptDelay -> (Map Domain [(IP, TTL)], ScriptDelay))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Map Domain [(IP, TTL)])
genDomainMap Gen (ScriptDelay -> (Map Domain [(IP, TTL)], ScriptDelay))
-> Gen ScriptDelay -> Gen (Map Domain [(IP, TTL)], ScriptDelay)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen ScriptDelay
forall a. Arbitrary a => Gen a
arbitrary)
  where
    genDomainMap :: Gen (Map Domain [(IP, TTL)])
    genDomainMap :: Gen (Map Domain [(IP, TTL)])
genDomainMap = do
      rm <- Gen [Domain]
removedDomains
      md <- modifiedDomains
      return $ Map.fromList md `Map.union` foldr Map.delete dnsMap rm

    removedDomains :: Gen [Domain]
    removedDomains :: Gen [Domain]
removedDomains = do
        as <- Int -> Gen Bool -> Gen [Bool]
forall a. Int -> Gen a -> Gen [a]
vectorOf ([Domain] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Domain]
domains) ([(Int, Gen Bool)] -> Gen Bool
forall a. [(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)])
        return $ map fst . filter snd $ zip domains as
      where
        domains :: [Domain]
domains = Map Domain [(IP, TTL)] -> [Domain]
forall k a. Map k a -> [k]
Map.keys Map Domain [(IP, TTL)]
dnsMap

    modifiedDomains :: Gen [(Domain, [(IP, TTL)])]
    modifiedDomains :: Gen [(Domain, [(IP, TTL)])]
modifiedDomains = do
        as <- Int -> Gen Bool -> Gen [Bool]
forall a. Int -> Gen a -> Gen [a]
vectorOf ([Domain] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Domain]
domains) ([(Int, Gen Bool)] -> Gen Bool
forall a. [(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)])
        let ds :: [Domain]
            ds = ((Domain, Bool) -> Domain) -> [(Domain, Bool)] -> [Domain]
forall a b. (a -> b) -> [a] -> [b]
map (Domain, Bool) -> Domain
forall a b. (a, b) -> a
fst ([(Domain, Bool)] -> [Domain])
-> ([(Domain, Bool)] -> [(Domain, Bool)])
-> [(Domain, Bool)]
-> [Domain]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Domain, Bool) -> Bool) -> [(Domain, Bool)] -> [(Domain, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Domain, Bool) -> Bool
forall a b. (a, b) -> b
snd ([(Domain, Bool)] -> [Domain]) -> [(Domain, Bool)] -> [Domain]
forall a b. (a -> b) -> a -> b
$ [Domain] -> [Bool] -> [(Domain, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Domain]
domains [Bool]
as
        ips <- vectorOf (length ds) (case relays of
                                       IPv4RelayAccessInfos [RelayAccessInfo]
_ -> Gen IP
PeerSelection.genIPv4
                                       IPv6RelayAccessInfos [RelayAccessInfo]
_ -> Gen IP
PeerSelection.genIPv6)
        return $ zip ds ((\IP
a -> [(IP
a,TTL
ttl)]) <$> ips)
      where
        domains :: [Domain]
domains = Map Domain [(IP, TTL)] -> [Domain]
forall k a. Map k a -> [k]
Map.keys Map Domain [(IP, TTL)]
dnsMap

    dnsMap :: Map Domain [(IP, TTL)]
    dnsMap :: Map Domain [(IP, TTL)]
dnsMap = ([(IP, TTL)] -> [(IP, TTL)] -> [(IP, TTL)])
-> [(Domain, [(IP, TTL)])] -> Map Domain [(IP, TTL)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [(IP, TTL)] -> [(IP, TTL)] -> [(IP, TTL)]
forall a. [a] -> [a] -> [a]
(++)
      [ (Domain
domain, [(IP
ip, TTL
ttl)])
      | RelayDomainInfo Domain
domain IP
ip PortNumber
_ PeerAdvertise
_ <- RelayAccessInfos -> [RelayAccessInfo]
getRelayAccessInfos RelayAccessInfos
relays
      ]

    ttl :: TTL
ttl = TTL
300


shrinkDomainMapScript :: RelayAccessInfos -> DomainMapScript -> [DomainMapScript]
shrinkDomainMapScript :: RelayAccessInfos -> DomainMapScript -> [DomainMapScript]
shrinkDomainMapScript RelayAccessInfos
relays DomainMapScript
script =
    [Maybe DomainMapScript] -> [DomainMapScript]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe DomainMapScript] -> [DomainMapScript])
-> [Maybe DomainMapScript] -> [DomainMapScript]
forall a b. (a -> b) -> a -> b
$
        -- make sure `fixupDomainMapScript` didn't return something that's
        -- equal to the original `script`
        (\DomainMapScript
script' -> if DomainMapScript
script DomainMapScript -> DomainMapScript -> Bool
forall a. Eq a => a -> a -> Bool
== DomainMapScript
script' then Maybe DomainMapScript
forall a. Maybe a
Nothing else DomainMapScript -> Maybe DomainMapScript
forall a. a -> Maybe a
Just DomainMapScript
script')
     (DomainMapScript -> Maybe DomainMapScript)
-> (DomainMapScript -> DomainMapScript)
-> DomainMapScript
-> Maybe DomainMapScript
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  RelayAccessInfos -> DomainMapScript -> DomainMapScript
fixupDomainMapScript RelayAccessInfos
relays
    (DomainMapScript -> Maybe DomainMapScript)
-> [DomainMapScript] -> [Maybe DomainMapScript]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Map Domain [(IP, TTL)], ScriptDelay)
 -> [(Map Domain [(IP, TTL)], ScriptDelay)])
-> DomainMapScript -> [DomainMapScript]
forall a. (a -> [a]) -> Script a -> [Script a]
shrinkScriptWith ((Map Domain [(IP, TTL)] -> [Map Domain [(IP, TTL)]])
-> (ScriptDelay -> [ScriptDelay])
-> (Map Domain [(IP, TTL)], ScriptDelay)
-> [(Map Domain [(IP, TTL)], ScriptDelay)]
forall a b. (a -> [a]) -> (b -> [b]) -> (a, b) -> [(a, b)]
shrinkTuple Map Domain [(IP, TTL)] -> [Map Domain [(IP, TTL)]]
forall a b. Ord a => Map a b -> [Map a b]
shrinkMap_ ScriptDelay -> [ScriptDelay]
forall a. Arbitrary a => a -> [a]
shrink) DomainMapScript
script
  where
    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

    shrinkTuple :: (a -> [a]) -> (b -> [b]) -> (a, b) -> [(a, b)]
    shrinkTuple :: forall a b. (a -> [a]) -> (b -> [b]) -> (a, b) -> [(a, b)]
shrinkTuple a -> [a]
f b -> [b]
g (a
a, b
b) = [(a
a', b
b) | a
a' <- a -> [a]
f a
a]
                          [(a, b)] -> [(a, b)] -> [(a, b)]
forall a. [a] -> [a] -> [a]
++ [(a
a, b
b') | b
b' <- b -> [b]
g b
b]

--
-- 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 -> String
show (DiffusionScript SimArgs
args DomainMapScript
dnsScript [(NodeArgs, [Command])]
nodes) =
      String
"DiffusionScript (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SimArgs -> String
forall a. Show a => a -> String
show SimArgs
args String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ DomainMapScript -> String
forall a. Show a => a -> String
show DomainMapScript
dnsScript String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(NodeArgs, [Command])] -> String
forall a. Show a => a -> String
show [(NodeArgs, [Command])]
nodes

-- | Information describing how nodes can be accessed.
--
data RelayAccessInfo
    = RelayAddrInfo          IP PortNumber PeerAdvertise
    -- ^ relays available using ip / port pair
    | RelayDomainInfo Domain IP PortNumber PeerAdvertise
    -- ^ relays available either using the given domain.
  deriving (Int -> RelayAccessInfo -> ShowS
[RelayAccessInfo] -> ShowS
RelayAccessInfo -> String
(Int -> RelayAccessInfo -> ShowS)
-> (RelayAccessInfo -> String)
-> ([RelayAccessInfo] -> ShowS)
-> Show RelayAccessInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RelayAccessInfo -> ShowS
showsPrec :: Int -> RelayAccessInfo -> ShowS
$cshow :: RelayAccessInfo -> String
show :: RelayAccessInfo -> String
$cshowList :: [RelayAccessInfo] -> ShowS
showList :: [RelayAccessInfo] -> ShowS
Show, RelayAccessInfo -> RelayAccessInfo -> Bool
(RelayAccessInfo -> RelayAccessInfo -> Bool)
-> (RelayAccessInfo -> RelayAccessInfo -> Bool)
-> Eq RelayAccessInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RelayAccessInfo -> RelayAccessInfo -> Bool
== :: RelayAccessInfo -> RelayAccessInfo -> Bool
$c/= :: RelayAccessInfo -> RelayAccessInfo -> Bool
/= :: RelayAccessInfo -> RelayAccessInfo -> Bool
Eq)

genRelayAccessInfo :: Gen IP
                   -> Gen RelayAccessInfo
genRelayAccessInfo :: Gen IP -> Gen RelayAccessInfo
genRelayAccessInfo Gen IP
genIP =
  [Gen RelayAccessInfo] -> Gen RelayAccessInfo
forall a. [Gen a] -> Gen a
oneof [ IP -> PortNumber -> PeerAdvertise -> RelayAccessInfo
RelayAddrInfo (IP -> PortNumber -> PeerAdvertise -> RelayAccessInfo)
-> Gen IP -> Gen (PortNumber -> PeerAdvertise -> RelayAccessInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen IP
genIP
                        Gen (PortNumber -> PeerAdvertise -> RelayAccessInfo)
-> Gen PortNumber -> Gen (PeerAdvertise -> RelayAccessInfo)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> PortNumber) -> Gen Int -> Gen PortNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Gen Int
forall a. Arbitrary a => Gen a
arbitrary :: Gen Int))
                        Gen (PeerAdvertise -> RelayAccessInfo)
-> Gen PeerAdvertise -> Gen RelayAccessInfo
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen PeerAdvertise
forall a. Arbitrary a => Gen a
arbitrary
        , (\(DomainAccessPoint Domain
domain PortNumber
port) IP
ip PeerAdvertise
advertise -> Domain -> IP -> PortNumber -> PeerAdvertise -> RelayAccessInfo
RelayDomainInfo Domain
domain IP
ip PortNumber
port PeerAdvertise
advertise)
                        (DomainAccessPoint -> IP -> PeerAdvertise -> RelayAccessInfo)
-> Gen DomainAccessPoint
-> Gen (IP -> PeerAdvertise -> RelayAccessInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen DomainAccessPoint
forall a. Arbitrary a => Gen a
arbitrary
                        Gen (IP -> PeerAdvertise -> RelayAccessInfo)
-> Gen IP -> Gen (PeerAdvertise -> RelayAccessInfo)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen IP
genIP
                        Gen (PeerAdvertise -> RelayAccessInfo)
-> Gen PeerAdvertise -> Gen RelayAccessInfo
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen PeerAdvertise
forall a. Arbitrary a => Gen a
arbitrary
        ]

makeRelayAccessPoint :: RelayAccessInfo -> RelayAccessPoint
makeRelayAccessPoint :: RelayAccessInfo -> RelayAccessPoint
makeRelayAccessPoint (RelayAddrInfo IP
ip PortNumber
port PeerAdvertise
_) = IP -> PortNumber -> RelayAccessPoint
RelayAccessAddress IP
ip PortNumber
port
makeRelayAccessPoint (RelayDomainInfo Domain
domain IP
_ip PortNumber
port PeerAdvertise
_) = Domain -> PortNumber -> RelayAccessPoint
RelayAccessDomain Domain
domain PortNumber
port

makeNtNAddr :: RelayAccessInfo -> NtNAddr
makeNtNAddr :: RelayAccessInfo -> NtNAddr
makeNtNAddr (RelayAddrInfo IP
ip PortNumber
port PeerAdvertise
_)        = NtNAddr_ -> NtNAddr
forall addr. addr -> TestAddress addr
TestAddress (IP -> PortNumber -> NtNAddr_
IPAddr IP
ip PortNumber
port)
makeNtNAddr (RelayDomainInfo Domain
_dns IP
ip PortNumber
port PeerAdvertise
_) = NtNAddr_ -> NtNAddr
forall addr. addr -> TestAddress addr
TestAddress (IP -> PortNumber -> NtNAddr_
IPAddr IP
ip PortNumber
port)

data RelayAccessInfos
    -- IPv4 only network
  = IPv4RelayAccessInfos { RelayAccessInfos -> [RelayAccessInfo]
getRelayAccessInfos :: [RelayAccessInfo] }
    -- IPv6 only network
  | IPv6RelayAccessInfos { getRelayAccessInfos :: [RelayAccessInfo] }
  deriving Int -> RelayAccessInfos -> ShowS
[RelayAccessInfos] -> ShowS
RelayAccessInfos -> String
(Int -> RelayAccessInfos -> ShowS)
-> (RelayAccessInfos -> String)
-> ([RelayAccessInfos] -> ShowS)
-> Show RelayAccessInfos
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RelayAccessInfos -> ShowS
showsPrec :: Int -> RelayAccessInfos -> ShowS
$cshow :: RelayAccessInfos -> String
show :: RelayAccessInfos -> String
$cshowList :: [RelayAccessInfos] -> ShowS
showList :: [RelayAccessInfos] -> ShowS
Show

fixupRelayAccessInfos :: [RelayAccessInfo] -> [RelayAccessInfo]
fixupRelayAccessInfos :: [RelayAccessInfo] -> [RelayAccessInfo]
fixupRelayAccessInfos [RelayAccessInfo]
as = RelayAccessInfo -> RelayAccessInfo
f (RelayAccessInfo -> RelayAccessInfo)
-> [RelayAccessInfo] -> [RelayAccessInfo]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RelayAccessInfo]
as
    where
      -- map domains to the same port number
      m :: Map Domain PortNumber
m = [(Domain, PortNumber)] -> Map Domain PortNumber
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Domain
domain, PortNumber
port)
                       | RelayDomainInfo Domain
domain IP
_ PortNumber
port PeerAdvertise
_ <- [RelayAccessInfo]
as
                       ]

      f :: RelayAccessInfo -> RelayAccessInfo
f a :: RelayAccessInfo
a@RelayAddrInfo {} = RelayAccessInfo
a
      f (RelayDomainInfo Domain
domain IP
ip PortNumber
_ PeerAdvertise
advertise) = Domain -> IP -> PortNumber -> PeerAdvertise -> RelayAccessInfo
RelayDomainInfo Domain
domain IP
ip (Map Domain PortNumber
m Map Domain PortNumber -> Domain -> PortNumber
forall k a. Ord k => Map k a -> k -> a
Map.! Domain
domain) PeerAdvertise
advertise


-- Generate a list of either IPv4 only or IPv6 only `RelayAccessInfo`.  All
-- `IP`'s using the same domain name are guaranteed to use the same port
-- number.
instance Arbitrary RelayAccessInfos where
    arbitrary :: Gen RelayAccessInfos
arbitrary = [Gen RelayAccessInfos] -> Gen RelayAccessInfos
forall a. [Gen a] -> Gen a
oneof
      [ do -- Limit the number of nodes to run in Simulation in order to limit
           -- simulation execution (real) time.
           size <- (Int, Int) -> Gen Int
chooseInt (Int
1,Int
3)
           IPv4RelayAccessInfos . fixupRelayAccessInfos
             <$> vectorOf size (genRelayAccessInfo PeerSelection.genIPv4)

      , do -- Limit the number of nodes to run in Simulation in order to limit
           -- simulation execution (real) time.
           size <- (Int, Int) -> Gen Int
chooseInt (Int
1,Int
3)
           IPv6RelayAccessInfos . fixupRelayAccessInfos
             <$> vectorOf size (genRelayAccessInfo PeerSelection.genIPv6)
      ]

    shrink :: RelayAccessInfos -> [RelayAccessInfos]
shrink (IPv4RelayAccessInfos [RelayAccessInfo]
as) = [RelayAccessInfo] -> RelayAccessInfos
IPv4RelayAccessInfos ([RelayAccessInfo] -> RelayAccessInfos)
-> ([RelayAccessInfo] -> [RelayAccessInfo])
-> [RelayAccessInfo]
-> RelayAccessInfos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RelayAccessInfo] -> [RelayAccessInfo]
fixupRelayAccessInfos
                                   ([RelayAccessInfo] -> RelayAccessInfos)
-> [[RelayAccessInfo]] -> [RelayAccessInfos]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RelayAccessInfo -> [RelayAccessInfo])
-> [RelayAccessInfo] -> [[RelayAccessInfo]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([RelayAccessInfo] -> RelayAccessInfo -> [RelayAccessInfo]
forall a b. a -> b -> a
const []) [RelayAccessInfo]
as
    shrink (IPv6RelayAccessInfos [RelayAccessInfo]
as) = [RelayAccessInfo] -> RelayAccessInfos
IPv6RelayAccessInfos ([RelayAccessInfo] -> RelayAccessInfos)
-> ([RelayAccessInfo] -> [RelayAccessInfo])
-> [RelayAccessInfo]
-> RelayAccessInfos
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RelayAccessInfo] -> [RelayAccessInfo]
fixupRelayAccessInfos
                                   ([RelayAccessInfo] -> RelayAccessInfos)
-> [[RelayAccessInfo]] -> [RelayAccessInfos]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (RelayAccessInfo -> [RelayAccessInfo])
-> [RelayAccessInfo] -> [[RelayAccessInfo]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([RelayAccessInfo] -> RelayAccessInfo -> [RelayAccessInfo]
forall a b. a -> b -> a
const []) [RelayAccessInfo]
as



-- | Relays access info and dns script.
--
data RelayAccessInfosWithDNS = RelayAccessInfosWithDNS RelayAccessInfos DomainMapScript
  deriving Int -> RelayAccessInfosWithDNS -> ShowS
[RelayAccessInfosWithDNS] -> ShowS
RelayAccessInfosWithDNS -> String
(Int -> RelayAccessInfosWithDNS -> ShowS)
-> (RelayAccessInfosWithDNS -> String)
-> ([RelayAccessInfosWithDNS] -> ShowS)
-> Show RelayAccessInfosWithDNS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RelayAccessInfosWithDNS -> ShowS
showsPrec :: Int -> RelayAccessInfosWithDNS -> ShowS
$cshow :: RelayAccessInfosWithDNS -> String
show :: RelayAccessInfosWithDNS -> String
$cshowList :: [RelayAccessInfosWithDNS] -> ShowS
showList :: [RelayAccessInfosWithDNS] -> ShowS
Show


instance Arbitrary RelayAccessInfosWithDNS where
    arbitrary :: Gen RelayAccessInfosWithDNS
arbitrary =
      (Gen RelayAccessInfosWithDNS
 -> (RelayAccessInfosWithDNS -> Bool)
 -> Gen RelayAccessInfosWithDNS)
-> (RelayAccessInfosWithDNS -> Bool)
-> Gen RelayAccessInfosWithDNS
-> Gen RelayAccessInfosWithDNS
forall a b c. (a -> b -> c) -> b -> a -> c
flip Gen RelayAccessInfosWithDNS
-> (RelayAccessInfosWithDNS -> Bool) -> Gen RelayAccessInfosWithDNS
forall a. Gen a -> (a -> Bool) -> Gen a
suchThat (\(RelayAccessInfosWithDNS RelayAccessInfos
infos DomainMapScript
_)
                      -> [RelayAccessInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (RelayAccessInfos -> [RelayAccessInfo]
getRelayAccessInfos RelayAccessInfos
infos) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2) (Gen RelayAccessInfosWithDNS -> Gen RelayAccessInfosWithDNS)
-> Gen RelayAccessInfosWithDNS -> Gen RelayAccessInfosWithDNS
forall a b. (a -> b) -> a -> b
$ do
        infos <- Gen RelayAccessInfos
forall a. Arbitrary a => Gen a
arbitrary
        domainMapScript <- genDomainMapScript infos
        return $ RelayAccessInfosWithDNS infos domainMapScript

    shrink :: RelayAccessInfosWithDNS -> [RelayAccessInfosWithDNS]
shrink (RelayAccessInfosWithDNS RelayAccessInfos
infos DomainMapScript
dnsMapScript) =
      [ RelayAccessInfos -> DomainMapScript -> RelayAccessInfosWithDNS
RelayAccessInfosWithDNS RelayAccessInfos
infos (RelayAccessInfos -> DomainMapScript -> DomainMapScript
fixupDomainMapScript RelayAccessInfos
infos' DomainMapScript
dnsMapScript)
      | RelayAccessInfos
infos' <- RelayAccessInfos -> [RelayAccessInfos]
forall a. Arbitrary a => a -> [a]
shrink RelayAccessInfos
infos
      , [RelayAccessInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (RelayAccessInfos -> [RelayAccessInfo]
getRelayAccessInfos RelayAccessInfos
infos') Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
      ]
      [RelayAccessInfosWithDNS]
-> [RelayAccessInfosWithDNS] -> [RelayAccessInfosWithDNS]
forall a. [a] -> [a] -> [a]
++
      [ RelayAccessInfos -> DomainMapScript -> RelayAccessInfosWithDNS
RelayAccessInfosWithDNS RelayAccessInfos
infos DomainMapScript
dnsMapScript'
      | DomainMapScript
dnsMapScript' <- RelayAccessInfos -> DomainMapScript -> [DomainMapScript]
shrinkDomainMapScript RelayAccessInfos
infos DomainMapScript
dnsMapScript
      ]


genDiffusionScript :: ([RelayAccessInfo]
                        -> RelayAccessInfo
                        -> Gen [( HotValency
                                , WarmValency
                                , Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
                   -> RelayAccessInfosWithDNS
                   -> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genDiffusionScript :: ([RelayAccessInfo]
 -> RelayAccessInfo
 -> Gen
      [(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> RelayAccessInfosWithDNS
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genDiffusionScript [RelayAccessInfo]
-> RelayAccessInfo
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
genLocalRootPeers
                   (RelayAccessInfosWithDNS RelayAccessInfos
relays DomainMapScript
dnsMapScript)
                   = do
    let simArgs :: SimArgs
simArgs = Int -> SimArgs
mainnetSimArgs ([RelayAccessInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RelayAccessInfo]
relays')
    nodesWithCommands <- (RelayAccessInfo -> Gen (NodeArgs, [Command]))
-> [RelayAccessInfo] -> Gen [(NodeArgs, [Command])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM RelayAccessInfo -> Gen (NodeArgs, [Command])
go ((RelayAccessInfo -> RelayAccessInfo -> Bool)
-> [RelayAccessInfo] -> [RelayAccessInfo]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (IP -> IP -> Bool
forall a. Eq a => a -> a -> Bool
(==) (IP -> IP -> Bool)
-> (RelayAccessInfo -> IP)
-> RelayAccessInfo
-> RelayAccessInfo
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` RelayAccessInfo -> IP
getRelayIP) [RelayAccessInfo]
relays')
    return (simArgs, dnsMapScript, nodesWithCommands)
  where
    getRelayIP :: RelayAccessInfo -> IP
    getRelayIP :: RelayAccessInfo -> IP
getRelayIP (RelayAddrInfo IP
ip PortNumber
_ PeerAdvertise
_)     = IP
ip
    getRelayIP (RelayDomainInfo Domain
_ IP
ip PortNumber
_ PeerAdvertise
_) = IP
ip

    relays' :: [RelayAccessInfo]
    relays' :: [RelayAccessInfo]
relays' = RelayAccessInfos -> [RelayAccessInfo]
getRelayAccessInfos RelayAccessInfos
relays

    go :: RelayAccessInfo -> Gen (NodeArgs, [Command])
    go :: RelayAccessInfo -> Gen (NodeArgs, [Command])
go RelayAccessInfo
relay = do
      let otherRelays :: [RelayAccessInfo]
otherRelays  = RelayAccessInfo
relay RelayAccessInfo -> [RelayAccessInfo] -> [RelayAccessInfo]
forall a. Eq a => a -> [a] -> [a]
`delete` [RelayAccessInfo]
relays'
          minConnected :: Int
minConnected = Int
3 Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` ([RelayAccessInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RelayAccessInfo]
relays' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      localRts <- [RelayAccessInfo]
-> RelayAccessInfo
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
genLocalRootPeers [RelayAccessInfo]
otherRelays RelayAccessInfo
relay
      nodeArgs <- genNodeArgs relays' minConnected localRts relay
      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 :: RelayAccessInfosWithDNS
                         -> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genNonHotDiffusionScript :: RelayAccessInfosWithDNS
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genNonHotDiffusionScript = ([RelayAccessInfo]
 -> RelayAccessInfo
 -> Gen
      [(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> RelayAccessInfosWithDNS
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genDiffusionScript [RelayAccessInfo]
-> RelayAccessInfo
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
genLocalRootPeers
  where
    -- | Generate Local Root Peers
    --
    genLocalRootPeers :: [RelayAccessInfo]
                      -> RelayAccessInfo
                      -> Gen [( HotValency
                              , WarmValency
                              , Map RelayAccessPoint (LocalRootConfig PeerTrustable)
                              )]
    genLocalRootPeers :: [RelayAccessInfo]
-> RelayAccessInfo
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
genLocalRootPeers [RelayAccessInfo]
relays RelayAccessInfo
_relay = (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 = [RelayAccessInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RelayAccessInfo]
relays
          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

      peerAdvertise <- vectorOf size arbitrary

      let relaysAdv = [RelayAccessPoint]
-> [LocalRootConfig PeerTrustable]
-> [(RelayAccessPoint, LocalRootConfig PeerTrustable)]
forall a b. [a] -> [b] -> [(a, b)]
zip (RelayAccessInfo -> RelayAccessPoint
makeRelayAccessPoint (RelayAccessInfo -> RelayAccessPoint)
-> [RelayAccessInfo] -> [RelayAccessPoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RelayAccessInfo]
relays) [LocalRootConfig PeerTrustable]
peerAdvertise
          relayGroups = Int
-> [(RelayAccessPoint, LocalRootConfig PeerTrustable)]
-> [[(RelayAccessPoint, LocalRootConfig PeerTrustable)]]
forall a. Int -> [a] -> [[a]]
divvy Int
sizePerGroup [(RelayAccessPoint, LocalRootConfig PeerTrustable)]
relaysAdv
          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))
-> [[(RelayAccessPoint, LocalRootConfig PeerTrustable)]]
-> [Map RelayAccessPoint (LocalRootConfig PeerTrustable)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(RelayAccessPoint, LocalRootConfig PeerTrustable)]]
relayGroups

      target <- forM relayGroups
                    (\[(RelayAccessPoint, LocalRootConfig PeerTrustable)]
x -> if [(RelayAccessPoint, LocalRootConfig PeerTrustable)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RelayAccessPoint, 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 ([(RelayAccessPoint, LocalRootConfig PeerTrustable)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(RelayAccessPoint, 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) -> [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))]
localRootPeers
             ]


-- | 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 :: RelayAccessInfosWithDNS
                      -> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genHotDiffusionScript :: RelayAccessInfosWithDNS
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genHotDiffusionScript = ([RelayAccessInfo]
 -> RelayAccessInfo
 -> Gen
      [(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> RelayAccessInfosWithDNS
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genDiffusionScript [RelayAccessInfo]
-> RelayAccessInfo
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
genLocalRootPeers
    where
      -- | Generate Local Root Peers.  This only generates 1 group
      --
      genLocalRootPeers :: [RelayAccessInfo]
                        -> RelayAccessInfo
                        -> Gen [( HotValency
                                , WarmValency
                                , Map RelayAccessPoint (LocalRootConfig PeerTrustable)
                                )]
      genLocalRootPeers :: [RelayAccessInfo]
-> RelayAccessInfo
-> Gen
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
genLocalRootPeers [RelayAccessInfo]
relays RelayAccessInfo
_relay = (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
        let size :: Int
size = [RelayAccessInfo] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [RelayAccessInfo]
relays

        peerAdvertise <- Int
-> Gen (LocalRootConfig PeerTrustable)
-> Gen [LocalRootConfig PeerTrustable]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
size Gen (LocalRootConfig PeerTrustable)
forall a. Arbitrary a => Gen a
arbitrary

        let relaysAdv      = [RelayAccessPoint]
-> [LocalRootConfig PeerTrustable]
-> [(RelayAccessPoint, LocalRootConfig PeerTrustable)]
forall a b. [a] -> [b] -> [(a, b)]
zip (RelayAccessInfo -> RelayAccessPoint
makeRelayAccessPoint (RelayAccessInfo -> RelayAccessPoint)
-> [RelayAccessInfo] -> [RelayAccessPoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RelayAccessInfo]
relays) [LocalRootConfig PeerTrustable]
peerAdvertise
            relayGroupsMap = [(RelayAccessPoint, LocalRootConfig PeerTrustable)]
-> Map RelayAccessPoint (LocalRootConfig PeerTrustable)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RelayAccessPoint, LocalRootConfig PeerTrustable)]
relaysAdv
            warmTarget         = [(RelayAccessPoint, LocalRootConfig PeerTrustable)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(RelayAccessPoint, 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) -> [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))]
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. [(Int, Gen a)] -> Gen a
frequency [ (Int
1, Gen RelayAccessInfosWithDNS
forall a. Arbitrary a => Gen a
arbitrary Gen RelayAccessInfosWithDNS
-> (RelayAccessInfosWithDNS
    -> 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
>>= RelayAccessInfosWithDNS
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genNonHotDiffusionScript)
                          , (Int
1, Gen RelayAccessInfosWithDNS
forall a. Arbitrary a => Gen a
arbitrary Gen RelayAccessInfosWithDNS
-> (RelayAccessInfosWithDNS
    -> 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
>>= RelayAccessInfosWithDNS
-> Gen (SimArgs, DomainMapScript, [(NodeArgs, [Command])])
genHotDiffusionScript)
                          ]
  -- TODO: shrink dns map
  -- TODO: we should write more careful shrinking than recursively shrinking
  -- `DiffusionScript`!
  shrink :: DiffusionScript -> [DiffusionScript]
shrink (DiffusionScript SimArgs
_ DomainMapScript
_ []) = []
  shrink (DiffusionScript SimArgs
sargs DomainMapScript
dnsMap ((NodeArgs
nargs, [Command]
cmds):[(NodeArgs, [Command])]
s)) = do
    shrinkedCmds <- [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
    DiffusionScript sa dnsMap' ss <- shrink (DiffusionScript sargs dnsMap s)
    return (DiffusionScript sa dnsMap' ((nargs, shrinkedCmds) : ss))
    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

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

-- | 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 -> ShowS
[HotDiffusionScript] -> ShowS
HotDiffusionScript -> String
(Int -> HotDiffusionScript -> ShowS)
-> (HotDiffusionScript -> String)
-> ([HotDiffusionScript] -> ShowS)
-> Show HotDiffusionScript
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HotDiffusionScript -> ShowS
showsPrec :: Int -> HotDiffusionScript -> ShowS
$cshow :: HotDiffusionScript -> String
show :: HotDiffusionScript -> String
$cshowList :: [HotDiffusionScript] -> ShowS
showList :: [HotDiffusionScript] -> ShowS
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 RelayAccessInfosWithDNS
forall a. Arbitrary a => Gen a
arbitrary Gen RelayAccessInfosWithDNS
-> (RelayAccessInfosWithDNS
    -> 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
>>= RelayAccessInfosWithDNS
-> 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)) =
  String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Failed with cmds: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Command] -> String
forall a. Show a => a -> String
show [Command]
cmds String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"fixupCommands cmds = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Command] -> String
forall a. Show a => a -> String
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)) =
  String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Failed with cmds: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Command] -> String
forall a. Show a => a -> String
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
_)   ->
          String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Invalid sequence: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Command -> String
forall a. Show a => a -> String
show Command
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Command -> String
forall a. Show a => a -> String
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
_)                 ->
          String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Invalid sequence: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Command -> String
forall a. Show a => a -> String
show Command
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Command -> String
forall a. Show a => a -> String
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))]
_)        ->
          String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Invalid sequence: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Command -> String
forall a. Show a => a -> String
show Command
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Command -> String
forall a. Show a => a -> String
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
_) ->
          String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Invalid sequence: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Command -> String
forall a. Show a => a -> String
show Command
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Command -> String
forall a. Show a => a -> String
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
  deriving (Int -> DiffusionSimulationTrace -> ShowS
[DiffusionSimulationTrace] -> ShowS
DiffusionSimulationTrace -> String
(Int -> DiffusionSimulationTrace -> ShowS)
-> (DiffusionSimulationTrace -> String)
-> ([DiffusionSimulationTrace] -> ShowS)
-> Show DiffusionSimulationTrace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DiffusionSimulationTrace -> ShowS
showsPrec :: Int -> DiffusionSimulationTrace -> ShowS
$cshow :: DiffusionSimulationTrace -> String
show :: DiffusionSimulationTrace -> String
$cshowList :: [DiffusionSimulationTrace] -> ShowS
showList :: [DiffusionSimulationTrace] -> ShowS
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 SomeException)
    | DiffusionPublicRootPeerTrace TracePublicRootPeers
    | DiffusionLedgerPeersTrace TraceLedgerPeers
    | DiffusionPeerSelectionTrace (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))
    | DiffusionDiffusionSimulationTrace DiffusionSimulationTrace
    | DiffusionConnectionManagerTransitionTrace
        (AbstractTransitionTrace CM.ConnStateId)
    | DiffusionInboundGovernorTransitionTrace
        (RemoteTransitionTrace NtNAddr)
    | DiffusionInboundGovernorTrace (IG.Trace NtNAddr)
    | DiffusionServerTrace (Server.Trace NtNAddr)
    | DiffusionFetchTrace (TraceFetchClientState BlockHeader)
    | DiffusionDebugTrace String
    deriving (Int -> DiffusionTestTrace -> ShowS
[DiffusionTestTrace] -> ShowS
DiffusionTestTrace -> String
(Int -> DiffusionTestTrace -> ShowS)
-> (DiffusionTestTrace -> String)
-> ([DiffusionTestTrace] -> ShowS)
-> Show DiffusionTestTrace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DiffusionTestTrace -> ShowS
showsPrec :: Int -> DiffusionTestTrace -> ShowS
$cshow :: DiffusionTestTrace -> String
show :: DiffusionTestTrace -> String
$cshowList :: [DiffusionTestTrace] -> ShowS
showList :: [DiffusionTestTrace] -> ShowS
Show)


-- | A debug tracer which embeds events in DiffusionTestTrace.
--
iosimTracer :: forall s a.
              ( Show a
              , Typeable a
              )
            => Tracer (IOSim s) (WithTime (WithName NtNAddr a))
iosimTracer :: forall s a.
(Show a, Typeable a) =>
Tracer (IOSim s) (WithTime (WithName NtNAddr a))
iosimTracer = (WithTime (WithName NtNAddr a) -> IOSim s ())
-> Tracer (IOSim s) (WithTime (WithName NtNAddr a))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer WithTime (WithName NtNAddr a) -> IOSim s ()
forall a s. Typeable a => a -> IOSim s ()
traceM Tracer (IOSim s) (WithTime (WithName NtNAddr a))
-> Tracer (IOSim s) (WithTime (WithName NtNAddr a))
-> Tracer (IOSim s) (WithTime (WithName NtNAddr a))
forall a. Semigroup a => a -> a -> a
<> Tracer (IOSim s) (WithTime (WithName NtNAddr a))
forall a (m :: * -> *). (Show a, MonadSay m) => Tracer m a
sayTracer

-- | 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 (Map Domain [(IP, TTL)])
-> StrictTVar m (Map Domain [(IP, TTL)])
forall (m :: * -> *) a. LazyTVar m a -> StrictTVar m a
fromLazyTVar (LazyTVar m (Map Domain [(IP, TTL)])
 -> StrictTVar m (Map Domain [(IP, TTL)]))
-> m (LazyTVar m (Map Domain [(IP, TTL)]))
-> m (StrictTVar m (Map Domain [(IP, TTL)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer m (Map Domain [(IP, TTL)])
-> DomainMapScript -> m (LazyTVar m (Map Domain [(IP, TTL)]))
forall (m :: * -> *) a.
(MonadAsync m, MonadDelay m) =>
Tracer m a -> TimedScript a -> m (TVar m a)
playTimedScript Tracer m (Map Domain [(IP, TTL)])
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer DomainMapScript
dnsMapScript
        withAsyncAll
          (map ((\(NodeArgs
args, [Command]
commands) -> Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> Snocket m (FD m NtNAddr) NtNAddr
-> Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> StrictTVar m (Map Domain [(IP, TTL)])
-> SimArgs
-> NodeArgs
-> ConnStateIdSupply m
-> [Command]
-> m Void
runCommand Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
forall a. Maybe a
Nothing Snocket m (FD m NtNAddr) NtNAddr
ntnSnocket Snocket m (FD m (TestAddress Int)) (TestAddress Int)
ntcSnocket StrictTVar m (Map Domain [(IP, TTL)])
dnsMapVar SimArgs
simArgs NodeArgs
args ConnStateIdSupply m
connStateIdSupply [Command]
commands))
               nodeArgs)
          $ \[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 -> String -> WithName NtNAddr String
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 (String -> IP
forall a. Read a => String -> a
read String
"0.0.0.0") PortNumber
0) Maybe NtNAddr
l) (SnocketTrace m NtNAddr -> String
forall a. Show a => a -> String
show SnocketTrace m NtNAddr
a))
       (WithAddr NtNAddr (SnocketTrace m NtNAddr)
 -> WithName NtNAddr String)
-> Tracer m (WithName NtNAddr String)
-> 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 String))
-> Tracer m (WithName NtNAddr String)
forall (m :: * -> *) a.
MonadMonotonicTime m =>
Tracer m (WithTime a) -> Tracer m a
tracerWithTime Tracer m (WithTime (WithName NtNAddr String))
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer

    -- | Runs a single node according to a list of commands.
    runCommand
      :: Maybe ( Async m Void
               , StrictTVar m [( HotValency
                               , WarmValency
                               , Map RelayAccessPoint (LocalRootConfig PeerTrustable)
                               )])
         -- ^ If the node is running and corresponding local root configuration
         -- TVar.
      -> Snocket m (FD m NtNAddr) NtNAddr
        -- ^ Node to node Snocket
      -> Snocket m (FD m NtCAddr) NtCAddr
        -- ^ Node to client Snocket
      -> StrictTVar m (Map Domain [(IP, TTL)])
        -- ^ 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
      -> [Command] -- ^ List of commands/actions to perform for a single node
      -> m Void
    runCommand :: Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> Snocket m (FD m NtNAddr) NtNAddr
-> Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> StrictTVar m (Map Domain [(IP, TTL)])
-> SimArgs
-> NodeArgs
-> ConnStateIdSupply m
-> [Command]
-> m Void
runCommand Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
Nothing Snocket m (FD m NtNAddr) NtNAddr
ntnSnocket Snocket m (FD m (TestAddress Int)) (TestAddress Int)
ntcSnocket StrictTVar m (Map Domain [(IP, TTL)])
dnsMapVar SimArgs
sArgs NodeArgs
nArgs ConnStateIdSupply m
connStateIdSupply [] = 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 (NodeArgs -> NtNAddr
naAddr NodeArgs
nArgs)) DiffusionSimulationTrace
TrRunning
      Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> Snocket m (FD m NtNAddr) NtNAddr
-> Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> StrictTVar m (Map Domain [(IP, TTL)])
-> SimArgs
-> NodeArgs
-> ConnStateIdSupply m
-> [Command]
-> m Void
runCommand Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
forall a. Maybe a
Nothing Snocket m (FD m NtNAddr) NtNAddr
ntnSnocket Snocket m (FD m (TestAddress Int)) (TestAddress Int)
ntcSnocket StrictTVar m (Map Domain [(IP, TTL)])
dnsMapVar SimArgs
sArgs NodeArgs
nArgs ConnStateIdSupply m
connStateIdSupply []
    runCommand (Just (Async m Void
_, StrictTVar
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
_)) Snocket m (FD m NtNAddr) NtNAddr
ntnSnocket Snocket m (FD m (TestAddress Int)) (TestAddress Int)
ntcSnocket StrictTVar m (Map Domain [(IP, TTL)])
dMapVarMap SimArgs
sArgs NodeArgs
nArgs ConnStateIdSupply m
connStateIdSupply [] = 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 (NodeArgs -> NtNAddr
naAddr NodeArgs
nArgs)) DiffusionSimulationTrace
TrRunning
      Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> Snocket m (FD m NtNAddr) NtNAddr
-> Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> StrictTVar m (Map Domain [(IP, TTL)])
-> SimArgs
-> NodeArgs
-> ConnStateIdSupply m
-> [Command]
-> m Void
runCommand Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
forall a. Maybe a
Nothing Snocket m (FD m NtNAddr) NtNAddr
ntnSnocket Snocket m (FD m (TestAddress Int)) (TestAddress Int)
ntcSnocket StrictTVar m (Map Domain [(IP, TTL)])
dMapVarMap SimArgs
sArgs NodeArgs
nArgs ConnStateIdSupply m
connStateIdSupply []
    runCommand Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
Nothing Snocket m (FD m NtNAddr) NtNAddr
ntnSnocket Snocket m (FD m (TestAddress Int)) (TestAddress Int)
ntcSnocket StrictTVar m (Map Domain [(IP, TTL)])
dnsMapVar SimArgs
sArgs NodeArgs
nArgs ConnStateIdSupply m
connStateIdSupply
               (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 (NodeArgs -> NtNAddr
naAddr NodeArgs
nArgs)) 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 ntnSnocket ntcSnocket connStateIdSupply lrpVar dnsMapVar) $ \Async m Void
nodeAsync ->
        Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
-> Snocket m (FD m NtNAddr) NtNAddr
-> Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> StrictTVar m (Map Domain [(IP, TTL)])
-> SimArgs
-> NodeArgs
-> ConnStateIdSupply m
-> [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)) Snocket m (FD m NtNAddr) NtNAddr
ntnSnocket Snocket m (FD m (TestAddress Int)) (TestAddress Int)
ntcSnocket StrictTVar m (Map Domain [(IP, TTL)])
dnsMapVar SimArgs
sArgs NodeArgs
nArgs ConnStateIdSupply m
connStateIdSupply [Command]
cs
    runCommand Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
_ Snocket m (FD m NtNAddr) NtNAddr
_ Snocket m (FD m (TestAddress Int)) (TestAddress Int)
_ StrictTVar m (Map Domain [(IP, TTL)])
_ SimArgs
_ NodeArgs
_ ConnStateIdSupply m
_ (JoinNetwork DiffTime
_:[Command]
_) =
      String -> m Void
forall a. HasCallStack => String -> a
error String
"runCommand: Impossible happened"
    runCommand (Just (Async m Void
async_, StrictTVar
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
_)) Snocket m (FD m NtNAddr) NtNAddr
ntnSnocket Snocket m (FD m (TestAddress Int)) (TestAddress Int)
ntcSnocket StrictTVar m (Map Domain [(IP, TTL)])
dMapVarMap SimArgs
sArgs NodeArgs
nArgs ConnStateIdSupply m
connStateIdSupply
               (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 (NodeArgs -> NtNAddr
naAddr NodeArgs
nArgs)) 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))])
-> Snocket m (FD m NtNAddr) NtNAddr
-> Snocket m (FD m (TestAddress Int)) (TestAddress Int)
-> StrictTVar m (Map Domain [(IP, TTL)])
-> SimArgs
-> NodeArgs
-> ConnStateIdSupply m
-> [Command]
-> m Void
runCommand Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
forall a. Maybe a
Nothing Snocket m (FD m NtNAddr) NtNAddr
ntnSnocket Snocket m (FD m (TestAddress Int)) (TestAddress Int)
ntcSnocket StrictTVar m (Map Domain [(IP, TTL)])
dMapVarMap SimArgs
sArgs NodeArgs
nArgs ConnStateIdSupply m
connStateIdSupply [Command]
cs
    runCommand Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
_ Snocket m (FD m NtNAddr) NtNAddr
_ Snocket m (FD m (TestAddress Int)) (TestAddress Int)
_ StrictTVar m (Map Domain [(IP, TTL)])
_ SimArgs
_ NodeArgs
_ ConnStateIdSupply m
_ (Kill DiffTime
_:[Command]
_) = do
      String -> m Void
forall a. HasCallStack => String -> a
error String
"runCommand: Impossible happened"
    runCommand Maybe
  (Async m Void,
   StrictTVar
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig PeerTrustable))])
Nothing Snocket m (FD m NtNAddr) NtNAddr
_ Snocket m (FD m (TestAddress Int)) (TestAddress Int)
_ StrictTVar m (Map Domain [(IP, TTL)])
_ SimArgs
_ NodeArgs
_ ConnStateIdSupply m
_ (Reconfigure DiffTime
_ [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
_:[Command]
_) =
      String -> m Void
forall a. HasCallStack => String -> a
error String
"runCommand: Impossible happened"
    runCommand (Just (Async m Void
async_, StrictTVar
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig PeerTrustable))]
lrpVar)) Snocket m (FD m NtNAddr) NtNAddr
ntnSnocket Snocket m (FD m (TestAddress Int)) (TestAddress Int)
ntcSnocket StrictTVar m (Map Domain [(IP, TTL)])
dMapVarMap SimArgs
sArgs NodeArgs
nArgs ConnStateIdSupply m
connStateIdSupply
               (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 (NodeArgs -> NtNAddr
naAddr NodeArgs
nArgs)) 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)) ntnSnocket ntcSnocket dMapVarMap sArgs nArgs connStateIdSupply
                 cs

    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 (Map Domain [(IP, TTL)])
            -> 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 (Map Domain [(IP, TTL)])
-> m Void
runNode SimArgs
            { saSlot :: SimArgs -> DiffTime
saSlot                  = DiffTime
bgaSlotDuration
            , saQuota :: SimArgs -> Int
saQuota                 = Int
quota
            }
            NodeArgs
            { naSeed :: NodeArgs -> Int
naSeed                   = Int
seed
            , naMbTime :: NodeArgs -> Maybe DiffTime
naMbTime                 = Maybe DiffTime
mustReplyTimeout
            , 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
            }
            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 (Map Domain [(IP, TTL)])
dMapVar = 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
AcceptedConnectionsLimit TTL
forall a. Bounded a => a
maxBound TTL
forall a. Bounded a => a
maxBound DiffTime
0
          diffusionMode = DiffusionMode
InitiatorAndResponderDiffusionMode
          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

          stdChainSyncTimeout :: ChainSyncTimeout
          stdChainSyncTimeout = do
              ChainSyncTimeout
                { canAwaitTimeout :: Maybe DiffTime
canAwaitTimeout  = Maybe DiffTime
shortWait
                , intersectTimeout :: Maybe DiffTime
intersectTimeout = Maybe DiffTime
shortWait
                , Maybe DiffTime
mustReplyTimeout :: Maybe DiffTime
mustReplyTimeout :: Maybe DiffTime
mustReplyTimeout
                , idleTimeout :: Maybe DiffTime
idleTimeout      = Maybe DiffTime
forall a. Maybe a
Nothing
                }

          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 (Word -> ByteString -> Word
forall a b. a -> b -> a
const Word
0)
                , chainSyncTimeLimits :: ProtocolTimeLimits
  (ChainSync BlockHeader (Point Block) (Tip Block))
Node.chainSyncTimeLimits  =
                    ChainSyncTimeout
-> ProtocolTimeLimits
     (ChainSync BlockHeader (Point Block) (Tip Block))
forall header point tip.
ChainSyncTimeout -> ProtocolTimeLimits (ChainSync header point tip)
timeLimitsChainSync ChainSyncTimeout
stdChainSyncTimeout
                , 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 (Word -> ByteString -> Word
forall a b. a -> b -> a
const Word
0)
                , 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 (Word -> ByteString -> Word
forall a b. a -> b -> a
const Word
0)
                , 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 (Word -> ByteString -> Word
forall a b. a -> b -> a
const Word
0)

                }

          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 (Map Domain [(IP, TTL)])
-> DNSLookupType
-> [DomainAccessPoint]
-> m (Map DomainAccessPoint (Set NtNAddr))
domainResolver StrictTVar m (Map Domain [(IP, TTL)])
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 (Map Domain [(IP, TTL)])
Node.iDomainMap         = StrictTVar m (Map Domain [(IP, TTL)])
dMapVar
              , iLedgerPeersConsensusInterface :: LedgerPeersConsensusInterface (LedgerPeersConsensusInterface m) m
Node.iLedgerPeersConsensusInterface
                                        =
                  STM m (WithOrigin SlotNo)
-> STM m [(PoolStake, NonEmpty RelayAccessPoint)]
-> LedgerPeersConsensusInterface m
-> LedgerPeersConsensusInterface
     (LedgerPeersConsensusInterface m) m
forall extraAPI (m :: * -> *).
STM m (WithOrigin SlotNo)
-> STM m [(PoolStake, NonEmpty RelayAccessPoint)]
-> 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 {
                      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

          cardanoExtraArgs :: Cardano.ExtraArguments m
          cardanoExtraArgs =
            Cardano.ExtraArguments {
              genesisPeerTargets :: PeerSelectionTargets
Cardano.genesisPeerTargets     = (PeerSelectionTargets, PeerSelectionTargets)
-> PeerSelectionTargets
forall a b. (a, b) -> b
snd (PeerSelectionTargets, PeerSelectionTargets)
peerTargets
            , readUseBootstrapPeers :: STM m UseBootstrapPeers
Cardano.readUseBootstrapPeers  = STM m UseBootstrapPeers
readUseBootstrapPeers
            , numberOfBigLedgerPeers :: NumberOfBigLedgerPeers
Cardano.numberOfBigLedgerPeers = NumberOfBigLedgerPeers
defaultNumberOfBigLedgerPeers
            , consensusMode :: ConsensusMode
Cardano.consensusMode          = ConsensusMode
consensusMode
            }

          cardanoChurnArgs :: Churn.ExtraArguments m
          cardanoChurnArgs =
            Churn.ExtraArguments {
              modeVar :: StrictTVar m ChurnMode
Churn.modeVar             = StrictTVar m ChurnMode
churnModeVar
            , readFetchMode :: STM m FetchMode
Churn.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)
            , genesisPeerTargets :: PeerSelectionTargets
Churn.genesisPeerTargets  = ExtraArguments m -> PeerSelectionTargets
forall (m :: * -> *). ExtraArguments m -> PeerSelectionTargets
Cardano.genesisPeerTargets ExtraArguments m
cardanoExtraArgs
            , readUseBootstrap :: STM m UseBootstrapPeers
Churn.readUseBootstrap    = ExtraArguments m -> STM m UseBootstrapPeers
forall (m :: * -> *). ExtraArguments m -> STM m UseBootstrapPeers
Cardano.readUseBootstrapPeers ExtraArguments m
cardanoExtraArgs
            , consensusMode :: ConsensusMode
Churn.consensusMode       = ConsensusMode
consensusMode
            }

          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
              , aOwnPeerSharing :: PeerSharing
Node.aOwnPeerSharing       = 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 String
Node.aDebugTracer          = (\String
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 (String -> DiffusionTestTrace
DiffusionDebugTrace String
s)))
                                                   (String -> WithTime (WithName NtNAddr DiffusionTestTrace))
-> Tracer m (WithTime (WithName NtNAddr DiffusionTestTrace))
-> Tracer m String
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
              , aExtraChurnArgs :: ExtraArguments m
Node.aExtraChurnArgs = ExtraArguments m
cardanoChurnArgs
              }

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

          requestPublicRootPeers' =
            Tracer m TracePublicRootPeers
-> STM m UseBootstrapPeers
-> STM m LedgerStateJudgement
-> STM m (Map RelayAccessPoint PeerAdvertise)
-> PeerActionsDNS NtNAddr () SomeException m
-> DNSSemaphore m
-> (Map NtNAddr PeerAdvertise -> ExtraPeers NtNAddr)
-> (NumberOfPeers
    -> LedgerPeersKind -> m (Maybe (Set NtNAddr, DiffTime)))
-> LedgerPeersKind
-> Int
-> m (CardanoPublicRootPeers NtNAddr, DiffTime)
forall (m :: * -> *) peeraddr resolver exception.
(MonadThrow m, MonadAsync m, Exception exception, Ord peeraddr) =>
Tracer m TracePublicRootPeers
-> STM m UseBootstrapPeers
-> STM m LedgerStateJudgement
-> STM m (Map RelayAccessPoint PeerAdvertise)
-> PeerActionsDNS peeraddr resolver exception m
-> DNSSemaphore m
-> (Map peeraddr PeerAdvertise -> ExtraPeers peeraddr)
-> (NumberOfPeers
    -> LedgerPeersKind -> m (Maybe (Set peeraddr, DiffTime)))
-> LedgerPeersKind
-> Int
-> m (CardanoPublicRootPeers peeraddr, DiffTime)
requestPublicRootPeers (Tracers
  NtNAddr
  NtNVersion
  NtNVersionData
  (TestAddress Int)
  NtNVersion
  NtCVersionData
  SomeException
  ExtraState
  ExtraState
  PeerTrustable
  (ExtraPeers NtNAddr)
  (ExtraPeerSelectionSetsWithSizes NtNAddr)
  m
-> Tracer m TracePublicRootPeers
forall ntnAddr ntnVersion ntnVersionData ntcAddr ntcVersion
       ntcVersionData resolverError extraState extraDebugState extraFlags
       extraPeers extraCounters (m :: * -> *).
Tracers
  ntnAddr
  ntnVersion
  ntnVersionData
  ntcAddr
  ntcVersion
  ntcVersionData
  resolverError
  extraState
  extraDebugState
  extraFlags
  extraPeers
  extraCounters
  m
-> Tracer m TracePublicRootPeers
Diff.dtTracePublicRootPeersTracer Tracers
  NtNAddr
  NtNVersion
  NtNVersionData
  (TestAddress Int)
  NtNVersion
  NtCVersionData
  SomeException
  ExtraState
  ExtraState
  PeerTrustable
  (ExtraPeers NtNAddr)
  (ExtraPeerSelectionSetsWithSizes NtNAddr)
  m
tracers)
                                   (ExtraArguments m -> STM m UseBootstrapPeers
forall (m :: * -> *). ExtraArguments m -> STM m UseBootstrapPeers
Cardano.readUseBootstrapPeers ExtraArguments m
cardanoExtraArgs)
                                   (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.cardanoExtraArgsToPeerSelectionActions cardanoExtraArgs)
          )
          Cardano.cardanoPeerSelectionStatetoCounters
          (flip Cardano.ExtraPeers Set.empty)
          requestPublicRootPeers'
          peerChurnGovernor
          tracers
          ( contramap (DiffusionFetchTrace . (\(TraceLabelPeer NtNAddr
_ TraceFetchClientState BlockHeader
a) -> TraceFetchClientState BlockHeader
a))
          . 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

    domainResolver :: StrictTVar m (Map Domain [(IP, TTL)])
                   -> 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 (Map Domain [(IP, TTL)])
-> DNSLookupType
-> [DomainAccessPoint]
-> m (Map DomainAccessPoint (Set NtNAddr))
domainResolver StrictTVar m (Map Domain [(IP, TTL)])
dnsMapVar DNSLookupType
_ [DomainAccessPoint]
daps = do
      dnsMap <- ([(IP, TTL)] -> [IP]) -> Map Domain [(IP, TTL)] -> Map Domain [IP]
forall a b. (a -> b) -> Map Domain a -> Map Domain b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((IP, TTL) -> IP) -> [(IP, TTL)] -> [IP]
forall a b. (a -> b) -> [a] -> [b]
map (IP, TTL) -> IP
forall a b. (a, b) -> a
fst) (Map Domain [(IP, TTL)] -> Map Domain [IP])
-> m (Map Domain [(IP, TTL)]) -> m (Map Domain [IP])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (Map Domain [(IP, TTL)]) -> m (Map Domain [(IP, TTL)])
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m (Map Domain [(IP, TTL)])
-> STM m (Map Domain [(IP, TTL)])
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Map Domain [(IP, TTL)])
dnsMapVar)
      let mapDomains :: [(DomainAccessPoint, Set NtNAddr)]
          mapDomains = [ ( DomainAccessPoint
dap
                         , [NtNAddr] -> Set NtNAddr
forall a. Ord a => [a] -> Set a
Set.fromList [ IP -> PortNumber -> NtNAddr
ntnToPeerAddr IP
a PortNumber
p | IP
a <- [IP]
addrs ]
                         )
                       | dap :: DomainAccessPoint
dap@(DomainAccessPoint Domain
d PortNumber
p) <- [DomainAccessPoint]
daps
                       , [IP]
addrs <- Maybe [IP] -> [[IP]]
forall a. Maybe a -> [a]
maybeToList (Domain
d Domain -> Map Domain [IP] -> Maybe [IP]
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map Domain [IP]
dnsMap) ]
      return (Map.fromListWith (<>) mapDomains)

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

    mkTracers
      :: NtNAddr
      -> Diff.Tracers NtNAddr NtNVersion NtNVersionData
                      NtCAddr NtCVersion NtCVersionData
                      SomeException Cardano.ExtraState
                      Cardano.ExtraState PeerTrustable
                      (Cardano.ExtraPeers NtNAddr)
                      (Cardano.ExtraPeerSelectionSetsWithSizes NtNAddr) m
    mkTracers :: NtNAddr
-> Tracers
     NtNAddr
     NtNVersion
     NtNVersionData
     (TestAddress Int)
     NtNVersion
     NtCVersionData
     SomeException
     ExtraState
     ExtraState
     PeerTrustable
     (ExtraPeers NtNAddr)
     (ExtraPeerSelectionSetsWithSizes NtNAddr)
     m
mkTracers NtNAddr
ntnAddr =
      Tracers
  NtNAddr
  NtNVersion
  Any
  (TestAddress Int)
  NtNVersion
  Any
  Any
  Any
  Any
  Any
  Any
  Any
  m
forall (m :: * -> *) ntnAddr ntnVersion ntnVersionData ntcAddr
       ntcVersion ntcVersionData resolverError extraState extraDebugState
       extraFlags extraPeers extraCounters.
Applicative m =>
Tracers
  ntnAddr
  ntnVersion
  ntnVersionData
  ntcAddr
  ntcVersion
  ntcVersionData
  resolverError
  extraState
  extraDebugState
  extraFlags
  extraPeers
  extraCounters
  m
Diff.nullTracers {
          Diff.dtTraceLocalRootPeersTracer       = contramap
                                                    DiffusionLocalRootPeerTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer
        , Diff.dtTracePublicRootPeersTracer      = contramap
                                                    DiffusionPublicRootPeerTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer
        , Diff.dtTraceLedgerPeersTracer          = contramap
                                                  DiffusionLedgerPeersTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer
        , Diff.dtTracePeerSelectionTracer          = contramap
                                                    DiffusionPeerSelectionTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer
        , Diff.dtDebugPeerSelectionInitiatorTracer = contramap
                                                    DiffusionDebugPeerSelectionTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer
        , Diff.dtDebugPeerSelectionInitiatorResponderTracer
            = contramap DiffusionDebugPeerSelectionTrace
            . tracerWithName ntnAddr
            . tracerWithTime
            $ nodeTracer
        , Diff.dtTracePeerSelectionCounters        = nullTracer
        , Diff.dtTraceChurnCounters                = nullTracer
        , Diff.dtPeerSelectionActionsTracer        = contramap
                                                    DiffusionPeerSelectionActionsTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer
        , Diff.dtConnectionManagerTracer           = contramap
                                                    DiffusionConnectionManagerTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer
        , Diff.dtConnectionManagerTransitionTracer = contramap
                                                     DiffusionConnectionManagerTransitionTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
          -- note: we have two ways getting transition trace:
          -- * through `traceTVar` installed in `newMutableConnState`
          -- * the `dtConnectionManagerTransitionTracer`
                                                     $ nodeTracer
        , Diff.dtServerTracer                      = contramap
                                                     DiffusionServerTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer
        , Diff.dtInboundGovernorTracer             = contramap
                                                     DiffusionInboundGovernorTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer
        , Diff.dtInboundGovernorTransitionTracer   = contramap
                                                     DiffusionInboundGovernorTransitionTrace
                                                 . tracerWithName ntnAddr
                                                 . tracerWithTime
                                                 $ nodeTracer
        , Diff.dtLocalConnectionManagerTracer      = nullTracer
        , Diff.dtLocalServerTracer                 = nullTracer
        , Diff.dtLocalInboundGovernorTracer        = nullTracer
      }


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


ntnToPeerAddr :: IP -> PortNumber -> NtNAddr
ntnToPeerAddr :: IP -> PortNumber -> NtNAddr
ntnToPeerAddr IP
a PortNumber
b = NtNAddr_ -> NtNAddr
forall addr. addr -> TestAddress addr
TestAddress (IP -> PortNumber -> NtNAddr_
IPAddr IP
a PortNumber
b)

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)