{-# 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 (forever, replicateM_)
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 (mapMaybe)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Time.Clock (picosecondsToDiffTime)
import Data.Void (Void)
import Data.Word (Word16)
import Network.DNS (DNSError (NameError), DNSMessage, ResourceRecord (..), TTL,
           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 (throw)
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadSay (MonadSay (..))
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime (getMonotonicTime),
           Time (..), addTime)
import Control.Monad.Class.MonadTimer.SI
import Control.Monad.Class.MonadTimer.SI qualified as MonadTimer
import Control.Monad.IOSim
import Control.Tracer (Tracer (Tracer), contramap, nullTracer, traceWith)

import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..))
import Ouroboros.Network.PeerSelection
import Ouroboros.Network.PeerSelection.RootPeersDNS
import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..),
           LocalRootConfig (..), WarmValency (..))
import Test.Ouroboros.Network.Data.Script (Script (Script), initScript',
           scriptHead, singletonScript, stepScript')
import Test.Ouroboros.Network.PeerSelection.Instances
import Test.QuickCheck
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)

tests :: TestTree
tests :: TestTree
tests =
  [Char] -> [TestTree] -> TestTree
testGroup [Char]
"Ouroboros.Network.PeerSelection"
  [ [Char] -> [TestTree] -> TestTree
testGroup [Char]
"RootPeersDNS"
    [ [Char] -> [TestTree] -> TestTree
testGroup [Char]
"localRootPeersProvider"
       [ [Char]
-> (MockRoots
    -> Script DNSTimeout
    -> Script DNSLookupDelay
    -> 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] -> [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. [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
genPort
      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. [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]

type MockDNSLookupResult = Either [(IP, TTL)]
                                  [( DNS.Domain
                                   , Word16 -- ^ priority
                                   , Word16 -- ^ weight
                                   , PortNumber)]
type MockDNSMap = (Map (DNS.Domain, DNS.TYPE) MockDNSLookupResult)

data MockRoots = MockRoots {
    MockRoots
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ()))]
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
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 ipsPerDomain = Int
2
        genLookup t RelayAccessPoint
relays = do
          let ([RelayAccessPoint]
_relayAddress, [DomainAccessPoint]
relayDomains, [DomainAccessPoint]
relaySRVs) =
                (([RelayAccessPoint], [DomainAccessPoint], [DomainAccessPoint])
 -> RelayAccessPoint
 -> ([RelayAccessPoint], [DomainAccessPoint], [DomainAccessPoint]))
-> ([RelayAccessPoint], [DomainAccessPoint], [DomainAccessPoint])
-> t RelayAccessPoint
-> ([RelayAccessPoint], [DomainAccessPoint], [DomainAccessPoint])
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([RelayAccessPoint], [DomainAccessPoint], [DomainAccessPoint])
-> RelayAccessPoint
-> ([RelayAccessPoint], [DomainAccessPoint], [DomainAccessPoint])
threeWay ([], [], []) t RelayAccessPoint
relays
          lookupIP <- Int -> [Domain] -> Gen MockDNSMap
genDomainIPLookupTable Int
ipsPerDomain (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

        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 ())]
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ()))]
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 (genLookup 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 (genLookup publicRootRelays)

    return (MockRoots {
      mockLocalRootPeers        = localRootPeers,
      mockLocalRootPeersDNSMap  = lrpDNSMap,
      mockPublicRootPeers       = publicRootPeers,
      mockPublicRootPeersDNSMap = publicRootPeersDNSMap
    })
  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)

    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)

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

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

-- 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}.
(Arbitrary a, Arbitrary a) =>
[(a, [(a, a, a, PortNumber)])]
-> [(a, [a])] -> Gen [(a, [(a, a, a, PortNumber)])]
go []
 where
  go :: [(a, [(a, a, a, PortNumber)])]
-> [(a, [a])] -> Gen [(a, [(a, a, a, PortNumber)])]
go [(a, [(a, a, a, PortNumber)])]
acc [] = [(a, [(a, a, a, PortNumber)])]
-> Gen [(a, [(a, a, a, PortNumber)])]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return [(a, [(a, a, a, PortNumber)])]
acc
  go [(a, [(a, a, a, PortNumber)])]
acc ((a
srv, [a]
subordinates):[(a, [a])]
srvs) = do
    let worker :: [(a, a, a, PortNumber)]
-> Int -> [a] -> Gen [(a, a, a, PortNumber)]
worker [(a, a, a, PortNumber)]
grouped Int
0 [a]
_ = [(a, a, a, PortNumber)] -> Gen [(a, a, a, PortNumber)]
forall a. [a] -> Gen [a]
shuffle [(a, a, a, PortNumber)]
grouped
        worker [(a, a, a, PortNumber)]
grouped Int
count [a]
domains' = do
          howMany <- (Int, Int) -> Gen Int
chooseInt (Int
1, Int
count)
          port <- genPort
          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, PortNumber
port)
              grouped' = (a -> a -> (a, a, a, PortNumber))
-> [a] -> [a] -> [(a, a, a, PortNumber)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> (a, a, a, PortNumber)
forall {a} {c}. a -> c -> (a, a, c, PortNumber)
smash [a]
group [a]
wts
                         [(a, a, a, PortNumber)]
-> [(a, a, a, PortNumber)] -> [(a, a, a, PortNumber)]
forall a. Semigroup a => a -> a -> a
<> [(a, a, a, PortNumber)]
grouped
          worker grouped' (count - howMany) (drop howMany domains')
    organized <- [(a, a, a, PortNumber)]
-> Int -> [a] -> Gen [(a, a, a, PortNumber)]
forall {a} {a} {a}.
(Arbitrary a, Arbitrary a) =>
[(a, a, a, PortNumber)]
-> Int -> [a] -> Gen [(a, a, a, PortNumber)]
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

instance Arbitrary MockRoots where
    arbitrary :: Gen MockRoots
arbitrary = Gen MockRoots
genMockRoots
    shrink :: MockRoots -> [MockRoots]
shrink roots :: MockRoots
roots@MockRoots
      { [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
mockLocalRootPeers :: MockRoots
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ()))]
mockLocalRootPeers :: [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
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
              }
      | [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
lrp <- ((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))
 -> [(HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig ()))])
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ()))]
-> [[(HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig ()))]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ([(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
-> (HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ()))
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ()))]
forall a b. a -> b -> a
const []) [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
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)])
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ()))]
-> [(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)
                  [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
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 = [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
-> Script MockDNSMap
-> Map RelayAccessPoint PeerAdvertise
-> Script MockDNSMap
-> MockRoots
MockRoots [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
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 :: [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
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 -> () -> LocalRootConfig ()
forall extraFlags.
PeerAdvertise
-> DiffusionMode -> extraFlags -> LocalRootConfig extraFlags
LocalRootConfig PeerAdvertise
DoAdvertisePeer DiffusionMode
InitiatorAndResponderDiffusionMode ()
            )
          , ( Domain -> PortNumber -> RelayAccessPoint
RelayAccessDomain  Domain
"test.domain"      ([Char] -> PortNumber
forall a. Read a => [Char] -> a
read [Char]
"4444")
            , PeerAdvertise -> DiffusionMode -> () -> LocalRootConfig ()
forall extraFlags.
PeerAdvertise
-> DiffusionMode -> extraFlags -> LocalRootConfig extraFlags
LocalRootConfig PeerAdvertise
DoNotAdvertisePeer DiffusionMode
InitiatorAndResponderDiffusionMode ()
            )
          ]
        )
      ]
    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. Int -> Gen a -> Gen a
resize (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
hi) Gen (NonNegative Integer)
forall a. Arbitrary a => Gen a
arbitrary


newtype DNSTimeout = DNSTimeout { DNSTimeout -> DiffTime
getDNSTimeout :: DiffTime }
  deriving Int -> DNSTimeout -> ShowS
[DNSTimeout] -> ShowS
DNSTimeout -> [Char]
(Int -> DNSTimeout -> ShowS)
-> (DNSTimeout -> [Char])
-> ([DNSTimeout] -> ShowS)
-> Show DNSTimeout
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DNSTimeout -> ShowS
showsPrec :: Int -> DNSTimeout -> ShowS
$cshow :: DNSTimeout -> [Char]
show :: DNSTimeout -> [Char]
$cshowList :: [DNSTimeout] -> ShowS
showList :: [DNSTimeout] -> ShowS
Show

instance Arbitrary DNSTimeout where
    arbitrary :: Gen DNSTimeout
arbitrary = DiffTime -> DNSTimeout
DNSTimeout (DiffTime -> DNSTimeout) -> Gen DiffTime -> Gen DNSTimeout
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen DiffTime
genDiffTime Integer
110 Integer
300
    shrink :: DNSTimeout -> [DNSTimeout]
shrink (DNSTimeout DiffTime
delta) =
      [ DiffTime -> DNSTimeout
DNSTimeout (Ratio Integer -> DiffTime
forall a. Fractional a => Ratio Integer -> a
fromRational Ratio Integer
delta')
      | Ratio Integer
delta' <- Ratio Integer -> [Ratio Integer]
forall a. Arbitrary a => a -> [a]
shrink (DiffTime -> Ratio Integer
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
delta)
      , Ratio Integer
delta' Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Ratio Integer
110
      ]


newtype DNSLookupDelay = DNSLookupDelay { DNSLookupDelay -> DiffTime
getDNSLookupDelay :: DiffTime }
  deriving Int -> DNSLookupDelay -> ShowS
[DNSLookupDelay] -> ShowS
DNSLookupDelay -> [Char]
(Int -> DNSLookupDelay -> ShowS)
-> (DNSLookupDelay -> [Char])
-> ([DNSLookupDelay] -> ShowS)
-> Show DNSLookupDelay
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DNSLookupDelay -> ShowS
showsPrec :: Int -> DNSLookupDelay -> ShowS
$cshow :: DNSLookupDelay -> [Char]
show :: DNSLookupDelay -> [Char]
$cshowList :: [DNSLookupDelay] -> ShowS
showList :: [DNSLookupDelay] -> ShowS
Show

instance Arbitrary DNSLookupDelay where
    arbitrary :: Gen DNSLookupDelay
arbitrary = DiffTime -> DNSLookupDelay
DNSLookupDelay (DiffTime -> DNSLookupDelay) -> Gen DiffTime -> Gen DNSLookupDelay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Integer -> Integer -> Gen DiffTime
genDiffTime Integer
20 Integer
120
    shrink :: DNSLookupDelay -> [DNSLookupDelay]
shrink (DNSLookupDelay DiffTime
delta) =
      [ DiffTime -> DNSLookupDelay
DNSLookupDelay (Ratio Integer -> DiffTime
forall a. Fractional a => Ratio Integer -> a
fromRational Ratio Integer
delta')
      | Ratio Integer
delta' <- Ratio Integer -> [Ratio Integer]
forall a. Arbitrary a => a -> [a]
shrink (DiffTime -> Ratio Integer
forall a b. (Real a, Fractional b) => a -> b
realToFrac DiffTime
delta)
      , Ratio Integer
delta' Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Ratio Integer
20
      ]

-- | Mock DNSActions data structure for testing purposes.
-- Adds DNS Lookup function for IOSim with different timeout and lookup
-- delays for every attempt.
mockDNSActions :: forall exception 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 () exception m
mockDNSActions :: forall exception 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 () exception 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 exception) ()))
forall {m :: * -> *} {m :: * -> *} {p} {a}.
(Monad m, Applicative m) =>
p -> m (Resource m (Either a ()))
dnsResolverResource :: forall {m :: * -> *} {m :: * -> *} {p} {a}.
(Monad m, Applicative m) =>
p -> m (Resource m (Either a ()))
dnsResolverResource :: ResolvConf -> m (Resource m (Either (DNSorIOError exception) ()))
dnsResolverResource,
      ResolvConf -> m (Resource m (Either (DNSorIOError exception) ()))
forall {m :: * -> *} {m :: * -> *} {p} {a}.
(Monad m, Applicative m) =>
p -> m (Resource m (Either a ()))
dnsAsyncResolverResource :: forall {m :: * -> *} {m :: * -> *} {p} {a}.
(Monad m, Applicative m) =>
p -> m (Resource m (Either a ()))
dnsAsyncResolverResource :: ResolvConf -> m (Resource m (Either (DNSorIOError exception) ()))
dnsAsyncResolverResource,
      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']}

-- | '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 Failure))
                           -> MockRoots
                           -> 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 Failure))
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> m ()
mockLocalRootPeersProvider Tracer m (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
tracer (MockRoots [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
localRootPeers Script MockDNSMap
dnsMapScript Map RelayAccessPoint PeerAdvertise
_ Script MockDNSMap
_)
                           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
      withAsync (updateDNSMap dnsMapScriptVar dnsMapVar) $ \Async m Void
_ -> do
        m (Maybe Void) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe Void) -> m ()) -> m (Maybe Void) -> m ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> m Void -> m (Maybe Void)
forall a. DiffTime -> m a -> m (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
MonadTimer.timeout DiffTime
3600 (m Void -> m (Maybe Void)) -> m Void -> m (Maybe Void)
forall a b. (a -> b) -> a -> b
$
          Tracer m (TraceLocalRootPeers () SockAddr Failure)
-> PeerActionsDNS SockAddr () Failure m
-> ResolvConf
-> StdGen
-> STM
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig ()))]
-> StrictTVar
     m [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> m Void
forall (m :: * -> *) extraFlags peerAddr resolver exception.
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 Ord peerAddr, Eq extraFlags) =>
Tracer m (TraceLocalRootPeers extraFlags peerAddr exception)
-> PeerActionsDNS peerAddr resolver exception m
-> ResolvConf
-> StdGen
-> STM
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> StrictTVar
     m
     [(HotValency, WarmValency,
       Map peerAddr (LocalRootConfig extraFlags))]
-> m Void
localRootPeersProvider ((TraceLocalRootPeers () SockAddr Failure
 -> TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
-> Tracer
     m (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
-> Tracer m (TraceLocalRootPeers () SockAddr Failure)
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 Failure
-> TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)
forall a b. a -> Either a b
Left Tracer m (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
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 () Failure m
paDnsActions =
                                     Tracer m DNSTrace
-> DNSLookupType
-> (IP -> PortNumber -> SockAddr)
-> StrictTVar m MockDNSMap
-> StrictTVar m (Script DNSTimeout)
-> StrictTVar m (Script DNSLookupDelay)
-> DNSActions SockAddr () Failure m
forall exception 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 () exception m
mockDNSActions
                                       ((DNSTrace
 -> TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
-> Tracer
     m (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
-> 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 Failure)
forall a b. b -> Either a b
Right Tracer m (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
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
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ()))]
-> STM
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig ()))]
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig ()))]
localRootPeersVar)
                                 StrictTVar
  m [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
resultVar
        -- if there's no dns domain, `localRootPeersProvider` will never write
        -- to `resultVar`; thus the `traceTVarIO` callback will never execute.
        -- 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
    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, DiffTime)) -> 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, DiffTime)) -> m a)
-> m ()
mockPublicRootPeersProvider Tracer m (TestTraceEvent TracePublicRootPeers)
tracer (MockRoots [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
_ Script MockDNSMap
_ Map RelayAccessPoint PeerAdvertise
publicRootPeers Script MockDNSMap
dnsMapScript)
                            Script DNSTimeout
dnsTimeoutScript Script DNSLookupDelay
dnsLookupDelayScript TestSeed
dnsSeed (Int -> m (Map SockAddr PeerAdvertise, DiffTime)) -> 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 @Failure
                                  (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 [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
_ 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 @Failure
                           (contramap Right tracer)
                           LookupReqAOnly
                           (curry toSockAddr)
                           dnsMapVar
                           dnsTimeoutScriptVar
                           dnsLookupDelayScriptVar)
                         AllLedgerPeers
                         relays
                         (mkStdGen dnsSeed)

--
-- Utils for properties
--

type TestTraceEvent a = Either a DNSTrace

tracerTraceLocalRoots :: Tracer (IOSim s) (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
tracerTraceLocalRoots :: forall s.
Tracer
  (IOSim s)
  (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
tracerTraceLocalRoots = (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)
 -> IOSim s ())
-> Tracer
     (IOSim s)
     (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)
-> 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. (a -> m ()) -> Tracer m a
Tracer 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 Failure))]
selectLocalRootPeersWithDNSEvents :: forall a.
SimTrace a
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
selectLocalRootPeersWithDNSEvents = ((Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
 -> Bool)
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
forall a. (a -> Bool) -> [a] -> [a]
filter (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
-> Bool
forall {a} {a}. (a, Either a DNSTrace) -> Bool
them ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
 -> [(Time,
      TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))])
-> (SimTrace a
    -> [(Time,
         TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))])
-> SimTrace a
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimTrace a
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
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
        (DNSResult DNSPeersKind
DNSLocalPeer Domain
_ Maybe Domain
_ [(IP, PortNumber, TTL)]
_)           -> Bool
True
        (DNSTraceLookupError DNSPeersKind
DNSLocalPeer Maybe DNSLookupType
_ Domain
_ DNSError
_) -> Bool
True
        (DNSSRVFail DNSPeersKind
DNSLocalPeer Domain
_)              -> Bool
True
        DNSTrace
_otherwise                               -> Bool
False
    them (a, Either a DNSTrace)
_ = Bool
True

selectLocalRootGroupsEvents :: [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
                            -> [(Time, [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
selectLocalRootGroupsEvents :: [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
selectLocalRootGroupsEvents [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
trace = [ (Time
t, [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
r)
                                    | (Time
t, Left (TraceLocalRootGroups [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
r)) <- [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
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
        (DNSResult DNSPeersKind
DNSPublicPeer Domain
_ Maybe Domain
_ [(IP, PortNumber, TTL)]
_)           -> Bool
True
        (DNSTraceLookupError DNSPeersKind
DNSPublicPeer Maybe DNSLookupType
_ Domain
_ DNSError
_) -> Bool
True
        (DNSSRVFail 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@(DNSResult {})) <- [(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 [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
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 Failure))]
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
selectLocalRootGroupsEvents
           ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
 -> [(Time,
      [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])])
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
forall a b. (a -> b) -> a -> b
$ SimTrace ()
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
forall a.
SimTrace a
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
selectLocalRootPeersWithDNSEvents
           (SimTrace ()
 -> [(Time,
      TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))])
-> SimTrace ()
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
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 Failure))
-> MockRoots
-> 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 Failure))
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> m ()
mockLocalRootPeersProvider Tracer
  (IOSim s)
  (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
forall s.
Tracer
  (IOSim s)
  (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
tracerTraceLocalRoots
                                        MockRoots
mockRoots
                                        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 = [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
-> Set SockAddr
forall a b.
[(a, b, Map RelayAccessPoint (LocalRootConfig ()))] -> Set SockAddr
localRootAddresses [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
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 '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 [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
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 Failure))]
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
selectLocalRootGroupsEvents
           ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
 -> [(Time,
      [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])])
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))])]
forall a b. (a -> b) -> a -> b
$ SimTrace ()
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
forall a.
SimTrace a
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
selectLocalRootPeersWithDNSEvents
           (SimTrace ()
 -> [(Time,
      TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))])
-> SimTrace ()
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
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 Failure))
-> MockRoots
-> 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 Failure))
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> m ()
mockLocalRootPeersProvider Tracer
  (IOSim s)
  (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
forall s.
Tracer
  (IOSim s)
  (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
tracerTraceLocalRoots
                                        MockRoots
mockRoots
                                        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
== [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
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'))
                                   [ [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
-> [(HotValency, WarmValency, Map SockAddr (LocalRootConfig ()))]
-> [((HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig ())),
     (HotValency, WarmValency, Map SockAddr (LocalRootConfig ())))]
forall a b. [a] -> [b] -> [(a, b)]
zip [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
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 [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
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 Failure))]
tr = SimTrace ()
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
forall a.
SimTrace a
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
selectLocalRootPeersWithDNSEvents
           (SimTrace ()
 -> [(Time,
      TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))])
-> SimTrace ()
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
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 Failure))
-> MockRoots
-> 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 Failure))
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> m ()
mockLocalRootPeersProvider Tracer
  (IOSim s)
  (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
forall s.
Tracer
  (IOSim s)
  (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
tracerTraceLocalRoots
                                        MockRoots
mockRoots'
                                        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) <- [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
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))
-> [(Domain, TYPE)] -> Set (Domain, TYPE)
forall a b. (a -> b) -> a -> b
$ ((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, DNSTrace)] -> [(Domain, TYPE)]
forall a b. (a -> b) -> a -> b
$ [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
-> [(Time, DNSTrace)]
forall a. [(Time, TestTraceEvent a)] -> [(Time, DNSTrace)]
selectDnsResultEvents
                    ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
 -> [(Time, DNSTrace)])
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
-> [(Time, DNSTrace)]
forall a b. (a -> b) -> a -> b
$ [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
tr
          where
            filtering :: DNSTrace -> Maybe (Domain, TYPE)
filtering = \case
              DNSResult 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)
              DNSResult 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))
-> [(Domain, TYPE)] -> Set (Domain, TYPE)
forall a b. (a -> b) -> a -> b
$ (DNSTrace -> (Domain, TYPE)) -> [DNSTrace] -> [(Domain, TYPE)]
forall a b. (a -> b) -> [a] -> [b]
map DNSTrace -> (Domain, TYPE)
filtering
                          ([DNSTrace] -> [(Domain, TYPE)]) -> [DNSTrace] -> [(Domain, TYPE)]
forall a b. (a -> b) -> a -> b
$ ((Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
 -> Maybe DNSTrace)
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
-> [DNSTrace]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)
-> Maybe DNSTrace
forall {a} {a}. Either a a -> Maybe a
selectDnsTraces (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)
 -> Maybe DNSTrace)
-> ((Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
    -> TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
-> (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
-> Maybe DNSTrace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
-> TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)
forall a b. (a, b) -> b
snd)
                          ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
 -> [DNSTrace])
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
-> [DNSTrace]
forall a b. (a -> b) -> a -> b
$ [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
tr
          where
            filtering :: DNSTrace -> (Domain, TYPE)
filtering = \case
              DNSResult DNSPeersKind
_ Domain
domain Maybe Domain
Nothing [(IP, PortNumber, TTL)]
_ -> (Domain
domain, TYPE
DNS.A)
              DNSResult DNSPeersKind
_ Domain
_ (Just Domain
domain) [(IP, PortNumber, TTL)]
_ -> (Domain
domain, TYPE
DNS.SRV)
              DNSSRVFail DNSPeersKind
_ Domain
domain -> (Domain
domain, TYPE
DNS.SRV)
              DNSTraceLookupError DNSPeersKind
_ Maybe DNSLookupType
Nothing Domain
srvDomain DNSError
_ -> (Domain
srvDomain, TYPE
DNS.SRV)
              DNSTraceLookupError DNSPeersKind
_ (Just DNSLookupType
_) Domain
domain DNSError
_ -> (Domain
domain, TYPE
DNS.A)
            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 [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
lrp Script MockDNSMap
_ Map RelayAccessPoint PeerAdvertise
_ Script MockDNSMap
_)
                                   Script DNSTimeout
dnsTimeoutScript
                                   Script DNSLookupDelay
dnsLookupDelayScript
                                   TestSeed
dnsSeed =
    let tr :: [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
tr = SimTrace ()
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
forall a.
SimTrace a
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
selectLocalRootPeersWithDNSEvents
           (SimTrace ()
 -> [(Time,
      TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))])
-> SimTrace ()
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
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 Failure))
-> MockRoots
-> 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 Failure))
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> TestSeed
-> m ()
mockLocalRootPeersProvider Tracer
  (IOSim s)
  (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
forall s.
Tracer
  (IOSim s)
  (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
tracerTraceLocalRoots
                                        MockRoots
mockRoots
                                        Script DNSTimeout
dnsTimeoutScript
                                        Script DNSLookupDelay
dnsLookupDelayScript
                                        TestSeed
dnsSeed

        r :: (Bool,
 (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)))
r = ((Bool,
  (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)))
 -> (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
 -> (Bool,
     (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))))
-> (Bool,
    (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)))
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
-> (Bool,
    (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (\(Bool
b, (Time
t, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)
x)) (Time
t', TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)
y) ->
                    case (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)
x, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)
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 Failure)
y))
                      -- Last DNS lookup result   , Current result groups value
                      (Right (DNSResult 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]
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig ()))]
-> [(Int,
     (HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig ())))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0,Int
1..] [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
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 Failure)
y))
                      -- the empty DNS result trivially passes
                      (Right (DNSResult DNSPeersKind
_ Domain
_ Maybe Domain
_ []), Left (TraceLocalRootGroups {})) ->
                        (Bool
b, (Time
t', TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)
y))
                      (Right {}, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)
_) -> (Bool
b, (Time
t, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)
x))
                      (TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)
_, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)
_)        -> (Bool
b, (Time
t', TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)
y))
                   )
              (Bool
True, [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
-> (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))
forall a. HasCallStack => [a] -> a
head [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
tr)
              ([(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
-> [(Time,
     TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
forall a. HasCallStack => [a] -> [a]
tail [(Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure))]
tr)
     in Bool -> Property
forall prop. Testable prop => prop -> Property
property ((Bool,
 (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)))
-> Bool
forall a b. (a, b) -> a
fst (Bool,
 (Time, TestTraceEvent (TraceLocalRootPeers () SockAddr Failure)))
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 [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig ()))]
_ 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, DiffTime))
    -> IOSim s (Map SockAddr PeerAdvertise, DiffTime))
-> 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, DiffTime)) -> 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, DiffTime))
-> Int -> IOSim s (Map SockAddr PeerAdvertise, DiffTime)
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)])
-> [(Time, TestTraceEvent TracePublicRootPeers)]
-> [(Time, DNSTrace)]
forall a b. (a -> b) -> a -> b
$ SimTrace () -> [(Time, TestTraceEvent TracePublicRootPeers)]
forall b a. Typeable b => SimTrace a -> [(Time, TestTraceEvent b)]
selectTestTraceEvents
                  (SimTrace () -> [(Time, TestTraceEvent TracePublicRootPeers)])
-> SimTrace () -> [(Time, TestTraceEvent TracePublicRootPeers)]
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 -> prop2 -> Property
step (DNSResult DNSPeersKind
_ Domain
"" (Just Domain
srvDomain) []) prop2
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 -> prop2 -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. prop2
r
        step (DNSResult DNSPeersKind
_ Domain
domain Maybe Domain
srvDomain [(IP, PortNumber, TTL)]
ipsttls) prop2
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 -> prop2 -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. prop2
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 -> prop2 -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. prop2
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 DNSTrace
_ prop2
_ = [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
forall {prop2}. Testable prop2 => DNSTrace -> prop2 -> 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. 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. (a -> m ()) -> Tracer m a
Tracer (\Int
a -> IOSim s Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime IOSim s Time -> (Time -> IOSim s ()) -> IOSim s ()
forall a b. IOSim s a -> (a -> IOSim s b) -> IOSim s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Time
t -> (Time, Int) -> IOSim s ()
forall a s. Typeable a => a -> IOSim s ()
traceM (Time
t, Int
a))
          Tracer (IOSim s) Int
-> Tracer (IOSim s) Int -> Tracer (IOSim s) Int
forall a. Semigroup a => a -> a -> a
<> (Int -> IOSim s ()) -> Tracer (IOSim s) Int
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (\Int
a -> IOSim s Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime IOSim s Time -> (Time -> IOSim s ()) -> IOSim s ()
forall a b. IOSim s a -> (a -> IOSim s b) -> IOSim s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Time
t -> [Char] -> IOSim s ()
forall (m :: * -> *). MonadSay m => [Char] -> m ()
say ((Time, Int) -> [Char]
forall a. Show a => a -> [Char]
show (Time
t, Int
a)))

    resource :: Resource (IOSim s) Int
    resource :: forall s. Resource (IOSim s) Int
resource = Tracer (IOSim s) Int
-> NonEmpty DiffTime
-> Resource (IOSim s) (Either Int Int)
-> Resource (IOSim s) Int
forall (m :: * -> *) e a.
MonadDelay m =>
Tracer m e
-> NonEmpty DiffTime -> Resource m (Either e a) -> Resource m a
retryResource Tracer (IOSim s) Int
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer NonEmpty DiffTime
delays
             (Resource (IOSim s) (Either Int Int) -> Resource (IOSim s) Int)
-> Resource (IOSim s) (Either Int Int) -> Resource (IOSim s) Int
forall a b. (a -> b) -> a -> b
$ Tracer (IOSim s) Int
-> [Either Int Int] -> Resource (IOSim s) (Either Int Int)
forall e (m :: * -> *) a.
Monad m =>
Tracer m a -> [Either e a] -> Resource m (Either e a)
listResource Tracer (IOSim s) Int
forall s. Tracer (IOSim s) Int
tracer [Either Int Int]
as

    sim :: IOSim s [Int]
    sim :: forall s. IOSim s [Int]
sim = Int -> Resource (IOSim s) Int -> IOSim s [Int]
forall s. Int -> Resource (IOSim s) Int -> IOSim s [Int]
run ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Either Int Int] -> [Int]
forall a b. [Either a b] -> [b]
rights [Either Int Int]
as)) Resource (IOSim s) Int
forall s. Resource (IOSim s) Int
resource
      where
        run :: Int -> Resource (IOSim s) Int -> IOSim s [Int]
        run :: forall s. Int -> Resource (IOSim s) Int -> IOSim s [Int]
run = [Int] -> Int -> Resource (IOSim s) Int -> IOSim s [Int]
forall {t} {m :: * -> *} {a}.
(Ord t, Num t, Monad m, Enum t) =>
[a] -> t -> Resource m a -> m [a]
go []
          where
            go :: [a] -> t -> Resource m a -> m [a]
go [a]
xs t
n Resource m a
_ | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
<= t
0 = [a] -> m [a]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs)
            go [a]
xs t
n Resource m a
r = do
              (x, r') <- Resource m a -> m (a, Resource m a)
forall (m :: * -> *) a. Resource m a -> m (a, Resource m a)
withResource Resource m a
r
              go (x : xs) (pred n) r'


    trace :: SimTrace [Int]
trace = (forall s. IOSim s [Int]) -> SimTrace [Int]
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace IOSim s [Int]
forall s. IOSim s [Int]
sim

    -- 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 -> InspectMonad m TraceValue
forall a. a -> InspectMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> TraceValue
TraceString (Bool -> [Char]
forall a. Show a => a -> [Char]
show Bool
a)))
    atomically (LazySTM.readTVar d >>= check)
    say "Sink me!"