{-# LANGUAGE CPP                 #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE NumericUnderscores  #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

{-# OPTIONS_GHC -Wno-unused-top-binds #-}
#if __GLASGOW_HASKELL__ >= 908
{-# OPTIONS_GHC -Wno-x-partial #-}
#endif

module Test.Ouroboros.Network.PeerSelection.RootPeersDNS
  ( tests
  , mockDNSActions
  , MockRoots (..)
  , DNSTimeout (..)
  , DNSLookupDelay (..)
  , DelayAndTimeoutScripts (..)
  ) where

import Control.Applicative (Alternative)
import Control.Monad (forever, replicateM_)
import Data.ByteString.Char8 (pack)
import Data.Dynamic (Typeable, fromDynamic)
import Data.Either (rights)
import Data.Foldable as Foldable (foldl')
import Data.Function (fix)
import Data.Functor (void)
import Data.IP (fromHostAddress, toIPv4w, toSockAddr)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (catMaybes)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Time.Clock (picosecondsToDiffTime)
import Data.Void (Void)
import Network.DNS (DNSError (NameError, TimeoutExpired), Domain, TTL)
import Network.DNS.Resolver qualified as DNSResolver
import Network.Socket (SockAddr (..))

import Control.Concurrent.Class.MonadSTM.Strict
import Control.Exception (throw)
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadSay (MonadSay (..))
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI (MonadMonotonicTime (getMonotonicTime),
           Time (..), addTime)
import Control.Monad.Class.MonadTimer.SI
import Control.Monad.Class.MonadTimer.SI qualified as MonadTimer
import Control.Monad.IOSim
import Control.Tracer (Tracer (Tracer), contramap, nullTracer, traceWith)

import Control.Concurrent.Class.MonadSTM qualified as LazySTM
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty (..))
import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..))
import Ouroboros.Network.PeerSelection.LedgerPeers
import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..))
import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable (..))
import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions
import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore
import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers
import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers
import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..),
           LocalRootConfig (..), WarmValency (..))
import Ouroboros.Network.Testing.Data.Script (Script (Script), initScript',
           scriptHead, singletonScript, stepScript')
import Test.Ouroboros.Network.PeerSelection.Instances ()
import Test.QuickCheck
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)

tests :: TestTree
tests :: TestTree
tests =
  [Char] -> [TestTree] -> TestTree
testGroup [Char]
"Ouroboros.Network.PeerSelection"
  [ [Char] -> [TestTree] -> TestTree
testGroup [Char]
"RootPeersDNS"
    [ [Char] -> [TestTree] -> TestTree
testGroup [Char]
"localRootPeersProvider"
       [ [Char]
-> (MockRoots
    -> Script DNSTimeout -> Script DNSLookupDelay -> Property)
-> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"preserve IPs"
                      MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> Property
prop_local_preservesIPs
       , [Char]
-> (MockRoots
    -> Script DNSTimeout -> Script DNSLookupDelay -> Property)
-> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"preserves groups and targets"
                      MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> Property
prop_local_preservesGroupNumberAndTargets
       , [Char]
-> (MockRoots
    -> Script DNSTimeout -> Script DNSLookupDelay -> Property)
-> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"resolves domains correctly"
                      MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> Property
prop_local_resolvesDomainsCorrectly
       , [Char]
-> (MockRoots
    -> Script DNSTimeout -> Script DNSLookupDelay -> Property)
-> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"updates domains correctly"
                      MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> Property
prop_local_updatesDomainsCorrectly
       ]
    , [Char] -> [TestTree] -> TestTree
testGroup [Char]
"publicRootPeersProvider"
       [ [Char]
-> (MockRoots -> DelayAndTimeoutScripts -> Int -> Property)
-> TestTree
forall a. Testable a => [Char] -> a -> TestTree
testProperty [Char]
"resolves domains correctly"
                      MockRoots -> DelayAndTimeoutScripts -> Int -> Property
prop_public_resolvesDomainsCorrectly
       ]
    , [Char] -> [TestTree] -> TestTree
testGroup [Char]
"delayedResource"
       [
       ]
    ]
  ]

--
-- Mock Environment and Utils
--

data MockRoots = MockRoots {
    MockRoots
-> [(HotValency, WarmValency,
     Map RelayAccessPoint LocalRootConfig)]
mockLocalRootPeers        :: [( HotValency
                                  , WarmValency
                                  , Map RelayAccessPoint LocalRootConfig)]
  , MockRoots -> Script (Map Domain [(IP, Word32)])
mockLocalRootPeersDNSMap  :: Script (Map Domain [(IP, TTL)])
  , MockRoots -> Map RelayAccessPoint PeerAdvertise
mockPublicRootPeers       :: Map RelayAccessPoint PeerAdvertise
  , MockRoots -> Script (Map Domain [(IP, Word32)])
mockPublicRootPeersDNSMap :: Script (Map Domain [(IP, TTL)])
  }
  deriving Int -> MockRoots -> ShowS
[MockRoots] -> ShowS
MockRoots -> [Char]
(Int -> MockRoots -> ShowS)
-> (MockRoots -> [Char])
-> ([MockRoots] -> ShowS)
-> Show MockRoots
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MockRoots -> ShowS
showsPrec :: Int -> MockRoots -> ShowS
$cshow :: MockRoots -> [Char]
show :: MockRoots -> [Char]
$cshowList :: [MockRoots] -> ShowS
showList :: [MockRoots] -> ShowS
Show

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

    localRootRelays <- vectorOf relaysNumber arbitrary
    targets <- vectorOf relaysNumber genTargets

    peerAdvertise <- blocks relaysPerGroup
                      <$> vectorOf relaysNumber arbitrary

        -- concat unique identifier to DNS domains to simplify tests
    let taggedLocalRelays = [RelayAccessPoint] -> [RelayAccessPoint]
tagRelays [RelayAccessPoint]
localRootRelays
        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
        localRootDomains  = [ Domain
domain
                            | RelayAccessDomain Domain
domain PortNumber
_ <- [RelayAccessPoint]
taggedLocalRelays ]

        ipsPerDomain = Int
2

    lrpDNSMap <- Script . NonEmpty.fromList
              <$> listOf1 (genDomainLookupTable ipsPerDomain localRootDomains)

    -- Generate PublicRootPeers
    --
    publicRootRelays <- vectorOf relaysNumber arbitrary
    publicRootPeersAdvertise <- vectorOf relaysNumber arbitrary

    let publicRootPeers =
          [(RelayAccessPoint, PeerAdvertise)]
-> Map RelayAccessPoint PeerAdvertise
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([RelayAccessPoint]
-> [PeerAdvertise] -> [(RelayAccessPoint, PeerAdvertise)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([RelayAccessPoint] -> [RelayAccessPoint]
tagRelays [RelayAccessPoint]
publicRootRelays)
                            [PeerAdvertise]
publicRootPeersAdvertise)

        publicRootDomains = [ Domain
domain
                            | (RelayAccessDomain Domain
domain PortNumber
_, PeerAdvertise
_)
                                <- Map RelayAccessPoint PeerAdvertise
-> [(RelayAccessPoint, PeerAdvertise)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map RelayAccessPoint PeerAdvertise
publicRootPeers ]

    publicRootPeersDNSMap <- Script . NonEmpty.fromList
                          <$> listOf1 (genDomainLookupTable ipsPerDomain publicRootDomains)

    return (MockRoots {
      mockLocalRootPeers        = localRootPeers,
      mockLocalRootPeersDNSMap  = lrpDNSMap,
      mockPublicRootPeers       = publicRootPeers,
      mockPublicRootPeersDNSMap = publicRootPeersDNSMap
    })
  where
    genTargets :: Gen (HotValency, WarmValency)
    genTargets :: Gen (HotValency, WarmValency)
genTargets = do
      warmValency <- Int -> WarmValency
WarmValency (Int -> WarmValency) -> Gen Int -> Gen WarmValency
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int, Int) -> Gen Int
forall a. Enum a => (a, a) -> Gen a
chooseEnum (Int
1, Int
5)
      hotValency <- HotValency <$> chooseEnum (1, getWarmValency warmValency)
      return (hotValency, warmValency)

    genDomainLookupTable :: Int -> [Domain] -> Gen (Map Domain [(IP, TTL)])
    genDomainLookupTable :: Int -> [Domain] -> Gen (Map Domain [(IP, Word32)])
genDomainLookupTable Int
ipsPerDomain [Domain]
localRootDomains = do
      localRootDomainIPs <- Int -> [IP] -> [[IP]]
forall {a}. Int -> [a] -> [[a]]
blocks Int
ipsPerDomain
              -- 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)
                           (IPv4 -> IP
IPv4 (IPv4 -> IP) -> (Word32 -> IPv4) -> Word32 -> IP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> IPv4
toIPv4w (Word32 -> IP) -> Gen Word32 -> Gen IP
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word32
forall a. Arbitrary a => Gen a
arbitrary)
      localRootDomainTTLs <- blocks ipsPerDomain
              <$> vectorOf (ipsPerDomain * length localRootDomains)
                           (arbitrary :: Gen TTL)

      let localRootDomainsIP_TTls = ([IP] -> [Word32] -> [(IP, Word32)])
-> [[IP]] -> [[Word32]] -> [[(IP, Word32)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [IP] -> [Word32] -> [(IP, Word32)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[IP]]
localRootDomainIPs [[Word32]]
localRootDomainTTLs
          lrpDNSMap = [(Domain, [(IP, Word32)])] -> Map Domain [(IP, Word32)]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Domain, [(IP, Word32)])] -> Map Domain [(IP, Word32)])
-> [(Domain, [(IP, Word32)])] -> Map Domain [(IP, Word32)]
forall a b. (a -> b) -> a -> b
$ [Domain] -> [[(IP, Word32)]] -> [(Domain, [(IP, Word32)])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Domain]
localRootDomains [[(IP, Word32)]]
localRootDomainsIP_TTls

      return lrpDNSMap

    tagRelays :: [RelayAccessPoint] -> [RelayAccessPoint]
tagRelays [RelayAccessPoint]
relays =
      (Int -> RelayAccessPoint -> RelayAccessPoint)
-> [Int] -> [RelayAccessPoint] -> [RelayAccessPoint]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
        (\Int
tag RelayAccessPoint
rel
          -> case RelayAccessPoint
rel of
               RelayAccessDomain Domain
domain PortNumber
port
                 -> Domain -> PortNumber -> RelayAccessPoint
RelayAccessDomain (Domain
domain Domain -> Domain -> Domain
forall a. Semigroup a => a -> a -> a
<> ([Char] -> Domain
pack ([Char] -> Domain) -> (Int -> [Char]) -> Int -> Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char]
forall a. Show a => a -> [Char]
show) Int
tag) PortNumber
port
               RelayAccessPoint
x -> RelayAccessPoint
x
        )
        [(Int
0 :: Int), Int
1 .. ]
        [RelayAccessPoint]
relays

    blocks :: Int -> [a] -> [[a]]
blocks Int
_ [] = []
    blocks Int
s [a]
l  = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
s [a]
l [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: Int -> [a] -> [[a]]
blocks Int
s (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
s [a]
l)

instance Arbitrary MockRoots where
    arbitrary :: Gen MockRoots
arbitrary = Gen MockRoots
genMockRoots
    shrink :: MockRoots -> [MockRoots]
shrink roots :: MockRoots
roots@MockRoots { [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
mockLocalRootPeers :: MockRoots
-> [(HotValency, WarmValency,
     Map RelayAccessPoint LocalRootConfig)]
mockLocalRootPeers :: [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
mockLocalRootPeers
                           , Script (Map Domain [(IP, Word32)])
mockLocalRootPeersDNSMap :: MockRoots -> Script (Map Domain [(IP, Word32)])
mockLocalRootPeersDNSMap :: Script (Map Domain [(IP, Word32)])
mockLocalRootPeersDNSMap
                           , Map RelayAccessPoint PeerAdvertise
mockPublicRootPeers :: MockRoots -> Map RelayAccessPoint PeerAdvertise
mockPublicRootPeers :: Map RelayAccessPoint PeerAdvertise
mockPublicRootPeers
                           , Script (Map Domain [(IP, Word32)])
mockPublicRootPeersDNSMap :: MockRoots -> Script (Map Domain [(IP, Word32)])
mockPublicRootPeersDNSMap :: Script (Map Domain [(IP, Word32)])
mockPublicRootPeersDNSMap
                           } =
      [ MockRoots
roots { mockLocalRootPeers        = lrp
              , mockLocalRootPeersDNSMap  = lrpDNSMap
              }
      | [(HotValency, WarmValency, Map RelayAccessPoint 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
lrpDomains =
              [Domain] -> Set Domain
forall a. Ord a => [a] -> Set a
Set.fromList [ Domain
domain
                           | RelayAccessDomain Domain
domain PortNumber
_
                              <- ((HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)
 -> [RelayAccessPoint])
-> [(HotValency, WarmValency,
     Map RelayAccessPoint LocalRootConfig)]
-> [RelayAccessPoint]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Map RelayAccessPoint LocalRootConfig -> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys (Map RelayAccessPoint LocalRootConfig -> [RelayAccessPoint])
-> ((HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)
    -> Map RelayAccessPoint LocalRootConfig)
-> (HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)
-> [RelayAccessPoint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)
-> Map RelayAccessPoint LocalRootConfig
forall {a} {b} {c}. (a, b, c) -> c
thrd) [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
lrp ]
            lrpDNSMap :: Script (Map Domain [(IP, Word32)])
lrpDNSMap  = (Map Domain [(IP, Word32)]
-> Set Domain -> Map Domain [(IP, Word32)]
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set Domain
lrpDomains)
                       (Map Domain [(IP, Word32)] -> Map Domain [(IP, Word32)])
-> Script (Map Domain [(IP, Word32)])
-> Script (Map Domain [(IP, Word32)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Script (Map Domain [(IP, Word32)])
mockLocalRootPeersDNSMap
      ] [MockRoots] -> [MockRoots] -> [MockRoots]
forall a. [a] -> [a] -> [a]
++
      [ MockRoots
roots { mockPublicRootPeers       = prp
              , mockPublicRootPeersDNSMap = prpDNSMap
              }
      | Map RelayAccessPoint PeerAdvertise
prp <- Map RelayAccessPoint PeerAdvertise
-> [Map RelayAccessPoint PeerAdvertise]
forall a. Arbitrary a => a -> [a]
shrink Map RelayAccessPoint PeerAdvertise
mockPublicRootPeers,
        let prpDomains :: Set Domain
prpDomains = [Domain] -> Set Domain
forall a. Ord a => [a] -> Set a
Set.fromList [ Domain
domain
                                      | (RelayAccessDomain Domain
domain PortNumber
_, PeerAdvertise
_)
                                          <- Map RelayAccessPoint PeerAdvertise
-> [(RelayAccessPoint, PeerAdvertise)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map RelayAccessPoint PeerAdvertise
prp ]
            prpDNSMap :: Script (Map Domain [(IP, Word32)])
prpDNSMap  = (Map Domain [(IP, Word32)]
-> Set Domain -> Map Domain [(IP, Word32)]
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set Domain
prpDomains)
                       (Map Domain [(IP, Word32)] -> Map Domain [(IP, Word32)])
-> Script (Map Domain [(IP, Word32)])
-> Script (Map Domain [(IP, Word32)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Script (Map Domain [(IP, Word32)])
mockPublicRootPeersDNSMap
      ]
        where
          thrd :: (a, b, c) -> c
thrd (a
_, b
_, c
c) = c
c

-- | Used for debugging in GHCI
--
simpleMockRoots :: MockRoots
simpleMockRoots :: MockRoots
simpleMockRoots = [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
-> Script (Map Domain [(IP, Word32)])
-> Map RelayAccessPoint PeerAdvertise
-> Script (Map Domain [(IP, Word32)])
-> MockRoots
MockRoots [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
localRootPeers Script (Map Domain [(IP, Word32)])
dnsMap Map RelayAccessPoint PeerAdvertise
forall k a. Map k a
Map.empty (Map Domain [(IP, Word32)] -> Script (Map Domain [(IP, Word32)])
forall a. a -> Script a
singletonScript Map Domain [(IP, Word32)]
forall k a. Map k a
Map.empty)
  where
    localRootPeers :: [(HotValency, WarmValency, Map RelayAccessPoint 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 -> PeerTrustable -> DiffusionMode -> LocalRootConfig
LocalRootConfig PeerAdvertise
DoAdvertisePeer PeerTrustable
IsNotTrustable DiffusionMode
InitiatorAndResponderDiffusionMode
            )
          , ( Domain -> PortNumber -> RelayAccessPoint
RelayAccessDomain  Domain
"test.domain"      ([Char] -> PortNumber
forall a. Read a => [Char] -> a
read [Char]
"4444")
            , PeerAdvertise -> PeerTrustable -> DiffusionMode -> LocalRootConfig
LocalRootConfig PeerAdvertise
DoNotAdvertisePeer PeerTrustable
IsNotTrustable DiffusionMode
InitiatorAndResponderDiffusionMode
            )
          ]
        )
      ]
    dnsMap :: Script (Map Domain [(IP, Word32)])
dnsMap = Map Domain [(IP, Word32)] -> Script (Map Domain [(IP, Word32)])
forall a. a -> Script a
singletonScript (Map Domain [(IP, Word32)] -> Script (Map Domain [(IP, Word32)]))
-> Map Domain [(IP, Word32)] -> Script (Map Domain [(IP, Word32)])
forall a b. (a -> b) -> a -> b
$ [(Domain, [(IP, Word32)])] -> Map Domain [(IP, Word32)]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
              [ (Domain
"test.domain", [[Char] -> (IP, Word32)
forall a. Read a => [Char] -> a
read [Char]
"192.1.1.1", [Char] -> (IP, Word32)
forall a. Read a => [Char] -> a
read [Char]
"192.2.2.2"])
              ]


genDiffTime :: Integer
            -> Integer
            -> Gen DiffTime
genDiffTime :: Integer -> Integer -> Gen DiffTime
genDiffTime Integer
lo Integer
hi =
      Integer -> DiffTime
picosecondsToDiffTime
    (Integer -> DiffTime)
-> (NonNegative Integer -> Integer)
-> NonNegative Integer
-> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer
lo Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
1_000_000_000 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+)
    (Integer -> Integer)
-> (NonNegative Integer -> Integer)
-> NonNegative Integer
-> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer
1_000_000_000 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*)
    (Integer -> Integer)
-> (NonNegative Integer -> Integer)
-> NonNegative Integer
-> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonNegative Integer -> Integer
forall a. NonNegative a -> a
getNonNegative
  (NonNegative Integer -> DiffTime)
-> Gen (NonNegative Integer) -> Gen DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen (NonNegative Integer) -> Gen (NonNegative Integer)
forall a. Int -> Gen a -> Gen a
resize (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
hi) Gen (NonNegative Integer)
forall a. Arbitrary a => Gen a
arbitrary


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

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


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

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

-- | 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 m.
                  ( MonadDelay m
                  , MonadTimer m
                  )
               => StrictTVar m (Map Domain [(IP, TTL)])
               -> StrictTVar m (Script DNSTimeout)
               -> StrictTVar m (Script DNSLookupDelay)
               -> DNSActions () exception m
mockDNSActions :: forall exception (m :: * -> *).
(MonadDelay m, MonadTimer m) =>
StrictTVar m (Map Domain [(IP, Word32)])
-> StrictTVar m (Script DNSTimeout)
-> StrictTVar m (Script DNSLookupDelay)
-> DNSActions () exception m
mockDNSActions StrictTVar m (Map Domain [(IP, Word32)])
dnsMapVar StrictTVar m (Script DNSTimeout)
dnsTimeoutScript StrictTVar m (Script DNSLookupDelay)
dnsLookupDelayScript =
    DNSActions {
      ResolvConf -> m (Resource m (Either (DNSorIOError exception) ()))
forall {m :: * -> *} {m :: * -> *} {p} {a}.
(Monad m, Applicative m) =>
p -> m (Resource m (Either a ()))
dnsResolverResource :: forall {m :: * -> *} {m :: * -> *} {p} {a}.
(Monad m, Applicative m) =>
p -> m (Resource m (Either a ()))
dnsResolverResource :: ResolvConf -> m (Resource m (Either (DNSorIOError exception) ()))
dnsResolverResource,
      ResolvConf -> m (Resource m (Either (DNSorIOError exception) ()))
forall {m :: * -> *} {m :: * -> *} {p} {a}.
(Monad m, Applicative m) =>
p -> m (Resource m (Either a ()))
dnsAsyncResolverResource :: forall {m :: * -> *} {m :: * -> *} {p} {a}.
(Monad m, Applicative m) =>
p -> m (Resource m (Either a ()))
dnsAsyncResolverResource :: ResolvConf -> m (Resource m (Either (DNSorIOError exception) ()))
dnsAsyncResolverResource,
      ResolvConf -> () -> Domain -> m ([DNSError], [(IP, Word32)])
forall resolvConf resolver.
resolvConf -> resolver -> Domain -> m ([DNSError], [(IP, Word32)])
dnsLookupWithTTL :: forall resolvConf resolver.
resolvConf -> resolver -> Domain -> m ([DNSError], [(IP, Word32)])
dnsLookupWithTTL :: ResolvConf -> () -> Domain -> m ([DNSError], [(IP, Word32)])
dnsLookupWithTTL
    }
 where
   dnsResolverResource :: p -> m (Resource m (Either a ()))
dnsResolverResource      p
_ = Resource m (Either a ()) -> m (Resource m (Either a ()))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either a ()
forall a b. b -> Either a b
Right (() -> Either a ()) -> Resource m () -> Resource m (Either a ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> () -> Resource m ()
forall (m :: * -> *) a. Applicative m => a -> Resource m a
constantResource ())
   dnsAsyncResolverResource :: p -> m (Resource m (Either a ()))
dnsAsyncResolverResource p
_ = Resource m (Either a ()) -> m (Resource m (Either a ()))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Either a ()
forall a b. b -> Either a b
Right (() -> Either a ()) -> Resource m () -> Resource m (Either a ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> () -> Resource m ()
forall (m :: * -> *) a. Applicative m => a -> Resource m a
constantResource ())

   dnsLookupWithTTL :: resolvConf
                    -> resolver
                    -> Domain
                    -> m ([DNSError], [(IP, TTL)])
   dnsLookupWithTTL :: forall resolvConf resolver.
resolvConf -> resolver -> Domain -> m ([DNSError], [(IP, Word32)])
dnsLookupWithTTL resolvConf
_ resolver
_ Domain
domain = do
     dnsMap <- StrictTVar m (Map Domain [(IP, Word32)])
-> m (Map Domain [(IP, Word32)])
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (Map Domain [(IP, Word32)])
dnsMapVar
     DNSTimeout dnsTimeout <- stepScript' dnsTimeoutScript
     DNSLookupDelay dnsLookupDelay <- stepScript' dnsLookupDelayScript

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

     case dnsLookup of
       Maybe (Either DNSError [(IP, Word32)])
Nothing        -> ([DNSError], [(IP, Word32)]) -> m ([DNSError], [(IP, Word32)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DNSError
TimeoutExpired], [])
       Just (Left DNSError
e)  -> ([DNSError], [(IP, Word32)]) -> m ([DNSError], [(IP, Word32)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DNSError
e], [])
       Just (Right [(IP, Word32)]
a) -> ([DNSError], [(IP, Word32)]) -> m ([DNSError], [(IP, Word32)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [(IP, Word32)]
a)

-- | '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 (TraceLocalRootPeers SockAddr Failure)
                           -> MockRoots
                           -> Script DNSTimeout
                           -> Script DNSLookupDelay
                           -> m ()
mockLocalRootPeersProvider :: forall (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 MonadTimer m, MonadTraceSTM m, MonadLabelledSTM m) =>
Tracer m (TraceLocalRootPeers SockAddr Failure)
-> MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> m ()
mockLocalRootPeersProvider Tracer m (TraceLocalRootPeers SockAddr Failure)
tracer (MockRoots [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
localRootPeers Script (Map Domain [(IP, Word32)])
dnsMapScript Map RelayAccessPoint PeerAdvertise
_ Script (Map Domain [(IP, Word32)])
_)
                           Script DNSTimeout
dnsTimeoutScript Script DNSLookupDelay
dnsLookupDelayScript = do
      dnsMapScriptVar <- Script (Map Domain [(IP, Word32)])
-> m (StrictTVar m (Script (Map Domain [(IP, Word32)])))
forall (m :: * -> *) a.
MonadSTM m =>
Script a -> m (StrictTVar m (Script a))
initScript' Script (Map Domain [(IP, Word32)])
dnsMapScript
      dnsMap <- stepScript' dnsMapScriptVar
      dnsMapVar <- newTVarIO dnsMap

      dnsTimeoutScriptVar <- initScript' dnsTimeoutScript
      dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
      localRootPeersVar <- newTVarIO localRootPeers
      resultVar <- newTVarIO mempty
      _ <- labelTVarIO resultVar "resultVar"
      _ <- traceTVarIO resultVar
                       (\Maybe [(HotValency, WarmValency, Map SockAddr LocalRootConfig)]
_ [(HotValency, WarmValency, Map SockAddr LocalRootConfig)]
a -> TraceValue -> InspectMonad m TraceValue
forall a. a -> InspectMonad m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TraceValue -> InspectMonad m TraceValue)
-> TraceValue -> InspectMonad m TraceValue
forall a b. (a -> b) -> a -> b
$ TestTraceEvent -> TraceValue
forall tr. Typeable tr => tr -> TraceValue
TraceDynamic ([(HotValency, WarmValency, Map SockAddr LocalRootConfig)]
-> TestTraceEvent
LocalRootPeersResults [(HotValency, WarmValency, Map SockAddr LocalRootConfig)]
a))
      withAsync (updateDNSMap dnsMapScriptVar dnsMapVar) $ \Async m Void
_ -> do
        m (Maybe Void) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Maybe Void) -> m ()) -> m (Maybe Void) -> m ()
forall a b. (a -> b) -> a -> b
$ DiffTime -> m Void -> m (Maybe Void)
forall a. DiffTime -> m a -> m (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
MonadTimer.timeout DiffTime
3600 (m Void -> m (Maybe Void)) -> m Void -> m (Maybe Void)
forall a b. (a -> b) -> a -> b
$
          Tracer m (TraceLocalRootPeers SockAddr Failure)
-> (IP -> PortNumber -> SockAddr)
-> ResolvConf
-> DNSActions () Failure m
-> STM
     m [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
-> StrictTVar
     m [(HotValency, WarmValency, Map SockAddr LocalRootConfig)]
-> m Void
forall (m :: * -> *) peerAddr resolver exception.
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 Ord peerAddr) =>
Tracer m (TraceLocalRootPeers peerAddr exception)
-> (IP -> PortNumber -> peerAddr)
-> ResolvConf
-> DNSActions resolver exception m
-> STM
     m [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
-> StrictTVar
     m [(HotValency, WarmValency, Map peerAddr LocalRootConfig)]
-> m Void
localRootPeersProvider Tracer m (TraceLocalRootPeers SockAddr Failure)
tracer
                                 (((IP, PortNumber) -> SockAddr) -> IP -> PortNumber -> SockAddr
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (IP, PortNumber) -> SockAddr
toSockAddr)
                                 ResolvConf
DNSResolver.defaultResolvConf
                                 (StrictTVar m (Map Domain [(IP, Word32)])
-> StrictTVar m (Script DNSTimeout)
-> StrictTVar m (Script DNSLookupDelay)
-> DNSActions () Failure m
forall exception (m :: * -> *).
(MonadDelay m, MonadTimer m) =>
StrictTVar m (Map Domain [(IP, Word32)])
-> StrictTVar m (Script DNSTimeout)
-> StrictTVar m (Script DNSLookupDelay)
-> DNSActions () exception m
mockDNSActions StrictTVar m (Map Domain [(IP, Word32)])
dnsMapVar
                                                 StrictTVar m (Script DNSTimeout)
dnsTimeoutScriptVar
                                                 StrictTVar m (Script DNSLookupDelay)
dnsLookupDelayScriptVar)
                                 (StrictTVar
  m [(HotValency, WarmValency, Map RelayAccessPoint 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 (Map Domain [(IP, TTL)]))
                 -> StrictTVar m (Map Domain [(IP, TTL)])
                 -> m Void
    updateDNSMap :: StrictTVar m (Script (Map Domain [(IP, Word32)]))
-> StrictTVar m (Map Domain [(IP, Word32)]) -> m Void
updateDNSMap StrictTVar m (Script (Map Domain [(IP, Word32)]))
dnsMapScriptVar StrictTVar m (Map Domain [(IP, Word32)])
dnsMapVar =
      m () -> m Void
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (m () -> m Void) -> m () -> m Void
forall a b. (a -> b) -> a -> b
$ do
        DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
10
        dnsMap <- StrictTVar m (Script (Map Domain [(IP, Word32)]))
-> m (Map Domain [(IP, Word32)])
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m (Script a) -> m a
stepScript' StrictTVar m (Script (Map Domain [(IP, Word32)]))
dnsMapScriptVar
        atomically (writeTVar dnsMapVar dnsMap)


-- | '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 TracePublicRootPeers
                            -> MockRoots
                            -> Script DNSTimeout
                            -> Script DNSLookupDelay
                            -> ((Int -> m (Map SockAddr PeerAdvertise, DiffTime)) -> m a)
                            -> m ()
mockPublicRootPeersProvider :: forall (m :: * -> *) a.
(MonadAsync m, MonadDelay m, MonadThrow m, MonadTimer m) =>
Tracer m TracePublicRootPeers
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> ((Int -> m (Map SockAddr PeerAdvertise, DiffTime)) -> m a)
-> m ()
mockPublicRootPeersProvider Tracer m TracePublicRootPeers
tracer (MockRoots [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
_ Script (Map Domain [(IP, Word32)])
_ Map RelayAccessPoint PeerAdvertise
publicRootPeers Script (Map Domain [(IP, Word32)])
dnsMapScript)
                            Script DNSTimeout
dnsTimeoutScript Script DNSLookupDelay
dnsLookupDelayScript (Int -> m (Map SockAddr PeerAdvertise, DiffTime)) -> m a
action = do
      dnsMapScriptVar <- Script (Map Domain [(IP, Word32)])
-> m (StrictTVar m (Script (Map Domain [(IP, Word32)])))
forall (m :: * -> *) a.
MonadSTM m =>
Script a -> m (StrictTVar m (Script a))
initScript' Script (Map Domain [(IP, Word32)])
dnsMapScript
      dnsMap <- stepScript' dnsMapScriptVar
      dnsMapVar <- newTVarIO dnsMap
      dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore

      dnsTimeoutScriptVar <- initScript' dnsTimeoutScript
      dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
      publicRootPeersVar <- newTVarIO publicRootPeers
      replicateM_ 5 $ do
        dnsMap' <- stepScript' dnsMapScriptVar
        atomically (writeTVar dnsMapVar dnsMap')

        publicRootPeersProvider tracer
                                (curry toSockAddr)
                                dnsSemaphore
                                DNSResolver.defaultResolvConf
                                (readTVar publicRootPeersVar)
                                (mockDNSActions @Failure
                                                dnsMapVar
                                                dnsTimeoutScriptVar
                                                dnsLookupDelayScriptVar)
                                action

-- | 'resolveDomainAddresses' running with a given MockRoots env
--
mockResolveLedgerPeers :: ( MonadAsync m
                         , MonadDelay m
                         , MonadThrow m
                         , MonadTimer m
                         )
                       => Tracer m TraceLedgerPeers
                       -> MockRoots
                       -> Script DNSTimeout
                       -> Script DNSLookupDelay
                       -> m (Map DomainAccessPoint (Set SockAddr))
mockResolveLedgerPeers :: forall (m :: * -> *).
(MonadAsync m, MonadDelay m, MonadThrow m, MonadTimer m) =>
Tracer m TraceLedgerPeers
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> m (Map DomainAccessPoint (Set SockAddr))
mockResolveLedgerPeers Tracer m TraceLedgerPeers
tracer (MockRoots [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
_ Script (Map Domain [(IP, Word32)])
_ Map RelayAccessPoint PeerAdvertise
publicRootPeers Script (Map Domain [(IP, Word32)])
dnsMapScript)
                       Script DNSTimeout
dnsTimeoutScript Script DNSLookupDelay
dnsLookupDelayScript = do
      dnsMapScriptVar <- Script (Map Domain [(IP, Word32)])
-> m (StrictTVar m (Script (Map Domain [(IP, Word32)])))
forall (m :: * -> *) a.
MonadSTM m =>
Script a -> m (StrictTVar m (Script a))
initScript' Script (Map Domain [(IP, Word32)])
dnsMapScript
      dnsMap <- stepScript' dnsMapScriptVar
      dnsMapVar <- newTVarIO dnsMap
      dnsSemaphore <- newLedgerAndPublicRootDNSSemaphore

      dnsTimeoutScriptVar <- initScript' dnsTimeoutScript
      dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
      resolveLedgerPeers tracer
                         (curry toSockAddr)
                         dnsSemaphore
                         DNSResolver.defaultResolvConf
                         (mockDNSActions @Failure dnsMapVar
                                                  dnsTimeoutScriptVar
                                                  dnsLookupDelayScriptVar)
                         [ domain
                         | (RelayDomainAccessPoint domain, _)
                              <- Map.assocs publicRootPeers ]

--
-- Utils for properties
--

data TestTraceEvent = RootPeerDNSLocal  (TraceLocalRootPeers SockAddr Failure)
                    | LocalRootPeersResults [(HotValency, WarmValency, Map SockAddr LocalRootConfig)]
                    | RootPeerDNSPublic TracePublicRootPeers
  deriving (Int -> TestTraceEvent -> ShowS
[TestTraceEvent] -> ShowS
TestTraceEvent -> [Char]
(Int -> TestTraceEvent -> ShowS)
-> (TestTraceEvent -> [Char])
-> ([TestTraceEvent] -> ShowS)
-> Show TestTraceEvent
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestTraceEvent -> ShowS
showsPrec :: Int -> TestTraceEvent -> ShowS
$cshow :: TestTraceEvent -> [Char]
show :: TestTraceEvent -> [Char]
$cshowList :: [TestTraceEvent] -> ShowS
showList :: [TestTraceEvent] -> ShowS
Show, Typeable)

tracerTraceLocalRoots :: Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
tracerTraceLocalRoots :: forall s. Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
tracerTraceLocalRoots = (TraceLocalRootPeers SockAddr Failure -> TestTraceEvent)
-> Tracer (IOSim s) TestTraceEvent
-> Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
forall a' a. (a' -> a) -> Tracer (IOSim s) a -> Tracer (IOSim s) a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap TraceLocalRootPeers SockAddr Failure -> TestTraceEvent
RootPeerDNSLocal Tracer (IOSim s) TestTraceEvent
forall s. Tracer (IOSim s) TestTraceEvent
tracerTestTraceEvent

tracerTracePublicRoots :: Tracer (IOSim s) TracePublicRootPeers
tracerTracePublicRoots :: forall s. Tracer (IOSim s) TracePublicRootPeers
tracerTracePublicRoots = (TracePublicRootPeers -> TestTraceEvent)
-> Tracer (IOSim s) TestTraceEvent
-> Tracer (IOSim s) TracePublicRootPeers
forall a' a. (a' -> a) -> Tracer (IOSim s) a -> Tracer (IOSim s) a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap TracePublicRootPeers -> TestTraceEvent
RootPeerDNSPublic Tracer (IOSim s) TestTraceEvent
forall s. Tracer (IOSim s) TestTraceEvent
tracerTestTraceEvent

tracerTestTraceEvent :: Tracer (IOSim s) TestTraceEvent
tracerTestTraceEvent :: forall s. Tracer (IOSim s) TestTraceEvent
tracerTestTraceEvent = Tracer (IOSim s) TestTraceEvent
forall a s. Typeable a => Tracer (IOSim s) a
dynamicTracer

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

selectRootPeerDNSTraceEvents :: SimTrace a -> [(Time, TestTraceEvent)]
selectRootPeerDNSTraceEvents :: forall a. SimTrace a -> [(Time, TestTraceEvent)]
selectRootPeerDNSTraceEvents = SimTrace a -> [(Time, TestTraceEvent)]
forall {b} {a}. Typeable b => SimTrace a -> [(Time, b)]
go
  where
    go :: SimTrace a -> [(Time, b)]
go (SimTrace Time
t IOSimThreadId
_ Maybe [Char]
_ (EventLog Dynamic
e) SimTrace a
trace)
     | Just b
x <- Dynamic -> Maybe b
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
e       = (Time
t,b
x) (Time, b) -> [(Time, b)] -> [(Time, b)]
forall a. a -> [a] -> [a]
: SimTrace a -> [(Time, b)]
go SimTrace a
trace
    go (SimPORTrace Time
t IOSimThreadId
_ Int
_ Maybe [Char]
_ (EventLog Dynamic
e) SimTrace a
trace)
     | Just b
x <- Dynamic -> Maybe b
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
e       = (Time
t,b
x) (Time, b) -> [(Time, b)] -> [(Time, b)]
forall a. a -> [a] -> [a]
: SimTrace a -> [(Time, b)]
go SimTrace a
trace
    go (SimTrace Time
_ IOSimThreadId
_ Maybe [Char]
_ SimEventType
_ SimTrace a
trace)      =         SimTrace a -> [(Time, b)]
go SimTrace a
trace
    go (SimPORTrace Time
_ IOSimThreadId
_ Int
_ Maybe [Char]
_ SimEventType
_ SimTrace a
trace) =         SimTrace a -> [(Time, b)]
go SimTrace a
trace
    go (TraceMainException Time
_ Labelled IOSimThreadId
_ SomeException
e [Labelled IOSimThreadId]
_)  = SomeException -> [(Time, b)]
forall a e. (HasCallStack, Exception e) => e -> a
throw SomeException
e
    go (TraceDeadlock      Time
_   [Labelled IOSimThreadId]
_)    = [] -- 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"

selectLocalRootPeersEvents :: [(Time, TestTraceEvent)]
                           -> [(Time, TraceLocalRootPeers SockAddr Failure)]
selectLocalRootPeersEvents :: [(Time, TestTraceEvent)]
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
selectLocalRootPeersEvents [(Time, TestTraceEvent)]
trace = [ (Time
t, TraceLocalRootPeers SockAddr Failure
e) | (Time
t, RootPeerDNSLocal TraceLocalRootPeers SockAddr Failure
e) <- [(Time, TestTraceEvent)]
trace ]

selectLocalRootPeersResults :: [(Time, TestTraceEvent)]
                            -> [(Time, [(HotValency, WarmValency, Map SockAddr LocalRootConfig)])]
selectLocalRootPeersResults :: [(Time, TestTraceEvent)]
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr LocalRootConfig)])]
selectLocalRootPeersResults [(Time, TestTraceEvent)]
trace = [ (Time
t, [(HotValency, WarmValency, Map SockAddr LocalRootConfig)]
r) | (Time
t, LocalRootPeersResults [(HotValency, WarmValency, Map SockAddr LocalRootConfig)]
r) <- [(Time, TestTraceEvent)]
trace ]

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

selectLocalRootResultEvents :: [(Time, TraceLocalRootPeers SockAddr Failure)]
                            -> [(Time, (Domain, [IP]))]
selectLocalRootResultEvents :: [(Time, TraceLocalRootPeers SockAddr Failure)]
-> [(Time, (Domain, [IP]))]
selectLocalRootResultEvents [(Time, TraceLocalRootPeers SockAddr Failure)]
trace = [ (Time
t, (Domain
domain, ((IP, Word32) -> IP) -> [(IP, Word32)] -> [IP]
forall a b. (a -> b) -> [a] -> [b]
map (IP, Word32) -> IP
forall a b. (a, b) -> a
fst [(IP, Word32)]
r))
                                    | (Time
t, TraceLocalRootResult (DomainAccessPoint Domain
domain PortNumber
_) [(IP, Word32)]
r) <- [(Time, TraceLocalRootPeers SockAddr Failure)]
trace ]

selectPublicRootPeersEvents :: [(Time, TestTraceEvent)]
                            -> [(Time, TracePublicRootPeers)]
selectPublicRootPeersEvents :: [(Time, TestTraceEvent)] -> [(Time, TracePublicRootPeers)]
selectPublicRootPeersEvents [(Time, TestTraceEvent)]
trace = [ (Time
t, TracePublicRootPeers
e) | (Time
t, RootPeerDNSPublic TracePublicRootPeers
e) <- [(Time, TestTraceEvent)]
trace ]

selectPublicRootFailureEvents :: [(Time, TracePublicRootPeers)]
                              -> [(Time, Domain)]
selectPublicRootFailureEvents :: [(Time, TracePublicRootPeers)] -> [(Time, Domain)]
selectPublicRootFailureEvents [(Time, TracePublicRootPeers)]
trace = [ (Time
t, Domain
domain)
                                      | (Time
t, TracePublicRootFailure Domain
domain DNSError
_) <- [(Time, TracePublicRootPeers)]
trace ]

selectPublicRootResultEvents :: [(Time, TracePublicRootPeers)]
                             -> [(Time, (Domain, [IP]))]
selectPublicRootResultEvents :: [(Time, TracePublicRootPeers)] -> [(Time, (Domain, [IP]))]
selectPublicRootResultEvents [(Time, TracePublicRootPeers)]
trace = [ (Time
t, (Domain
domain, ((IP, Word32) -> IP) -> [(IP, Word32)] -> [IP]
forall a b. (a -> b) -> [a] -> [b]
map (IP, Word32) -> IP
forall a b. (a, b) -> a
fst [(IP, Word32)]
r))
                                     | (Time
t, TracePublicRootResult Domain
domain [(IP, Word32)]
r) <- [(Time, TracePublicRootPeers)]
trace ]

--
-- 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
                        -> Property
prop_local_preservesIPs :: MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> Property
prop_local_preservesIPs mockRoots :: MockRoots
mockRoots@(MockRoots [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
localRoots Script (Map Domain [(IP, Word32)])
_ Map RelayAccessPoint PeerAdvertise
_ Script (Map Domain [(IP, Word32)])
_)
                        Script DNSTimeout
dnsTimeoutScript
                        Script DNSLookupDelay
dnsLookupDelayScript =
    let tr :: [(Time, [(HotValency, WarmValency, Map SockAddr LocalRootConfig)])]
tr = [(Time, TestTraceEvent)]
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr LocalRootConfig)])]
selectLocalRootPeersResults
           ([(Time, TestTraceEvent)]
 -> [(Time,
      [(HotValency, WarmValency, Map SockAddr LocalRootConfig)])])
-> [(Time, TestTraceEvent)]
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr LocalRootConfig)])]
forall a b. (a -> b) -> a -> b
$ SimTrace () -> [(Time, TestTraceEvent)]
forall a. SimTrace a -> [(Time, TestTraceEvent)]
selectRootPeerDNSTraceEvents
           (SimTrace () -> [(Time, TestTraceEvent)])
-> SimTrace () -> [(Time, TestTraceEvent)]
forall a b. (a -> b) -> a -> b
$ (forall s. IOSim s ()) -> SimTrace ()
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace
           ((forall s. IOSim s ()) -> SimTrace ())
-> (forall s. IOSim s ()) -> SimTrace ()
forall a b. (a -> b) -> a -> b
$ Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> IOSim s ()
forall (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 MonadTimer m, MonadTraceSTM m, MonadLabelledSTM m) =>
Tracer m (TraceLocalRootPeers SockAddr Failure)
-> MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> m ()
mockLocalRootPeersProvider Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
forall s. Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
tracerTraceLocalRoots
                                        MockRoots
mockRoots
                                        Script DNSTimeout
dnsTimeoutScript
                                        Script DNSLookupDelay
dnsLookupDelayScript

     in [Char] -> Property -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ ((Time, [(HotValency, WarmValency, Map SockAddr 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
                                          -> Property
prop_local_preservesGroupNumberAndTargets :: MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> Property
prop_local_preservesGroupNumberAndTargets mockRoots :: MockRoots
mockRoots@(MockRoots [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
lrp Script (Map Domain [(IP, Word32)])
_ Map RelayAccessPoint PeerAdvertise
_ Script (Map Domain [(IP, Word32)])
_)
                                          Script DNSTimeout
dnsTimeoutScript
                                          Script DNSLookupDelay
dnsLookupDelayScript =
    let tr :: [(Time, [(HotValency, WarmValency, Map SockAddr LocalRootConfig)])]
tr = [(Time, TestTraceEvent)]
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr LocalRootConfig)])]
selectLocalRootPeersResults
           ([(Time, TestTraceEvent)]
 -> [(Time,
      [(HotValency, WarmValency, Map SockAddr LocalRootConfig)])])
-> [(Time, TestTraceEvent)]
-> [(Time,
     [(HotValency, WarmValency, Map SockAddr LocalRootConfig)])]
forall a b. (a -> b) -> a -> b
$ SimTrace () -> [(Time, TestTraceEvent)]
forall a. SimTrace a -> [(Time, TestTraceEvent)]
selectRootPeerDNSTraceEvents
           (SimTrace () -> [(Time, TestTraceEvent)])
-> SimTrace () -> [(Time, TestTraceEvent)]
forall a b. (a -> b) -> a -> b
$ (forall s. IOSim s ()) -> SimTrace ()
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace
           ((forall s. IOSim s ()) -> SimTrace ())
-> (forall s. IOSim s ()) -> SimTrace ()
forall a b. (a -> b) -> a -> b
$ Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> IOSim s ()
forall (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 MonadTimer m, MonadTraceSTM m, MonadLabelledSTM m) =>
Tracer m (TraceLocalRootPeers SockAddr Failure)
-> MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> m ()
mockLocalRootPeersProvider Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
forall s. Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
tracerTraceLocalRoots
                                        MockRoots
mockRoots
                                        Script DNSTimeout
dnsTimeoutScript
                                        Script DNSLookupDelay
dnsLookupDelayScript

        -- 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
                                    -> Property
prop_local_resolvesDomainsCorrectly :: MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> Property
prop_local_resolvesDomainsCorrectly mockRoots :: MockRoots
mockRoots@(MockRoots [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
localRoots Script (Map Domain [(IP, Word32)])
lDNSMap Map RelayAccessPoint PeerAdvertise
_ Script (Map Domain [(IP, Word32)])
_)
                                    Script DNSTimeout
dnsTimeoutScript
                                    Script DNSLookupDelay
dnsLookupDelayScript =
    let mockRoots' :: MockRoots
mockRoots' =
          MockRoots
mockRoots { mockLocalRootPeersDNSMap =
                        singletonScript (scriptHead lDNSMap)
                    }
        tr :: [(Time, TraceLocalRootPeers SockAddr Failure)]
tr = [(Time, TestTraceEvent)]
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
selectLocalRootPeersEvents
           ([(Time, TestTraceEvent)]
 -> [(Time, TraceLocalRootPeers SockAddr Failure)])
-> [(Time, TestTraceEvent)]
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
forall a b. (a -> b) -> a -> b
$ SimTrace () -> [(Time, TestTraceEvent)]
forall a. SimTrace a -> [(Time, TestTraceEvent)]
selectRootPeerDNSTraceEvents
           (SimTrace () -> [(Time, TestTraceEvent)])
-> SimTrace () -> [(Time, TestTraceEvent)]
forall a b. (a -> b) -> a -> b
$ (forall s. IOSim s ()) -> SimTrace ()
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace
           ((forall s. IOSim s ()) -> SimTrace ())
-> (forall s. IOSim s ()) -> SimTrace ()
forall a b. (a -> b) -> a -> b
$ Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> IOSim s ()
forall (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 MonadTimer m, MonadTraceSTM m, MonadLabelledSTM m) =>
Tracer m (TraceLocalRootPeers SockAddr Failure)
-> MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> m ()
mockLocalRootPeersProvider Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
forall s. Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
tracerTraceLocalRoots
                                        MockRoots
mockRoots'
                                        Script DNSTimeout
dnsTimeoutScript
                                        Script DNSLookupDelay
dnsLookupDelayScript

        -- local root domains
        localRootDomains :: Set Domain
        localRootDomains :: Set Domain
localRootDomains =
          [Domain] -> Set Domain
forall a. Ord a => [a] -> Set a
Set.fromList
          [ Domain
domain
          | (HotValency
_, WarmValency
_, Map RelayAccessPoint LocalRootConfig
m) <- [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
localRoots
          , RelayAccessDomain Domain
domain PortNumber
_ <- Map RelayAccessPoint LocalRootConfig -> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys Map RelayAccessPoint LocalRootConfig
m
          ]

        -- domains that were resolved during simulation
        resultMap :: Set Domain
        resultMap :: Set Domain
resultMap = [Domain] -> Set Domain
forall a. Ord a => [a] -> Set a
Set.fromList
                  ([Domain] -> Set Domain) -> [Domain] -> Set Domain
forall a b. (a -> b) -> a -> b
$ ((Time, (Domain, [IP])) -> Domain)
-> [(Time, (Domain, [IP]))] -> [Domain]
forall a b. (a -> b) -> [a] -> [b]
map ((Domain, [IP]) -> Domain
forall a b. (a, b) -> a
fst ((Domain, [IP]) -> Domain)
-> ((Time, (Domain, [IP])) -> (Domain, [IP]))
-> (Time, (Domain, [IP]))
-> Domain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Time, (Domain, [IP])) -> (Domain, [IP])
forall a b. (a, b) -> b
snd)
                  ([(Time, (Domain, [IP]))] -> [Domain])
-> [(Time, (Domain, [IP]))] -> [Domain]
forall a b. (a -> b) -> a -> b
$ [(Time, TraceLocalRootPeers SockAddr Failure)]
-> [(Time, (Domain, [IP]))]
selectLocalRootResultEvents
                  ([(Time, TraceLocalRootPeers SockAddr Failure)]
 -> [(Time, (Domain, [IP]))])
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
-> [(Time, (Domain, [IP]))]
forall a b. (a -> b) -> a -> b
$ [(Time, TraceLocalRootPeers SockAddr Failure)]
tr

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

        -- all domains that were tried to resolve during the simulation
        allTriedDomains :: Set Domain
        allTriedDomains :: Set Domain
allTriedDomains
          = [Domain] -> Set Domain
forall a. Ord a => [a] -> Set a
Set.fromList
          ([Domain] -> Set Domain) -> [Domain] -> Set Domain
forall a b. (a -> b) -> a -> b
$ [Maybe Domain] -> [Domain]
forall a. [Maybe a] -> [a]
catMaybes
          [ Maybe Domain
mbDomain
          | (Time
_, TraceLocalRootPeers SockAddr Failure
ev) <- [(Time, TraceLocalRootPeers SockAddr Failure)]
tr
          , let mbDomain :: Maybe Domain
mbDomain = case TraceLocalRootPeers SockAddr Failure
ev of
                  TraceLocalRootResult  (DomainAccessPoint Domain
domain PortNumber
_)  [(IP, Word32)]
_ -> Domain -> Maybe Domain
forall a. a -> Maybe a
Just Domain
domain
                  TraceLocalRootFailure (DomainAccessPoint Domain
domain PortNumber
_)  DNSorIOError Failure
_ -> Domain -> Maybe Domain
forall a. a -> Maybe a
Just Domain
domain
                  TraceLocalRootError   (DomainAccessPoint Domain
_domain PortNumber
_) SomeException
_ -> Maybe Domain
forall a. Maybe a
Nothing
                  TraceLocalRootPeers SockAddr Failure
_                                                     -> Maybe Domain
forall a. Maybe a
Nothing

          ]


    in
      -- we verify that we tried to resolve all local root domains, and that the
      -- resolved ones are a subset of `maxResultMap`
           Set Domain
localRootDomains Set Domain -> Set Domain -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Set Domain
allTriedDomains
      Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. (Set Domain -> Property -> Property)
-> Property -> Script (Set Domain) -> Property
forall a b. (a -> b -> b) -> b -> Script a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Set Domain
rm Property
r -> [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample (Set Domain -> [Char]
forall a. Show a => a -> [Char]
show Set Domain
resultMap [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
" is subset of "
                                     [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Set Domain -> [Char]
forall a. Show a => a -> [Char]
show Set Domain
rm)
                          (Set Domain
resultMap Set Domain -> Set Domain -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set Domain
rm)
                        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Property
r
                 )
                 (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True)
                 Script (Set Domain)
maxResultMap


-- | 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
                                   -> Property
prop_local_updatesDomainsCorrectly :: MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> Property
prop_local_updatesDomainsCorrectly mockRoots :: MockRoots
mockRoots@(MockRoots [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
lrp Script (Map Domain [(IP, Word32)])
_ Map RelayAccessPoint PeerAdvertise
_ Script (Map Domain [(IP, Word32)])
_)
                                   Script DNSTimeout
dnsTimeoutScript
                                   Script DNSLookupDelay
dnsLookupDelayScript =
    let tr :: [(Time, TraceLocalRootPeers SockAddr Failure)]
tr = [(Time, TestTraceEvent)]
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
selectLocalRootPeersEvents
           ([(Time, TestTraceEvent)]
 -> [(Time, TraceLocalRootPeers SockAddr Failure)])
-> [(Time, TestTraceEvent)]
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
forall a b. (a -> b) -> a -> b
$ SimTrace () -> [(Time, TestTraceEvent)]
forall a. SimTrace a -> [(Time, TestTraceEvent)]
selectRootPeerDNSTraceEvents
           (SimTrace () -> [(Time, TestTraceEvent)])
-> SimTrace () -> [(Time, TestTraceEvent)]
forall a b. (a -> b) -> a -> b
$ (forall s. IOSim s ()) -> SimTrace ()
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace
           ((forall s. IOSim s ()) -> SimTrace ())
-> (forall s. IOSim s ()) -> SimTrace ()
forall a b. (a -> b) -> a -> b
$ Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> IOSim s ()
forall (m :: * -> *).
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 MonadTimer m, MonadTraceSTM m, MonadLabelledSTM m) =>
Tracer m (TraceLocalRootPeers SockAddr Failure)
-> MockRoots -> Script DNSTimeout -> Script DNSLookupDelay -> m ()
mockLocalRootPeersProvider Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
forall s. Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
tracerTraceLocalRoots
                                        MockRoots
mockRoots
                                        Script DNSTimeout
dnsTimeoutScript
                                        Script DNSLookupDelay
dnsLookupDelayScript

        r :: (Bool, (Time, TraceLocalRootPeers SockAddr Failure))
r = ((Bool, (Time, TraceLocalRootPeers SockAddr Failure))
 -> (Time, TraceLocalRootPeers SockAddr Failure)
 -> (Bool, (Time, TraceLocalRootPeers SockAddr Failure)))
-> (Bool, (Time, TraceLocalRootPeers SockAddr Failure))
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
-> (Bool, (Time, TraceLocalRootPeers SockAddr Failure))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' (\(Bool
b, (Time
t, TraceLocalRootPeers SockAddr Failure
x)) (Time
t', TraceLocalRootPeers SockAddr Failure
y) ->
                    case (TraceLocalRootPeers SockAddr Failure
x, TraceLocalRootPeers SockAddr Failure
y) of
                      -- Last result groups value, Current result groups value
                      (TraceLocalRootGroups [(HotValency, WarmValency, Map SockAddr LocalRootConfig)]
lrpg, 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', TraceLocalRootPeers SockAddr Failure
y))
                      -- Last DNS lookup result   , Current result groups value
                      (TraceLocalRootResult DomainAccessPoint
da [(IP, Word32)]
res, TraceLocalRootGroups [(HotValency, WarmValency, Map SockAddr LocalRootConfig)]
lrpg) ->
                            -- create and index db for each group
                        let 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 (DomainAccessPoint -> RelayAccessPoint
RelayDomainAccessPoint DomainAccessPoint
da) 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
_ Word32
hostAddr
                                                 -> IPv4 -> IP
IPv4 (IPv4 -> IP) -> IPv4 -> IP
forall a b. (a -> b) -> a -> b
$ Word32 -> IPv4
fromHostAddress Word32
hostAddr
                                               SockAddr
_ -> [Char] -> IP
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible happened!"

                                         ) ([SockAddr] -> [IP]) -> [SockAddr] -> [IP]
forall a b. (a -> b) -> a -> b
$ Map SockAddr 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, Word32) -> Bool) -> [(IP, Word32)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((IP -> [IP] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IP]
ipsAtIndex) (IP -> Bool) -> ((IP, Word32) -> IP) -> (IP, Word32) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IP, Word32) -> IP
forall a b. (a, b) -> a
fst) [(IP, Word32)]
res
                         in (Bool
arePresent Bool -> Bool -> Bool
&& Bool
b, (Time
t', TraceLocalRootPeers SockAddr Failure
y))

                      (TraceLocalRootResult DomainAccessPoint
_ [(IP, Word32)]
_, TraceLocalRootPeers SockAddr Failure
_) -> (Bool
b, (Time
t, TraceLocalRootPeers SockAddr Failure
x))
                      (TraceLocalRootPeers SockAddr Failure
_, TraceLocalRootPeers SockAddr Failure
_)                        -> (Bool
b, (Time
t', TraceLocalRootPeers SockAddr Failure
y))
                   )
              (Bool
True, [(Time, TraceLocalRootPeers SockAddr Failure)]
-> (Time, TraceLocalRootPeers SockAddr Failure)
forall a. HasCallStack => [a] -> a
head [(Time, TraceLocalRootPeers SockAddr Failure)]
tr)
              ([(Time, TraceLocalRootPeers SockAddr Failure)]
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
forall a. HasCallStack => [a] -> [a]
tail [(Time, TraceLocalRootPeers SockAddr Failure)]
tr)
     in Bool -> Property
forall prop. Testable prop => prop -> Property
property ((Bool, (Time, TraceLocalRootPeers SockAddr Failure)) -> Bool
forall a b. (a, b) -> a
fst (Bool, (Time, TraceLocalRootPeers SockAddr Failure))
r)
  where
    thrd :: (a, b, c) -> c
thrd (a
_, b
_, c
c) = c
c

--
-- 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
                                     -> Property
prop_public_resolvesDomainsCorrectly :: MockRoots -> DelayAndTimeoutScripts -> Int -> Property
prop_public_resolvesDomainsCorrectly
    mockRoots :: MockRoots
mockRoots@(MockRoots [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
_ Script (Map Domain [(IP, Word32)])
_ Map RelayAccessPoint PeerAdvertise
_ Script (Map Domain [(IP, Word32)])
pDNSMap)
    (DelayAndTimeoutScripts Script DNSLookupDelay
dnsLookupDelayScript Script DNSTimeout
dnsTimeoutScript)
    Int
n
  =
    let mockRoots' :: MockRoots
mockRoots' =
          MockRoots
mockRoots { mockPublicRootPeersDNSMap =
                        singletonScript (scriptHead pDNSMap)
                    }
        tr :: SimTrace ()
tr = (forall s. IOSim s ()) -> SimTrace ()
forall a. (forall s. IOSim s a) -> SimTrace a
runSimTrace
           ((forall s. IOSim s ()) -> SimTrace ())
-> (forall s. IOSim s ()) -> SimTrace ()
forall a b. (a -> b) -> a -> b
$ Tracer (IOSim s) TracePublicRootPeers
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> ((Int -> IOSim s (Map SockAddr PeerAdvertise, DiffTime))
    -> IOSim s (Map SockAddr PeerAdvertise, DiffTime))
-> IOSim s ()
forall (m :: * -> *) a.
(MonadAsync m, MonadDelay m, MonadThrow m, MonadTimer m) =>
Tracer m TracePublicRootPeers
-> MockRoots
-> Script DNSTimeout
-> Script DNSLookupDelay
-> ((Int -> m (Map SockAddr PeerAdvertise, DiffTime)) -> m a)
-> m ()
mockPublicRootPeersProvider Tracer (IOSim s) TracePublicRootPeers
forall s. Tracer (IOSim s) TracePublicRootPeers
tracerTracePublicRoots
                                         MockRoots
mockRoots'
                                         Script DNSTimeout
dnsTimeoutScript
                                         Script DNSLookupDelay
dnsLookupDelayScript
                                         ((Int -> IOSim s (Map SockAddr PeerAdvertise, DiffTime))
-> Int -> IOSim s (Map SockAddr PeerAdvertise, DiffTime)
forall a b. (a -> b) -> a -> b
$ Int
n)

        successes :: [(Time, (Domain, [IP]))]
successes = [(Time, TracePublicRootPeers)] -> [(Time, (Domain, [IP]))]
selectPublicRootResultEvents
                  ([(Time, TracePublicRootPeers)] -> [(Time, (Domain, [IP]))])
-> [(Time, TracePublicRootPeers)] -> [(Time, (Domain, [IP]))]
forall a b. (a -> b) -> a -> b
$ [(Time, TestTraceEvent)] -> [(Time, TracePublicRootPeers)]
selectPublicRootPeersEvents
                  ([(Time, TestTraceEvent)] -> [(Time, TracePublicRootPeers)])
-> [(Time, TestTraceEvent)] -> [(Time, TracePublicRootPeers)]
forall a b. (a -> b) -> a -> b
$ SimTrace () -> [(Time, TestTraceEvent)]
forall a. SimTrace a -> [(Time, TestTraceEvent)]
selectRootPeerDNSTraceEvents
                  (SimTrace () -> [(Time, TestTraceEvent)])
-> SimTrace () -> [(Time, TestTraceEvent)]
forall a b. (a -> b) -> a -> b
$ SimTrace ()
tr

        successesMap :: Map Domain [IP]
successesMap = [(Domain, [IP])] -> Map Domain [IP]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Domain, [IP])] -> Map Domain [IP])
-> [(Domain, [IP])] -> Map Domain [IP]
forall a b. (a -> b) -> a -> b
$ ((Time, (Domain, [IP])) -> (Domain, [IP]))
-> [(Time, (Domain, [IP]))] -> [(Domain, [IP])]
forall a b. (a -> b) -> [a] -> [b]
map (Time, (Domain, [IP])) -> (Domain, [IP])
forall a b. (a, b) -> b
snd [(Time, (Domain, [IP]))]
successes

     in [Char] -> Bool -> Property
forall prop. Testable prop => [Char] -> prop -> Property
counterexample ([(Time, (Domain, [IP]))] -> [Char]
forall a. Show a => a -> [Char]
show [(Time, (Domain, [IP]))]
successes)
      (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ Map Domain [IP]
successesMap Map Domain [IP] -> Map Domain [IP] -> Bool
forall a. Eq a => a -> a -> Bool
== (((IP, Word32) -> IP) -> [(IP, Word32)] -> [IP]
forall a b. (a -> b) -> [a] -> [b]
map (IP, Word32) -> IP
forall a b. (a, b) -> a
fst ([(IP, Word32)] -> [IP])
-> Map Domain [(IP, Word32)] -> Map Domain [IP]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Script (Map Domain [(IP, Word32)]) -> Map Domain [(IP, Word32)]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions Script (Map Domain [(IP, Word32)])
pDNSMap)


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