Just (Left e) -> return ([e], [])
Just (Right a) -> return ([], a)
-
-- TODO: Change this once upgraded to most recent GHC version
-
newtype Solo a = Solo { unSolo :: a }
-- | 'localRootPeersProvider' running with a given MockRoots env
mockLocalRootPeersProvider :: forall m.
=> Tracer m (TraceLocalRootPeers SockAddr Failure)
dnsLookupDelayScriptVar <- initScript' dnsLookupDelayScript
localRootPeersVar <- newTVarIO localRootPeers
resultVar <- newTVarIO mempty
+
_ <- labelTVarIO resultVar "resultVar"
_ <- traceTVarIO resultVar
-
(\_ a -> pure $ TraceDynamic (Solo a))
+
(\_ a -> pure $ TraceDynamic (LocalRootPeersResults a))
withAsync (updateDNSMap dnsMapScriptVar dnsMapVar) $ \_ -> do
void $ MonadTimer.timeout 3600 $
localRootPeersProvider tracer
(readTVar localRootPeersVar)
+
-- 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
+
atomically $ readTVar resultVar >>= writeTVar resultVar
updateDNSMap :: LazySTM.TVar m (Script (Map Domain [(IP, TTL)]))
-> StrictTVar m (Map Domain [(IP, TTL)])
-
data TestTraceEvent exception = RootPeerDNSLocal (TraceLocalRootPeers SockAddr exception)
-
| RootPeerDNSPublic TracePublicRootPeers
+
data TestTraceEvent = RootPeerDNSLocal (TraceLocalRootPeers SockAddr Failure)
+
| LocalRootPeersResults [(Int, Map SockAddr PeerAdvertise)]
+
| RootPeerDNSPublic TracePublicRootPeers
+
deriving (Show, Typeable)
tracerTraceLocalRoots :: Tracer (IOSim s) (TraceLocalRootPeers SockAddr Failure)
tracerTraceLocalRoots = contramap RootPeerDNSLocal tracerTestTraceEvent
tracerTracePublicRoots :: Tracer (IOSim s) TracePublicRootPeers
tracerTracePublicRoots = contramap RootPeerDNSPublic tracerTestTraceEvent
-
tracerTestTraceEvent :: Tracer (IOSim s) (TestTraceEvent Failure)
+
tracerTestTraceEvent :: Tracer (IOSim s) TestTraceEvent
tracerTestTraceEvent = dynamicTracer
dynamicTracer :: Typeable a => Tracer (IOSim s) a
dynamicTracer = Tracer traceM
-
selectRootPeerDNSTraceEvents :: SimTrace a -> [(Time, TestTraceEvent Failure)]
+
selectRootPeerDNSTraceEvents :: SimTrace a -> [(Time, TestTraceEvent)]
selectRootPeerDNSTraceEvents = go
go (SimTrace t _ _ (EventLog e) trace)
go (TraceMainReturn _ _ _) = []
go TraceLoop = error "IOSimPOR step time limit exceeded"
-
selectLocalRootPeersEvents :: [(Time, TestTraceEvent Failure)]
+
selectLocalRootPeersEvents :: [(Time, TestTraceEvent)]
-> [(Time, TraceLocalRootPeers SockAddr Failure)]
selectLocalRootPeersEvents trace = [ (t, e) | (t, RootPeerDNSLocal e) <- trace ]
-
selectLocalRootGroupsEvents :: [(Time, TraceLocalRootPeers SockAddr Failure)]
+
selectLocalRootPeersResults :: [(Time, TestTraceEvent)]
-> [(Time, [(Int, Map SockAddr PeerAdvertise)])]
-
selectLocalRootGroupsEvents trace = [ (t, e) | (t, TraceLocalRootGroups e) <- trace ]
+
selectLocalRootPeersResults trace = [ (t, r) | (t, LocalRootPeersResults r) <- trace ]
selectLocalRootResultEvents :: [(Time, TraceLocalRootPeers SockAddr Failure)]
-> [(Time, (Domain, [IP]))]
selectLocalRootResultEvents trace = [ (t, (domain, map fst r))
| (t, TraceLocalRootResult (DomainAccessPoint domain _) r) <- trace ]
-
selectPublicRootPeersEvents :: [(Time, TestTraceEvent Failure)]
+
selectPublicRootPeersEvents :: [(Time, TestTraceEvent)]
-> [(Time, TracePublicRootPeers)]
selectPublicRootPeersEvents trace = [ (t, e) | (t, RootPeerDNSPublic e) <- trace ]
prop_local_preservesIPs mockRoots@(MockRoots localRoots _ _ _)
-
let tr = selectLocalRootGroupsEvents
-
$ selectLocalRootPeersEvents
+
let tr = selectLocalRootPeersResults
$ selectRootPeerDNSTraceEvents
$ mockLocalRootPeersProvider tracerTraceLocalRoots
prop_local_preservesGroupNumberAndTargets mockRoots@(MockRoots lrp _ _ _)
-
let tr = selectLocalRootGroupsEvents
-
$ selectLocalRootPeersEvents
+
let tr = selectLocalRootPeersResults
$ selectRootPeerDNSTraceEvents
$ mockLocalRootPeersProvider tracerTraceLocalRoots
