{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
#if __GLASGOW_HASKELL__ >= 908
{-# OPTIONS_GHC -Wno-x-partial #-}
#endif
module Test.Ouroboros.Network.PeerSelection.RootPeersDNS
( tests
, mockDNSActions
, MockRoots (..)
, DNSTimeout (..)
, DNSLookupDelay (..)
, DelayAndTimeoutScripts (..)
) where
import Control.Applicative (Alternative)
import Control.Monad (forever, replicateM_)
import Data.ByteString.Char8 (pack)
import Data.Dynamic (Typeable, fromDynamic)
import Data.Either (rights)
import Data.Foldable as Foldable (foldl')
import Data.Function (fix)
import Data.Functor (void)
import Data.IP (fromHostAddress, toIPv4w, toSockAddr)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (catMaybes)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Time.Clock (picosecondsToDiffTime)
import Data.Void (Void)
import Network.DNS (DNSError (NameError, TimeoutExpired), Domain, TTL)
import Network.DNS.Resolver qualified as DNSResolver
import Network.Socket (SockAddr (..))
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Exception (throw)
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadSay (MonadSay (..))
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime (getMonotonicTime),
Time (..), addTime)
import Control.Monad.Class.MonadTimer.SI
import Control.Monad.Class.MonadTimer.SI qualified as MonadTimer
import Control.Monad.IOSim
import Control.Tracer (Tracer (Tracer), contramap, nullTracer, traceWith)
import Control.Concurrent.Class.MonadSTM qualified as LazySTM
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty (..))
import Ouroboros.Network.PeerSelection.LedgerPeers
import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..))
import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable (..))
import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions
import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore
import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers
import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers
import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..),
WarmValency (..))
import Ouroboros.Network.Testing.Data.Script (Script (Script), initScript',
scriptHead, singletonScript, stepScript')
import Test.Ouroboros.Network.PeerSelection.Instances ()
import Test.QuickCheck
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)
tests :: TestTree
tests :: TestTree
tests =
[Char] -> [TestTree] -> TestTree
testGroup [Char]
"Ouroboros.Network.PeerSelection"
[ [Char] -> [TestTree] -> TestTree
testGroup [Char]
"RootPeersDNS"
[ [Char] -> [TestTree] -> TestTree
testGroup [Char]
"localRootPeersProvider"
[ [Char]
-> (MockRoots
-> Script DNSTimeout -> Script DNSLookupDelay -> Property)
-> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"preserve IPs"
MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> Property
prop_local_preservesIPs
, [Char]
-> (MockRoots
-> Script DNSTimeout -> Script DNSLookupDelay -> Property)
-> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"preserves groups and targets"
MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> Property
prop_local_preservesGroupNumberAndTargets
, [Char]
-> (MockRoots
-> Script DNSTimeout -> Script DNSLookupDelay -> Property)
-> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"resolves domains correctly"
MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> Property
prop_local_resolvesDomainsCorrectly
, [Char]
-> (MockRoots
-> Script DNSTimeout -> Script DNSLookupDelay -> Property)
-> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"updates domains correctly"
MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> Property
prop_local_updatesDomainsCorrectly
]
, [Char] -> [TestTree] -> TestTree
testGroup [Char]
"publicRootPeersProvider"
[ [Char]
-> (MockRoots -> DelayAndTimeoutScripts -> Int -> Property)
-> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"resolves domains correctly"
MockRoots -> DelayAndTimeoutScripts -> Int -> Property
prop_public_resolvesDomainsCorrectly
]
, [Char] -> [TestTree] -> TestTree
testGroup [Char]
"delayedResource"
[
]
]
]
data MockRoots = MockRoots {
MockRoots
-> [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
mockLocalRootPeers :: [( HotValency
, WarmValency
, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
, MockRoots -> Script (Map Domain [(IP, Word32)])
mockLocalRootPeersDNSMap :: Script (Map Domain [(IP, TTL)])
, MockRoots -> Map RelayAccessPoint PeerAdvertise
mockPublicRootPeers :: Map RelayAccessPoint PeerAdvertise
, MockRoots -> Script (Map Domain [(IP, Word32)])
mockPublicRootPeersDNSMap :: Script (Map Domain [(IP, TTL)])
}
deriving Int -> MockRoots -> ShowS
[MockRoots] -> ShowS
MockRoots -> [Char]
(Int -> MockRoots -> ShowS)
-> (MockRoots -> [Char])
-> ([MockRoots] -> ShowS)
-> Show MockRoots
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MockRoots -> ShowS
showsPrec :: Int -> MockRoots -> ShowS
$cshow :: MockRoots -> [Char]
show :: MockRoots -> [Char]
$cshowList :: [MockRoots] -> ShowS
showList :: [MockRoots] -> ShowS
Show
genMockRoots :: Gen MockRoots
genMockRoots :: Gen MockRoots
genMockRoots = (Int -> Gen MockRoots) -> Gen MockRoots
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen MockRoots) -> Gen MockRoots)
-> (Int -> Gen MockRoots) -> Gen MockRoots
forall a b. (a -> b) -> a -> b
$ \Int
relaysNumber -> do
relaysPerGroup <- (Int, Int) -> Gen Int
forall a. Enum a => (a, a) -> Gen a
chooseEnum (Int
1, Int
relaysNumber Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3)
localRootRelays <- vectorOf relaysNumber arbitrary
targets <- vectorOf relaysNumber genTargets
peerAdvertise <- blocks relaysPerGroup
<$> vectorOf relaysNumber arbitrary
let taggedLocalRelays = [RelayAccessPoint] -> [RelayAccessPoint]
tagRelays [RelayAccessPoint]
localRootRelays
localRelaysBlocks = Int -> [RelayAccessPoint] -> [[RelayAccessPoint]]
forall {a}. Int -> [a] -> [[a]]
blocks Int
relaysPerGroup [RelayAccessPoint]
taggedLocalRelays
localRelaysMap = ([(RelayAccessPoint, (PeerAdvertise, PeerTrustable))]
-> Map RelayAccessPoint (PeerAdvertise, PeerTrustable))
-> [[(RelayAccessPoint, (PeerAdvertise, PeerTrustable))]]
-> [Map RelayAccessPoint (PeerAdvertise, PeerTrustable)]
forall a b. (a -> b) -> [a] -> [b]
map [(RelayAccessPoint, (PeerAdvertise, PeerTrustable))]
-> Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([[(RelayAccessPoint, (PeerAdvertise, PeerTrustable))]]
-> [Map RelayAccessPoint (PeerAdvertise, PeerTrustable)])
-> [[(RelayAccessPoint, (PeerAdvertise, PeerTrustable))]]
-> [Map RelayAccessPoint (PeerAdvertise, PeerTrustable)]
forall a b. (a -> b) -> a -> b
$ ([RelayAccessPoint]
-> [(PeerAdvertise, PeerTrustable)]
-> [(RelayAccessPoint, (PeerAdvertise, PeerTrustable))])
-> [[RelayAccessPoint]]
-> [[(PeerAdvertise, PeerTrustable)]]
-> [[(RelayAccessPoint, (PeerAdvertise, PeerTrustable))]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [RelayAccessPoint]
-> [(PeerAdvertise, PeerTrustable)]
-> [(RelayAccessPoint, (PeerAdvertise, PeerTrustable))]
forall a b. [a] -> [b] -> [(a, b)]
zip [[RelayAccessPoint]]
localRelaysBlocks
[[(PeerAdvertise, PeerTrustable)]]
peerAdvertise
localRootPeers = ((HotValency, WarmValency)
-> Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
-> (HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable)))
-> [(HotValency, WarmValency)]
-> [Map RelayAccessPoint (PeerAdvertise, PeerTrustable)]
-> [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(HotValency
h, WarmValency
w) Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
g -> (HotValency
h, WarmValency
w, Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
g)) [(HotValency, WarmValency)]
targets [Map RelayAccessPoint (PeerAdvertise, PeerTrustable)]
localRelaysMap
localRootDomains = [ Domain
domain
| RelayAccessDomain Domain
domain PortNumber
_ <- [RelayAccessPoint]
taggedLocalRelays ]
ipsPerDomain = Int
2
lrpDNSMap <- Script . NonEmpty.fromList
<$> listOf1 (genDomainLookupTable ipsPerDomain localRootDomains)
publicRootRelays <- vectorOf relaysNumber arbitrary
publicRootPeersAdvertise <- vectorOf relaysNumber arbitrary
let publicRootPeers =
[(RelayAccessPoint, PeerAdvertise)]
-> Map RelayAccessPoint PeerAdvertise
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([RelayAccessPoint]
-> [PeerAdvertise] -> [(RelayAccessPoint, PeerAdvertise)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([RelayAccessPoint] -> [RelayAccessPoint]
tagRelays [RelayAccessPoint]
publicRootRelays)
[PeerAdvertise]
publicRootPeersAdvertise)
publicRootDomains = [ Domain
domain
| (RelayAccessDomain Domain
domain PortNumber
_, PeerAdvertise
_)
<- Map RelayAccessPoint PeerAdvertise
-> [(RelayAccessPoint, PeerAdvertise)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map RelayAccessPoint PeerAdvertise
publicRootPeers ]
publicRootPeersDNSMap <- Script . NonEmpty.fromList
<$> listOf1 (genDomainLookupTable ipsPerDomain publicRootDomains)
return (MockRoots {
mockLocalRootPeers = localRootPeers,
mockLocalRootPeersDNSMap = lrpDNSMap,
mockPublicRootPeers = publicRootPeers,
mockPublicRootPeersDNSMap = publicRootPeersDNSMap
})
where
genTargets :: Gen (HotValency, WarmValency)
genTargets :: Gen (HotValency, WarmValency)
genTargets = do
warmValency <- Int -> WarmValency
WarmValency (Int -> WarmValency) -> Gen Int -> Gen WarmValency
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
forall a. Enum a => (a, a) -> Gen a
chooseEnum (Int
1, Int
5)
hotValency <- HotValency <$> chooseEnum (1, getWarmValency warmValency)
return (hotValency, warmValency)
genDomainLookupTable :: Int -> [Domain] -> Gen (Map Domain [(IP, TTL)])
genDomainLookupTable :: Int -> [Domain] -> Gen (Map Domain [(IP, Word32)])
genDomainLookupTable Int
ipsPerDomain [Domain]
localRootDomains = do
localRootDomainIPs <- Int -> [IP] -> [[IP]]
forall {a}. Int -> [a] -> [[a]]
blocks Int
ipsPerDomain
([IP] -> [[IP]]) -> Gen [IP] -> Gen [[IP]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen IP -> Gen [IP]
forall a. Int -> Gen a -> Gen [a]
vectorOf (Int
ipsPerDomain Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Domain] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Domain]
localRootDomains)
(IPv4 -> IP
IPv4 (IPv4 -> IP) -> (Word32 -> IPv4) -> Word32 -> IP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> IPv4
toIPv4w (Word32 -> IP) -> Gen Word32 -> Gen IP
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary)
localRootDomainTTLs <- blocks ipsPerDomain
<$> vectorOf (ipsPerDomain * length localRootDomains)
(arbitrary :: Gen TTL)
let localRootDomainsIP_TTls = ([IP] -> [Word32] -> [(IP, Word32)])
-> [[IP]] -> [[Word32]] -> [[(IP, Word32)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [IP] -> [Word32] -> [(IP, Word32)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[IP]]
localRootDomainIPs [[Word32]]
localRootDomainTTLs
lrpDNSMap = [(Domain, [(IP, Word32)])] -> Map Domain [(IP, Word32)]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Domain, [(IP, Word32)])] -> Map Domain [(IP, Word32)])
-> [(Domain, [(IP, Word32)])] -> Map Domain [(IP, Word32)]
forall a b. (a -> b) -> a -> b
$ [Domain] -> [[(IP, Word32)]] -> [(Domain, [(IP, Word32)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Domain]
localRootDomains [[(IP, Word32)]]
localRootDomainsIP_TTls
return lrpDNSMap
tagRelays :: [RelayAccessPoint] -> [RelayAccessPoint]
tagRelays [RelayAccessPoint]
relays =
(Int -> RelayAccessPoint -> RelayAccessPoint)
-> [Int] -> [RelayAccessPoint] -> [RelayAccessPoint]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
(\Int
tag RelayAccessPoint
rel
-> case RelayAccessPoint
rel of
RelayAccessDomain Domain
domain PortNumber
port
-> Domain -> PortNumber -> RelayAccessPoint
RelayAccessDomain (Domain
domain Domain -> Domain -> Domain
forall a. Semigroup a => a -> a -> a
<> ([Char] -> Domain
pack ([Char] -> Domain) -> (Int -> [Char]) -> Int -> Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show) Int
tag) PortNumber
port
RelayAccessPoint
x -> RelayAccessPoint
x
)
[(Int
0 :: Int), Int
1 .. ]
[RelayAccessPoint]
relays
blocks :: Int -> [a] -> [[a]]
blocks Int
_ [] = []
blocks Int
s [a]
l = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
s [a]
l [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Int -> [a] -> [[a]]
blocks Int
s (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
s [a]
l)
instance Arbitrary MockRoots where
arbitrary :: Gen MockRoots
arbitrary = Gen MockRoots
genMockRoots
shrink :: MockRoots -> [MockRoots]
shrink roots :: MockRoots
roots@MockRoots { [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
mockLocalRootPeers :: MockRoots
-> [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
mockLocalRootPeers :: [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
mockLocalRootPeers
, Script (Map Domain [(IP, Word32)])
mockLocalRootPeersDNSMap :: MockRoots -> Script (Map Domain [(IP, Word32)])
mockLocalRootPeersDNSMap :: Script (Map Domain [(IP, Word32)])
mockLocalRootPeersDNSMap
, Map RelayAccessPoint PeerAdvertise
mockPublicRootPeers :: MockRoots -> Map RelayAccessPoint PeerAdvertise
mockPublicRootPeers :: Map RelayAccessPoint PeerAdvertise
mockPublicRootPeers
, Script (Map Domain [(IP, Word32)])
mockPublicRootPeersDNSMap :: MockRoots -> Script (Map Domain [(IP, Word32)])
mockPublicRootPeersDNSMap :: Script (Map Domain [(IP, Word32)])
mockPublicRootPeersDNSMap
} =
[ MockRoots
roots { mockLocalRootPeers = lrp
, mockLocalRootPeersDNSMap = lrpDNSMap
}
| [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
lrp <- ((HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))
-> [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))])
-> [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
-> [[(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
-> (HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))
-> [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
forall a b. a -> b -> a
const []) [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
mockLocalRootPeers,
let lrpDomains :: Set Domain
lrpDomains =
[Domain] -> Set Domain
forall a. Ord a => [a] -> Set a
Set.fromList [ Domain
domain
| RelayAccessDomain Domain
domain PortNumber
_
<- ((HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))
-> [RelayAccessPoint])
-> [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
-> [RelayAccessPoint]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
-> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys (Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
-> [RelayAccessPoint])
-> ((HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))
-> Map RelayAccessPoint (PeerAdvertise, PeerTrustable))
-> (HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))
-> [RelayAccessPoint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))
-> Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
forall {a} {b} {c}. (a, b, c) -> c
thrd) [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
lrp ]
lrpDNSMap :: Script (Map Domain [(IP, Word32)])
lrpDNSMap = (Map Domain [(IP, Word32)]
-> Set Domain -> Map Domain [(IP, Word32)]
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set Domain
lrpDomains)
(Map Domain [(IP, Word32)] -> Map Domain [(IP, Word32)])
-> Script (Map Domain [(IP, Word32)])
-> Script (Map Domain [(IP, Word32)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Script (Map Domain [(IP, Word32)])
mockLocalRootPeersDNSMap
] [MockRoots] -> [MockRoots] -> [MockRoots]
forall a. [a] -> [a] -> [a]
++
[ MockRoots
roots { mockPublicRootPeers = prp
, mockPublicRootPeersDNSMap = prpDNSMap
}
| Map RelayAccessPoint PeerAdvertise
prp <- Map RelayAccessPoint PeerAdvertise
-> [Map RelayAccessPoint PeerAdvertise]
forall a. Arbitrary a => a -> [a]
shrink Map RelayAccessPoint PeerAdvertise
mockPublicRootPeers,
let prpDomains :: Set Domain
prpDomains = [Domain] -> Set Domain
forall a. Ord a => [a] -> Set a
Set.fromList [ Domain
domain
| (RelayAccessDomain Domain
domain PortNumber
_, PeerAdvertise
_)
<- Map RelayAccessPoint PeerAdvertise
-> [(RelayAccessPoint, PeerAdvertise)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map RelayAccessPoint PeerAdvertise
prp ]
prpDNSMap :: Script (Map Domain [(IP, Word32)])
prpDNSMap = (Map Domain [(IP, Word32)]
-> Set Domain -> Map Domain [(IP, Word32)]
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set Domain
prpDomains)
(Map Domain [(IP, Word32)] -> Map Domain [(IP, Word32)])
-> Script (Map Domain [(IP, Word32)])
-> Script (Map Domain [(IP, Word32)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Script (Map Domain [(IP, Word32)])
mockPublicRootPeersDNSMap
]
where
thrd :: (a, b, c) -> c
thrd (a
_, b
_, c
c) = c
c
simpleMockRoots :: MockRoots
simpleMockRoots :: MockRoots
simpleMockRoots = [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
-> Script (Map Domain [(IP, Word32)])
-> Map RelayAccessPoint PeerAdvertise
-> Script (Map Domain [(IP, Word32)])
-> MockRoots
MockRoots [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
localRootPeers Script (Map Domain [(IP, Word32)])
dnsMap Map RelayAccessPoint PeerAdvertise
forall k a. Map k a
Map.empty (Map Domain [(IP, Word32)] -> Script (Map Domain [(IP, Word32)])
forall a. a -> Script a
singletonScript Map Domain [(IP, Word32)]
forall k a. Map k a
Map.empty)
where
localRootPeers :: [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
localRootPeers =
[ ( HotValency
2, WarmValency
2
, [(RelayAccessPoint, (PeerAdvertise, PeerTrustable))]
-> Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ ( IP -> PortNumber -> RelayAccessPoint
RelayAccessAddress ([Char] -> IP
forall a. Read a => [Char] -> a
read [Char]
"192.0.2.1") ([Char] -> PortNumber
forall a. Read a => [Char] -> a
read [Char]
"3333")
, (PeerAdvertise
DoAdvertisePeer, PeerTrustable
IsNotTrustable)
)
, ( Domain -> PortNumber -> RelayAccessPoint
RelayAccessDomain Domain
"test.domain" ([Char] -> PortNumber
forall a. Read a => [Char] -> a
read [Char]
"4444")
, (PeerAdvertise
DoNotAdvertisePeer, PeerTrustable
IsNotTrustable)
)
]
)
]
dnsMap :: Script (Map Domain [(IP, Word32)])
dnsMap = Map Domain [(IP, Word32)] -> Script (Map Domain [(IP, Word32)])
forall a. a -> Script a
singletonScript (Map Domain [(IP, Word32)] -> Script (Map Domain [(IP, Word32)]))
-> Map Domain [(IP, Word32)] -> Script (Map Domain [(IP, Word32)])
forall a b. (a -> b) -> a -> b
$ [(Domain, [(IP, Word32)])] -> Map Domain [(IP, Word32)]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (Domain
"test.domain", [[Char] -> (IP, Word32)
forall a. Read a => [Char] -> a
read [Char]
"192.1.1.1", [Char] -> (IP, Word32)
forall a. Read a => [Char] -> a
read [Char]
"192.2.2.2"])
]
genDiffTime :: Integer
-> Integer
-> Gen DiffTime
genDiffTime :: Integer -> Integer -> Gen DiffTime
genDiffTime Integer
lo Integer
hi =
Integer -> DiffTime
picosecondsToDiffTime
(Integer -> DiffTime)
-> (NonNegative Integer -> Integer)
-> NonNegative Integer
-> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer
lo Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1_000_000_000 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+)
(Integer -> Integer)
-> (NonNegative Integer -> Integer)
-> NonNegative Integer
-> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer
1_000_000_000 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*)
(Integer -> Integer)
-> (NonNegative Integer -> Integer)
-> NonNegative Integer
-> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonNegative Integer -> Integer
forall a. NonNegative a -> a
getNonNegative
(NonNegative Integer -> DiffTime)
-> Gen (NonNegative Integer) -> Gen DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen (NonNegative Integer) -> Gen (NonNegative Integer)
forall a. Int -> Gen a -> Gen a
resize (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
hi) Gen (NonNegative Integer)
forall a. Arbitrary a => Gen a
arbitrary
newtype DNSTimeout = DNSTimeout { DNSTimeout -> DiffTime
getDNSTimeout :: DiffTime }
deriving Int -> DNSTimeout -> ShowS
[DNSTimeout] -> ShowS
DNSTimeout -> [Char]
(Int -> DNSTimeout -> ShowS)
-> (DNSTimeout -> [Char])
-> ([DNSTimeout] -> ShowS)
-> Show DNSTimeout
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DNSTimeout -> ShowS
showsPrec :: Int -> DNSTimeout -> ShowS
$cshow :: DNSTimeout -> [Char]
show :: DNSTimeout -> [Char]
$cshowList :: [DNSTimeout] -> ShowS
showList :: [DNSTimeout] -> ShowS
Show
instance Arbitrary DNSTimeout where
arbitrary :: Gen DNSTimeout
arbitrary = DiffTime -> DNSTimeout
DNSTimeout (DiffTime -> DNSTimeout) -> Gen DiffTime -> Gen DNSTimeout
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen DiffTime
genDiffTime Integer
110 Integer
300
shrink :: DNSTimeout -> [DNSTimeout]
shrink (DNSTimeout DiffTime
delta) =
[ DiffTime -> DNSTimeout
DNSTimeout (Ratio Integer -> DiffTime
forall a. Fractional a => Ratio Integer -> a
fromRational Ratio Integer
delta')
| Ratio Integer
delta' <- Ratio Integer -> [Ratio Integer]
forall a. Arbitrary a => a -> [a]
shrink (DiffTime -> Ratio Integer
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
delta)
, Ratio Integer
delta' Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Ratio Integer
110
]
newtype DNSLookupDelay = DNSLookupDelay { DNSLookupDelay -> DiffTime
getDNSLookupDelay :: DiffTime }
deriving Int -> DNSLookupDelay -> ShowS
[DNSLookupDelay] -> ShowS
DNSLookupDelay -> [Char]
(Int -> DNSLookupDelay -> ShowS)
-> (DNSLookupDelay -> [Char])
-> ([DNSLookupDelay] -> ShowS)
-> Show DNSLookupDelay
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DNSLookupDelay -> ShowS
showsPrec :: Int -> DNSLookupDelay -> ShowS
$cshow :: DNSLookupDelay -> [Char]
show :: DNSLookupDelay -> [Char]
$cshowList :: [DNSLookupDelay] -> ShowS
showList :: [DNSLookupDelay] -> ShowS
Show
instance Arbitrary DNSLookupDelay where
arbitrary :: Gen DNSLookupDelay
arbitrary = DiffTime -> DNSLookupDelay
DNSLookupDelay (DiffTime -> DNSLookupDelay) -> Gen DiffTime -> Gen DNSLookupDelay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen DiffTime
genDiffTime Integer
20 Integer
120
shrink :: DNSLookupDelay -> [DNSLookupDelay]
shrink (DNSLookupDelay DiffTime
delta) =
[ DiffTime -> DNSLookupDelay
DNSLookupDelay (Ratio Integer -> DiffTime
forall a. Fractional a => Ratio Integer -> a
fromRational Ratio Integer
delta')
| Ratio Integer
delta' <- Ratio Integer -> [Ratio Integer]
forall a. Arbitrary a => a -> [a]
shrink (DiffTime -> Ratio Integer
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
delta)
, Ratio Integer
delta' Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Ratio Integer
20
]
mockDNSActions :: forall exception m.
( MonadDelay m
, MonadTimer m
)
=> StrictTVar m (Map Domain [(IP, TTL)])
-> StrictTVar m (Script DNSTimeout)
-> StrictTVar m (Script DNSLookupDelay)
-> DNSActions () exception m
mockDNSActions :: forall exception (m :: * -> *).
(MonadDelay m, MonadTimer m) =>
StrictTVar m (Map Domain [(IP, Word32)])
-> StrictTVar m (Script DNSTimeout)
-> StrictTVar m (Script DNSLookupDelay)
-> DNSActions () exception m
mockDNSActions StrictTVar m (Map Domain [(IP, Word32)])
dnsMapVar StrictTVar m (Script DNSTimeout)
dnsTimeoutScript StrictTVar m (Script DNSLookupDelay)
dnsLookupDelayScript =
DNSActions {
ResolvConf -> m (Resource m (Either (DNSorIOError exception) ()))
forall {m :: * -> *} {m :: * -> *} {p} {a}.
(Monad m, Applicative m) =>
p -> m (Resource m (Either a ()))
dnsResolverResource :: forall {m :: * -> *} {m :: * -> *} {p} {a}.
(Monad m, Applicative m) =>
p -> m (Resource m (Either a ()))
dnsResolverResource :: ResolvConf -> m (Resource m (Either (DNSorIOError exception) ()))
dnsResolverResource,
ResolvConf -> m (Resource m (Either (DNSorIOError exception) ()))
forall {m :: * -> *} {m :: * -> *} {p} {a}.
(Monad m, Applicative m) =>
p -> m (Resource m (Either a ()))
dnsAsyncResolverResource :: forall {m :: * -> *} {m :: * -> *} {p} {a}.
(Monad m, Applicative m) =>
p -> m (Resource m (Either a ()))
dnsAsyncResolverResource :: ResolvConf -> m (Resource m (Either (DNSorIOError exception) ()))
dnsAsyncResolverResource,
ResolvConf -> () -> Domain -> m ([DNSError], [(IP, Word32)])
forall resolvConf resolver.
resolvConf -> resolver -> Domain -> m ([DNSError], [(IP, Word32)])
dnsLookupWithTTL :: forall resolvConf resolver.
resolvConf -> resolver -> Domain -> m ([DNSError], [(IP, Word32)])
dnsLookupWithTTL :: ResolvConf -> () -> Domain -> m ([DNSError], [(IP, Word32)])
dnsLookupWithTTL
}
where
dnsResolverResource :: p -> m (Resource m (Either a ()))
dnsResolverResource p
_ = Resource m (Either a ()) -> m (Resource m (Either a ()))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either a ()
forall a b. b -> Either a b
Right (() -> Either a ()) -> Resource m () -> Resource m (Either a ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> () -> Resource m ()
forall (m :: * -> *) a. Applicative m => a -> Resource m a
constantResource ())
dnsAsyncResolverResource :: p -> m (Resource m (Either a ()))
dnsAsyncResolverResource p
_ = Resource m (Either a ()) -> m (Resource m (Either a ()))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either a ()
forall a b. b -> Either a b
Right (() -> Either a ()) -> Resource m () -> Resource m (Either a ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> () -> Resource m ()
forall (m :: * -> *) a. Applicative m => a -> Resource m a
constantResource ())
dnsLookupWithTTL :: resolvConf
-> resolver
-> Domain
-> m ([DNSError], [(IP, TTL)])
dnsLookupWithTTL :: forall resolvConf resolver.
resolvConf -> resolver -> Domain -> m ([DNSError], [(IP, Word32)])
dnsLookupWithTTL resolvConf
_ resolver
_ Domain
domain = do
dnsMap <- StrictTVar m (Map Domain [(IP, Word32)])
-> m (Map Domain [(IP, Word32)])
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (Map Domain [(IP, Word32)])
dnsMapVar
DNSTimeout dnsTimeout <- stepScript' dnsTimeoutScript
DNSLookupDelay dnsLookupDelay <- stepScript' dnsLookupDelayScript
dnsLookup <-
MonadTimer.timeout dnsTimeout $ do
MonadTimer.threadDelay dnsLookupDelay
case Map.lookup domain dnsMap of
Maybe [(IP, Word32)]
Nothing -> Either DNSError [(IP, Word32)]
-> m (Either DNSError [(IP, Word32)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DNSError -> Either DNSError [(IP, Word32)]
forall a b. a -> Either a b
Left DNSError
NameError)
Just [(IP, Word32)]
x -> Either DNSError [(IP, Word32)]
-> m (Either DNSError [(IP, Word32)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(IP, Word32)] -> Either DNSError [(IP, Word32)]
forall a b. b -> Either a b
Right [(IP, Word32)]
x)
case dnsLookup of
Maybe (Either DNSError [(IP, Word32)])
Nothing -> ([DNSError], [(IP, Word32)]) -> m ([DNSError], [(IP, Word32)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DNSError
TimeoutExpired], [])
Just (Left DNSError
e) -> ([DNSError], [(IP, Word32)]) -> m ([DNSError], [(IP, Word32)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DNSError
e], [])
Just (Right [(IP, Word32)]
a) -> ([DNSError], [(IP, Word32)]) -> m ([DNSError], [(IP, Word32)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [(IP, Word32)]
a)
mockLocalRootPeersProvider :: forall m.
( Alternative (STM m)
, MonadAsync m
, MonadDelay m
, MonadThrow m
, MonadTimer m
, MonadTraceSTM m
, MonadLabelledSTM m
)
=> Tracer m (TraceLocalRootPeers SockAddr Failure)
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> m ()
mockLocalRootPeersProvider :: forall (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
MonadTimer m, MonadTraceSTM m, MonadLabelledSTM m) =>
Tracer m (TraceLocalRootPeers SockAddr Failure)
-> MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> m ()
mockLocalRootPeersProvider Tracer m (TraceLocalRootPeers SockAddr Failure)
tracer (MockRoots [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
localRootPeers Script (Map Domain [(IP, Word32)])
dnsMapScript Map RelayAccessPoint PeerAdvertise
_ Script (Map Domain [(IP, Word32)])
_)
Script DNSTimeout
dnsTimeoutScript Script DNSLookupDelay
dnsLookupDelayScript = do
dnsMapScriptVar <- Script (Map Domain [(IP, Word32)])
-> m (StrictTVar m (Script (Map Domain [(IP, Word32)])))
forall (m :: * -> *) a.
MonadSTM m =>
Script a -> m (StrictTVar m (Script a))
initScript' Script (Map Domain [(IP, Word32)])
dnsMapScript
dnsMap <- stepScript' dnsMapScriptVar
dnsMapVar <- newTVarIO dnsMap
dnsTimeoutScriptVar <- initScript' dnsTimeoutScript
dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
localRootPeersVar <- newTVarIO localRootPeers
resultVar <- newTVarIO mempty
_ <- labelTVarIO resultVar "resultVar"
_ <- traceTVarIO resultVar
(\Maybe
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
_ [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
a -> TraceValue -> InspectMonad m TraceValue
forall a. a -> InspectMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TraceValue -> InspectMonad m TraceValue)
-> TraceValue -> InspectMonad m TraceValue
forall a b. (a -> b) -> a -> b
$ TestTraceEvent -> TraceValue
forall tr. Typeable tr => tr -> TraceValue
TraceDynamic ([(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
-> TestTraceEvent
LocalRootPeersResults [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
a))
withAsync (updateDNSMap dnsMapScriptVar dnsMapVar) $ \Async m Void
_ -> do
m (Maybe Void) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe Void) -> m ()) -> m (Maybe Void) -> m ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> m Void -> m (Maybe Void)
forall a. DiffTime -> m a -> m (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
MonadTimer.timeout DiffTime
3600 (m Void -> m (Maybe Void)) -> m Void -> m (Maybe Void)
forall a b. (a -> b) -> a -> b
$
Tracer m (TraceLocalRootPeers SockAddr Failure)
-> (IP -> PortNumber -> SockAddr)
-> ResolvConf
-> DNSActions () Failure m
-> STM
m
[(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
-> StrictTVar
m
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
-> m Void
forall (m :: * -> *) peerAddr resolver exception.
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
Ord peerAddr) =>
Tracer m (TraceLocalRootPeers peerAddr exception)
-> (IP -> PortNumber -> peerAddr)
-> ResolvConf
-> DNSActions resolver exception m
-> STM
m
[(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
-> StrictTVar
m
[(HotValency, WarmValency,
Map peerAddr (PeerAdvertise, PeerTrustable))]
-> m Void
localRootPeersProvider Tracer m (TraceLocalRootPeers SockAddr Failure)
tracer
(((IP, PortNumber) -> SockAddr) -> IP -> PortNumber -> SockAddr
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (IP, PortNumber) -> SockAddr
toSockAddr)
ResolvConf
DNSResolver.defaultResolvConf
(StrictTVar m (Map Domain [(IP, Word32)])
-> StrictTVar m (Script DNSTimeout)
-> StrictTVar m (Script DNSLookupDelay)
-> DNSActions () Failure m
forall exception (m :: * -> *).
(MonadDelay m, MonadTimer m) =>
StrictTVar m (Map Domain [(IP, Word32)])
-> StrictTVar m (Script DNSTimeout)
-> StrictTVar m (Script DNSLookupDelay)
-> DNSActions () exception m
mockDNSActions StrictTVar m (Map Domain [(IP, Word32)])
dnsMapVar
StrictTVar m (Script DNSTimeout)
dnsTimeoutScriptVar
StrictTVar m (Script DNSLookupDelay)
dnsLookupDelayScriptVar)
(StrictTVar
m
[(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
-> STM
m
[(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
m
[(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
localRootPeersVar)
StrictTVar
m
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
resultVar
STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar
m
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
-> STM
m
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
m
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
resultVar STM
m
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
-> ([(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
-> STM m ())
-> STM m ()
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= StrictTVar
m
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
-> [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar
m
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
resultVar
where
updateDNSMap :: StrictTVar m (Script (Map Domain [(IP, TTL)]))
-> StrictTVar m (Map Domain [(IP, TTL)])
-> m Void
updateDNSMap :: StrictTVar m (Script (Map Domain [(IP, Word32)]))
-> StrictTVar m (Map Domain [(IP, Word32)]) -> m Void
updateDNSMap StrictTVar m (Script (Map Domain [(IP, Word32)]))
dnsMapScriptVar StrictTVar m (Map Domain [(IP, Word32)])
dnsMapVar =
m () -> m Void
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m Void) -> m () -> m Void
forall a b. (a -> b) -> a -> b
$ do
DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
10
dnsMap <- StrictTVar m (Script (Map Domain [(IP, Word32)]))
-> m (Map Domain [(IP, Word32)])
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m (Script a) -> m a
stepScript' StrictTVar m (Script (Map Domain [(IP, Word32)]))
dnsMapScriptVar
atomically (writeTVar dnsMapVar dnsMap)
mockPublicRootPeersProvider :: forall m a.
( MonadAsync m
, MonadDelay m
, MonadThrow m
, MonadTimer m
)
=> Tracer m TracePublicRootPeers
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> ((Int -> m (Map SockAddr PeerAdvertise, DiffTime)) -> m a)
-> m ()
mockPublicRootPeersProvider :: forall (m :: * -> *) a.
(MonadAsync m, MonadDelay m, MonadThrow m, MonadTimer m) =>
Tracer m TracePublicRootPeers
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> ((Int -> m (Map SockAddr PeerAdvertise, DiffTime)) -> m a)
-> m ()
mockPublicRootPeersProvider Tracer m TracePublicRootPeers
tracer (MockRoots [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
_ Script (Map Domain [(IP, Word32)])
_ Map RelayAccessPoint PeerAdvertise
publicRootPeers Script (Map Domain [(IP, Word32)])
dnsMapScript)
Script DNSTimeout
dnsTimeoutScript Script DNSLookupDelay
dnsLookupDelayScript (Int -> m (Map SockAddr PeerAdvertise, DiffTime)) -> m a
action = do
dnsMapScriptVar <- Script (Map Domain [(IP, Word32)])
-> m (StrictTVar m (Script (Map Domain [(IP, Word32)])))
forall (m :: * -> *) a.
MonadSTM m =>
Script a -> m (StrictTVar m (Script a))
initScript' Script (Map Domain [(IP, Word32)])
dnsMapScript
dnsMap <- stepScript' dnsMapScriptVar
dnsMapVar <- newTVarIO dnsMap
dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore
dnsTimeoutScriptVar <- initScript' dnsTimeoutScript
dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
publicRootPeersVar <- newTVarIO publicRootPeers
replicateM_ 5 $ do
dnsMap' <- stepScript' dnsMapScriptVar
atomically (writeTVar dnsMapVar dnsMap')
publicRootPeersProvider tracer
(curry toSockAddr)
dnsSemaphore
DNSResolver.defaultResolvConf
(readTVar publicRootPeersVar)
(mockDNSActions @Failure
dnsMapVar
dnsTimeoutScriptVar
dnsLookupDelayScriptVar)
action
mockResolveLedgerPeers :: ( MonadAsync m
, MonadDelay m
, MonadThrow m
, MonadTimer m
)
=> Tracer m TraceLedgerPeers
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> m (Map DomainAccessPoint (Set SockAddr))
mockResolveLedgerPeers :: forall (m :: * -> *).
(MonadAsync m, MonadDelay m, MonadThrow m, MonadTimer m) =>
Tracer m TraceLedgerPeers
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> m (Map DomainAccessPoint (Set SockAddr))
mockResolveLedgerPeers Tracer m TraceLedgerPeers
tracer (MockRoots [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
_ Script (Map Domain [(IP, Word32)])
_ Map RelayAccessPoint PeerAdvertise
publicRootPeers Script (Map Domain [(IP, Word32)])
dnsMapScript)
Script DNSTimeout
dnsTimeoutScript Script DNSLookupDelay
dnsLookupDelayScript = do
dnsMapScriptVar <- Script (Map Domain [(IP, Word32)])
-> m (StrictTVar m (Script (Map Domain [(IP, Word32)])))
forall (m :: * -> *) a.
MonadSTM m =>
Script a -> m (StrictTVar m (Script a))
initScript' Script (Map Domain [(IP, Word32)])
dnsMapScript
dnsMap <- stepScript' dnsMapScriptVar
dnsMapVar <- newTVarIO dnsMap
dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore
dnsTimeoutScriptVar <- initScript' dnsTimeoutScript
dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
resolveLedgerPeers tracer
(curry toSockAddr)
dnsSemaphore
DNSResolver.defaultResolvConf
(mockDNSActions @Failure dnsMapVar
dnsTimeoutScriptVar
dnsLookupDelayScriptVar)
[ domain
| (RelayDomainAccessPoint domain, _)
<- Map.assocs publicRootPeers ]
data TestTraceEvent = RootPeerDNSLocal (TraceLocalRootPeers SockAddr Failure)
| LocalRootPeersResults [(HotValency, WarmValency, Map SockAddr (PeerAdvertise, PeerTrustable))]
| RootPeerDNSPublic TracePublicRootPeers
deriving (Int -> TestTraceEvent -> ShowS
[TestTraceEvent] -> ShowS
TestTraceEvent -> [Char]
(Int -> TestTraceEvent -> ShowS)
-> (TestTraceEvent -> [Char])
-> ([TestTraceEvent] -> ShowS)
-> Show TestTraceEvent
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestTraceEvent -> ShowS
showsPrec :: Int -> TestTraceEvent -> ShowS
$cshow :: TestTraceEvent -> [Char]
show :: TestTraceEvent -> [Char]
$cshowList :: [TestTraceEvent] -> ShowS
showList :: [TestTraceEvent] -> ShowS
Show, Typeable)
tracerTraceLocalRoots :: Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
tracerTraceLocalRoots :: forall s. Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
tracerTraceLocalRoots = (TraceLocalRootPeers SockAddr Failure -> TestTraceEvent)
-> Tracer (IOSim s) TestTraceEvent
-> Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
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 TraceLocalRootPeers SockAddr Failure -> TestTraceEvent
RootPeerDNSLocal Tracer (IOSim s) TestTraceEvent
forall s. Tracer (IOSim s) TestTraceEvent
tracerTestTraceEvent
tracerTracePublicRoots :: Tracer (IOSim s) TracePublicRootPeers
tracerTracePublicRoots :: forall s. Tracer (IOSim s) TracePublicRootPeers
tracerTracePublicRoots = (TracePublicRootPeers -> TestTraceEvent)
-> Tracer (IOSim s) TestTraceEvent
-> Tracer (IOSim s) TracePublicRootPeers
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 TracePublicRootPeers -> TestTraceEvent
RootPeerDNSPublic 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
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
selectRootPeerDNSTraceEvents :: SimTrace a -> [(Time, TestTraceEvent)]
selectRootPeerDNSTraceEvents :: forall a. SimTrace a -> [(Time, TestTraceEvent)]
selectRootPeerDNSTraceEvents = 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 [Char]
_ (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 [Char]
_ (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 [Char]
_ SimEventType
_ SimTrace a
trace) = SimTrace a -> [(Time, b)]
go SimTrace a
trace
go (SimPORTrace Time
_ IOSimThreadId
_ Int
_ Maybe [Char]
_ SimEventType
_ 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]
_) = []
go TraceMainReturn {} = []
go (TraceInternalError [Char]
e) = [Char] -> [(Time, b)]
forall a. HasCallStack => [Char] -> a
error ([Char]
"IOSim: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
e)
go SimTrace a
TraceLoop = [Char] -> [(Time, b)]
forall a. HasCallStack => [Char] -> a
error [Char]
"IOSimPOR step time limit exceeded"
selectLocalRootPeersEvents :: [(Time, TestTraceEvent)]
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
selectLocalRootPeersEvents :: [(Time, TestTraceEvent)]
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
selectLocalRootPeersEvents [(Time, TestTraceEvent)]
trace = [ (Time
t, TraceLocalRootPeers SockAddr Failure
e) | (Time
t, RootPeerDNSLocal TraceLocalRootPeers SockAddr Failure
e) <- [(Time, TestTraceEvent)]
trace ]
selectLocalRootPeersResults :: [(Time, TestTraceEvent)]
-> [(Time, [(HotValency, WarmValency, Map SockAddr (PeerAdvertise, PeerTrustable))])]
selectLocalRootPeersResults :: [(Time, TestTraceEvent)]
-> [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
selectLocalRootPeersResults [(Time, TestTraceEvent)]
trace = [ (Time
t, [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
r) | (Time
t, LocalRootPeersResults [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
r) <- [(Time, TestTraceEvent)]
trace ]
selectLocalRootGroupsEvents :: [(Time, TraceLocalRootPeers SockAddr Failure)]
-> [(Time, [( HotValency
, WarmValency
, Map SockAddr (PeerAdvertise, PeerTrustable))])]
selectLocalRootGroupsEvents :: [(Time, TraceLocalRootPeers SockAddr Failure)]
-> [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
selectLocalRootGroupsEvents [(Time, TraceLocalRootPeers SockAddr Failure)]
trace = [ (Time
t, [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
e) | (Time
t, TraceLocalRootGroups [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
e) <- [(Time, TraceLocalRootPeers SockAddr Failure)]
trace ]
selectLocalRootResultEvents :: [(Time, TraceLocalRootPeers SockAddr Failure)]
-> [(Time, (Domain, [IP]))]
selectLocalRootResultEvents :: [(Time, TraceLocalRootPeers SockAddr Failure)]
-> [(Time, (Domain, [IP]))]
selectLocalRootResultEvents [(Time, TraceLocalRootPeers SockAddr Failure)]
trace = [ (Time
t, (Domain
domain, ((IP, Word32) -> IP) -> [(IP, Word32)] -> [IP]
forall a b. (a -> b) -> [a] -> [b]
map (IP, Word32) -> IP
forall a b. (a, b) -> a
fst [(IP, Word32)]
r))
| (Time
t, TraceLocalRootResult (DomainAccessPoint Domain
domain PortNumber
_) [(IP, Word32)]
r) <- [(Time, TraceLocalRootPeers SockAddr Failure)]
trace ]
selectPublicRootPeersEvents :: [(Time, TestTraceEvent)]
-> [(Time, TracePublicRootPeers)]
selectPublicRootPeersEvents :: [(Time, TestTraceEvent)] -> [(Time, TracePublicRootPeers)]
selectPublicRootPeersEvents [(Time, TestTraceEvent)]
trace = [ (Time
t, TracePublicRootPeers
e) | (Time
t, RootPeerDNSPublic TracePublicRootPeers
e) <- [(Time, TestTraceEvent)]
trace ]
selectPublicRootFailureEvents :: [(Time, TracePublicRootPeers)]
-> [(Time, Domain)]
selectPublicRootFailureEvents :: [(Time, TracePublicRootPeers)] -> [(Time, Domain)]
selectPublicRootFailureEvents [(Time, TracePublicRootPeers)]
trace = [ (Time
t, Domain
domain)
| (Time
t, TracePublicRootFailure Domain
domain DNSError
_) <- [(Time, TracePublicRootPeers)]
trace ]
selectPublicRootResultEvents :: [(Time, TracePublicRootPeers)]
-> [(Time, (Domain, [IP]))]
selectPublicRootResultEvents :: [(Time, TracePublicRootPeers)] -> [(Time, (Domain, [IP]))]
selectPublicRootResultEvents [(Time, TracePublicRootPeers)]
trace = [ (Time
t, (Domain
domain, ((IP, Word32) -> IP) -> [(IP, Word32)] -> [IP]
forall a b. (a -> b) -> [a] -> [b]
map (IP, Word32) -> IP
forall a b. (a, b) -> a
fst [(IP, Word32)]
r))
| (Time
t, TracePublicRootResult Domain
domain [(IP, Word32)]
r) <- [(Time, TracePublicRootPeers)]
trace ]
prop_local_preservesIPs :: MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> Property
prop_local_preservesIPs :: MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> Property
prop_local_preservesIPs mockRoots :: MockRoots
mockRoots@(MockRoots [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
localRoots Script (Map Domain [(IP, Word32)])
_ Map RelayAccessPoint PeerAdvertise
_ Script (Map Domain [(IP, Word32)])
_)
Script DNSTimeout
dnsTimeoutScript
Script DNSLookupDelay
dnsLookupDelayScript =
let tr :: [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
tr = [(Time, TestTraceEvent)]
-> [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
selectLocalRootPeersResults
([(Time, TestTraceEvent)]
-> [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])])
-> [(Time, TestTraceEvent)]
-> [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
forall a b. (a -> b) -> a -> b
$ SimTrace () -> [(Time, TestTraceEvent)]
forall a. SimTrace a -> [(Time, TestTraceEvent)]
selectRootPeerDNSTraceEvents
(SimTrace () -> [(Time, TestTraceEvent)])
-> SimTrace () -> [(Time, TestTraceEvent)]
forall a b. (a -> b) -> a -> b
$ (forall s. IOSim s ()) -> SimTrace ()
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace
((forall s. IOSim s ()) -> SimTrace ())
-> (forall s. IOSim s ()) -> SimTrace ()
forall a b. (a -> b) -> a -> b
$ Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> IOSim s ()
forall (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
MonadTimer m, MonadTraceSTM m, MonadLabelledSTM m) =>
Tracer m (TraceLocalRootPeers SockAddr Failure)
-> MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> m ()
mockLocalRootPeersProvider Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
forall s. Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
tracerTraceLocalRoots
MockRoots
mockRoots
Script DNSTimeout
dnsTimeoutScript
Script DNSLookupDelay
dnsLookupDelayScript
in [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ ((Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])
-> [Char])
-> [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
-> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])
-> [Char]
forall a. Show a => a -> [Char]
show [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
tr)
(Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> Property -> Property
forall prop. Testable prop => Bool -> [Char] -> prop -> Property
classify ([(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
tr Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) [Char]
"Actually testing something"
(Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
-> Property
checkAll [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
tr
where
checkAll :: [(Time, [( HotValency
, WarmValency
, Map SockAddr (PeerAdvertise, PeerTrustable))])]
-> Property
checkAll :: [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
-> Property
checkAll [] = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
checkAll ((Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])
x:[(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
t) =
let thrd :: (a, b, c) -> c
thrd (a
_, b
_, c
c) = c
c
localRootAddresses :: [(a, b, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
-> Set SockAddr
localRootAddresses :: forall a b.
[(a, b, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
-> Set SockAddr
localRootAddresses [(a, b, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
lrp =
[SockAddr] -> Set SockAddr
forall a. Ord a => [a] -> Set a
Set.fromList
[ (IP, PortNumber) -> SockAddr
toSockAddr (IP
ip, PortNumber
port)
| (a
_, b
_, Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
m) <- [(a, b, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
lrp
, RelayAccessAddress IP
ip PortNumber
port <- Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
-> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
m
]
localGroupEventsAddresses :: (a, [( HotValency
, WarmValency
, Map SockAddr (PeerAdvertise, PeerTrustable))])
-> Set SockAddr
localGroupEventsAddresses :: forall a.
(a,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])
-> Set SockAddr
localGroupEventsAddresses (a
_, [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
s) =
[SockAddr] -> Set SockAddr
forall a. Ord a => [a] -> Set a
Set.fromList
([SockAddr] -> Set SockAddr) -> [SockAddr] -> Set SockAddr
forall a b. (a -> b) -> a -> b
$ ((HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))
-> [SockAddr])
-> [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
-> [SockAddr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Map SockAddr (PeerAdvertise, PeerTrustable) -> [SockAddr]
forall k a. Map k a -> [k]
Map.keys (Map SockAddr (PeerAdvertise, PeerTrustable) -> [SockAddr])
-> ((HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))
-> Map SockAddr (PeerAdvertise, PeerTrustable))
-> (HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))
-> [SockAddr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))
-> Map SockAddr (PeerAdvertise, PeerTrustable)
forall {a} {b} {c}. (a, b, c) -> c
thrd)
([(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
-> [SockAddr])
-> [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
-> [SockAddr]
forall a b. (a -> b) -> a -> b
$ [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
s
localRootAddressesSet :: Set SockAddr
localRootAddressesSet = [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
-> Set SockAddr
forall a b.
[(a, b, Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
-> Set SockAddr
localRootAddresses [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
localRoots
localGroupEventsAddressesSet :: Set SockAddr
localGroupEventsAddressesSet = (Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])
-> Set SockAddr
forall a.
(a,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])
-> Set SockAddr
localGroupEventsAddresses (Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])
x
in [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample (Set SockAddr -> [Char]
forall a. Show a => a -> [Char]
show Set SockAddr
localRootAddressesSet [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is not subset of "
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Set SockAddr -> [Char]
forall a. Show a => a -> [Char]
show Set SockAddr
localGroupEventsAddressesSet)
(Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Set SockAddr
localRootAddressesSet Set SockAddr -> Set SockAddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set SockAddr
localGroupEventsAddressesSet
Bool -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
-> Property
checkAll [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
t
prop_local_preservesGroupNumberAndTargets :: MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> Property
prop_local_preservesGroupNumberAndTargets :: MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> Property
prop_local_preservesGroupNumberAndTargets mockRoots :: MockRoots
mockRoots@(MockRoots [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
lrp Script (Map Domain [(IP, Word32)])
_ Map RelayAccessPoint PeerAdvertise
_ Script (Map Domain [(IP, Word32)])
_)
Script DNSTimeout
dnsTimeoutScript
Script DNSLookupDelay
dnsLookupDelayScript =
let tr :: [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
tr = [(Time, TestTraceEvent)]
-> [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
selectLocalRootPeersResults
([(Time, TestTraceEvent)]
-> [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])])
-> [(Time, TestTraceEvent)]
-> [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
forall a b. (a -> b) -> a -> b
$ SimTrace () -> [(Time, TestTraceEvent)]
forall a. SimTrace a -> [(Time, TestTraceEvent)]
selectRootPeerDNSTraceEvents
(SimTrace () -> [(Time, TestTraceEvent)])
-> SimTrace () -> [(Time, TestTraceEvent)]
forall a b. (a -> b) -> a -> b
$ (forall s. IOSim s ()) -> SimTrace ()
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace
((forall s. IOSim s ()) -> SimTrace ())
-> (forall s. IOSim s ()) -> SimTrace ()
forall a b. (a -> b) -> a -> b
$ Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> IOSim s ()
forall (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
MonadTimer m, MonadTraceSTM m, MonadLabelledSTM m) =>
Tracer m (TraceLocalRootPeers SockAddr Failure)
-> MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> m ()
mockLocalRootPeersProvider Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
forall s. Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
tracerTraceLocalRoots
MockRoots
mockRoots
Script DNSTimeout
dnsTimeoutScript
Script DNSLookupDelay
dnsLookupDelayScript
preservesGroupNumber :: Bool
preservesGroupNumber = ((Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])
-> Bool)
-> [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
lrp) (Int -> Bool)
-> ((Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])
-> Int)
-> (Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
-> Int)
-> ((Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])
-> [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])
-> (Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])
-> [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
forall a b. (a, b) -> b
snd) [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
tr
preservesTargets :: Bool
preservesTargets = ([((HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable)),
(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable)))]
-> Bool)
-> [[((HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable)),
(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable)))]]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((((HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable)),
(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable)))
-> Bool)
-> [((HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable)),
(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable)))]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\((HotValency
a, WarmValency
b, Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
_), (HotValency
a', WarmValency
b', Map SockAddr (PeerAdvertise, PeerTrustable)
_)) -> HotValency
a HotValency -> HotValency -> Bool
forall a. Eq a => a -> a -> Bool
== HotValency
a' Bool -> Bool -> Bool
&& WarmValency
b WarmValency -> WarmValency -> Bool
forall a. Eq a => a -> a -> Bool
== WarmValency
b'))
[ [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
-> [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
-> [((HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable)),
(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
lrp [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
r | [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
r <- ((Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])
-> [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])
-> [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
-> [[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]]
forall a b. (a -> b) -> [a] -> [b]
map (Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])
-> [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
forall a b. (a, b) -> b
snd [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
tr ]
in [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
label (Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Char]) -> Int -> [Char]
forall a b. (a -> b) -> a -> b
$ [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Time,
[(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))])]
tr Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
100 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
100) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
Bool
preservesGroupNumber Bool -> Bool -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Bool
preservesTargets
prop_local_resolvesDomainsCorrectly :: MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> Property
prop_local_resolvesDomainsCorrectly :: MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> Property
prop_local_resolvesDomainsCorrectly mockRoots :: MockRoots
mockRoots@(MockRoots [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
localRoots Script (Map Domain [(IP, Word32)])
lDNSMap Map RelayAccessPoint PeerAdvertise
_ Script (Map Domain [(IP, Word32)])
_)
Script DNSTimeout
dnsTimeoutScript
Script DNSLookupDelay
dnsLookupDelayScript =
let mockRoots' :: MockRoots
mockRoots' =
MockRoots
mockRoots { mockLocalRootPeersDNSMap =
singletonScript (scriptHead lDNSMap)
}
tr :: [(Time, TraceLocalRootPeers SockAddr Failure)]
tr = [(Time, TestTraceEvent)]
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
selectLocalRootPeersEvents
([(Time, TestTraceEvent)]
-> [(Time, TraceLocalRootPeers SockAddr Failure)])
-> [(Time, TestTraceEvent)]
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
forall a b. (a -> b) -> a -> b
$ SimTrace () -> [(Time, TestTraceEvent)]
forall a. SimTrace a -> [(Time, TestTraceEvent)]
selectRootPeerDNSTraceEvents
(SimTrace () -> [(Time, TestTraceEvent)])
-> SimTrace () -> [(Time, TestTraceEvent)]
forall a b. (a -> b) -> a -> b
$ (forall s. IOSim s ()) -> SimTrace ()
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace
((forall s. IOSim s ()) -> SimTrace ())
-> (forall s. IOSim s ()) -> SimTrace ()
forall a b. (a -> b) -> a -> b
$ Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> IOSim s ()
forall (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
MonadTimer m, MonadTraceSTM m, MonadLabelledSTM m) =>
Tracer m (TraceLocalRootPeers SockAddr Failure)
-> MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> m ()
mockLocalRootPeersProvider Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
forall s. Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
tracerTraceLocalRoots
MockRoots
mockRoots'
Script DNSTimeout
dnsTimeoutScript
Script DNSLookupDelay
dnsLookupDelayScript
localRootDomains :: Set Domain
localRootDomains :: Set Domain
localRootDomains =
[Domain] -> Set Domain
forall a. Ord a => [a] -> Set a
Set.fromList
[ Domain
domain
| (HotValency
_, WarmValency
_, Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
m) <- [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
localRoots
, RelayAccessDomain Domain
domain PortNumber
_ <- Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
-> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
m
]
resultMap :: Set Domain
resultMap :: Set Domain
resultMap = [Domain] -> Set Domain
forall a. Ord a => [a] -> Set a
Set.fromList
([Domain] -> Set Domain) -> [Domain] -> Set Domain
forall a b. (a -> b) -> a -> b
$ ((Time, (Domain, [IP])) -> Domain)
-> [(Time, (Domain, [IP]))] -> [Domain]
forall a b. (a -> b) -> [a] -> [b]
map ((Domain, [IP]) -> Domain
forall a b. (a, b) -> a
fst ((Domain, [IP]) -> Domain)
-> ((Time, (Domain, [IP])) -> (Domain, [IP]))
-> (Time, (Domain, [IP]))
-> Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, (Domain, [IP])) -> (Domain, [IP])
forall a b. (a, b) -> b
snd)
([(Time, (Domain, [IP]))] -> [Domain])
-> [(Time, (Domain, [IP]))] -> [Domain]
forall a b. (a -> b) -> a -> b
$ [(Time, TraceLocalRootPeers SockAddr Failure)]
-> [(Time, (Domain, [IP]))]
selectLocalRootResultEvents
([(Time, TraceLocalRootPeers SockAddr Failure)]
-> [(Time, (Domain, [IP]))])
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
-> [(Time, (Domain, [IP]))]
forall a b. (a -> b) -> a -> b
$ [(Time, TraceLocalRootPeers SockAddr Failure)]
tr
maxResultMap :: Script (Set Domain)
maxResultMap :: Script (Set Domain)
maxResultMap = Map Domain [(IP, Word32)] -> Set Domain
forall k a. Map k a -> Set k
Map.keysSet
(Map Domain [(IP, Word32)] -> Set Domain)
-> (Map Domain [(IP, Word32)] -> Map Domain [(IP, Word32)])
-> Map Domain [(IP, Word32)]
-> Set Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Domain [(IP, Word32)]
-> Set Domain -> Map Domain [(IP, Word32)]
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set Domain
localRootDomains)
(Map Domain [(IP, Word32)] -> Set Domain)
-> Script (Map Domain [(IP, Word32)]) -> Script (Set Domain)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Script (Map Domain [(IP, Word32)])
lDNSMap
allTriedDomains :: Set Domain
allTriedDomains :: Set Domain
allTriedDomains
= [Domain] -> Set Domain
forall a. Ord a => [a] -> Set a
Set.fromList
([Domain] -> Set Domain) -> [Domain] -> Set Domain
forall a b. (a -> b) -> a -> b
$ [Maybe Domain] -> [Domain]
forall a. [Maybe a] -> [a]
catMaybes
[ Maybe Domain
mbDomain
| (Time
_, TraceLocalRootPeers SockAddr Failure
ev) <- [(Time, TraceLocalRootPeers SockAddr Failure)]
tr
, let mbDomain :: Maybe Domain
mbDomain = case TraceLocalRootPeers SockAddr Failure
ev of
TraceLocalRootResult (DomainAccessPoint Domain
domain PortNumber
_) [(IP, Word32)]
_ -> Domain -> Maybe Domain
forall a. a -> Maybe a
Just Domain
domain
TraceLocalRootFailure (DomainAccessPoint Domain
domain PortNumber
_) DNSorIOError Failure
_ -> Domain -> Maybe Domain
forall a. a -> Maybe a
Just Domain
domain
TraceLocalRootError (DomainAccessPoint Domain
_domain PortNumber
_) SomeException
_ -> Maybe Domain
forall a. Maybe a
Nothing
TraceLocalRootPeers SockAddr Failure
_ -> Maybe Domain
forall a. Maybe a
Nothing
]
in
Set Domain
localRootDomains Set Domain -> Set Domain -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Set Domain
allTriedDomains
Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. (Set Domain -> Property -> Property)
-> Property -> Script (Set Domain) -> Property
forall a b. (a -> b -> b) -> b -> Script a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Set Domain
rm Property
r -> [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample (Set Domain -> [Char]
forall a. Show a => a -> [Char]
show Set Domain
resultMap [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is subset of "
[Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Set Domain -> [Char]
forall a. Show a => a -> [Char]
show Set Domain
rm)
(Set Domain
resultMap Set Domain -> Set Domain -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set Domain
rm)
Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Property
r
)
(Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True)
Script (Set Domain)
maxResultMap
prop_local_updatesDomainsCorrectly :: MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> Property
prop_local_updatesDomainsCorrectly :: MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> Property
prop_local_updatesDomainsCorrectly mockRoots :: MockRoots
mockRoots@(MockRoots [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
lrp Script (Map Domain [(IP, Word32)])
_ Map RelayAccessPoint PeerAdvertise
_ Script (Map Domain [(IP, Word32)])
_)
Script DNSTimeout
dnsTimeoutScript
Script DNSLookupDelay
dnsLookupDelayScript =
let tr :: [(Time, TraceLocalRootPeers SockAddr Failure)]
tr = [(Time, TestTraceEvent)]
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
selectLocalRootPeersEvents
([(Time, TestTraceEvent)]
-> [(Time, TraceLocalRootPeers SockAddr Failure)])
-> [(Time, TestTraceEvent)]
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
forall a b. (a -> b) -> a -> b
$ SimTrace () -> [(Time, TestTraceEvent)]
forall a. SimTrace a -> [(Time, TestTraceEvent)]
selectRootPeerDNSTraceEvents
(SimTrace () -> [(Time, TestTraceEvent)])
-> SimTrace () -> [(Time, TestTraceEvent)]
forall a b. (a -> b) -> a -> b
$ (forall s. IOSim s ()) -> SimTrace ()
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace
((forall s. IOSim s ()) -> SimTrace ())
-> (forall s. IOSim s ()) -> SimTrace ()
forall a b. (a -> b) -> a -> b
$ Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> IOSim s ()
forall (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
MonadTimer m, MonadTraceSTM m, MonadLabelledSTM m) =>
Tracer m (TraceLocalRootPeers SockAddr Failure)
-> MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> m ()
mockLocalRootPeersProvider Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
forall s. Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
tracerTraceLocalRoots
MockRoots
mockRoots
Script DNSTimeout
dnsTimeoutScript
Script DNSLookupDelay
dnsLookupDelayScript
r :: (Bool, (Time, TraceLocalRootPeers SockAddr Failure))
r = ((Bool, (Time, TraceLocalRootPeers SockAddr Failure))
-> (Time, TraceLocalRootPeers SockAddr Failure)
-> (Bool, (Time, TraceLocalRootPeers SockAddr Failure)))
-> (Bool, (Time, TraceLocalRootPeers SockAddr Failure))
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
-> (Bool, (Time, TraceLocalRootPeers SockAddr Failure))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (\(Bool
b, (Time
t, TraceLocalRootPeers SockAddr Failure
x)) (Time
t', TraceLocalRootPeers SockAddr Failure
y) ->
case (TraceLocalRootPeers SockAddr Failure
x, TraceLocalRootPeers SockAddr Failure
y) of
(TraceLocalRootGroups [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
lrpg, TraceLocalRootGroups [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
lrpg') ->
let
ipsAtIndex :: [SockAddr]
ipsAtIndex = Map SockAddr (PeerAdvertise, PeerTrustable) -> [SockAddr]
forall k a. Map k a -> [k]
Map.keys
(Map SockAddr (PeerAdvertise, PeerTrustable) -> [SockAddr])
-> Map SockAddr (PeerAdvertise, PeerTrustable) -> [SockAddr]
forall a b. (a -> b) -> a -> b
$ ((HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))
-> Map SockAddr (PeerAdvertise, PeerTrustable))
-> [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
-> Map SockAddr (PeerAdvertise, PeerTrustable)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))
-> Map SockAddr (PeerAdvertise, PeerTrustable)
forall {a} {b} {c}. (a, b, c) -> c
thrd [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
lrpg
ipsAtIndex' :: [SockAddr]
ipsAtIndex' = Map SockAddr (PeerAdvertise, PeerTrustable) -> [SockAddr]
forall k a. Map k a -> [k]
Map.keys
(Map SockAddr (PeerAdvertise, PeerTrustable) -> [SockAddr])
-> Map SockAddr (PeerAdvertise, PeerTrustable) -> [SockAddr]
forall a b. (a -> b) -> a -> b
$ ((HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))
-> Map SockAddr (PeerAdvertise, PeerTrustable))
-> [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
-> Map SockAddr (PeerAdvertise, PeerTrustable)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))
-> Map SockAddr (PeerAdvertise, PeerTrustable)
forall {a} {b} {c}. (a, b, c) -> c
thrd [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
lrpg'
arePreserved :: Bool
arePreserved = (SockAddr -> Bool) -> [SockAddr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (SockAddr -> [SockAddr] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SockAddr]
ipsAtIndex') [SockAddr]
ipsAtIndex
in (Bool
arePreserved Bool -> Bool -> Bool
&& Bool
b, (Time
t', TraceLocalRootPeers SockAddr Failure
y))
(TraceLocalRootResult DomainAccessPoint
da [(IP, Word32)]
res, TraceLocalRootGroups [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
lrpg) ->
let db :: [(Int,
(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable)))]
db = [Int]
-> [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
-> [(Int,
(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0,Int
1..] [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
lrp
index :: Int
index = ((Int,
(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable)))
-> Int -> Int)
-> Int
-> [(Int,
(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable)))]
-> Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Int
i, (HotValency
_, WarmValency
_, Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
m)) Int
prev ->
case RelayAccessPoint
-> Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
-> Maybe (PeerAdvertise, PeerTrustable)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (DomainAccessPoint -> RelayAccessPoint
RelayDomainAccessPoint DomainAccessPoint
da) Map RelayAccessPoint (PeerAdvertise, PeerTrustable)
m of
Maybe (PeerAdvertise, PeerTrustable)
Nothing -> Int
prev
Just (PeerAdvertise, PeerTrustable)
_ -> Int
i
) (-Int
1) [(Int,
(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable)))]
db
ipsAtIndex :: [IP]
ipsAtIndex = (SockAddr -> IP) -> [SockAddr] -> [IP]
forall a b. (a -> b) -> [a] -> [b]
map (\SockAddr
sockAddr ->
case SockAddr
sockAddr of
SockAddrInet PortNumber
_ Word32
hostAddr
-> IPv4 -> IP
IPv4 (IPv4 -> IP) -> IPv4 -> IP
forall a b. (a -> b) -> a -> b
$ Word32 -> IPv4
fromHostAddress Word32
hostAddr
SockAddr
_ -> [Char] -> IP
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible happened!"
) ([SockAddr] -> [IP]) -> [SockAddr] -> [IP]
forall a b. (a -> b) -> a -> b
$ Map SockAddr (PeerAdvertise, PeerTrustable) -> [SockAddr]
forall k a. Map k a -> [k]
Map.keys
(Map SockAddr (PeerAdvertise, PeerTrustable) -> [SockAddr])
-> Map SockAddr (PeerAdvertise, PeerTrustable) -> [SockAddr]
forall a b. (a -> b) -> a -> b
$ (HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))
-> Map SockAddr (PeerAdvertise, PeerTrustable)
forall {a} {b} {c}. (a, b, c) -> c
thrd
((HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))
-> Map SockAddr (PeerAdvertise, PeerTrustable))
-> (HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))
-> Map SockAddr (PeerAdvertise, PeerTrustable)
forall a b. (a -> b) -> a -> b
$ [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
lrpg [(HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))]
-> Int
-> (HotValency, WarmValency,
Map SockAddr (PeerAdvertise, PeerTrustable))
forall a. HasCallStack => [a] -> Int -> a
!! Int
index :: [IP]
arePresent :: Bool
arePresent = ((IP, Word32) -> Bool) -> [(IP, Word32)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((IP -> [IP] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IP]
ipsAtIndex) (IP -> Bool) -> ((IP, Word32) -> IP) -> (IP, Word32) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IP, Word32) -> IP
forall a b. (a, b) -> a
fst) [(IP, Word32)]
res
in (Bool
arePresent Bool -> Bool -> Bool
&& Bool
b, (Time
t', TraceLocalRootPeers SockAddr Failure
y))
(TraceLocalRootResult DomainAccessPoint
_ [(IP, Word32)]
_, TraceLocalRootPeers SockAddr Failure
_) -> (Bool
b, (Time
t, TraceLocalRootPeers SockAddr Failure
x))
(TraceLocalRootPeers SockAddr Failure
_, TraceLocalRootPeers SockAddr Failure
_) -> (Bool
b, (Time
t', TraceLocalRootPeers SockAddr Failure
y))
)
(Bool
True, [(Time, TraceLocalRootPeers SockAddr Failure)]
-> (Time, TraceLocalRootPeers SockAddr Failure)
forall a. HasCallStack => [a] -> a
head [(Time, TraceLocalRootPeers SockAddr Failure)]
tr)
([(Time, TraceLocalRootPeers SockAddr Failure)]
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
forall a. HasCallStack => [a] -> [a]
tail [(Time, TraceLocalRootPeers SockAddr Failure)]
tr)
in Bool -> Property
forall prop. Testable prop => prop -> Property
property ((Bool, (Time, TraceLocalRootPeers SockAddr Failure)) -> Bool
forall a b. (a, b) -> a
fst (Bool, (Time, TraceLocalRootPeers SockAddr Failure))
r)
where
thrd :: (a, b, c) -> c
thrd (a
_, b
_, c
c) = c
c
data DelayAndTimeoutScripts = DelayAndTimeoutScripts
(Script DNSLookupDelay)
(Script DNSTimeout)
deriving Int -> DelayAndTimeoutScripts -> ShowS
[DelayAndTimeoutScripts] -> ShowS
DelayAndTimeoutScripts -> [Char]
(Int -> DelayAndTimeoutScripts -> ShowS)
-> (DelayAndTimeoutScripts -> [Char])
-> ([DelayAndTimeoutScripts] -> ShowS)
-> Show DelayAndTimeoutScripts
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DelayAndTimeoutScripts -> ShowS
showsPrec :: Int -> DelayAndTimeoutScripts -> ShowS
$cshow :: DelayAndTimeoutScripts -> [Char]
show :: DelayAndTimeoutScripts -> [Char]
$cshowList :: [DelayAndTimeoutScripts] -> ShowS
showList :: [DelayAndTimeoutScripts] -> ShowS
Show
fixupDelayAndTimeoutScripts :: DelayAndTimeoutScripts
-> DelayAndTimeoutScripts
fixupDelayAndTimeoutScripts :: DelayAndTimeoutScripts -> DelayAndTimeoutScripts
fixupDelayAndTimeoutScripts (DelayAndTimeoutScripts lookupScript :: Script DNSLookupDelay
lookupScript@(Script NonEmpty DNSLookupDelay
delays)
timeoutScript :: Script DNSTimeout
timeoutScript@(Script NonEmpty DNSTimeout
timeouts)) =
let lastTimeout :: DiffTime
lastTimeout :: DiffTime
lastTimeout = DNSTimeout -> DiffTime
getDNSTimeout (DNSTimeout -> DiffTime) -> DNSTimeout -> DiffTime
forall a b. (a -> b) -> a -> b
$ NonEmpty DNSTimeout -> DNSTimeout
forall a. NonEmpty a -> a
NonEmpty.last NonEmpty DNSTimeout
timeouts
lookupScript' :: Script DNSLookupDelay
lookupScript' =
if DNSLookupDelay -> DiffTime
getDNSLookupDelay (NonEmpty DNSLookupDelay -> DNSLookupDelay
forall a. NonEmpty a -> a
NonEmpty.last NonEmpty DNSLookupDelay
delays) DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DiffTime
lastTimeout
then NonEmpty DNSLookupDelay -> Script DNSLookupDelay
forall a. NonEmpty a -> Script a
Script (NonEmpty DNSLookupDelay
delays NonEmpty DNSLookupDelay
-> NonEmpty DNSLookupDelay -> NonEmpty DNSLookupDelay
forall a. Semigroup a => a -> a -> a
<> (DiffTime -> DNSLookupDelay
DNSLookupDelay (DiffTime
lastTimeout DiffTime -> DiffTime -> DiffTime
forall a. Fractional a => a -> a -> a
/ DiffTime
2) DNSLookupDelay -> [DNSLookupDelay] -> NonEmpty DNSLookupDelay
forall a. a -> [a] -> NonEmpty a
:| []))
else Script DNSLookupDelay
lookupScript
in (Script DNSLookupDelay
-> Script DNSTimeout -> DelayAndTimeoutScripts
DelayAndTimeoutScripts Script DNSLookupDelay
lookupScript' Script DNSTimeout
timeoutScript)
instance Arbitrary DelayAndTimeoutScripts where
arbitrary :: Gen DelayAndTimeoutScripts
arbitrary = (DelayAndTimeoutScripts -> DelayAndTimeoutScripts)
-> Gen DelayAndTimeoutScripts -> Gen DelayAndTimeoutScripts
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DelayAndTimeoutScripts -> DelayAndTimeoutScripts
fixupDelayAndTimeoutScripts
(Gen DelayAndTimeoutScripts -> Gen DelayAndTimeoutScripts)
-> Gen DelayAndTimeoutScripts -> Gen DelayAndTimeoutScripts
forall a b. (a -> b) -> a -> b
$ Script DNSLookupDelay
-> Script DNSTimeout -> DelayAndTimeoutScripts
DelayAndTimeoutScripts
(Script DNSLookupDelay
-> Script DNSTimeout -> DelayAndTimeoutScripts)
-> Gen (Script DNSLookupDelay)
-> Gen (Script DNSTimeout -> DelayAndTimeoutScripts)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Script DNSLookupDelay)
forall a. Arbitrary a => Gen a
arbitrary
Gen (Script DNSTimeout -> DelayAndTimeoutScripts)
-> Gen (Script DNSTimeout) -> Gen DelayAndTimeoutScripts
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (Script DNSTimeout)
forall a. Arbitrary a => Gen a
arbitrary
shrink :: DelayAndTimeoutScripts -> [DelayAndTimeoutScripts]
shrink (DelayAndTimeoutScripts Script DNSLookupDelay
lookupScript Script DNSTimeout
timeoutScript) =
[ DelayAndTimeoutScripts -> DelayAndTimeoutScripts
fixupDelayAndTimeoutScripts
(Script DNSLookupDelay
-> Script DNSTimeout -> DelayAndTimeoutScripts
DelayAndTimeoutScripts Script DNSLookupDelay
lookupScript Script DNSTimeout
timeoutScript')
| Script DNSTimeout
timeoutScript' <- Script DNSTimeout -> [Script DNSTimeout]
forall a. Arbitrary a => a -> [a]
shrink Script DNSTimeout
timeoutScript
]
[DelayAndTimeoutScripts]
-> [DelayAndTimeoutScripts] -> [DelayAndTimeoutScripts]
forall a. [a] -> [a] -> [a]
++
[ DelayAndTimeoutScripts -> DelayAndTimeoutScripts
fixupDelayAndTimeoutScripts
(Script DNSLookupDelay
-> Script DNSTimeout -> DelayAndTimeoutScripts
DelayAndTimeoutScripts Script DNSLookupDelay
lookupScript' Script DNSTimeout
timeoutScript)
| Script DNSLookupDelay
lookupScript' <- Script DNSLookupDelay -> [Script DNSLookupDelay]
forall a. Arbitrary a => a -> [a]
shrink Script DNSLookupDelay
lookupScript
]
prop_public_resolvesDomainsCorrectly :: MockRoots
-> DelayAndTimeoutScripts
-> Int
-> Property
prop_public_resolvesDomainsCorrectly :: MockRoots -> DelayAndTimeoutScripts -> Int -> Property
prop_public_resolvesDomainsCorrectly
mockRoots :: MockRoots
mockRoots@(MockRoots [(HotValency, WarmValency,
Map RelayAccessPoint (PeerAdvertise, PeerTrustable))]
_ Script (Map Domain [(IP, Word32)])
_ Map RelayAccessPoint PeerAdvertise
_ Script (Map Domain [(IP, Word32)])
pDNSMap)
(DelayAndTimeoutScripts Script DNSLookupDelay
dnsLookupDelayScript Script DNSTimeout
dnsTimeoutScript)
Int
n
=
let mockRoots' :: MockRoots
mockRoots' =
MockRoots
mockRoots { mockPublicRootPeersDNSMap =
singletonScript (scriptHead pDNSMap)
}
tr :: SimTrace ()
tr = (forall s. IOSim s ()) -> SimTrace ()
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace
((forall s. IOSim s ()) -> SimTrace ())
-> (forall s. IOSim s ()) -> SimTrace ()
forall a b. (a -> b) -> a -> b
$ Tracer (IOSim s) TracePublicRootPeers
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> ((Int -> IOSim s (Map SockAddr PeerAdvertise, DiffTime))
-> IOSim s (Map SockAddr PeerAdvertise, DiffTime))
-> IOSim s ()
forall (m :: * -> *) a.
(MonadAsync m, MonadDelay m, MonadThrow m, MonadTimer m) =>
Tracer m TracePublicRootPeers
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> ((Int -> m (Map SockAddr PeerAdvertise, DiffTime)) -> m a)
-> m ()
mockPublicRootPeersProvider Tracer (IOSim s) TracePublicRootPeers
forall s. Tracer (IOSim s) TracePublicRootPeers
tracerTracePublicRoots
MockRoots
mockRoots'
Script DNSTimeout
dnsTimeoutScript
Script DNSLookupDelay
dnsLookupDelayScript
((Int -> IOSim s (Map SockAddr PeerAdvertise, DiffTime))
-> Int -> IOSim s (Map SockAddr PeerAdvertise, DiffTime)
forall a b. (a -> b) -> a -> b
$ Int
n)
successes :: [(Time, (Domain, [IP]))]
successes = [(Time, TracePublicRootPeers)] -> [(Time, (Domain, [IP]))]
selectPublicRootResultEvents
([(Time, TracePublicRootPeers)] -> [(Time, (Domain, [IP]))])
-> [(Time, TracePublicRootPeers)] -> [(Time, (Domain, [IP]))]
forall a b. (a -> b) -> a -> b
$ [(Time, TestTraceEvent)] -> [(Time, TracePublicRootPeers)]
selectPublicRootPeersEvents
([(Time, TestTraceEvent)] -> [(Time, TracePublicRootPeers)])
-> [(Time, TestTraceEvent)] -> [(Time, TracePublicRootPeers)]
forall a b. (a -> b) -> a -> b
$ SimTrace () -> [(Time, TestTraceEvent)]
forall a. SimTrace a -> [(Time, TestTraceEvent)]
selectRootPeerDNSTraceEvents
(SimTrace () -> [(Time, TestTraceEvent)])
-> SimTrace () -> [(Time, TestTraceEvent)]
forall a b. (a -> b) -> a -> b
$ SimTrace ()
tr
successesMap :: Map Domain [IP]
successesMap = [(Domain, [IP])] -> Map Domain [IP]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Domain, [IP])] -> Map Domain [IP])
-> [(Domain, [IP])] -> Map Domain [IP]
forall a b. (a -> b) -> a -> b
$ ((Time, (Domain, [IP])) -> (Domain, [IP]))
-> [(Time, (Domain, [IP]))] -> [(Domain, [IP])]
forall a b. (a -> b) -> [a] -> [b]
map (Time, (Domain, [IP])) -> (Domain, [IP])
forall a b. (a, b) -> b
snd [(Time, (Domain, [IP]))]
successes
in [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([(Time, (Domain, [IP]))] -> [Char]
forall a. Show a => a -> [Char]
show [(Time, (Domain, [IP]))]
successes)
(Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ Map Domain [IP]
successesMap Map Domain [IP] -> Map Domain [IP] -> Bool
forall a. Eq a => a -> a -> Bool
== (((IP, Word32) -> IP) -> [(IP, Word32)] -> [IP]
forall a b. (a -> b) -> [a] -> [b]
map (IP, Word32) -> IP
forall a b. (a, b) -> a
fst ([(IP, Word32)] -> [IP])
-> Map Domain [(IP, Word32)] -> Map Domain [IP]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Script (Map Domain [(IP, Word32)]) -> Map Domain [(IP, Word32)]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions Script (Map Domain [(IP, Word32)])
pDNSMap)
listResource :: forall e m a. Monad m
=> Tracer m a
-> [Either e a] -> Resource m (Either e a)
listResource :: forall e (m :: * -> *) a.
Monad m =>
Tracer m a -> [Either e a] -> Resource m (Either e a)
listResource Tracer m a
tracer = (([Either e a] -> Resource m (Either e a))
-> [Either e a] -> Resource m (Either e a))
-> [Either e a] -> Resource m (Either e a)
forall a. (a -> a) -> a
fix ([Either e a] -> Resource m (Either e a))
-> [Either e a] -> Resource m (Either e a)
go
where
go :: ([Either e a] -> Resource m (Either e a))
-> ([Either e a] -> Resource m (Either e a))
go :: ([Either e a] -> Resource m (Either e a))
-> [Either e a] -> Resource m (Either e a)
go [Either e a] -> Resource m (Either e a)
_this [] = [Char] -> Resource m (Either e a)
forall a. HasCallStack => [Char] -> a
error [Char]
"listResource: invariant vaiolation"
go [Either e a] -> Resource m (Either e a)
this (a :: Either e a
a@(Right a
x) : [Either e a]
as) = m (Either e a, Resource m (Either e a)) -> Resource m (Either e a)
forall (m :: * -> *) a. m (a, Resource m a) -> Resource m a
Resource (m (Either e a, Resource m (Either e a))
-> Resource m (Either e a))
-> m (Either e a, Resource m (Either e a))
-> Resource m (Either e a)
forall a b. (a -> b) -> a -> b
$ do
Tracer m a -> a -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m a
tracer a
x
(Either e a, Resource m (Either e a))
-> m (Either e a, Resource m (Either e a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a
a, [Either e a] -> Resource m (Either e a)
this [Either e a]
as)
go [Either e a] -> Resource m (Either e a)
this (a :: Either e a
a@Left {}: [Either e a]
as) = m (Either e a, Resource m (Either e a)) -> Resource m (Either e a)
forall (m :: * -> *) a. m (a, Resource m a) -> Resource m a
Resource (m (Either e a, Resource m (Either e a))
-> Resource m (Either e a))
-> m (Either e a, Resource m (Either e a))
-> Resource m (Either e a)
forall a b. (a -> b) -> a -> b
$
(Either e a, Resource m (Either e a))
-> m (Either e a, Resource m (Either e a))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a
a, [Either e a] -> Resource m (Either e a)
this [Either e a]
as)
prop_retryResource :: NonEmptyList DNSTimeout -> [Either Int Int] -> Property
prop_retryResource :: NonEmptyList DNSTimeout -> [Either Int Int] -> Property
prop_retryResource (NonEmpty [DNSTimeout]
delays0) [Either Int Int]
as =
[Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample (SimTrace [Int] -> [Char]
forall a. Show a => SimTrace a -> [Char]
ppTrace SimTrace [Int]
trace) (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$
SimTrace [Int] -> [(Time, Int)]
forall a b. Typeable b => SimTrace a -> [b]
selectTraceEventsDynamic SimTrace [Int]
trace [(Time, Int)] -> [(Time, Int)] -> Bool
forall a. Eq a => a -> a -> Bool
/= NonEmpty DiffTime -> [Either Int Int] -> [(Time, Int)]
model NonEmpty DiffTime
delays [Either Int Int]
as
where
delays :: NonEmpty DiffTime
delays :: NonEmpty DiffTime
delays = DNSTimeout -> DiffTime
getDNSTimeout (DNSTimeout -> DiffTime)
-> NonEmpty DNSTimeout -> NonEmpty DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DNSTimeout] -> NonEmpty DNSTimeout
forall a. HasCallStack => [a] -> NonEmpty a
NonEmpty.fromList [DNSTimeout]
delays0
tracer :: Tracer (IOSim s) Int
tracer :: forall s. Tracer (IOSim s) Int
tracer = (Int -> IOSim s ()) -> Tracer (IOSim s) Int
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (\Int
a -> IOSim s Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime IOSim s Time -> (Time -> IOSim s ()) -> IOSim s ()
forall a b. IOSim s a -> (a -> IOSim s b) -> IOSim s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Time
t -> (Time, Int) -> IOSim s ()
forall a s. Typeable a => a -> IOSim s ()
traceM (Time
t, Int
a))
Tracer (IOSim s) Int
-> Tracer (IOSim s) Int -> Tracer (IOSim s) Int
forall a. Semigroup a => a -> a -> a
<> (Int -> IOSim s ()) -> Tracer (IOSim s) Int
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (\Int
a -> IOSim s Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime IOSim s Time -> (Time -> IOSim s ()) -> IOSim s ()
forall a b. IOSim s a -> (a -> IOSim s b) -> IOSim s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Time
t -> [Char] -> IOSim s ()
forall (m :: * -> *). MonadSay m => [Char] -> m ()
say ((Time, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Time
t, Int
a)))
resource :: Resource (IOSim s) Int
resource :: forall s. Resource (IOSim s) Int
resource = Tracer (IOSim s) Int
-> NonEmpty DiffTime
-> Resource (IOSim s) (Either Int Int)
-> Resource (IOSim s) Int
forall (m :: * -> *) e a.
MonadDelay m =>
Tracer m e
-> NonEmpty DiffTime -> Resource m (Either e a) -> Resource m a
retryResource Tracer (IOSim s) Int
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer NonEmpty DiffTime
delays
(Resource (IOSim s) (Either Int Int) -> Resource (IOSim s) Int)
-> Resource (IOSim s) (Either Int Int) -> Resource (IOSim s) Int
forall a b. (a -> b) -> a -> b
$ Tracer (IOSim s) Int
-> [Either Int Int] -> Resource (IOSim s) (Either Int Int)
forall e (m :: * -> *) a.
Monad m =>
Tracer m a -> [Either e a] -> Resource m (Either e a)
listResource Tracer (IOSim s) Int
forall s. Tracer (IOSim s) Int
tracer [Either Int Int]
as
sim :: IOSim s [Int]
sim :: forall s. IOSim s [Int]
sim = Int -> Resource (IOSim s) Int -> IOSim s [Int]
forall s. Int -> Resource (IOSim s) Int -> IOSim s [Int]
run ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Either Int Int] -> [Int]
forall a b. [Either a b] -> [b]
rights [Either Int Int]
as)) Resource (IOSim s) Int
forall s. Resource (IOSim s) Int
resource
where
run :: Int -> Resource (IOSim s) Int -> IOSim s [Int]
run :: forall s. Int -> Resource (IOSim s) Int -> IOSim s [Int]
run = [Int] -> Int -> Resource (IOSim s) Int -> IOSim s [Int]
forall {t} {m :: * -> *} {a}.
(Ord t, Num t, Monad m, Enum t) =>
[a] -> t -> Resource m a -> m [a]
go []
where
go :: [a] -> t -> Resource m a -> m [a]
go [a]
xs t
n Resource m a
_ | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs)
go [a]
xs t
n Resource m a
r = do
(x, r') <- Resource m a -> m (a, Resource m a)
forall (m :: * -> *) a. Resource m a -> m (a, Resource m a)
withResource Resource m a
r
go (x : xs) (pred n) r'
trace :: SimTrace [Int]
trace = (forall s. IOSim s [Int]) -> SimTrace [Int]
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace IOSim s [Int]
forall s. IOSim s [Int]
sim
model :: NonEmpty DiffTime -> [Either Int Int] -> [(Time, Int)]
model :: NonEmpty DiffTime -> [Either Int Int] -> [(Time, Int)]
model NonEmpty DiffTime
ds0 = Time
-> [(Time, Int)]
-> NonEmpty DiffTime
-> [Either Int Int]
-> [(Time, Int)]
go (DiffTime -> Time
Time DiffTime
0) [] NonEmpty DiffTime
ds0
where
dropHead :: forall x. NonEmpty x -> NonEmpty x
dropHead :: forall x. NonEmpty x -> NonEmpty x
dropHead xs :: NonEmpty x
xs@(x
_ :| []) = NonEmpty x
xs
dropHead (x
_ :| x
x : [x]
xs) = x
x x -> [x] -> NonEmpty x
forall a. a -> [a] -> NonEmpty a
:| [x]
xs
go :: Time
-> [(Time, Int)]
-> NonEmpty DiffTime
-> [Either Int Int]
-> [(Time, Int)]
go :: Time
-> [(Time, Int)]
-> NonEmpty DiffTime
-> [Either Int Int]
-> [(Time, Int)]
go Time
_t [(Time, Int)]
r NonEmpty DiffTime
_ds [] = [(Time, Int)] -> [(Time, Int)]
forall a. [a] -> [a]
reverse [(Time, Int)]
r
go Time
t [(Time, Int)]
r NonEmpty DiffTime
ds (Left Int
_ : [Either Int Int]
xs) =
Time
-> [(Time, Int)]
-> NonEmpty DiffTime
-> [Either Int Int]
-> [(Time, Int)]
go (NonEmpty DiffTime -> DiffTime
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty DiffTime
ds DiffTime -> Time -> Time
`addTime` Time
t)
[(Time, Int)]
r
(NonEmpty DiffTime -> NonEmpty DiffTime
forall x. NonEmpty x -> NonEmpty x
dropHead NonEmpty DiffTime
ds)
[Either Int Int]
xs
go Time
t [(Time, Int)]
r NonEmpty DiffTime
_ds (Right Int
x : [Either Int Int]
xs) =
Time
-> [(Time, Int)]
-> NonEmpty DiffTime
-> [Either Int Int]
-> [(Time, Int)]
go Time
t ((Time
t, Int
x) (Time, Int) -> [(Time, Int)] -> [(Time, Int)]
forall a. a -> [a] -> [a]
: [(Time, Int)]
r) NonEmpty DiffTime
ds0 [Either Int Int]
xs
ex :: (MonadLabelledSTM m, MonadTimer m, MonadTraceSTM m, MonadSay m) => m ()
ex :: forall (m :: * -> *).
(MonadLabelledSTM m, MonadTimer m, MonadTraceSTM m, MonadSay m) =>
m ()
ex = do
d <- DiffTime -> m (TVar m Bool)
forall (m :: * -> *). MonadTimer m => DiffTime -> m (TVar m Bool)
registerDelay DiffTime
1
LazySTM.labelTVarIO d "delayVar"
LazySTM.traceTVarIO d (\Maybe Bool
_ Bool
a -> TraceValue -> InspectMonad m TraceValue
forall a. a -> InspectMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> TraceValue
TraceString (Bool -> [Char]
forall a. Show a => a -> [Char]
show Bool
a)))
atomically (LazySTM.readTVar d >>= check)
say "Sink me!"