{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}

{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module Test.Ouroboros.Network.PeerSelection.MockEnvironment
  ( PeerGraph (..)
  , GovernorMockEnvironment (..)
  , GovernorPraosMockEnvironment (..)
  , GovernorMockEnvironmentWithoutAsyncDemotion (..)
  , runGovernorInMockEnvironment
  , exploreGovernorInMockEnvironment
  , TraceMockEnv (..)
  , TestTraceEvent (..)
  , selectGovernorEvents
  , selectGovernorStateEvents
  , selectPeerSelectionTraceEvents
  , selectPeerSelectionTraceEventsUntil
  , peerShareReachablePeers
  , module Ouroboros.Network.Testing.Data.Script
  , module Ouroboros.Network.PeerSelection.Types
  , tests
  , prop_shrink_nonequal_GovernorMockEnvironment
  , config_REPROMOTE_DELAY
  ) where

import Data.Bifunctor (bimap, first)
import Data.Dynamic (fromDynamic)
import Data.List (nub)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Proxy (Proxy (..))
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Typeable (Typeable)
import Data.Void (Void)
import System.Random (mkStdGen)

import Control.Concurrent.Class.MonadSTM
import Control.Concurrent.Class.MonadSTM.Strict qualified as StrictTVar
import Control.Exception (throw)
import Control.Monad (forM, when)
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork
import Control.Monad.Class.MonadSay
import Control.Monad.Class.MonadTest
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI hiding (timeout)
import Control.Monad.Fail qualified as Fail
import Control.Monad.IOSim
import Control.Tracer (Tracer (..), contramap, traceWith)

import Ouroboros.Network.ExitPolicy
import Ouroboros.Network.PeerSelection.Governor hiding (PeerSelectionState (..))
import Ouroboros.Network.PeerSelection.Governor qualified as Governor
import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers
import Ouroboros.Network.Point

import Ouroboros.Network.Testing.Data.Script (PickScript, Script (..),
           ScriptDelay (..), TimedScript, arbitraryPickScript,
           arbitraryScriptOf, initScript, initScript', interpretPickScript,
           playTimedScript, prop_shrink_Script, shrinkScriptWith,
           singletonScript, singletonTimedScript, stepScript, stepScriptSTM,
           stepScriptSTM')
import Ouroboros.Network.Testing.Utils (ShrinkCarefully, arbitrarySubset,
           nightlyTest, prop_shrink_nonequal, prop_shrink_valid)

import Test.Ouroboros.Network.PeerSelection.Instances
import Test.Ouroboros.Network.PeerSelection.LocalRootPeers as LocalRootPeers hiding
           (tests)
import Test.Ouroboros.Network.PeerSelection.PeerGraph

import Ouroboros.Network.ConsensusMode
import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..),
           requiresBootstrapPeers)
import Ouroboros.Network.PeerSelection.LedgerPeers
import Ouroboros.Network.PeerSelection.LocalRootPeers
           (OutboundConnectionsState (..))
import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..))
import Ouroboros.Network.PeerSelection.PublicRootPeers (PublicRootPeers (..))
import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers
import Ouroboros.Network.PeerSelection.Types (PeerStatus (..))
import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount,
           PeerSharingResult (..))
import Test.Ouroboros.Network.LedgerPeers (ArbitraryLedgerStateJudgement (..))
import Test.Ouroboros.Network.PeerSelection.PublicRootPeers ()
import Test.QuickCheck
import Test.Tasty (TestTree, localOption, testGroup)
import Test.Tasty.QuickCheck (QuickCheckMaxSize (..), testProperty)


tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup TestName
"Ouroboros.Network.PeerSelection"
    [ TestName -> [TestTree] -> TestTree
testGroup TestName
"MockEnvironment"
      [ TestName -> (ShrinkCarefully (Script Int) -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrink for Script"                     ShrinkCarefully (Script Int) -> Property
prop_shrink_Script
      , TestName
-> (ShrinkCarefully GovernorScripts -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrink for GovernorScripts"            ShrinkCarefully GovernorScripts -> Property
prop_shrink_GovernorScripts
      , TestName -> (PeerSelectionTargets -> Bool) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"arbitrary for PeerSelectionTargets"    PeerSelectionTargets -> Bool
prop_arbitrary_PeerSelectionTargets
      , TestName
-> (ShrinkCarefully PeerSelectionTargets -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrink for PeerSelectionTargets"       ShrinkCarefully PeerSelectionTargets -> Property
prop_shrink_PeerSelectionTargets
      , TestName -> (PeerGraph -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"arbitrary for PeerGraph"               PeerGraph -> Property
prop_arbitrary_PeerGraph
      , QuickCheckMaxSize -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Int -> QuickCheckMaxSize
QuickCheckMaxSize Int
30) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
        TestName -> (ShrinkCarefully PeerGraph -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrink for PeerGraph"                  ShrinkCarefully PeerGraph -> Property
prop_shrink_PeerGraph
      , TestName -> (GovernorMockEnvironment -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"arbitrary for GovernorMockEnvironment" GovernorMockEnvironment -> Property
prop_arbitrary_GovernorMockEnvironment
      , QuickCheckMaxSize -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Int -> QuickCheckMaxSize
QuickCheckMaxSize Int
30) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
        TestName
-> (ShrinkCarefully GovernorMockEnvironment -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrink for GovernorMockEnvironment"    ShrinkCarefully GovernorMockEnvironment -> Property
prop_shrink_GovernorMockEnvironment
      , TestTree -> TestTree
nightlyTest (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
        TestName
-> (ShrinkCarefully GovernorMockEnvironment -> Property)
-> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"shrink nonequal GovernorMockEnvironment"
                                                             ShrinkCarefully GovernorMockEnvironment -> Property
prop_shrink_nonequal_GovernorMockEnvironment
      ]
    ]


--
-- Mock environment types
--

-- | The data needed to execute the peer selection governor in a test with a
-- mock network environment. It contains the data needed to provide the
-- 'PeerSelectionActions' and 'PeerSelectionPolicy' to run the governor.
--
-- The representations are chosen to be easily shrinkable. See the @Arbitrary@
-- instances.
--
data GovernorMockEnvironment = GovernorMockEnvironment {
       GovernorMockEnvironment -> PeerGraph
peerGraph                  :: !PeerGraph,
       GovernorMockEnvironment -> LocalRootPeers PeerAddr
localRootPeers             :: !(LocalRootPeers PeerAddr),
       GovernorMockEnvironment -> PublicRootPeers PeerAddr
publicRootPeers            :: !(PublicRootPeers PeerAddr),
       GovernorMockEnvironment -> TimedScript ConsensusModePeerTargets
targets                    :: !(TimedScript ConsensusModePeerTargets),
       GovernorMockEnvironment -> PickScript PeerAddr
pickKnownPeersForPeerShare :: !(PickScript PeerAddr),
       GovernorMockEnvironment -> PickScript PeerAddr
pickColdPeersToPromote     :: !(PickScript PeerAddr),
       GovernorMockEnvironment -> PickScript PeerAddr
pickWarmPeersToPromote     :: !(PickScript PeerAddr),
       GovernorMockEnvironment -> PickScript PeerAddr
pickHotPeersToDemote       :: !(PickScript PeerAddr),
       GovernorMockEnvironment -> PickScript PeerAddr
pickWarmPeersToDemote      :: !(PickScript PeerAddr),
       GovernorMockEnvironment -> PickScript PeerAddr
pickColdPeersToForget      :: !(PickScript PeerAddr),
       GovernorMockEnvironment -> PickScript PeerAddr
pickInboundPeers           :: !(PickScript PeerAddr),
       GovernorMockEnvironment -> PeerSharing
peerSharingFlag            :: !PeerSharing,
       GovernorMockEnvironment -> TimedScript UseBootstrapPeers
useBootstrapPeers          :: !(TimedScript UseBootstrapPeers),
       GovernorMockEnvironment -> ConsensusMode
consensusMode              :: !ConsensusMode,
       GovernorMockEnvironment -> TimedScript UseLedgerPeers
useLedgerPeers             :: !(TimedScript UseLedgerPeers),
       GovernorMockEnvironment -> TimedScript LedgerStateJudgement
ledgerStateJudgement       :: !(TimedScript LedgerStateJudgement)
     }
  deriving (Int -> GovernorMockEnvironment -> ShowS
[GovernorMockEnvironment] -> ShowS
GovernorMockEnvironment -> TestName
(Int -> GovernorMockEnvironment -> ShowS)
-> (GovernorMockEnvironment -> TestName)
-> ([GovernorMockEnvironment] -> ShowS)
-> Show GovernorMockEnvironment
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GovernorMockEnvironment -> ShowS
showsPrec :: Int -> GovernorMockEnvironment -> ShowS
$cshow :: GovernorMockEnvironment -> TestName
show :: GovernorMockEnvironment -> TestName
$cshowList :: [GovernorMockEnvironment] -> ShowS
showList :: [GovernorMockEnvironment] -> ShowS
Show, GovernorMockEnvironment -> GovernorMockEnvironment -> Bool
(GovernorMockEnvironment -> GovernorMockEnvironment -> Bool)
-> (GovernorMockEnvironment -> GovernorMockEnvironment -> Bool)
-> Eq GovernorMockEnvironment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GovernorMockEnvironment -> GovernorMockEnvironment -> Bool
== :: GovernorMockEnvironment -> GovernorMockEnvironment -> Bool
$c/= :: GovernorMockEnvironment -> GovernorMockEnvironment -> Bool
/= :: GovernorMockEnvironment -> GovernorMockEnvironment -> Bool
Eq)

-- | This instance is used to generate test cases for properties
-- which rely on peer selection prior to introduction of Genesis
--
newtype GovernorPraosMockEnvironment = GovernorPraosMockEnvironment { GovernorPraosMockEnvironment -> GovernorMockEnvironment
getMockEnv :: GovernorMockEnvironment }
  deriving (GovernorPraosMockEnvironment
-> GovernorPraosMockEnvironment -> Bool
(GovernorPraosMockEnvironment
 -> GovernorPraosMockEnvironment -> Bool)
-> (GovernorPraosMockEnvironment
    -> GovernorPraosMockEnvironment -> Bool)
-> Eq GovernorPraosMockEnvironment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GovernorPraosMockEnvironment
-> GovernorPraosMockEnvironment -> Bool
== :: GovernorPraosMockEnvironment
-> GovernorPraosMockEnvironment -> Bool
$c/= :: GovernorPraosMockEnvironment
-> GovernorPraosMockEnvironment -> Bool
/= :: GovernorPraosMockEnvironment
-> GovernorPraosMockEnvironment -> Bool
Eq, Int -> GovernorPraosMockEnvironment -> ShowS
[GovernorPraosMockEnvironment] -> ShowS
GovernorPraosMockEnvironment -> TestName
(Int -> GovernorPraosMockEnvironment -> ShowS)
-> (GovernorPraosMockEnvironment -> TestName)
-> ([GovernorPraosMockEnvironment] -> ShowS)
-> Show GovernorPraosMockEnvironment
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GovernorPraosMockEnvironment -> ShowS
showsPrec :: Int -> GovernorPraosMockEnvironment -> ShowS
$cshow :: GovernorPraosMockEnvironment -> TestName
show :: GovernorPraosMockEnvironment -> TestName
$cshowList :: [GovernorPraosMockEnvironment] -> ShowS
showList :: [GovernorPraosMockEnvironment] -> ShowS
Show)

data PeerConn m = PeerConn !PeerAddr !PeerSharing !(TVar m PeerStatus)

instance Show (PeerConn m) where
    show :: PeerConn m -> TestName
show (PeerConn PeerAddr
peeraddr PeerSharing
peerSharing TVar m PeerStatus
_) =
      TestName
"PeerConn " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ PeerAddr -> TestName
forall a. Show a => a -> TestName
show PeerAddr
peeraddr TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
" " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ PeerSharing -> TestName
forall a. Show a => a -> TestName
show PeerSharing
peerSharing


-- | 'GovernorMockEnvironment' which does not do any asynchronous demotions.
--
newtype GovernorMockEnvironmentWithoutAsyncDemotion =
    GovernorMockEnvironmentWAD GovernorMockEnvironment
  deriving Int -> GovernorMockEnvironmentWithoutAsyncDemotion -> ShowS
[GovernorMockEnvironmentWithoutAsyncDemotion] -> ShowS
GovernorMockEnvironmentWithoutAsyncDemotion -> TestName
(Int -> GovernorMockEnvironmentWithoutAsyncDemotion -> ShowS)
-> (GovernorMockEnvironmentWithoutAsyncDemotion -> TestName)
-> ([GovernorMockEnvironmentWithoutAsyncDemotion] -> ShowS)
-> Show GovernorMockEnvironmentWithoutAsyncDemotion
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GovernorMockEnvironmentWithoutAsyncDemotion -> ShowS
showsPrec :: Int -> GovernorMockEnvironmentWithoutAsyncDemotion -> ShowS
$cshow :: GovernorMockEnvironmentWithoutAsyncDemotion -> TestName
show :: GovernorMockEnvironmentWithoutAsyncDemotion -> TestName
$cshowList :: [GovernorMockEnvironmentWithoutAsyncDemotion] -> ShowS
showList :: [GovernorMockEnvironmentWithoutAsyncDemotion] -> ShowS
Show

instance Arbitrary GovernorMockEnvironmentWithoutAsyncDemotion where
    arbitrary :: Gen GovernorMockEnvironmentWithoutAsyncDemotion
arbitrary = GovernorMockEnvironment
-> GovernorMockEnvironmentWithoutAsyncDemotion
GovernorMockEnvironmentWAD (GovernorMockEnvironment
 -> GovernorMockEnvironmentWithoutAsyncDemotion)
-> (GovernorMockEnvironment -> GovernorMockEnvironment)
-> GovernorMockEnvironment
-> GovernorMockEnvironmentWithoutAsyncDemotion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GovernorMockEnvironment -> GovernorMockEnvironment
fixGraph (GovernorMockEnvironment
 -> GovernorMockEnvironmentWithoutAsyncDemotion)
-> Gen GovernorMockEnvironment
-> Gen GovernorMockEnvironmentWithoutAsyncDemotion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen GovernorMockEnvironment
forall a. Arbitrary a => Gen a
arbitrary
      where
        fixGraph :: GovernorMockEnvironment -> GovernorMockEnvironment
fixGraph g :: GovernorMockEnvironment
g@GovernorMockEnvironment { peerGraph :: GovernorMockEnvironment -> PeerGraph
peerGraph = PeerGraph [(PeerAddr, [PeerAddr], GovernorScripts)]
peerGraph } =
          GovernorMockEnvironment
g { peerGraph = PeerGraph (map fixNode peerGraph) }
        fixNode :: (a, b, GovernorScripts) -> (a, b, GovernorScripts)
fixNode (a
addr, b
addrs, GovernorScripts
peerInfo) =
          (a
addr, b
addrs, GovernorScripts
peerInfo { connectionScript = singletonScript (Noop, ShortDelay) })
    shrink :: GovernorMockEnvironmentWithoutAsyncDemotion
-> [GovernorMockEnvironmentWithoutAsyncDemotion]
shrink (GovernorMockEnvironmentWAD GovernorMockEnvironment
env) = (GovernorMockEnvironment
 -> GovernorMockEnvironmentWithoutAsyncDemotion)
-> [GovernorMockEnvironment]
-> [GovernorMockEnvironmentWithoutAsyncDemotion]
forall a b. (a -> b) -> [a] -> [b]
map GovernorMockEnvironment
-> GovernorMockEnvironmentWithoutAsyncDemotion
GovernorMockEnvironmentWAD (GovernorMockEnvironment -> [GovernorMockEnvironment]
forall a. Arbitrary a => a -> [a]
shrink GovernorMockEnvironment
env)


-- | Invariant. Used to check the QC generator and shrinker.
--
-- NOTE: Local and Public Root Peers sets should be disjoint.
-- However we do not check for that invariant here. The goal
-- is to check if the actual Governor takes care of this and enforces
-- the invariant.
validGovernorMockEnvironment :: GovernorMockEnvironment -> Property
validGovernorMockEnvironment :: GovernorMockEnvironment -> Property
validGovernorMockEnvironment GovernorMockEnvironment {
                               PeerGraph
peerGraph :: GovernorMockEnvironment -> PeerGraph
peerGraph :: PeerGraph
peerGraph,
                               LocalRootPeers PeerAddr
localRootPeers :: GovernorMockEnvironment -> LocalRootPeers PeerAddr
localRootPeers :: LocalRootPeers PeerAddr
localRootPeers,
                               PublicRootPeers PeerAddr
publicRootPeers :: GovernorMockEnvironment -> PublicRootPeers PeerAddr
publicRootPeers :: PublicRootPeers PeerAddr
publicRootPeers,
                               TimedScript ConsensusModePeerTargets
targets :: GovernorMockEnvironment -> TimedScript ConsensusModePeerTargets
targets :: TimedScript ConsensusModePeerTargets
targets
                             } =
   [Property] -> Property
forall prop. Testable prop => [prop] -> Property
conjoin [ TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"invalid peer graph"
              (PeerGraph -> Bool
validPeerGraph PeerGraph
peerGraph)
           , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"local roots not a subset of all peers"
              (LocalRootPeers PeerAddr -> Set PeerAddr
forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers PeerAddr
localRootPeers Set PeerAddr -> Set PeerAddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set PeerAddr
allPeersSet)
           , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"public root peers not a subset of  all peers" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
             Bool -> Property
forall prop. Testable prop => prop -> Property
property (PublicRootPeers PeerAddr -> Set PeerAddr
forall peeraddr.
Ord peeraddr =>
PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.toSet PublicRootPeers PeerAddr
publicRootPeers Set PeerAddr -> Set PeerAddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set PeerAddr
allPeersSet)
           , TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"failed peer selection targets sanity check" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
             Bool -> Property
forall prop. Testable prop => prop -> Property
property ((Bool -> (ConsensusModePeerTargets, ScriptDelay) -> Bool)
-> Bool -> TimedScript ConsensusModePeerTargets -> Bool
forall b a. (b -> a -> b) -> b -> Script a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ !Bool
p (ConsensusModePeerTargets {PeerSelectionTargets
deadlineTargets :: PeerSelectionTargets
syncTargets :: PeerSelectionTargets
deadlineTargets :: ConsensusModePeerTargets -> PeerSelectionTargets
syncTargets :: ConsensusModePeerTargets -> PeerSelectionTargets
..},ScriptDelay
_) ->
                                Bool
p Bool -> Bool -> Bool
&& (PeerSelectionTargets -> Bool) -> [PeerSelectionTargets] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all PeerSelectionTargets -> Bool
sanePeerSelectionTargets [PeerSelectionTargets
deadlineTargets, PeerSelectionTargets
syncTargets])
                        Bool
True
                        TimedScript ConsensusModePeerTargets
targets)
           , TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample TestName
"big ledger peers not a subset of public roots"
                (PublicRootPeers PeerAddr -> Bool
forall peeraddr. Ord peeraddr => PublicRootPeers peeraddr -> Bool
PublicRootPeers.invariant PublicRootPeers PeerAddr
publicRootPeers)
           ]
  where
    allPeersSet :: Set PeerAddr
allPeersSet = PeerGraph -> Set PeerAddr
allPeers PeerGraph
peerGraph


--
-- Execution in the mock environment
--

-- | Run the 'peerSelectionGovernor' in the mock environment dictated by the
-- data in the 'GovernorMockEnvironment'.
--
-- The result is an execution trace.
--
runGovernorInMockEnvironment :: GovernorMockEnvironment -> SimTrace Void
runGovernorInMockEnvironment :: GovernorMockEnvironment -> SimTrace Void
runGovernorInMockEnvironment GovernorMockEnvironment
mockEnv =
    (forall s. IOSim s Void) -> SimTrace Void
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace ((forall s. IOSim s Void) -> SimTrace Void)
-> (forall s. IOSim s Void) -> SimTrace Void
forall a b. (a -> b) -> a -> b
$ GovernorMockEnvironment -> IOSim s Void
forall s. GovernorMockEnvironment -> IOSim s Void
governorAction GovernorMockEnvironment
mockEnv

governorAction :: GovernorMockEnvironment -> IOSim s Void
governorAction :: forall s. GovernorMockEnvironment -> IOSim s Void
governorAction mockEnv :: GovernorMockEnvironment
mockEnv@GovernorMockEnvironment {
                 ConsensusMode
consensusMode :: GovernorMockEnvironment -> ConsensusMode
consensusMode :: ConsensusMode
consensusMode,
                 targets :: GovernorMockEnvironment -> TimedScript ConsensusModePeerTargets
targets = Script NonEmpty (ConsensusModePeerTargets, ScriptDelay)
targets',
                 ledgerStateJudgement :: GovernorMockEnvironment -> TimedScript LedgerStateJudgement
ledgerStateJudgement = Script NonEmpty (LedgerStateJudgement, ScriptDelay)
ledgerStateJudgement'} = do
    publicStateVar <- IOSim s (StrictTVar (IOSim s) (PublicPeerSelectionState PeerAddr))
forall (m :: * -> *) peeraddr.
(MonadSTM m, Ord peeraddr) =>
m (StrictTVar m (PublicPeerSelectionState peeraddr))
makePublicPeerSelectionStateVar
    lpVar <- playTimedScript (contramap TraceEnvUseLedgerPeers tracerMockEnv)
                             (useLedgerPeers mockEnv)
    usbVar <- playTimedScript (contramap TraceEnvSetUseBootstrapPeers tracerMockEnv)
                              (useBootstrapPeers mockEnv)
    -- todo: make MinBigLedgerPeersForTrustedState come from quickcheck
    debugStateVar <- StrictTVar.newTVarIO (emptyPeerSelectionState (mkStdGen 42) consensusMode (MinBigLedgerPeersForTrustedState 0))
    countersVar <- StrictTVar.newTVarIO emptyPeerSelectionCounters
    policy  <- mockPeerSelectionPolicy mockEnv
    let initialPeerTargets = (ConsensusModePeerTargets, ScriptDelay) -> ConsensusModePeerTargets
forall a b. (a, b) -> a
fst ((ConsensusModePeerTargets, ScriptDelay)
 -> ConsensusModePeerTargets)
-> (NonEmpty (ConsensusModePeerTargets, ScriptDelay)
    -> (ConsensusModePeerTargets, ScriptDelay))
-> NonEmpty (ConsensusModePeerTargets, ScriptDelay)
-> ConsensusModePeerTargets
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (ConsensusModePeerTargets, ScriptDelay)
-> (ConsensusModePeerTargets, ScriptDelay)
forall a. NonEmpty a -> a
NonEmpty.head (NonEmpty (ConsensusModePeerTargets, ScriptDelay)
 -> ConsensusModePeerTargets)
-> NonEmpty (ConsensusModePeerTargets, ScriptDelay)
-> ConsensusModePeerTargets
forall a b. (a -> b) -> a -> b
$ NonEmpty (ConsensusModePeerTargets, ScriptDelay)
targets'

    actions <-
      case consensusMode of
        ConsensusMode
PraosMode -> do
          lsjVar <- Tracer (IOSim s) LedgerStateJudgement
-> TimedScript LedgerStateJudgement
-> IOSim s (TVar (IOSim s) LedgerStateJudgement)
forall (m :: * -> *) a.
(MonadAsync m, MonadDelay m) =>
Tracer m a -> TimedScript a -> m (TVar m a)
playTimedScript ((LedgerStateJudgement -> TraceMockEnv)
-> Tracer (IOSim s) TraceMockEnv
-> Tracer (IOSim s) LedgerStateJudgement
forall a' a. (a' -> a) -> Tracer (IOSim s) a -> Tracer (IOSim s) a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap LedgerStateJudgement -> TraceMockEnv
TraceEnvSetLedgerStateJudgement Tracer (IOSim s) TraceMockEnv
forall s. Tracer (IOSim s) TraceMockEnv
tracerMockEnv)
                                    (GovernorMockEnvironment -> TimedScript LedgerStateJudgement
ledgerStateJudgement GovernorMockEnvironment
mockEnv)
          targetsVar <- playTimedScript (contramap TraceEnvSetTargets tracerMockEnv)
                                        (first deadlineTargets <$> targets mockEnv)
          mockPeerSelectionActions tracerMockEnv mockEnv
                                   initialPeerTargets
                                   (readTVar usbVar)
                                   (readTVar lpVar)
                                   (readTVar lsjVar)
                                   (readTVar targetsVar)
                                   policy
        ConsensusMode
GenesisMode -> do
          let tandemLsjAndTargets :: Script ((LedgerStateJudgement, PeerSelectionTargets), ScriptDelay)
tandemLsjAndTargets =
                NonEmpty
  ((LedgerStateJudgement, PeerSelectionTargets), ScriptDelay)
-> Script
     ((LedgerStateJudgement, PeerSelectionTargets), ScriptDelay)
forall a. NonEmpty a -> Script a
Script (NonEmpty
   ((LedgerStateJudgement, PeerSelectionTargets), ScriptDelay)
 -> Script
      ((LedgerStateJudgement, PeerSelectionTargets), ScriptDelay))
-> NonEmpty
     ((LedgerStateJudgement, PeerSelectionTargets), ScriptDelay)
-> Script
     ((LedgerStateJudgement, PeerSelectionTargets), ScriptDelay)
forall a b. (a -> b) -> a -> b
$ ((LedgerStateJudgement, ScriptDelay)
 -> (ConsensusModePeerTargets, ScriptDelay)
 -> ((LedgerStateJudgement, PeerSelectionTargets), ScriptDelay))
-> NonEmpty (LedgerStateJudgement, ScriptDelay)
-> NonEmpty (ConsensusModePeerTargets, ScriptDelay)
-> NonEmpty
     ((LedgerStateJudgement, PeerSelectionTargets), ScriptDelay)
forall a b c.
(a -> b -> c) -> NonEmpty a -> NonEmpty b -> NonEmpty c
NonEmpty.zipWith (\(LedgerStateJudgement
lsj, ScriptDelay
delay) (ConsensusModePeerTargets {
                                                             PeerSelectionTargets
deadlineTargets :: ConsensusModePeerTargets -> PeerSelectionTargets
deadlineTargets :: PeerSelectionTargets
deadlineTargets,
                                                             PeerSelectionTargets
syncTargets :: ConsensusModePeerTargets -> PeerSelectionTargets
syncTargets :: PeerSelectionTargets
syncTargets }, ScriptDelay
_) ->
                                             let pickTargets :: PeerSelectionTargets
pickTargets =
                                                   case LedgerStateJudgement
lsj of
                                                     LedgerStateJudgement
TooOld -> PeerSelectionTargets
syncTargets
                                                     LedgerStateJudgement
YoungEnough -> PeerSelectionTargets
deadlineTargets
                                             in ((LedgerStateJudgement
lsj, PeerSelectionTargets
pickTargets), ScriptDelay
delay))
                                          NonEmpty (LedgerStateJudgement, ScriptDelay)
ledgerStateJudgement'
                                          NonEmpty (ConsensusModePeerTargets, ScriptDelay)
targets'
          tandemVar <- Tracer (IOSim s) (LedgerStateJudgement, PeerSelectionTargets)
-> Script
     ((LedgerStateJudgement, PeerSelectionTargets), ScriptDelay)
-> IOSim
     s (TVar (IOSim s) (LedgerStateJudgement, PeerSelectionTargets))
forall (m :: * -> *) a.
(MonadAsync m, MonadDelay m) =>
Tracer m a -> TimedScript a -> m (TVar m a)
playTimedScript (((LedgerStateJudgement, PeerSelectionTargets) -> TraceMockEnv)
-> Tracer (IOSim s) TraceMockEnv
-> Tracer (IOSim s) (LedgerStateJudgement, PeerSelectionTargets)
forall a' a. (a' -> a) -> Tracer (IOSim s) a -> Tracer (IOSim s) a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (LedgerStateJudgement, PeerSelectionTargets) -> TraceMockEnv
TraceEnvGenesisLsjAndTargets Tracer (IOSim s) TraceMockEnv
forall s. Tracer (IOSim s) TraceMockEnv
tracerMockEnv)
                                       Script ((LedgerStateJudgement, PeerSelectionTargets), ScriptDelay)
tandemLsjAndTargets
          mockPeerSelectionActions tracerMockEnv mockEnv
                                   initialPeerTargets
                                   (readTVar usbVar)
                                   (readTVar lpVar)
                                   (fst <$> readTVar tandemVar)
                                   (snd <$> readTVar tandemVar)
                                   policy


    let interfaces = PeerSelectionInterfaces {
            StrictTVar (IOSim s) PeerSelectionCounters
countersVar :: StrictTVar (IOSim s) PeerSelectionCounters
countersVar :: StrictTVar (IOSim s) PeerSelectionCounters
countersVar,
            StrictTVar (IOSim s) (PublicPeerSelectionState PeerAddr)
publicStateVar :: StrictTVar (IOSim s) (PublicPeerSelectionState PeerAddr)
publicStateVar :: StrictTVar (IOSim s) (PublicPeerSelectionState PeerAddr)
publicStateVar,
            StrictTVar
  (IOSim s) (PeerSelectionState PeerAddr (PeerConn (IOSim s)))
debugStateVar :: StrictTVar
  (IOSim s) (PeerSelectionState PeerAddr (PeerConn (IOSim s)))
debugStateVar :: StrictTVar
  (IOSim s) (PeerSelectionState PeerAddr (PeerConn (IOSim s)))
debugStateVar,
            -- TODO: peer selection tests are not relying on `UseLedgerPeers`
            readUseLedgerPeers :: STM (IOSim s) UseLedgerPeers
readUseLedgerPeers = UseLedgerPeers -> STM s UseLedgerPeers
forall a. a -> STM s a
forall (m :: * -> *) a. Monad m => a -> m a
return UseLedgerPeers
DontUseLedgerPeers
          }

    exploreRaces      -- explore races within the governor
    _ <- forkIO $ do  -- races with the governor should be explored
      labelThisThread "outbound-governor"
      _ <- peerSelectionGovernor
        tracerTracePeerSelection
        (tracerDebugPeerSelection <> traceAssociationMode interfaces actions)
        tracerTracePeerSelectionCounters
        (mkStdGen 42)
        consensusMode
        (MinBigLedgerPeersForTrustedState 0) -- ^ todo: make this come from quickcheck
        actions
        policy
        interfaces
      atomically retry
    atomically retry  -- block to allow the governor to run

exploreGovernorInMockEnvironment :: Testable test
                                 => (ExplorationOptions->ExplorationOptions)
                                 -> GovernorMockEnvironment
                                 -> (Maybe (SimTrace Void) -> SimTrace Void -> test)
                                 -> Property
exploreGovernorInMockEnvironment :: forall test.
Testable test =>
(ExplorationOptions -> ExplorationOptions)
-> GovernorMockEnvironment
-> (Maybe (SimTrace Void) -> SimTrace Void -> test)
-> Property
exploreGovernorInMockEnvironment ExplorationOptions -> ExplorationOptions
optsf GovernorMockEnvironment
mockEnv Maybe (SimTrace Void) -> SimTrace Void -> test
k =
    (ExplorationOptions -> ExplorationOptions)
-> (forall s. IOSim s Void)
-> (Maybe (SimTrace Void) -> SimTrace Void -> test)
-> Property
forall a test.
Testable test =>
(ExplorationOptions -> ExplorationOptions)
-> (forall s. IOSim s a)
-> (Maybe (SimTrace a) -> SimTrace a -> test)
-> Property
exploreSimTrace ExplorationOptions -> ExplorationOptions
optsf (GovernorMockEnvironment -> IOSim s Void
forall s. GovernorMockEnvironment -> IOSim s Void
governorAction GovernorMockEnvironment
mockEnv) Maybe (SimTrace Void) -> SimTrace Void -> test
k

data TraceMockEnv = TraceEnvAddPeers       !PeerGraph
                  | TraceEnvSetLocalRoots  !(LocalRootPeers PeerAddr)
                  | TraceEnvRequestPublicRootPeers
                  | TraceEnvRequestBigLedgerPeers
                  | TraceEnvSetPublicRoots !(PublicRootPeers PeerAddr)
                  | TraceEnvPublicRootTTL
                  | TraceEnvBigLedgerPeersTTL
                  | TraceEnvPeerShareTTL   !PeerAddr
                  | TraceEnvSetTargets     !PeerSelectionTargets
                  | TraceEnvPeersDemote    !AsyncDemotion !PeerAddr
                  | TraceEnvEstablishConn  !PeerAddr
                  | TraceEnvActivatePeer   !PeerAddr
                  | TraceEnvDeactivatePeer !PeerAddr
                  | TraceEnvCloseConn      !PeerAddr
                  | TraceEnvRootsResult      ![PeerAddr]
                  | TraceEnvBigLedgerPeersResult !(Set PeerAddr)
                  | TraceEnvPeerShareRequest !PeerAddr !(Maybe ([PeerAddr], PeerShareTime))
                  | TraceEnvPeerShareResult  !PeerAddr ![PeerAddr]
                  | TraceEnvPeersStatus      !(Map PeerAddr PeerStatus)
                  | TraceEnvSetUseBootstrapPeers !UseBootstrapPeers
                  | TraceEnvSetLedgerStateJudgement !LedgerStateJudgement
                  | TraceEnvUseLedgerPeers !UseLedgerPeers
                  | TraceEnvGenesisLsjAndTargets !(LedgerStateJudgement, PeerSelectionTargets)
  deriving Int -> TraceMockEnv -> ShowS
[TraceMockEnv] -> ShowS
TraceMockEnv -> TestName
(Int -> TraceMockEnv -> ShowS)
-> (TraceMockEnv -> TestName)
-> ([TraceMockEnv] -> ShowS)
-> Show TraceMockEnv
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TraceMockEnv -> ShowS
showsPrec :: Int -> TraceMockEnv -> ShowS
$cshow :: TraceMockEnv -> TestName
show :: TraceMockEnv -> TestName
$cshowList :: [TraceMockEnv] -> ShowS
showList :: [TraceMockEnv] -> ShowS
Show

mockPeerSelectionActions :: forall m.
                            (MonadAsync m, MonadDelay m, Fail.MonadFail m,
                             MonadThrow (STM m), MonadTraceSTM m)
                         => Tracer m TraceMockEnv
                         -> GovernorMockEnvironment
                         -> ConsensusModePeerTargets
                         -> STM m UseBootstrapPeers
                         -> STM m UseLedgerPeers
                         -> STM m LedgerStateJudgement
                         -> STM m PeerSelectionTargets
                         -> PeerSelectionPolicy PeerAddr m
                         -> m (PeerSelectionActions PeerAddr (PeerConn m) m)
mockPeerSelectionActions :: forall (m :: * -> *).
(MonadAsync m, MonadDelay m, MonadFail m, MonadThrow (STM m),
 MonadTraceSTM m) =>
Tracer m TraceMockEnv
-> GovernorMockEnvironment
-> ConsensusModePeerTargets
-> STM m UseBootstrapPeers
-> STM m UseLedgerPeers
-> STM m LedgerStateJudgement
-> STM m PeerSelectionTargets
-> PeerSelectionPolicy PeerAddr m
-> m (PeerSelectionActions PeerAddr (PeerConn m) m)
mockPeerSelectionActions Tracer m TraceMockEnv
tracer
                         env :: GovernorMockEnvironment
env@GovernorMockEnvironment {
                           PeerGraph
peerGraph :: GovernorMockEnvironment -> PeerGraph
peerGraph :: PeerGraph
peerGraph,
                           LocalRootPeers PeerAddr
localRootPeers :: GovernorMockEnvironment -> LocalRootPeers PeerAddr
localRootPeers :: LocalRootPeers PeerAddr
localRootPeers,
                           PublicRootPeers PeerAddr
publicRootPeers :: GovernorMockEnvironment -> PublicRootPeers PeerAddr
publicRootPeers :: PublicRootPeers PeerAddr
publicRootPeers
                         }
                         ConsensusModePeerTargets
initialPeerTargets
                         STM m UseBootstrapPeers
readUseBootstrapPeers
                         STM m UseLedgerPeers
readUseLedgerPeers
                         STM m LedgerStateJudgement
getLedgerStateJudgement
                         STM m PeerSelectionTargets
readTargets
                         PeerSelectionPolicy PeerAddr m
policy = do
    scripts <- [(PeerAddr,
  (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
   TVar m (Script PeerSharing),
   TVar m (Script (AsyncDemotion, ScriptDelay))))]
-> Map
     PeerAddr
     (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
      TVar m (Script PeerSharing),
      TVar m (Script (AsyncDemotion, ScriptDelay)))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PeerAddr,
   (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
    TVar m (Script PeerSharing),
    TVar m (Script (AsyncDemotion, ScriptDelay))))]
 -> Map
      PeerAddr
      (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
       TVar m (Script PeerSharing),
       TVar m (Script (AsyncDemotion, ScriptDelay))))
-> m [(PeerAddr,
       (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
        TVar m (Script PeerSharing),
        TVar m (Script (AsyncDemotion, ScriptDelay))))]
-> m (Map
        PeerAddr
        (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
         TVar m (Script PeerSharing),
         TVar m (Script (AsyncDemotion, ScriptDelay))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                 [m (PeerAddr,
    (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
     TVar m (Script PeerSharing),
     TVar m (Script (AsyncDemotion, ScriptDelay))))]
-> m [(PeerAddr,
       (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
        TVar m (Script PeerSharing),
        TVar m (Script (AsyncDemotion, ScriptDelay))))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence
                   [ (\TVar m (Script (Maybe ([PeerAddr], PeerShareTime)))
a TVar m (Script PeerSharing)
b TVar m (Script (AsyncDemotion, ScriptDelay))
c -> (PeerAddr
addr, (TVar m (Script (Maybe ([PeerAddr], PeerShareTime)))
a, TVar m (Script PeerSharing)
b, TVar m (Script (AsyncDemotion, ScriptDelay))
c)))
                     (TVar m (Script (Maybe ([PeerAddr], PeerShareTime)))
 -> TVar m (Script PeerSharing)
 -> TVar m (Script (AsyncDemotion, ScriptDelay))
 -> (PeerAddr,
     (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
      TVar m (Script PeerSharing),
      TVar m (Script (AsyncDemotion, ScriptDelay)))))
-> m (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))))
-> m (TVar m (Script PeerSharing)
      -> TVar m (Script (AsyncDemotion, ScriptDelay))
      -> (PeerAddr,
          (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
           TVar m (Script PeerSharing),
           TVar m (Script (AsyncDemotion, ScriptDelay)))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Script (Maybe ([PeerAddr], PeerShareTime))
-> m (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))))
forall (m :: * -> *) a.
MonadSTM m =>
Script a -> m (TVar m (Script a))
initScript Script (Maybe ([PeerAddr], PeerShareTime))
peerShareScript
                     m (TVar m (Script PeerSharing)
   -> TVar m (Script (AsyncDemotion, ScriptDelay))
   -> (PeerAddr,
       (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
        TVar m (Script PeerSharing),
        TVar m (Script (AsyncDemotion, ScriptDelay)))))
-> m (TVar m (Script PeerSharing))
-> m (TVar m (Script (AsyncDemotion, ScriptDelay))
      -> (PeerAddr,
          (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
           TVar m (Script PeerSharing),
           TVar m (Script (AsyncDemotion, ScriptDelay)))))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Script PeerSharing -> m (TVar m (Script PeerSharing))
forall (m :: * -> *) a.
MonadSTM m =>
Script a -> m (TVar m (Script a))
initScript Script PeerSharing
peerSharingScript
                     m (TVar m (Script (AsyncDemotion, ScriptDelay))
   -> (PeerAddr,
       (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
        TVar m (Script PeerSharing),
        TVar m (Script (AsyncDemotion, ScriptDelay)))))
-> m (TVar m (Script (AsyncDemotion, ScriptDelay)))
-> m (PeerAddr,
      (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
       TVar m (Script PeerSharing),
       TVar m (Script (AsyncDemotion, ScriptDelay))))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Script (AsyncDemotion, ScriptDelay)
-> m (TVar m (Script (AsyncDemotion, ScriptDelay)))
forall (m :: * -> *) a.
MonadSTM m =>
Script a -> m (TVar m (Script a))
initScript Script (AsyncDemotion, ScriptDelay)
connectionScript
                   | let PeerGraph [(PeerAddr, [PeerAddr], GovernorScripts)]
adjacency = PeerGraph
peerGraph
                   , (PeerAddr
addr, [PeerAddr]
_, GovernorScripts {
                                 Script (Maybe ([PeerAddr], PeerShareTime))
peerShareScript :: Script (Maybe ([PeerAddr], PeerShareTime))
peerShareScript :: GovernorScripts -> Script (Maybe ([PeerAddr], PeerShareTime))
peerShareScript,
                                 Script PeerSharing
peerSharingScript :: Script PeerSharing
peerSharingScript :: GovernorScripts -> Script PeerSharing
peerSharingScript,
                                 Script (AsyncDemotion, ScriptDelay)
connectionScript :: GovernorScripts -> Script (AsyncDemotion, ScriptDelay)
connectionScript :: Script (AsyncDemotion, ScriptDelay)
connectionScript
                               }) <- [(PeerAddr, [PeerAddr], GovernorScripts)]
adjacency
                   ]
    peerConns  <- atomically $ do
      v <- newTVar Map.empty
      traceTVar proxy
                v (\Maybe (Map PeerAddr (TVar m PeerStatus))
_ Map PeerAddr (TVar m PeerStatus)
a -> TraceMockEnv -> TraceValue
forall tr. Typeable tr => tr -> TraceValue
TraceDynamic (TraceMockEnv -> TraceValue)
-> (Map PeerAddr PeerStatus -> TraceMockEnv)
-> Map PeerAddr PeerStatus
-> TraceValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map PeerAddr PeerStatus -> TraceMockEnv
TraceEnvPeersStatus
                       (Map PeerAddr PeerStatus -> TraceValue)
-> InspectMonad m (Map PeerAddr PeerStatus)
-> InspectMonad m TraceValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Proxy m
-> Map PeerAddr (TVar m PeerStatus)
-> InspectMonad m (Map PeerAddr PeerStatus)
forall (m :: * -> *) (proxy :: (* -> *) -> *).
MonadInspectSTM m =>
proxy m
-> Map PeerAddr (TVar m PeerStatus)
-> InspectMonad m (Map PeerAddr PeerStatus)
snapshotPeersStatus Proxy m
proxy Map PeerAddr (TVar m PeerStatus)
a)
      return v

    onlyLocalOutboundConnsVar <- newTVarIO UntrustedState
    traceWith tracer (TraceEnvAddPeers peerGraph)
    traceWith tracer (TraceEnvSetLocalRoots localRootPeers)   --TODO: make dynamic
    traceWith tracer (TraceEnvSetPublicRoots publicRootPeers) --TODO: make dynamic
    return $ mockPeerSelectionActions'
               tracer env initialPeerTargets policy
               scripts readTargets
               readUseBootstrapPeers
               readUseLedgerPeers
               getLedgerStateJudgement
               peerConns
               onlyLocalOutboundConnsVar
  where
    proxy :: Proxy m
    proxy :: Proxy m
proxy = Proxy m
forall {k} (t :: k). Proxy t
Proxy


data TransitionError
  = ActivationError
  | DeactivationError
  deriving (Int -> TransitionError -> ShowS
[TransitionError] -> ShowS
TransitionError -> TestName
(Int -> TransitionError -> ShowS)
-> (TransitionError -> TestName)
-> ([TransitionError] -> ShowS)
-> Show TransitionError
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransitionError -> ShowS
showsPrec :: Int -> TransitionError -> ShowS
$cshow :: TransitionError -> TestName
show :: TransitionError -> TestName
$cshowList :: [TransitionError] -> ShowS
showList :: [TransitionError] -> ShowS
Show, Typeable)

instance Exception TransitionError where


mockPeerSelectionActions' :: forall m.
                             (MonadAsync m, MonadDelay m, Fail.MonadFail m,
                              MonadThrow (STM m))
                          => Tracer m TraceMockEnv
                          -> GovernorMockEnvironment
                          -> ConsensusModePeerTargets
                          -> PeerSelectionPolicy PeerAddr m
                          -> Map PeerAddr (TVar m PeerShareScript, TVar m PeerSharingScript, TVar m ConnectionScript)
                          -> STM m PeerSelectionTargets
                          -> STM m UseBootstrapPeers
                          -> STM m UseLedgerPeers
                          -> STM m LedgerStateJudgement
                          -> TVar m (Map PeerAddr (TVar m PeerStatus))
                          -> TVar m OutboundConnectionsState
                          -> PeerSelectionActions PeerAddr (PeerConn m) m
mockPeerSelectionActions' :: forall (m :: * -> *).
(MonadAsync m, MonadDelay m, MonadFail m, MonadThrow (STM m)) =>
Tracer m TraceMockEnv
-> GovernorMockEnvironment
-> ConsensusModePeerTargets
-> PeerSelectionPolicy PeerAddr m
-> Map
     PeerAddr
     (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
      TVar m (Script PeerSharing),
      TVar m (Script (AsyncDemotion, ScriptDelay)))
-> STM m PeerSelectionTargets
-> STM m UseBootstrapPeers
-> STM m UseLedgerPeers
-> STM m LedgerStateJudgement
-> TVar m (Map PeerAddr (TVar m PeerStatus))
-> TVar m OutboundConnectionsState
-> PeerSelectionActions PeerAddr (PeerConn m) m
mockPeerSelectionActions' Tracer m TraceMockEnv
tracer
                          GovernorMockEnvironment {
                            LocalRootPeers PeerAddr
localRootPeers :: GovernorMockEnvironment -> LocalRootPeers PeerAddr
localRootPeers :: LocalRootPeers PeerAddr
localRootPeers,
                            PublicRootPeers PeerAddr
publicRootPeers :: GovernorMockEnvironment -> PublicRootPeers PeerAddr
publicRootPeers :: PublicRootPeers PeerAddr
publicRootPeers,
                            PeerSharing
peerSharingFlag :: GovernorMockEnvironment -> PeerSharing
peerSharingFlag :: PeerSharing
peerSharingFlag
                          }
                          ConsensusModePeerTargets
peerTargets
                          PeerSelectionPolicy PeerAddr m
_
                          Map
  PeerAddr
  (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
   TVar m (Script PeerSharing),
   TVar m (Script (AsyncDemotion, ScriptDelay)))
scripts
                          STM m PeerSelectionTargets
readTargets
                          STM m UseBootstrapPeers
readUseBootstrapPeers
                          STM m UseLedgerPeers
readUseLedgerPeers
                          STM m LedgerStateJudgement
readLedgerStateJudgement
                          TVar m (Map PeerAddr (TVar m PeerStatus))
connsVar
                          TVar m OutboundConnectionsState
outboundConnectionsStateVar =
    PeerSelectionActions {
      readLocalRootPeers :: STM m (Config PeerAddr)
readLocalRootPeers       = Config PeerAddr -> STM m (Config PeerAddr)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalRootPeers PeerAddr -> Config PeerAddr
forall peeraddr.
Ord peeraddr =>
LocalRootPeers peeraddr
-> [(HotValency, WarmValency,
     Map peeraddr (PeerAdvertise, PeerTrustable))]
LocalRootPeers.toGroups LocalRootPeers PeerAddr
localRootPeers),
      peerSharing :: PeerSharing
peerSharing              = PeerSharing
peerSharingFlag,
      peerConnToPeerSharing :: PeerConn m -> PeerSharing
peerConnToPeerSharing    = \(PeerConn PeerAddr
_ PeerSharing
ps TVar m PeerStatus
_) -> PeerSharing
ps,
      LedgerPeersKind -> Int -> m (PublicRootPeers PeerAddr, DiffTime)
forall {p}.
LedgerPeersKind -> p -> m (PublicRootPeers PeerAddr, DiffTime)
requestPublicRootPeers :: forall {p}.
LedgerPeersKind -> p -> m (PublicRootPeers PeerAddr, DiffTime)
requestPublicRootPeers :: LedgerPeersKind -> Int -> m (PublicRootPeers PeerAddr, DiffTime)
requestPublicRootPeers,
      readPeerSelectionTargets :: STM m PeerSelectionTargets
readPeerSelectionTargets = STM m PeerSelectionTargets
readTargets,
      PeerSharingAmount -> PeerAddr -> m (PeerSharingResult PeerAddr)
requestPeerShare :: PeerSharingAmount -> PeerAddr -> m (PeerSharingResult PeerAddr)
requestPeerShare :: PeerSharingAmount -> PeerAddr -> m (PeerSharingResult PeerAddr)
requestPeerShare,
      peerStateActions :: PeerStateActions PeerAddr (PeerConn m) m
peerStateActions         = PeerStateActions {
          IsBigLedgerPeer -> PeerAddr -> m (PeerConn m)
establishPeerConnection :: IsBigLedgerPeer -> PeerAddr -> m (PeerConn m)
establishPeerConnection :: IsBigLedgerPeer -> PeerAddr -> m (PeerConn m)
establishPeerConnection,
          PeerConn m -> STM m (PeerStatus, Maybe RepromoteDelay)
monitorPeerConnection :: PeerConn m -> STM m (PeerStatus, Maybe RepromoteDelay)
monitorPeerConnection :: PeerConn m -> STM m (PeerStatus, Maybe RepromoteDelay)
monitorPeerConnection,
          IsBigLedgerPeer -> PeerConn m -> m ()
activatePeerConnection :: IsBigLedgerPeer -> PeerConn m -> m ()
activatePeerConnection :: IsBigLedgerPeer -> PeerConn m -> m ()
activatePeerConnection,
          PeerConn m -> m ()
deactivatePeerConnection :: PeerConn m -> m ()
deactivatePeerConnection :: PeerConn m -> m ()
deactivatePeerConnection,
          PeerConn m -> m ()
closePeerConnection :: PeerConn m -> m ()
closePeerConnection :: PeerConn m -> m ()
closePeerConnection
        },
      STM m UseBootstrapPeers
readUseBootstrapPeers :: STM m UseBootstrapPeers
readUseBootstrapPeers :: STM m UseBootstrapPeers
readUseBootstrapPeers,
      getLedgerStateCtx :: LedgerPeersConsensusInterface m
getLedgerStateCtx = LedgerPeersConsensusInterface {
          lpGetLedgerStateJudgement :: STM m LedgerStateJudgement
lpGetLedgerStateJudgement = STM m LedgerStateJudgement
readLedgerStateJudgement,
          lpGetLatestSlot :: STM m (WithOrigin SlotNo)
lpGetLatestSlot = WithOrigin SlotNo -> STM m (WithOrigin SlotNo)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WithOrigin SlotNo
forall t. WithOrigin t
Origin,
          lpGetLedgerPeers :: STM m [(PoolStake, NonEmpty RelayAccessPoint)]
lpGetLedgerPeers = [(PoolStake, NonEmpty RelayAccessPoint)]
-> STM m [(PoolStake, NonEmpty RelayAccessPoint)]
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] },
      readInboundPeers :: m (Map PeerAddr PeerSharing)
readInboundPeers = Map PeerAddr PeerSharing -> m (Map PeerAddr PeerSharing)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map PeerAddr PeerSharing
forall k a. Map k a
Map.empty,
      updateOutboundConnectionsState :: OutboundConnectionsState -> STM m ()
updateOutboundConnectionsState = \OutboundConnectionsState
a -> do
        a' <- TVar m OutboundConnectionsState -> STM m OutboundConnectionsState
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m OutboundConnectionsState
outboundConnectionsStateVar
        when (a /= a') $
          writeTVar outboundConnectionsStateVar a,
      ConsensusModePeerTargets
peerTargets :: ConsensusModePeerTargets
peerTargets :: ConsensusModePeerTargets
peerTargets,
      readLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot)
readLedgerPeerSnapshot = Maybe LedgerPeerSnapshot -> STM m (Maybe LedgerPeerSnapshot)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe LedgerPeerSnapshot
forall a. Maybe a
Nothing
    }
  where
    -- TODO: make this dynamic
    requestPublicRootPeers :: LedgerPeersKind -> p -> m (PublicRootPeers PeerAddr, DiffTime)
requestPublicRootPeers LedgerPeersKind
ledgerPeersKind p
_n = do
      Tracer m TraceMockEnv -> TraceMockEnv -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceMockEnv
tracer TraceMockEnv
TraceEnvRequestPublicRootPeers
      let ttl :: DiffTime
          ttl :: DiffTime
ttl = DiffTime
60
      _ <- m () -> m (Async m ())
forall a. m a -> m (Async m a)
forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a)
async (m () -> m (Async m ())) -> m () -> m (Async m ())
forall a b. (a -> b) -> a -> b
$ do
        DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
ttl
        Tracer m TraceMockEnv -> TraceMockEnv -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceMockEnv
tracer TraceMockEnv
TraceEnvPublicRootTTL

      -- Read the current ledger state judgement
      usingBootstrapPeers <- atomically
                           $ requiresBootstrapPeers <$> readUseBootstrapPeers
                                                    <*> readLedgerStateJudgement
      useLedgerPeers <- atomically readUseLedgerPeers
      -- If the ledger state is YoungEnough we should get ledger peers.
      -- Otherwise we should get bootstrap peers
      let publicConfigPeers = PublicRootPeers PeerAddr -> Map PeerAddr PeerAdvertise
forall peeraddr.
PublicRootPeers peeraddr -> Map peeraddr PeerAdvertise
PublicRootPeers.getPublicConfigPeers PublicRootPeers PeerAddr
publicRootPeers
          bootstrapPeers    = PublicRootPeers PeerAddr -> Set PeerAddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBootstrapPeers PublicRootPeers PeerAddr
publicRootPeers
          ledgerPeers       = PublicRootPeers PeerAddr -> Set PeerAddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getLedgerPeers PublicRootPeers PeerAddr
publicRootPeers
          bigLedgerPeers    = PublicRootPeers PeerAddr -> Set PeerAddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers PeerAddr
publicRootPeers
          result =
            if Bool
usingBootstrapPeers
               then Set PeerAddr -> PublicRootPeers PeerAddr
forall peeraddr. Set peeraddr -> PublicRootPeers peeraddr
PublicRootPeers.fromBootstrapPeers Set PeerAddr
bootstrapPeers
               else case UseLedgerPeers
useLedgerPeers of
                 UseLedgerPeers
DontUseLedgerPeers -> PublicRootPeers PeerAddr
forall peeraddr. PublicRootPeers peeraddr
PublicRootPeers.empty
                 UseLedgerPeers AfterSlot
_ -> case LedgerPeersKind
ledgerPeersKind of
                   LedgerPeersKind
AllLedgerPeers
                     | Set PeerAddr -> Bool
forall a. Set a -> Bool
Set.null Set PeerAddr
ledgerPeers ->
                       Map PeerAddr PeerAdvertise -> PublicRootPeers PeerAddr
forall peeraddr.
Map peeraddr PeerAdvertise -> PublicRootPeers peeraddr
PublicRootPeers.fromPublicRootPeers Map PeerAddr PeerAdvertise
publicConfigPeers
                     | Bool
otherwise            ->
                       Set PeerAddr -> PublicRootPeers PeerAddr
forall peeraddr. Set peeraddr -> PublicRootPeers peeraddr
PublicRootPeers.fromLedgerPeers Set PeerAddr
ledgerPeers
                   LedgerPeersKind
BigLedgerPeers
                     | Set PeerAddr -> Bool
forall a. Set a -> Bool
Set.null Set PeerAddr
ledgerPeers ->
                       Map PeerAddr PeerAdvertise -> PublicRootPeers PeerAddr
forall peeraddr.
Map peeraddr PeerAdvertise -> PublicRootPeers peeraddr
PublicRootPeers.fromPublicRootPeers Map PeerAddr PeerAdvertise
publicConfigPeers
                     | Bool
otherwise            ->
                       Set PeerAddr -> PublicRootPeers PeerAddr
forall peeraddr. Set peeraddr -> PublicRootPeers peeraddr
PublicRootPeers.fromBigLedgerPeers Set PeerAddr
bigLedgerPeers

      traceWith tracer (TraceEnvRootsResult (Set.toList (PublicRootPeers.toSet result)))
      return (result, ttl)

    requestPeerShare :: PeerSharingAmount -> PeerAddr -> m (PeerSharingResult PeerAddr)
    requestPeerShare :: PeerSharingAmount -> PeerAddr -> m (PeerSharingResult PeerAddr)
requestPeerShare PeerSharingAmount
_ PeerAddr
addr = do
      let Just (TVar m (Script (Maybe ([PeerAddr], PeerShareTime)))
peerShareScript, TVar m (Script PeerSharing)
_, TVar m (Script (AsyncDemotion, ScriptDelay))
_) = PeerAddr
-> Map
     PeerAddr
     (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
      TVar m (Script PeerSharing),
      TVar m (Script (AsyncDemotion, ScriptDelay)))
-> Maybe
     (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
      TVar m (Script PeerSharing),
      TVar m (Script (AsyncDemotion, ScriptDelay)))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PeerAddr
addr Map
  PeerAddr
  (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
   TVar m (Script PeerSharing),
   TVar m (Script (AsyncDemotion, ScriptDelay)))
scripts
      mPeerShare <- TVar m (Script (Maybe ([PeerAddr], PeerShareTime)))
-> m (Maybe ([PeerAddr], PeerShareTime))
forall (m :: * -> *) a. MonadSTM m => TVar m (Script a) -> m a
stepScript TVar m (Script (Maybe ([PeerAddr], PeerShareTime)))
peerShareScript
      traceWith tracer (TraceEnvPeerShareRequest addr mPeerShare)
      case mPeerShare of
        Maybe ([PeerAddr], PeerShareTime)
Nothing                -> do
          DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1
          Tracer m TraceMockEnv -> TraceMockEnv -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceMockEnv
tracer (PeerAddr -> [PeerAddr] -> TraceMockEnv
TraceEnvPeerShareResult PeerAddr
addr [])
          TestName -> m (PeerSharingResult PeerAddr)
forall a. TestName -> m a
forall (m :: * -> *) a. MonadFail m => TestName -> m a
fail TestName
"no peers"
        Just ([PeerAddr]
peeraddrs, PeerShareTime
time) -> do
          DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (PeerShareTime -> DiffTime
interpretPeerShareTime PeerShareTime
time)
          Tracer m TraceMockEnv -> TraceMockEnv -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceMockEnv
tracer (PeerAddr -> [PeerAddr] -> TraceMockEnv
TraceEnvPeerShareResult PeerAddr
addr [PeerAddr]
peeraddrs)
          PeerSharingResult PeerAddr -> m (PeerSharingResult PeerAddr)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PeerAddr] -> PeerSharingResult PeerAddr
forall peerAddress. [peerAddress] -> PeerSharingResult peerAddress
PeerSharingResult [PeerAddr]
peeraddrs)

    establishPeerConnection :: IsBigLedgerPeer -> PeerAddr -> m (PeerConn m)
    establishPeerConnection :: IsBigLedgerPeer -> PeerAddr -> m (PeerConn m)
establishPeerConnection IsBigLedgerPeer
_ PeerAddr
peeraddr = do
      --TODO: add support for variable delays and synchronous failure
      Tracer m TraceMockEnv -> TraceMockEnv -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceMockEnv
tracer (PeerAddr -> TraceMockEnv
TraceEnvEstablishConn PeerAddr
peeraddr)
      DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1
      let Just (TVar m (Script (Maybe ([PeerAddr], PeerShareTime)))
_, TVar m (Script PeerSharing)
peerSharingScript, TVar m (Script (AsyncDemotion, ScriptDelay))
connectScript) = PeerAddr
-> Map
     PeerAddr
     (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
      TVar m (Script PeerSharing),
      TVar m (Script (AsyncDemotion, ScriptDelay)))
-> Maybe
     (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
      TVar m (Script PeerSharing),
      TVar m (Script (AsyncDemotion, ScriptDelay)))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PeerAddr
peeraddr Map
  PeerAddr
  (TVar m (Script (Maybe ([PeerAddr], PeerShareTime))),
   TVar m (Script PeerSharing),
   TVar m (Script (AsyncDemotion, ScriptDelay)))
scripts
      conn@(PeerConn _ _ v) <- STM m (PeerConn m) -> m (PeerConn m)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (PeerConn m) -> m (PeerConn m))
-> STM m (PeerConn m) -> m (PeerConn m)
forall a b. (a -> b) -> a -> b
$ do
        conn  <- PeerStatus -> STM m (TVar m PeerStatus)
forall a. a -> STM m (TVar m a)
forall (m :: * -> *) a. MonadSTM m => a -> STM m (TVar m a)
newTVar PeerStatus
PeerWarm
        conns <- readTVar connsVar
        let !conns' = PeerAddr
-> TVar m PeerStatus
-> Map PeerAddr (TVar m PeerStatus)
-> Map PeerAddr (TVar m PeerStatus)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PeerAddr
peeraddr TVar m PeerStatus
conn Map PeerAddr (TVar m PeerStatus)
conns
        writeTVar connsVar conns'
        remotePeerSharing <- stepScriptSTM peerSharingScript
        return (PeerConn peeraddr (peerSharingFlag <> remotePeerSharing) conn)
      _ <- async $
        -- monitoring loop which does asynchronous demotions. It will terminate
        -- as soon as either of the events:
        --
        -- + the script returns 'Noop'
        -- + peer demoted to 'PeerCold'
        --
        let loop = do
              (demotion, delay) <- TVar m (Script (AsyncDemotion, ScriptDelay))
-> m (AsyncDemotion, ScriptDelay)
forall (m :: * -> *) a. MonadSTM m => TVar m (Script a) -> m a
stepScript TVar m (Script (AsyncDemotion, ScriptDelay))
connectScript
              let interpretScriptDelay ScriptDelay
NoDelay    = DiffTime
1
                  interpretScriptDelay ScriptDelay
ShortDelay = DiffTime
60
                  interpretScriptDelay ScriptDelay
LongDelay  = DiffTime
600
                  interpretScriptDelay (Delay DiffTime
a)  = DiffTime
a -- not used by the generator
              done <-
                case demotion of
                  AsyncDemotion
Noop   -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                  AsyncDemotion
ToWarm -> do
                    DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (ScriptDelay -> DiffTime
interpretScriptDelay ScriptDelay
delay)
                    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
                      s <- TVar m PeerStatus -> STM m PeerStatus
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m PeerStatus
v
                      case s of
                        PeerStatus
PeerHot  -> TVar m PeerStatus -> PeerStatus -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m PeerStatus
v PeerStatus
PeerWarm
                                 STM m () -> STM m Bool -> STM m Bool
forall a b. STM m a -> STM m b -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                        PeerStatus
PeerCold -> Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                        PeerStatus
_        -> Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                  AsyncDemotion
ToCooling -> do
                    DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (ScriptDelay -> DiffTime
interpretScriptDelay ScriptDelay
delay)
                    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
                      s <- TVar m PeerStatus -> STM m PeerStatus
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m PeerStatus
v
                      case s of
                        PeerStatus
PeerCooling -> Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                        PeerStatus
PeerCold -> Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                        PeerStatus
_        -> TVar m PeerStatus -> PeerStatus -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m PeerStatus
v PeerStatus
PeerCooling
                                 STM m () -> STM m Bool -> STM m Bool
forall a b. STM m a -> STM m b -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                  AsyncDemotion
ToCold -> do
                    DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (ScriptDelay -> DiffTime
interpretScriptDelay ScriptDelay
delay)
                    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
                      s <- TVar m PeerStatus -> STM m PeerStatus
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m PeerStatus
v
                      case s of
                        PeerStatus
PeerCold -> Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                        PeerStatus
_        -> TVar m PeerStatus -> PeerStatus -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m PeerStatus
v PeerStatus
PeerCold
                                 STM m () -> STM m Bool -> STM m Bool
forall a b. STM m a -> STM m b -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> STM m Bool
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

              traceWith tracer (TraceEnvPeersDemote demotion peeraddr)

              if done
                then return ()
                else loop
        in loop
      return conn

    activatePeerConnection :: IsBigLedgerPeer -> PeerConn m -> m ()
    activatePeerConnection :: IsBigLedgerPeer -> PeerConn m -> m ()
activatePeerConnection IsBigLedgerPeer
_ (PeerConn PeerAddr
peeraddr PeerSharing
_ TVar m PeerStatus
conn) = do
      Tracer m TraceMockEnv -> TraceMockEnv -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceMockEnv
tracer (PeerAddr -> TraceMockEnv
TraceEnvActivatePeer PeerAddr
peeraddr)
      DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
1
      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
$ do
        status <- TVar m PeerStatus -> STM m PeerStatus
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m PeerStatus
conn
        case status of
          PeerStatus
PeerHot     -> TestName -> STM m ()
forall a. HasCallStack => TestName -> a
error TestName
"activatePeerConnection of hot peer"
          PeerStatus
PeerWarm    -> TVar m PeerStatus -> PeerStatus -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m PeerStatus
conn PeerStatus
PeerHot
          --TODO: check it's just a race condition and not just wrong:
          --
          -- We throw 'ActivationError' for the following reason:
          -- 'PeerCold' can be set by the monitoring loop started by
          -- 'establishedPeerConnection' above.  However if that happens we
          -- want to signal the governor that the warm -> hot transition
          -- errored.  Otherwise 'jobPromoteWarmPeer' will try to update the
          -- state as if the transition went fine which will violate
          -- 'invariantPeerSelectionState'.
          PeerStatus
PeerCooling -> TransitionError -> STM m ()
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO TransitionError
ActivationError
          PeerStatus
PeerCold    -> TransitionError -> STM m ()
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO TransitionError
ActivationError

    deactivatePeerConnection :: PeerConn m -> m ()
    deactivatePeerConnection :: PeerConn m -> m ()
deactivatePeerConnection (PeerConn PeerAddr
peeraddr PeerSharing
_ TVar m PeerStatus
conn) = do
      Tracer m TraceMockEnv -> TraceMockEnv -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceMockEnv
tracer (PeerAddr -> TraceMockEnv
TraceEnvDeactivatePeer PeerAddr
peeraddr)
      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
$ do
        status <- TVar m PeerStatus -> STM m PeerStatus
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m PeerStatus
conn
        case status of
          PeerStatus
PeerHot     -> TVar m PeerStatus -> PeerStatus -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m PeerStatus
conn PeerStatus
PeerWarm
          --TODO: check it's just a race condition and not just wrong:
          PeerStatus
PeerWarm    -> () -> STM m ()
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          -- See the note in 'activatePeerConnection' why we throw an exception
          -- here.
          PeerStatus
PeerCooling -> TransitionError -> STM m ()
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO TransitionError
DeactivationError
          PeerStatus
PeerCold    -> TransitionError -> STM m ()
forall e a. Exception e => e -> STM m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO TransitionError
DeactivationError

    closePeerConnection :: PeerConn m -> m ()
    closePeerConnection :: PeerConn m -> m ()
closePeerConnection (PeerConn PeerAddr
peeraddr PeerSharing
_ TVar m PeerStatus
conn) = do
      Tracer m TraceMockEnv -> TraceMockEnv -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceMockEnv
tracer (PeerAddr -> TraceMockEnv
TraceEnvCloseConn PeerAddr
peeraddr)
      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
$ do
        status <- TVar m PeerStatus -> STM m PeerStatus
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m PeerStatus
conn
        case status of
          PeerStatus
PeerHot     -> TVar m PeerStatus -> PeerStatus -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m PeerStatus
conn PeerStatus
PeerCold
          --TODO: check it's just a race condition and not just wrong:
          PeerStatus
PeerWarm    -> TVar m PeerStatus -> PeerStatus -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m PeerStatus
conn PeerStatus
PeerCold
          PeerStatus
PeerCooling -> TVar m PeerStatus -> PeerStatus -> STM m ()
forall a. TVar m a -> a -> STM m ()
forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m ()
writeTVar TVar m PeerStatus
conn PeerStatus
PeerCold
          PeerStatus
PeerCold    -> () -> STM m ()
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        conns <- readTVar connsVar
        let !conns' = PeerAddr
-> Map PeerAddr (TVar m PeerStatus)
-> Map PeerAddr (TVar m PeerStatus)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete PeerAddr
peeraddr Map PeerAddr (TVar m PeerStatus)
conns
        writeTVar connsVar conns'

    monitorPeerConnection :: PeerConn m -> STM m (PeerStatus, Maybe RepromoteDelay)
    monitorPeerConnection :: PeerConn m -> STM m (PeerStatus, Maybe RepromoteDelay)
monitorPeerConnection (PeerConn PeerAddr
_peeraddr PeerSharing
_ TVar m PeerStatus
conn) = do
      st <- TVar m PeerStatus -> STM m PeerStatus
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
readTVar TVar m PeerStatus
conn
      pure $ case st of
        PeerStatus
PeerCooling -> (PeerStatus
st, Maybe RepromoteDelay
forall a. Maybe a
Nothing)
        PeerStatus
_           -> (PeerStatus
st, RepromoteDelay -> Maybe RepromoteDelay
forall a. a -> Maybe a
Just RepromoteDelay
config_REPROMOTE_DELAY)


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


snapshotPeersStatus :: MonadInspectSTM m
                    => proxy m
                    -> Map PeerAddr (TVar m PeerStatus)
                    -> InspectMonad m (Map PeerAddr PeerStatus)
snapshotPeersStatus :: forall (m :: * -> *) (proxy :: (* -> *) -> *).
MonadInspectSTM m =>
proxy m
-> Map PeerAddr (TVar m PeerStatus)
-> InspectMonad m (Map PeerAddr PeerStatus)
snapshotPeersStatus proxy m
p Map PeerAddr (TVar m PeerStatus)
conns = (TVar m PeerStatus -> InspectMonad m PeerStatus)
-> Map PeerAddr (TVar m PeerStatus)
-> InspectMonad m (Map PeerAddr PeerStatus)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map PeerAddr a -> f (Map PeerAddr b)
traverse (proxy m -> TVar m PeerStatus -> InspectMonad m PeerStatus
forall (m :: * -> *) (proxy :: (* -> *) -> *) a.
MonadInspectSTM m =>
proxy m -> TVar m a -> InspectMonad m a
forall (proxy :: (* -> *) -> *) a.
proxy m -> TVar m a -> InspectMonad m a
inspectTVar proxy m
p) Map PeerAddr (TVar m PeerStatus)
conns


mockPeerSelectionPolicy  :: MonadSTM m
                         => GovernorMockEnvironment
                         -> m (PeerSelectionPolicy PeerAddr m)
mockPeerSelectionPolicy :: forall (m :: * -> *).
MonadSTM m =>
GovernorMockEnvironment -> m (PeerSelectionPolicy PeerAddr m)
mockPeerSelectionPolicy GovernorMockEnvironment {
                          PickScript PeerAddr
pickKnownPeersForPeerShare :: GovernorMockEnvironment -> PickScript PeerAddr
pickKnownPeersForPeerShare :: PickScript PeerAddr
pickKnownPeersForPeerShare,
                          PickScript PeerAddr
pickColdPeersToPromote :: GovernorMockEnvironment -> PickScript PeerAddr
pickColdPeersToPromote :: PickScript PeerAddr
pickColdPeersToPromote,
                          PickScript PeerAddr
pickWarmPeersToPromote :: GovernorMockEnvironment -> PickScript PeerAddr
pickWarmPeersToPromote :: PickScript PeerAddr
pickWarmPeersToPromote,
                          PickScript PeerAddr
pickHotPeersToDemote :: GovernorMockEnvironment -> PickScript PeerAddr
pickHotPeersToDemote :: PickScript PeerAddr
pickHotPeersToDemote,
                          PickScript PeerAddr
pickWarmPeersToDemote :: GovernorMockEnvironment -> PickScript PeerAddr
pickWarmPeersToDemote :: PickScript PeerAddr
pickWarmPeersToDemote,
                          PickScript PeerAddr
pickColdPeersToForget :: GovernorMockEnvironment -> PickScript PeerAddr
pickColdPeersToForget :: PickScript PeerAddr
pickColdPeersToForget,
                          PickScript PeerAddr
pickInboundPeers :: GovernorMockEnvironment -> PickScript PeerAddr
pickInboundPeers :: PickScript PeerAddr
pickInboundPeers
                        } = do
    pickKnownPeersForPeerShareVar <- PickScript PeerAddr -> m (StrictTVar m (PickScript PeerAddr))
forall (m :: * -> *) a.
MonadSTM m =>
Script a -> m (StrictTVar m (Script a))
initScript' PickScript PeerAddr
pickKnownPeersForPeerShare
    pickColdPeersToPromoteVar  <- initScript' pickColdPeersToPromote
    pickWarmPeersToPromoteVar  <- initScript' pickWarmPeersToPromote
    pickHotPeersToDemoteVar    <- initScript' pickHotPeersToDemote
    pickWarmPeersToDemoteVar   <- initScript' pickWarmPeersToDemote
    pickColdPeersToForgetVar   <- initScript' pickColdPeersToForget
    pickInboundPeersVar        <- initScript' pickInboundPeers
    return PeerSelectionPolicy {
      policyPickKnownPeersForPeerShare = \PeerAddr -> PeerSource
_ PeerAddr -> Int
_ PeerAddr -> Bool
_ -> StrictTVar m (PickScript PeerAddr)
-> Set PeerAddr -> Int -> STM m (Set PeerAddr)
forall (m :: * -> *) peeraddr.
(MonadSTM m, Ord peeraddr) =>
StrictTVar m (PickScript peeraddr)
-> Set peeraddr -> Int -> STM m (Set peeraddr)
interpretPickScript StrictTVar m (PickScript PeerAddr)
pickKnownPeersForPeerShareVar,
      policyPickColdPeersToPromote  = \PeerAddr -> PeerSource
_ PeerAddr -> Int
_ PeerAddr -> Bool
_ -> StrictTVar m (PickScript PeerAddr)
-> Set PeerAddr -> Int -> STM m (Set PeerAddr)
forall (m :: * -> *) peeraddr.
(MonadSTM m, Ord peeraddr) =>
StrictTVar m (PickScript peeraddr)
-> Set peeraddr -> Int -> STM m (Set peeraddr)
interpretPickScript StrictTVar m (PickScript PeerAddr)
pickColdPeersToPromoteVar,
      policyPickWarmPeersToPromote  = \PeerAddr -> PeerSource
_ PeerAddr -> Int
_ PeerAddr -> Bool
_ -> StrictTVar m (PickScript PeerAddr)
-> Set PeerAddr -> Int -> STM m (Set PeerAddr)
forall (m :: * -> *) peeraddr.
(MonadSTM m, Ord peeraddr) =>
StrictTVar m (PickScript peeraddr)
-> Set peeraddr -> Int -> STM m (Set peeraddr)
interpretPickScript StrictTVar m (PickScript PeerAddr)
pickWarmPeersToPromoteVar,
      policyPickHotPeersToDemote    = \PeerAddr -> PeerSource
_ PeerAddr -> Int
_ PeerAddr -> Bool
_ -> StrictTVar m (PickScript PeerAddr)
-> Set PeerAddr -> Int -> STM m (Set PeerAddr)
forall (m :: * -> *) peeraddr.
(MonadSTM m, Ord peeraddr) =>
StrictTVar m (PickScript peeraddr)
-> Set peeraddr -> Int -> STM m (Set peeraddr)
interpretPickScript StrictTVar m (PickScript PeerAddr)
pickHotPeersToDemoteVar,
      policyPickWarmPeersToDemote   = \PeerAddr -> PeerSource
_ PeerAddr -> Int
_ PeerAddr -> Bool
_ -> StrictTVar m (PickScript PeerAddr)
-> Set PeerAddr -> Int -> STM m (Set PeerAddr)
forall (m :: * -> *) peeraddr.
(MonadSTM m, Ord peeraddr) =>
StrictTVar m (PickScript peeraddr)
-> Set peeraddr -> Int -> STM m (Set peeraddr)
interpretPickScript StrictTVar m (PickScript PeerAddr)
pickWarmPeersToDemoteVar,
      policyPickColdPeersToForget   = \PeerAddr -> PeerSource
_ PeerAddr -> Int
_ PeerAddr -> Bool
_ -> StrictTVar m (PickScript PeerAddr)
-> Set PeerAddr -> Int -> STM m (Set PeerAddr)
forall (m :: * -> *) peeraddr.
(MonadSTM m, Ord peeraddr) =>
StrictTVar m (PickScript peeraddr)
-> Set peeraddr -> Int -> STM m (Set peeraddr)
interpretPickScript StrictTVar m (PickScript PeerAddr)
pickColdPeersToForgetVar,
      policyPickInboundPeers        = \PeerAddr -> PeerSource
_ PeerAddr -> Int
_ PeerAddr -> Bool
_ -> StrictTVar m (PickScript PeerAddr)
-> Set PeerAddr -> Int -> STM m (Set PeerAddr)
forall (m :: * -> *) peeraddr.
(MonadSTM m, Ord peeraddr) =>
StrictTVar m (PickScript peeraddr)
-> Set peeraddr -> Int -> STM m (Set peeraddr)
interpretPickScript StrictTVar m (PickScript PeerAddr)
pickInboundPeersVar,
      policyFindPublicRootTimeout   = 5,    -- seconds
      policyMaxInProgressPeerShareReqs = 2,
      policyPeerShareRetryTime         = 3600, -- seconds
      policyPeerShareBatchWaitTime     = 3,    -- seconds
      policyPeerShareOverallTimeout    = 10,   -- seconds
      policyPeerShareActivationDelay   = 300,  -- seconds
      policyErrorDelay                 = 10    -- seconds
    }

--
-- Utils for properties
--

data TestTraceEvent = GovernorDebug           !(DebugPeerSelection PeerAddr)
                    | GovernorEvent           !(TracePeerSelection PeerAddr)
                    | GovernorCounters        !PeerSelectionCounters
                    | GovernorAssociationMode !AssociationMode
                    | MockEnvEvent            !TraceMockEnv
                   -- Warning: be careful with writing properties that rely
                   -- on trace events from both the governor and from the
                   -- 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.
                   -- The governor debug vs other events are fully ordered.
  deriving Int -> TestTraceEvent -> ShowS
[TestTraceEvent] -> ShowS
TestTraceEvent -> TestName
(Int -> TestTraceEvent -> ShowS)
-> (TestTraceEvent -> TestName)
-> ([TestTraceEvent] -> ShowS)
-> Show TestTraceEvent
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestTraceEvent -> ShowS
showsPrec :: Int -> TestTraceEvent -> ShowS
$cshow :: TestTraceEvent -> TestName
show :: TestTraceEvent -> TestName
$cshowList :: [TestTraceEvent] -> ShowS
showList :: [TestTraceEvent] -> ShowS
Show

tracerTracePeerSelection :: Tracer (IOSim s) (TracePeerSelection PeerAddr)
tracerTracePeerSelection :: forall s. Tracer (IOSim s) (TracePeerSelection PeerAddr)
tracerTracePeerSelection = (TracePeerSelection PeerAddr -> TestTraceEvent)
-> Tracer (IOSim s) TestTraceEvent
-> Tracer (IOSim s) (TracePeerSelection PeerAddr)
forall a' a. (a' -> a) -> Tracer (IOSim s) a -> Tracer (IOSim s) a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap TracePeerSelection PeerAddr -> TestTraceEvent
f Tracer (IOSim s) TestTraceEvent
forall s. Tracer (IOSim s) TestTraceEvent
tracerTestTraceEvent
  where
    -- make the tracer strict
    f :: TracePeerSelection PeerAddr -> TestTraceEvent
    f :: TracePeerSelection PeerAddr -> TestTraceEvent
f a :: TracePeerSelection PeerAddr
a@(TraceLocalRootPeersChanged !LocalRootPeers PeerAddr
_ !LocalRootPeers PeerAddr
_)                   = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceTargetsChanged !PeerSelectionTargets
_ !PeerSelectionTargets
_)                          = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePublicRootsRequest !Int
_ !Int
_)                      = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePublicRootsResults !PublicRootPeers PeerAddr
_ !Int
_ !DiffTime
_)                   = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePublicRootsFailure !SomeException
_ !Int
_ !DiffTime
_)                   = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceForgetColdPeers !Int
_ !Int
_ !Set PeerAddr
_)                      = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceBigLedgerPeersRequest !Int
_ !Int
_)                   = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceBigLedgerPeersResults !Set PeerAddr
_ !Int
_ !DiffTime
_)                = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceBigLedgerPeersFailure !SomeException
_ !Int
_ !DiffTime
_)                = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceForgetBigLedgerPeers !Int
_ !Int
_ !Set PeerAddr
_)                 = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePickInboundPeers !Int
_ !Int
_ !Map PeerAddr PeerSharing
_ !Set PeerAddr
_)                  = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePeerShareRequests !Int
_ !Int
_ !PeerSharingAmount
_ !Set PeerAddr
_ !Set PeerAddr
_)              = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePeerShareResults ![(PeerAddr, Either SomeException (PeerSharingResult PeerAddr))]
_)                           = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePeerShareResultsFiltered ![PeerAddr]
_)                   = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePromoteColdPeers !Int
_ !Int
_ !Set PeerAddr
_)                     = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePromoteColdLocalPeers ![(WarmValency, Int)]
_ !Set PeerAddr
_)                   = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePromoteColdFailed !Int
_ !Int
_ !PeerAddr
_ !DiffTime
_ !SomeException
_)              = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePromoteColdDone !Int
_ !Int
_ !PeerAddr
_)                      = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePromoteColdBigLedgerPeers !Int
_ !Int
_ !Set PeerAddr
_)            = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePromoteColdBigLedgerPeerFailed !Int
_ !Int
_ !PeerAddr
_ !DiffTime
_ !SomeException
_) = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePromoteColdBigLedgerPeerDone !Int
_ !Int
_ !PeerAddr
_)         = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePromoteWarmPeers !Int
_ !Int
_ !Set PeerAddr
_)                     = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePromoteWarmLocalPeers ![(HotValency, Int)]
_ !Set PeerAddr
_)                   = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePromoteWarmFailed !Int
_ !Int
_ !PeerAddr
_ !SomeException
_)                 = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePromoteWarmDone !Int
_ !Int
_ !PeerAddr
_)                      = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePromoteWarmAborted !Int
_ !Int
_ !PeerAddr
_)                   = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePromoteWarmBigLedgerPeers !Int
_ !Int
_ !Set PeerAddr
_)            = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePromoteWarmBigLedgerPeerFailed !Int
_ !Int
_ !PeerAddr
_ !SomeException
_)    = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePromoteWarmBigLedgerPeerDone !Int
_ !Int
_ !PeerAddr
_)         = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TracePromoteWarmBigLedgerPeerAborted !Int
_ !Int
_ !PeerAddr
_)      = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceDemoteWarmPeers !Int
_ !Int
_ !Set PeerAddr
_)                      = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceDemoteWarmFailed !Int
_ !Int
_ !PeerAddr
_ !SomeException
_)                  = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceDemoteWarmDone !Int
_ !Int
_ !PeerAddr
_)                       = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceDemoteWarmBigLedgerPeers !Int
_ !Int
_ !Set PeerAddr
_)             = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceDemoteWarmBigLedgerPeerFailed !Int
_ !Int
_ !PeerAddr
_ !SomeException
_)     = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceDemoteWarmBigLedgerPeerDone !Int
_ !Int
_ !PeerAddr
_)          = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceDemoteHotPeers !Int
_ !Int
_ !Set PeerAddr
_)                       = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceDemoteLocalHotPeers ![(HotValency, Int)]
_ !Set PeerAddr
_)                     = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceDemoteHotFailed !Int
_ !Int
_ !PeerAddr
_ !SomeException
_)                   = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceDemoteHotDone !Int
_ !Int
_ !PeerAddr
_)                        = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceDemoteHotBigLedgerPeers !Int
_ !Int
_ !Set PeerAddr
_)              = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceDemoteHotBigLedgerPeerFailed !Int
_ !Int
_ !PeerAddr
_ !SomeException
_)      = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceDemoteHotBigLedgerPeerDone !Int
_ !Int
_ !PeerAddr
_)           = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceDemoteAsynchronous !Map PeerAddr (PeerStatus, Maybe RepromoteDelay)
_)                         = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceDemoteLocalAsynchronous !Map PeerAddr (PeerStatus, Maybe RepromoteDelay)
_)                    = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceDemoteBigLedgerPeersAsynchronous !Map PeerAddr (PeerStatus, Maybe RepromoteDelay)
_)           = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@TracePeerSelection PeerAddr
TraceGovernorWakeup                                  = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceChurnWait !DiffTime
_)                                  = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceChurnMode !ChurnMode
_)                                  = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceLedgerStateJudgementChanged !LedgerStateJudgement
_)                = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@TracePeerSelection PeerAddr
TraceOnlyBootstrapPeers                              = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@TracePeerSelection PeerAddr
TraceBootstrapPeersFlagChangedWhilstInSensitiveState = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceUseBootstrapPeersChanged !UseBootstrapPeers
_)                   = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceOutboundGovernorCriticalFailure !SomeException
_)            = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceDebugState !Time
_ !DebugPeerSelectionState PeerAddr
_)                              = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceChurnAction !DiffTime
_ !ChurnAction
_ !Int
_)                          = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceChurnTimeout !DiffTime
_ !ChurnAction
_ !Int
_)                         = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a
    f a :: TracePeerSelection PeerAddr
a@(TraceVerifyPeerSnapshot !Bool
_)                         = TracePeerSelection PeerAddr -> TestTraceEvent
GovernorEvent TracePeerSelection PeerAddr
a

tracerDebugPeerSelection :: Tracer (IOSim s) (DebugPeerSelection PeerAddr)
tracerDebugPeerSelection :: forall s. Tracer (IOSim s) (DebugPeerSelection PeerAddr)
tracerDebugPeerSelection = DebugPeerSelection PeerAddr -> TestTraceEvent
GovernorDebug (DebugPeerSelection PeerAddr -> TestTraceEvent)
-> Tracer (IOSim s) TestTraceEvent
-> Tracer (IOSim s) (DebugPeerSelection PeerAddr)
forall a' a. (a' -> a) -> Tracer (IOSim s) a -> Tracer (IOSim s) a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer (IOSim s) TestTraceEvent
forall s. Tracer (IOSim s) TestTraceEvent
tracerTestTraceEvent

traceAssociationMode :: PeerSelectionInterfaces PeerAddr (PeerConn (IOSim s)) (IOSim s)
                     -> PeerSelectionActions PeerAddr (PeerConn (IOSim s)) (IOSim s)
                     -> Tracer (IOSim s) (DebugPeerSelection PeerAddr)
traceAssociationMode :: forall s.
PeerSelectionInterfaces PeerAddr (PeerConn (IOSim s)) (IOSim s)
-> PeerSelectionActions PeerAddr (PeerConn (IOSim s)) (IOSim s)
-> Tracer (IOSim s) (DebugPeerSelection PeerAddr)
traceAssociationMode PeerSelectionInterfaces PeerAddr (PeerConn (IOSim s)) (IOSim s)
interfaces PeerSelectionActions PeerAddr (PeerConn (IOSim s)) (IOSim s)
actions = (DebugPeerSelection PeerAddr -> IOSim s ())
-> Tracer (IOSim s) (DebugPeerSelection PeerAddr)
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((DebugPeerSelection PeerAddr -> IOSim s ())
 -> Tracer (IOSim s) (DebugPeerSelection PeerAddr))
-> (DebugPeerSelection PeerAddr -> IOSim s ())
-> Tracer (IOSim s) (DebugPeerSelection PeerAddr)
forall a b. (a -> b) -> a -> b
$ \(TraceGovernorState Time
_ Maybe DiffTime
_ PeerSelectionState PeerAddr peerconn
st) -> do
    associationMode <- STM (IOSim s) AssociationMode -> IOSim s AssociationMode
forall a. HasCallStack => STM (IOSim s) a -> IOSim s a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM (IOSim s) AssociationMode -> IOSim s AssociationMode)
-> STM (IOSim s) AssociationMode -> IOSim s AssociationMode
forall a b. (a -> b) -> a -> b
$ STM (IOSim s) UseLedgerPeers
-> PeerSharing
-> UseBootstrapPeers
-> STM (IOSim s) AssociationMode
forall (m :: * -> *).
MonadSTM m =>
STM m UseLedgerPeers
-> PeerSharing -> UseBootstrapPeers -> STM m AssociationMode
readAssociationMode
                                           (PeerSelectionInterfaces PeerAddr (PeerConn (IOSim s)) (IOSim s)
-> STM (IOSim s) UseLedgerPeers
forall peeraddr peerconn (m :: * -> *).
PeerSelectionInterfaces peeraddr peerconn m -> STM m UseLedgerPeers
readUseLedgerPeers PeerSelectionInterfaces PeerAddr (PeerConn (IOSim s)) (IOSim s)
interfaces)
                                           (PeerSelectionActions PeerAddr (PeerConn (IOSim s)) (IOSim s)
-> PeerSharing
forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m -> PeerSharing
Governor.peerSharing PeerSelectionActions PeerAddr (PeerConn (IOSim s)) (IOSim s)
actions)
                                           (PeerSelectionState PeerAddr peerconn -> UseBootstrapPeers
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> UseBootstrapPeers
Governor.bootstrapPeersFlag PeerSelectionState PeerAddr peerconn
st)
    traceWith tracerTestTraceEvent (GovernorAssociationMode associationMode)

tracerTracePeerSelectionCounters :: Tracer (IOSim s) PeerSelectionCounters
tracerTracePeerSelectionCounters :: forall s. Tracer (IOSim s) PeerSelectionCounters
tracerTracePeerSelectionCounters = (PeerSelectionCounters -> TestTraceEvent)
-> Tracer (IOSim s) TestTraceEvent
-> Tracer (IOSim s) PeerSelectionCounters
forall a' a. (a' -> a) -> Tracer (IOSim s) a -> Tracer (IOSim s) a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap PeerSelectionCounters -> TestTraceEvent
GovernorCounters Tracer (IOSim s) TestTraceEvent
forall s. Tracer (IOSim s) TestTraceEvent
tracerTestTraceEvent

tracerMockEnv :: Tracer (IOSim s) TraceMockEnv
tracerMockEnv :: forall s. Tracer (IOSim s) TraceMockEnv
tracerMockEnv = (TraceMockEnv -> TestTraceEvent)
-> Tracer (IOSim s) TestTraceEvent -> Tracer (IOSim s) TraceMockEnv
forall a' a. (a' -> a) -> Tracer (IOSim s) a -> Tracer (IOSim s) a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap TraceMockEnv -> TestTraceEvent
MockEnvEvent Tracer (IOSim s) TestTraceEvent
forall s. Tracer (IOSim s) TestTraceEvent
tracerTestTraceEvent

tracerTestTraceEvent :: Tracer (IOSim s) TestTraceEvent
tracerTestTraceEvent :: forall s. Tracer (IOSim s) TestTraceEvent
tracerTestTraceEvent = Tracer (IOSim s) TestTraceEvent
forall a s. Typeable a => Tracer (IOSim s) a
dynamicTracer Tracer (IOSim s) TestTraceEvent
-> Tracer (IOSim s) TestTraceEvent
-> Tracer (IOSim s) TestTraceEvent
forall a. Semigroup a => a -> a -> a
<> (TestTraceEvent -> IOSim s ()) -> Tracer (IOSim s) TestTraceEvent
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (TestName -> IOSim s ()
forall (m :: * -> *). MonadSay m => TestName -> m ()
say (TestName -> IOSim s ())
-> (TestTraceEvent -> TestName) -> TestTraceEvent -> IOSim s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestTraceEvent -> TestName
forall a. Show a => a -> TestName
show)

dynamicTracer :: Typeable a => Tracer (IOSim s) a
dynamicTracer :: forall a s. Typeable a => Tracer (IOSim s) a
dynamicTracer = (a -> IOSim s ()) -> Tracer (IOSim s) a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer a -> IOSim s ()
forall a s. Typeable a => a -> IOSim s ()
traceM

selectPeerSelectionTraceEvents :: SimTrace a -> [(Time, TestTraceEvent)]
selectPeerSelectionTraceEvents :: forall a. SimTrace a -> [(Time, TestTraceEvent)]
selectPeerSelectionTraceEvents = SimTrace a -> [(Time, TestTraceEvent)]
forall {b} {a}. Typeable b => SimTrace a -> [(Time, b)]
go
  where
    go :: SimTrace a -> [(Time, b)]
go (SimTrace Time
t IOSimThreadId
_ Maybe TestName
_ (EventLog Dynamic
e) SimTrace a
trace)
     | Just b
x <- Dynamic -> Maybe b
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
e       = (Time
t,b
x) (Time, b) -> [(Time, b)] -> [(Time, b)]
forall a. a -> [a] -> [a]
: SimTrace a -> [(Time, b)]
go SimTrace a
trace
    go (SimPORTrace Time
t IOSimThreadId
_ Int
_ Maybe TestName
_ (EventLog Dynamic
e) SimTrace a
trace)
     | Just b
x <- Dynamic -> Maybe b
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
e       = (Time
t,b
x) (Time, b) -> [(Time, b)] -> [(Time, b)]
forall a. a -> [a] -> [a]
: SimTrace a -> [(Time, b)]
go SimTrace a
trace
    go (SimTrace Time
_ IOSimThreadId
_ Maybe TestName
_ SimEventType
_ SimTrace a
trace)      =         SimTrace a -> [(Time, b)]
go SimTrace a
trace
    go (SimPORTrace Time
_ IOSimThreadId
_ Int
_ Maybe TestName
_ SimEventType
_ SimTrace a
trace) =         SimTrace a -> [(Time, b)]
go SimTrace a
trace
    go (TraceRacesFound [ScheduleControl]
_ SimTrace a
trace)     =         SimTrace a -> [(Time, b)]
go SimTrace a
trace
    go (TraceMainException Time
_ Labelled IOSimThreadId
_ SomeException
e [Labelled IOSimThreadId]
_)  = SomeException -> [(Time, b)]
forall a e. (HasCallStack, Exception e) => e -> a
throw SomeException
e
    go (TraceDeadlock      Time
_   [Labelled IOSimThreadId]
_)    = [] -- expected result in many cases
    go  TraceMainReturn {}           = []
    go (TraceInternalError TestName
e)        = TestName -> [(Time, b)]
forall a. HasCallStack => TestName -> a
error (TestName
"IOSim: " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
e)
    go SimTrace a
TraceLoop                     = TestName -> [(Time, b)]
forall a. HasCallStack => TestName -> a
error TestName
"Step time limit exceeded"

selectPeerSelectionTraceEventsUntil :: Time -> SimTrace a -> [(Time, TestTraceEvent)]
selectPeerSelectionTraceEventsUntil :: forall a. Time -> SimTrace a -> [(Time, TestTraceEvent)]
selectPeerSelectionTraceEventsUntil Time
tmax = SimTrace a -> [(Time, TestTraceEvent)]
forall {b} {a}. Typeable b => SimTrace a -> [(Time, b)]
go
  where
    go :: SimTrace a -> [(Time, b)]
go (SimTrace Time
t IOSimThreadId
_ Maybe TestName
_ SimEventType
_ SimTrace a
_)
     | Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
tmax                      = []
    go (SimTrace Time
t IOSimThreadId
_ Maybe TestName
_ (EventLog Dynamic
e) SimTrace a
trace)
     | Just b
x <- Dynamic -> Maybe b
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
e       = (Time
t,b
x) (Time, b) -> [(Time, b)] -> [(Time, b)]
forall a. a -> [a] -> [a]
: SimTrace a -> [(Time, b)]
go SimTrace a
trace
    go (SimPORTrace Time
t IOSimThreadId
_ Int
_ Maybe TestName
_ SimEventType
_ SimTrace a
_)
     | Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
tmax                      = []
    go (SimPORTrace Time
t IOSimThreadId
_ Int
_ Maybe TestName
_ (EventLog Dynamic
e) SimTrace a
trace)
     | Just b
x <- Dynamic -> Maybe b
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
e       = (Time
t,b
x) (Time, b) -> [(Time, b)] -> [(Time, b)]
forall a. a -> [a] -> [a]
: SimTrace a -> [(Time, b)]
go SimTrace a
trace
    go (SimTrace Time
_ IOSimThreadId
_ Maybe TestName
_ SimEventType
_ SimTrace a
trace)      =         SimTrace a -> [(Time, b)]
go SimTrace a
trace
    go (SimPORTrace Time
_ IOSimThreadId
_ Int
_ Maybe TestName
_ SimEventType
_ SimTrace a
trace) =         SimTrace a -> [(Time, b)]
go SimTrace a
trace
    go (TraceRacesFound [ScheduleControl]
_ SimTrace a
trace)     =         SimTrace a -> [(Time, b)]
go SimTrace a
trace
    go (TraceMainException Time
_ Labelled IOSimThreadId
_ SomeException
e [Labelled IOSimThreadId]
_)  = SomeException -> [(Time, b)]
forall a e. (HasCallStack, Exception e) => e -> a
throw SomeException
e
    go (TraceDeadlock      Time
_   [Labelled IOSimThreadId]
_)    = [] -- expected result in many cases
    go  TraceMainReturn {}           = []
    go (TraceInternalError TestName
e)        = TestName -> [(Time, b)]
forall a. HasCallStack => TestName -> a
error (TestName
"IOSim: " TestName -> ShowS
forall a. [a] -> [a] -> [a]
++ TestName
e)
    go SimTrace a
TraceLoop                     = TestName -> [(Time, b)]
forall a. HasCallStack => TestName -> a
error TestName
"Step time limit exceeded"

selectGovernorEvents :: [(Time, TestTraceEvent)]
                     -> [(Time, TracePeerSelection PeerAddr)]
selectGovernorEvents :: [(Time, TestTraceEvent)] -> [(Time, TracePeerSelection PeerAddr)]
selectGovernorEvents [(Time, TestTraceEvent)]
trace = [ (Time
t, TracePeerSelection PeerAddr
e) | (Time
t, GovernorEvent TracePeerSelection PeerAddr
e) <- [(Time, TestTraceEvent)]
trace ]

selectGovernorStateEvents :: [(Time, TestTraceEvent)]
                          -> [(Time, DebugPeerSelection PeerAddr)]
selectGovernorStateEvents :: [(Time, TestTraceEvent)] -> [(Time, DebugPeerSelection PeerAddr)]
selectGovernorStateEvents [(Time, TestTraceEvent)]
trace = [ (Time
t, DebugPeerSelection PeerAddr
e) | (Time
t, GovernorDebug DebugPeerSelection PeerAddr
e) <- [(Time, TestTraceEvent)]
trace ]



--
-- QuickCheck instances
--

instance Arbitrary GovernorPraosMockEnvironment where
  arbitrary :: Gen GovernorPraosMockEnvironment
arbitrary = do
    mockEnv <- Gen GovernorMockEnvironment
forall a. Arbitrary a => Gen a
arbitrary
    bootstrapScript <- arbitrary
    return $ GovernorPraosMockEnvironment mockEnv {
      consensusMode = PraosMode,
      useBootstrapPeers = bootstrapScript }

  shrink :: GovernorPraosMockEnvironment -> [GovernorPraosMockEnvironment]
shrink GovernorPraosMockEnvironment
env = GovernorMockEnvironment -> GovernorPraosMockEnvironment
GovernorPraosMockEnvironment (GovernorMockEnvironment -> GovernorPraosMockEnvironment)
-> [GovernorMockEnvironment] -> [GovernorPraosMockEnvironment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GovernorMockEnvironment -> [GovernorMockEnvironment]
forall a. Arbitrary a => a -> [a]
shrink (GovernorPraosMockEnvironment -> GovernorMockEnvironment
getMockEnv GovernorPraosMockEnvironment
env)

instance Arbitrary GovernorMockEnvironment where
  arbitrary :: Gen GovernorMockEnvironment
arbitrary = do
      -- Dependency of the root set on the graph
      peerGraph         <- Gen PeerGraph
forall a. Arbitrary a => Gen a
arbitrary
      let peersSet       = PeerGraph -> Set PeerAddr
allPeers PeerGraph
peerGraph
      (localRootPeers,
       publicRootPeers) <- arbitraryRootPeers peersSet

      let arbitrarySubsetOfPeers = Set PeerAddr -> Gen (Set PeerAddr)
forall a. Ord a => Set a -> Gen (Set a)
arbitrarySubset Set PeerAddr
peersSet
      pickKnownPeersForPeerShare <- arbitraryPickScript arbitrarySubsetOfPeers
      pickColdPeersToPromote  <- arbitraryPickScript arbitrarySubsetOfPeers
      pickWarmPeersToPromote  <- arbitraryPickScript arbitrarySubsetOfPeers
      pickHotPeersToDemote    <- arbitraryPickScript arbitrarySubsetOfPeers
      pickWarmPeersToDemote   <- arbitraryPickScript arbitrarySubsetOfPeers
      pickColdPeersToForget   <- arbitraryPickScript arbitrarySubsetOfPeers
      pickInboundPeers        <- arbitraryPickScript arbitrarySubsetOfPeers
      peerSharingFlag         <- arbitrary
      consensusMode           <- arbitrary
      useBootstrapPeers       <- case consensusMode of
                                   ConsensusMode
GenesisMode -> TimedScript UseBootstrapPeers
-> Gen (TimedScript UseBootstrapPeers)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimedScript UseBootstrapPeers
 -> Gen (TimedScript UseBootstrapPeers))
-> TimedScript UseBootstrapPeers
-> Gen (TimedScript UseBootstrapPeers)
forall a b. (a -> b) -> a -> b
$ UseBootstrapPeers -> TimedScript UseBootstrapPeers
forall a. a -> TimedScript a
singletonTimedScript UseBootstrapPeers
DontUseBootstrapPeers
                                   ConsensusMode
PraosMode   -> Gen (TimedScript UseBootstrapPeers)
forall a. Arbitrary a => Gen a
arbitrary
      useLedgerPeers          <- arbitrary
      ledgerStateJudgement0   <- listOf arbitrary
      (ledgerStateJudgement, targets) <-
        genLsjWithTargets localRootPeers publicRootPeers ledgerStateJudgement0 consensusMode

      return GovernorMockEnvironment{..}
    where
      arbitraryRootPeers :: Set PeerAddr
                         -> Gen (LocalRootPeers PeerAddr, PublicRootPeers PeerAddr)
      arbitraryRootPeers :: Set PeerAddr
-> Gen (LocalRootPeers PeerAddr, PublicRootPeers PeerAddr)
arbitraryRootPeers Set PeerAddr
peers | Set PeerAddr -> Bool
forall a. Set a -> Bool
Set.null Set PeerAddr
peers =
        (LocalRootPeers PeerAddr, PublicRootPeers PeerAddr)
-> Gen (LocalRootPeers PeerAddr, PublicRootPeers PeerAddr)
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalRootPeers PeerAddr
forall peeraddr. LocalRootPeers peeraddr
LocalRootPeers.empty, PublicRootPeers PeerAddr
forall peeraddr. PublicRootPeers peeraddr
PublicRootPeers.empty)

      arbitraryRootPeers Set PeerAddr
peers = do
        -- We decide how many we want and then pick randomly.
        sz <- Gen Int
getSize
        let minroots
              | Int
sz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10  = Int
1
              | Bool
otherwise = Int
0
            maxroots      = Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling
                          (Double -> Int) -> (Set PeerAddr -> Double) -> Set PeerAddr -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double
forall a. Floating a => a -> a
sqrt
                          (Double -> Double)
-> (Set PeerAddr -> Double) -> Set PeerAddr -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Double)
                          (Int -> Double) -> (Set PeerAddr -> Int) -> Set PeerAddr -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set PeerAddr -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
                          (Set PeerAddr -> Int) -> Set PeerAddr -> Int
forall a b. (a -> b) -> a -> b
$ Set PeerAddr
peers
        numroots  <- choose (minroots, maxroots)
        ixs       <- vectorOf numroots (getNonNegative <$> arbitrary)
        let pick Int
n    = Int -> Set PeerAddr -> PeerAddr
forall a. Int -> Set a -> a
Set.elemAt Int
i Set PeerAddr
peers where i :: Int
i = Int
n Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Set PeerAddr -> Int
forall a. Set a -> Int
Set.size Set PeerAddr
peers
            rootPeers = [PeerAddr] -> [PeerAddr]
forall a. Eq a => [a] -> [a]
nub ((Int -> PeerAddr) -> [Int] -> [PeerAddr]
forall a b. (a -> b) -> [a] -> [b]
map Int -> PeerAddr
pick [Int]
ixs)
        -- divide into local and public, but with a bit of overlap:
        local <- vectorOf (length rootPeers) (choose (0, 10 :: Int))
        -- Deliberately asking for a small intersection in order to test if
        -- the Governor actually takes care of this invariant
        let localRootsSet  = [PeerAddr] -> Set PeerAddr
forall a. Ord a => [a] -> Set a
Set.fromList [ PeerAddr
x | (PeerAddr
x, Int
v) <- [PeerAddr] -> [Int] -> [(PeerAddr, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [PeerAddr]
rootPeers [Int]
local
                                              , Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
5 ]
            publicRootsSet = [PeerAddr] -> [PeerAddr]
forall a. Eq a => [a] -> [a]
nub [ PeerAddr
x | (PeerAddr
x, Int
v) <- [PeerAddr] -> [Int] -> [(PeerAddr, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [PeerAddr]
rootPeers [Int]
local
                                     , Int
v Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
5 ]
        pAdvPLedger <- vectorOf (length publicRootsSet)
                               ((,) <$> arbitrary <*> arbitrary)
        let publicRoots = [(PeerAddr, (Bool, PeerAdvertise))]
-> Map PeerAddr (Bool, PeerAdvertise)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([PeerAddr]
-> [(Bool, PeerAdvertise)] -> [(PeerAddr, (Bool, PeerAdvertise))]
forall a b. [a] -> [b] -> [(a, b)]
zip [PeerAddr]
publicRootsSet [(Bool, PeerAdvertise)]
pAdvPLedger)

        numBigLedgerPeers <- choose (minroots, numroots)
        -- `publicRoots` might be empty
        ixs' <- vectorOf numBigLedgerPeers (getNonNegative <$> arbitrary)
        let bigLedgerPeers = (Set PeerAddr -> Set PeerAddr -> Set PeerAddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set PeerAddr
localRootsSet)
                           (Set PeerAddr -> Set PeerAddr)
-> ([(Int, Int, PeerAddr)] -> Set PeerAddr)
-> [(Int, Int, PeerAddr)]
-> Set PeerAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PeerAddr] -> Set PeerAddr
forall a. Ord a => [a] -> Set a
Set.fromList
                           ([PeerAddr] -> Set PeerAddr)
-> ([(Int, Int, PeerAddr)] -> [PeerAddr])
-> [(Int, Int, PeerAddr)]
-> Set PeerAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int, PeerAddr) -> PeerAddr)
-> [(Int, Int, PeerAddr)] -> [PeerAddr]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
_,Int
_,PeerAddr
a) -> PeerAddr
a)
                           ([(Int, Int, PeerAddr)] -> [PeerAddr])
-> ([(Int, Int, PeerAddr)] -> [(Int, Int, PeerAddr)])
-> [(Int, Int, PeerAddr)]
-> [PeerAddr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Int, PeerAddr) -> Bool)
-> [(Int, Int, PeerAddr)] -> [(Int, Int, PeerAddr)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Int
ix, Int
ix', PeerAddr
_) ->
                                       Int
ix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ix' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Map PeerAddr (Bool, PeerAdvertise) -> Int
forall k a. Map k a -> Int
Map.size Map PeerAddr (Bool, PeerAdvertise)
publicRoots)
                           ([(Int, Int, PeerAddr)] -> Set PeerAddr)
-> [(Int, Int, PeerAddr)] -> Set PeerAddr
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int] -> [PeerAddr] -> [(Int, Int, PeerAddr)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Int
0..] [Int]
ixs' (Map PeerAddr (Bool, PeerAdvertise) -> [PeerAddr]
forall k a. Map k a -> [k]
Map.keys Map PeerAddr (Bool, PeerAdvertise)
publicRoots)

        let (publicConfigPeers, otherPeers) =
              span (\case (PeerAddr
_, (Bool
x, PeerAdvertise
_)) -> Bool -> Bool
not Bool
x)
                   (zip publicRootsSet pAdvPLedger)
            (publicConfigPeersMap, (boostrapPeers, ledgerPeers)) =
              ( Map.fromList $ map (\(PeerAddr
p, (Bool
_, PeerAdvertise
pa)) -> (PeerAddr
p, PeerAdvertise
pa)) publicConfigPeers
              , let otherPeers' = ((PeerAddr, (Bool, PeerAdvertise)) -> PeerAddr)
-> [(PeerAddr, (Bool, PeerAdvertise))] -> [PeerAddr]
forall a b. (a -> b) -> [a] -> [b]
map (PeerAddr, (Bool, PeerAdvertise)) -> PeerAddr
forall a b. (a, b) -> a
fst [(PeerAddr, (Bool, PeerAdvertise))]
otherPeers
                 in splitAt (length otherPeers' `div` 2) otherPeers'
              )

        localRoots <- arbitraryLocalRootPeers localRootsSet
        return ( localRoots
               , PublicRootPeers.fromMapAndSet
                  publicConfigPeersMap
                  (Set.fromList boostrapPeers)
                  (Set.fromList ledgerPeers)
                  bigLedgerPeers
               )

      genLsjWithTargets :: LocalRootPeers peeraddr
-> PublicRootPeers a
-> [ArbitraryLedgerStateJudgement]
-> ConsensusMode
-> Gen
     (TimedScript LedgerStateJudgement,
      TimedScript ConsensusModePeerTargets)
genLsjWithTargets LocalRootPeers peeraddr
localRootPeers PublicRootPeers a
publicRootPeers [ArbitraryLedgerStateJudgement]
ledgerStateJudgement0 ConsensusMode
consensusMode =
        let wrap :: [a] -> Script a
wrap = NonEmpty a -> Script a
forall a. NonEmpty a -> Script a
Script (NonEmpty a -> Script a) -> ([a] -> NonEmpty a) -> [a] -> Script a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> NonEmpty a
forall a. HasCallStack => [a] -> NonEmpty a
NonEmpty.fromList
        in      ([(LedgerStateJudgement, ScriptDelay)]
 -> TimedScript LedgerStateJudgement)
-> ([(ConsensusModePeerTargets, ScriptDelay)]
    -> TimedScript ConsensusModePeerTargets)
-> ([(LedgerStateJudgement, ScriptDelay)],
    [(ConsensusModePeerTargets, ScriptDelay)])
-> (TimedScript LedgerStateJudgement,
    TimedScript ConsensusModePeerTargets)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [(LedgerStateJudgement, ScriptDelay)]
-> TimedScript LedgerStateJudgement
forall {a}. [a] -> Script a
wrap [(ConsensusModePeerTargets, ScriptDelay)]
-> TimedScript ConsensusModePeerTargets
forall {a}. [a] -> Script a
wrap (([(LedgerStateJudgement, ScriptDelay)],
  [(ConsensusModePeerTargets, ScriptDelay)])
 -> (TimedScript LedgerStateJudgement,
     TimedScript ConsensusModePeerTargets))
-> ([((LedgerStateJudgement, ScriptDelay),
      (ConsensusModePeerTargets, ScriptDelay))]
    -> ([(LedgerStateJudgement, ScriptDelay)],
        [(ConsensusModePeerTargets, ScriptDelay)]))
-> [((LedgerStateJudgement, ScriptDelay),
     (ConsensusModePeerTargets, ScriptDelay))]
-> (TimedScript LedgerStateJudgement,
    TimedScript ConsensusModePeerTargets)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [((LedgerStateJudgement, ScriptDelay),
  (ConsensusModePeerTargets, ScriptDelay))]
-> ([(LedgerStateJudgement, ScriptDelay)],
    [(ConsensusModePeerTargets, ScriptDelay)])
forall a b. [(a, b)] -> ([a], [b])
unzip
            ([((LedgerStateJudgement, ScriptDelay),
   (ConsensusModePeerTargets, ScriptDelay))]
 -> (TimedScript LedgerStateJudgement,
     TimedScript ConsensusModePeerTargets))
-> Gen
     [((LedgerStateJudgement, ScriptDelay),
       (ConsensusModePeerTargets, ScriptDelay))]
-> Gen
     (TimedScript LedgerStateJudgement,
      TimedScript ConsensusModePeerTargets)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ArbitraryLedgerStateJudgement]
-> (ArbitraryLedgerStateJudgement
    -> Gen
         ((LedgerStateJudgement, ScriptDelay),
          (ConsensusModePeerTargets, ScriptDelay)))
-> Gen
     [((LedgerStateJudgement, ScriptDelay),
       (ConsensusModePeerTargets, ScriptDelay))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (   [ArbitraryLedgerStateJudgement]
ledgerStateJudgement0
                      [ArbitraryLedgerStateJudgement]
-> [ArbitraryLedgerStateJudgement]
-> [ArbitraryLedgerStateJudgement]
forall a. [a] -> [a] -> [a]
++ [LedgerStateJudgement -> ArbitraryLedgerStateJudgement
ArbitraryLedgerStateJudgement LedgerStateJudgement
YoungEnough])
                     (\(ArbitraryLedgerStateJudgement LedgerStateJudgement
lsj) -> do
                          (praosKnown, genesisKnown) <- (,) (Int -> Int -> (Int, Int)) -> Gen Int -> Gen (Int -> (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Int
knownGen Gen (Int -> (Int, Int)) -> Gen Int -> Gen (Int, Int)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen Int
knownGen
                          (praosRootKnown, genesisRootKnown) <- (,) <$> rootKnownGen praosKnown
                                                                    <*> rootKnownGen genesisKnown
                          (praosEst, genesisEst) <- (,) <$> estGen praosKnown <*> estGen genesisKnown
                          (praosAct, genesisAct) <- (,) <$> actGen praosEst <*> actGen genesisEst
                          (praosBigKnown, Positive genesisBigKnown)
                            <- (,) <$> resize 1000 arbitrarySizedNatural
                                   <*> resize 1000 arbitrary `suchThat` ((>= 10) . getPositive)
                          (praosBigEst, genesisBigEst) <- (,) <$> choose (0, min 1000 praosBigKnown)
                                                              <*> choose (1, min 1000 genesisBigKnown)
                          (praosBigAct, genesisBigAct) <- (,) <$> choose (0, min 100 praosBigEst)
                                                              <*> choose (1, min 100 genesisBigEst)
                          let targets =
                                ConsensusModePeerTargets {
                                  deadlineTargets :: PeerSelectionTargets
deadlineTargets = PeerSelectionTargets {
                                      targetNumberOfRootPeers :: Int
targetNumberOfRootPeers = Int
praosRootKnown,
                                      targetNumberOfKnownPeers :: Int
targetNumberOfKnownPeers = Int
praosKnown,
                                      targetNumberOfEstablishedPeers :: Int
targetNumberOfEstablishedPeers = Int
praosEst,
                                      targetNumberOfActivePeers :: Int
targetNumberOfActivePeers = Int
praosAct,
                                      targetNumberOfKnownBigLedgerPeers :: Int
targetNumberOfKnownBigLedgerPeers = Int
praosBigKnown,
                                      targetNumberOfEstablishedBigLedgerPeers :: Int
targetNumberOfEstablishedBigLedgerPeers = Int
praosBigEst,
                                      targetNumberOfActiveBigLedgerPeers :: Int
targetNumberOfActiveBigLedgerPeers = Int
praosBigAct },
                                  syncTargets :: PeerSelectionTargets
syncTargets = PeerSelectionTargets {
                                      targetNumberOfRootPeers :: Int
targetNumberOfRootPeers = Int
genesisRootKnown,
                                      targetNumberOfKnownPeers :: Int
targetNumberOfKnownPeers = Int
genesisKnown,
                                      targetNumberOfEstablishedPeers :: Int
targetNumberOfEstablishedPeers = Int
genesisEst,
                                      targetNumberOfActivePeers :: Int
targetNumberOfActivePeers = Int
genesisAct,
                                      targetNumberOfKnownBigLedgerPeers :: Int
targetNumberOfKnownBigLedgerPeers = Int
genesisBigKnown,
                                      targetNumberOfEstablishedBigLedgerPeers :: Int
targetNumberOfEstablishedBigLedgerPeers = Int
genesisBigKnown,
                                      targetNumberOfActiveBigLedgerPeers :: Int
targetNumberOfActiveBigLedgerPeers = Int
genesisBigAct } }
                          let lsjWithDelay = (,) LedgerStateJudgement
lsj (ScriptDelay -> (LedgerStateJudgement, ScriptDelay))
-> Gen ScriptDelay -> Gen (LedgerStateJudgement, ScriptDelay)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ScriptDelay] -> Gen ScriptDelay
forall a. [a] -> Gen a
elements [ScriptDelay
ShortDelay, ScriptDelay
NoDelay]
                              -- synchronize target basis with ledger state judgement
                              -- so we can use tests which check if the right targets
                              -- are selected
                              targetsWithDelay =     (,) ConsensusModePeerTargets
targets
                                                 (ScriptDelay -> (ConsensusModePeerTargets, ScriptDelay))
-> Gen ScriptDelay -> Gen (ConsensusModePeerTargets, ScriptDelay)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case ConsensusMode
consensusMode of
                                                       ConsensusMode
PraosMode -> [ScriptDelay] -> Gen ScriptDelay
forall a. [a] -> Gen a
elements [ScriptDelay
ShortDelay, ScriptDelay
NoDelay]
                                                       ConsensusMode
GenesisMode -> (LedgerStateJudgement, ScriptDelay) -> ScriptDelay
forall a b. (a, b) -> b
snd ((LedgerStateJudgement, ScriptDelay) -> ScriptDelay)
-> Gen (LedgerStateJudgement, ScriptDelay) -> Gen ScriptDelay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (LedgerStateJudgement, ScriptDelay)
lsjWithDelay

                          (,) <$> lsjWithDelay <*> targetsWithDelay)
        where
          -- we want to generate targets which respect the number of local roots
          -- and locally configured public roots which we plucked from the peer
          -- graph
          (HotValency Int
localHot) = LocalRootPeers peeraddr -> HotValency
forall peeraddr. LocalRootPeers peeraddr -> HotValency
LocalRootPeers.hotTarget LocalRootPeers peeraddr
localRootPeers
          (WarmValency Int
localWarm) = LocalRootPeers peeraddr -> WarmValency
forall peeraddr. LocalRootPeers peeraddr -> WarmValency
LocalRootPeers.warmTarget LocalRootPeers peeraddr
localRootPeers
          publicConfiguredRootSize :: Int
publicConfiguredRootSize = Set a -> Int
forall a. Set a -> Int
Set.size (Set a -> Int)
-> (PublicRootPeers a -> Set a) -> PublicRootPeers a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicRootPeers a -> Set a
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.toPublicConfigPeerSet (PublicRootPeers a -> Int) -> PublicRootPeers a -> Int
forall a b. (a -> b) -> a -> b
$ PublicRootPeers a
publicRootPeers
          knownOffset :: Int
knownOffset = Int
localWarm Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
publicConfiguredRootSize
          knownGen :: Gen Int
knownGen = (Int
knownOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> Gen Int -> Gen Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Int -> Gen Int
forall a. Int -> Gen a -> Gen a
resize (Int
1000 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
1000 Int
knownOffset) Gen Int
forall a. Integral a => Gen a
arbitrarySizedNatural
          rootKnownGen :: Int -> Gen Int
rootKnownGen Int
knownMax = (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
100 (Int
knownMax Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
localWarm))
          estGen :: Int -> Gen Int
estGen Int
knownMax = (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
localWarm, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
1000 Int
knownMax)
          actGen :: Int -> Gen Int
actGen Int
estMax = (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
localHot, Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
100 Int
estMax)

  shrink :: GovernorMockEnvironment -> [GovernorMockEnvironment]
shrink env :: GovernorMockEnvironment
env@GovernorMockEnvironment {
           PeerGraph
peerGraph :: GovernorMockEnvironment -> PeerGraph
peerGraph :: PeerGraph
peerGraph,
           LocalRootPeers PeerAddr
localRootPeers :: GovernorMockEnvironment -> LocalRootPeers PeerAddr
localRootPeers :: LocalRootPeers PeerAddr
localRootPeers,
           PublicRootPeers PeerAddr
publicRootPeers :: GovernorMockEnvironment -> PublicRootPeers PeerAddr
publicRootPeers :: PublicRootPeers PeerAddr
publicRootPeers,
           TimedScript ConsensusModePeerTargets
targets :: GovernorMockEnvironment -> TimedScript ConsensusModePeerTargets
targets :: TimedScript ConsensusModePeerTargets
targets,
           PickScript PeerAddr
pickKnownPeersForPeerShare :: GovernorMockEnvironment -> PickScript PeerAddr
pickKnownPeersForPeerShare :: PickScript PeerAddr
pickKnownPeersForPeerShare,
           PickScript PeerAddr
pickColdPeersToPromote :: GovernorMockEnvironment -> PickScript PeerAddr
pickColdPeersToPromote :: PickScript PeerAddr
pickColdPeersToPromote,
           PickScript PeerAddr
pickWarmPeersToPromote :: GovernorMockEnvironment -> PickScript PeerAddr
pickWarmPeersToPromote :: PickScript PeerAddr
pickWarmPeersToPromote,
           PickScript PeerAddr
pickHotPeersToDemote :: GovernorMockEnvironment -> PickScript PeerAddr
pickHotPeersToDemote :: PickScript PeerAddr
pickHotPeersToDemote,
           PickScript PeerAddr
pickWarmPeersToDemote :: GovernorMockEnvironment -> PickScript PeerAddr
pickWarmPeersToDemote :: PickScript PeerAddr
pickWarmPeersToDemote,
           PickScript PeerAddr
pickColdPeersToForget :: GovernorMockEnvironment -> PickScript PeerAddr
pickColdPeersToForget :: PickScript PeerAddr
pickColdPeersToForget,
           PickScript PeerAddr
pickInboundPeers :: GovernorMockEnvironment -> PickScript PeerAddr
pickInboundPeers :: PickScript PeerAddr
pickInboundPeers,
           PeerSharing
peerSharingFlag :: GovernorMockEnvironment -> PeerSharing
peerSharingFlag :: PeerSharing
peerSharingFlag,
           TimedScript UseBootstrapPeers
useBootstrapPeers :: GovernorMockEnvironment -> TimedScript UseBootstrapPeers
useBootstrapPeers :: TimedScript UseBootstrapPeers
useBootstrapPeers,
           ConsensusMode
consensusMode :: GovernorMockEnvironment -> ConsensusMode
consensusMode :: ConsensusMode
consensusMode,
           TimedScript UseLedgerPeers
useLedgerPeers :: GovernorMockEnvironment -> TimedScript UseLedgerPeers
useLedgerPeers :: TimedScript UseLedgerPeers
useLedgerPeers,
           TimedScript LedgerStateJudgement
ledgerStateJudgement :: GovernorMockEnvironment -> TimedScript LedgerStateJudgement
ledgerStateJudgement :: TimedScript LedgerStateJudgement
ledgerStateJudgement
         } =
      -- Special rule for shrinking the peerGraph because the localRootPeers
      -- depends on it so has to be updated too.
      [ GovernorMockEnvironment
env {
          peerGraph       = peerGraph',
          localRootPeers  = LocalRootPeers.restrictKeys localRootPeers nodes',
          publicRootPeers = publicRootPeers `PublicRootPeers.intersection` nodes'
        }
      | PeerGraph
peerGraph' <- PeerGraph -> [PeerGraph]
forall a. Arbitrary a => a -> [a]
shrink PeerGraph
peerGraph
      , let nodes' :: Set PeerAddr
nodes' = PeerGraph -> Set PeerAddr
allPeers PeerGraph
peerGraph' ]
      -- All the others are generic.
   [GovernorMockEnvironment]
-> [GovernorMockEnvironment] -> [GovernorMockEnvironment]
forall a. [a] -> [a] -> [a]
++ [ GovernorMockEnvironment
env { localRootPeers = localRootPeers' }
      | LocalRootPeers PeerAddr
localRootPeers' <- LocalRootPeers PeerAddr -> [LocalRootPeers PeerAddr]
forall {peeraddr}.
(Arbitrary peeraddr, Ord peeraddr) =>
LocalRootPeers peeraddr -> [LocalRootPeers peeraddr]
shrinkLocalRootPeers LocalRootPeers PeerAddr
localRootPeers
      ]
   [GovernorMockEnvironment]
-> [GovernorMockEnvironment] -> [GovernorMockEnvironment]
forall a. [a] -> [a] -> [a]
++ [ GovernorMockEnvironment
env { publicRootPeers = publicRootPeers' }
      | PublicRootPeers PeerAddr
publicRootPeers' <- PublicRootPeers PeerAddr -> [PublicRootPeers PeerAddr]
forall {peeraddr}.
(Ord peeraddr, Arbitrary peeraddr) =>
PublicRootPeers peeraddr -> [PublicRootPeers peeraddr]
shrinkPublicRootPeers PublicRootPeers PeerAddr
publicRootPeers
      ]
   [GovernorMockEnvironment]
-> [GovernorMockEnvironment] -> [GovernorMockEnvironment]
forall a. [a] -> [a] -> [a]
++ [ GovernorMockEnvironment
env { targets = targets' }
      | TimedScript ConsensusModePeerTargets
targets' <- ((ConsensusModePeerTargets, ScriptDelay)
 -> [(ConsensusModePeerTargets, ScriptDelay)])
-> TimedScript ConsensusModePeerTargets
-> [TimedScript ConsensusModePeerTargets]
forall a. (a -> [a]) -> Script a -> [Script a]
shrinkScriptWith (ConsensusModePeerTargets, ScriptDelay)
-> [(ConsensusModePeerTargets, ScriptDelay)]
forall {b}.
Arbitrary b =>
(ConsensusModePeerTargets, b) -> [(ConsensusModePeerTargets, b)]
shrinkTargets TimedScript ConsensusModePeerTargets
targets
      ]
   [GovernorMockEnvironment]
-> [GovernorMockEnvironment] -> [GovernorMockEnvironment]
forall a. [a] -> [a] -> [a]
++ [ GovernorMockEnvironment
env { pickKnownPeersForPeerShare = pickKnownPeersForPeerShare' }
      | PickScript PeerAddr
pickKnownPeersForPeerShare' <- PickScript PeerAddr -> [PickScript PeerAddr]
forall a. Arbitrary a => a -> [a]
shrink PickScript PeerAddr
pickKnownPeersForPeerShare
      ]
   [GovernorMockEnvironment]
-> [GovernorMockEnvironment] -> [GovernorMockEnvironment]
forall a. [a] -> [a] -> [a]
++ [ GovernorMockEnvironment
env { pickColdPeersToPromote = pickColdPeersToPromote' }
      | PickScript PeerAddr
pickColdPeersToPromote' <- PickScript PeerAddr -> [PickScript PeerAddr]
forall a. Arbitrary a => a -> [a]
shrink PickScript PeerAddr
pickColdPeersToPromote
      ]
   [GovernorMockEnvironment]
-> [GovernorMockEnvironment] -> [GovernorMockEnvironment]
forall a. [a] -> [a] -> [a]
++ [ GovernorMockEnvironment
env { pickWarmPeersToPromote = pickWarmPeersToPromote' }
      | PickScript PeerAddr
pickWarmPeersToPromote' <- PickScript PeerAddr -> [PickScript PeerAddr]
forall a. Arbitrary a => a -> [a]
shrink PickScript PeerAddr
pickWarmPeersToPromote
      ]
   [GovernorMockEnvironment]
-> [GovernorMockEnvironment] -> [GovernorMockEnvironment]
forall a. [a] -> [a] -> [a]
++ [ GovernorMockEnvironment
env { pickWarmPeersToDemote = pickWarmPeersToDemote' }
      | PickScript PeerAddr
pickWarmPeersToDemote' <- PickScript PeerAddr -> [PickScript PeerAddr]
forall a. Arbitrary a => a -> [a]
shrink PickScript PeerAddr
pickWarmPeersToDemote
      ]
   [GovernorMockEnvironment]
-> [GovernorMockEnvironment] -> [GovernorMockEnvironment]
forall a. [a] -> [a] -> [a]
++ [ GovernorMockEnvironment
env { pickHotPeersToDemote = pickHotPeersToDemote' }
      | PickScript PeerAddr
pickHotPeersToDemote' <- PickScript PeerAddr -> [PickScript PeerAddr]
forall a. Arbitrary a => a -> [a]
shrink PickScript PeerAddr
pickHotPeersToDemote
      ]
   [GovernorMockEnvironment]
-> [GovernorMockEnvironment] -> [GovernorMockEnvironment]
forall a. [a] -> [a] -> [a]
++ [ GovernorMockEnvironment
env { pickColdPeersToForget = pickColdPeersToForget' }
      | PickScript PeerAddr
pickColdPeersToForget' <- PickScript PeerAddr -> [PickScript PeerAddr]
forall a. Arbitrary a => a -> [a]
shrink PickScript PeerAddr
pickColdPeersToForget
      ]
   [GovernorMockEnvironment]
-> [GovernorMockEnvironment] -> [GovernorMockEnvironment]
forall a. [a] -> [a] -> [a]
++ [ GovernorMockEnvironment
env { pickInboundPeers = pickInboundPeers' }
      | PickScript PeerAddr
pickInboundPeers' <- PickScript PeerAddr -> [PickScript PeerAddr]
forall a. Arbitrary a => a -> [a]
shrink PickScript PeerAddr
pickInboundPeers
      ]
   [GovernorMockEnvironment]
-> [GovernorMockEnvironment] -> [GovernorMockEnvironment]
forall a. [a] -> [a] -> [a]
++ [ GovernorMockEnvironment
env { useBootstrapPeers = useBootstrapPeers' }
      | TimedScript UseBootstrapPeers
useBootstrapPeers' <- TimedScript UseBootstrapPeers -> [TimedScript UseBootstrapPeers]
forall a. Arbitrary a => a -> [a]
shrink TimedScript UseBootstrapPeers
useBootstrapPeers
      ]
   [GovernorMockEnvironment]
-> [GovernorMockEnvironment] -> [GovernorMockEnvironment]
forall a. [a] -> [a] -> [a]
++ [ GovernorMockEnvironment
env { useLedgerPeers = useLedgerPeers' }
      | TimedScript UseLedgerPeers
useLedgerPeers' <- TimedScript UseLedgerPeers -> [TimedScript UseLedgerPeers]
forall a. Arbitrary a => a -> [a]
shrink TimedScript UseLedgerPeers
useLedgerPeers
      ]
   [GovernorMockEnvironment]
-> [GovernorMockEnvironment] -> [GovernorMockEnvironment]
forall a. [a] -> [a] -> [a]
++ [ GovernorMockEnvironment
env { ledgerStateJudgement = fmap (first getArbitraryLedgerStateJudgement) ledgerStateJudgement' }
      | Script (ArbitraryLedgerStateJudgement, ScriptDelay)
ledgerStateJudgement' <- Script (ArbitraryLedgerStateJudgement, ScriptDelay)
-> [Script (ArbitraryLedgerStateJudgement, ScriptDelay)]
forall a. Arbitrary a => a -> [a]
shrink (((LedgerStateJudgement, ScriptDelay)
 -> (ArbitraryLedgerStateJudgement, ScriptDelay))
-> TimedScript LedgerStateJudgement
-> Script (ArbitraryLedgerStateJudgement, ScriptDelay)
forall a b. (a -> b) -> Script a -> Script b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LedgerStateJudgement -> ArbitraryLedgerStateJudgement)
-> (LedgerStateJudgement, ScriptDelay)
-> (ArbitraryLedgerStateJudgement, ScriptDelay)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first LedgerStateJudgement -> ArbitraryLedgerStateJudgement
ArbitraryLedgerStateJudgement) TimedScript LedgerStateJudgement
ledgerStateJudgement)
      ]
   [GovernorMockEnvironment]
-> [GovernorMockEnvironment] -> [GovernorMockEnvironment]
forall a. [a] -> [a] -> [a]
++ [ GovernorMockEnvironment
env { peerSharingFlag = peerSharingFlag' }
      | PeerSharing
peerSharingFlag' <- PeerSharing -> [PeerSharing]
forall a. Arbitrary a => a -> [a]
shrink PeerSharing
peerSharingFlag
      ]
   [GovernorMockEnvironment]
-> [GovernorMockEnvironment] -> [GovernorMockEnvironment]
forall a. [a] -> [a] -> [a]
++ [ GovernorMockEnvironment
env { consensusMode = consensusMode' }
      | ConsensusMode
consensusMode' <- ConsensusMode -> [ConsensusMode]
forall a. Arbitrary a => a -> [a]
shrink ConsensusMode
consensusMode
      ]
    where
      -- A sensible shrink will not decrease target of known peers below
      -- the minimum number of local root peers that we need from configuration (hot+warm)
      -- and the number of publicly configured root peers. A similar treatment with
      -- appropriate conditions is necessary for established and active peers.
      shrinkTargets :: (ConsensusModePeerTargets, b) -> [(ConsensusModePeerTargets, b)]
shrinkTargets (ConsensusModePeerTargets, b)
targetsWithDelay =
        let publicConfiguredRootSize :: Int
publicConfiguredRootSize = Set PeerAddr -> Int
forall a. Set a -> Int
Set.size (Set PeerAddr -> Int)
-> (PublicRootPeers PeerAddr -> Set PeerAddr)
-> PublicRootPeers PeerAddr
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicRootPeers PeerAddr -> Set PeerAddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.toPublicConfigPeerSet (PublicRootPeers PeerAddr -> Int)
-> PublicRootPeers PeerAddr -> Int
forall a b. (a -> b) -> a -> b
$ PublicRootPeers PeerAddr
publicRootPeers
            (HotValency Int
hotLocalRootsSize) = LocalRootPeers PeerAddr -> HotValency
forall peeraddr. LocalRootPeers peeraddr -> HotValency
LocalRootPeers.hotTarget LocalRootPeers PeerAddr
localRootPeers
            (WarmValency Int
warmLocalRootsSize) = LocalRootPeers PeerAddr -> WarmValency
forall peeraddr. LocalRootPeers peeraddr -> WarmValency
LocalRootPeers.warmTarget LocalRootPeers PeerAddr
localRootPeers
            shrunkScript :: [(ConsensusModePeerTargets, b)]
shrunkScript = (ConsensusModePeerTargets, b) -> [(ConsensusModePeerTargets, b)]
forall a. Arbitrary a => a -> [a]
shrink (ConsensusModePeerTargets, b)
targetsWithDelay
            checkTargets :: PeerSelectionTargets -> Bool
checkTargets PeerSelectionTargets
t =
                 PeerSelectionTargets -> Int
targetNumberOfKnownPeers PeerSelectionTargets
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
publicConfiguredRootSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
warmLocalRootsSize
              Bool -> Bool -> Bool
&& PeerSelectionTargets -> Int
targetNumberOfEstablishedPeers PeerSelectionTargets
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
warmLocalRootsSize
              Bool -> Bool -> Bool
&& PeerSelectionTargets -> Int
targetNumberOfEstablishedPeers PeerSelectionTargets
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= PeerSelectionTargets -> Int
targetNumberOfKnownPeers PeerSelectionTargets
t
              Bool -> Bool -> Bool
&& PeerSelectionTargets -> Int
targetNumberOfActivePeers PeerSelectionTargets
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
hotLocalRootsSize
              Bool -> Bool -> Bool
&& PeerSelectionTargets -> Int
targetNumberOfActivePeers PeerSelectionTargets
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= PeerSelectionTargets -> Int
targetNumberOfEstablishedPeers PeerSelectionTargets
t
              Bool -> Bool -> Bool
&& PeerSelectionTargets -> Int
targetNumberOfRootPeers PeerSelectionTargets
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=   PeerSelectionTargets -> Int
targetNumberOfKnownPeers PeerSelectionTargets
t
                                              Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
warmLocalRootsSize
        in
          [(ConsensusModePeerTargets, b)
shrunk
          | shrunk :: (ConsensusModePeerTargets, b)
shrunk@(ConsensusModePeerTargets
shrunkTarget, b
_) <- [(ConsensusModePeerTargets, b)]
shrunkScript,
            let ConsensusModePeerTargets {
                  PeerSelectionTargets
deadlineTargets :: ConsensusModePeerTargets -> PeerSelectionTargets
deadlineTargets :: PeerSelectionTargets
deadlineTargets,
                  syncTargets :: ConsensusModePeerTargets -> PeerSelectionTargets
syncTargets = syncTargets :: PeerSelectionTargets
syncTargets@PeerSelectionTargets {
                      targetNumberOfKnownBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfKnownBigLedgerPeers = Int
genesisBigKnown,
                      targetNumberOfEstablishedBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedBigLedgerPeers = Int
genesisBigEst,
                      targetNumberOfActiveBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfActiveBigLedgerPeers = Int
genesisBigAct } } = ConsensusModePeerTargets
shrunkTarget,
            (PeerSelectionTargets -> Bool) -> [PeerSelectionTargets] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all PeerSelectionTargets -> Bool
checkTargets [PeerSelectionTargets
deadlineTargets, PeerSelectionTargets
syncTargets],
            Int
genesisBigKnown Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
10 Bool -> Bool -> Bool
&& Int
genesisBigEst Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
genesisBigKnown Bool -> Bool -> Bool
&& Int
genesisBigAct Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
genesisBigEst,
            Int
genesisBigEst Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
genesisBigAct Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0]

      shrinkLocalRootPeers :: LocalRootPeers peeraddr -> [LocalRootPeers peeraddr]
shrinkLocalRootPeers LocalRootPeers peeraddr
a =
        [ [(HotValency, WarmValency,
  Map peeraddr (PeerAdvertise, PeerTrustable))]
-> LocalRootPeers peeraddr
forall peeraddr.
Ord peeraddr =>
[(HotValency, WarmValency,
  Map peeraddr (PeerAdvertise, PeerTrustable))]
-> LocalRootPeers peeraddr
LocalRootPeers.fromGroups [(HotValency, WarmValency,
  Map peeraddr (PeerAdvertise, PeerTrustable))]
g
          | [(HotValency, WarmValency,
  Map peeraddr (PeerAdvertise, PeerTrustable))]
g <- [(HotValency, WarmValency,
  Map peeraddr (PeerAdvertise, PeerTrustable))]
-> [[(HotValency, WarmValency,
      Map peeraddr (PeerAdvertise, PeerTrustable))]]
forall a. Arbitrary a => a -> [a]
shrink (LocalRootPeers peeraddr
-> [(HotValency, WarmValency,
     Map peeraddr (PeerAdvertise, PeerTrustable))]
forall peeraddr.
Ord peeraddr =>
LocalRootPeers peeraddr
-> [(HotValency, WarmValency,
     Map peeraddr (PeerAdvertise, PeerTrustable))]
LocalRootPeers.toGroups LocalRootPeers peeraddr
a)
        ]
      shrinkPublicRootPeers :: PublicRootPeers peeraddr -> [PublicRootPeers peeraddr]
shrinkPublicRootPeers (PublicRootPeers Map peeraddr PeerAdvertise
pp Set peeraddr
bsp Set peeraddr
lp Set peeraddr
blp) =
        [ Map peeraddr PeerAdvertise
-> Set peeraddr
-> Set peeraddr
-> Set peeraddr
-> PublicRootPeers peeraddr
forall peeraddr.
Map peeraddr PeerAdvertise
-> Set peeraddr
-> Set peeraddr
-> Set peeraddr
-> PublicRootPeers peeraddr
PublicRootPeers Map peeraddr PeerAdvertise
pp' Set peeraddr
bsp' Set peeraddr
lp' Set peeraddr
blp'
          | (Map peeraddr PeerAdvertise
pp', Set peeraddr
bsp', Set peeraddr
lp', Set peeraddr
blp') <- (Map peeraddr PeerAdvertise, Set peeraddr, Set peeraddr,
 Set peeraddr)
-> [(Map peeraddr PeerAdvertise, Set peeraddr, Set peeraddr,
     Set peeraddr)]
forall a. Arbitrary a => a -> [a]
shrink (Map peeraddr PeerAdvertise
pp, Set peeraddr
bsp, Set peeraddr
lp, Set peeraddr
blp)
        ]

--
-- Tests for the QC Arbitrary instances
--

prop_arbitrary_GovernorMockEnvironment :: GovernorMockEnvironment -> Property
prop_arbitrary_GovernorMockEnvironment :: GovernorMockEnvironment -> Property
prop_arbitrary_GovernorMockEnvironment GovernorMockEnvironment
env =
    TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"num root peers"        [Int -> TestName
forall a. Show a => a -> TestName
show (LocalRootPeers PeerAddr -> Int
forall peeraddr. LocalRootPeers peeraddr -> Int
LocalRootPeers.size (GovernorMockEnvironment -> LocalRootPeers PeerAddr
localRootPeers GovernorMockEnvironment
env)
                                          Int -> Int -> Int
forall a. Num a => a -> a -> a
+ PublicRootPeers PeerAddr -> Int
forall peeraddr. PublicRootPeers peeraddr -> Int
PublicRootPeers.size (GovernorMockEnvironment -> PublicRootPeers PeerAddr
publicRootPeers GovernorMockEnvironment
env))] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"num local root peers"  [Int -> TestName
forall a. Show a => a -> TestName
show (LocalRootPeers PeerAddr -> Int
forall peeraddr. LocalRootPeers peeraddr -> Int
LocalRootPeers.size (GovernorMockEnvironment -> LocalRootPeers PeerAddr
localRootPeers GovernorMockEnvironment
env))] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"num public root peers" [Int -> TestName
forall a. Show a => a -> TestName
show (PublicRootPeers PeerAddr -> Int
forall peeraddr. PublicRootPeers peeraddr -> Int
PublicRootPeers.size (GovernorMockEnvironment -> PublicRootPeers PeerAddr
publicRootPeers GovernorMockEnvironment
env))] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"empty root peers" [Bool -> TestName
forall a. Show a => a -> TestName
show (Bool -> TestName) -> Bool -> TestName
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
emptyGraph Bool -> Bool -> Bool
&& Bool
emptyRootPeers]  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"overlapping local/public roots" [Bool -> TestName
forall a. Show a => a -> TestName
show Bool
overlappingRootPeers]  (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    TestName -> [TestName] -> Property -> Property
forall prop.
Testable prop =>
TestName -> [TestName] -> prop -> Property
tabulate TestName
"num big ledger peers"  [Int -> TestName
forall a. Show a => a -> TestName
show (Set PeerAddr -> Int
forall a. Set a -> Int
Set.size Set PeerAddr
bigLedgerPeersSet)] (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$

    GovernorMockEnvironment -> Property
validGovernorMockEnvironment GovernorMockEnvironment
env
  where
    bigLedgerPeersSet :: Set PeerAddr
bigLedgerPeersSet = PublicRootPeers PeerAddr -> Set PeerAddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers (GovernorMockEnvironment -> PublicRootPeers PeerAddr
publicRootPeers GovernorMockEnvironment
env)
    emptyGraph :: Bool
emptyGraph     = [(PeerAddr, [PeerAddr], GovernorScripts)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PeerAddr, [PeerAddr], GovernorScripts)]
g where PeerGraph [(PeerAddr, [PeerAddr], GovernorScripts)]
g = GovernorMockEnvironment -> PeerGraph
peerGraph GovernorMockEnvironment
env
    emptyRootPeers :: Bool
emptyRootPeers = LocalRootPeers PeerAddr -> Bool
forall peeraddr. LocalRootPeers peeraddr -> Bool
LocalRootPeers.null (GovernorMockEnvironment -> LocalRootPeers PeerAddr
localRootPeers GovernorMockEnvironment
env)
                  Bool -> Bool -> Bool
&& PublicRootPeers PeerAddr -> Bool
forall peeraddr. PublicRootPeers peeraddr -> Bool
PublicRootPeers.null (GovernorMockEnvironment -> PublicRootPeers PeerAddr
publicRootPeers GovernorMockEnvironment
env)
    overlappingRootPeers :: Bool
overlappingRootPeers =
      Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ PublicRootPeers PeerAddr -> Bool
forall peeraddr. PublicRootPeers peeraddr -> Bool
PublicRootPeers.null (PublicRootPeers PeerAddr -> Bool)
-> PublicRootPeers PeerAddr -> Bool
forall a b. (a -> b) -> a -> b
$
        PublicRootPeers PeerAddr
-> Set PeerAddr -> PublicRootPeers PeerAddr
forall peeraddr.
Ord peeraddr =>
PublicRootPeers peeraddr
-> Set peeraddr -> PublicRootPeers peeraddr
PublicRootPeers.intersection
          (GovernorMockEnvironment -> PublicRootPeers PeerAddr
publicRootPeers GovernorMockEnvironment
env)
          (LocalRootPeers PeerAddr -> Set PeerAddr
forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet (GovernorMockEnvironment -> LocalRootPeers PeerAddr
localRootPeers GovernorMockEnvironment
env))

prop_shrink_GovernorMockEnvironment :: ShrinkCarefully GovernorMockEnvironment -> Property
prop_shrink_GovernorMockEnvironment :: ShrinkCarefully GovernorMockEnvironment -> Property
prop_shrink_GovernorMockEnvironment ShrinkCarefully GovernorMockEnvironment
x =
      (GovernorMockEnvironment -> Property)
-> ShrinkCarefully GovernorMockEnvironment -> Property
forall a prop.
(Arbitrary a, Show a, Testable prop) =>
(a -> prop) -> ShrinkCarefully a -> Property
prop_shrink_valid GovernorMockEnvironment -> Property
validGovernorMockEnvironment ShrinkCarefully GovernorMockEnvironment
x
 Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. ShrinkCarefully GovernorMockEnvironment -> Property
forall a.
(Arbitrary a, Eq a, Show a) =>
ShrinkCarefully a -> Property
prop_shrink_nonequal ShrinkCarefully GovernorMockEnvironment
x

prop_shrink_nonequal_GovernorMockEnvironment ::
  ShrinkCarefully GovernorMockEnvironment -> Property
prop_shrink_nonequal_GovernorMockEnvironment :: ShrinkCarefully GovernorMockEnvironment -> Property
prop_shrink_nonequal_GovernorMockEnvironment = ShrinkCarefully GovernorMockEnvironment -> Property
forall a.
(Arbitrary a, Eq a, Show a) =>
ShrinkCarefully a -> Property
prop_shrink_nonequal