{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE NumericUnderscores  #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# 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
  , genGroupSrvs
  , genDomainName
  , DomainAccessPoint (..)
  , MockRoots (..)
  , MockDNSMap
  , MockDNSLookupResult
  , DNSTimeout (..)
  , DNSLookupDelay (..)
  , DelayAndTimeoutScripts (..)
  ) where

import Control.Applicative (Alternative)
import Control.Monad (foldM, forever, replicateM_, when)
import Data.Bifunctor (bimap)
import Data.ByteString.Char8 (pack)
import Data.ByteString.Char8 qualified as BSC
import Data.Dynamic (Typeable, fromDynamic)
import Data.Either (fromLeft, rights)
import Data.Foldable as Foldable (foldl')
import Data.Function (fix)
import Data.Functor (void)
import Data.IP (fromHostAddress, toSockAddr)
import Data.List (find, intercalate)
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (isJust, listToMaybe, mapMaybe)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Time.Clock (diffTimeToPicoseconds, picosecondsToDiffTime)
import Data.Void (Void)
import Data.Word (Word16)
import Network.DNS (DNSError (NameError), DNSMessage, ResourceRecord (..),
           answer, defaultResponse)
import Network.DNS qualified as DNS
import Network.DNS.Resolver qualified as DNSResolver
import Network.Socket (SockAddr (..))
import System.Random

import Control.Concurrent.Class.MonadSTM qualified as LazySTM
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Exception (IOException, throw)
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadSay (MonadSay (..))
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import Control.Monad.Class.MonadTimer.SI qualified as MonadTimer
import Control.Monad.IOSim
import Control.Tracer (Tracer, contramap, mkTracer, nullTracer, traceWith)

import Ouroboros.Network.ConnectionManager.Types (Provenance (Outbound))
import Ouroboros.Network.DiffusionMode
import Ouroboros.Network.PeerSelection
import Test.Ouroboros.Network.Data.Script (Script (Script), initScript',
           scriptHead, singletonScript, stepScript')
import Test.Ouroboros.Network.OrphanInstances (genIPv4)
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
    -> TestSeed
    -> Property)
-> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"preserve IPs"
                      MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> Property
prop_local_preservesIPs
       , [Char]
-> (MockRoots
    -> Script DNSTimeout
    -> Script DNSLookupDelay
    -> TestSeed
    -> Property)
-> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"preserves groups and targets"
                      MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> Property
prop_local_preservesGroupNumberAndTargets
       , [Char]
-> (MockRoots
    -> Script DNSTimeout
    -> Script DNSLookupDelay
    -> TestSeed
    -> Property)
-> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"resolves domains correctly"
                      MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> Property
prop_local_resolvesDomainsCorrectly
       , [Char]
-> (MockRoots
    -> Script DNSTimeout
    -> Script DNSLookupDelay
    -> TestSeed
    -> Property)
-> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"updates domains correctly"
                      MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> Property
prop_local_updatesDomainsCorrectly
       , [Char]
-> (Script DNSTimeout
    -> Script DNSLookupDelay -> TestSeed -> Property)
-> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"reconfigures IP addresses"
                      Script DNSTimeout -> Script DNSLookupDelay -> TestSeed -> Property
prop_local_reconfiguresIPs
       , [Char] -> (MockRoots -> MockRoots -> Bool -> Property) -> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"publishes IP addresses before setting up a resolver"
                      MockRoots -> MockRoots -> Bool -> Property
prop_local_publishesBeforeResolver
       ]
    , [Char] -> [TestTree] -> TestTree
testGroup [Char]
"publicRootPeersProvider"
       [ [Char]
-> (MockRoots
    -> DelayAndTimeoutScripts -> Int -> TestSeed -> Property)
-> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"resolves domains correctly"
                      MockRoots -> DelayAndTimeoutScripts -> Int -> TestSeed -> Property
prop_public_resolvesDomainsCorrectly
       ]
    , [Char] -> [TestTree] -> TestTree
testGroup [Char]
"delayedResource"
       [
       ]
    ]
  ]

--
-- Mock Environment and Utils
--

data DomainAccessPoint = DomainAccessPoint !DNS.Domain PortNumber
                       | DomainSRVAccessPoint !DNS.Domain
  deriving (DomainAccessPoint -> DomainAccessPoint -> Bool
(DomainAccessPoint -> DomainAccessPoint -> Bool)
-> (DomainAccessPoint -> DomainAccessPoint -> Bool)
-> Eq DomainAccessPoint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DomainAccessPoint -> DomainAccessPoint -> Bool
== :: DomainAccessPoint -> DomainAccessPoint -> Bool
$c/= :: DomainAccessPoint -> DomainAccessPoint -> Bool
/= :: DomainAccessPoint -> DomainAccessPoint -> Bool
Eq, Int -> DomainAccessPoint -> ShowS
[DomainAccessPoint] -> ShowS
DomainAccessPoint -> [Char]
(Int -> DomainAccessPoint -> ShowS)
-> (DomainAccessPoint -> [Char])
-> ([DomainAccessPoint] -> ShowS)
-> Show DomainAccessPoint
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DomainAccessPoint -> ShowS
showsPrec :: Int -> DomainAccessPoint -> ShowS
$cshow :: DomainAccessPoint -> [Char]
show :: DomainAccessPoint -> [Char]
$cshowList :: [DomainAccessPoint] -> ShowS
showList :: [DomainAccessPoint] -> ShowS
Show, Eq DomainAccessPoint
Eq DomainAccessPoint =>
(DomainAccessPoint -> DomainAccessPoint -> Ordering)
-> (DomainAccessPoint -> DomainAccessPoint -> Bool)
-> (DomainAccessPoint -> DomainAccessPoint -> Bool)
-> (DomainAccessPoint -> DomainAccessPoint -> Bool)
-> (DomainAccessPoint -> DomainAccessPoint -> Bool)
-> (DomainAccessPoint -> DomainAccessPoint -> DomainAccessPoint)
-> (DomainAccessPoint -> DomainAccessPoint -> DomainAccessPoint)
-> Ord DomainAccessPoint
DomainAccessPoint -> DomainAccessPoint -> Bool
DomainAccessPoint -> DomainAccessPoint -> Ordering
DomainAccessPoint -> DomainAccessPoint -> DomainAccessPoint
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DomainAccessPoint -> DomainAccessPoint -> Ordering
compare :: DomainAccessPoint -> DomainAccessPoint -> Ordering
$c< :: DomainAccessPoint -> DomainAccessPoint -> Bool
< :: DomainAccessPoint -> DomainAccessPoint -> Bool
$c<= :: DomainAccessPoint -> DomainAccessPoint -> Bool
<= :: DomainAccessPoint -> DomainAccessPoint -> Bool
$c> :: DomainAccessPoint -> DomainAccessPoint -> Bool
> :: DomainAccessPoint -> DomainAccessPoint -> Bool
$c>= :: DomainAccessPoint -> DomainAccessPoint -> Bool
>= :: DomainAccessPoint -> DomainAccessPoint -> Bool
$cmax :: DomainAccessPoint -> DomainAccessPoint -> DomainAccessPoint
max :: DomainAccessPoint -> DomainAccessPoint -> DomainAccessPoint
$cmin :: DomainAccessPoint -> DomainAccessPoint -> DomainAccessPoint
min :: DomainAccessPoint -> DomainAccessPoint -> DomainAccessPoint
Ord)

instance Arbitrary DomainAccessPoint where
  arbitrary :: Gen DomainAccessPoint
arbitrary = [Gen DomainAccessPoint] -> Gen DomainAccessPoint
forall a. HasCallStack => [Gen a] -> Gen a
oneof [Gen DomainAccessPoint
plain, Gen DomainAccessPoint
srv]
    where
      plain :: Gen DomainAccessPoint
plain = Domain -> PortNumber -> DomainAccessPoint
DomainAccessPoint
                (Domain -> PortNumber -> DomainAccessPoint)
-> Gen Domain -> Gen (PortNumber -> DomainAccessPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Domain
genDomainName
                Gen (PortNumber -> DomainAccessPoint)
-> Gen PortNumber -> Gen DomainAccessPoint
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen PortNumber
forall a. Arbitrary a => Gen a
arbitrary
      srv :: Gen DomainAccessPoint
srv = Domain -> DomainAccessPoint
DomainSRVAccessPoint (Domain -> DomainAccessPoint)
-> Gen Domain -> Gen DomainAccessPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Domain
genDomainName

genDomainName :: Gen BSC.ByteString
genDomainName :: Gen Domain
genDomainName = [Domain] -> Gen Domain
forall a. HasCallStack => [a] -> Gen a
elements ([Domain] -> Gen Domain) -> [Domain] -> Gen Domain
forall a b. (a -> b) -> a -> b
$ (\Int
i -> Domain
"test" Domain -> Domain -> Domain
forall a. Semigroup a => a -> a -> a
<> ([Char] -> Domain
BSC.pack ([Char] -> Domain) -> (Int -> [Char]) -> Int -> Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> Domain) -> Int -> Domain
forall a b. (a -> b) -> a -> b
$ Int
i)) (Int -> Domain) -> [Int] -> [Domain]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int
1..Int
6 :: Int]

-- TODO: this type alias should be turned into a newtype with a `Show` instance
-- which displays `IP` as a string literal.
type MockDNSLookupResult = Either [(IP, DNS.TTL)]
                                  [( DNS.Domain
                                   , Word16 -- ^ priority
                                   , Word16 -- ^ weight
                                   , PortNumber)]
type MockDNSMap = (Map (DNS.Domain, DNS.TYPE) MockDNSLookupResult)

data MockRoots = MockRoots {
    MockRoots -> LocalRootsConfig
mockLocalRootPeers        :: [( HotValency
                                  , WarmValency
                                  , Map RelayAccessPoint (LocalRootConfig ()))
                                  -- ^ extraFlags isn't used here since it is
                                  -- not required for testing.
                                 ]
  , MockRoots -> Script MockDNSMap
mockLocalRootPeersDNSMap  :: Script MockDNSMap
  , MockRoots -> Map RelayAccessPoint PeerAdvertise
mockPublicRootPeers       :: Map RelayAccessPoint PeerAdvertise
  , MockRoots -> Script MockDNSMap
mockPublicRootPeersDNSMap :: Script MockDNSMap
  }
  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

-- | Generates MockRoots environments
--
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
    -- Generate LocalRootPeers
    --
    relaysPerGroup <- (Int, Int) -> Gen Int
forall a. Enum a => (a, a) -> Gen a
chooseEnum (Int
1, Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int
relaysNumber Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3))

    -- concat unique identifier to DNS domains to simplify tests
    taggedLocalRelays <- tagRelays <$> vectorOf relaysNumber arbitrary
    targets <- vectorOf relaysNumber genTargets
    peerAdvertise <- blocks relaysPerGroup
                      <$> vectorOf relaysNumber arbitrary

    let localRelaysBlocks = Int -> [RelayAccessPoint] -> [[RelayAccessPoint]]
forall a. Int -> [a] -> [[a]]
blocks Int
relaysPerGroup [RelayAccessPoint]
taggedLocalRelays
        localRelaysMap    = ([(RelayAccessPoint, LocalRootConfig ())]
 -> Map RelayAccessPoint (LocalRootConfig ()))
-> [[(RelayAccessPoint, LocalRootConfig ())]]
-> [Map RelayAccessPoint (LocalRootConfig ())]
forall a b. (a -> b) -> [a] -> [b]
map [(RelayAccessPoint, LocalRootConfig ())]
-> Map RelayAccessPoint (LocalRootConfig ())
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([[(RelayAccessPoint, LocalRootConfig ())]]
 -> [Map RelayAccessPoint (LocalRootConfig ())])
-> [[(RelayAccessPoint, LocalRootConfig ())]]
-> [Map RelayAccessPoint (LocalRootConfig ())]
forall a b. (a -> b) -> a -> b
$ ([RelayAccessPoint]
 -> [LocalRootConfig ()]
 -> [(RelayAccessPoint, LocalRootConfig ())])
-> [[RelayAccessPoint]]
-> [[LocalRootConfig ()]]
-> [[(RelayAccessPoint, LocalRootConfig ())]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [RelayAccessPoint]
-> [LocalRootConfig ()] -> [(RelayAccessPoint, LocalRootConfig ())]
forall a b. [a] -> [b] -> [(a, b)]
zip [[RelayAccessPoint]]
localRelaysBlocks
                                                           [[LocalRootConfig ()]]
peerAdvertise
        localRootPeers    = ((HotValency, WarmValency)
 -> Map RelayAccessPoint (LocalRootConfig ())
 -> (HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ())))
-> [(HotValency, WarmValency)]
-> [Map RelayAccessPoint (LocalRootConfig ())]
-> LocalRootsConfig
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(HotValency
h, WarmValency
w) Map RelayAccessPoint (LocalRootConfig ())
g -> (HotValency
h, WarmValency
w, Map RelayAccessPoint (LocalRootConfig ())
g)) [(HotValency, WarmValency)]
targets [Map RelayAccessPoint (LocalRootConfig ())]
localRelaysMap

    lrpDNSMap <- Script . NonEmpty.fromList
              <$> listOf1 (genDNSLookupMap taggedLocalRelays)

    -- Generate PublicRootPeers
    --
    publicRootRelays <- tagRelays <$> vectorOf relaysNumber arbitrary
    let publicRootAdvertise = Int -> Gen PeerAdvertise -> Gen [PeerAdvertise]
forall a. Int -> Gen a -> Gen [a]
vectorOf Int
relaysNumber Gen PeerAdvertise
forall a. Arbitrary a => Gen a
arbitrary

    publicRootPeers <- Map.fromList . zip publicRootRelays <$> publicRootAdvertise
    publicRootPeersDNSMap <- Script . NonEmpty.fromList <$> listOf1 (genDNSLookupMap publicRootRelays)

    return (MockRoots {
      mockLocalRootPeers        = localRootPeers,
      mockLocalRootPeersDNSMap  = lrpDNSMap,
      mockPublicRootPeers       = publicRootPeers,
      mockPublicRootPeersDNSMap = publicRootPeersDNSMap
    })
  where
    tagRelays :: [RelayAccessPoint] -> [RelayAccessPoint]
tagRelays =
      (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
               RelayAccessSRVDomain Domain
domain ->
                 Domain -> RelayAccessPoint
RelayAccessSRVDomain (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)
               RelayAccessPoint
x -> RelayAccessPoint
x
        )
        [(Int
0 :: Int), Int
1 .. ]

blocks :: Int -> [a] -> [[a]]
blocks :: forall a. 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]]
forall a. Int -> [a] -> [[a]]
blocks Int
s (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
s [a]
l)

-- | DNS answers for the domains among the relays: two addresses for each
-- plain domain, and for each SRV domain some of the plain ones.
genDNSLookupMap :: [RelayAccessPoint] -> Gen MockDNSMap
genDNSLookupMap :: [RelayAccessPoint] -> Gen MockDNSMap
genDNSLookupMap [RelayAccessPoint]
relays = do
    let ([RelayAccessPoint]
_relayAddress, [DomainAccessPoint]
relayDomains, [DomainAccessPoint]
relaySRVs) =
          (([RelayAccessPoint], [DomainAccessPoint], [DomainAccessPoint])
 -> RelayAccessPoint
 -> ([RelayAccessPoint], [DomainAccessPoint], [DomainAccessPoint]))
-> ([RelayAccessPoint], [DomainAccessPoint], [DomainAccessPoint])
-> [RelayAccessPoint]
-> ([RelayAccessPoint], [DomainAccessPoint], [DomainAccessPoint])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([RelayAccessPoint], [DomainAccessPoint], [DomainAccessPoint])
-> RelayAccessPoint
-> ([RelayAccessPoint], [DomainAccessPoint], [DomainAccessPoint])
threeWay ([], [], []) [RelayAccessPoint]
relays
    lookupIP <- Int -> [Domain] -> Gen MockDNSMap
genDomainIPLookupTable Int
2 (DomainAccessPoint -> Domain
dapDomain (DomainAccessPoint -> Domain) -> [DomainAccessPoint] -> [Domain]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DomainAccessPoint]
relayDomains)
    srvs <- dealDomains relayDomains relaySRVs
    let srvs' = (DomainAccessPoint -> Domain)
-> ([DomainAccessPoint] -> [Domain])
-> (DomainAccessPoint, [DomainAccessPoint])
-> (Domain, [Domain])
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap DomainAccessPoint -> Domain
dapDomain ((DomainAccessPoint -> Domain) -> [DomainAccessPoint] -> [Domain]
forall a b. (a -> b) -> [a] -> [b]
map DomainAccessPoint -> Domain
dapDomain) ((DomainAccessPoint, [DomainAccessPoint]) -> (Domain, [Domain]))
-> [(DomainAccessPoint, [DomainAccessPoint])]
-> [(Domain, [Domain])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(DomainAccessPoint, [DomainAccessPoint])]
srvs
    lookupSRV <- Map.fromList . map (bimap (,DNS.SRV) Right)
                 <$> genGroupSrvs srvs'
    return $ Map.union lookupIP lookupSRV
  where
    dapDomain :: DomainAccessPoint -> Domain
dapDomain (DomainAccessPoint Domain
d PortNumber
_p) = Domain
d
    dapDomain (DomainSRVAccessPoint Domain
d) = Domain
d

    -- assigns some domains to srv records
    dealDomains :: [DomainAccessPoint]
                -> [DomainAccessPoint]
                -> Gen [(DomainAccessPoint, [DomainAccessPoint])]
    dealDomains :: [DomainAccessPoint]
-> [DomainAccessPoint]
-> Gen [(DomainAccessPoint, [DomainAccessPoint])]
dealDomains = [(DomainAccessPoint, [DomainAccessPoint])]
-> [DomainAccessPoint]
-> [DomainAccessPoint]
-> Gen [(DomainAccessPoint, [DomainAccessPoint])]
forall {a} {a}. [(a, [a])] -> [a] -> [a] -> Gen [(a, [a])]
dealDomains' []

    -- kickstart the dealing
    dealDomains' :: [(a, [a])] -> [a] -> [a] -> Gen [(a, [a])]
dealDomains' [] (a
domain : [a]
domains) (a
srv : [a]
srvs') =
      [(a, [a])] -> [a] -> [a] -> Gen [(a, [a])]
dealDomains' [(a
srv, [a
domain])] [a]
domains [a]
srvs'

    -- when no more plain domains are available, return empty lookup
    -- which should trace as an error, but a lookup attempt is registered
    dealDomains' [(a, [a])]
acc [] (a
srv : [a]
srvs') =
      [(a, [a])] -> [a] -> [a] -> Gen [(a, [a])]
dealDomains' ((a
srv, [])(a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
:[(a, [a])]
acc) [] [a]
srvs'

    -- toss a coin, if True pop a `DomainPlain` and assign it to
    -- the top srv record. Otherwise, pop the next srv record, and
    -- associate the plain domain with that one.
    dealDomains' as' :: [(a, [a])]
as'@((a
s, [a]
ds):[(a, [a])]
as) (a
domain : [a]
domains) srvs :: [a]
srvs@(a
srv : [a]
srvs') = do
      toss <- Gen Bool
forall a. Arbitrary a => Gen a
arbitrary
      if toss
        then dealDomains' ((s, domain : ds):as) domains srvs
        else dealDomains' ((srv, [domain]):as') domains srvs'

    dealDomains' [(a, [a])]
as [a]
_ds [a]
_srvs = [(a, [a])] -> Gen [(a, [a])]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return [(a, [a])]
as

    threeWay :: ([RelayAccessPoint], [DomainAccessPoint], [DomainAccessPoint])
             -> RelayAccessPoint
             -> ([RelayAccessPoint], [DomainAccessPoint], [DomainAccessPoint])
    threeWay :: ([RelayAccessPoint], [DomainAccessPoint], [DomainAccessPoint])
-> RelayAccessPoint
-> ([RelayAccessPoint], [DomainAccessPoint], [DomainAccessPoint])
threeWay ([RelayAccessPoint]
rAddressAcc, [DomainAccessPoint]
rDomainAcc, [DomainAccessPoint]
rSRVAcc) = \case
      a :: RelayAccessPoint
a@RelayAccessAddress {} -> (RelayAccessPoint
a RelayAccessPoint -> [RelayAccessPoint] -> [RelayAccessPoint]
forall a. a -> [a] -> [a]
: [RelayAccessPoint]
rAddressAcc, [DomainAccessPoint]
rDomainAcc, [DomainAccessPoint]
rSRVAcc)
      RelayAccessDomain Domain
d PortNumber
p  -> ([RelayAccessPoint]
rAddressAcc, Domain -> PortNumber -> DomainAccessPoint
DomainAccessPoint Domain
d PortNumber
p DomainAccessPoint -> [DomainAccessPoint] -> [DomainAccessPoint]
forall a. a -> [a] -> [a]
: [DomainAccessPoint]
rDomainAcc, [DomainAccessPoint]
rSRVAcc)
      RelayAccessSRVDomain Domain
d -> ([RelayAccessPoint]
rAddressAcc, [DomainAccessPoint]
rDomainAcc, Domain -> DomainAccessPoint
DomainSRVAccessPoint Domain
d DomainAccessPoint -> [DomainAccessPoint] -> [DomainAccessPoint]
forall a. a -> [a] -> [a]
: [DomainAccessPoint]
rSRVAcc)

    genDomainIPLookupTable :: Int -> [DNS.Domain] -> Gen (Map (DNS.Domain, DNS.TYPE)
                                                              MockDNSLookupResult)
    genDomainIPLookupTable :: Int -> [Domain] -> Gen MockDNSMap
genDomainIPLookupTable Int
ipsPerDomain [Domain]
localRootDomains = do
      localRootDomainIPs <- Int -> [IP] -> [[IP]]
forall a. Int -> [a] -> [[a]]
blocks Int
ipsPerDomain
              -- Modules under test do not differ by IP version so we only
              -- generate IPv4 addresses.
              ([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)
                           Gen IP
genIPv4
      localRootDomainTTLs <- blocks ipsPerDomain
              <$> vectorOf (ipsPerDomain * length localRootDomains)
                           (arbitrary :: Gen DNS.TTL)

      let localRootDomainsIP_TTls = ([IP] -> [TTL] -> [(IP, TTL)])
-> [[IP]] -> [[TTL]] -> [[(IP, TTL)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [IP] -> [TTL] -> [(IP, TTL)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[IP]]
localRootDomainIPs [[TTL]]
localRootDomainTTLs
          rootDomainKeys = (, TYPE
DNS.A) (Domain -> (Domain, TYPE)) -> [Domain] -> [(Domain, TYPE)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Domain]
localRootDomains
          lrpDNSMap = [((Domain, TYPE), Either [(IP, TTL)] b)]
-> Map (Domain, TYPE) (Either [(IP, TTL)] b)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([((Domain, TYPE), Either [(IP, TTL)] b)]
 -> Map (Domain, TYPE) (Either [(IP, TTL)] b))
-> [((Domain, TYPE), Either [(IP, TTL)] b)]
-> Map (Domain, TYPE) (Either [(IP, TTL)] b)
forall a b. (a -> b) -> a -> b
$ [(Domain, TYPE)]
-> [Either [(IP, TTL)] b]
-> [((Domain, TYPE), Either [(IP, TTL)] b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Domain, TYPE)]
rootDomainKeys ([(IP, TTL)] -> Either [(IP, TTL)] b
forall a b. a -> Either a b
Left ([(IP, TTL)] -> Either [(IP, TTL)] b)
-> [[(IP, TTL)]] -> [Either [(IP, TTL)] b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(IP, TTL)]]
localRootDomainsIP_TTls)

      return lrpDNSMap

-- assigns weights and priorities to SRV record's subordinate domains
-- such that several subdomains may have the same priority level and port
-- number, and each one will have a random weight, and result is shuffled
--
genGroupSrvs :: (Arbitrary prio, Arbitrary wt)
             => [(srv, [subordinate])]
             -> Gen [(srv, [(subordinate, prio, wt, PortNumber)])]
genGroupSrvs :: forall prio wt srv subordinate.
(Arbitrary prio, Arbitrary wt) =>
[(srv, [subordinate])]
-> Gen [(srv, [(subordinate, prio, wt, PortNumber)])]
genGroupSrvs = [(srv, [(subordinate, prio, wt, PortNumber)])]
-> [(srv, [subordinate])]
-> Gen [(srv, [(subordinate, prio, wt, PortNumber)])]
forall {a} {a} {a} {a} {a}.
(Arbitrary a, Arbitrary a, Arbitrary a) =>
[(a, [(a, a, a, a)])] -> [(a, [a])] -> Gen [(a, [(a, a, a, a)])]
go []
 where
  go :: [(a, [(a, a, a, a)])] -> [(a, [a])] -> Gen [(a, [(a, a, a, a)])]
go [(a, [(a, a, a, a)])]
acc [] = [(a, [(a, a, a, a)])] -> Gen [(a, [(a, a, a, a)])]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return [(a, [(a, a, a, a)])]
acc
  go [(a, [(a, a, a, a)])]
acc ((a
srv, [a]
subordinates):[(a, [a])]
srvs) = do
    let worker :: [(a, a, a, a)] -> Int -> [a] -> Gen [(a, a, a, a)]
worker [(a, a, a, a)]
grouped Int
0 [a]
_ = [(a, a, a, a)] -> Gen [(a, a, a, a)]
forall a. [a] -> Gen [a]
shuffle [(a, a, a, a)]
grouped
        worker [(a, a, a, a)]
grouped Int
count [a]
domains' = do
          howMany <- (Int, Int) -> Gen Int
chooseInt (Int
1, Int
count)
          port <- arbitrary
          prio <- arbitrary
          wts <- vectorOf howMany arbitrary
          let group = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
howMany [a]
domains'
              smash a
dom c
wt = (a
dom, a
prio, c
wt, a
port)
              grouped' = (a -> a -> (a, a, a, a)) -> [a] -> [a] -> [(a, a, a, a)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> (a, a, a, a)
forall {a} {c}. a -> c -> (a, a, c, a)
smash [a]
group [a]
wts
                         [(a, a, a, a)] -> [(a, a, a, a)] -> [(a, a, a, a)]
forall a. Semigroup a => a -> a -> a
<> [(a, a, a, a)]
grouped
          worker grouped' (count - howMany) (drop howMany domains')
    organized <- [(a, a, a, a)] -> Int -> [a] -> Gen [(a, a, a, a)]
forall {a} {a} {a} {a}.
(Arbitrary a, Arbitrary a, Arbitrary a) =>
[(a, a, a, a)] -> Int -> [a] -> Gen [(a, a, a, a)]
worker [] ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
subordinates) [a]
subordinates
    go ((srv, organized) : acc) srvs

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)

type LocalRootsConfig = [( HotValency
                         , WarmValency
                         , Map RelayAccessPoint (LocalRootConfig ()))]

-- | The local root groups the provider publishes.
type LocalRootGroups = [( HotValency
                        , WarmValency
                        , Map SockAddr (LocalRootConfig ()))]

data Edit = EditFlags | EditTargets | Remove | Add
  deriving (Edit
Edit -> Edit -> Bounded Edit
forall a. a -> a -> Bounded a
$cminBound :: Edit
minBound :: Edit
$cmaxBound :: Edit
maxBound :: Edit
Bounded, Int -> Edit
Edit -> Int
Edit -> [Edit]
Edit -> Edit
Edit -> Edit -> [Edit]
Edit -> Edit -> Edit -> [Edit]
(Edit -> Edit)
-> (Edit -> Edit)
-> (Int -> Edit)
-> (Edit -> Int)
-> (Edit -> [Edit])
-> (Edit -> Edit -> [Edit])
-> (Edit -> Edit -> [Edit])
-> (Edit -> Edit -> Edit -> [Edit])
-> Enum Edit
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Edit -> Edit
succ :: Edit -> Edit
$cpred :: Edit -> Edit
pred :: Edit -> Edit
$ctoEnum :: Int -> Edit
toEnum :: Int -> Edit
$cfromEnum :: Edit -> Int
fromEnum :: Edit -> Int
$cenumFrom :: Edit -> [Edit]
enumFrom :: Edit -> [Edit]
$cenumFromThen :: Edit -> Edit -> [Edit]
enumFromThen :: Edit -> Edit -> [Edit]
$cenumFromTo :: Edit -> Edit -> [Edit]
enumFromTo :: Edit -> Edit -> [Edit]
$cenumFromThenTo :: Edit -> Edit -> Edit -> [Edit]
enumFromThenTo :: Edit -> Edit -> Edit -> [Edit]
Enum)

-- | A new local roots configuration for a reload of the given one: a
-- configuration of its own at an independent size, none at all, the same
-- one, or an edit of it which changes flags or targets, removes entries or
-- groups, or adds entries, IP addresses and domains of its own.
genReconfiguration :: LocalRootsConfig -> Gen LocalRootsConfig
genReconfiguration :: LocalRootsConfig -> Gen LocalRootsConfig
genReconfiguration LocalRootsConfig
old =
    [(Int, Gen LocalRootsConfig)] -> Gen LocalRootsConfig
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [ (Int
2, (Int -> Gen LocalRootsConfig) -> Gen LocalRootsConfig
forall a. (Int -> Gen a) -> Gen a
sized ((Int -> Gen LocalRootsConfig) -> Gen LocalRootsConfig)
-> (Int -> Gen LocalRootsConfig) -> Gen LocalRootsConfig
forall a b. (a -> b) -> a -> b
$ \Int
n -> do
                      n' <- (Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0, Int
n)
                      mockLocalRootPeers <$> resize n' genMockRoots)
              , (Int
1, LocalRootsConfig -> Gen LocalRootsConfig
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [])
              , (Int
1, LocalRootsConfig -> Gen LocalRootsConfig
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalRootsConfig
old)
              , (Int
8, do edits <- [(Int, Gen [Edit])] -> Gen [Edit]
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency
                                  [ (Int
3, (Edit -> [Edit] -> [Edit]
forall a. a -> [a] -> [a]
: []) (Edit -> [Edit]) -> Gen Edit -> Gen [Edit]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Edit] -> Gen Edit
forall a. HasCallStack => [a] -> Gen a
elements [Edit
forall a. Bounded a => a
minBound .. Edit
forall a. Bounded a => a
maxBound])
                                  , (Int
1, [Edit] -> Gen [Edit]
forall a. [a] -> Gen [a]
sublistOf [Edit
forall a. Bounded a => a
minBound .. Edit
forall a. Bounded a => a
maxBound]) ]
                       foldM edit old edits)
              ]
  where
    edit :: LocalRootsConfig -> Edit -> Gen LocalRootsConfig
    edit :: LocalRootsConfig -> Edit -> Gen LocalRootsConfig
edit LocalRootsConfig
conf Edit
EditFlags =
      ((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> Gen
      (HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig ())))
-> LocalRootsConfig -> Gen LocalRootsConfig
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(HotValency
h, WarmValency
w, Map RelayAccessPoint (LocalRootConfig ())
m) -> (HotValency
h, WarmValency
w,) (Map RelayAccessPoint (LocalRootConfig ())
 -> (HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ())))
-> Gen (Map RelayAccessPoint (LocalRootConfig ()))
-> Gen
     (HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LocalRootConfig () -> Gen (LocalRootConfig ()))
-> Map RelayAccessPoint (LocalRootConfig ())
-> Gen (Map RelayAccessPoint (LocalRootConfig ()))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map RelayAccessPoint a -> f (Map RelayAccessPoint b)
traverse (\LocalRootConfig ()
c -> [Gen (LocalRootConfig ())] -> Gen (LocalRootConfig ())
forall a. HasCallStack => [Gen a] -> Gen a
oneof [LocalRootConfig () -> Gen (LocalRootConfig ())
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LocalRootConfig ()
c, Gen (LocalRootConfig ())
forall a. Arbitrary a => Gen a
arbitrary]) Map RelayAccessPoint (LocalRootConfig ())
m) LocalRootsConfig
conf
    edit LocalRootsConfig
conf Edit
EditTargets =
      ((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> Gen
      (HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig ())))
-> LocalRootsConfig -> Gen LocalRootsConfig
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\g :: (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
g@(HotValency
_, WarmValency
_, Map RelayAccessPoint (LocalRootConfig ())
m) -> [Gen
   (HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ()))]
-> Gen
     (HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig ()))
forall a. HasCallStack => [Gen a] -> Gen a
oneof [(HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
-> Gen
     (HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig ()))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
g, (\(HotValency
h, WarmValency
w) -> (HotValency
h, WarmValency
w, Map RelayAccessPoint (LocalRootConfig ())
m)) ((HotValency, WarmValency)
 -> (HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ())))
-> Gen (HotValency, WarmValency)
-> Gen
     (HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (HotValency, WarmValency)
genTargets]) LocalRootsConfig
conf
    edit LocalRootsConfig
conf Edit
Remove =
      LocalRootsConfig -> Gen LocalRootsConfig
forall a. [a] -> Gen [a]
sublistOf LocalRootsConfig
conf
      Gen LocalRootsConfig
-> (LocalRootsConfig -> Gen LocalRootsConfig)
-> Gen LocalRootsConfig
forall a b. Gen a -> (a -> Gen b) -> Gen b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> Gen
      (HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig ())))
-> LocalRootsConfig -> Gen LocalRootsConfig
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(HotValency
h, WarmValency
w, Map RelayAccessPoint (LocalRootConfig ())
m) -> (HotValency
h, WarmValency
w,) (Map RelayAccessPoint (LocalRootConfig ())
 -> (HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ())))
-> ([(RelayAccessPoint, LocalRootConfig ())]
    -> Map RelayAccessPoint (LocalRootConfig ()))
-> [(RelayAccessPoint, LocalRootConfig ())]
-> (HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(RelayAccessPoint, LocalRootConfig ())]
-> Map RelayAccessPoint (LocalRootConfig ())
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(RelayAccessPoint, LocalRootConfig ())]
 -> (HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ())))
-> Gen [(RelayAccessPoint, LocalRootConfig ())]
-> Gen
     (HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RelayAccessPoint, LocalRootConfig ())]
-> Gen [(RelayAccessPoint, LocalRootConfig ())]
forall a. [a] -> Gen [a]
sublistOf (Map RelayAccessPoint (LocalRootConfig ())
-> [(RelayAccessPoint, LocalRootConfig ())]
forall k a. Map k a -> [(k, a)]
Map.toList Map RelayAccessPoint (LocalRootConfig ())
m))
    edit LocalRootsConfig
conf Edit
Add = do
      new <- ([(RelayAccessPoint, LocalRootConfig ())]
 -> Map RelayAccessPoint (LocalRootConfig ()))
-> Gen [(RelayAccessPoint, LocalRootConfig ())]
-> Gen (Map RelayAccessPoint (LocalRootConfig ()))
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(RelayAccessPoint, LocalRootConfig ())]
-> Map RelayAccessPoint (LocalRootConfig ())
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (Gen [(RelayAccessPoint, LocalRootConfig ())]
 -> Gen (Map RelayAccessPoint (LocalRootConfig ())))
-> (Gen (RelayAccessPoint, LocalRootConfig ())
    -> Gen [(RelayAccessPoint, LocalRootConfig ())])
-> Gen (RelayAccessPoint, LocalRootConfig ())
-> Gen (Map RelayAccessPoint (LocalRootConfig ()))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gen (RelayAccessPoint, LocalRootConfig ())
-> Gen [(RelayAccessPoint, LocalRootConfig ())]
forall a. Gen a -> Gen [a]
listOf1 (Gen (RelayAccessPoint, LocalRootConfig ())
 -> Gen (Map RelayAccessPoint (LocalRootConfig ())))
-> Gen (RelayAccessPoint, LocalRootConfig ())
-> Gen (Map RelayAccessPoint (LocalRootConfig ()))
forall a b. (a -> b) -> a -> b
$ (,) (RelayAccessPoint
 -> LocalRootConfig () -> (RelayAccessPoint, LocalRootConfig ()))
-> Gen RelayAccessPoint
-> Gen
     (LocalRootConfig () -> (RelayAccessPoint, LocalRootConfig ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen RelayAccessPoint
genEntry Gen (LocalRootConfig () -> (RelayAccessPoint, LocalRootConfig ()))
-> Gen (LocalRootConfig ())
-> Gen (RelayAccessPoint, LocalRootConfig ())
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (LocalRootConfig ())
forall a. Arbitrary a => Gen a
arbitrary
      i <- chooseInt (0, length conf)
      if i == length conf
        then (\(HotValency
h, WarmValency
w) -> LocalRootsConfig
conf LocalRootsConfig -> LocalRootsConfig -> LocalRootsConfig
forall a. [a] -> [a] -> [a]
++ [(HotValency
h, WarmValency
w, Map RelayAccessPoint (LocalRootConfig ())
new)]) <$> genTargets
        else pure [ if j == i then (h, w, m <> new) else g
                  | (j, g@(h, w, m)) <- zip [0 ..] conf ]

    -- an entry of the new configuration's own: a domain is named apart from
    -- those of 'genMockRoots'
    genEntry :: Gen RelayAccessPoint
    genEntry :: Gen RelayAccessPoint
genEntry = [(Int, Gen RelayAccessPoint)] -> Gen RelayAccessPoint
forall a. HasCallStack => [(Int, Gen a)] -> Gen a
frequency [ (Int
2, IP -> PortNumber -> RelayAccessPoint
RelayAccessAddress (IP -> PortNumber -> RelayAccessPoint)
-> Gen IP -> Gen (PortNumber -> RelayAccessPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen IP
genIPv4 Gen (PortNumber -> RelayAccessPoint)
-> Gen PortNumber -> Gen RelayAccessPoint
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen PortNumber
genPort)
                         , (Int
1, Domain -> PortNumber -> RelayAccessPoint
RelayAccessDomain (Domain -> PortNumber -> RelayAccessPoint)
-> Gen Domain -> Gen (PortNumber -> RelayAccessPoint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Domain
genNewDomain Gen (PortNumber -> RelayAccessPoint)
-> Gen PortNumber -> Gen RelayAccessPoint
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen PortNumber
genPort)
                         , (Int
1, Domain -> RelayAccessPoint
RelayAccessSRVDomain (Domain -> RelayAccessPoint) -> Gen Domain -> Gen RelayAccessPoint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Domain
genNewDomain) ]
    genPort :: Gen PortNumber
genPort = Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> PortNumber) -> Gen Int -> Gen PortNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
chooseInt (Int
1, Int
65535)
    genNewDomain :: Gen Domain
genNewDomain = (Domain -> Domain -> Domain
forall a. Semigroup a => a -> a -> a
<> Domain
"new") (Domain -> Domain) -> Gen Domain -> Gen Domain
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Domain
genDomainName

-- | Shrinks groups away, entries out of groups, targets towards one, and
-- entries towards a plain configuration.
shrinkLocalRootsConfig :: LocalRootsConfig -> [LocalRootsConfig]
shrinkLocalRootsConfig :: LocalRootsConfig -> [LocalRootsConfig]
shrinkLocalRootsConfig = ((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> LocalRootsConfig)
-> LocalRootsConfig -> [LocalRootsConfig]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
-> LocalRootsConfig
forall {a}.
Ord a =>
(HotValency, WarmValency, Map a (LocalRootConfig ()))
-> [(HotValency, WarmValency, Map a (LocalRootConfig ()))]
group
  where
    group :: (HotValency, WarmValency, Map a (LocalRootConfig ()))
-> [(HotValency, WarmValency, Map a (LocalRootConfig ()))]
group (HotValency
h, WarmValency
w, Map a (LocalRootConfig ())
m) =
         [ (HotValency
h', WarmValency
w', Map a (LocalRootConfig ())
m) | (HotValency
h', WarmValency
w') <- (HotValency, WarmValency) -> [(HotValency, WarmValency)]
targets (HotValency
h, WarmValency
w) ]
      [(HotValency, WarmValency, Map a (LocalRootConfig ()))]
-> [(HotValency, WarmValency, Map a (LocalRootConfig ()))]
-> [(HotValency, WarmValency, Map a (LocalRootConfig ()))]
forall a. [a] -> [a] -> [a]
++ [ (HotValency
h, WarmValency
w, [(a, LocalRootConfig ())] -> Map a (LocalRootConfig ())
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(a, LocalRootConfig ())]
m') | [(a, LocalRootConfig ())]
m' <- ((a, LocalRootConfig ()) -> [(a, LocalRootConfig ())])
-> [(a, LocalRootConfig ())] -> [[(a, LocalRootConfig ())]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (a, LocalRootConfig ()) -> [(a, LocalRootConfig ())]
forall {a}. (a, LocalRootConfig ()) -> [(a, LocalRootConfig ())]
entry (Map a (LocalRootConfig ()) -> [(a, LocalRootConfig ())]
forall k a. Map k a -> [(k, a)]
Map.toList Map a (LocalRootConfig ())
m) ]
    targets :: (HotValency, WarmValency) -> [(HotValency, WarmValency)]
targets (HotValency
h, WarmValency
w) =
      [ (HotValency
1, WarmValency
1) | (HotValency
h, WarmValency
w) (HotValency, WarmValency) -> (HotValency, WarmValency) -> Bool
forall a. Eq a => a -> a -> Bool
/= (HotValency
1, WarmValency
1) ]
      [(HotValency, WarmValency)]
-> [(HotValency, WarmValency)] -> [(HotValency, WarmValency)]
forall a. [a] -> [a] -> [a]
++ [ (HotValency
1, WarmValency
w) | HotValency
h HotValency -> HotValency -> Bool
forall a. Eq a => a -> a -> Bool
/= HotValency
1, WarmValency
w WarmValency -> WarmValency -> Bool
forall a. Eq a => a -> a -> Bool
/= WarmValency
1 ]
      [(HotValency, WarmValency)]
-> [(HotValency, WarmValency)] -> [(HotValency, WarmValency)]
forall a. [a] -> [a] -> [a]
++ [ (HotValency
h, Int -> WarmValency
WarmValency (HotValency -> Int
getHotValency HotValency
h)) | HotValency -> Int
getHotValency HotValency
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< WarmValency -> Int
getWarmValency WarmValency
w, HotValency
h HotValency -> HotValency -> Bool
forall a. Eq a => a -> a -> Bool
/= HotValency
1 ]
    entry :: (a, LocalRootConfig ()) -> [(a, LocalRootConfig ())]
entry (a
rap, LocalRootConfig ()
c) = [ (a
rap, LocalRootConfig ()
plain) | LocalRootConfig ()
c LocalRootConfig () -> LocalRootConfig () -> Bool
forall a. Eq a => a -> a -> Bool
/= LocalRootConfig ()
plain ]
    plain :: LocalRootConfig ()
plain = PeerAdvertise
-> DiffusionMode -> Provenance -> () -> LocalRootConfig ()
forall extraFlags.
PeerAdvertise
-> DiffusionMode
-> Provenance
-> extraFlags
-> LocalRootConfig extraFlags
LocalRootConfig PeerAdvertise
DoNotAdvertisePeer DiffusionMode
InitiatorAndResponderDiffusionMode Provenance
Outbound ()

instance Arbitrary MockRoots where
    arbitrary :: Gen MockRoots
arbitrary = Gen MockRoots
genMockRoots
    shrink :: MockRoots -> [MockRoots]
shrink roots :: MockRoots
roots@MockRoots
      { LocalRootsConfig
mockLocalRootPeers :: MockRoots -> LocalRootsConfig
mockLocalRootPeers :: LocalRootsConfig
mockLocalRootPeers
      , Script MockDNSMap
mockLocalRootPeersDNSMap :: MockRoots -> Script MockDNSMap
mockLocalRootPeersDNSMap :: Script MockDNSMap
mockLocalRootPeersDNSMap
      , Map RelayAccessPoint PeerAdvertise
mockPublicRootPeers :: MockRoots -> Map RelayAccessPoint PeerAdvertise
mockPublicRootPeers :: Map RelayAccessPoint PeerAdvertise
mockPublicRootPeers
      , Script MockDNSMap
mockPublicRootPeersDNSMap :: MockRoots -> Script MockDNSMap
mockPublicRootPeersDNSMap :: Script MockDNSMap
mockPublicRootPeersDNSMap
      } =
      [ MockRoots
roots { mockLocalRootPeers        = lrp
              , mockLocalRootPeersDNSMap  = lrpDNSMap
              }
      | LocalRootsConfig
lrp <- ((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> LocalRootsConfig)
-> LocalRootsConfig -> [LocalRootsConfig]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (LocalRootsConfig
-> (HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ()))
-> LocalRootsConfig
forall a b. a -> b -> a
const []) LocalRootsConfig
mockLocalRootPeers,
        let lrpDomains :: Set (Domain, TYPE)
lrpDomains =
              [(Domain, TYPE)] -> Set (Domain, TYPE)
forall a. Ord a => [a] -> Set a
Set.fromList ([(Domain, TYPE)] -> Set (Domain, TYPE))
-> [(Domain, TYPE)] -> Set (Domain, TYPE)
forall a b. (a -> b) -> a -> b
$
                ((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> [(Domain, TYPE)])
-> LocalRootsConfig -> [(Domain, TYPE)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
                  ((RelayAccessPoint -> Maybe (Domain, TYPE))
-> [RelayAccessPoint] -> [(Domain, TYPE)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                    (\case
                        RelayAccessDomain Domain
d PortNumber
_p -> (Domain, TYPE) -> Maybe (Domain, TYPE)
forall a. a -> Maybe a
Just (Domain
d, TYPE
DNS.A)
                        RelayAccessSRVDomain Domain
d -> (Domain, TYPE) -> Maybe (Domain, TYPE)
forall a. a -> Maybe a
Just (Domain
d, TYPE
DNS.SRV)
                        RelayAccessPoint
_otherwise -> Maybe (Domain, TYPE)
forall a. Maybe a
Nothing)
                    ([RelayAccessPoint] -> [(Domain, TYPE)])
-> ((HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ()))
    -> [RelayAccessPoint])
-> (HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ()))
-> [(Domain, TYPE)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map RelayAccessPoint (LocalRootConfig ()) -> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys (Map RelayAccessPoint (LocalRootConfig ()) -> [RelayAccessPoint])
-> ((HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ()))
    -> Map RelayAccessPoint (LocalRootConfig ()))
-> (HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ()))
-> [RelayAccessPoint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
-> Map RelayAccessPoint (LocalRootConfig ())
forall {a} {b} {c}. (a, b, c) -> c
thrd)
                  LocalRootsConfig
lrp
            lrpDNSMap :: Script MockDNSMap
lrpDNSMap  = (MockDNSMap -> Set (Domain, TYPE) -> MockDNSMap
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set (Domain, TYPE)
lrpDomains)
                       (MockDNSMap -> MockDNSMap)
-> Script MockDNSMap -> Script MockDNSMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Script MockDNSMap
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, TYPE)
prpDomains = [(Domain, TYPE)] -> Set (Domain, TYPE)
forall a. Ord a => [a] -> Set a
Set.fromList ([(Domain, TYPE)] -> Set (Domain, TYPE))
-> [(Domain, TYPE)] -> Set (Domain, TYPE)
forall a b. (a -> b) -> a -> b
$
              ((RelayAccessPoint, PeerAdvertise) -> Maybe (Domain, TYPE))
-> [(RelayAccessPoint, PeerAdvertise)] -> [(Domain, TYPE)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
                ((\case
                    RelayAccessDomain Domain
d PortNumber
_p -> (Domain, TYPE) -> Maybe (Domain, TYPE)
forall a. a -> Maybe a
Just (Domain
d, TYPE
DNS.A)
                    RelayAccessSRVDomain Domain
d -> (Domain, TYPE) -> Maybe (Domain, TYPE)
forall a. a -> Maybe a
Just (Domain
d, TYPE
DNS.SRV)
                    RelayAccessPoint
_otherwise -> Maybe (Domain, TYPE)
forall a. Maybe a
Nothing) (RelayAccessPoint -> Maybe (Domain, TYPE))
-> ((RelayAccessPoint, PeerAdvertise) -> RelayAccessPoint)
-> (RelayAccessPoint, PeerAdvertise)
-> Maybe (Domain, TYPE)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RelayAccessPoint, PeerAdvertise) -> RelayAccessPoint
forall a b. (a, b) -> a
fst)
               (Map RelayAccessPoint PeerAdvertise
-> [(RelayAccessPoint, PeerAdvertise)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map RelayAccessPoint PeerAdvertise
prp)
            prpDNSMap :: Script MockDNSMap
prpDNSMap  = (MockDNSMap -> Set (Domain, TYPE) -> MockDNSMap
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set (Domain, TYPE)
prpDomains)
                       (MockDNSMap -> MockDNSMap)
-> Script MockDNSMap -> Script MockDNSMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Script MockDNSMap
mockPublicRootPeersDNSMap
      ]
        where
          thrd :: (a, b, c) -> c
thrd (a
_, b
_, c
c) = c
c

-- | Used for debugging in GHCI
--
simpleMockRoots :: MockRoots
simpleMockRoots :: MockRoots
simpleMockRoots = LocalRootsConfig
-> Script MockDNSMap
-> Map RelayAccessPoint PeerAdvertise
-> Script MockDNSMap
-> MockRoots
MockRoots LocalRootsConfig
localRootPeers Script MockDNSMap
forall {b}. Script (Map (Domain, TYPE) (Either [(IP, TTL)] b))
dnsMap Map RelayAccessPoint PeerAdvertise
forall k a. Map k a
Map.empty (MockDNSMap -> Script MockDNSMap
forall a. a -> Script a
singletonScript MockDNSMap
forall k a. Map k a
Map.empty)
  where
    localRootPeers :: LocalRootsConfig
localRootPeers =
      [ ( HotValency
2, WarmValency
2
        , [(RelayAccessPoint, LocalRootConfig ())]
-> Map RelayAccessPoint (LocalRootConfig ())
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
-> DiffusionMode -> Provenance -> () -> LocalRootConfig ()
forall extraFlags.
PeerAdvertise
-> DiffusionMode
-> Provenance
-> extraFlags
-> LocalRootConfig extraFlags
LocalRootConfig PeerAdvertise
DoAdvertisePeer DiffusionMode
InitiatorAndResponderDiffusionMode Provenance
Outbound ()
            )
          , ( Domain -> PortNumber -> RelayAccessPoint
RelayAccessDomain  Domain
"test.domain"      ([Char] -> PortNumber
forall a. Read a => [Char] -> a
read [Char]
"4444")
            , PeerAdvertise
-> DiffusionMode -> Provenance -> () -> LocalRootConfig ()
forall extraFlags.
PeerAdvertise
-> DiffusionMode
-> Provenance
-> extraFlags
-> LocalRootConfig extraFlags
LocalRootConfig PeerAdvertise
DoNotAdvertisePeer DiffusionMode
InitiatorAndResponderDiffusionMode Provenance
Outbound ()
            )
          ]
        )
      ]
    dnsMap :: Script (Map (Domain, TYPE) (Either [(IP, TTL)] b))
dnsMap = Map (Domain, TYPE) (Either [(IP, TTL)] b)
-> Script (Map (Domain, TYPE) (Either [(IP, TTL)] b))
forall a. a -> Script a
singletonScript (Map (Domain, TYPE) (Either [(IP, TTL)] b)
 -> Script (Map (Domain, TYPE) (Either [(IP, TTL)] b)))
-> Map (Domain, TYPE) (Either [(IP, TTL)] b)
-> Script (Map (Domain, TYPE) (Either [(IP, TTL)] b))
forall a b. (a -> b) -> a -> b
$ [((Domain, TYPE), Either [(IP, TTL)] b)]
-> Map (Domain, TYPE) (Either [(IP, TTL)] b)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
              [ ((Domain
"test.domain", TYPE
DNS.A), [(IP, TTL)] -> Either [(IP, TTL)] b
forall a b. a -> Either a b
Left [[Char] -> (IP, TTL)
forall a. Read a => [Char] -> a
read [Char]
"192.1.1.1", [Char] -> (IP, TTL)
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. HasCallStack => 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

-- | Whether the timeouts and delays are whole milliseconds, as 'genDiffTime'
-- draws them and their shrinkers keep them; the reload instant of
-- 'reloadDelay' relies on it.
wholeMilliseconds :: Script DNSTimeout -> Script DNSLookupDelay -> Bool
wholeMilliseconds :: Script DNSTimeout -> Script DNSLookupDelay -> Bool
wholeMilliseconds (Script NonEmpty DNSTimeout
timeouts) (Script NonEmpty DNSLookupDelay
delays) =
     (DNSTimeout -> Bool) -> NonEmpty DNSTimeout -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (DiffTime -> Bool
wholeMillisecond (DiffTime -> Bool)
-> (DNSTimeout -> DiffTime) -> DNSTimeout -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSTimeout -> DiffTime
getDNSTimeout) NonEmpty DNSTimeout
timeouts
  Bool -> Bool -> Bool
&& (DNSLookupDelay -> Bool) -> NonEmpty DNSLookupDelay -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (DiffTime -> Bool
wholeMillisecond (DiffTime -> Bool)
-> (DNSLookupDelay -> DiffTime) -> DNSLookupDelay -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSLookupDelay -> DiffTime
getDNSLookupDelay) NonEmpty DNSLookupDelay
delays
  where
    wholeMillisecond :: DiffTime -> Bool
wholeMillisecond DiffTime
t = DiffTime -> Integer
diffTimeToPicoseconds DiffTime
t Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` Integer
1_000_000_000 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0


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
    -- in whole milliseconds, as drawn
    shrink :: DNSTimeout -> [DNSTimeout]
shrink (DNSTimeout DiffTime
delta) =
      [ DiffTime -> DNSTimeout
DNSTimeout (Integer -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
ms DiffTime -> DiffTime -> DiffTime
forall a. Fractional a => a -> a -> a
/ DiffTime
1000)
      | Integer
ms <- Integer -> [Integer]
forall a. Arbitrary a => a -> [a]
shrink (DiffTime -> Integer
forall b. Integral b => DiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (DiffTime
delta DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
1000) :: Integer)
      , Integer
ms Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= 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
    -- in whole milliseconds, as drawn
    shrink :: DNSLookupDelay -> [DNSLookupDelay]
shrink (DNSLookupDelay DiffTime
delta) =
      [ DiffTime -> DNSLookupDelay
DNSLookupDelay (Integer -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
ms DiffTime -> DiffTime -> DiffTime
forall a. Fractional a => a -> a -> a
/ DiffTime
1000)
      | Integer
ms <- Integer -> [Integer]
forall a. Arbitrary a => a -> [a]
shrink (DiffTime -> Integer
forall b. Integral b => DiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (DiffTime
delta DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
1000) :: Integer)
      , Integer
ms Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
20
      ]

-- | Mock DNSActions data structure for testing purposes.
-- Adds DNS Lookup function for IOSim with different timeout and lookup
-- delays for every attempt.
mockDNSActions :: forall peerAddr m.
                  ( MonadDelay m
                  , MonadTimer m
                  , MonadAsync m
                  )
               => Tracer m DNSTrace
               -> DNSLookupType
               -> (IP -> PortNumber -> peerAddr)
               -> StrictTVar m MockDNSMap
               -> StrictTVar m (Script DNSTimeout)
               -> StrictTVar m (Script DNSLookupDelay)
               -> DNSActions peerAddr () m
mockDNSActions :: forall peerAddr (m :: * -> *).
(MonadDelay m, MonadTimer m, MonadAsync m) =>
Tracer m DNSTrace
-> DNSLookupType
-> (IP -> PortNumber -> peerAddr)
-> StrictTVar m MockDNSMap
-> StrictTVar m (Script DNSTimeout)
-> StrictTVar m (Script DNSLookupDelay)
-> DNSActions peerAddr () m
mockDNSActions Tracer m DNSTrace
tracer DNSLookupType
ofType0 IP -> PortNumber -> peerAddr
toPeerAddr StrictTVar m MockDNSMap
dnsMapVar StrictTVar m (Script DNSTimeout)
dnsTimeoutScript StrictTVar m (Script DNSLookupDelay)
dnsLookupDelayScript =
    DNSActions {
      ResolvConf -> m (Resource m (Either DNSorIOError ()))
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 ()))
dnsResolverResource,
      ResolvConf -> m (Resource m (Either DNSorIOError ()))
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 ()))
dnsAsyncResolverResource,
      dnsLookupWithTTL :: DNSPeersKind
-> RelayAccessPoint
-> ResolvConf
-> ()
-> StdGen
-> m (DNSLookupResult peerAddr)
dnsLookupWithTTL = DNSLookupType
-> (()
    -> ResolvConf
    -> Domain
    -> TYPE
    -> m (Maybe (Either DNSError DNSMessage)))
-> Tracer m DNSTrace
-> (IP -> PortNumber -> peerAddr)
-> DNSPeersKind
-> RelayAccessPoint
-> ResolvConf
-> ()
-> StdGen
-> m (DNSLookupResult peerAddr)
forall (m :: * -> *) resolver resolvConf peerAddr.
MonadAsync m =>
DNSLookupType
-> (resolver
    -> resolvConf
    -> Domain
    -> TYPE
    -> m (Maybe (Either DNSError DNSMessage)))
-> Tracer m DNSTrace
-> (IP -> PortNumber -> peerAddr)
-> DNSPeersKind
-> RelayAccessPoint
-> resolvConf
-> resolver
-> StdGen
-> m (DNSLookupResult peerAddr)
dispatchLookupWithTTL DNSLookupType
ofType0 ()
-> ResolvConf
-> Domain
-> TYPE
-> m (Maybe (Either DNSError DNSMessage))
forall resolver resolvConf.
resolver
-> resolvConf
-> Domain
-> TYPE
-> m (Maybe (Either DNSError DNSMessage))
mockLookup Tracer m DNSTrace
tracer IP -> PortNumber -> peerAddr
toPeerAddr
    }
 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 ())

   mockLookup :: resolver
              -> resolvConf
              -> DNS.Domain
              -> DNS.TYPE
              -> m (Maybe (Either DNSError DNSMessage))
   mockLookup :: forall resolver resolvConf.
resolver
-> resolvConf
-> Domain
-> TYPE
-> m (Maybe (Either DNSError DNSMessage))
mockLookup resolver
_ resolvConf
_ Domain
domain TYPE
ofType = do
     dnsMap <- StrictTVar m MockDNSMap -> m MockDNSMap
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m MockDNSMap
dnsMapVar
     DNSTimeout dnsTimeout <- stepScript' dnsTimeoutScript
     DNSLookupDelay dnsLookupDelay <- stepScript' dnsLookupDelayScript

     MonadTimer.timeout dnsTimeout do
       MonadTimer.threadDelay dnsLookupDelay
       case Map.lookup (domain, ofType) dnsMap of
         Maybe (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
Nothing -> Either DNSError DNSMessage -> m (Either DNSError DNSMessage)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DNSError -> Either DNSError DNSMessage
forall a b. a -> Either a b
Left DNSError
NameError)
         Just Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
x  -> Either DNSError DNSMessage -> m (Either DNSError DNSMessage)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DNSMessage -> Either DNSError DNSMessage
forall a b. b -> Either a b
Right (DNSMessage -> Either DNSError DNSMessage)
-> DNSMessage -> Either DNSError DNSMessage
forall a b. (a -> b) -> a -> b
$ Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
-> DNSMessage
toDNSMessage Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
x)

     where
       toDNSMessage :: Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
-> DNSMessage
toDNSMessage = \case
         Left [(IP, TTL)]
ipsttls ->
           DNSMessage
defaultResponse {
             answer = [ResourceRecord domain DNS.NULL 0 ttl rdata
                      | (ip, ttl) <- ipsttls
                      , let rdata = case IP
ip of
                              IPv4 IPv4
ip' -> IPv4 -> RData
DNS.RD_A IPv4
ip'
                              IPv6 IPv6
ip' -> IPv6 -> RData
DNS.RD_AAAA IPv6
ip']}
         Right [(Domain, Word16, Word16, PortNumber)]
ds ->
           DNSMessage
defaultResponse {
             answer = [ResourceRecord domain DNS.NULL 0 0 rdata
                      | (domain', prio, weight, port) <- ds
                      , let rdata = Word16 -> Word16 -> Word16 -> Domain -> RData
DNS.RD_SRV Word16
prio Word16
weight (PortNumber -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral PortNumber
port) Domain
domain']}

-- | When 'mockLocalRootPeersProvider' applies its reconfiguration: half a
-- millisecond past the second, when no lookup completes, as the delays and
-- timeouts are whole milliseconds and the TTL waits whole seconds. An answer
-- committed in the instant of the reload could have its thread stopped before
-- it is traced.
reloadDelay :: DiffTime
reloadDelay :: DiffTime
reloadDelay = DiffTime
100.0005

-- | 'localRootPeersProvider' running with a given MockRoots env
--
mockLocalRootPeersProvider :: forall m.
                              ( Alternative (STM m)
                              , MonadAsync    m
                              , MonadDelay    m
                              , MonadThrow    m
                              , MonadTimer    m
                              , MonadTraceSTM m
                              , MonadLabelledSTM m
                              )
                           => Tracer m (TestTraceEvent (TraceLocalRootPeers () SockAddr))
                           -> MockRoots
                           -> Maybe [( HotValency
                                     , WarmValency
                                     , Map RelayAccessPoint (LocalRootConfig ()))]
                           -- ^ a reconfiguration, applied after 'reloadDelay'
                           -> Script DNSTimeout
                           -> Script DNSLookupDelay
                           -> TestSeed
                           -> m ()
mockLocalRootPeersProvider :: forall (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 MonadTimer m, MonadTraceSTM m, MonadLabelledSTM m) =>
Tracer m (TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> MockRoots
-> Maybe LocalRootsConfig
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> m ()
mockLocalRootPeersProvider Tracer m (TestTraceEvent (TraceLocalRootPeers () SockAddr))
tracer (MockRoots LocalRootsConfig
localRootPeers Script MockDNSMap
dnsMapScript Map RelayAccessPoint PeerAdvertise
_ Script MockDNSMap
_) Maybe LocalRootsConfig
reconfiguration
                           Script DNSTimeout
dnsTimeoutScript Script DNSLookupDelay
dnsLookupDelayScript TestSeed
dnsSeed = do
      dnsMapScriptVar <- Script MockDNSMap -> m (StrictTVar m (Script MockDNSMap))
forall (m :: * -> *) a.
MonadSTM m =>
Script a -> m (StrictTVar m (Script a))
initScript' Script MockDNSMap
dnsMapScript
      dnsMap <- stepScript' dnsMapScriptVar
      dnsMapVar <- newTVarIO dnsMap

      dnsTimeoutScriptVar <- initScript' dnsTimeoutScript
      dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
      localRootPeersVar <- newTVarIO localRootPeers
      resultVar <- newTVarIO mempty
      traceTVarIO resultVar (\Maybe
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
_ [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups -> TraceValue -> InspectMonadSTM m TraceValue
forall a. a -> InspectMonadSTM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Published -> TraceValue
forall tr. Typeable tr => tr -> TraceValue
TraceDynamic ([(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> Published
Published [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups)))
      withAsync (updateDNSMap dnsMapScriptVar dnsMapVar) $ \Async m Void
_ ->
        m () -> (Async m () -> m ()) -> m ()
forall a b. m a -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync (StrictTVar m LocalRootsConfig -> m ()
reconfigure StrictTVar m LocalRootsConfig
localRootPeersVar) ((Async m () -> m ()) -> m ()) -> (Async m () -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Async m ()
_ -> 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)
-> PeerActionsDNS SockAddr () m
-> ResolvConf
-> StdGen
-> STM m LocalRootsConfig
-> StrictTVar
     m [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> m Void
forall (m :: * -> *) extraFlags peerAddr resolver.
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 Ord peerAddr, Eq extraFlags) =>
Tracer m (TraceLocalRootPeers extraFlags peerAddr)
-> PeerActionsDNS peerAddr resolver m
-> ResolvConf
-> StdGen
-> STM
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> StrictTVar
     m
     [(HotValency, WarmValency,
       Map peerAddr (LocalRootConfig extraFlags))]
-> m Void
localRootPeersProvider ((TraceLocalRootPeers () SockAddr
 -> TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> Tracer m (TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> Tracer m (TraceLocalRootPeers () SockAddr)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap TraceLocalRootPeers () SockAddr
-> TestTraceEvent (TraceLocalRootPeers () SockAddr)
forall a b. a -> Either a b
Left Tracer m (TestTraceEvent (TraceLocalRootPeers () SockAddr))
tracer)
                                 PeerActionsDNS {
                                   paToPeerAddr :: IP -> PortNumber -> SockAddr
paToPeerAddr = ((IP, PortNumber) -> SockAddr) -> IP -> PortNumber -> SockAddr
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (IP, PortNumber) -> SockAddr
toSockAddr,
                                   paDnsActions :: DNSActions SockAddr () m
paDnsActions =
                                     Tracer m DNSTrace
-> DNSLookupType
-> (IP -> PortNumber -> SockAddr)
-> StrictTVar m MockDNSMap
-> StrictTVar m (Script DNSTimeout)
-> StrictTVar m (Script DNSLookupDelay)
-> DNSActions SockAddr () m
forall peerAddr (m :: * -> *).
(MonadDelay m, MonadTimer m, MonadAsync m) =>
Tracer m DNSTrace
-> DNSLookupType
-> (IP -> PortNumber -> peerAddr)
-> StrictTVar m MockDNSMap
-> StrictTVar m (Script DNSTimeout)
-> StrictTVar m (Script DNSLookupDelay)
-> DNSActions peerAddr () m
mockDNSActions
                                       ((DNSTrace -> TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> Tracer m (TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> Tracer m DNSTrace
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap DNSTrace -> TestTraceEvent (TraceLocalRootPeers () SockAddr)
forall a b. b -> Either a b
Right Tracer m (TestTraceEvent (TraceLocalRootPeers () SockAddr))
tracer)
                                       DNSLookupType
LookupReqAOnly
                                       (((IP, PortNumber) -> SockAddr) -> IP -> PortNumber -> SockAddr
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (IP, PortNumber) -> SockAddr
toSockAddr)
                                       StrictTVar m MockDNSMap
dnsMapVar
                                       StrictTVar m (Script DNSTimeout)
dnsTimeoutScriptVar
                                       StrictTVar m (Script DNSLookupDelay)
dnsLookupDelayScriptVar
                                 }
                                 ResolvConf
DNSResolver.defaultResolvConf
                                 (Int -> StdGen
mkStdGen (Int -> StdGen) -> Int -> StdGen
forall a b. (a -> b) -> a -> b
$ TestSeed -> Int
unTestSeed TestSeed
dnsSeed)
                                 (StrictTVar m LocalRootsConfig -> STM m LocalRootsConfig
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m LocalRootsConfig
localRootPeersVar)
                                 StrictTVar
  m [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
resultVar
        -- if the groups never differ from the empty ones `resultVar` starts
        -- with, `localRootPeersProvider` never writes to it, and the
        -- `traceTVarIO` callback never executes. By reading & writing to the
        -- `TVar` we are forcing it to run at least once.
        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 (LocalRootConfig ()))]
-> STM
     m [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
resultVar STM
  m [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> ([(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
    -> 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 (LocalRootConfig ()))]
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar
  m [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
resultVar
  where
    reconfigure :: StrictTVar m [( HotValency
                                 , WarmValency
                                 , Map RelayAccessPoint (LocalRootConfig ()))]
                -> m ()
    reconfigure :: StrictTVar m LocalRootsConfig -> m ()
reconfigure StrictTVar m LocalRootsConfig
localRootPeersVar = do
      DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
reloadDelay
      case Maybe LocalRootsConfig
reconfiguration of
           Just LocalRootsConfig
localRootPeers' -> STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m LocalRootsConfig -> LocalRootsConfig -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m LocalRootsConfig
localRootPeersVar LocalRootsConfig
localRootPeers')
           Maybe LocalRootsConfig
Nothing              -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    updateDNSMap :: StrictTVar m (Script MockDNSMap)
                 -> StrictTVar m MockDNSMap
                 -> m Void
    updateDNSMap :: StrictTVar m (Script MockDNSMap)
-> StrictTVar m MockDNSMap -> m Void
updateDNSMap StrictTVar m (Script MockDNSMap)
dnsMapScriptVar StrictTVar m MockDNSMap
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 MockDNSMap) -> m MockDNSMap
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m (Script a) -> m a
stepScript' StrictTVar m (Script MockDNSMap)
dnsMapScriptVar
        atomically (writeTVar dnsMapVar dnsMap)


-- | 'publicRootPeersProvider' running with a given MockRoots env.
--
-- NOTE: This function is used in 'prop_public_resolvesDomainsCorrectly'. Due to
-- API limitations it is needed to run 'publicRootPeersProvider' multiple times,
-- in order to run only 1 simulation which resolves untill we get the expected
-- result, instead of a recursive loop which at each step runs IOSim.
--
mockPublicRootPeersProvider :: forall m a.
                               ( MonadAsync m
                               , MonadDelay m
                               , MonadThrow m
                               , MonadTimer m
                               )
                            => Tracer m (TestTraceEvent TracePublicRootPeers)
                            -> MockRoots
                            -> Script DNSTimeout
                            -> Script DNSLookupDelay
                            -> TestSeed
                            -> ((Int -> m (Map SockAddr PeerAdvertise, TTL)) -> m a)
                            -> m ()
mockPublicRootPeersProvider :: forall (m :: * -> *) a.
(MonadAsync m, MonadDelay m, MonadThrow m, MonadTimer m) =>
Tracer m (TestTraceEvent TracePublicRootPeers)
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> ((Int -> m (Map SockAddr PeerAdvertise, TTL)) -> m a)
-> m ()
mockPublicRootPeersProvider Tracer m (TestTraceEvent TracePublicRootPeers)
tracer (MockRoots LocalRootsConfig
_ Script MockDNSMap
_ Map RelayAccessPoint PeerAdvertise
publicRootPeers Script MockDNSMap
dnsMapScript)
                            Script DNSTimeout
dnsTimeoutScript Script DNSLookupDelay
dnsLookupDelayScript TestSeed
dnsSeed (Int -> m (Map SockAddr PeerAdvertise, TTL)) -> m a
action = do
      dnsMapScriptVar <- Script MockDNSMap -> m (StrictTVar m (Script MockDNSMap))
forall (m :: * -> *) a.
MonadSTM m =>
Script a -> m (StrictTVar m (Script a))
initScript' Script MockDNSMap
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 (contramap Left tracer)
                                (curry toSockAddr)
                                dnsSemaphore
                                DNSResolver.defaultResolvConf
                                (readTVar publicRootPeersVar)
                                (mockDNSActions
                                  (contramap Right tracer)
                                  LookupReqAOnly
                                  (curry toSockAddr)
                                  dnsMapVar
                                  dnsTimeoutScriptVar
                                  dnsLookupDelayScriptVar)
                                (mkStdGen $ unTestSeed dnsSeed)
                                action

-- | 'resolveDomainAddresses' running with a given MockRoots env
--
mockResolveLedgerPeers :: ( MonadAsync m
                          , MonadDelay m
                          , MonadThrow m
                          , MonadTimer m
                          )
                       => Tracer m (TestTraceEvent TraceLedgerPeers)
                       -> MockRoots
                       -> Script DNSTimeout
                       -> Script DNSLookupDelay
                       -> TestSeed
                       -> m (Map DNS.Domain (Set SockAddr))
mockResolveLedgerPeers :: forall (m :: * -> *).
(MonadAsync m, MonadDelay m, MonadThrow m, MonadTimer m) =>
Tracer m (TestTraceEvent TraceLedgerPeers)
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> m (Map Domain (Set SockAddr))
mockResolveLedgerPeers Tracer m (TestTraceEvent TraceLedgerPeers)
tracer (MockRoots LocalRootsConfig
_ Script MockDNSMap
_ Map RelayAccessPoint PeerAdvertise
publicRootPeers Script MockDNSMap
dnsMapScript)
                       Script DNSTimeout
dnsTimeoutScript Script DNSLookupDelay
dnsLookupDelayScript (TestSeed Int
dnsSeed) = do
      dnsMapScriptVar <- Script MockDNSMap -> m (StrictTVar m (Script MockDNSMap))
forall (m :: * -> *) a.
MonadSTM m =>
Script a -> m (StrictTVar m (Script a))
initScript' Script MockDNSMap
dnsMapScript
      dnsMap <- stepScript' dnsMapScriptVar
      dnsMapVar <- newTVarIO dnsMap
      dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore

      dnsTimeoutScriptVar <- initScript' dnsTimeoutScript
      dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
      let relays = [ RelayAccessPoint
dap
                   | (RelayAccessPoint
relay, PeerAdvertise
_) <- Map RelayAccessPoint PeerAdvertise
-> [(RelayAccessPoint, PeerAdvertise)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map RelayAccessPoint PeerAdvertise
publicRootPeers
                   , RelayAccessPoint
dap <- case RelayAccessPoint
relay of
                              RelayAccessAddress {} -> []
                              RelayAccessPoint
x                     -> [RelayAccessPoint
x]]
      traceWith tracer . Left $ TraceLedgerPeersDomains relays
      resolveLedgerPeers dnsSemaphore
                         DNSResolver.defaultResolvConf
                         (mockDNSActions
                           (contramap Right tracer)
                           LookupReqAOnly
                           (curry toSockAddr)
                           dnsMapVar
                           dnsTimeoutScriptVar
                           dnsLookupDelayScriptVar)
                         SingAllLedgerPeers
                         relays
                         (mkStdGen dnsSeed)

--
-- Utils for properties
--

type TestTraceEvent a = Either a DNSTrace

tracerTraceLocalRoots :: Tracer (IOSim s) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
tracerTraceLocalRoots :: forall s.
Tracer (IOSim s) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
tracerTraceLocalRoots = (TestTraceEvent (TraceLocalRootPeers () SockAddr) -> IOSim s ())
-> Tracer
     (IOSim s) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
forall (m :: * -> *) a. Applicative m => (a -> m ()) -> Tracer m a
mkTracer TestTraceEvent (TraceLocalRootPeers () SockAddr) -> IOSim s ()
forall a s. Typeable a => a -> IOSim s ()
traceM

tracerTracePublicRoots :: Tracer (IOSim s) (TestTraceEvent TracePublicRootPeers)
tracerTracePublicRoots :: forall s. Tracer (IOSim s) (TestTraceEvent TracePublicRootPeers)
tracerTracePublicRoots = (TestTraceEvent TracePublicRootPeers -> IOSim s ())
-> Tracer (IOSim s) (TestTraceEvent TracePublicRootPeers)
forall (m :: * -> *) a. Applicative m => (a -> m ()) -> Tracer m a
mkTracer TestTraceEvent TracePublicRootPeers -> IOSim s ()
forall a s. Typeable a => a -> IOSim s ()
traceM

selectTestTraceEvents :: (Typeable b) => SimTrace a
                      -> [(Time, TestTraceEvent b)]
selectTestTraceEvents :: forall b a. Typeable b => SimTrace a -> [(Time, TestTraceEvent b)]
selectTestTraceEvents = SimTrace a -> [(Time, TestTraceEvent b)]
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]
_)    = [] -- expected result in many cases
    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"

selectLocalRootPeersWithDNSEvents :: SimTrace a
                                  -> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
selectLocalRootPeersWithDNSEvents :: forall a.
SimTrace a
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
selectLocalRootPeersWithDNSEvents = ((Time, TestTraceEvent (TraceLocalRootPeers () SockAddr)) -> Bool)
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
forall a. (a -> Bool) -> [a] -> [a]
filter (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr)) -> Bool
forall {a} {a}. (a, Either a DNSTrace) -> Bool
them ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
 -> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))])
-> (SimTrace a
    -> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))])
-> SimTrace a
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimTrace a
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
forall b a. Typeable b => SimTrace a -> [(Time, TestTraceEvent b)]
selectTestTraceEvents
  where
    them :: (a, Either a DNSTrace) -> Bool
them (a
_t, Right DNSTrace
dns) =
      case DNSTrace
dns of
        (DNSLookupResult DNSPeersKind
DNSLocalPeer Domain
_ Maybe Domain
_ [(IP, PortNumber, TTL)]
_) -> Bool
True
        (DNSLookupError DNSPeersKind
DNSLocalPeer Maybe DNSLookupType
_ Domain
_ DNSError
_)  -> Bool
True
        (SRVLookupResult DNSPeersKind
DNSLocalPeer Domain
_ [(Domain, Word16, Word16, Word16, TTL)]
_)   -> Bool
True
        (SRVLookupError DNSPeersKind
DNSLocalPeer Domain
_)      -> Bool
True
        DNSTrace
_otherwise                           -> Bool
False
    them (a, Either a DNSTrace)
_ = Bool
True

selectLocalRootGroupsEvents :: [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
                            -> [(Time, [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
selectLocalRootGroupsEvents :: [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
selectLocalRootGroupsEvents [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
trace = [ (Time
t, [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
r)
                                    | (Time
t, Left (TraceLocalRootGroups [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
r)) <- [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
trace ]

selectPublicRootPeersWithDNSEvents :: SimTrace a
                                   -> [(Time, TestTraceEvent TracePublicRootPeers)]
selectPublicRootPeersWithDNSEvents :: forall a.
SimTrace a -> [(Time, TestTraceEvent TracePublicRootPeers)]
selectPublicRootPeersWithDNSEvents = ((Time, TestTraceEvent TracePublicRootPeers) -> Bool)
-> [(Time, TestTraceEvent TracePublicRootPeers)]
-> [(Time, TestTraceEvent TracePublicRootPeers)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Time, TestTraceEvent TracePublicRootPeers) -> Bool
forall {a} {a}. (a, Either a DNSTrace) -> Bool
them ([(Time, TestTraceEvent TracePublicRootPeers)]
 -> [(Time, TestTraceEvent TracePublicRootPeers)])
-> (SimTrace a -> [(Time, TestTraceEvent TracePublicRootPeers)])
-> SimTrace a
-> [(Time, TestTraceEvent TracePublicRootPeers)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimTrace a -> [(Time, TestTraceEvent TracePublicRootPeers)]
forall b a. Typeable b => SimTrace a -> [(Time, TestTraceEvent b)]
selectTestTraceEvents
  where
    them :: (a, Either a DNSTrace) -> Bool
them (a
_t, Right DNSTrace
dns) =
      case DNSTrace
dns of
        (DNSLookupResult DNSPeersKind
DNSPublicPeer Domain
_ Maybe Domain
_ [(IP, PortNumber, TTL)]
_) -> Bool
True
        (DNSLookupError DNSPeersKind
DNSPublicPeer Maybe DNSLookupType
_ Domain
_ DNSError
_)  -> Bool
True
        (SRVLookupResult DNSPeersKind
DNSPublicPeer Domain
_ [(Domain, Word16, Word16, Word16, TTL)]
_)   -> Bool
True
        (SRVLookupError DNSPeersKind
DNSPublicPeer Domain
_)      -> Bool
True
        DNSTrace
_otherwise                            -> Bool
False
    them (a, Either a DNSTrace)
_ = Bool
True

selectDnsResultEvents :: [(Time, TestTraceEvent a)]
                      -> [(Time, DNSTrace)]
selectDnsResultEvents :: forall a. [(Time, TestTraceEvent a)] -> [(Time, DNSTrace)]
selectDnsResultEvents [(Time, TestTraceEvent a)]
trace = [(Time
t, DNSTrace
r)
                              | (Time
t, Right r :: DNSTrace
r@(DNSLookupResult {})) <- [(Time, TestTraceEvent a)]
trace]

--
-- Local Root Peers Provider Tests
--

-- | The 'localRootPeersProvider' should use the IP addresses. This property
-- tests whether local root peer groups contain the IP addresses provided.
--
prop_local_preservesIPs :: MockRoots
                        -> Script DNSTimeout
                        -> Script DNSLookupDelay
                        -> TestSeed
                        -> Property
prop_local_preservesIPs :: MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> Property
prop_local_preservesIPs mockRoots :: MockRoots
mockRoots@(MockRoots LocalRootsConfig
localRoots Script MockDNSMap
_ Map RelayAccessPoint PeerAdvertise
_ Script MockDNSMap
_)
                        Script DNSTimeout
dnsTimeoutScript
                        Script DNSLookupDelay
dnsLookupDelayScript
                        TestSeed
dnsSeed =
    let tr :: [(Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
tr = [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
selectLocalRootGroupsEvents
           ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
 -> [(Time,
      [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])])
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
forall a b. (a -> b) -> a -> b
$ SimTrace ()
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
forall a.
SimTrace a
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
selectLocalRootPeersWithDNSEvents
           (SimTrace ()
 -> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))])
-> SimTrace ()
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
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) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> MockRoots
-> Maybe LocalRootsConfig
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> IOSim s ()
forall (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 MonadTimer m, MonadTraceSTM m, MonadLabelledSTM m) =>
Tracer m (TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> MockRoots
-> Maybe LocalRootsConfig
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> m ()
mockLocalRootPeersProvider Tracer (IOSim s) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
forall s.
Tracer (IOSim s) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
tracerTraceLocalRoots
                                        MockRoots
mockRoots
                                        Maybe LocalRootsConfig
forall a. Maybe a
Nothing
                                        Script DNSTimeout
dnsTimeoutScript
                                        Script DNSLookupDelay
dnsLookupDelayScript
                                        TestSeed
dnsSeed

     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 (LocalRootConfig ()))])
 -> [Char])
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
-> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Time,
 [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
-> [Char]
forall a. Show a => a -> [Char]
show [(Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
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 (LocalRootConfig ()))])]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
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 (LocalRootConfig ()))])]
-> Property
checkAll [(Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
tr
  where
    checkAll :: [(Time, [( HotValency
                         , WarmValency
                         , Map SockAddr (LocalRootConfig ()))])]
             -> Property
    checkAll :: [(Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
-> Property
checkAll [] = Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
    checkAll ((Time,
 [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
x:[(Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
t) =
      let thrd :: (a, b, c) -> c
thrd (a
_, b
_, c
c) = c
c
          -- get local root ip addresses
          localRootAddresses :: [(a, b, Map RelayAccessPoint (LocalRootConfig ()))]
                             -> Set SockAddr
          localRootAddresses :: forall a b.
[(a, b, Map RelayAccessPoint (LocalRootConfig ()))] -> Set SockAddr
localRootAddresses [(a, b, Map RelayAccessPoint (LocalRootConfig ()))]
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 (LocalRootConfig ())
m) <- [(a, b, Map RelayAccessPoint (LocalRootConfig ()))]
lrp
            , RelayAccessAddress IP
ip PortNumber
port <- Map RelayAccessPoint (LocalRootConfig ()) -> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys Map RelayAccessPoint (LocalRootConfig ())
m
            ]

          -- get ip addresses out of LocalRootGroup trace events
          localGroupEventsAddresses :: (a, [( HotValency
                                            , WarmValency
                                            , Map SockAddr (LocalRootConfig ()))])
                                    -> Set SockAddr
          localGroupEventsAddresses :: forall a.
(a, [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
-> Set SockAddr
localGroupEventsAddresses (a
_, [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
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 (LocalRootConfig ()))
 -> [SockAddr])
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> [SockAddr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Map SockAddr (LocalRootConfig ()) -> [SockAddr]
forall k a. Map k a -> [k]
Map.keys (Map SockAddr (LocalRootConfig ()) -> [SockAddr])
-> ((HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))
    -> Map SockAddr (LocalRootConfig ()))
-> (HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))
-> [SockAddr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))
-> Map SockAddr (LocalRootConfig ())
forall {a} {b} {c}. (a, b, c) -> c
thrd)
            ([(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
 -> [SockAddr])
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> [SockAddr]
forall a b. (a -> b) -> a -> b
$ [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
s

          localRootAddressesSet :: Set SockAddr
localRootAddressesSet = LocalRootsConfig -> Set SockAddr
forall a b.
[(a, b, Map RelayAccessPoint (LocalRootConfig ()))] -> Set SockAddr
localRootAddresses LocalRootsConfig
localRoots
          localGroupEventsAddressesSet :: Set SockAddr
localGroupEventsAddressesSet = (Time,
 [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
-> Set SockAddr
forall a.
(a, [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
-> Set SockAddr
localGroupEventsAddresses (Time,
 [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
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 (LocalRootConfig ()))])]
-> Property
checkAll [(Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
t

-- | The configuration without its domain names.
ipEntriesOnly :: [(HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig ()))]
              -> [(HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig ()))]
ipEntriesOnly :: LocalRootsConfig -> LocalRootsConfig
ipEntriesOnly = ((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> (HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ())))
-> LocalRootsConfig -> LocalRootsConfig
forall a b. (a -> b) -> [a] -> [b]
map (\(HotValency
h, WarmValency
w, Map RelayAccessPoint (LocalRootConfig ())
m) -> (HotValency
h, WarmValency
w, (RelayAccessPoint -> LocalRootConfig () -> Bool)
-> Map RelayAccessPoint (LocalRootConfig ())
-> Map RelayAccessPoint (LocalRootConfig ())
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\RelayAccessPoint
rap LocalRootConfig ()
_ -> RelayAccessPoint -> Bool
isRelayAccessAddress RelayAccessPoint
rap) Map RelayAccessPoint (LocalRootConfig ())
m))

-- | The IP entries of a group, as the provider publishes them.
ipAddressesOf :: Map RelayAccessPoint (LocalRootConfig ()) -> Map SockAddr (LocalRootConfig ())
ipAddressesOf :: Map RelayAccessPoint (LocalRootConfig ())
-> Map SockAddr (LocalRootConfig ())
ipAddressesOf Map RelayAccessPoint (LocalRootConfig ())
m =
  [(SockAddr, LocalRootConfig ())]
-> Map SockAddr (LocalRootConfig ())
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ ((IP, PortNumber) -> SockAddr
toSockAddr (IP
ip, PortNumber
port), LocalRootConfig ()
c) | (RelayAccessAddress IP
ip PortNumber
port, LocalRootConfig ()
c) <- Map RelayAccessPoint (LocalRootConfig ())
-> [(RelayAccessPoint, LocalRootConfig ())]
forall k a. Map k a -> [(k, a)]
Map.toList Map RelayAccessPoint (LocalRootConfig ())
m ]

-- | After a reconfiguration the provider applies the new local root groups at
-- once, IP addresses included, even when the new configuration has no domain
-- name to resolve.
--
-- The provider sees the change at the reload, after 'reloadDelay', and from
-- then on every value it publishes has the groups and targets of the new
-- configuration, every IP address of a group with its own configuration, and
-- nothing else but addresses of the group's domains, each with that domain's
-- configuration.
--
-- At the reload a kept domain contributes the addresses it had, which must be
-- there, and no other domain contributes: a new one is not resolved yet. Every
-- kept domain is then looked up again. For a configuration without domain
-- names this is equality with the configured groups.
--
prop_local_reconfiguresIPs :: Script DNSTimeout
                           -> Script DNSLookupDelay
                           -> TestSeed
                           -> Property
prop_local_reconfiguresIPs :: Script DNSTimeout -> Script DNSLookupDelay -> TestSeed -> Property
prop_local_reconfiguresIPs Script DNSTimeout
dnsTimeoutScript Script DNSLookupDelay
dnsLookupDelayScript TestSeed
dnsSeed =
    Property -> Property
forall prop. Testable prop => prop -> Property
checkCoverage (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    Gen (MockRoots, LocalRootsConfig, Bool)
-> ((MockRoots, LocalRootsConfig, Bool)
    -> [(MockRoots, LocalRootsConfig, Bool)])
-> ((MockRoots, LocalRootsConfig, Bool) -> Property)
-> Property
forall a prop.
(Show a, Testable prop) =>
Gen a -> (a -> [a]) -> (a -> prop) -> Property
forAllShrink Gen (MockRoots, LocalRootsConfig, Bool)
genRoots (MockRoots, LocalRootsConfig, Bool)
-> [(MockRoots, LocalRootsConfig, Bool)]
shrinkRoots (((MockRoots, LocalRootsConfig, Bool) -> Property) -> Property)
-> ((MockRoots, LocalRootsConfig, Bool) -> Property) -> Property
forall a b. (a -> b) -> a -> b
$
    \(mockRoots :: MockRoots
mockRoots@(MockRoots LocalRootsConfig
localRoots (Script NonEmpty MockDNSMap
dnsMaps) Map RelayAccessPoint PeerAdvertise
_ Script MockDNSMap
_), LocalRootsConfig
newRoots, Bool
ipOnly) ->
    let newRoots' :: LocalRootsConfig
        newRoots' :: LocalRootsConfig
newRoots'
          | Bool
ipOnly    = LocalRootsConfig -> LocalRootsConfig
ipEntriesOnly LocalRootsConfig
newRoots
          | Bool
otherwise = LocalRootsConfig
newRoots
        simTrace :: SimTrace ()
        simTrace :: SimTrace ()
simTrace = (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) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> MockRoots
-> Maybe LocalRootsConfig
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> IOSim s ()
forall (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 MonadTimer m, MonadTraceSTM m, MonadLabelledSTM m) =>
Tracer m (TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> MockRoots
-> Maybe LocalRootsConfig
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> m ()
mockLocalRootPeersProvider Tracer (IOSim s) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
forall s.
Tracer (IOSim s) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
tracerTraceLocalRoots
                                              MockRoots
mockRoots
                                              (LocalRootsConfig -> Maybe LocalRootsConfig
forall a. a -> Maybe a
Just LocalRootsConfig
newRoots')
                                              Script DNSTimeout
dnsTimeoutScript
                                              Script DNSLookupDelay
dnsLookupDelayScript
                                              TestSeed
dnsSeed
        tr :: [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
        tr :: [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
tr = SimTrace ()
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
forall a.
SimTrace a
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
selectLocalRootPeersWithDNSEvents SimTrace ()
simTrace
        published :: [(Time, LocalRootGroups)]
        published :: [(Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
published = [ (Time
t, [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups)
                    | (Time
t, Published [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups) <- SimTrace () -> [(Time, Published)]
forall a b. Typeable b => SimTrace a -> [(Time, b)]
selectTraceEventsDynamicWithTime SimTrace ()
simTrace
                    ]
        reload :: Time
        reload :: Time
reload = DiffTime -> Time
Time DiffTime
reloadDelay
        changed :: Bool
        changed :: Bool
changed = LocalRootsConfig
newRoots' LocalRootsConfig -> LocalRootsConfig -> Bool
forall a. Eq a => a -> a -> Bool
/= LocalRootsConfig
localRoots
        -- the groups published at the reload: the last by then, as no answer
        -- of the old lookup threads is published in the instant of the reload
        atReload :: LocalRootGroups
        atReload :: [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
atReload = [[(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]]
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
forall a. HasCallStack => [a] -> a
last ([] [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> [[(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]]
-> [[(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]]
forall a. a -> [a] -> [a]
: [ [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups | (Time
t, [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups) <- [(Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
published, Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<= Time
reload ])
        -- the groups the provider wrote in that instant, if any, which it
        -- traces right after the domains, and only then
        writtenAtReload, tracedAtReload :: [LocalRootGroups]
        writtenAtReload :: [[(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]]
writtenAtReload = [ [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups | (Time
t, [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups) <- [(Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
published, Time
t Time -> Time -> Bool
forall a. Eq a => a -> a -> Bool
== Time
reload ]
        tracedAtReload :: [[(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]]
tracedAtReload  = case [ TraceLocalRootPeers () SockAddr
ev | (Time
_, Left TraceLocalRootPeers () SockAddr
ev) <- [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
after ] of
                            TraceLocalRootPeers () SockAddr
_ : TraceLocalRootDomains LocalRootsConfig
_ : TraceLocalRootGroups [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
g : [TraceLocalRootPeers () SockAddr]
_ -> [[(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
g]
                            [TraceLocalRootPeers () SockAddr]
_ -> []
        oldDomains :: Set RelayAccessPoint
        oldDomains :: Set RelayAccessPoint
oldDomains = [RelayAccessPoint] -> Set RelayAccessPoint
forall a. Ord a => [a] -> Set a
Set.fromList [ RelayAccessPoint
rap
                                  | (HotValency
_, WarmValency
_, Map RelayAccessPoint (LocalRootConfig ())
m) <- LocalRootsConfig
localRoots
                                  , RelayAccessPoint
rap <- Map RelayAccessPoint (LocalRootConfig ()) -> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys Map RelayAccessPoint (LocalRootConfig ())
m
                                  , Bool -> Bool
not (RelayAccessPoint -> Bool
isRelayAccessAddress RelayAccessPoint
rap)
                                  ]
        -- the trace up to the provider seeing the change, and from then on
        before, after :: [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
        ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
before, [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
after) = ((Time, TestTraceEvent (TraceLocalRootPeers () SockAddr)) -> Bool)
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))],
    [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr)) -> Bool
isReconfigured [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
tr
        isReconfigured :: (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr)) -> Bool
        isReconfigured :: (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr)) -> Bool
isReconfigured (Time
_, Left TraceLocalRootReconfigured {}) = Bool
True
        isReconfigured (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))
_                                       = Bool
False
        reconfigured :: Bool
        reconfigured :: Bool
reconfigured = case [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
after of
                         (Time
t, TestTraceEvent (TraceLocalRootPeers () SockAddr)
_) : [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
_ -> Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
reload
                         []         -> Bool
False
        -- the addresses the provider had resolved when it saw the change, and
        -- the ones it started the new configuration from: those of each kept
        -- domain, none for the others. The last traced map is the last
        -- committed one, as IOSim resumes threads in the order they committed
        resolvedBefore :: Map RelayAccessPoint [SockAddr]
        resolvedBefore :: Map RelayAccessPoint [SockAddr]
resolvedBefore = [Map RelayAccessPoint [SockAddr]]
-> Map RelayAccessPoint [SockAddr]
forall a. HasCallStack => [a] -> a
last (Map RelayAccessPoint [SockAddr]
forall k a. Map k a
Map.empty Map RelayAccessPoint [SockAddr]
-> [Map RelayAccessPoint [SockAddr]]
-> [Map RelayAccessPoint [SockAddr]]
forall a. a -> [a] -> [a]
: [ Map RelayAccessPoint [SockAddr]
m | (Time
_, Left (TraceLocalRootDNSMap Map RelayAccessPoint [SockAddr]
m)) <- [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
before ])
        startedFrom :: Maybe (Map RelayAccessPoint [SockAddr])
        startedFrom :: Maybe (Map RelayAccessPoint [SockAddr])
startedFrom = [Map RelayAccessPoint [SockAddr]]
-> Maybe (Map RelayAccessPoint [SockAddr])
forall a. [a] -> Maybe a
listToMaybe [ Map RelayAccessPoint [SockAddr]
m | (Time
_, Left (TraceLocalRootDNSMap Map RelayAccessPoint [SockAddr]
m)) <- [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
after ]
        expectedStart :: Map RelayAccessPoint [SockAddr]
        expectedStart :: Map RelayAccessPoint [SockAddr]
expectedStart = [(RelayAccessPoint, [SockAddr])] -> Map RelayAccessPoint [SockAddr]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (RelayAccessPoint
rap, [SockAddr]
-> RelayAccessPoint
-> Map RelayAccessPoint [SockAddr]
-> [SockAddr]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] RelayAccessPoint
rap Map RelayAccessPoint [SockAddr]
resolvedBefore)
                                     | (HotValency
_, WarmValency
_, Map RelayAccessPoint (LocalRootConfig ())
m) <- LocalRootsConfig
newRoots'
                                     , RelayAccessPoint
rap <- Map RelayAccessPoint (LocalRootConfig ()) -> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys Map RelayAccessPoint (LocalRootConfig ())
m
                                     , Bool -> Bool
not (RelayAccessPoint -> Bool
isRelayAccessAddress RelayAccessPoint
rap)
                                     ]
        -- the addresses of the IP entries and the kept domains at the reload,
        -- each with the configuration of its IP entry, if any, else of the
        -- first domain of its group that holds it, as the provider gives an
        -- address held by several entries
        requiredAtReload :: [Map SockAddr (LocalRootConfig ())]
        requiredAtReload :: [Map SockAddr (LocalRootConfig ())]
requiredAtReload =
          [ Map RelayAccessPoint (LocalRootConfig ())
-> Map SockAddr (LocalRootConfig ())
ipAddressesOf Map RelayAccessPoint (LocalRootConfig ())
m
            Map SockAddr (LocalRootConfig ())
-> Map SockAddr (LocalRootConfig ())
-> Map SockAddr (LocalRootConfig ())
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union`
            (LocalRootConfig () -> LocalRootConfig () -> LocalRootConfig ())
-> [(SockAddr, LocalRootConfig ())]
-> Map SockAddr (LocalRootConfig ())
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (\LocalRootConfig ()
_ LocalRootConfig ()
first -> LocalRootConfig ()
first)
              [ (SockAddr
a, LocalRootConfig ()
c)
              | (RelayAccessPoint
rap, LocalRootConfig ()
c) <- Map RelayAccessPoint (LocalRootConfig ())
-> [(RelayAccessPoint, LocalRootConfig ())]
forall k a. Map k a -> [(k, a)]
Map.toList Map RelayAccessPoint (LocalRootConfig ())
m
              , Bool -> Bool
not (RelayAccessPoint -> Bool
isRelayAccessAddress RelayAccessPoint
rap)
              , SockAddr
a <- [SockAddr]
-> RelayAccessPoint
-> Map RelayAccessPoint [SockAddr]
-> [SockAddr]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] RelayAccessPoint
rap Map RelayAccessPoint [SockAddr]
expectedStart
              ]
          | (HotValency
_, WarmValency
_, Map RelayAccessPoint (LocalRootConfig ())
m) <- LocalRootsConfig
newRoots'
          ]
        missingAtReload :: [String]
        missingAtReload :: [[Char]]
missingAtReload
          | Bool
changed   = [ (SockAddr, LocalRootConfig ()) -> [Char]
forall a. Show a => a -> [Char]
show (SockAddr
a, LocalRootConfig ()
c) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" missing at the reload in " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Map SockAddr (LocalRootConfig ()) -> [Char]
forall a. Show a => a -> [Char]
show Map SockAddr (LocalRootConfig ())
pm
                        | (Map SockAddr (LocalRootConfig ())
required, (HotValency
_, WarmValency
_, Map SockAddr (LocalRootConfig ())
pm)) <- [Map SockAddr (LocalRootConfig ())]
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> [(Map SockAddr (LocalRootConfig ()),
     (HotValency, WarmValency, Map SockAddr (LocalRootConfig ())))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Map SockAddr (LocalRootConfig ())]
requiredAtReload [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
atReload
                        , (SockAddr
a, LocalRootConfig ()
c) <- Map SockAddr (LocalRootConfig ())
-> [(SockAddr, LocalRootConfig ())]
forall k a. Map k a -> [(k, a)]
Map.toList Map SockAddr (LocalRootConfig ())
required
                        , SockAddr
-> Map SockAddr (LocalRootConfig ()) -> Maybe (LocalRootConfig ())
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SockAddr
a Map SockAddr (LocalRootConfig ())
pm Maybe (LocalRootConfig ()) -> Maybe (LocalRootConfig ()) -> Bool
forall a. Eq a => a -> a -> Bool
/= LocalRootConfig () -> Maybe (LocalRootConfig ())
forall a. a -> Maybe a
Just LocalRootConfig ()
c
                        ]
          | Bool
otherwise = []
        -- the kept domains are looked up again
        lookedUp :: Set DNS.Domain
        lookedUp :: Set Domain
lookedUp = [Domain] -> Set Domain
forall a. Ord a => [a] -> Set a
Set.fromList [ Domain
d
                                | (Time
_, Right DNSTrace
ev) <- [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
after
                                , Just Domain
d <- [DNSTrace -> Maybe Domain
lookedUpDomain DNSTrace
ev]
                                ]
        notLookedUp :: [RelayAccessPoint]
        notLookedUp :: [RelayAccessPoint]
notLookedUp
          | Bool
changed   = [ RelayAccessPoint
rap
                        | (HotValency
_, WarmValency
_, Map RelayAccessPoint (LocalRootConfig ())
m) <- LocalRootsConfig
newRoots'
                        , RelayAccessPoint
rap <- Map RelayAccessPoint (LocalRootConfig ()) -> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys Map RelayAccessPoint (LocalRootConfig ())
m
                        , RelayAccessPoint
rap RelayAccessPoint -> Set RelayAccessPoint -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set RelayAccessPoint
oldDomains
                        , Just Domain
d <- [RelayAccessPoint -> Maybe Domain
relayAccessPointDomain RelayAccessPoint
rap]
                        , Domain
d Domain -> Set Domain -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Domain
lookedUp
                        ]
          | Bool
otherwise = []
        sameShape :: (   (HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig ()))
                      -> (HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig ()))
                      -> Bool)
                  -> Bool
        sameShape :: ((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> (HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ()))
 -> Bool)
-> Bool
sameShape (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
-> (HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ()))
-> Bool
f = Bool
changed
                   Bool -> Bool -> Bool
&& LocalRootsConfig -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length LocalRootsConfig
newRoots' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== LocalRootsConfig -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length LocalRootsConfig
localRoots
                   Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> (HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ()))
 -> Bool)
-> LocalRootsConfig -> LocalRootsConfig -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
-> (HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ()))
-> Bool
f LocalRootsConfig
newRoots' LocalRootsConfig
localRoots)
        allowedOld, allowedLater :: [Map SockAddr [LocalRootConfig ()]]
        allowedOld :: [Map SockAddr [LocalRootConfig ()]]
allowedOld   = ((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> Map SockAddr [LocalRootConfig ()])
-> LocalRootsConfig -> [Map SockAddr [LocalRootConfig ()]]
forall a b. (a -> b) -> [a] -> [b]
map (NonEmpty MockDNSMap
-> (RelayAccessPoint -> Bool)
-> (HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ()))
-> Map SockAddr [LocalRootConfig ()]
allowedBy NonEmpty MockDNSMap
dnsMaps (RelayAccessPoint -> Set RelayAccessPoint -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set RelayAccessPoint
oldDomains)) LocalRootsConfig
newRoots'
        allowedLater :: [Map SockAddr [LocalRootConfig ()]]
allowedLater = ((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> Map SockAddr [LocalRootConfig ()])
-> LocalRootsConfig -> [Map SockAddr [LocalRootConfig ()]]
forall a b. (a -> b) -> [a] -> [b]
map (NonEmpty MockDNSMap
-> (RelayAccessPoint -> Bool)
-> (HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ()))
-> Map SockAddr [LocalRootConfig ()]
allowedBy NonEmpty MockDNSMap
dnsMaps (Bool -> RelayAccessPoint -> Bool
forall a b. a -> b -> a
const Bool
True)) LocalRootsConfig
newRoots'
        -- once the groups match the new configuration, an address beyond
        -- those of its IP entries and old domains is a new domain's
        newDomainContributes :: Bool
        newDomainContributes :: Bool
newDomainContributes =
          ((Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
 -> Bool)
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Time
t, [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups) -> Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
reload Bool -> Bool -> Bool
&& Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isJust (LocalRootsConfig
-> [Map SockAddr [LocalRootConfig ()]]
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> Maybe [Char]
discrepancy LocalRootsConfig
newRoots' [Map SockAddr [LocalRootConfig ()]]
allowedOld [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups))
              [(Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
published
    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, TestTraceEvent (TraceLocalRootPeers () SockAddr))
 -> [Char])
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr)) -> [Char]
forall a. Show a => a -> [Char]
show [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
tr)
     (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> [Char] -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> [Char] -> prop -> Property
cover Double
30 (((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> Bool)
-> LocalRootsConfig -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((RelayAccessPoint -> Bool) -> [RelayAccessPoint] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all RelayAccessPoint -> Bool
isRelayAccessAddress ([RelayAccessPoint] -> Bool)
-> ((HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ()))
    -> [RelayAccessPoint])
-> (HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ()))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map RelayAccessPoint (LocalRootConfig ()) -> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys (Map RelayAccessPoint (LocalRootConfig ()) -> [RelayAccessPoint])
-> ((HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ()))
    -> Map RelayAccessPoint (LocalRootConfig ()))
-> (HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ()))
-> [RelayAccessPoint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
-> Map RelayAccessPoint (LocalRootConfig ())
forall entries. (HotValency, WarmValency, entries) -> entries
entriesOf) LocalRootsConfig
newRoots')
                [Char]
"new configuration has no domain names"
     (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> [Char] -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> [Char] -> prop -> Property
cover Double
1 ([()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ ()
                     | (HotValency
_, WarmValency
_, Map RelayAccessPoint (LocalRootConfig ())
m) <- LocalRootsConfig
newRoots'
                     , RelayAccessPoint
rap <- Map RelayAccessPoint (LocalRootConfig ()) -> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys Map RelayAccessPoint (LocalRootConfig ())
m
                     , RelayAccessPoint -> Bool
isRelayAccessAddress RelayAccessPoint
rap
                     ])
                [Char]
"new configuration has no IP addresses"
     (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> [Char] -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> [Char] -> prop -> Property
cover Double
1 (LocalRootsConfig
newRoots' LocalRootsConfig -> LocalRootsConfig -> Bool
forall a. Eq a => a -> a -> Bool
== LocalRootsConfig
localRoots) [Char]
"unchanged configuration"
     (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> [Char] -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> [Char] -> prop -> Property
cover Double
1 (LocalRootsConfig -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null LocalRootsConfig
localRoots Bool -> Bool -> Bool
&& Bool -> Bool
not (LocalRootsConfig -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null LocalRootsConfig
newRoots')) [Char]
"from no groups"
     (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> [Char] -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> [Char] -> prop -> Property
cover Double
1 (Bool -> Bool
not (LocalRootsConfig -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null LocalRootsConfig
localRoots) Bool -> Bool -> Bool
&& LocalRootsConfig -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null LocalRootsConfig
newRoots') [Char]
"to no groups"
     (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> [Char] -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> [Char] -> prop -> Property
cover Double
1 (((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> (HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ()))
 -> Bool)
-> Bool
sameShape (\(HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
g (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
g' -> (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
-> (HotValency, WarmValency)
forall entries.
(HotValency, WarmValency, entries) -> (HotValency, WarmValency)
targetsOf (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
g (HotValency, WarmValency) -> (HotValency, WarmValency) -> Bool
forall a. Eq a => a -> a -> Bool
== (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
-> (HotValency, WarmValency)
forall entries.
(HotValency, WarmValency, entries) -> (HotValency, WarmValency)
targetsOf (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
g'
                                  Bool -> Bool -> Bool
&& Map RelayAccessPoint (LocalRootConfig ()) -> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys ((HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
-> Map RelayAccessPoint (LocalRootConfig ())
forall entries. (HotValency, WarmValency, entries) -> entries
entriesOf (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
g) [RelayAccessPoint] -> [RelayAccessPoint] -> Bool
forall a. Eq a => a -> a -> Bool
== Map RelayAccessPoint (LocalRootConfig ()) -> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys ((HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
-> Map RelayAccessPoint (LocalRootConfig ())
forall entries. (HotValency, WarmValency, entries) -> entries
entriesOf (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
g')))
               [Char]
"only flags change"
     (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> [Char] -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> [Char] -> prop -> Property
cover Double
1 (((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> (HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ()))
 -> Bool)
-> Bool
sameShape (\(HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
g (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
g' -> (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
-> Map RelayAccessPoint (LocalRootConfig ())
forall entries. (HotValency, WarmValency, entries) -> entries
entriesOf (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
g Map RelayAccessPoint (LocalRootConfig ())
-> Map RelayAccessPoint (LocalRootConfig ()) -> Bool
forall a. Eq a => a -> a -> Bool
== (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
-> Map RelayAccessPoint (LocalRootConfig ())
forall entries. (HotValency, WarmValency, entries) -> entries
entriesOf (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
g')) [Char]
"only targets change"
     (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> [Char] -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> [Char] -> prop -> Property
cover Double
1 (LocalRootsConfig
newRoots' LocalRootsConfig -> LocalRootsConfig -> Bool
forall a. Eq a => a -> a -> Bool
/= LocalRootsConfig
localRoots Bool -> Bool -> Bool
&& LocalRootsConfig -> LocalRootsConfig -> Bool
removalOf LocalRootsConfig
newRoots' LocalRootsConfig
localRoots) [Char]
"only removals"
     (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> [Char] -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> [Char] -> prop -> Property
cover Double
5 ((RelayAccessPoint -> Bool) -> [RelayAccessPoint] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\RelayAccessPoint
rap -> Bool -> Bool
not (RelayAccessPoint -> Bool
isRelayAccessAddress RelayAccessPoint
rap) Bool -> Bool -> Bool
&& RelayAccessPoint
rap RelayAccessPoint -> Set RelayAccessPoint -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set RelayAccessPoint
oldDomains)
                    (((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> [RelayAccessPoint])
-> LocalRootsConfig -> [RelayAccessPoint]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Map RelayAccessPoint (LocalRootConfig ()) -> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys (Map RelayAccessPoint (LocalRootConfig ()) -> [RelayAccessPoint])
-> ((HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ()))
    -> Map RelayAccessPoint (LocalRootConfig ()))
-> (HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ()))
-> [RelayAccessPoint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
-> Map RelayAccessPoint (LocalRootConfig ())
forall entries. (HotValency, WarmValency, entries) -> entries
entriesOf) LocalRootsConfig
newRoots'))
               [Char]
"a domain is kept"
     (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> [Char] -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> [Char] -> prop -> Property
cover Double
5 Bool
newDomainContributes [Char]
"a new domain contributes"
     (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ (case Bool -> SimTrace () -> Either Failure ()
forall a. Bool -> SimTrace a -> Either Failure a
traceResult Bool
False SimTrace ()
simTrace of
          Left Failure
e  -> [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"the simulation failed: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Failure -> [Char]
forall a. Show a => a -> [Char]
show Failure
e) Bool
False
          Right ()
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True)
       Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"the configuration change was not seen at the reload"
              (Bool -> Bool
not Bool
changed Bool -> Bool -> Bool
|| Bool
reconfigured)
       Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"the reload instant relies on whole-millisecond "
                            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"timeouts and delays")
              (Script DNSTimeout -> Script DNSLookupDelay -> Bool
wholeMilliseconds Script DNSTimeout
dnsTimeoutScript Script DNSLookupDelay
dnsLookupDelayScript)
       Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"the provider started from " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe (Map RelayAccessPoint [SockAddr]) -> [Char]
forall a. Show a => a -> [Char]
show Maybe (Map RelayAccessPoint [SockAddr])
startedFrom
                            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" rather than " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Map RelayAccessPoint [SockAddr] -> [Char]
forall a. Show a => a -> [Char]
show Map RelayAccessPoint [SockAddr]
expectedStart)
              (Bool -> Bool
not Bool
changed Bool -> Bool -> Bool
|| Maybe (Map RelayAccessPoint [SockAddr])
startedFrom Maybe (Map RelayAccessPoint [SockAddr])
-> Maybe (Map RelayAccessPoint [SockAddr]) -> Bool
forall a. Eq a => a -> a -> Bool
== Map RelayAccessPoint [SockAddr]
-> Maybe (Map RelayAccessPoint [SockAddr])
forall a. a -> Maybe a
Just Map RelayAccessPoint [SockAddr]
expectedStart)
       Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. (case [[Char]]
missingAtReload of
               []    -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
               [Char]
e : [[Char]]
_ -> [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
e Bool
False)
       Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"the groups written at the reload " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]]
-> [Char]
forall a. Show a => a -> [Char]
show [[(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]]
writtenAtReload
                            [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" are traced as " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [[(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]]
-> [Char]
forall a. Show a => a -> [Char]
show [[(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]]
tracedAtReload)
              (Bool -> Bool
not Bool
changed Bool -> Bool -> Bool
|| [[(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]]
writtenAtReload [[(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]]
-> [[(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]]
-> Bool
forall a. Eq a => a -> a -> Bool
== [[(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]]
tracedAtReload)
       Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"kept domains not looked up again: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [RelayAccessPoint] -> [Char]
forall a. Show a => a -> [Char]
show [RelayAccessPoint]
notLookedUp)
              ([RelayAccessPoint] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RelayAccessPoint]
notLookedUp)
       Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. (case LocalRootsConfig
-> [Map SockAddr [LocalRootConfig ()]]
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> Maybe [Char]
discrepancy LocalRootsConfig
newRoots' [Map SockAddr [LocalRootConfig ()]]
allowedOld [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
atReload of
               Maybe [Char]
Nothing -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
               Just [Char]
e  -> [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"at the reload: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
e) Bool
False)
       Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. (case [ [Char]
"at " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Time -> [Char]
forall a. Show a => a -> [Char]
show Time
t [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
e
                  | (Time
t, [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups) <- [(Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
published
                  , Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
> Time
reload
                  , Just [Char]
e <- [LocalRootsConfig
-> [Map SockAddr [LocalRootConfig ()]]
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> Maybe [Char]
discrepancy LocalRootsConfig
newRoots' [Map SockAddr [LocalRootConfig ()]]
allowedLater [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups]
                  ] of
               []    -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
               [Char]
e : [[Char]]
_ -> [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
e Bool
False)
  where
    -- the domain a lookup trace is of; the subordinate of an SRV domain is
    -- traced with it
    lookedUpDomain :: DNSTrace -> Maybe DNS.Domain
    lookedUpDomain :: DNSTrace -> Maybe Domain
lookedUpDomain = \case
      DNSLookupResult DNSPeersKind
_ Domain
d Maybe Domain
Nothing [(IP, PortNumber, TTL)]
_  -> Domain -> Maybe Domain
forall a. a -> Maybe a
Just Domain
d
      DNSLookupResult DNSPeersKind
_ Domain
_ (Just Domain
d) [(IP, PortNumber, TTL)]
_ -> Domain -> Maybe Domain
forall a. a -> Maybe a
Just Domain
d
      DNSLookupError DNSPeersKind
_ Maybe DNSLookupType
_ Domain
d DNSError
_         -> Domain -> Maybe Domain
forall a. a -> Maybe a
Just Domain
d
      SRVLookupResult DNSPeersKind
_ Domain
d [(Domain, Word16, Word16, Word16, TTL)]
_          -> Domain -> Maybe Domain
forall a. a -> Maybe a
Just Domain
d
      SRVLookupError DNSPeersKind
_ Domain
d             -> Domain -> Maybe Domain
forall a. a -> Maybe a
Just Domain
d

    genRoots :: Gen (MockRoots, LocalRootsConfig, Bool)
    genRoots :: Gen (MockRoots, LocalRootsConfig, Bool)
genRoots = do
      roots <- Gen MockRoots
forall a. Arbitrary a => Gen a
arbitrary
      noGroups <- frequency [(1, pure True), (5, pure False)]
      let roots' | Bool
noGroups  = MockRoots
roots { mockLocalRootPeers = [] }
                 | Bool
otherwise = MockRoots
roots
      newRoots <- genReconfiguration (mockLocalRootPeers roots')
      -- the domains the new configuration adds get answers too; for the
      -- old ones the script's own entries take precedence
      newDNSMap <- genDNSLookupMap (concatMap (Map.keys . entriesOf) newRoots)
      let roots'' = MockRoots
roots' { mockLocalRootPeersDNSMap =
                               (`Map.union` newDNSMap) <$> mockLocalRootPeersDNSMap roots' }
      ipOnly <- frequency [(1, pure True), (2, pure False)]
      return (roots'', newRoots, ipOnly)

    -- the old configuration only loses entries, and the new one loses them
    -- too, so a kept domain stays kept and a new one new; an unchanged
    -- configuration stays unchanged
    shrinkRoots :: (MockRoots, LocalRootsConfig, Bool) -> [(MockRoots, LocalRootsConfig, Bool)]
    shrinkRoots :: (MockRoots, LocalRootsConfig, Bool)
-> [(MockRoots, LocalRootsConfig, Bool)]
shrinkRoots (roots :: MockRoots
roots@MockRoots { mockLocalRootPeers :: MockRoots -> LocalRootsConfig
mockLocalRootPeers = LocalRootsConfig
old }, LocalRootsConfig
newRoots, Bool
ipOnly) =
         [ (MockRoots
roots { mockLocalRootPeers = old' }, LocalRootsConfig
newRoots', Bool
ipOnly)
         | LocalRootsConfig
old' <- ((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> LocalRootsConfig)
-> LocalRootsConfig -> [LocalRootsConfig]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList (\(HotValency
h, WarmValency
w, Map RelayAccessPoint (LocalRootConfig ())
m) -> [ (HotValency
h, WarmValency
w, [(RelayAccessPoint, LocalRootConfig ())]
-> Map RelayAccessPoint (LocalRootConfig ())
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(RelayAccessPoint, LocalRootConfig ())]
m')
                                             | [(RelayAccessPoint, LocalRootConfig ())]
m' <- ((RelayAccessPoint, LocalRootConfig ())
 -> [(RelayAccessPoint, LocalRootConfig ())])
-> [(RelayAccessPoint, LocalRootConfig ())]
-> [[(RelayAccessPoint, LocalRootConfig ())]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([(RelayAccessPoint, LocalRootConfig ())]
-> (RelayAccessPoint, LocalRootConfig ())
-> [(RelayAccessPoint, LocalRootConfig ())]
forall a b. a -> b -> a
const []) (Map RelayAccessPoint (LocalRootConfig ())
-> [(RelayAccessPoint, LocalRootConfig ())]
forall k a. Map k a -> [(k, a)]
Map.toList Map RelayAccessPoint (LocalRootConfig ())
m)
                                             ])
                              LocalRootsConfig
old
         , let removed :: Set RelayAccessPoint
removed = LocalRootsConfig -> Set RelayAccessPoint
keysOf LocalRootsConfig
old Set RelayAccessPoint
-> Set RelayAccessPoint -> Set RelayAccessPoint
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` LocalRootsConfig -> Set RelayAccessPoint
keysOf LocalRootsConfig
old'
               newRoots' :: LocalRootsConfig
newRoots' | LocalRootsConfig
newRoots LocalRootsConfig -> LocalRootsConfig -> Bool
forall a. Eq a => a -> a -> Bool
== LocalRootsConfig
old = LocalRootsConfig
old'
                         | Bool
otherwise       = Set RelayAccessPoint -> LocalRootsConfig -> LocalRootsConfig
without Set RelayAccessPoint
removed LocalRootsConfig
newRoots
         ]
      [(MockRoots, LocalRootsConfig, Bool)]
-> [(MockRoots, LocalRootsConfig, Bool)]
-> [(MockRoots, LocalRootsConfig, Bool)]
forall a. [a] -> [a] -> [a]
++ [ (MockRoots
roots, LocalRootsConfig
newRoots', Bool
ipOnly)
         | LocalRootsConfig
newRoots LocalRootsConfig -> LocalRootsConfig -> Bool
forall a. Eq a => a -> a -> Bool
/= LocalRootsConfig
old
         , LocalRootsConfig
newRoots' <- LocalRootsConfig -> [LocalRootsConfig]
shrinkLocalRootsConfig LocalRootsConfig
newRoots
         ]
      -- the public roots play no part
      [(MockRoots, LocalRootsConfig, Bool)]
-> [(MockRoots, LocalRootsConfig, Bool)]
-> [(MockRoots, LocalRootsConfig, Bool)]
forall a. [a] -> [a] -> [a]
++ [ ( MockRoots
roots { mockPublicRootPeers       = Map.empty
                   , mockPublicRootPeersDNSMap = singletonScript Map.empty }
           , LocalRootsConfig
newRoots, Bool
ipOnly )
         | Bool -> Bool
not (Map RelayAccessPoint PeerAdvertise -> Bool
forall k a. Map k a -> Bool
Map.null (MockRoots -> Map RelayAccessPoint PeerAdvertise
mockPublicRootPeers MockRoots
roots))
         ]
      where
        keysOf :: LocalRootsConfig -> Set RelayAccessPoint
        keysOf :: LocalRootsConfig -> Set RelayAccessPoint
keysOf LocalRootsConfig
conf = [RelayAccessPoint] -> Set RelayAccessPoint
forall a. Ord a => [a] -> Set a
Set.fromList (((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> [RelayAccessPoint])
-> LocalRootsConfig -> [RelayAccessPoint]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Map RelayAccessPoint (LocalRootConfig ()) -> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys (Map RelayAccessPoint (LocalRootConfig ()) -> [RelayAccessPoint])
-> ((HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ()))
    -> Map RelayAccessPoint (LocalRootConfig ()))
-> (HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ()))
-> [RelayAccessPoint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
-> Map RelayAccessPoint (LocalRootConfig ())
forall entries. (HotValency, WarmValency, entries) -> entries
entriesOf) LocalRootsConfig
conf)

        without :: Set RelayAccessPoint -> LocalRootsConfig -> LocalRootsConfig
        without :: Set RelayAccessPoint -> LocalRootsConfig -> LocalRootsConfig
without Set RelayAccessPoint
removed = ((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> (HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ())))
-> LocalRootsConfig -> LocalRootsConfig
forall a b. (a -> b) -> [a] -> [b]
map (\(HotValency
h, WarmValency
w, Map RelayAccessPoint (LocalRootConfig ())
m) -> (HotValency
h, WarmValency
w, Map RelayAccessPoint (LocalRootConfig ())
m Map RelayAccessPoint (LocalRootConfig ())
-> Set RelayAccessPoint
-> Map RelayAccessPoint (LocalRootConfig ())
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.withoutKeys` Set RelayAccessPoint
removed))

    -- the new groups are the old ones with groups or entries left out
    removalOf :: LocalRootsConfig -> LocalRootsConfig -> Bool
    removalOf :: LocalRootsConfig -> LocalRootsConfig -> Bool
removalOf [] LocalRootsConfig
_ = Bool
True
    removalOf LocalRootsConfig
_ [] = Bool
False
    removalOf new :: LocalRootsConfig
new@((HotValency
h, WarmValency
w, Map RelayAccessPoint (LocalRootConfig ())
m) : LocalRootsConfig
new') ((HotValency
h', WarmValency
w', Map RelayAccessPoint (LocalRootConfig ())
m') : LocalRootsConfig
old')
      | HotValency
h HotValency -> HotValency -> Bool
forall a. Eq a => a -> a -> Bool
== HotValency
h', WarmValency
w WarmValency -> WarmValency -> Bool
forall a. Eq a => a -> a -> Bool
== WarmValency
w', Map RelayAccessPoint (LocalRootConfig ())
m Map RelayAccessPoint (LocalRootConfig ())
-> Map RelayAccessPoint (LocalRootConfig ()) -> Bool
forall k a. (Ord k, Eq a) => Map k a -> Map k a -> Bool
`Map.isSubmapOf` Map RelayAccessPoint (LocalRootConfig ())
m' = LocalRootsConfig -> LocalRootsConfig -> Bool
removalOf LocalRootsConfig
new' LocalRootsConfig
old'
      | Bool
otherwise                               = LocalRootsConfig -> LocalRootsConfig -> Bool
removalOf LocalRootsConfig
new LocalRootsConfig
old'

    -- the addresses a relay access point can stand for, in any step of the
    -- DNS script
    resolvable :: NonEmpty MockDNSMap -> RelayAccessPoint -> Set SockAddr
    resolvable :: NonEmpty MockDNSMap -> RelayAccessPoint -> Set SockAddr
resolvable NonEmpty MockDNSMap
dnsMaps = \case
      RelayAccessAddress IP
ip PortNumber
port -> SockAddr -> Set SockAddr
forall a. a -> Set a
Set.singleton ((IP, PortNumber) -> SockAddr
toSockAddr (IP
ip, PortNumber
port))
      RelayAccessDomain Domain
d PortNumber
port   -> NonEmpty MockDNSMap -> Domain -> PortNumber -> Set SockAddr
aRecords NonEmpty MockDNSMap
dnsMaps Domain
d PortNumber
port
      RelayAccessSRVDomain Domain
d     ->
        [Set SockAddr] -> Set SockAddr
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [ NonEmpty MockDNSMap -> Domain -> PortNumber -> Set SockAddr
aRecords NonEmpty MockDNSMap
dnsMaps Domain
d' PortNumber
port
                   | MockDNSMap
dnsMap <- NonEmpty MockDNSMap -> [MockDNSMap]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty MockDNSMap
dnsMaps
                   , Just (Right [(Domain, Word16, Word16, PortNumber)]
srvs) <- [(Domain, TYPE)
-> MockDNSMap
-> Maybe
     (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Domain
d, TYPE
DNS.SRV) MockDNSMap
dnsMap]
                   , (Domain
d', Word16
_, Word16
_, PortNumber
port) <- [(Domain, Word16, Word16, PortNumber)]
srvs
                   ]

    aRecords :: NonEmpty MockDNSMap -> DNS.Domain -> PortNumber -> Set SockAddr
    aRecords :: NonEmpty MockDNSMap -> Domain -> PortNumber -> Set SockAddr
aRecords NonEmpty MockDNSMap
dnsMaps Domain
d PortNumber
port =
      [SockAddr] -> Set SockAddr
forall a. Ord a => [a] -> Set a
Set.fromList [ (IP, PortNumber) -> SockAddr
toSockAddr (IP
ip, PortNumber
port)
                   | MockDNSMap
dnsMap <- NonEmpty MockDNSMap -> [MockDNSMap]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty MockDNSMap
dnsMaps
                   , Just (Left [(IP, TTL)]
ips) <- [(Domain, TYPE)
-> MockDNSMap
-> Maybe
     (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Domain
d, TYPE
DNS.A) MockDNSMap
dnsMap]
                   , (IP
ip, TTL
_) <- [(IP, TTL)]
ips
                   ]

    -- the addresses each group may hold, with the configurations each may
    -- have, when only the domains 'resolved' admits have contributed
    allowedBy :: NonEmpty MockDNSMap
              -> (RelayAccessPoint -> Bool)
              -> (HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig ()))
              -> Map SockAddr [LocalRootConfig ()]
    allowedBy :: NonEmpty MockDNSMap
-> (RelayAccessPoint -> Bool)
-> (HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ()))
-> Map SockAddr [LocalRootConfig ()]
allowedBy NonEmpty MockDNSMap
dnsMaps RelayAccessPoint -> Bool
resolved (HotValency
_, WarmValency
_, Map RelayAccessPoint (LocalRootConfig ())
m) =
      ([LocalRootConfig ()]
 -> [LocalRootConfig ()] -> [LocalRootConfig ()])
-> [(SockAddr, [LocalRootConfig ()])]
-> Map SockAddr [LocalRootConfig ()]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [LocalRootConfig ()]
-> [LocalRootConfig ()] -> [LocalRootConfig ()]
forall a. [a] -> [a] -> [a]
(++) [ (SockAddr
a, [LocalRootConfig ()
c])
                            | (RelayAccessPoint
rap, LocalRootConfig ()
c) <- Map RelayAccessPoint (LocalRootConfig ())
-> [(RelayAccessPoint, LocalRootConfig ())]
forall k a. Map k a -> [(k, a)]
Map.toList Map RelayAccessPoint (LocalRootConfig ())
m
                            , RelayAccessPoint -> Bool
isRelayAccessAddress RelayAccessPoint
rap Bool -> Bool -> Bool
|| RelayAccessPoint -> Bool
resolved RelayAccessPoint
rap
                            , SockAddr
a <- Set SockAddr -> [SockAddr]
forall a. Set a -> [a]
Set.toList (NonEmpty MockDNSMap -> RelayAccessPoint -> Set SockAddr
resolvable NonEmpty MockDNSMap
dnsMaps RelayAccessPoint
rap)
                            ]

    -- the first way the published groups differ from those of the new
    -- configuration, if any
    discrepancy :: LocalRootsConfig
                -> [Map SockAddr [LocalRootConfig ()]]
                -> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
                -> Maybe String
    discrepancy :: LocalRootsConfig
-> [Map SockAddr [LocalRootConfig ()]]
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> Maybe [Char]
discrepancy LocalRootsConfig
conf [Map SockAddr [LocalRootConfig ()]]
allowed [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups
      | ((HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))
 -> (HotValency, WarmValency))
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> [(HotValency, WarmValency)]
forall a b. (a -> b) -> [a] -> [b]
map (HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))
-> (HotValency, WarmValency)
forall entries.
(HotValency, WarmValency, entries) -> (HotValency, WarmValency)
targetsOf [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups [(HotValency, WarmValency)] -> [(HotValency, WarmValency)] -> Bool
forall a. Eq a => a -> a -> Bool
/= ((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> (HotValency, WarmValency))
-> LocalRootsConfig -> [(HotValency, WarmValency)]
forall a b. (a -> b) -> [a] -> [b]
map (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
-> (HotValency, WarmValency)
forall entries.
(HotValency, WarmValency, entries) -> (HotValency, WarmValency)
targetsOf LocalRootsConfig
conf
      = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char]
"groups or targets differ: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> [Char]
forall a. Show a => a -> [Char]
show [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups)
      | Bool
otherwise
      = [[Char]] -> Maybe [Char]
forall a. [a] -> Maybe a
listToMaybe ([[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> Map SockAddr [LocalRootConfig ()]
 -> (HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))
 -> [[Char]])
-> LocalRootsConfig
-> [Map SockAddr [LocalRootConfig ()]]
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> [[[Char]]]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
-> Map SockAddr [LocalRootConfig ()]
-> (HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))
-> [[Char]]
group LocalRootsConfig
conf [Map SockAddr [LocalRootConfig ()]]
allowed [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups))
      where
        group :: (HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig ()))
              -> Map SockAddr [LocalRootConfig ()]
              -> (HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))
              -> [String]
        group :: (HotValency, WarmValency,
 Map RelayAccessPoint (LocalRootConfig ()))
-> Map SockAddr [LocalRootConfig ()]
-> (HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))
-> [[Char]]
group (HotValency
_, WarmValency
_, Map RelayAccessPoint (LocalRootConfig ())
m) Map SockAddr [LocalRootConfig ()]
ok (HotValency
_, WarmValency
_, Map SockAddr (LocalRootConfig ())
pm) =
             [ SockAddr -> [Char]
forall a. Show a => a -> [Char]
show SockAddr
a [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" missing or misconfigured in " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Map SockAddr (LocalRootConfig ()) -> [Char]
forall a. Show a => a -> [Char]
show Map SockAddr (LocalRootConfig ())
pm
             | (RelayAccessAddress IP
ip PortNumber
port, LocalRootConfig ()
c) <- Map RelayAccessPoint (LocalRootConfig ())
-> [(RelayAccessPoint, LocalRootConfig ())]
forall k a. Map k a -> [(k, a)]
Map.toList Map RelayAccessPoint (LocalRootConfig ())
m
             , let a :: SockAddr
a = (IP, PortNumber) -> SockAddr
toSockAddr (IP
ip, PortNumber
port)
             , SockAddr
-> Map SockAddr (LocalRootConfig ()) -> Maybe (LocalRootConfig ())
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SockAddr
a Map SockAddr (LocalRootConfig ())
pm Maybe (LocalRootConfig ()) -> Maybe (LocalRootConfig ()) -> Bool
forall a. Eq a => a -> a -> Bool
/= LocalRootConfig () -> Maybe (LocalRootConfig ())
forall a. a -> Maybe a
Just LocalRootConfig ()
c
             ]
          [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [ (SockAddr, LocalRootConfig ()) -> [Char]
forall a. Show a => a -> [Char]
show (SockAddr
a, LocalRootConfig ()
c) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is not from the configuration " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Map RelayAccessPoint (LocalRootConfig ()) -> [Char]
forall a. Show a => a -> [Char]
show Map RelayAccessPoint (LocalRootConfig ())
m
             | (SockAddr
a, LocalRootConfig ()
c) <- Map SockAddr (LocalRootConfig ())
-> [(SockAddr, LocalRootConfig ())]
forall k a. Map k a -> [(k, a)]
Map.toList Map SockAddr (LocalRootConfig ())
pm
             , LocalRootConfig ()
c LocalRootConfig () -> [LocalRootConfig ()] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [LocalRootConfig ()]
-> SockAddr
-> Map SockAddr [LocalRootConfig ()]
-> [LocalRootConfig ()]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] SockAddr
a Map SockAddr [LocalRootConfig ()]
ok
             ]

    targetsOf :: (HotValency, WarmValency, entries) -> (HotValency, WarmValency)
    targetsOf :: forall entries.
(HotValency, WarmValency, entries) -> (HotValency, WarmValency)
targetsOf (HotValency
h, WarmValency
w, entries
_) = (HotValency
h, WarmValency
w)

    entriesOf :: (HotValency, WarmValency, entries) -> entries
    entriesOf :: forall entries. (HotValency, WarmValency, entries) -> entries
entriesOf (HotValency
_, WarmValency
_, entries
m) = entries
m

-- | The provider publishes the IP addresses of its configuration before it
-- sets up a DNS resolver, so they are in place even if that fails: at
-- startup, or, when the first set-up succeeds, at a reload to a
-- configuration without domain names after 'reloadDelay'.
prop_local_publishesBeforeResolver :: MockRoots -> MockRoots -> Bool -> Property
prop_local_publishesBeforeResolver :: MockRoots -> MockRoots -> Bool -> Property
prop_local_publishesBeforeResolver (MockRoots LocalRootsConfig
localRoots (Script NonEmpty MockDNSMap
dnsMaps) Map RelayAccessPoint PeerAdvertise
_ Script MockDNSMap
_)
                                   (MockRoots LocalRootsConfig
newRoots Script MockDNSMap
_ Map RelayAccessPoint PeerAdvertise
_ Script MockDNSMap
_)
                                   Bool
atReload =
    Bool -> [Char] -> Property -> Property
forall prop. Testable prop => Bool -> [Char] -> prop -> Property
classify (Bool
atReload Bool -> Bool -> Bool
&& LocalRootsConfig
newRoots' LocalRootsConfig -> LocalRootsConfig -> Bool
forall a. Eq a => a -> a -> Bool
/= LocalRootsConfig
localRoots) [Char]
"the set-up fails at a reload" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    case (forall s.
 IOSim
   s [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
-> Either
     Failure
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
forall a. (forall s. IOSim s a) -> Either Failure a
runSim IOSim
  s [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
forall s.
IOSim
  s [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
sim of
      Left Failure
failure -> [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample (Failure -> [Char]
forall a. Show a => a -> [Char]
show Failure
failure) Bool
False
      Right [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups -> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
groups [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== LocalRootsConfig
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
addressesOf (if Bool
atReload then LocalRootsConfig
newRoots' else LocalRootsConfig
localRoots)
  where
    newRoots' :: LocalRootsConfig
    newRoots' :: LocalRootsConfig
newRoots' = LocalRootsConfig -> LocalRootsConfig
ipEntriesOnly LocalRootsConfig
newRoots

    addressesOf :: LocalRootsConfig -> LocalRootGroups
    addressesOf :: LocalRootsConfig
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
addressesOf LocalRootsConfig
conf = [ (HotValency
h, WarmValency
w, Map RelayAccessPoint (LocalRootConfig ())
-> Map SockAddr (LocalRootConfig ())
ipAddressesOf Map RelayAccessPoint (LocalRootConfig ())
m) | (HotValency
h, WarmValency
w, Map RelayAccessPoint (LocalRootConfig ())
m) <- LocalRootsConfig
conf ]

    sim :: IOSim s [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
    sim :: forall s.
IOSim
  s [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
sim = do
      dnsMapVar <- MockDNSMap -> IOSim s (StrictTVar (IOSim s) MockDNSMap)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO (NonEmpty MockDNSMap -> MockDNSMap
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty MockDNSMap
dnsMaps)
      timeouts  <- initScript' (singletonScript (DNSTimeout 10))
      delays    <- initScript' (singletonScript (DNSLookupDelay 0))
      confVar   <- newTVarIO localRoots
      resultVar <- newTVarIO []
      let mock = Tracer (IOSim s) DNSTrace
-> DNSLookupType
-> (IP -> PortNumber -> SockAddr)
-> StrictTVar (IOSim s) MockDNSMap
-> StrictTVar (IOSim s) (Script DNSTimeout)
-> StrictTVar (IOSim s) (Script DNSLookupDelay)
-> DNSActions SockAddr () (IOSim s)
forall peerAddr (m :: * -> *).
(MonadDelay m, MonadTimer m, MonadAsync m) =>
Tracer m DNSTrace
-> DNSLookupType
-> (IP -> PortNumber -> peerAddr)
-> StrictTVar m MockDNSMap
-> StrictTVar m (Script DNSTimeout)
-> StrictTVar m (Script DNSLookupDelay)
-> DNSActions peerAddr () m
mockDNSActions Tracer (IOSim s) DNSTrace
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer DNSLookupType
LookupReqAOnly (((IP, PortNumber) -> SockAddr) -> IP -> PortNumber -> SockAddr
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (IP, PortNumber) -> SockAddr
toSockAddr)
                                StrictTVar (IOSim s) MockDNSMap
dnsMapVar StrictTVar (IOSim s) (Script DNSTimeout)
timeouts StrictTVar (IOSim s) (Script DNSLookupDelay)
delays
          actions = DNSActions SockAddr () (IOSim s)
mock {
            dnsAsyncResolverResource = \ResolvConf
conf -> do
              -- the set-up fails at startup, or under the new configuration
              conf' <- StrictTVar (IOSim s) LocalRootsConfig -> IOSim s LocalRootsConfig
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar (IOSim s) LocalRootsConfig
confVar
              if not atReload || conf' == newRoots'
                then throwIO (userError "no resolver")
                else dnsAsyncResolverResource mock conf
          }
      withAsync (when atReload $ do
                   threadDelay reloadDelay
                   atomically (writeTVar confVar newRoots')) $ \Async (IOSim s) ()
_ ->
        IOSim s (Maybe (Either IOException Void)) -> IOSim s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IOSim s (Maybe (Either IOException Void)) -> IOSim s ())
-> IOSim s (Maybe (Either IOException Void)) -> IOSim s ()
forall a b. (a -> b) -> a -> b
$ DiffTime
-> IOSim s (Either IOException Void)
-> IOSim s (Maybe (Either IOException Void))
forall a. DiffTime -> IOSim s a -> IOSim s (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
MonadTimer.timeout (DiffTime
reloadDelay DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
100) (IOSim s (Either IOException Void)
 -> IOSim s (Maybe (Either IOException Void)))
-> IOSim s (Either IOException Void)
-> IOSim s (Maybe (Either IOException Void))
forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @_ @IOException (IOSim s Void -> IOSim s (Either IOException Void))
-> IOSim s Void -> IOSim s (Either IOException Void)
forall a b. (a -> b) -> a -> b
$
            Tracer (IOSim s) (TraceLocalRootPeers () SockAddr)
-> PeerActionsDNS SockAddr () (IOSim s)
-> ResolvConf
-> StdGen
-> STM (IOSim s) LocalRootsConfig
-> StrictTVar
     (IOSim s)
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> IOSim s Void
forall (m :: * -> *) extraFlags peerAddr resolver.
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 Ord peerAddr, Eq extraFlags) =>
Tracer m (TraceLocalRootPeers extraFlags peerAddr)
-> PeerActionsDNS peerAddr resolver m
-> ResolvConf
-> StdGen
-> STM
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> StrictTVar
     m
     [(HotValency, WarmValency,
       Map peerAddr (LocalRootConfig extraFlags))]
-> m Void
localRootPeersProvider Tracer (IOSim s) (TraceLocalRootPeers () SockAddr)
forall (m :: * -> *) a. Monad m => Tracer m a
nullTracer
                                   PeerActionsDNS { paToPeerAddr :: IP -> PortNumber -> SockAddr
paToPeerAddr = ((IP, PortNumber) -> SockAddr) -> IP -> PortNumber -> SockAddr
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (IP, PortNumber) -> SockAddr
toSockAddr,
                                                    paDnsActions :: DNSActions SockAddr () (IOSim s)
paDnsActions = DNSActions SockAddr () (IOSim s)
actions }
                                   ResolvConf
DNSResolver.defaultResolvConf
                                   (Int -> StdGen
mkStdGen Int
0)
                                   (StrictTVar (IOSim s) LocalRootsConfig
-> STM (IOSim s) LocalRootsConfig
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar (IOSim s) LocalRootsConfig
confVar)
                                   StrictTVar
  (IOSim s)
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
resultVar
      readTVarIO resultVar

-- | The groups the provider published, one write at a time.
newtype Published = Published [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]

-- | The 'localRootPeersProvider' should preserve the local root peers
-- group number and respective targets. This property tests whether local
-- root peer groups update due to DNS resolution results, does not alter
-- the initial groups configuration.
--
prop_local_preservesGroupNumberAndTargets :: MockRoots
                                          -> Script DNSTimeout
                                          -> Script DNSLookupDelay
                                          -> TestSeed
                                          -> Property
prop_local_preservesGroupNumberAndTargets :: MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> Property
prop_local_preservesGroupNumberAndTargets mockRoots :: MockRoots
mockRoots@(MockRoots LocalRootsConfig
lrp Script MockDNSMap
_ Map RelayAccessPoint PeerAdvertise
_ Script MockDNSMap
_)
                                          Script DNSTimeout
dnsTimeoutScript
                                          Script DNSLookupDelay
dnsLookupDelayScript
                                          TestSeed
dnsSeed =
    let tr :: [(Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
tr = [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
selectLocalRootGroupsEvents
           ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
 -> [(Time,
      [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])])
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
forall a b. (a -> b) -> a -> b
$ SimTrace ()
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
forall a.
SimTrace a
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
selectLocalRootPeersWithDNSEvents
           (SimTrace ()
 -> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))])
-> SimTrace ()
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
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) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> MockRoots
-> Maybe LocalRootsConfig
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> IOSim s ()
forall (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 MonadTimer m, MonadTraceSTM m, MonadLabelledSTM m) =>
Tracer m (TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> MockRoots
-> Maybe LocalRootsConfig
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> m ()
mockLocalRootPeersProvider Tracer (IOSim s) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
forall s.
Tracer (IOSim s) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
tracerTraceLocalRoots
                                        MockRoots
mockRoots
                                        Maybe LocalRootsConfig
forall a. Maybe a
Nothing
                                        Script DNSTimeout
dnsTimeoutScript
                                        Script DNSLookupDelay
dnsLookupDelayScript
                                        TestSeed
dnsSeed

        -- For all LocalRootGroup results, the number of groups should be
        -- preserved, i.e. no new groups are added nor deleted along the
        -- trace by localRootPeersProvider.
        preservesGroupNumber :: Bool
preservesGroupNumber = ((Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
 -> Bool)
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== LocalRootsConfig -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length LocalRootsConfig
lrp) (Int -> Bool)
-> ((Time,
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
    -> Int)
-> (Time,
    [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
 -> Int)
-> ((Time,
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
    -> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
-> (Time,
    [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time,
 [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
forall a b. (a, b) -> b
snd) [(Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
tr

        -- For all LocalRootGroup results, the targets for each group
        -- should be preserved, i.e. targets are not modified along the
        -- trace by localRootPeersProvider.
        preservesTargets :: Bool
preservesTargets     = ([((HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ())),
   (HotValency, WarmValency, Map SockAddr (LocalRootConfig ())))]
 -> Bool)
-> [[((HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig ())),
      (HotValency, WarmValency, Map SockAddr (LocalRootConfig ())))]]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((((HotValency, WarmValency,
   Map RelayAccessPoint (LocalRootConfig ())),
  (HotValency, WarmValency, Map SockAddr (LocalRootConfig ())))
 -> Bool)
-> [((HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig ())),
     (HotValency, WarmValency, Map SockAddr (LocalRootConfig ())))]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\((HotValency
a, WarmValency
b, Map RelayAccessPoint (LocalRootConfig ())
_), (HotValency
a', WarmValency
b', Map SockAddr (LocalRootConfig ())
_)) -> 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'))
                                   [ LocalRootsConfig
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> [((HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig ())),
     (HotValency, WarmValency, Map SockAddr (LocalRootConfig ())))]
forall a b. [a] -> [b] -> [(a, b)]
zip LocalRootsConfig
lrp [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
r | [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
r <- ((Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
 -> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
-> [[(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]]
forall a b. (a -> b) -> [a] -> [b]
map (Time,
 [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
forall a b. (a, b) -> b
snd [(Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
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 (LocalRootConfig ()))])]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Time,
  [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
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

-- | The 'localRootPeersProvider' should be able to resolve DNS domains
-- correctly, assuming the domain maps to any IP address. This property
-- tests whether 'localRootPeersProvider' is capable of eventually resolving
-- domain addresses even after having failed to do so in the first attempt.
--
prop_local_resolvesDomainsCorrectly :: MockRoots
                                    -> Script DNSTimeout
                                    -> Script DNSLookupDelay
                                    -> TestSeed
                                    -> Property
prop_local_resolvesDomainsCorrectly :: MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> Property
prop_local_resolvesDomainsCorrectly mockRoots :: MockRoots
mockRoots@(MockRoots LocalRootsConfig
localRoots Script MockDNSMap
lDNSMap Map RelayAccessPoint PeerAdvertise
_ Script MockDNSMap
_)
                                    Script DNSTimeout
dnsTimeoutScript
                                    Script DNSLookupDelay
dnsLookupDelayScript
                                    TestSeed
dnsSeed =
    let mockRoots' :: MockRoots
mockRoots' =
          MockRoots
mockRoots { mockLocalRootPeersDNSMap =
                        singletonScript (scriptHead lDNSMap)
                    }
        tr :: [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
tr = SimTrace ()
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
forall a.
SimTrace a
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
selectLocalRootPeersWithDNSEvents
           (SimTrace ()
 -> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))])
-> SimTrace ()
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
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) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> MockRoots
-> Maybe LocalRootsConfig
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> IOSim s ()
forall (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 MonadTimer m, MonadTraceSTM m, MonadLabelledSTM m) =>
Tracer m (TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> MockRoots
-> Maybe LocalRootsConfig
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> m ()
mockLocalRootPeersProvider Tracer (IOSim s) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
forall s.
Tracer (IOSim s) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
tracerTraceLocalRoots
                                        MockRoots
mockRoots'
                                        Maybe LocalRootsConfig
forall a. Maybe a
Nothing
                                        Script DNSTimeout
dnsTimeoutScript
                                        Script DNSLookupDelay
dnsLookupDelayScript
                                        TestSeed
dnsSeed

        -- local root domains
        localRootDomains :: Set (DNS.Domain, DNS.TYPE)
        localRootDomains :: Set (Domain, TYPE)
localRootDomains =
          [(Domain, TYPE)] -> Set (Domain, TYPE)
forall a. Ord a => [a] -> Set a
Set.fromList
          [ (Domain, TYPE)
item
          | (HotValency
_, WarmValency
_, Map RelayAccessPoint (LocalRootConfig ())
m) <- LocalRootsConfig
localRoots
          , (Domain, TYPE)
item <- ((RelayAccessPoint -> Maybe (Domain, TYPE))
 -> [RelayAccessPoint] -> [(Domain, TYPE)])
-> [RelayAccessPoint]
-> (RelayAccessPoint -> Maybe (Domain, TYPE))
-> [(Domain, TYPE)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (RelayAccessPoint -> Maybe (Domain, TYPE))
-> [RelayAccessPoint] -> [(Domain, TYPE)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Map RelayAccessPoint (LocalRootConfig ()) -> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys Map RelayAccessPoint (LocalRootConfig ())
m) \case
              RelayAccessDomain Domain
d PortNumber
_p -> (Domain, TYPE) -> Maybe (Domain, TYPE)
forall a. a -> Maybe a
Just (Domain
d, TYPE
DNS.A)
              RelayAccessSRVDomain Domain
d -> (Domain, TYPE) -> Maybe (Domain, TYPE)
forall a. a -> Maybe a
Just (Domain
d, TYPE
DNS.SRV)
              RelayAccessPoint
_otherwise -> Maybe (Domain, TYPE)
forall a. Maybe a
Nothing
          ]

        -- domains that were resolved during simulation
        resultMap :: Set (DNS.Domain, DNS.TYPE)
        resultMap :: Set (Domain, TYPE)
resultMap = [(Domain, TYPE)] -> Set (Domain, TYPE)
forall a. Ord a => [a] -> Set a
Set.fromList
                  ([(Domain, TYPE)] -> Set (Domain, TYPE))
-> ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
    -> [(Domain, TYPE)])
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> Set (Domain, TYPE)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Time, DNSTrace) -> Maybe (Domain, TYPE))
-> [(Time, DNSTrace)] -> [(Domain, TYPE)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (DNSTrace -> Maybe (Domain, TYPE)
filtering (DNSTrace -> Maybe (Domain, TYPE))
-> ((Time, DNSTrace) -> DNSTrace)
-> (Time, DNSTrace)
-> Maybe (Domain, TYPE)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, DNSTrace) -> DNSTrace
forall a b. (a, b) -> b
snd)
                  ([(Time, DNSTrace)] -> [(Domain, TYPE)])
-> ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
    -> [(Time, DNSTrace)])
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> [(Domain, TYPE)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> [(Time, DNSTrace)]
forall a. [(Time, TestTraceEvent a)] -> [(Time, DNSTrace)]
selectDnsResultEvents
                  ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
 -> Set (Domain, TYPE))
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> Set (Domain, TYPE)
forall a b. (a -> b) -> a -> b
$ [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
tr
          where
            filtering :: DNSTrace -> Maybe (Domain, TYPE)
filtering = \case
              DNSLookupResult DNSPeersKind
_ Domain
domain Maybe Domain
Nothing [(IP, PortNumber, TTL)]
_ -> (Domain, TYPE) -> Maybe (Domain, TYPE)
forall a. a -> Maybe a
Just (Domain
domain, TYPE
DNS.A)
              DNSLookupResult DNSPeersKind
_ Domain
_ (Just Domain
domain) [(IP, PortNumber, TTL)]
_ -> (Domain, TYPE) -> Maybe (Domain, TYPE)
forall a. a -> Maybe a
Just (Domain
domain, TYPE
DNS.SRV)
              DNSTrace
_otherwise -> Maybe (Domain, TYPE)
forall a. Maybe a
Nothing

        -- all domains that could have been resolved in each script
        maxResultMap :: Script (Set (DNS.Domain, DNS.TYPE))
        maxResultMap :: Script (Set (Domain, TYPE))
maxResultMap = MockDNSMap -> Set (Domain, TYPE)
forall k a. Map k a -> Set k
Map.keysSet
                       (MockDNSMap -> Set (Domain, TYPE))
-> (MockDNSMap -> MockDNSMap) -> MockDNSMap -> Set (Domain, TYPE)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MockDNSMap -> Set (Domain, TYPE) -> MockDNSMap
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set (Domain, TYPE)
localRootDomains)
                       (MockDNSMap -> Set (Domain, TYPE))
-> Script MockDNSMap -> Script (Set (Domain, TYPE))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Script MockDNSMap
lDNSMap

        -- all domains that were tried to resolve during the simulation
        allTriedDomains :: Set (DNS.Domain, DNS.TYPE)
        allTriedDomains :: Set (Domain, TYPE)
allTriedDomains = [(Domain, TYPE)] -> Set (Domain, TYPE)
forall a. Ord a => [a] -> Set a
Set.fromList
                        ([(Domain, TYPE)] -> Set (Domain, TYPE))
-> ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
    -> [(Domain, TYPE)])
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> Set (Domain, TYPE)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DNSTrace -> (Domain, TYPE)) -> [DNSTrace] -> [(Domain, TYPE)]
forall a b. (a -> b) -> [a] -> [b]
map DNSTrace -> (Domain, TYPE)
filtering
                        ([DNSTrace] -> [(Domain, TYPE)])
-> ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
    -> [DNSTrace])
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> [(Domain, TYPE)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))
 -> Maybe DNSTrace)
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> [DNSTrace]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TestTraceEvent (TraceLocalRootPeers () SockAddr) -> Maybe DNSTrace
forall {a} {a}. Either a a -> Maybe a
selectDnsTraces (TestTraceEvent (TraceLocalRootPeers () SockAddr)
 -> Maybe DNSTrace)
-> ((Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))
    -> TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> Maybe DNSTrace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> TestTraceEvent (TraceLocalRootPeers () SockAddr)
forall a b. (a, b) -> b
snd)
                        ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
 -> Set (Domain, TYPE))
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> Set (Domain, TYPE)
forall a b. (a -> b) -> a -> b
$ [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
tr
          where
            filtering :: DNSTrace -> (Domain, TYPE)
filtering = \case
              DNSLookupResult DNSPeersKind
_ Domain
domain Maybe Domain
Nothing [(IP, PortNumber, TTL)]
_ -> (Domain
domain, TYPE
DNS.A)
              DNSLookupResult DNSPeersKind
_ Domain
_ (Just Domain
domain) [(IP, PortNumber, TTL)]
_ -> (Domain
domain, TYPE
DNS.SRV)
              DNSLookupError DNSPeersKind
_ Maybe DNSLookupType
Nothing Domain
srvDomain DNSError
_ -> (Domain
srvDomain, TYPE
DNS.SRV)
              DNSLookupError DNSPeersKind
_ (Just DNSLookupType
_) Domain
domain DNSError
_ -> (Domain
domain, TYPE
DNS.A)
              SRVLookupResult DNSPeersKind
_ Domain
domain [(Domain, Word16, Word16, Word16, TTL)]
_ -> (Domain
domain, TYPE
DNS.A)
              SRVLookupError DNSPeersKind
_ Domain
domain -> (Domain
domain, TYPE
DNS.SRV)
            selectDnsTraces :: Either a a -> Maybe a
selectDnsTraces = \case
              Right a
trace -> a -> Maybe a
forall a. a -> Maybe a
Just a
trace
              Left  a
_ -> Maybe a
forall a. Maybe a
Nothing
    in
      -- we verify that we tried to resolve all local root domains, and that the
      -- resolved ones are a subset of `maxResultMap`
           [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char]
"violation: localRootDomains isSubsetOf allTriedDomains\nlocalRootDomains: "
                           [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set (Domain, TYPE) -> [Char]
forall a. Show a => a -> [Char]
show Set (Domain, TYPE)
localRootDomains
                           [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"\nallTriedDomains: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Set (Domain, TYPE) -> [Char]
forall a. Show a => a -> [Char]
show Set (Domain, TYPE)
allTriedDomains) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
           Set (Domain, TYPE)
localRootDomains Set (Domain, TYPE) -> Set (Domain, TYPE) -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set (Domain, TYPE)
allTriedDomains
      Bool -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. (Set (Domain, TYPE) -> Property -> Property)
-> Property -> Script (Set (Domain, TYPE)) -> 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, TYPE)
rm Property
r -> [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample (Set (Domain, TYPE) -> [Char]
forall a. Show a => a -> [Char]
show Set (Domain, TYPE)
resultMap [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is subset of "
                                     [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Set (Domain, TYPE) -> [Char]
forall a. Show a => a -> [Char]
show Set (Domain, TYPE)
rm)
                          (Set (Domain, TYPE)
resultMap Set (Domain, TYPE) -> Set (Domain, TYPE) -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set (Domain, TYPE)
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, TYPE))
maxResultMap


-- | The 'localRootPeersProvider' after resolving a DNS domain address
-- should update the local result group list correctly, i.e. add the
-- resolved ip addresses to the correct group where the domain address was
-- (in the initial configuration specification). This property tests whether
-- after a successful DNS lookup the result list is updated correctly.
--
-- Correctly means: Updates in the right place and does not overwrite the
-- previous state.
--
prop_local_updatesDomainsCorrectly :: MockRoots
                                   -> Script DNSTimeout
                                   -> Script DNSLookupDelay
                                   -> TestSeed
                                   -> Property
prop_local_updatesDomainsCorrectly :: MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> Property
prop_local_updatesDomainsCorrectly mockRoots :: MockRoots
mockRoots@(MockRoots LocalRootsConfig
lrp Script MockDNSMap
_ Map RelayAccessPoint PeerAdvertise
_ Script MockDNSMap
_)
                                   Script DNSTimeout
dnsTimeoutScript
                                   Script DNSLookupDelay
dnsLookupDelayScript
                                   TestSeed
dnsSeed =
    let tr :: [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
tr = SimTrace ()
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
forall a.
SimTrace a
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
selectLocalRootPeersWithDNSEvents
           (SimTrace ()
 -> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))])
-> SimTrace ()
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
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) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> MockRoots
-> Maybe LocalRootsConfig
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> IOSim s ()
forall (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 MonadTimer m, MonadTraceSTM m, MonadLabelledSTM m) =>
Tracer m (TestTraceEvent (TraceLocalRootPeers () SockAddr))
-> MockRoots
-> Maybe LocalRootsConfig
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> m ()
mockLocalRootPeersProvider Tracer (IOSim s) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
forall s.
Tracer (IOSim s) (TestTraceEvent (TraceLocalRootPeers () SockAddr))
tracerTraceLocalRoots
                                        MockRoots
mockRoots
                                        Maybe LocalRootsConfig
forall a. Maybe a
Nothing
                                        Script DNSTimeout
dnsTimeoutScript
                                        Script DNSLookupDelay
dnsLookupDelayScript
                                        TestSeed
dnsSeed

        r :: (Bool, (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr)))
r = ((Bool, (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr)))
 -> (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))
 -> (Bool,
     (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))))
-> (Bool, (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr)))
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> (Bool, (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr)))
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, TestTraceEvent (TraceLocalRootPeers () SockAddr)
x)) (Time
t', TestTraceEvent (TraceLocalRootPeers () SockAddr)
y) ->
                    case (TestTraceEvent (TraceLocalRootPeers () SockAddr)
x, TestTraceEvent (TraceLocalRootPeers () SockAddr)
y) of
                      -- Last result groups value, Current result groups value
                      (Left (TraceLocalRootGroups [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
lrpg), Left (TraceLocalRootGroups [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
lrpg')) ->
                        let -- Get all IPs present in last group at position
                            -- 'index'
                            ipsAtIndex :: [SockAddr]
ipsAtIndex = Map SockAddr (LocalRootConfig ()) -> [SockAddr]
forall k a. Map k a -> [k]
Map.keys
                                       (Map SockAddr (LocalRootConfig ()) -> [SockAddr])
-> Map SockAddr (LocalRootConfig ()) -> [SockAddr]
forall a b. (a -> b) -> a -> b
$ ((HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))
 -> Map SockAddr (LocalRootConfig ()))
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> Map SockAddr (LocalRootConfig ())
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 (LocalRootConfig ()))
-> Map SockAddr (LocalRootConfig ())
forall {a} {b} {c}. (a, b, c) -> c
thrd [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
lrpg

                            -- Get all IPs present in current group at position
                            -- 'index'
                            ipsAtIndex' :: [SockAddr]
ipsAtIndex' = Map SockAddr (LocalRootConfig ()) -> [SockAddr]
forall k a. Map k a -> [k]
Map.keys
                                        (Map SockAddr (LocalRootConfig ()) -> [SockAddr])
-> Map SockAddr (LocalRootConfig ()) -> [SockAddr]
forall a b. (a -> b) -> a -> b
$ ((HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))
 -> Map SockAddr (LocalRootConfig ()))
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> Map SockAddr (LocalRootConfig ())
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 (LocalRootConfig ()))
-> Map SockAddr (LocalRootConfig ())
forall {a} {b} {c}. (a, b, c) -> c
thrd [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
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', TestTraceEvent (TraceLocalRootPeers () SockAddr)
y))
                      -- Last DNS lookup result   , Current result groups value
                      (Right (DNSLookupResult DNSPeersKind
_ Domain
dFollow Maybe Domain
dSRV ipsttls :: [(IP, PortNumber, TTL)]
ipsttls@((IP, PortNumber, TTL)
ipttl : [(IP, PortNumber, TTL)]
_)), Left (TraceLocalRootGroups [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
lrpg)) ->
                        -- create and index db for each group
                        let rap :: RelayAccessPoint
rap =
                              case Maybe Domain
dSRV of
                                Just Domain
dSRV' -> Domain -> RelayAccessPoint
RelayAccessSRVDomain Domain
dSRV'
                                Maybe Domain
Nothing    -> Domain -> PortNumber -> RelayAccessPoint
RelayAccessDomain Domain
dFollow ((IP, PortNumber, TTL) -> PortNumber
forall {a} {b} {c}. (a, b, c) -> b
port (IP, PortNumber, TTL)
ipttl)

                            db :: [(Int,
  (HotValency, WarmValency,
   Map RelayAccessPoint (LocalRootConfig ())))]
db = [Int]
-> LocalRootsConfig
-> [(Int,
     (HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig ())))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0,Int
1..] LocalRootsConfig
lrp
                            -- since our MockRoots generator generates
                            -- unique domain addresses we can look for
                            -- which group index does a particular domain
                            -- address belongs
                            index :: Int
index = ((Int,
  (HotValency, WarmValency,
   Map RelayAccessPoint (LocalRootConfig ())))
 -> Int -> Int)
-> Int
-> [(Int,
     (HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig ())))]
-> 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 (LocalRootConfig ())
m)) Int
prev ->
                                            case RelayAccessPoint
-> Map RelayAccessPoint (LocalRootConfig ())
-> Maybe (LocalRootConfig ())
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RelayAccessPoint
rap Map RelayAccessPoint (LocalRootConfig ())
m of
                                              Maybe (LocalRootConfig ())
Nothing -> Int
prev
                                              Just LocalRootConfig ()
_  -> Int
i
                                          ) (-Int
1) [(Int,
  (HotValency, WarmValency,
   Map RelayAccessPoint (LocalRootConfig ())))]
db
                            -- Get all IPs present in group at position
                            -- 'index'
                            ipsAtIndex :: [IP]
ipsAtIndex = (SockAddr -> IP) -> [SockAddr] -> [IP]
forall a b. (a -> b) -> [a] -> [b]
map (\SockAddr
sockAddr ->
                                             case SockAddr
sockAddr of
                                               SockAddrInet PortNumber
_ TTL
hostAddr
                                                 -> IPv4 -> IP
IPv4 (IPv4 -> IP) -> IPv4 -> IP
forall a b. (a -> b) -> a -> b
$ TTL -> IPv4
fromHostAddress TTL
hostAddr
                                               SockAddr
_ -> [Char] -> IP
forall a. HasCallStack => [Char] -> a
error ([Char] -> IP) -> [Char] -> IP
forall a b. (a -> b) -> a -> b
$ SockAddr -> [Char]
forall a. Show a => a -> [Char]
show SockAddr
sockAddr --error "Impossible happened!"

                                         ) ([SockAddr] -> [IP]) -> [SockAddr] -> [IP]
forall a b. (a -> b) -> a -> b
$ Map SockAddr (LocalRootConfig ()) -> [SockAddr]
forall k a. Map k a -> [k]
Map.keys
                                           (Map SockAddr (LocalRootConfig ()) -> [SockAddr])
-> Map SockAddr (LocalRootConfig ()) -> [SockAddr]
forall a b. (a -> b) -> a -> b
$ (HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))
-> Map SockAddr (LocalRootConfig ())
forall {a} {b} {c}. (a, b, c) -> c
thrd
                                           ((HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))
 -> Map SockAddr (LocalRootConfig ()))
-> (HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))
-> Map SockAddr (LocalRootConfig ())
forall a b. (a -> b) -> a -> b
$ [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
lrpg [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> Int
-> (HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))
forall a. HasCallStack => [a] -> Int -> a
!! Int
index :: [IP]
                            -- Check if all ips from the previous DNS
                            -- lookup result are present in the current
                            -- result group at the correct index
                            arePresent :: Bool
arePresent = ((IP, PortNumber, TTL) -> Bool) -> [(IP, PortNumber, TTL)] -> 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, PortNumber, TTL) -> IP) -> (IP, PortNumber, TTL) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IP, PortNumber, TTL) -> IP
forall {a} {b} {c}. (a, b, c) -> a
ip) [(IP, PortNumber, TTL)]
ipsttls
                         in (Bool
arePresent Bool -> Bool -> Bool
&& Bool
b, (Time
t', TestTraceEvent (TraceLocalRootPeers () SockAddr)
y))
                      -- the empty DNS result trivially passes
                      (Right (DNSLookupResult DNSPeersKind
_ Domain
_ Maybe Domain
_ []), Left (TraceLocalRootGroups {})) ->
                        (Bool
b, (Time
t', TestTraceEvent (TraceLocalRootPeers () SockAddr)
y))
                      (Right {}, TestTraceEvent (TraceLocalRootPeers () SockAddr)
_) -> (Bool
b, (Time
t, TestTraceEvent (TraceLocalRootPeers () SockAddr)
x))
                      (TestTraceEvent (TraceLocalRootPeers () SockAddr)
_, TestTraceEvent (TraceLocalRootPeers () SockAddr)
_)        -> (Bool
b, (Time
t', TestTraceEvent (TraceLocalRootPeers () SockAddr)
y))
                   )
              (Bool
True, [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))
forall a. HasCallStack => [a] -> a
head [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
tr)
              ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
-> [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
forall a. HasCallStack => [a] -> [a]
tail [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr))]
tr)
     in Bool -> Property
forall prop. Testable prop => prop -> Property
property ((Bool, (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr)))
-> Bool
forall a b. (a, b) -> a
fst (Bool, (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr)))
r)
  where
    thrd :: (a, b, c) -> c
thrd (a
_, b
_, c
c) = c
c
    port :: (a, b, c) -> b
port (a
_, b
it, c
_) = b
it
    ip :: (a, b, c) -> a
ip   (a
it, b
_, c
_) = a
it

--
-- Public Root Peers Provider Tests
--

-- | Delay and timeout script which make sure that eventually the dns lookup
-- will not timeout.
--
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
      ]



-- | The 'publicRootPeersProvider' should be able to resolve DNS domains
-- correctly, assuming the domain maps to any IP address. This property
-- tests whether 'publicRootPeersProvider' is capable of eventually resolving domain
-- addresses even after having failed to do so in the first attempt, in
-- a bounded amount of time.
--
prop_public_resolvesDomainsCorrectly :: MockRoots
                                     -> DelayAndTimeoutScripts
                                     -> Int
                                     -> TestSeed
                                     -> Property
prop_public_resolvesDomainsCorrectly :: MockRoots -> DelayAndTimeoutScripts -> Int -> TestSeed -> Property
prop_public_resolvesDomainsCorrectly
    mockRoots :: MockRoots
mockRoots@(MockRoots LocalRootsConfig
_ Script MockDNSMap
_ Map RelayAccessPoint PeerAdvertise
_ Script MockDNSMap
pDNSMap)
    (DelayAndTimeoutScripts Script DNSLookupDelay
dnsLookupDelayScript Script DNSTimeout
dnsTimeoutScript)
    Int
n
    TestSeed
dnsSeed
  =
    let pDNSMap' :: MockDNSMap
pDNSMap' = Script MockDNSMap -> MockDNSMap
forall a. Script a -> a
scriptHead Script MockDNSMap
pDNSMap
        mockPublicRootPeersDNSMap :: Script MockDNSMap
mockPublicRootPeersDNSMap = MockDNSMap -> Script MockDNSMap
forall a. a -> Script a
singletonScript MockDNSMap
pDNSMap'
        mockRoots' :: MockRoots
mockRoots' =
          MockRoots
mockRoots { mockPublicRootPeersDNSMap }
        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) (TestTraceEvent TracePublicRootPeers)
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> ((Int -> IOSim s (Map SockAddr PeerAdvertise, TTL))
    -> IOSim s (Map SockAddr PeerAdvertise, TTL))
-> IOSim s ()
forall (m :: * -> *) a.
(MonadAsync m, MonadDelay m, MonadThrow m, MonadTimer m) =>
Tracer m (TestTraceEvent TracePublicRootPeers)
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> ((Int -> m (Map SockAddr PeerAdvertise, TTL)) -> m a)
-> m ()
mockPublicRootPeersProvider Tracer (IOSim s) (TestTraceEvent TracePublicRootPeers)
forall s. Tracer (IOSim s) (TestTraceEvent TracePublicRootPeers)
tracerTracePublicRoots
                                         MockRoots
mockRoots'
                                         Script DNSTimeout
dnsTimeoutScript
                                         Script DNSLookupDelay
dnsLookupDelayScript
                                         TestSeed
dnsSeed
                                         ((Int -> IOSim s (Map SockAddr PeerAdvertise, TTL))
-> Int -> IOSim s (Map SockAddr PeerAdvertise, TTL)
forall a b. (a -> b) -> a -> b
$ Int
n)

        successes :: [(Time, DNSTrace)]
successes = forall a. [(Time, TestTraceEvent a)] -> [(Time, DNSTrace)]
selectDnsResultEvents @TracePublicRootPeers
                  ([(Time, TestTraceEvent TracePublicRootPeers)]
 -> [(Time, DNSTrace)])
-> (SimTrace () -> [(Time, TestTraceEvent TracePublicRootPeers)])
-> SimTrace ()
-> [(Time, DNSTrace)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimTrace () -> [(Time, TestTraceEvent TracePublicRootPeers)]
forall b a. Typeable b => SimTrace a -> [(Time, TestTraceEvent b)]
selectTestTraceEvents
                  (SimTrace () -> [(Time, DNSTrace)])
-> SimTrace () -> [(Time, DNSTrace)]
forall a b. (a -> b) -> a -> b
$ SimTrace ()
tr

        successes' :: [DNSTrace]
successes' = ((Time, DNSTrace) -> DNSTrace) -> [(Time, DNSTrace)] -> [DNSTrace]
forall a b. (a -> b) -> [a] -> [b]
map (Time, DNSTrace) -> DNSTrace
forall a b. (a, b) -> b
snd [(Time, DNSTrace)]
successes

        step :: DNSTrace -> Property -> Property
        step :: DNSTrace -> Property -> Property
step (DNSLookupResult DNSPeersKind
_ Domain
"" (Just Domain
srvDomain) []) Property
r =
          [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"SRV record not found in mock lookup map" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
            (Domain, TYPE) -> MockDNSMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (Domain
srvDomain, TYPE
DNS.SRV) MockDNSMap
pDNSMap' Bool -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Property
r
        step (DNSLookupResult DNSPeersKind
_ Domain
domain Maybe Domain
srvDomain [(IP, PortNumber, TTL)]
ipsttls) Property
r =
          case Maybe Domain
srvDomain of
            Maybe Domain
Nothing ->
               [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"DNS.A IP mismatch error" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                 ([IP]
fromLookup [IP] -> [IP] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [IP]
fromTrace) Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Property
r
               where
                 fromLookup :: [IP]
fromLookup =
                  (IP, TTL) -> IP
forall a b. (a, b) -> a
fst ((IP, TTL) -> IP) -> [(IP, TTL)] -> [IP]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(IP, TTL)]
-> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
-> [(IP, TTL)]
forall a b. a -> Either a b -> a
fromLeft ([Char] -> [(IP, TTL)]
forall a. HasCallStack => [Char] -> a
error [Char]
e) (MockDNSMap
pDNSMap' MockDNSMap
-> (Domain, TYPE)
-> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
forall k a. Ord k => Map k a -> k -> a
Map.! (Domain
domain, TYPE
DNS.A))
                 e :: [Char]
e = [Char]
"Domain " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Domain -> [Char]
forall a. Show a => a -> [Char]
show Domain
domain [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" not found in lookup map"
                 fromTrace :: [IP]
fromTrace = (IP, PortNumber, TTL) -> IP
forall {a} {b} {c}. (a, b, c) -> a
ip ((IP, PortNumber, TTL) -> IP) -> [(IP, PortNumber, TTL)] -> [IP]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(IP, PortNumber, TTL)]
ipsttls
            Just Domain
srvDomain' ->
              [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"SRV lookup error" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                case (Domain, TYPE)
-> MockDNSMap
-> Maybe
     (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Domain
srvDomain', TYPE
DNS.SRV) MockDNSMap
pDNSMap' of
                  Maybe (Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)])
Nothing -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
                  Just (Left {}) -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
                  Just (Right [(Domain, Word16, Word16, PortNumber)]
ds) ->
                    case ((Domain, Word16, Word16, PortNumber) -> Bool)
-> [(Domain, Word16, Word16, PortNumber)]
-> Maybe (Domain, Word16, Word16, PortNumber)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Domain
domain Domain -> Domain -> Bool
forall a. Eq a => a -> a -> Bool
==) (Domain -> Bool)
-> ((Domain, Word16, Word16, PortNumber) -> Domain)
-> (Domain, Word16, Word16, PortNumber)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Domain, Word16, Word16, PortNumber) -> Domain
forall {a} {b} {c} {d}. (a, b, c, d) -> a
dFollow) [(Domain, Word16, Word16, PortNumber)]
ds of
                      Maybe (Domain, Word16, Word16, PortNumber)
Nothing -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
                      Just (Domain
d, Word16
_, Word16
_, PortNumber
_) ->
                        [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample [Char]
"IP mismatch" (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
                          [IP]
fromLookup [IP] -> [IP] -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== [IP]
fromTrace Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Property
r
                        where
                          fromLookup :: [IP]
fromLookup =
                            (IP, TTL) -> IP
forall a b. (a, b) -> a
fst ((IP, TTL) -> IP) -> [(IP, TTL)] -> [IP]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(IP, TTL)]
-> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
-> [(IP, TTL)]
forall a b. a -> Either a b -> a
fromLeft ([Char] -> [(IP, TTL)]
forall a. HasCallStack => [Char] -> a
error [Char]
err) (MockDNSMap
pDNSMap' MockDNSMap
-> (Domain, TYPE)
-> Either [(IP, TTL)] [(Domain, Word16, Word16, PortNumber)]
forall k a. Ord k => Map k a -> k -> a
Map.! (Domain
d, TYPE
DNS.A))
                          err :: [Char]
err = [Char]
"Domain " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Domain -> [Char]
forall a. Show a => a -> [Char]
show Domain
d [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" from SRV lookup of " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Domain -> [Char]
forall a. Show a => a -> [Char]
show Domain
srvDomain'
                                [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
" not found."
                          fromTrace :: [IP]
fromTrace = (IP, PortNumber, TTL) -> IP
forall {a} {b} {c}. (a, b, c) -> a
ip ((IP, PortNumber, TTL) -> IP) -> [(IP, PortNumber, TTL)] -> [IP]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(IP, PortNumber, TTL)]
ipsttls

        step (SRVLookupResult DNSPeersKind
_ Domain
domain [(Domain, Word16, Word16, Word16, TTL)]
_) Property
r =
          (Domain, TYPE) -> MockDNSMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (Domain
domain, TYPE
DNS.SRV) MockDNSMap
pDNSMap' Bool -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Property
r
        step DNSTrace
_ Property
_ = [Char] -> Property
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible!"
     in
       (DNSTrace -> Property -> Property)
-> Property -> [DNSTrace] -> Property
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DNSTrace -> Property -> Property
step (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True) [DNSTrace]
successes'
  where
    ip :: (a, b, c) -> a
ip (a
it, b
_, c
_) = a
it
    dFollow :: (a, b, c, d) -> a
dFollow (a
it, b
_, c
_, d
_) = a
it



-- | Create a resource from a list.
--
-- Invariant: the resource fails if it is run more than the number of items.
--
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. Monad m => 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)


-- | Verify retryResource
--
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. Applicative m => (a -> m ()) -> Tracer m a
mkTracer (\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. Applicative m => (a -> m ()) -> Tracer m a
mkTracer (\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. Monad 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

    -- pure model of `retryResource`
    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
           -- ^ current time
           -> [(Time, Int)]
           -- ^ results
           -> NonEmpty DiffTime
           -- ^ delays stack
           -> [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) =
          -- lefts cause delay
          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) =
          -- rights do not take time
          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 -> InspectMonadSTM m TraceValue
forall a. a -> InspectMonadSTM 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!"