{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}


module Test.Ouroboros.Network.Testnet.Policies where

import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad.Class.MonadTime.SI
import Control.Monad.IOSim (runSimOrThrow)
import Data.IntPSQ qualified as Pq
import Data.List as List (foldl')
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Word
import Network.Socket (SockAddr (..))
import System.Random

import NoThunks.Class.Orphans ()

import Cardano.Slotting.Slot (SlotNo (..))
import Ouroboros.Network.Diffusion.Policies
import Ouroboros.Network.ExitPolicy (RepromoteDelay (..))
import Ouroboros.Network.PeerSelection.Governor
import Ouroboros.Network.PeerSelection.PeerMetric
import Ouroboros.Network.PeerSelection.Types (PeerSource (..))
import Ouroboros.Network.SizeInBytes

import Test.QuickCheck
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)

tests :: TestTree
tests :: TestTree
tests = TestName -> [TestTree] -> TestTree
testGroup TestName
"Policies"
  [ TestName
-> (ArbitraryPolicyArguments -> Int -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"HotToWarm" ArbitraryPolicyArguments -> Int -> Property
prop_hotToWarm
  , TestName
-> (ArbitraryPolicyArguments -> Int -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"WarmToCooling" ArbitraryPolicyArguments -> Int -> Property
prop_randomDemotion
  ]

newtype ArbitrarySockAddr = ArbitrarySockAddr SockAddr deriving (ArbitrarySockAddr -> ArbitrarySockAddr -> Bool
(ArbitrarySockAddr -> ArbitrarySockAddr -> Bool)
-> (ArbitrarySockAddr -> ArbitrarySockAddr -> Bool)
-> Eq ArbitrarySockAddr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArbitrarySockAddr -> ArbitrarySockAddr -> Bool
== :: ArbitrarySockAddr -> ArbitrarySockAddr -> Bool
$c/= :: ArbitrarySockAddr -> ArbitrarySockAddr -> Bool
/= :: ArbitrarySockAddr -> ArbitrarySockAddr -> Bool
Eq, Eq ArbitrarySockAddr
Eq ArbitrarySockAddr =>
(ArbitrarySockAddr -> ArbitrarySockAddr -> Ordering)
-> (ArbitrarySockAddr -> ArbitrarySockAddr -> Bool)
-> (ArbitrarySockAddr -> ArbitrarySockAddr -> Bool)
-> (ArbitrarySockAddr -> ArbitrarySockAddr -> Bool)
-> (ArbitrarySockAddr -> ArbitrarySockAddr -> Bool)
-> (ArbitrarySockAddr -> ArbitrarySockAddr -> ArbitrarySockAddr)
-> (ArbitrarySockAddr -> ArbitrarySockAddr -> ArbitrarySockAddr)
-> Ord ArbitrarySockAddr
ArbitrarySockAddr -> ArbitrarySockAddr -> Bool
ArbitrarySockAddr -> ArbitrarySockAddr -> Ordering
ArbitrarySockAddr -> ArbitrarySockAddr -> ArbitrarySockAddr
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ArbitrarySockAddr -> ArbitrarySockAddr -> Ordering
compare :: ArbitrarySockAddr -> ArbitrarySockAddr -> Ordering
$c< :: ArbitrarySockAddr -> ArbitrarySockAddr -> Bool
< :: ArbitrarySockAddr -> ArbitrarySockAddr -> Bool
$c<= :: ArbitrarySockAddr -> ArbitrarySockAddr -> Bool
<= :: ArbitrarySockAddr -> ArbitrarySockAddr -> Bool
$c> :: ArbitrarySockAddr -> ArbitrarySockAddr -> Bool
> :: ArbitrarySockAddr -> ArbitrarySockAddr -> Bool
$c>= :: ArbitrarySockAddr -> ArbitrarySockAddr -> Bool
>= :: ArbitrarySockAddr -> ArbitrarySockAddr -> Bool
$cmax :: ArbitrarySockAddr -> ArbitrarySockAddr -> ArbitrarySockAddr
max :: ArbitrarySockAddr -> ArbitrarySockAddr -> ArbitrarySockAddr
$cmin :: ArbitrarySockAddr -> ArbitrarySockAddr -> ArbitrarySockAddr
min :: ArbitrarySockAddr -> ArbitrarySockAddr -> ArbitrarySockAddr
Ord, Int -> ArbitrarySockAddr -> ShowS
[ArbitrarySockAddr] -> ShowS
ArbitrarySockAddr -> TestName
(Int -> ArbitrarySockAddr -> ShowS)
-> (ArbitrarySockAddr -> TestName)
-> ([ArbitrarySockAddr] -> ShowS)
-> Show ArbitrarySockAddr
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArbitrarySockAddr -> ShowS
showsPrec :: Int -> ArbitrarySockAddr -> ShowS
$cshow :: ArbitrarySockAddr -> TestName
show :: ArbitrarySockAddr -> TestName
$cshowList :: [ArbitrarySockAddr] -> ShowS
showList :: [ArbitrarySockAddr] -> ShowS
Show)

instance Arbitrary ArbitrarySockAddr where
    arbitrary :: Gen ArbitrarySockAddr
arbitrary = do
        ip <- Gen HostAddress
forall a. Arbitrary a => Gen a
arbitrary
        port <- arbitrary
        return $ ArbitrarySockAddr $
            SockAddrInet (fromIntegral (port :: Word16)) ip

data ArbitraryPeerInfo = ArbitraryPeerInfo {
    ArbitraryPeerInfo -> Int
piFailCount :: !Int
  , ArbitraryPeerInfo -> Bool
piTepid     :: !Bool
  } deriving Int -> ArbitraryPeerInfo -> ShowS
[ArbitraryPeerInfo] -> ShowS
ArbitraryPeerInfo -> TestName
(Int -> ArbitraryPeerInfo -> ShowS)
-> (ArbitraryPeerInfo -> TestName)
-> ([ArbitraryPeerInfo] -> ShowS)
-> Show ArbitraryPeerInfo
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArbitraryPeerInfo -> ShowS
showsPrec :: Int -> ArbitraryPeerInfo -> ShowS
$cshow :: ArbitraryPeerInfo -> TestName
show :: ArbitraryPeerInfo -> TestName
$cshowList :: [ArbitraryPeerInfo] -> ShowS
showList :: [ArbitraryPeerInfo] -> ShowS
Show

instance Arbitrary ArbitraryPeerInfo where
    arbitrary :: Gen ArbitraryPeerInfo
arbitrary = do
        tepid <- Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
        failCnt <- oneof [ return 0
                         , choose (0, 10)
                         , choose (0, maxBound)
                         ]
        return $ ArbitraryPeerInfo failCnt tepid


data ArbitraryPolicyArguments = ArbitraryPolicyArguments {
    ArbitraryPolicyArguments -> Map SockAddr ArbitraryPeerInfo
apaAvailable     :: Map SockAddr ArbitraryPeerInfo
  , ArbitraryPolicyArguments -> Int
apaPickNum       :: Int
  , ArbitraryPolicyArguments -> SlotMetric SockAddr
apaHeaderMetric  :: SlotMetric SockAddr
  , ArbitraryPolicyArguments -> SlotMetric (SockAddr, SizeInBytes)
apaFetchedMetric :: SlotMetric (SockAddr, SizeInBytes)
  , ArbitraryPolicyArguments -> ChurnMode
apaChurnMode     :: ChurnMode
  , ArbitraryPolicyArguments -> ArbitraryDemotion
apaDemotion      :: ArbitraryDemotion
  } deriving Int -> ArbitraryPolicyArguments -> ShowS
[ArbitraryPolicyArguments] -> ShowS
ArbitraryPolicyArguments -> TestName
(Int -> ArbitraryPolicyArguments -> ShowS)
-> (ArbitraryPolicyArguments -> TestName)
-> ([ArbitraryPolicyArguments] -> ShowS)
-> Show ArbitraryPolicyArguments
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArbitraryPolicyArguments -> ShowS
showsPrec :: Int -> ArbitraryPolicyArguments -> ShowS
$cshow :: ArbitraryPolicyArguments -> TestName
show :: ArbitraryPolicyArguments -> TestName
$cshowList :: [ArbitraryPolicyArguments] -> ShowS
showList :: [ArbitraryPolicyArguments] -> ShowS
Show

data ArbitraryDemotion = ArbitraryWarmDemotion
                       | ArbitraryColdDemotion
                       deriving Int -> ArbitraryDemotion -> ShowS
[ArbitraryDemotion] -> ShowS
ArbitraryDemotion -> TestName
(Int -> ArbitraryDemotion -> ShowS)
-> (ArbitraryDemotion -> TestName)
-> ([ArbitraryDemotion] -> ShowS)
-> Show ArbitraryDemotion
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArbitraryDemotion -> ShowS
showsPrec :: Int -> ArbitraryDemotion -> ShowS
$cshow :: ArbitraryDemotion -> TestName
show :: ArbitraryDemotion -> TestName
$cshowList :: [ArbitraryDemotion] -> ShowS
showList :: [ArbitraryDemotion] -> ShowS
Show

instance Arbitrary ArbitraryDemotion where
    arbitrary :: Gen ArbitraryDemotion
arbitrary = [ArbitraryDemotion] -> Gen ArbitraryDemotion
forall a. [a] -> Gen a
elements [ArbitraryDemotion
ArbitraryWarmDemotion, ArbitraryDemotion
ArbitraryColdDemotion]

newtype ArbitraryChurnMode = ArbitraryChurnMode ChurnMode deriving Int -> ArbitraryChurnMode -> ShowS
[ArbitraryChurnMode] -> ShowS
ArbitraryChurnMode -> TestName
(Int -> ArbitraryChurnMode -> ShowS)
-> (ArbitraryChurnMode -> TestName)
-> ([ArbitraryChurnMode] -> ShowS)
-> Show ArbitraryChurnMode
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArbitraryChurnMode -> ShowS
showsPrec :: Int -> ArbitraryChurnMode -> ShowS
$cshow :: ArbitraryChurnMode -> TestName
show :: ArbitraryChurnMode -> TestName
$cshowList :: [ArbitraryChurnMode] -> ShowS
showList :: [ArbitraryChurnMode] -> ShowS
Show

instance Arbitrary ArbitraryChurnMode where
    arbitrary :: Gen ArbitraryChurnMode
arbitrary = ChurnMode -> ArbitraryChurnMode
ArbitraryChurnMode (ChurnMode -> ArbitraryChurnMode)
-> Gen ChurnMode -> Gen ArbitraryChurnMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        [ChurnMode] -> Gen ChurnMode
forall a. [a] -> Gen a
elements [ChurnMode
ChurnModeNormal, ChurnMode
ChurnModeBulkSync]

instance Arbitrary ArbitraryPolicyArguments where
    arbitrary :: Gen ArbitraryPolicyArguments
arbitrary = do
        peer <- Gen ArbitrarySockAddr
forall a. Arbitrary a => Gen a
arbitrary
        peers_ <- arbitrary
        kpi <- arbitrary
        kpis <- arbitrary
        let available = [(SockAddr, ArbitraryPeerInfo)] -> Map SockAddr ArbitraryPeerInfo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(SockAddr, ArbitraryPeerInfo)] -> Map SockAddr ArbitraryPeerInfo)
-> [(SockAddr, ArbitraryPeerInfo)]
-> Map SockAddr ArbitraryPeerInfo
forall a b. (a -> b) -> a -> b
$ (ArbitrarySockAddr
 -> ArbitraryPeerInfo -> (SockAddr, ArbitraryPeerInfo))
-> [ArbitrarySockAddr]
-> [ArbitraryPeerInfo]
-> [(SockAddr, ArbitraryPeerInfo)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ArbitrarySockAddr
-> ArbitraryPeerInfo -> (SockAddr, ArbitraryPeerInfo)
fn (ArbitrarySockAddr
peerArbitrarySockAddr -> [ArbitrarySockAddr] -> [ArbitrarySockAddr]
forall a. a -> [a] -> [a]
:[ArbitrarySockAddr]
peers_) (ArbitraryPeerInfo
kpiArbitraryPeerInfo -> [ArbitraryPeerInfo] -> [ArbitraryPeerInfo]
forall a. a -> [a] -> [a]
:[ArbitraryPeerInfo]
kpis)
            peers = Map SockAddr ArbitraryPeerInfo -> [SockAddr]
forall k a. Map k a -> [k]
Map.keys Map SockAddr ArbitraryPeerInfo
available
        pickNum <- oneof [ return 1
                         , return $ min 2 (Map.size available)
                         , choose (1, Map.size available)
                         ]
        hCnt <- choose (0, maxSamples)
        fCnt <- choose (0, maxSamples)
        let hSlotNo = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
hCnt [Int
1..Int
maxSamples]
            fSlotNo = Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
fCnt [Int
1..Int
maxSamples]
        hm <- Pq.fromList <$> mapM (headerMetric peers) hSlotNo
        fm <- Pq.fromList <$> mapM (fetchedMetric peers) fSlotNo
        (ArbitraryChurnMode cm) <- arbitrary
        dm <- arbitrary

        return $ ArbitraryPolicyArguments available pickNum hm fm cm dm

     where
       maxSamples :: Int
maxSamples = Int
10

       fn :: ArbitrarySockAddr
          -> ArbitraryPeerInfo
          -> (SockAddr, ArbitraryPeerInfo)
       fn :: ArbitrarySockAddr
-> ArbitraryPeerInfo -> (SockAddr, ArbitraryPeerInfo)
fn (ArbitrarySockAddr SockAddr
addr) ArbitraryPeerInfo
kpi = (SockAddr
addr, ArbitraryPeerInfo
kpi)

       headerMetric :: [SockAddr]
                    -> Int
                    -> Gen (Int, SlotNo, (SockAddr, Time))
       headerMetric :: [SockAddr] -> Int -> Gen (Int, SlotNo, (SockAddr, Time))
headerMetric [SockAddr]
peers Int
slotNo = do
           peer <- [SockAddr] -> Gen SockAddr
forall a. [a] -> Gen a
elements [SockAddr]
peers
           return (slotNo, SlotNo $ fromIntegral slotNo, (peer, Time 0))

       fetchedMetric :: [SockAddr]
                     -> Int
                     -> Gen (Int, SlotNo, ((SockAddr, SizeInBytes), Time))
       fetchedMetric :: [SockAddr]
-> Int -> Gen (Int, SlotNo, ((SockAddr, SizeInBytes), Time))
fetchedMetric [SockAddr]
peers Int
slotNo = do
           peer <- [SockAddr] -> Gen SockAddr
forall a. [a] -> Gen a
elements [SockAddr]
peers
           fetched <- SizeInBytes <$> choose (1, 0xffff)
           return (slotNo, SlotNo $ fromIntegral slotNo,
                   ((peer, fetched), Time 0))



prop_hotToWarm :: ArbitraryPolicyArguments
               -> Int
               -> Property
prop_hotToWarm :: ArbitraryPolicyArguments -> Int -> Property
prop_hotToWarm ArbitraryPolicyArguments
args Int
seed = (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$ ArbitraryPolicyArguments -> Int -> IOSim s Property
forall (m :: * -> *).
MonadLabelledSTM m =>
ArbitraryPolicyArguments -> Int -> m Property
prop_hotToWarmM ArbitraryPolicyArguments
args Int
seed

-- Verify that there are no peers worse than the peers picked for demotion.
prop_hotToWarmM :: forall m. MonadLabelledSTM m
                 => ArbitraryPolicyArguments
                 -> Int
                 -> m Property
prop_hotToWarmM :: forall (m :: * -> *).
MonadLabelledSTM m =>
ArbitraryPolicyArguments -> Int -> m Property
prop_hotToWarmM ArbitraryPolicyArguments{Int
Map SockAddr ArbitraryPeerInfo
ChurnMode
SlotMetric (SockAddr, SizeInBytes)
SlotMetric SockAddr
ArbitraryDemotion
apaAvailable :: ArbitraryPolicyArguments -> Map SockAddr ArbitraryPeerInfo
apaPickNum :: ArbitraryPolicyArguments -> Int
apaHeaderMetric :: ArbitraryPolicyArguments -> SlotMetric SockAddr
apaFetchedMetric :: ArbitraryPolicyArguments -> SlotMetric (SockAddr, SizeInBytes)
apaChurnMode :: ArbitraryPolicyArguments -> ChurnMode
apaDemotion :: ArbitraryPolicyArguments -> ArbitraryDemotion
apaAvailable :: Map SockAddr ArbitraryPeerInfo
apaPickNum :: Int
apaHeaderMetric :: SlotMetric SockAddr
apaFetchedMetric :: SlotMetric (SockAddr, SizeInBytes)
apaChurnMode :: ChurnMode
apaDemotion :: ArbitraryDemotion
..} Int
seed = do
    let rng :: StdGen
rng = Int -> StdGen
mkStdGen Int
seed
    rngVar <- StdGen -> m (StrictTVar m StdGen)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO StdGen
rng
    cmVar <- newTVarIO apaChurnMode
    metrics <- newPeerMetric' apaHeaderMetric apaFetchedMetric
                              PeerMetricsConfiguration { maxEntriesToTrack = 180 }

    let policies = StrictTVar m StdGen
-> STM m ChurnMode
-> PeerMetrics m SockAddr
-> RepromoteDelay
-> PeerSelectionPolicy SockAddr m
forall (m :: * -> *) peerAddr.
(MonadSTM m, Ord peerAddr) =>
StrictTVar m StdGen
-> STM m ChurnMode
-> PeerMetrics m peerAddr
-> RepromoteDelay
-> PeerSelectionPolicy peerAddr m
simplePeerSelectionPolicy
                        StrictTVar m StdGen
rngVar
                        (StrictTVar m ChurnMode -> STM m ChurnMode
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m ChurnMode
cmVar)
                        PeerMetrics m SockAddr
metrics
                        (DiffTime -> RepromoteDelay
RepromoteDelay DiffTime
10)
    picked <- atomically $ policyPickHotPeersToDemote policies
                  (const PeerSourceLocalRoot)
                  peerConnectFailCount
                  peerIsTepid
                  (Map.keysSet apaAvailable)
                  apaPickNum
    noneWorse metrics picked

  where

    peerConnectFailCount :: SockAddr -> Int
peerConnectFailCount SockAddr
p =
        Int -> (ArbitraryPeerInfo -> Int) -> Maybe ArbitraryPeerInfo -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TestName -> Int
forall a. HasCallStack => TestName -> a
error TestName
"peerConnectFailCount") ArbitraryPeerInfo -> Int
piFailCount (SockAddr
-> Map SockAddr ArbitraryPeerInfo -> Maybe ArbitraryPeerInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SockAddr
p Map SockAddr ArbitraryPeerInfo
apaAvailable)

    peerIsTepid :: SockAddr -> Bool
peerIsTepid SockAddr
p =
        Bool
-> (ArbitraryPeerInfo -> Bool) -> Maybe ArbitraryPeerInfo -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TestName -> Bool
forall a. HasCallStack => TestName -> a
error TestName
"peerIsTepid") ArbitraryPeerInfo -> Bool
piTepid (SockAddr
-> Map SockAddr ArbitraryPeerInfo -> Maybe ArbitraryPeerInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SockAddr
p Map SockAddr ArbitraryPeerInfo
apaAvailable)

    noneWorse :: PeerMetrics m SockAddr
              -> Set SockAddr
              -> m Property
    noneWorse :: PeerMetrics m SockAddr -> Set SockAddr -> m Property
noneWorse PeerMetrics m SockAddr
metrics Set SockAddr
pickedSet = do
        scores <- STM m (Map SockAddr Int) -> m (Map SockAddr Int)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Map SockAddr Int) -> m (Map SockAddr Int))
-> STM m (Map SockAddr Int) -> m (Map SockAddr Int)
forall a b. (a -> b) -> a -> b
$ case ChurnMode
apaChurnMode of
                      ChurnMode
ChurnModeNormal -> do
                          hup <- PeerMetrics m SockAddr -> STM m (Map SockAddr Int)
forall p (m :: * -> *).
(MonadSTM m, Ord p) =>
PeerMetrics m p -> STM m (Map p Int)
upstreamyness PeerMetrics m SockAddr
metrics
                          bup <- fetchynessBlocks metrics
                          return $ Map.unionWith (+) hup bup
                      ChurnMode
ChurnModeBulkSync ->
                          PeerMetrics m SockAddr -> STM m (Map SockAddr Int)
forall p (m :: * -> *).
(MonadSTM m, Ord p) =>
PeerMetrics m p -> STM m (Map p Int)
fetchynessBytes PeerMetrics m SockAddr
metrics
        let (picked, notPicked) = Map.partitionWithKey fn scores
            maxPicked = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Map SockAddr Int -> [Int]
forall k a. Map k a -> [a]
Map.elems Map SockAddr Int
picked
            minNotPicked = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Map SockAddr Int -> [Int]
forall k a. Map k a -> [a]
Map.elems Map SockAddr Int
notPicked
        if Map.null notPicked || Map.null picked
           then return $ property True
           else return $
               counterexample (show maxPicked ++ " > " ++ show minNotPicked)
                 (maxPicked <= minNotPicked)
      where
        fn :: SockAddr -> a -> Bool
        fn :: forall a. SockAddr -> a -> Bool
fn SockAddr
peer a
_ = SockAddr -> Set SockAddr -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member SockAddr
peer Set SockAddr
pickedSet


prop_randomDemotion :: ArbitraryPolicyArguments
                 -> Int
                 -> Property
prop_randomDemotion :: ArbitraryPolicyArguments -> Int -> Property
prop_randomDemotion ArbitraryPolicyArguments
args Int
seed = (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
runSimOrThrow ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$ ArbitraryPolicyArguments -> Int -> IOSim s Property
forall (m :: * -> *).
MonadLabelledSTM m =>
ArbitraryPolicyArguments -> Int -> m Property
prop_randomDemotionM ArbitraryPolicyArguments
args Int
seed


-- Verifies that Tepid (formerly hot) or failing peers are more likely to get
-- demoted/forgotten.
prop_randomDemotionM :: forall m. MonadLabelledSTM m
                     => ArbitraryPolicyArguments
                     -> Int
                     -> m Property
prop_randomDemotionM :: forall (m :: * -> *).
MonadLabelledSTM m =>
ArbitraryPolicyArguments -> Int -> m Property
prop_randomDemotionM ArbitraryPolicyArguments{Int
Map SockAddr ArbitraryPeerInfo
ChurnMode
SlotMetric (SockAddr, SizeInBytes)
SlotMetric SockAddr
ArbitraryDemotion
apaAvailable :: ArbitraryPolicyArguments -> Map SockAddr ArbitraryPeerInfo
apaPickNum :: ArbitraryPolicyArguments -> Int
apaHeaderMetric :: ArbitraryPolicyArguments -> SlotMetric SockAddr
apaFetchedMetric :: ArbitraryPolicyArguments -> SlotMetric (SockAddr, SizeInBytes)
apaChurnMode :: ArbitraryPolicyArguments -> ChurnMode
apaDemotion :: ArbitraryPolicyArguments -> ArbitraryDemotion
apaAvailable :: Map SockAddr ArbitraryPeerInfo
apaPickNum :: Int
apaHeaderMetric :: SlotMetric SockAddr
apaFetchedMetric :: SlotMetric (SockAddr, SizeInBytes)
apaChurnMode :: ChurnMode
apaDemotion :: ArbitraryDemotion
..} Int
seed = do
    let rng :: StdGen
rng = Int -> StdGen
mkStdGen Int
seed
    rngVar <- StdGen -> m (StrictTVar m StdGen)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO StdGen
rng
    cmVar <- newTVarIO apaChurnMode
    metrics <- newPeerMetric' apaHeaderMetric apaFetchedMetric
                              PeerMetricsConfiguration { maxEntriesToTrack = 180 }

    let policies = StrictTVar m StdGen
-> STM m ChurnMode
-> PeerMetrics m SockAddr
-> RepromoteDelay
-> PeerSelectionPolicy SockAddr m
forall (m :: * -> *) peerAddr.
(MonadSTM m, Ord peerAddr) =>
StrictTVar m StdGen
-> STM m ChurnMode
-> PeerMetrics m peerAddr
-> RepromoteDelay
-> PeerSelectionPolicy peerAddr m
simplePeerSelectionPolicy
                        StrictTVar m StdGen
rngVar
                        (StrictTVar m ChurnMode -> STM m ChurnMode
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m ChurnMode
cmVar)
                        PeerMetrics m SockAddr
metrics
                        (DiffTime -> RepromoteDelay
RepromoteDelay DiffTime
10)
    doDemotion numberOfTries policies Map.empty


  where
    numberOfTries :: Int
numberOfTries = Int
10000

    peerConnectFailCount :: SockAddr -> Int
peerConnectFailCount SockAddr
p =
        Int -> (ArbitraryPeerInfo -> Int) -> Maybe ArbitraryPeerInfo -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TestName -> Int
forall a. HasCallStack => TestName -> a
error TestName
"peerConnectFailCount") ArbitraryPeerInfo -> Int
piFailCount (SockAddr
-> Map SockAddr ArbitraryPeerInfo -> Maybe ArbitraryPeerInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SockAddr
p Map SockAddr ArbitraryPeerInfo
apaAvailable)

    peerIsTepid :: SockAddr -> Bool
peerIsTepid SockAddr
p =
        Bool
-> (ArbitraryPeerInfo -> Bool) -> Maybe ArbitraryPeerInfo -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TestName -> Bool
forall a. HasCallStack => TestName -> a
error TestName
"peerIsTepid") ArbitraryPeerInfo -> Bool
piTepid (SockAddr
-> Map SockAddr ArbitraryPeerInfo -> Maybe ArbitraryPeerInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SockAddr
p Map SockAddr ArbitraryPeerInfo
apaAvailable)

    doDemotion :: Int
               -> PeerSelectionPolicy SockAddr m
               -> Map SockAddr Int
               -> m Property
    doDemotion :: Int
-> PeerSelectionPolicy SockAddr m -> Map SockAddr Int -> m Property
doDemotion Int
0 PeerSelectionPolicy SockAddr m
_ Map SockAddr Int
countMap = do
        let (!Int
nonTepids, !Int
nonTepidSum, !Int
tepids, !Int
tepidSum) =
                ((Int, Int, Int, Int) -> (SockAddr, Int) -> (Int, Int, Int, Int))
-> (Int, Int, Int, Int)
-> [(SockAddr, Int)]
-> (Int, Int, Int, Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (Int, Int, Int, Int) -> (SockAddr, Int) -> (Int, Int, Int, Int)
byTepid (Int
0,Int
0,Int
0,Int
0) ([(SockAddr, Int)] -> (Int, Int, Int, Int))
-> [(SockAddr, Int)] -> (Int, Int, Int, Int)
forall a b. (a -> b) -> a -> b
$ Map SockAddr Int -> [(SockAddr, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList Map SockAddr Int
countMap
            meanNonTepid :: Double
meanNonTepid = if Int
nonTepids Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                              then Double
0 :: Double
                              else Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nonTepidSum Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/
                                     Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nonTepids
            meanTepid :: Double
meanTepid = if Int
tepids Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                           then Double
0 :: Double
                           else Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tepidSum Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/
                                  Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
tepids
        if Int
apaPickNum Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Map SockAddr ArbitraryPeerInfo -> Int
forall k a. Map k a -> Int
Map.size Map SockAddr ArbitraryPeerInfo
apaAvailable
           then Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
           else if Double
meanNonTepid Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0 Bool -> Bool -> Bool
&& Double
meanTepid Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
0
           then Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ Double
meanNonTepid Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
meanTepid
           else Property -> m Property
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Property -> m Property) -> Property -> m Property
forall a b. (a -> b) -> a -> b
$ Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
      where
        kpiFilter :: ArbitraryPeerInfo -> Bool
        kpiFilter :: ArbitraryPeerInfo -> Bool
kpiFilter = case ArbitraryDemotion
apaDemotion of
                     ArbitraryDemotion
ArbitraryWarmDemotion -> ArbitraryPeerInfo -> Bool
piTepid
                     ArbitraryDemotion
ArbitraryColdDemotion ->
                         (\ArbitraryPeerInfo
kpi -> ArbitraryPeerInfo -> Int
piFailCount ArbitraryPeerInfo
kpi Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)

        byTepid :: (Int, Int, Int, Int)
                -> (SockAddr, Int)
                -> (Int, Int, Int, Int)
        byTepid :: (Int, Int, Int, Int) -> (SockAddr, Int) -> (Int, Int, Int, Int)
byTepid (!Int
nonTepids, !Int
nonTepidSum, !Int
tepids, !Int
tepidSum) (SockAddr
addr, Int
cnt) =
            case SockAddr
-> Map SockAddr ArbitraryPeerInfo -> Maybe ArbitraryPeerInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SockAddr
addr Map SockAddr ArbitraryPeerInfo
apaAvailable of
                 Just ArbitraryPeerInfo
kpi ->
                     if ArbitraryPeerInfo -> Bool
kpiFilter ArbitraryPeerInfo
kpi
                        then ( Int
nonTepids, Int
nonTepidSum
                             , Int
tepids Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
tepidSum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cnt)
                        else ( Int
nonTepids Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
nonTepidSum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
cnt
                             , Int
tepids, Int
tepidSum)
                 Maybe ArbitraryPeerInfo
Nothing -> TestName -> (Int, Int, Int, Int)
forall a. HasCallStack => TestName -> a
error TestName
"picked unknown addr"

    doDemotion !Int
n PeerSelectionPolicy SockAddr m
policies Map SockAddr Int
countMap = do
        let policy :: PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policy = case ArbitraryDemotion
apaDemotion of
                          ArbitraryDemotion
ArbitraryWarmDemotion -> PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickWarmPeersToDemote
                          ArbitraryDemotion
ArbitraryColdDemotion -> PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickColdPeersToForget
        picked <- STM m (Set SockAddr) -> m (Set SockAddr)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Set SockAddr) -> m (Set SockAddr))
-> STM m (Set SockAddr) -> m (Set SockAddr)
forall a b. (a -> b) -> a -> b
$ PeerSelectionPolicy SockAddr m -> PickPolicy SockAddr (STM m)
forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policy PeerSelectionPolicy SockAddr m
policies
                    (PeerSource -> SockAddr -> PeerSource
forall a b. a -> b -> a
const PeerSource
PeerSourceLocalRoot)
                    SockAddr -> Int
peerConnectFailCount
                    SockAddr -> Bool
peerIsTepid
                    (Map SockAddr ArbitraryPeerInfo -> Set SockAddr
forall k a. Map k a -> Set k
Map.keysSet Map SockAddr ArbitraryPeerInfo
apaAvailable)
                    Int
apaPickNum
        if Set.size picked /= apaPickNum
           then return $ property False
           else do
               let countMap' = (Map SockAddr Int -> SockAddr -> Map SockAddr Int)
-> Map SockAddr Int -> Set SockAddr -> Map SockAddr Int
forall b a. (b -> a -> b) -> b -> Set a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Map SockAddr Int -> SockAddr -> Map SockAddr Int
fn Map SockAddr Int
countMap Set SockAddr
picked
               doDemotion (n-1) policies countMap'
      where
        fn :: Map SockAddr Int -> SockAddr -> Map SockAddr Int
        fn :: Map SockAddr Int -> SockAddr -> Map SockAddr Int
fn Map SockAddr Int
m SockAddr
addr = (Maybe Int -> Maybe Int)
-> SockAddr -> Map SockAddr Int -> Map SockAddr Int
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe Int -> Maybe Int
add SockAddr
addr Map SockAddr Int
m

        add :: Maybe Int -> Maybe Int
        add :: Maybe Int -> Maybe Int
add Maybe Int
Nothing  = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
        add (Just Int
c) = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$! Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1