diff --git a/cardano-diffusion/lib/Cardano/Network/Diffusion.hs b/cardano-diffusion/lib/Cardano/Network/Diffusion.hs index a47de1475a1..32a24d7a96a 100644 --- a/cardano-diffusion/lib/Cardano/Network/Diffusion.hs +++ b/cardano-diffusion/lib/Cardano/Network/Diffusion.hs @@ -14,6 +14,8 @@ module Cardano.Network.Diffusion ( module Cardano.Network.Diffusion.Types , run + -- * Utils + , Diffusion.readIPAndPort ) where import Control.DeepSeq (NFData) diff --git a/cardano-diffusion/ping/Cardano/Network/Ping.hs b/cardano-diffusion/ping/Cardano/Network/Ping.hs index a973b1b47cf..21ad9f47fec 100644 --- a/cardano-diffusion/ping/Cardano/Network/Ping.hs +++ b/cardano-diffusion/ping/Cardano/Network/Ping.hs @@ -110,6 +110,7 @@ import System.IO qualified as IO import System.Random (initStdGen) import Text.Read (readMaybe) +import Cardano.Network.Diffusion (readIPAndPort) import Cardano.Network.Diffusion.Configuration (defaultChainSyncIdleTimeout) import Cardano.Network.NodeToClient qualified as NodeToClient import Cardano.Network.NodeToClient.Version @@ -149,7 +150,7 @@ data PingMode = -- ^ query handshake parameters deriving (Eq, Show) -type Port = Word +type Port = Socket.PortNumber -- | There are three stages for resolving addresses. -- @@ -337,43 +338,13 @@ argParser = addrParser :: Parser (Address (Unresolved SRVOrFilePathUnresolved)) addrParser = argument - ( uncurry IP <$> readIPv4AndPort - <|> uncurry IP <$> readIPv6AndPort + ( uncurry IP <$> readIPAndPort <|> readDomainNameOrFilePath ) ( help "List of IP/DNS/SRV address and ports or UNIX socket paths, e.g. 127.0.0.1:3001 [::1]:3001 example.org:3001." <> metavar "ADDRS" ) where - -- note: `Read` instances for `IP`, `IPv4`, `IPv6` expect no trailing - -- characters after the address, thus we need to find the split position - -- first. - - -- parse IPv4 address and port in a form `127.0.0.1:3001` - readIPv4AndPort :: ReadM (IP, Port) - readIPv4AndPort = - eitherReader $ \s -> do - case splitWith ':' s of - Nothing -> Left s - Just (addrStr, portStr) -> - maybe (Left s) Right $ - (,) <$> readMaybe addrStr - <*> readMaybe portStr - - -- parse IPv6 address and port in a form `[::1]:3001` or a UNIX file path - readIPv6AndPort :: ReadM (IP, Port) - readIPv6AndPort = - eitherReader $ \s -> - case s of - ('[':s') -> - case splitWith ']' s' of - Just (addrStr, ':' : portStr) -> - maybe (Left s) Right $ - (,) <$> readMaybe addrStr - <*> readMaybe portStr - _ -> Left s - _ -> Left s - readDomainNameOrFilePath :: ReadM (Address (Unresolved SRVOrFilePathUnresolved)) readDomainNameOrFilePath = eitherReader $ Right . mkAddress @@ -420,7 +391,7 @@ instance Exception AddressResolutionError where -- | Log messages to stderr. -- data PingWarning = AddressResolutionError AddressResolutionError - | DNSResolution DNS.Domain [IP] Word + | DNSResolution DNS.Domain [IP] Port | Error SomeException | ConnectError SockAddr SomeException diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs index 19172bfbf1b..65fa0179569 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet.hs @@ -436,7 +436,7 @@ unit_cm_valid_transitions = DoAdvertisePeer)]) GenesisMode (Script (DontUseBootstrapPeers :| [])) - (TestAddress (IPAddr (read "0:79::1:0:0") 3)) + (IPAddr (read "0:79::1:0:0") 3) PeerSharingDisabled [ (HotValency {getHotValency = 1}, WarmValency {getWarmValency = 1}, @@ -479,7 +479,7 @@ unit_cm_valid_transitions = Map.empty GenesisMode (Script (DontUseBootstrapPeers :| [])) - (TestAddress (IPAddr (read "0:71:0:1:0:1:0:1") 65_534)) + (IPAddr (read "0:71:0:1:0:1:0:1") 65_534) PeerSharingEnabled [ (HotValency {getHotValency = 1}, WarmValency {getWarmValency = 1}, @@ -641,8 +641,8 @@ unit_connection_manager_trace_coverage = _ -> True) where addr, addr' :: NtNAddr - addr = TestAddress (IPAddr (read "127.0.0.2") 1_000) - addr' = TestAddress (IPAddr (read "127.0.0.1") 1_000) + addr = IPAddr (read "127.0.0.2") 1_000 + addr' = IPAddr (read "127.0.0.1") 1_000 script@(DiffusionScript _ _ nodes) = DiffusionScript @@ -767,8 +767,8 @@ unit_connection_manager_transitions_coverage = where addr, addr' :: NtNAddr - addr = TestAddress (IPAddr (read "127.0.0.2") 1000) - addr' = TestAddress (IPAddr (read "127.0.0.1") 1000) + addr = IPAddr (read "127.0.0.2") 1000 + addr' = IPAddr (read "127.0.0.1") 1000 script@(DiffusionScript _ _ nodes) = DiffusionScript @@ -956,7 +956,7 @@ prop_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) Map.empty PraosMode (Script (DontUseBootstrapPeers :| [])) - (TestAddress (IPAddr (read "0.0.0.0") 0)) + (IPAddr (read "0.0.0.0") 0) PeerSharingDisabled [(2,2,Map.fromList [(RelayAccessAddress "0.0.0.1" 0, localRootConfig)])] (Script (LedgerPools [] :| [])) @@ -986,7 +986,7 @@ prop_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) Map.empty PraosMode (Script (DontUseBootstrapPeers :| [])) - (TestAddress (IPAddr (read "0.0.0.1") 0)) + (IPAddr (read "0.0.0.1") 0) PeerSharingDisabled [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.0" 0, localRootConfig)])] (Script (LedgerPools [] :| [])) @@ -1088,7 +1088,7 @@ prop_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) -- for the two nodes involved in the simulation and verify that indeed -- each peer managed to learn about the other peer' transactions. -- - $ case Map.lookup (TestAddress (IPAddr (read "0.0.0.0") 0)) sortedAcceptedTxidsMap + $ case Map.lookup (IPAddr (read "0.0.0.0") 0) sortedAcceptedTxidsMap of Just acceptedTxidsA -> counterexample "0.0.0.0" $ @@ -1096,7 +1096,7 @@ prop_txSubmission_allTransactions (ArbTxDecisionPolicy decisionPolicy) Nothing | [] <- validSortedTxidsB -> property True | otherwise -> counterexample "Didn't found any entry in the map!" False .&&. - case Map.lookup (TestAddress (IPAddr (read "0.0.0.1") 0)) sortedAcceptedTxidsMap + case Map.lookup (IPAddr (read "0.0.0.1") 0) sortedAcceptedTxidsMap of Just acceptedTxidsB -> counterexample "0.0.0.1" $ @@ -1150,7 +1150,7 @@ txChainIntegrityDiffScript (ArbTxDecisionPolicy decisionPolicy) Map.empty PraosMode (Script (DontUseBootstrapPeers :| [])) - (TestAddress (IPAddr (read "0.0.0.0") 0)) + (IPAddr (read "0.0.0.0") 0) PeerSharingDisabled [] (Script (LedgerPools [] :| [])) @@ -1169,7 +1169,7 @@ txChainIntegrityDiffScript (ArbTxDecisionPolicy decisionPolicy) Map.empty PraosMode (Script (DontUseBootstrapPeers :| [])) - (TestAddress (IPAddr (read "0.0.0.1") 0)) + (IPAddr (read "0.0.0.1") 0) PeerSharingDisabled [(1, 1, Map.fromList [(RelayAccessAddress "0.0.0.0" 0, localRootConfig)])] @@ -1189,7 +1189,7 @@ txChainIntegrityDiffScript (ArbTxDecisionPolicy decisionPolicy) Map.empty PraosMode (Script (DontUseBootstrapPeers :| [])) - (TestAddress (IPAddr (read "0.0.0.2") 0)) + (IPAddr (read "0.0.0.2") 0) PeerSharingDisabled [(1, 1, Map.fromList [(RelayAccessAddress "0.0.0.0" 0, localRootConfig)])] @@ -1259,7 +1259,7 @@ checkTxChainIntegrity (ChainedPeerTxs chainedTxsB chainedTxsC) . splitWithNameTrace $ events - receiverAddr = TestAddress (IPAddr (read "0.0.0.0") 0) + receiverAddr = IPAddr (read "0.0.0.0") 0 accepted = Map.lookup receiverAddr sortedAcceptedTxidsMap actualSet = maybe Set.empty Set.fromList accepted missing = expectedAtReceiver `Set.difference` actualSet in @@ -1449,7 +1449,7 @@ txScoreImpairmentDiffScript ScoreImpairmentInput { siiTxCount, siiBDelayMul, sii Map.empty PraosMode (Script (DontUseBootstrapPeers :| [])) - (TestAddress (IPAddr (read "0.0.0.0") 0)) + (IPAddr (read "0.0.0.0") 0) PeerSharingDisabled [] (Script (LedgerPools [] :| [])) @@ -1468,7 +1468,7 @@ txScoreImpairmentDiffScript ScoreImpairmentInput { siiTxCount, siiBDelayMul, sii Map.empty PraosMode (Script (DontUseBootstrapPeers :| [])) - (TestAddress (IPAddr (read "0.0.0.1") 0)) + (IPAddr (read "0.0.0.1") 0) PeerSharingDisabled [(1, 1, Map.fromList [(RelayAccessAddress "0.0.0.0" 0, localRootConfig)])] @@ -1488,7 +1488,7 @@ txScoreImpairmentDiffScript ScoreImpairmentInput { siiTxCount, siiBDelayMul, sii Map.empty PraosMode (Script (DontUseBootstrapPeers :| [])) - (TestAddress (IPAddr (read "0.0.0.2") 0)) + (IPAddr (read "0.0.0.2") 0) PeerSharingDisabled [(1, 1, Map.fromList [(RelayAccessAddress "0.0.0.0" 0, localRootConfig)])] @@ -1515,9 +1515,9 @@ prop_txSubmission_score_impairment input@ScoreImpairmentInput { siiTxCount, siiB $ diffusionSimulation noAttenuation (txScoreImpairmentDiffScript input) - receiverAddr = TestAddress (IPAddr (read "0.0.0.0") 0) - peerB = TestAddress (IPAddr (read "0.0.0.1") 0) - peerC = TestAddress (IPAddr (read "0.0.0.2") 0) + receiverAddr = IPAddr (read "0.0.0.0") 0 + peerB = IPAddr (read "0.0.0.1") 0 + peerC = IPAddr (read "0.0.0.2") 0 scores :: Map NtNAddr Double scores = @@ -1971,7 +1971,7 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script (Map.fromList [(RelayAccessDomain "test2" 65_535, DoAdvertisePeer)]) PraosMode (Script (UseBootstrapPeers [RelayAccessDomain "bootstrap" 0] :| [])) - (TestAddress (IPAddr (read "0:7:0:7::") 65_533)) + (IPAddr (read "0:7:0:7::") 65_533) PeerSharingDisabled [ (1,1,Map.fromList [(RelayAccessDomain "test2" 65_535,LocalRootConfig DoNotAdvertisePeer InitiatorAndResponderDiffusionMode Outbound IsNotTrustable) , (RelayAccessAddress "0:6:0:3:0:6:0:5" 65_530,LocalRootConfig DoNotAdvertisePeer InitiatorAndResponderDiffusionMode Outbound IsNotTrustable)]) @@ -2004,7 +2004,7 @@ unit_4177 = prop_inbound_governor_transitions_coverage absNoAttenuation script (Map.fromList [(RelayAccessAddress "0:7:0:7::" 65_533, DoAdvertisePeer)]) PraosMode (Script (UseBootstrapPeers [RelayAccessDomain "bootstrap" 0] :| [])) - (TestAddress (IPAddr (read "0:6:0:3:0:6:0:5") 65_530)) + (IPAddr (read "0:6:0:3:0:6:0:5") 65_530) PeerSharingDisabled [] (Script (LedgerPools [] :| [])) @@ -2617,7 +2617,7 @@ unit_4191 = testWithIOSim prop_diffusion_dns_can_recover long_trace absInfo scri Map.empty PraosMode (Script (UseBootstrapPeers [RelayAccessDomain "bootstrap" 0] :| [])) - (TestAddress (IPAddr (read "0.0.1.236") 65_527)) + (IPAddr (read "0.0.1.236") 65_527) PeerSharingDisabled [ (2,2,Map.fromList [ (RelayAccessDomain "test2" 15,LocalRootConfig DoNotAdvertisePeer InitiatorAndResponderDiffusionMode Outbound IsNotTrustable) , (RelayAccessDomain "test3" 4,LocalRootConfig DoAdvertisePeer InitiatorAndResponderDiffusionMode Outbound IsNotTrustable)]) @@ -2696,12 +2696,12 @@ prop_connect_failure (AbsIOError ioerr) = . Trace.take noEvents $ trace evs = eventsToList (selectDiffusionSimulationTrace events) - in counterexample (Trace.ppTrace show (ppSimEvent 0 0 0) . Trace.take noEvents $ trace) - . counterexample (show evs) + in -- counterexample (Trace.ppTrace show (ppSimEvent 0 0 0) . Trace.take noEvents $ trace) + counterexample (show evs) . -- verify that the node was not killed by the `IOError` - all (\case - TrErrored {} -> False - _ -> True) + foldMap (\case + TrErrored err -> Every (counterexample ("exception: " ++ show err) False) + _ -> Every (property True)) . map snd $ evs ) noEvents absInfo script @@ -2719,7 +2719,7 @@ prop_connect_failure (AbsIOError ioerr) = nodeIP = read "10.0.0.0" nodePort = 1 - nodeAddr = TestAddress (IPAddr nodeIP nodePort) + nodeAddr = IPAddr nodeIP nodePort relayIP = read "10.0.0.1" relayPort = 1 @@ -2734,7 +2734,7 @@ prop_connect_failure (AbsIOError ioerr) = naPublicRoots = Map.empty, naConsensusMode = PraosMode, naBootstrapPeers = Script (DontUseBootstrapPeers :| []), - naAddr = TestAddress (IPAddr nodeIP nodePort), + naAddr = IPAddr nodeIP nodePort, naPeerSharing = PeerSharingDisabled, naLocalRootPeers = [(1,1,Map.fromList [(RelayAccessAddress relayIP relayPort,LocalRootConfig DoNotAdvertisePeer InitiatorAndResponderDiffusionMode Outbound IsNotTrustable)])], naLedgerPeers = Script (LedgerPools [] :| []), @@ -2764,7 +2764,7 @@ prop_connect_failure (AbsIOError ioerr) = naPublicRoots = Map.empty, naConsensusMode = PraosMode, naBootstrapPeers = Script (DontUseBootstrapPeers :| []), - naAddr = TestAddress (IPAddr relayIP relayPort), + naAddr = IPAddr relayIP relayPort, naPeerSharing = PeerSharingDisabled, naLocalRootPeers = [], naLedgerPeers = Script (LedgerPools [] :| []), @@ -2852,7 +2852,7 @@ prop_accept_failure (AbsIOError ioerr) = relayIP = read "10.0.0.1" relayPort = 1 - relayAddr = TestAddress (IPAddr relayIP relayPort) + relayAddr = IPAddr relayIP relayPort script = DiffusionScript @@ -2864,7 +2864,7 @@ prop_accept_failure (AbsIOError ioerr) = naPublicRoots = Map.empty, naConsensusMode = PraosMode, naBootstrapPeers = Script (DontUseBootstrapPeers :| []), - naAddr = TestAddress (IPAddr nodeIP nodePort), + naAddr = IPAddr nodeIP nodePort, naPeerSharing = PeerSharingDisabled, naLocalRootPeers = [(1,1,Map.fromList [(RelayAccessAddress relayIP relayPort,LocalRootConfig DoNotAdvertisePeer InitiatorAndResponderDiffusionMode Outbound IsNotTrustable)])], naLedgerPeers = Script (LedgerPools [] :| []), @@ -2894,7 +2894,7 @@ prop_accept_failure (AbsIOError ioerr) = naPublicRoots = Map.empty, naConsensusMode = PraosMode, naBootstrapPeers = Script (DontUseBootstrapPeers :| []), - naAddr = TestAddress (IPAddr relayIP relayPort), + naAddr = IPAddr relayIP relayPort, naPeerSharing = PeerSharingDisabled, naLocalRootPeers = [], naLedgerPeers = Script (LedgerPools [] :| []), @@ -3967,17 +3967,17 @@ async_demotion_network_script = ) ] where - addr1 = TestAddress (IPAddr (read "10.0.0.1") 3000) + addr1 = IPAddr (read "10.0.0.1") 3000 ra_addr1 = RelayAccessAddress (read "10.0.0.1") 3000 localRoots1 = [(2,2, Map.fromList [(ra_addr2, LocalRootConfig DoNotAdvertisePeer InitiatorAndResponderDiffusionMode Outbound IsNotTrustable) ,(ra_addr3, LocalRootConfig DoNotAdvertisePeer InitiatorAndResponderDiffusionMode Outbound IsNotTrustable)])] localRoots1' = [(2,2, Map.fromList [(ra_addr2, LocalRootConfig DoAdvertisePeer InitiatorAndResponderDiffusionMode Outbound IsNotTrustable) ,(ra_addr3, LocalRootConfig DoAdvertisePeer InitiatorAndResponderDiffusionMode Outbound IsNotTrustable)])] - addr2 = TestAddress (IPAddr (read "10.0.0.2") 3000) + addr2 = IPAddr (read "10.0.0.2") 3000 ra_addr2 = RelayAccessAddress (read "10.0.0.2") 3000 - addr3 = TestAddress (IPAddr (read "10.0.0.3") 3000) + addr3 = IPAddr (read "10.0.0.3") 3000 ra_addr3 = RelayAccessAddress (read "10.0.0.3") 3000 simArgs = SimArgs { @@ -4558,7 +4558,7 @@ prop_unit_4258 = Map.empty PraosMode (Script (UseBootstrapPeers [RelayAccessDomain "bootstrap" 0] :| [])) - (TestAddress (IPAddr (read "0.0.0.4") 9)) + (IPAddr (read "0.0.0.4") 9) PeerSharingDisabled [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.8" 65_531,LocalRootConfig DoNotAdvertisePeer InitiatorAndResponderDiffusionMode Outbound IsNotTrustable)])] (Script (LedgerPools [] :| [])) @@ -4594,7 +4594,7 @@ prop_unit_4258 = (Map.fromList [(RelayAccessAddress "0.0.0.4" 9, DoAdvertisePeer)]) PraosMode (Script (UseBootstrapPeers [RelayAccessDomain "bootstrap" 0] :| [])) - (TestAddress (IPAddr (read "0.0.0.8") 65_531)) + (IPAddr (read "0.0.0.8") 65_531) PeerSharingDisabled [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.4" 9,LocalRootConfig DoNotAdvertisePeer InitiatorAndResponderDiffusionMode Outbound IsNotTrustable)])] (Script (LedgerPools [] :| [])) @@ -4667,7 +4667,7 @@ prop_unit_reconnect = Map.empty PraosMode (Script (DontUseBootstrapPeers :| [])) - (TestAddress (IPAddr (read "0.0.0.0") 0)) + (IPAddr (read "0.0.0.0") 0) PeerSharingDisabled [ (2,2,Map.fromList [ (RelayAccessAddress "0.0.0.1" 0,LocalRootConfig DoNotAdvertisePeer InitiatorAndResponderDiffusionMode Outbound IsNotTrustable) , (RelayAccessAddress "0.0.0.2" 0,LocalRootConfig DoNotAdvertisePeer InitiatorAndResponderDiffusionMode Outbound IsNotTrustable) @@ -4699,7 +4699,7 @@ prop_unit_reconnect = Map.empty PraosMode (Script (DontUseBootstrapPeers :| [])) - (TestAddress (IPAddr (read "0.0.0.1") 0)) + (IPAddr (read "0.0.0.1") 0) PeerSharingDisabled [(1,1,Map.fromList [(RelayAccessAddress "0.0.0.0" 0,LocalRootConfig DoNotAdvertisePeer InitiatorAndResponderDiffusionMode Outbound IsNotTrustable)])] (Script (LedgerPools [] :| [])) @@ -5110,13 +5110,13 @@ unit_peer_sharing = -- peer sharing), and thus it should be marked as `DoAdvertisePeer` -- * ip_2 should learn about ip_0 from ip_1 by peer sharing - ip_0 = TestAddress $ IPAddr (IP.IPv4 (IP.toIPv4 [0,0,0,0])) 3000 + ip_0 = IPAddr (IP.IPv4 (IP.toIPv4 [0,0,0,0])) 3000 -- ra_0 = RelayAccessAddress (IP.IPv4 (IP.toIPv4 [0,0,0,0])) 3000 - ip_1 = TestAddress $ IPAddr (IP.IPv4 (IP.toIPv4 [0,0,0,0])) 3001 + ip_1 = IPAddr (IP.IPv4 (IP.toIPv4 [0,0,0,0])) 3001 ra_1 = RelayAccessAddress (IP.IPv4 (IP.toIPv4 [0,0,0,0])) 3001 - ip_2 = TestAddress $ IPAddr (IP.IPv4 (IP.toIPv4 [0,0,0,0])) 3002 + ip_2 = IPAddr (IP.IPv4 (IP.toIPv4 [0,0,0,0])) 3002 -- ra_2 = RelayAccessAddress (IP.IPv4 (IP.toIPv4 [0,0,0,0])) 3002 targets x = let t = PeerSelectionTargets { @@ -5842,8 +5842,8 @@ unit_local_root_diffusion_mode diffusionMode = in property $ foldMap (\versionData -> Every $ ntnDiffusionMode versionData === diffusionMode) events where addr, addr' :: NtNAddr - addr = TestAddress (IPAddr (read "127.0.0.2") 1000) - addr' = TestAddress (IPAddr (read "127.0.0.1") 1000) + addr = IPAddr (read "127.0.0.2") 1000 + addr' = IPAddr (read "127.0.0.1") 1000 script = DiffusionScript @@ -6039,7 +6039,7 @@ selectDiffusionPeerSelectionStateWithName f = Signal.nub -- TODO: #3182 Rng seed should come from quickcheck. . Signal.scanl (\z -> - maybe z \(addr, trace) -> either (TestAddress UnusedAddr,) (addr,) trace) + maybe z \(addr, trace) -> either (UnusedAddr,) (addr,) trace) offState . Signal.fromEvents . Signal.selectEvents ( @@ -6052,7 +6052,7 @@ selectDiffusionPeerSelectionStateWithName f = _ -> Nothing) >>> \(addr, tr) -> (addr,) <$> tr) where - offState = (TestAddress UnusedAddr, initial PraosMode) + offState = (UnusedAddr, initial PraosMode) initial consensusMode = f $! Governor.emptyPeerSelectionState (mkStdGen 42) diff --git a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs index 2796ff29eb8..a54ffc1d402 100644 --- a/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs +++ b/cardano-diffusion/tests/lib/Test/Cardano/Network/Diffusion/Testnet/Simulation.hs @@ -32,7 +32,7 @@ module Test.Cardano.Network.Diffusion.Testnet.Simulation , DiffusionTestTrace (..) , ppDiffusionTestTrace -- * Re-exports - , TestAddress (..) + , Node.NetworkAddress (..) , RelayAccessPoint (..) , Script (..) , module PeerSelection @@ -125,7 +125,7 @@ import Ouroboros.Network.Protocol.PeerSharing.Codec (byteLimitsPeerSharing, import Ouroboros.Network.Protocol.TxSubmission2.Codec (byteLimitsTxSubmission2, timeLimitsTxSubmission2) import Ouroboros.Network.Server qualified as Server -import Ouroboros.Network.Snocket (Snocket, TestAddress (..)) +import Ouroboros.Network.Snocket (Snocket) import Ouroboros.Network.TxSubmission.Inbound.V2.Policy (TxDecisionPolicy) import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TraceTxLogic, TraceTxSubmissionInbound) @@ -138,8 +138,7 @@ import Simulation.Network.Snocket (BearerInfo (..), FD, SnocketTrace, import Test.Ouroboros.Network.Data.Script import Test.Ouroboros.Network.Diffusion.Node qualified as Node import Test.Ouroboros.Network.Diffusion.Node.Kernel (NtCAddr, NtCVersion, - NtCVersionData, NtNAddr, NtNAddr_ (IPAddr), NtNVersion, - NtNVersionData) + NtCVersionData, NtNAddr, NtNVersion, NtNVersionData) import Test.Ouroboros.Network.LedgerPeers (LedgerPools (..), cardanoSRVPrefix, genLedgerPoolsFrom) import Test.Ouroboros.Network.OrphanInstances (genIPv4, genIPv6) @@ -474,7 +473,7 @@ genNodeArgs relays minConnected localRootPeers self txs = flip suchThat hasUpstr -- `UseLedgerPeers 0`! , naConsensusMode , naBootstrapPeers = bootstrapPeersDomain - , naAddr = TestAddress ((\(_, ip, port, _) -> IPAddr ip port) self) + , naAddr = ((\(_, ip, port, _) -> Node.IPAddr ip port) self) , naLocalRootPeers = localRootPeers , naLedgerPeers = ledgerPeersScript , naPeerTargets = peerTargets @@ -1001,7 +1000,7 @@ ppDiffusionTestTrace (DiffusionInboundGovernorTransitionTrace tr) = show tr ppDiffusionTestTrace (DiffusionServerTrace tr) = show tr ppDiffusionTestTrace (DiffusionFetchTrace tr) = show tr ppDiffusionTestTrace (DiffusionChurnModeTrace tr) = show tr -ppDiffusionTestTrace (DiffusionTxSubmissionInbound (TestAddress peer) tr) = prettyShow peer ++ " " ++ show tr +ppDiffusionTestTrace (DiffusionTxSubmissionInbound peer tr) = prettyShow peer ++ " " ++ show tr ppDiffusionTestTrace (DiffusionTxLogic tr) = show tr ppDiffusionTestTrace (DiffusionDebugTrace tr) = tr ppDiffusionTestTrace (DiffusionDNSTrace tr) = show tr @@ -1071,15 +1070,13 @@ diffusionSimulationM -- TODO: we should use `snocket` per node, this will allow us to set up -- bearer info per node withSnocket netSimTracer defaultBearerInfo Map.empty - $ \ntnSnocket _ -> - withSnocket nullTracer defaultBearerInfo Map.empty - $ \ntcSnocket _ -> do + $ \snocket _ -> do dnsMapVar <- fromLazyTVar <$> playTimedScript nullTracer dnsMapScript withAsyncAll (zipWith (\(args, commands) nodeId -> do labelThisThread ("ctrl-" ++ show nodeId) - runCommand ntnSnocket ntcSnocket dnsMapVar simArgs args connStateIdSupply nodeId Nothing commands) + runCommand snocket dnsMapVar simArgs args connStateIdSupply nodeId Nothing commands) nodeArgs [NodeId 1..] ) @@ -1088,16 +1085,14 @@ diffusionSimulationM return x ) where - netSimTracer :: Tracer m (WithAddr NtNAddr (SnocketTrace m NtNAddr)) - netSimTracer = (\(WithAddr l _ a) -> WithName (fromMaybe (TestAddress $ IPAddr (read "0.0.0.0") 0) l) (show a)) + netSimTracer :: Tracer m (WithAddr (SnocketTrace m)) + netSimTracer = (\(WithAddr l _ a) -> WithName (fromMaybe (Node.IPAddr (read "0.0.0.0") 0) l) (show a)) `contramap` tracerWithTime nullTracer -- | Runs a single node according to a list of commands. runCommand - :: Snocket m (FD m NtNAddr) NtNAddr - -- ^ Node to node Snocket - -> Snocket m (FD m NtCAddr) NtCAddr - -- ^ Node to client Snocket + :: Snocket m (FD m) Node.NetworkAddress + -- ^ snocket -> StrictTVar m MockDNSMap -- ^ Map of domain map TVars to be updated in case a node changes its IP -> SimArgs -- ^ Simulation arguments needed in order to run a simulation @@ -1113,7 +1108,7 @@ diffusionSimulationM -- TVar. -> [Command] -- ^ List of commands/actions to perform for a single node -> m Void - runCommand ntnSocket ntcSocket dnsMapVar sArgs nArgs@NodeArgs { naAddr, naConsensusMode } + runCommand snocket dnsMapVar sArgs nArgs@NodeArgs { naAddr, naConsensusMode } connStateIdSupply nodeId hostAndLRP cmds = do traceWith (diffSimTracer naAddr) . TrSay $ show nodeId ++ "@" ++ prettyShow naAddr runCommand' hostAndLRP cmds @@ -1134,7 +1129,7 @@ diffusionSimulationM threadDelay delay traceWith (diffSimTracer naAddr) (TrJoiningNetwork naConsensusMode) lrpVar <- newTVarIO $ naLocalRootPeers nArgs - withAsync (runNode sArgs nArgs ntnSocket ntcSocket connStateIdSupply lrpVar dnsMapVar nodeId) $ \nodeAsync -> + withAsync (runNode sArgs nArgs snocket connStateIdSupply lrpVar dnsMapVar nodeId) $ \nodeAsync -> runCommand' (Just (nodeAsync, lrpVar)) cs runCommand' _ (JoinNetwork _:_) = error "runCommand: Impossible happened" @@ -1160,8 +1155,7 @@ diffusionSimulationM runNode :: SimArgs -> NodeArgs - -> Snocket m (FD m NtNAddr) NtNAddr - -> Snocket m (FD m NtCAddr) NtCAddr + -> Snocket m (FD m) Node.NetworkAddress -> CM.ConnStateIdSupply m -> StrictTVar m [( HotValency , WarmValency @@ -1192,8 +1186,7 @@ diffusionSimulationM , naTxs = txs , naTxImpairment = txImpairment } - ntnSnocket - ntcSnocket + snocket connStateIdSupply lrpVar dMapVar @@ -1259,11 +1252,10 @@ diffusionSimulationM interfaces :: Node.Interfaces (Cardano.LedgerPeersConsensusInterface m) m interfaces = Node.Interfaces - { Node.iNtnSnocket = ntnSnocket + { Node.iSnocket = snocket , Node.iNtnBearer = makeFDBearer , Node.iAcceptVersion = acceptVersion , Node.iNtnDomainResolver = domainResolver dMapVar - , Node.iNtcSnocket = ntcSnocket , Node.iNtcBearer = makeFDBearer , Node.iRng = rng , Node.iDomainMap = dMapVar @@ -1445,7 +1437,7 @@ diffusionSimulationM let mapDomains :: [(DomainAccessPoint, Set NtNAddr)] mapDomains = [ ( dap - , Set.fromList [ TestAddress (IPAddr a p) | (a, p) <- addrs ] + , Set.fromList [ Node.IPAddr a p | (a, p) <- addrs ] ) | dap <- daps , let addrs = case dap of diff --git a/ouroboros-network/changelog.d/20260803_173319_coot_diffusion_addresses.md b/ouroboros-network/changelog.d/20260803_173319_coot_diffusion_addresses.md new file mode 100644 index 00000000000..30da650264a --- /dev/null +++ b/ouroboros-network/changelog.d/20260803_173319_coot_diffusion_addresses.md @@ -0,0 +1,27 @@ + + +### Breaking + +- `Ouroboros.Network.Diffusion.Configuration` now has a single `dcAddresses :: + [Either ntnFd ntnAddr]` field, instead of the two `dcIPv[46]Address`. This + allows us to support multiple interfaces. Use + `Ouroboros.Network.Diffusion.readIPAddressAndPort` to parse `IP:Port` pari + from a command line. + + + diff --git a/ouroboros-network/changelog.d/20260806_164125_coot_multiple_interfaces.md b/ouroboros-network/changelog.d/20260806_164125_coot_multiple_interfaces.md new file mode 100644 index 00000000000..c5ee4f59f6c --- /dev/null +++ b/ouroboros-network/changelog.d/20260806_164125_coot_multiple_interfaces.md @@ -0,0 +1,23 @@ + + +### Breaking + +- Removed `addressType` API from `ConnectionManager.Arguments` and thus from `Diffusion.Interfaces`, we use `Snocket.addrFamily` instead. + + + diff --git a/ouroboros-network/changelog.d/20260806_164635_coot_multiple_interfaces.md b/ouroboros-network/changelog.d/20260806_164635_coot_multiple_interfaces.md new file mode 100644 index 00000000000..5b92dbfe732 --- /dev/null +++ b/ouroboros-network/changelog.d/20260806_164635_coot_multiple_interfaces.md @@ -0,0 +1,27 @@ + + +### Breaking + +- `Snocket`'s `addrFamily` API change + * Simplified `AddressFamily` data type, now it's a simple enumerationo of `AFInet`, `AFInet6` and `AFLocal`, removed `TestFamily`. +- The `Simulation.Netork.Snocket` is now monomorphic over address type, e.g. + `NetworkAddress` (brought from diffusion testnet), which simplifies test + cases. This makes the API easier to use in tests. + + + diff --git a/ouroboros-network/demo/connection-manager.hs b/ouroboros-network/demo/connection-manager.hs index fb80bd5437c..22250f137d1 100644 --- a/ouroboros-network/demo/connection-manager.hs +++ b/ouroboros-network/demo/connection-manager.hs @@ -198,7 +198,7 @@ withBidirectionalConnectionManager -> CM.ConnStateIdSupply m -> DiffTime -- protocol idle timeout -> DiffTime -- wait time timeout - -> Maybe peerAddr + -> [peerAddr] -> Random.StdGen -> ClientAndServerData -- ^ series of request possible to do with the bidirectional connection @@ -214,7 +214,7 @@ withBidirectionalConnectionManager snocket makeBearer socket connStateIdSupply protocolIdleTimeout timeWaitTimeout - localAddress + localAddresses stdGen ClientAndServerData { hotInitiatorRequests, @@ -261,9 +261,8 @@ withBidirectionalConnectionManager snocket makeBearer socket -- ConnectionManagerTrace tracer = ("cm",) `contramap` debugTracer, trTracer = ("cm-state",) `contramap` debugTracer, - ipv4Address = localAddress, - ipv6Address = Nothing, - addressType = \_ -> Just IPv4Address, + ipv4Address = localAddresses, + ipv6Address = [], snocket = snocket, makeBearer = makeBearer, CM.withBuffer = \f -> f Nothing, @@ -488,7 +487,7 @@ bidirectionalExperiment withBidirectionalConnectionManager snocket makeBearer socket0 connStateIdSupply protocolIdleTimeout timeWaitTimeout - (Just localAddr) stdGen clientAndServerData $ + [localAddr] stdGen clientAndServerData $ \connectionManager _serverAddr _inbGovAsync -> forever' $ do -- runInitiatorProtocols returns a list of results per each protocol -- in each bucket (warm \/ hot \/ established); but we run only one diff --git a/ouroboros-network/framework/io-tests/Test/Ouroboros/Network/Socket.hs b/ouroboros-network/framework/io-tests/Test/Ouroboros/Network/Socket.hs index f56d5025003..af12a446660 100644 --- a/ouroboros-network/framework/io-tests/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network/framework/io-tests/Test/Ouroboros/Network/Socket.hs @@ -331,7 +331,7 @@ prop_socket_recv_error f rerr = snocket = socketSnocket iomgr bracket - (open snocket (SocketFamily Socket.AF_INET)) + (open snocket AFInet) (close snocket) $ \sd -> do -- bind the socket @@ -436,7 +436,7 @@ prop_socket_send_error rerr = snocket = socketSnocket iomgr bracket - (open snocket (SocketFamily Socket.AF_INET)) + (open snocket AFInet) (close snocket) $ \sd -> do -- bind the socket diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionManager/Core.hs b/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionManager/Core.hs index 8fd696c052e..62827fc354c 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionManager/Core.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionManager/Core.hs @@ -95,16 +95,14 @@ data Arguments handlerTrace socket peerAddr handle handleError versionNumber ver -- bidirectional @TCP@ connections, it must be the same as the server -- listening @IPv4@ address. -- - ipv4Address :: Maybe peerAddr, + ipv4Address :: [peerAddr], -- | @IPv6@ address of the connection manager. If given, outbound -- connections to an @IPv6@ address will bound to it. To use -- bidirectional @TCP@ connections, it must be the same as the server -- listening @IPv6@ address. -- - ipv6Address :: Maybe peerAddr, - - addressType :: peerAddr -> Maybe AddressType, + ipv6Address :: [peerAddr], -- | Snocket for the 'socket' type. -- @@ -395,7 +393,6 @@ with args@Arguments { trTracer, ipv4Address, ipv6Address, - addressType, snocket, makeBearer, withBuffer, @@ -1470,24 +1467,24 @@ with args@Arguments { ) $ \socket -> do traceWith tracer (TrConnectionNotFound provenance peerAddr) - let addr = case addressType peerAddr of - Nothing -> Nothing - Just IPv4Address -> ipv4Address - Just IPv6Address -> ipv6Address + addr <- case addrFamily snocket peerAddr of + AFInet -> randomElement stdGenVar ipv4Address + AFInet6 -> randomElement stdGenVar ipv6Address + AFLocal{} -> pure Nothing configureSocket socket addr -- only bind to the ip address if: -- the diffusion is given `ipv4/6` addresses; -- `diffusionMode` for this connection is -- `InitiatorAndResponderMode`. - case addressType peerAddr of - Just IPv4Address | InitiatorAndResponderDiffusionMode - <- diffusionMode -> - traverse_ (bind snocket socket) - ipv4Address - Just IPv6Address | InitiatorAndResponderDiffusionMode - <- diffusionMode -> - traverse_ (bind snocket socket) - ipv6Address + case addrFamily snocket peerAddr of + AFInet | InitiatorAndResponderDiffusionMode + <- diffusionMode -> + traverse_ (bind snocket socket) + ipv4Address + AFInet6 | InitiatorAndResponderDiffusionMode + <- diffusionMode -> + traverse_ (bind snocket socket) + ipv6Address _ -> pure () traceWith tracer (TrConnect addr peerAddr diffusionMode) @@ -2444,3 +2441,13 @@ data Trace peerAddr handlerTrace | TrUnexpectedlyFalseAssertion (AssertionLocation peerAddr) -- ^ This case is unexpected at call site. deriving Show + + +randomElement :: MonadSTM m + => StrictTVar m StdGen -> [a] -> m (Maybe a) +randomElement _ [] = pure Nothing +randomElement _ [a] = pure $ Just a +randomElement stdGenVar as = do + stdGen <- atomically $ stateTVar stdGenVar Random.splitGen + let (indx, _) = Random.uniformR (0, length as - 1) stdGen + return $ Just $ as List.!! indx diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionManager/Types.hs b/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionManager/Types.hs index 695f6aa723e..8e8960e940f 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionManager/Types.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/ConnectionManager/Types.hs @@ -90,8 +90,7 @@ module Ouroboros.Network.ConnectionManager.Types ( -- * Connection manager core types -- ** Connection Types - AddressType (..) - , Provenance (..) + Provenance (..) , DataFlow (..) , TimeoutExpired (..) , ConnectionType (..) @@ -189,12 +188,6 @@ import Ouroboros.Network.MuxMode import Ouroboros.Network.Util (PrettyShow (..)) --- | Connection manager supports `IPv4` and `IPv6` addresses. --- -data AddressType = IPv4Address | IPv6Address - deriving Show - - -- | Each connection is is either initiated locally (outbound) or by a remote -- peer (inbound). -- diff --git a/ouroboros-network/framework/lib/Ouroboros/Network/Snocket.hs b/ouroboros-network/framework/lib/Ouroboros/Network/Snocket.hs index 603fc67800f..ac04fcc5bb6 100644 --- a/ouroboros-network/framework/lib/Ouroboros/Network/Snocket.hs +++ b/ouroboros-network/framework/lib/Ouroboros/Network/Snocket.hs @@ -43,7 +43,6 @@ module Ouroboros.Network.Snocket , LocalAddress (..) , LocalConnectionId , localAddressFromPath - , TestAddress (..) , FileDescriptor , socketFileDescriptor , localSocketFileDescriptor @@ -51,6 +50,7 @@ module Ouroboros.Network.Snocket , invalidFileDescriptor -- * Re-exports , MakeBearer (..) + , Socket.Family (Socket.AF_INET, Socket.AF_INET6) ) where import Control.DeepSeq (NFData (..)) @@ -75,8 +75,6 @@ import "Win32-network" System.Win32.NamedPipes qualified as Win32.NamedPipes #endif #endif -import NoThunks.Class - import Network.Socket (SockAddr (..), Socket) import Network.Socket qualified as Socket @@ -226,19 +224,8 @@ instance PrettyShow LocalAddress where instance Hashable LocalAddress where hashWithSalt s (LocalAddress path) = hashWithSalt s path -newtype TestAddress addr = TestAddress { getTestAddress :: addr } - deriving (Eq, Ord, Generic, NFData) - deriving NoThunks via InspectHeap (TestAddress addr) - -instance Show addr => Show (TestAddress addr) where - showsPrec d (TestAddress addr) = showParen (d > app_prec) $ - showString "TestAddress " . showsPrec (app_prec+1) addr - where app_prec = 10 - -instance PrettyShow addr => PrettyShow (TestAddress addr) where - prettyShow (TestAddress addr) = prettyShow addr - -instance Hashable addr => Hashable (TestAddress addr) +instance NFData LocalAddress where + rnf (LocalAddress path) = rnf path type LocalConnectionId = ConnectionId LocalAddress @@ -251,21 +238,11 @@ type LocalConnectionId = ConnectionId LocalAddress -- 'LocalFamily' requires 'LocalAddress', this is needed to provide path of the -- opened Win32 'HANDLE'. -- -data AddressFamily addr where - - SocketFamily :: !Socket.Family - -> AddressFamily Socket.SockAddr - - LocalFamily :: !LocalAddress -> AddressFamily LocalAddress - - -- | Using a newtype wrapper 'TestAddress' makes pattern matches on - -- @AddressFamily@ complete, e.g. it makes 'AddressFamily' injective: - -- @AddressFamily addr == AddressFamily addr'@ then @addr == addr'@. . - -- - TestFamily :: AddressFamily (TestAddress addr) - -deriving instance Eq addr => Eq (AddressFamily addr) -deriving instance Show addr => Show (AddressFamily addr) +data AddressFamily + = AFInet + | AFInet6 + | AFLocal !LocalAddress + deriving (Eq, Show) -- | Abstract communication interface that can be used by more than @@ -292,7 +269,7 @@ data Snocket m fd addr = Snocket { -- | Get address family of an address. -- - , addrFamily :: addr -> AddressFamily addr + , addrFamily :: addr -> AddressFamily -- | Open a file descriptor (socket / namedPipe). -- @@ -300,7 +277,7 @@ data Snocket m fd addr = Snocket { -- -- /For named pipes:/ 'Win32.createNamedPipe' is used. -- - , open :: AddressFamily addr -> m fd + , open :: AddressFamily -> m fd -- | A way to create 'fd' to pass to 'connect'. -- @@ -347,10 +324,15 @@ data Snocket m fd addr = Snocket { -- -socketAddrFamily :: Socket.SockAddr -> AddressFamily Socket.SockAddr -socketAddrFamily Socket.SockAddrInet {} = SocketFamily Socket.AF_INET -socketAddrFamily Socket.SockAddrInet6 {} = SocketFamily Socket.AF_INET6 -socketAddrFamily Socket.SockAddrUnix {} = SocketFamily Socket.AF_UNIX +socketAddrFamily :: Socket.SockAddr -> AddressFamily +socketAddrFamily Socket.SockAddrInet {} = AFInet +socketAddrFamily Socket.SockAddrInet6 {} = AFInet6 +socketAddrFamily (Socket.SockAddrUnix file) = AFLocal (LocalAddress file) + +addressFamilyToFamily :: AddressFamily -> Socket.Family +addressFamilyToFamily AFInet = Socket.AF_INET +addressFamilyToFamily AFInet6 = Socket.AF_INET6 +addressFamilyToFamily AFLocal {} = Socket.AF_UNIX type SocketSnocket = Snocket IO Socket SockAddr @@ -391,9 +373,9 @@ socketSnocket ioManager = Snocket { , close = uninterruptibleMask_ . Socket.close } where - openSocket :: AddressFamily SockAddr -> IO Socket - openSocket (SocketFamily family_) = do - sd <- Socket.socket family_ Socket.Stream Socket.defaultProtocol + openSocket :: AddressFamily -> IO Socket + openSocket af = do + sd <- Socket.socket (addressFamilyToFamily af) Socket.Stream Socket.defaultProtocol associateWithIOManager ioManager (Right sd) -- open is designed to be used in `bracket`, and thus it's called with -- async exceptions masked. The 'associateWithIOCP' is a blocking @@ -571,7 +553,7 @@ localSnocket ioManager = Snocket { getLocalAddr = fmap toLocalAddress . Socket.getSocketName . getLocalHandle , getRemoteAddr = fmap toLocalAddress . Socket.getPeerName . getLocalHandle - , addrFamily = LocalFamily + , addrFamily = AFLocal , connect = \(LocalSocket s) addr -> Socket.connect s (fromLocalAddress addr) , bind = \(LocalSocket fd) addr -> Socket.bind fd (fromLocalAddress addr) @@ -580,7 +562,7 @@ localSnocket ioManager = . berkeleyAccept ioManager . getLocalHandle , open = openSocket - , openToConnect = openSocket . LocalFamily + , openToConnect = openSocket . AFLocal , close = uninterruptibleMask_ . Socket.close . getLocalHandle } where @@ -592,8 +574,8 @@ localSnocket ioManager = fromLocalAddress :: LocalAddress -> SockAddr fromLocalAddress = SockAddrUnix . getFilePath - openSocket :: AddressFamily LocalAddress -> IO LocalSocket - openSocket (LocalFamily _addr) = do + openSocket :: AddressFamily -> IO LocalSocket + openSocket (AFLocal _addr) = do sd <- Socket.socket Socket.AF_UNIX Socket.Stream Socket.defaultProtocol associateWithIOManager ioManager (Right sd) -- open is designed to be used in `bracket`, and thus it's called with @@ -606,6 +588,8 @@ localSnocket ioManager = Socket.close sd throwIO e return (LocalSocket sd) + openSocket af = + throwIO (userError $ "unsupported address family: " ++ show af) #endif localAddressFromPath :: FilePath -> LocalAddress diff --git a/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs b/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs index 71ca7ec9517..e1292687996 100644 --- a/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs +++ b/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/ConnectionManager.hs @@ -69,7 +69,7 @@ import Ouroboros.Network.InboundGovernor.InformationChannel qualified as InfoCha import Ouroboros.Network.MuxMode import Ouroboros.Network.Server.RateLimiting import Ouroboros.Network.Snocket (Accept (..), Accepted (..), - AddressFamily (TestFamily), Snocket (..), TestAddress (..)) + AddressFamily (..), Snocket (..)) import Ouroboros.Network.Util (PrettyShow (..)) import Test.Ouroboros.Network.ConnectionManager.Utils (verifyAbstractTransition) @@ -91,12 +91,15 @@ tests = -- | Address type. '0' indicates local address, the 'Arbitrary' generator only -- returns (strictly) positive addresses. -- -type Addr = TestAddress Int +newtype TestAddress = TestAddress { getTestAddress :: Int } + deriving (Eq, Enum, Num, Ord, Show) +type Addr = TestAddress +instance PrettyShow TestAddress where + prettyShow = show . getTestAddress -instance Arbitrary Addr where +instance Arbitrary TestAddress where arbitrary = - TestAddress <$> -- from one side we want a small address pool (this makes a greater -- chance of reusing a connection), but we also want to allow -- variability @@ -416,10 +419,10 @@ mkSnocket :: forall m. , MonadSTM m , MonadThrow (STM m) ) - => RefinedScheduleMap Addr + => RefinedScheduleMap TestAddress -- ^ we need the schedule to know how much time 'connect' will take -- and weather it errors or not. - -> m (Snocket m (FD m) Addr) + -> m (Snocket m (FD m) TestAddress) mkSnocket scheduleMap = do -- We keep track of outbound connections which will call 'connect' in -- a mutable TVar. @@ -466,7 +469,8 @@ mkSnocket scheduleMap = do Nothing -> throwIO InvalidArgumentError Just addr -> pure addr - addrFamily _ = TestFamily + addrFamily (TestAddress a) | odd a = AFInet + | otherwise = AFInet6 open _ = FD <$> @@ -725,10 +729,10 @@ prop_valid_transitions (Fixed rnd) (SkewedBool bindToLocalAddress) scheduleMap = in counterexample ("\nTransition Trace\n" ++ (intercalate "\n" . map show $ cmTrace)) (verifyTrace cmTrace) where - myAddress :: Maybe Addr + myAddress :: [Addr] myAddress = if bindToLocalAddress - then Just (TestAddress 0) - else Nothing + then [TestAddress 0] + else [] verifyTrace :: [TestAbstractTransitionTrace] -> Property verifyTrace = conjoin @@ -771,8 +775,7 @@ prop_valid_transitions (Fixed rnd) (SkewedBool bindToLocalAddress) scheduleMap = tracer, trTracer, ipv4Address = myAddress, - ipv6Address = Nothing, - addressType = \_ -> Just IPv4Address, + ipv6Address = [], snocket = snocket, makeBearer = makeFDBearer, withBuffer = \f -> f Nothing, @@ -795,7 +798,7 @@ prop_valid_transitions (Fixed rnd) (SkewedBool bindToLocalAddress) scheduleMap = $ \(connectionManager :: ConnectionManager Mx.InitiatorResponderMode (FD (IOSim s)) Addr (Handle m) Void (IOSim s)) -> do - fd <- open snocket TestFamily + fd <- open snocket AFInet traverse_ (bind snocket fd) myAddress let go :: HasCallStack diff --git a/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs b/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs index 3317811817e..e4178bf6b71 100644 --- a/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs +++ b/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/RawBearer.hs @@ -10,7 +10,6 @@ import Control.Monad.Class.MonadSay import Control.Monad.IOSim hiding (liftST) import Control.Tracer (Tracer, mkTracer, nullTracer) -import Ouroboros.Network.Snocket import Simulation.Network.Snocket as SimSnocket import Test.Ouroboros.Network.Data.AbsBearerInfo @@ -34,7 +33,7 @@ onlyIf :: Bool -> a -> Maybe a onlyIf False = const Nothing onlyIf True = Just -prop_raw_bearer_send_and_receive_iosim :: Int -> Int -> Message -> Property +prop_raw_bearer_send_and_receive_iosim :: Natural -> Natural -> Message -> Property prop_raw_bearer_send_and_receive_iosim serverInt clientInt msg = iosimProperty $ SimSnocket.withSnocket @@ -45,8 +44,8 @@ prop_raw_bearer_send_and_receive_iosim serverInt clientInt msg = iosimTracer snocket (makeFDRawBearer nullTracer) - (TestAddress serverInt) - (Just $ TestAddress clientInt) + (EphIPv4Addr serverInt) + (Just $ EphIPv4Addr clientInt) msg diff --git a/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs b/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs index ad65e8a8bce..19208786286 100644 --- a/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs +++ b/ouroboros-network/framework/sim-tests/Test/Ouroboros/Network/Server/Sim.hs @@ -97,7 +97,7 @@ import Ouroboros.Network.Protocol.Handshake.Unversioned import Ouroboros.Network.Server (RemoteTransitionTrace) import Ouroboros.Network.Server qualified as Server import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) -import Ouroboros.Network.Snocket (Snocket, TestAddress (..)) +import Ouroboros.Network.Snocket (Snocket) import Ouroboros.Network.Snocket qualified as Snocket import Ouroboros.Network.Util (PrettyShow (..)) @@ -160,7 +160,6 @@ tests = ] ] - -- -- Server tests -- @@ -174,13 +173,14 @@ prop_unidirectional_Sim (Fixed rnd) clientAndServerData = noAttenuation Map.empty $ \snock _ -> - bracket (Snocket.open snock Snocket.TestFamily) + bracket (Snocket.open snock Snocket.AFInet) (Snocket.close snock) $ \fd -> do Snocket.bind snock fd serverAddr Snocket.listen snock fd unidirectionalExperiment (mkStdGen rnd) simTimeouts snock makeFDBearer mempty fd clientAndServerData where - serverAddr = Snocket.TestAddress (0 :: Int) + serverAddr :: NetworkAddress + serverAddr = EphIPv4Addr 0 prop_bidirectional_Sim :: Fixed Int -> ClientAndServerData Int @@ -192,13 +192,13 @@ prop_bidirectional_Sim (Fixed rnd) data0 data1 = noAttenuation Map.empty $ \snock _ -> - bracket ((,) <$> Snocket.open snock Snocket.TestFamily - <*> Snocket.open snock Snocket.TestFamily) + bracket ((,) <$> Snocket.open snock Snocket.AFInet + <*> Snocket.open snock Snocket.AFInet) (\ (socket0, socket1) -> Snocket.close snock socket0 >> Snocket.close snock socket1) $ \ (socket0, socket1) -> do - let addr0 = Snocket.TestAddress (0 :: Int) - addr1 = Snocket.TestAddress 1 + let addr0 = EphIPv4Addr 0 + addr1 = EphIPv4Addr 1 Snocket.bind snock socket0 addr0 Snocket.bind snock socket1 addr1 Snocket.listen snock socket0 @@ -217,31 +217,31 @@ prop_bidirectional_Sim (Fixed rnd) data0 data1 = -- | A test case for the multi-node property contains a sequence of connection -- events. The `DiffTime` in each constructor is relative to the previous event -- in the sequence. -data ConnectionEvent req peerAddr - = StartClient DiffTime peerAddr +data ConnectionEvent req + = StartClient DiffTime NetworkAddress -- ^ Start a new client at the given address - | StartServer DiffTime peerAddr req + | StartServer DiffTime NetworkAddress req -- ^ Start a new server at the given address - | InboundConnection DiffTime peerAddr + | InboundConnection DiffTime NetworkAddress -- ^ Create a connection from client or server with the given address to the central server. - | OutboundConnection DiffTime peerAddr + | OutboundConnection DiffTime NetworkAddress -- ^ Create a connection from the central server to another server. - | InboundMiniprotocols DiffTime peerAddr (TemperatureBundle [req]) + | InboundMiniprotocols DiffTime NetworkAddress (TemperatureBundle [req]) -- ^ Run a bundle of mini protocols on the inbound connection from the given address. - | OutboundMiniprotocols DiffTime peerAddr (TemperatureBundle [req]) + | OutboundMiniprotocols DiffTime NetworkAddress (TemperatureBundle [req]) -- ^ Run a bundle of mini protocols on the outbound connection to the given address. - | CloseInboundConnection DiffTime peerAddr + | CloseInboundConnection DiffTime NetworkAddress -- ^ Close an inbound connection. - | CloseOutboundConnection DiffTime peerAddr + | CloseOutboundConnection DiffTime NetworkAddress -- ^ Close an outbound connection. - | ShutdownClientServer DiffTime peerAddr + | ShutdownClientServer DiffTime NetworkAddress -- ^ Shuts down a client/server (simulates power loss) deriving (Eq, Show, Functor) -- | A sequence of connection events that make up a test scenario for `prop_multinode_Sim`. -data MultiNodeScript req peerAddr = MultiNodeScript - { mnsEvents :: [ConnectionEvent req peerAddr] - , mnsAttenuationMap :: Map peerAddr +data MultiNodeScript req = MultiNodeScript + { mnsEvents :: [ConnectionEvent req] + , mnsAttenuationMap :: Map NetworkAddress (Script AbsBearerInfo) } deriving (Show) @@ -252,8 +252,8 @@ data MultiNodePruningScript req = MultiNodePruningScript { mnpsAcceptedConnLimit :: AcceptedConnectionsLimit -- ^ Should yield small values to trigger pruning -- more often - , mnpsEvents :: [ConnectionEvent req TestAddr] - , mnpsAttenuationMap :: Map TestAddr + , mnpsEvents :: [ConnectionEvent req] + , mnpsAttenuationMap :: Map NetworkAddress (Script AbsBearerInfo) } deriving Show @@ -265,14 +265,14 @@ data MultiNodePruningScript req = MultiNodePruningScript -- there's already a `Unidirectional` inbound connection (i.e. -- a `ForbiddenOperation`). -- -data ScriptState peerAddr = ScriptState { startedClients :: [peerAddr] - , startedServers :: [peerAddr] - , clientConnections :: [peerAddr] - , inboundConnections :: [peerAddr] - , outboundConnections :: [peerAddr] } +data ScriptState = ScriptState { startedClients :: [NetworkAddress] + , startedServers :: [NetworkAddress] + , clientConnections :: [NetworkAddress] + , inboundConnections :: [NetworkAddress] + , outboundConnections :: [NetworkAddress] } -- | Update the state after a connection event. -nextState :: Eq peerAddr => ConnectionEvent req peerAddr -> ScriptState peerAddr -> ScriptState peerAddr +nextState :: ConnectionEvent req -> ScriptState -> ScriptState nextState e s@ScriptState{..} = case e of StartClient _ a -> s{ startedClients = a : startedClients } @@ -287,7 +287,7 @@ nextState e s@ScriptState{..} = , startedServers = delete a startedServers } -- | Check if an event makes sense in a given state. -isValidEvent :: Eq peerAddr => ConnectionEvent req peerAddr -> ScriptState peerAddr -> Bool +isValidEvent :: ConnectionEvent req -> ScriptState -> Bool isValidEvent e ScriptState{..} = case e of StartClient _ a -> notElem a (startedClients ++ startedServers) @@ -310,9 +310,8 @@ shrinkBundle (TemperatureBundle (WithHot hot) (WithWarm warm) (WithEstablished e (shrink warm <&> \ warm' -> TemperatureBundle (WithHot hot) (WithWarm warm') (WithEstablished est)) ++ (shrink est <&> \ est' -> TemperatureBundle (WithHot hot) (WithWarm warm) (WithEstablished est')) -genAttenuationMap :: Ord peerAddr - => [ConnectionEvent req peerAddr] - -> Gen (Map peerAddr (Script AbsBearerInfo)) +genAttenuationMap :: [ConnectionEvent req] + -> Gen (Map NetworkAddress (Script AbsBearerInfo)) genAttenuationMap events = do let nodes = map (\ case @@ -340,8 +339,8 @@ genAttenuationMap events = do return (Map.fromList attenuationMap) -instance (Arbitrary peerAddr, Arbitrary req, Ord peerAddr) => - Arbitrary (MultiNodeScript req peerAddr) where +instance Arbitrary req + => Arbitrary (MultiNodeScript req) where arbitrary = do Positive len <- scale ((* 2) . (`div` 3)) arbitrary events <- go (ScriptState [] [] [] [] []) (len :: Integer) @@ -403,7 +402,7 @@ instance (Arbitrary peerAddr, Arbitrary req, Ord peerAddr) => shrinkEvent (ShutdownClientServer d a) = shrinkDelay d <&> \ d' -> ShutdownClientServer d' a -prop_generator_MultiNodeScript :: MultiNodeScript Int TestAddr -> Property +prop_generator_MultiNodeScript :: MultiNodeScript Int -> Property prop_generator_MultiNodeScript (MultiNodeScript script _) = label ("Number of events: " ++ within_ 10 (length script)) $ label ( "Number of servers: " @@ -589,24 +588,24 @@ instance (Eq req, Arbitrary req) => shrinkDelay d <&> \ d' -> ShutdownClientServer d' a -- | Each node in the multi-node experiment is controlled by a thread responding to these messages. -data ConnectionHandlerMessage peerAddr req - = NewConnection peerAddr +data ConnectionHandlerMessage req + = NewConnection NetworkAddress -- ^ Connect to the server at the given address. - | Disconnect peerAddr + | Disconnect NetworkAddress -- ^ Disconnect from the server at the given address. - | RunMiniProtocols peerAddr (TemperatureBundle [req]) + | RunMiniProtocols NetworkAddress (TemperatureBundle [req]) -- ^ Run a bundle of mini protocols against the server at the given address (requires an active -- connection). | Shutdown -- ^ Shutdowns a server at the given address -data Name addr = Client addr - | Node addr - | MainServer +data Name = Client NetworkAddress + | Node NetworkAddress + | MainServer deriving (Eq, Show) -instance PrettyShow addr => PrettyShow (Name addr) where +instance PrettyShow Name where prettyShow (Client addr) = "client-" ++ prettyShow addr prettyShow (Node addr) = "node-" ++ prettyShow addr prettyShow MainServer = "main-server" @@ -622,7 +621,7 @@ instance Exception ExperimentError where -- | Run a central server that talks to any number of clients and other nodes. multinodeExperiment - :: forall peerAddr socket acc req resp m. + :: forall acc req resp m. ( ConnectionManagerMonad m , MonadAsync m , MonadDelay m @@ -631,39 +630,35 @@ multinodeExperiment , MonadTraceSTM m , MonadSay m , acc ~ [req], resp ~ [req] - , Ord peerAddr - , PrettyShow peerAddr - , Typeable peerAddr - , Eq peerAddr , Serialise req , Show req , NFData req , Serialise resp, Show resp, Eq resp , Typeable req, Typeable resp ) - => Tracer m (WithName (Name peerAddr) - (RemoteTransitionTrace peerAddr)) - -> Tracer m (WithName (Name peerAddr) + => Tracer m (WithName Name + (RemoteTransitionTrace NetworkAddress)) + -> Tracer m (WithName Name (AbstractTransitionTrace CM.ConnStateId)) - -> Tracer m (WithName (Name peerAddr) - (IG.Trace peerAddr)) - -> Tracer m (WithName (Name peerAddr) - (IG.Debug peerAddr DataFlowProtocolData)) - -> Tracer m (WithName (Name peerAddr) + -> Tracer m (WithName Name + (IG.Trace NetworkAddress)) + -> Tracer m (WithName Name + (IG.Debug NetworkAddress DataFlowProtocolData)) + -> Tracer m (WithName Name (CM.Trace - peerAddr + NetworkAddress (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData))) - -> Mux.Tracers' m (WithNameAndBearer (Name peerAddr) peerAddr) + -> Mux.Tracers' m (WithNameAndBearer Name NetworkAddress) -> StdGen - -> Snocket m socket peerAddr - -> Mux.MakeBearer m socket - -> Snocket.AddressFamily peerAddr + -> Snocket m (FD m) NetworkAddress + -> Mux.MakeBearer m (FD m) + -> Snocket.AddressFamily -- ^ either run the main node in 'Duplex' or 'Unidirectional' mode. - -> peerAddr + -> NetworkAddress -> req -> DataFlow -> AcceptedConnectionsLimit - -> MultiNodeScript req peerAddr + -> MultiNodeScript req -> m () multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer muxTracers stdGen0 snocket makeBearer addrFamily serverAddr accInit @@ -678,9 +673,9 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer loop :: StrictTVar m StdGen -> CM.ConnStateIdSupply m - -> Map.Map peerAddr acc - -> Map.Map peerAddr (StrictTQueue m (ConnectionHandlerMessage peerAddr req)) - -> [ConnectionEvent req peerAddr] + -> Map.Map NetworkAddress acc + -> Map.Map NetworkAddress (StrictTQueue m (ConnectionHandlerMessage req)) + -> [ConnectionEvent req] -> JobPool () m () -> m () loop _ _ _ _ [] _ = threadDelay 3600 @@ -732,17 +727,17 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer sendMsg nodeAddr Shutdown loop stdGenVar connStateIdSupply nodeAccs servers events jobpool where - sendMsg :: peerAddr -> ConnectionHandlerMessage peerAddr req -> m () + sendMsg :: NetworkAddress -> ConnectionHandlerMessage req -> m () sendMsg addr msg = atomically $ case Map.lookup addr servers of Nothing -> throwIO (NodeNotRunningException addr) Just cc -> writeTQueue cc msg - mkNextRequests :: StrictTVar m (Map.Map (ConnectionId peerAddr) (TemperatureBundle (StrictTQueue m [req]))) -> - TemperatureBundle (ConnectionId peerAddr -> STM m [req]) + mkNextRequests :: StrictTVar m (Map.Map (ConnectionId NetworkAddress) (TemperatureBundle (StrictTQueue m [req]))) -> + TemperatureBundle (ConnectionId NetworkAddress -> STM m [req]) mkNextRequests connVar = makeBundle next where - next :: forall pt. SingProtocolTemperature pt -> ConnectionId peerAddr -> STM m [req] + next :: forall pt. SingProtocolTemperature pt -> ConnectionId NetworkAddress -> STM m [req] next tok connId = do connMap <- readTVar connVar case Map.lookup connId connMap of @@ -751,10 +746,10 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer startClientConnectionHandler :: StrictTVar m StdGen -> CM.ConnStateIdSupply m - -> Name peerAddr - -> peerAddr + -> Name + -> NetworkAddress -> JobPool () m () - -> m (StrictTQueue m (ConnectionHandlerMessage peerAddr req)) + -> m (StrictTQueue m (ConnectionHandlerMessage req)) startClientConnectionHandler stdGenVar connStateIdSupply name localAddr jobpool = do cc <- atomically newTQueue labelTQueueIO cc $ "cc/" ++ show name @@ -767,7 +762,7 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer ( withInitiatorOnlyConnectionManager name simTimeouts nullTracer cmTracer stdGen snocket makeBearer connStateIdSupply - (Just localAddr) (mkNextRequests connVar) + [localAddr] (mkNextRequests connVar) timeLimitsHandshake acceptedConnLimit ( \ connectionManager -> connectionLoop SingInitiatorMode localAddr cc connectionManager Map.empty connVar @@ -780,12 +775,12 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer startServerConnectionHandler :: StrictTVar m StdGen -> CM.ConnStateIdSupply m - -> Name peerAddr + -> Name -> DataFlow -> acc - -> peerAddr + -> NetworkAddress -> JobPool () m () - -> m (StrictTQueue m (ConnectionHandlerMessage peerAddr req)) + -> m (StrictTQueue m (ConnectionHandlerMessage req)) startServerConnectionHandler stdGenVar connStateIdSupply name dataFlow serverAcc localAddr jobpool = do fd <- Snocket.open snocket addrFamily Snocket.bind snocket fd localAddr @@ -805,7 +800,7 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer inboundTracer muxTracers debugTracer stdGen snocket makeBearer connStateIdSupply - (\_ -> pure ()) fd (Just localAddr) serverAcc + (\_ -> pure ()) fd [localAddr] serverAcc (mkNextRequests connVar) timeLimitsHandshake acceptedConnLimit @@ -823,7 +818,7 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer Unidirectional -> Job ( withInitiatorOnlyConnectionManager name simTimeouts trTracer cmTracer stdGen snocket makeBearer - connStateIdSupply (Just localAddr) + connStateIdSupply [localAddr] (mkNextRequests connVar) timeLimitsHandshake acceptedConnLimit @@ -867,18 +862,18 @@ multinodeExperiment inboundTrTracer trTracer inboundTracer debugTracer cmTracer :: forall muxMode a. (HasInitiator muxMode ~ True) => SingMuxMode muxMode - -> peerAddr - -> StrictTQueue m (ConnectionHandlerMessage peerAddr req) + -> NetworkAddress + -> StrictTQueue m (ConnectionHandlerMessage req) -- ^ control channel - -> ConnectionManagerWithExpandedCtx muxMode socket peerAddr () DataFlowProtocolData UnversionedProtocol ByteString m [resp] a - -> Map.Map peerAddr (HandleWithExpandedCtx muxMode peerAddr () DataFlowProtocolData ByteString m [resp] a) + -> ConnectionManagerWithExpandedCtx muxMode (FD m) NetworkAddress () DataFlowProtocolData UnversionedProtocol ByteString m [resp] a + -> Map.Map NetworkAddress (HandleWithExpandedCtx muxMode NetworkAddress () DataFlowProtocolData ByteString m [resp] a) -- ^ active connections - -> StrictTVar m (Map.Map (ConnectionId peerAddr) (TemperatureBundle (StrictTQueue m [req]))) + -> StrictTVar m (Map.Map (ConnectionId NetworkAddress) (TemperatureBundle (StrictTQueue m [req]))) -- ^ mini protocol queues -> m () connectionLoop muxMode localAddr cc cm connMap0 connVar = go connMap0 where - go :: Map.Map peerAddr (HandleWithExpandedCtx muxMode peerAddr () DataFlowProtocolData ByteString m [resp] a) -- active connections + go :: Map.Map NetworkAddress (HandleWithExpandedCtx muxMode NetworkAddress () DataFlowProtocolData ByteString m [resp] a) -- active connections -> m () go !connMap = atomically (readTQueue cc) >>= \ case NewConnection remoteAddr -> do @@ -962,7 +957,7 @@ data Three a b c | Third c deriving Show -validate_transitions :: MultiNodeScript Int TestAddr +validate_transitions :: MultiNodeScript Int -> SimTrace () -> Property validate_transitions mns@(MultiNodeScript events _) trace = @@ -1009,20 +1004,20 @@ validate_transitions mns@(MultiNodeScript events _) trace = $ evs where -- abstractTransitionEvents :: Trace (SimResult ()) - -- (AbstractTransitionTrace SimAddr) + -- (AbstractTransitionTrace NetworkAddress) -- abstractTransitionEvents = traceWithNameTraceEvents trace - evs :: Trace (SimResult ()) (Either (AbstractTransitionTrace SimAddr) - (CM.Trace SimAddr (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData))) + evs :: Trace (SimResult ()) (Either (AbstractTransitionTrace NetworkAddress) + (CM.Trace NetworkAddress (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData))) evs = fmap (bimap wnEvent wnEvent) . Trace.filter ((MainServer ==) . either wnName wnName) . traceSelectTraceEvents fn $ trace where fn :: Time -> SimEventType - -> Maybe (Either (WithName (Name SimAddr) (AbstractTransitionTrace SimAddr)) - (WithName (Name SimAddr) (CM.Trace SimAddr - (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData)))) + -> Maybe (Either (WithName Name (AbstractTransitionTrace NetworkAddress)) + (WithName Name (CM.Trace NetworkAddress + (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData)))) fn _ (EventLog dyn) = Left <$> fromDynamic dyn <|> Right <$> fromDynamic dyn fn _ _ = Nothing @@ -1038,7 +1033,7 @@ prop_connection_manager_valid_transitions -> Int -> ArbDataFlow -> AbsBearerInfo - -> MultiNodeScript Int TestAddr + -> MultiNodeScript Int -> Property prop_connection_manager_valid_transitions (Fixed rnd) serverAcc (ArbDataFlow dataFlow) defaultBearerInfo @@ -1059,7 +1054,7 @@ prop_connection_manager_valid_transitions_racy -> Int -> ArbDataFlow -> AbsBearerInfo - -> MultiNodeScript Int TestAddr + -> MultiNodeScript Int -> Property prop_connection_manager_valid_transitions_racy (Fixed rnd) serverAcc (ArbDataFlow dataFlow) @@ -1085,7 +1080,7 @@ prop_connection_manager_transitions_coverage :: Fixed Int -> Int -> ArbDataFlow -> AbsBearerInfo - -> MultiNodeScript Int TestAddr + -> MultiNodeScript Int -> Property prop_connection_manager_transitions_coverage (Fixed rnd) serverAcc (ArbDataFlow dataFlow) @@ -1093,7 +1088,7 @@ prop_connection_manager_transitions_coverage (Fixed rnd) serverAcc (MultiNodeScript events attenuationMap) = let trace = runSimTrace sim - abstractTransitionEvents :: [AbstractTransitionTrace SimAddr] + abstractTransitionEvents :: [AbstractTransitionTrace NetworkAddress] abstractTransitionEvents = withNameTraceEvents trace transitionsSeen = nub [ tran | TransitionTrace _ tran <- abstractTransitionEvents] @@ -1119,7 +1114,7 @@ prop_connection_manager_no_invalid_traces :: Fixed Int -> Int -> ArbDataFlow -> AbsBearerInfo - -> MultiNodeScript Int TestAddr + -> MultiNodeScript Int -> Property prop_connection_manager_no_invalid_traces (Fixed rnd) serverAcc (ArbDataFlow dataFlow) defaultBearerInfo @@ -1129,7 +1124,7 @@ prop_connection_manager_no_invalid_traces (Fixed rnd) serverAcc (ArbDataFlow dat connectionManagerEvents :: Trace (SimResult ()) (CM.Trace - SimAddr + NetworkAddress (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData)) @@ -1172,7 +1167,7 @@ prop_connection_manager_valid_transition_order :: Fixed Int -> Int -> ArbDataFlow -> AbsBearerInfo - -> MultiNodeScript Int TestAddr + -> MultiNodeScript Int -> Property prop_connection_manager_valid_transition_order (Fixed rnd) serverAcc (ArbDataFlow dataFlow) defaultBearerInfo @@ -1182,7 +1177,7 @@ prop_connection_manager_valid_transition_order (Fixed rnd) serverAcc (ArbDataFlo let trace = runSimTrace sim abstractTransitionEvents :: Trace (SimResult ()) - (AbstractTransitionTrace SimAddr) + (AbstractTransitionTrace NetworkAddress) abstractTransitionEvents = traceWithNameTraceEvents trace in tabulate "ConnectionEvents" (map showConnectionEvents events) @@ -1211,7 +1206,7 @@ prop_connection_manager_valid_transition_order_racy :: Fixed Int -> Int -> ArbDataFlow -> AbsBearerInfo - -> MultiNodeScript Int TestAddr + -> MultiNodeScript Int -> Property prop_connection_manager_valid_transition_order_racy (Fixed rnd) serverAcc (ArbDataFlow dataFlow) defaultBearerInfo @@ -1222,7 +1217,7 @@ prop_connection_manager_valid_transition_order_racy (Fixed rnd) serverAcc (ArbDa (\a -> a { explorationReplay = Just ControlDefault }) sim $ \_ trace -> let abstractTransitionEvents :: Trace (SimResult ()) - (AbstractTransitionTrace SimAddr) + (AbstractTransitionTrace NetworkAddress) abstractTransitionEvents = traceWithNameTraceEvents trace in -- ppDebug trace @@ -1265,7 +1260,7 @@ prop_connection_manager_valid_transition_order_racy (Fixed rnd) serverAcc (ArbDa prop_connection_manager_counters :: Fixed Int -> Int -> ArbDataFlow - -> MultiNodeScript Int TestAddr + -> MultiNodeScript Int -> Property prop_connection_manager_counters (Fixed rnd) serverAcc (ArbDataFlow dataFlow) (MultiNodeScript events @@ -1274,14 +1269,14 @@ prop_connection_manager_counters (Fixed rnd) serverAcc (ArbDataFlow dataFlow) connectionManagerEvents :: Trace (SimResult ()) (CM.Trace - SimAddr + NetworkAddress (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData)) connectionManagerEvents = traceWithNameTraceEvents trace -- Needed for calculating a more accurate upper bound - networkEvents :: [ObservableNetworkState SimAddr] + networkEvents :: [ObservableNetworkState] networkEvents = selectTraceEventsDynamic trace upperBound = @@ -1311,8 +1306,8 @@ prop_connection_manager_counters (Fixed rnd) serverAcc (ArbDataFlow dataFlow) ) $ connectionManagerEvents where - serverAddress :: SimAddr - serverAddress = TestAddress 0 + serverAddress :: NetworkAddress + serverAddress = EphIPv4Addr 0 -- We count all connections as prunable because we do not have a better way -- to know what transitions will a given connection go through. We also @@ -1325,8 +1320,8 @@ prop_connection_manager_counters (Fixed rnd) serverAcc (ArbDataFlow dataFlow) -- Note that this is only valid in the case of no attenuation. -- multiNodeScriptToCounters :: DataFlow - -> [ConnectionEvent Int TestAddr] - -> [ObservableNetworkState SimAddr] + -> [ConnectionEvent Int] + -> [ObservableNetworkState] -> ConnectionManagerCounters multiNodeScriptToCounters df ces uss = let ifDuplex = bool 0 1 (df == Duplex) @@ -1456,14 +1451,14 @@ prop_connection_manager_counters (Fixed rnd) serverAcc (ArbDataFlow dataFlow) (mkStdGen rnd) snocket makeFDBearer - Snocket.TestFamily + Snocket.AFInet serverAddress serverAcc dataFlow maxAcceptedConnectionsLimit (MultiNodeScript - (fmap unTestAddr <$> events) - (Map.mapKeys unTestAddr attenuationMap) + events + attenuationMap ) ) case mb of @@ -1475,7 +1470,7 @@ prop_connection_manager_counters (Fixed rnd) serverAcc (ArbDataFlow dataFlow) -- -- Using type alias enforces an invariant between event tracer & event selector -- to trace / select the same type. -type TimedTransitionEvents = WithTime (WithName (Name SimAddr) (AbstractTransitionTrace CM.ConnStateId)) +type TimedTransitionEvents = WithTime (WithName Name (AbstractTransitionTrace CM.ConnStateId)) -- | Property wrapping `multinodeExperiment`. -- @@ -1489,7 +1484,7 @@ type TimedTransitionEvents = WithTime (WithName (Name SimAddr) (AbstractTransiti prop_timeouts_enforced :: Fixed Int -> Int -> ArbDataFlow - -> MultiNodeScript Int TestAddr + -> MultiNodeScript Int -> Property prop_timeouts_enforced (Fixed rnd) serverAcc (ArbDataFlow dataFlow) (MultiNodeScript events attenuationMap) = @@ -1551,7 +1546,7 @@ prop_inbound_governor_valid_transitions :: Fixed Int -> Int -> ArbDataFlow -> AbsBearerInfo - -> MultiNodeScript Int TestAddr + -> MultiNodeScript Int -> Property prop_inbound_governor_valid_transitions (Fixed rnd) serverAcc (ArbDataFlow dataFlow) defaultBearerInfo @@ -1561,7 +1556,7 @@ prop_inbound_governor_valid_transitions (Fixed rnd) serverAcc (ArbDataFlow dataF let trace = runSimTrace sim remoteTransitionTraceEvents :: Trace (SimResult ()) - (RemoteTransitionTrace SimAddr) + (RemoteTransitionTrace NetworkAddress) remoteTransitionTraceEvents = traceWithNameTraceEvents trace in tabulate "ConnectionEvents" (map showConnectionEvents events) @@ -1597,7 +1592,7 @@ prop_inbound_governor_no_unsupported_state :: Fixed Int -> Int -> ArbDataFlow -> AbsBearerInfo - -> MultiNodeScript Int TestAddr + -> MultiNodeScript Int -> Property prop_inbound_governor_no_unsupported_state (Fixed rnd) serverAcc (ArbDataFlow dataFlow) defaultBearerInfo @@ -1607,7 +1602,7 @@ prop_inbound_governor_no_unsupported_state (Fixed rnd) serverAcc (ArbDataFlow da let trace = runSimTrace sim inboundGovernorEvents :: Trace (SimResult ()) - (IG.Trace SimAddr) + (IG.Trace NetworkAddress) inboundGovernorEvents = traceWithNameTraceEvents trace in tabulate "ConnectionEvents" (map showConnectionEvents events) @@ -1654,7 +1649,7 @@ prop_inbound_governor_no_invalid_traces :: Fixed Int -> Int -> ArbDataFlow -> AbsBearerInfo - -> MultiNodeScript Int TestAddr + -> MultiNodeScript Int -> Property prop_inbound_governor_no_invalid_traces (Fixed rnd) serverAcc (ArbDataFlow dataFlow) defaultBearerInfo @@ -1662,7 +1657,7 @@ prop_inbound_governor_no_invalid_traces (Fixed rnd) serverAcc (ArbDataFlow dataF attenuationMap) = let trace = runSimTrace sim - inboundGovernorEvents :: Trace (SimResult ()) (IG.Trace SimAddr) + inboundGovernorEvents :: Trace (SimResult ()) (IG.Trace NetworkAddress) inboundGovernorEvents = traceWithNameTraceEvents trace in tabulate "ConnectionEvents" (map showConnectionEvents events) @@ -1702,7 +1697,7 @@ prop_inbound_governor_transitions_coverage :: Fixed Int -> Int -> ArbDataFlow -> AbsBearerInfo - -> MultiNodeScript Int TestAddr + -> MultiNodeScript Int -> Property prop_inbound_governor_transitions_coverage (Fixed rnd) serverAcc (ArbDataFlow dataFlow) @@ -1710,7 +1705,7 @@ prop_inbound_governor_transitions_coverage (Fixed rnd) serverAcc (MultiNodeScript events attenuationMap) = let trace = runSimTrace sim - remoteTransitionTraceEvents :: [RemoteTransitionTrace SimAddr] + remoteTransitionTraceEvents :: [RemoteTransitionTrace NetworkAddress] remoteTransitionTraceEvents = withNameTraceEvents trace transitionsSeen = nub [ tran @@ -1739,7 +1734,7 @@ prop_inbound_governor_valid_transition_order :: Fixed Int -> Int -> ArbDataFlow -> AbsBearerInfo - -> MultiNodeScript Int TestAddr + -> MultiNodeScript Int -> Property prop_inbound_governor_valid_transition_order (Fixed rnd) serverAcc (ArbDataFlow dataFlow) defaultBearerInfo @@ -1748,10 +1743,10 @@ prop_inbound_governor_valid_transition_order (Fixed rnd) serverAcc (ArbDataFlow attenuationMap) = let trace = runSimTrace sim - remoteTransitionTraceEvents :: Trace (SimResult ()) (RemoteTransitionTrace SimAddr) + remoteTransitionTraceEvents :: Trace (SimResult ()) (RemoteTransitionTrace NetworkAddress) remoteTransitionTraceEvents = traceWithNameTraceEvents trace - -- inboundGovernorEvents :: Trace (SimResult ()) (InboundGovernorTrace SimAddr) + -- inboundGovernorEvents :: Trace (SimResult ()) (InboundGovernorTrace NetworkAddress) -- inboundGovernorEvents = traceWithNameTraceEvents trace in tabulate "ConnectionEvents" (map showConnectionEvents events) @@ -1782,7 +1777,7 @@ prop_inbound_governor_valid_transition_order (Fixed rnd) serverAcc (ArbDataFlow prop_inbound_governor_counters :: Fixed Int -> Int -> ArbDataFlow - -> MultiNodeScript Int TestAddr + -> MultiNodeScript Int -> Property prop_inbound_governor_counters (Fixed rnd) serverAcc (ArbDataFlow dataFlow) mns@(MultiNodeScript @@ -1791,7 +1786,7 @@ prop_inbound_governor_counters (Fixed rnd) serverAcc (ArbDataFlow dataFlow) let trace = runSimTrace sim inboundGovernorEvents :: Trace (SimResult ()) - (IG.Trace SimAddr) + (IG.Trace NetworkAddress) inboundGovernorEvents = traceWithNameTraceEvents trace upperBound = multiNodeScriptToCounters events @@ -1829,10 +1824,10 @@ prop_inbound_governor_counters (Fixed rnd) serverAcc (ArbDataFlow dataFlow) -- inbound governor states of remote warm or remote hot connections. An -- upper bound is established because it is not possible to predict whether -- some failure will occur. - multiNodeScriptToCounters :: [ConnectionEvent Int TestAddr] + multiNodeScriptToCounters :: [ConnectionEvent Int] -> IG.Counters multiNodeScriptToCounters = - let taServerAcc = TestAddr (TestAddress 0) + let taServerAcc = EphIPv4Addr 0 in (\x -> let serverAccEntry = x Map.! taServerAcc @@ -1878,17 +1873,17 @@ prop_inbound_governor_state :: Fixed Int -> Int -> ArbDataFlow -> AbsBearerInfo - -> MultiNodeScript Int TestAddr + -> MultiNodeScript Int -> Property prop_inbound_governor_state (Fixed rnd) serverAcc (ArbDataFlow dataFlow) defaultBearerInfo mns@(MultiNodeScript events attenuationMap) = let trace = runSimTrace sim - evs :: Trace (SimResult ()) (IG.Debug SimAddr DataFlowProtocolData) + evs :: Trace (SimResult ()) (IG.Debug NetworkAddress DataFlowProtocolData) evs = traceWithNameTraceEvents trace - -- inboundGovernorEvents :: Trace (SimResult ()) (InboundGovernorTrace SimAddr) + -- inboundGovernorEvents :: Trace (SimResult ()) (InboundGovernorTrace NetworkAddress) -- inboundGovernorEvents = traceWithNameTraceEvents trace in counterexample (ppScript mns) @@ -1907,7 +1902,7 @@ prop_inbound_governor_state (Fixed rnd) serverAcc (ArbDataFlow dataFlow) events attenuationMap - inboundGovernorStateInvariant :: IG.Debug SimAddr DataFlowProtocolData + inboundGovernorStateInvariant :: IG.Debug NetworkAddress DataFlowProtocolData -> Property inboundGovernorStateInvariant (IG.Debug IG.State { IG.connections, @@ -1944,17 +1939,17 @@ prop_connection_manager_pruning (Fixed rnd) serverAcc attenuationMap) = let trace = runSimTrace sim - evs :: Trace (SimResult ()) (Either (AbstractTransitionTrace SimAddr) - (CM.Trace SimAddr (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData))) + evs :: Trace (SimResult ()) (Either (AbstractTransitionTrace NetworkAddress) + (CM.Trace NetworkAddress (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData))) evs = fmap (bimap wnEvent wnEvent) . Trace.filter ((MainServer ==) . either wnName wnName) . traceSelectTraceEvents fn $ trace where fn :: Time -> SimEventType - -> Maybe (Either (WithName (Name SimAddr) (AbstractTransitionTrace SimAddr)) - (WithName (Name SimAddr) (CM.Trace SimAddr - (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData)))) + -> Maybe (Either (WithName Name (AbstractTransitionTrace NetworkAddress)) + (WithName Name (CM.Trace NetworkAddress + (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData)))) fn _ (EventLog dyn) = fromDynamic dyn fn _ _ = Nothing @@ -2033,15 +2028,15 @@ prop_inbound_governor_pruning (Fixed rnd) serverAcc attenuationMap) = let trace = runSimTrace sim - evs :: Trace (SimResult ()) (Either (IG.Trace SimAddr) - (RemoteTransitionTrace SimAddr)) + evs :: Trace (SimResult ()) (Either (IG.Trace NetworkAddress) + (RemoteTransitionTrace NetworkAddress)) evs = fmap (bimap wnEvent wnEvent) . Trace.filter ((MainServer ==) . either wnName wnName) . traceSelectTraceEvents fn $ trace where - fn :: Time -> SimEventType -> Maybe (Either (WithName (Name SimAddr) (IG.Trace SimAddr)) - (WithName (Name SimAddr) (RemoteTransitionTrace SimAddr))) + fn :: Time -> SimEventType -> Maybe (Either (WithName Name (IG.Trace NetworkAddress)) + (WithName Name (RemoteTransitionTrace NetworkAddress))) fn _ (EventLog dyn) = Left <$> fromDynamic dyn <|> Right <$> fromDynamic dyn fn _ _ = Nothing @@ -2161,16 +2156,16 @@ prop_never_above_hardlimit (Fixed rnd) serverAcc connectionManagerEvents :: Trace (SimResult ()) (CM.Trace - SimAddr + NetworkAddress (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData)) connectionManagerEvents = traceWithNameTraceEvents trace - -- abstractTransitionEvents :: Trace (SimResult ()) (AbstractTransitionTrace SimAddr) + -- abstractTransitionEvents :: Trace (SimResult ()) (AbstractTransitionTrace NetworkAddress) -- abstractTransitionEvents = traceWithNameTraceEvents trace - -- inboundGovernorEvents :: Trace (SimResult ()) (InboundGovernorTrace SimAddr) + -- inboundGovernorEvents :: Trace (SimResult ()) (InboundGovernorTrace NetworkAddress) -- inboundGovernorEvents = traceWithNameTraceEvents trace in tabulate "ConnectionEvents" (map showConnectionEvents events) @@ -2243,14 +2238,14 @@ prop_server_accept_error (Fixed rnd) (AbsIOError ioerr) = bearerAttenuation Map.empty $ \snock _ -> - bracket ((,) <$> Snocket.open snock Snocket.TestFamily - <*> Snocket.open snock Snocket.TestFamily) + bracket ((,) <$> Snocket.open snock Snocket.AFInet + <*> Snocket.open snock Snocket.AFInet) (\ (socket0, socket1) -> Snocket.close snock socket0 >> Snocket.close snock socket1) $ \ (socket0, socket1) -> do - let addr :: SimAddr - addr = Snocket.TestAddress (0 :: Int) + let addr :: NetworkAddress + addr = EphIPv4Addr 0 pdata :: ClientAndServerData Int pdata = ClientAndServerData 0 [] [] [] Snocket.bind snock socket0 addr @@ -2267,7 +2262,7 @@ prop_server_accept_error (Fixed rnd) (AbsIOError ioerr) = makeFDBearer connStateIdSupply (\_ -> pure ()) - socket0 (Just addr) + socket0 [addr] [accumulatorInit pdata] nextRequests noTimeLimitsHandshake @@ -2316,22 +2311,22 @@ multiNodeSimTracer :: ( Alternative (STM m), Monad m, MonadFix m -> DataFlow -> AbsBearerInfo -> AcceptedConnectionsLimit - -> [ConnectionEvent req TestAddr] - -> Map TestAddr (Script AbsBearerInfo) + -> [ConnectionEvent req] + -> Map NetworkAddress (Script AbsBearerInfo) -> Tracer m - (WithName (Name SimAddr) (RemoteTransitionTrace SimAddr)) + (WithName Name (RemoteTransitionTrace NetworkAddress)) -> Tracer m - (WithName (Name SimAddr) (AbstractTransitionTrace CM.ConnStateId)) + (WithName Name (AbstractTransitionTrace CM.ConnStateId)) -> Tracer m - (WithName (Name SimAddr) (IG.Trace SimAddr)) + (WithName Name (IG.Trace NetworkAddress)) -> Tracer m - (WithName (Name SimAddr) (IG.Debug SimAddr DataFlowProtocolData)) - -> Mux.Tracers' m (WithNameAndBearer (Name SimAddr) SimAddr) + (WithName Name (IG.Debug NetworkAddress DataFlowProtocolData)) + -> Mux.Tracers' m (WithNameAndBearer Name NetworkAddress) -> Tracer m (WithName - (Name SimAddr) + Name (CM.Trace - SimAddr + NetworkAddress (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData))) -> m () @@ -2343,7 +2338,7 @@ multiNodeSimTracer stdGen serverAcc dataFlow defaultBearerInfo let attenuationMap' = (fmap toBearerInfo <$>) . Map.mapKeys ( normaliseId . ConnectionId mainServerAddr - . unTestAddr) + ) $ attenuationMap mb <- timeout 7200 @@ -2360,22 +2355,22 @@ multiNodeSimTracer stdGen serverAcc dataFlow defaultBearerInfo stdGen snocket makeFDBearer - Snocket.TestFamily + Snocket.AFInet mainServerAddr serverAcc dataFlow acceptedConnLimit (MultiNodeScript - ((unTestAddr <$>) <$> events) - (Map.mapKeys unTestAddr attenuationMap) + events + attenuationMap ) ) case mb of Nothing -> throwIO SimulationTimeout Just a -> return a where - mainServerAddr :: SimAddr - mainServerAddr = Snocket.TestAddress 0 + mainServerAddr :: NetworkAddress + mainServerAddr = EphIPv4Addr 0 multiNodeSim :: ( Serialise req @@ -2389,8 +2384,8 @@ multiNodeSim :: ( Serialise req -> DataFlow -> AbsBearerInfo -> AcceptedConnectionsLimit - -> [ConnectionEvent req TestAddr] - -> Map TestAddr (Script AbsBearerInfo) + -> [ConnectionEvent req] + -> Map NetworkAddress (Script AbsBearerInfo) -> IOSim s () multiNodeSim stdGen serverAcc dataFlow defaultBearerInfo acceptedConnLimit events attenuationMap = do @@ -2421,16 +2416,16 @@ unit_connection_terminated_when_negotiating = } multiNodeScript = MultiNodeScript - [ StartServer 0 (TestAddr {unTestAddr = TestAddress 24}) 0 - , OutboundConnection 0 (TestAddr {unTestAddr = TestAddress 24}) - , StartServer 0 (TestAddr {unTestAddr = TestAddress 40}) 0 - , OutboundMiniprotocols 0 (TestAddr {unTestAddr = TestAddress 24}) + [ StartServer 0 (EphIPv4Addr 24) 0 + , OutboundConnection 0 (EphIPv4Addr 24) + , StartServer 0 (EphIPv4Addr 40) 0 + , OutboundMiniprotocols 0 (EphIPv4Addr 24) (TemperatureBundle { withHot = WithHot [0] , withWarm = WithWarm [] , withEstablished = WithEstablished [] }) - , OutboundConnection 0 (TestAddr {unTestAddr = TestAddress 40}) + , OutboundConnection 0 (EphIPv4Addr 40) ] Map.empty in @@ -2446,7 +2441,7 @@ unit_connection_terminated_when_negotiating = (Fixed 0) 0 arbDataFlow absBearerInfo multiNodeScript -ppScript :: (Show peerAddr, Show req) => MultiNodeScript peerAddr req -> String +ppScript :: Show req => MultiNodeScript req -> String ppScript (MultiNodeScript script _) = intercalate "\n" $ go 0 script where delay (StartServer d _ _) = d @@ -2497,24 +2492,24 @@ traceWithNameTraceEvents = fmap wnEvent . Trace.filter ((MainServer ==) . wnName) . traceSelectTraceEventsDynamic @(SimResult ()) - @(WithName (Name SimAddr) b) + @(WithName Name b) withNameTraceEvents :: forall b. Typeable b => SimTrace () -> [b] withNameTraceEvents = fmap wnEvent . filter ((MainServer ==) . wnName) . selectTraceEventsDynamic @() - @(WithName (Name SimAddr) b) + @(WithName Name b) withTimeNameTraceEvents :: forall b. Typeable b => SimTrace () - -> Trace (SimResult ()) (WithTime (WithName (Name SimAddr) b)) + -> Trace (SimResult ()) (WithTime (WithName Name b)) withTimeNameTraceEvents = traceSelectTraceEventsDynamic @(SimResult ()) - @(WithTime (WithName (Name SimAddr) b)) + @(WithTime (WithName Name b)) -showConnectionEvents :: ConnectionEvent req peerAddr -> String +showConnectionEvents :: ConnectionEvent req -> String showConnectionEvents StartClient{} = "StartClient" showConnectionEvents StartServer{} = "StartServer" showConnectionEvents InboundConnection{} = "InboundConnection" diff --git a/ouroboros-network/framework/sim-tests/Test/Simulation/Network/Snocket.hs b/ouroboros-network/framework/sim-tests/Test/Simulation/Network/Snocket.hs index fdc4084613d..6742d9ffa06 100644 --- a/ouroboros-network/framework/sim-tests/Test/Simulation/Network/Snocket.hs +++ b/ouroboros-network/framework/sim-tests/Test/Simulation/Network/Snocket.hs @@ -91,9 +91,7 @@ tests = prop_self_connect ] -type TestAddr = TestAddress Int -type TestFD m = FD m TestAddr -type TestSnocket m = Snocket m (TestFD m) TestAddr +type TestSnocket m = Snocket m (FD m) NetworkAddress pingServer :: forall payload m. Applicative m => ReqRespServer payload payload m () @@ -193,7 +191,7 @@ untilSuccess go = clientServerSimulation - :: forall m addr payload. + :: forall m payload. ( Alternative (STM m) , MonadAsync m , MonadDelay m @@ -212,7 +210,7 @@ clientServerSimulation , Ord (Async m ()) ) => [payload] - -> m (Either (TestError addr) ()) + -> m (Either TestError ()) clientServerSimulation payloads = withSnocket nullTracer (toBearerInfo absNoAttenuation) Map.empty $ \snocket _ -> @@ -225,8 +223,8 @@ clientServerSimulation payloads = reqRespProtocolNum :: MiniProtocolNum reqRespProtocolNum = MiniProtocolNum 0 - serverAddr :: TestAddr - serverAddr = TestAddress 1 + serverAddr :: NetworkAddress + serverAddr = EphIPv4Addr 1 serverPeer :: Peer (ReqResp payload payload) AsServer NonPipelined StIdle m () serverPeer = reqRespServerPeer pingServer @@ -239,7 +237,7 @@ clientServerSimulation payloads = server snocket = do labelThisThread "server" threadsVar <- newTVarIO Set.empty - bracket (open snocket TestFamily) + bracket (open snocket AFInet) (close snocket) (\fd -> do bind snocket fd serverAddr @@ -250,7 +248,7 @@ clientServerSimulation payloads = traverse_ cancel threads where acceptLoop :: StrictTVar m (Set (Async m ())) - -> Accept m (TestFD m) TestAddr + -> Accept m (FD m) NetworkAddress -> m () acceptLoop threadsVar accept0 = do (accepted, accept1) <- runAccept accept0 @@ -266,7 +264,7 @@ clientServerSimulation payloads = AcceptFailure _err -> acceptLoop threadsVar accept1 - handleConnection :: Mx.Bearer m -> TestAddr -> m () + handleConnection :: Mx.Bearer m -> NetworkAddress -> m () handleConnection bearer remoteAddr = do labelThisThread "server-handler" let connId = ConnectionId { @@ -395,17 +393,17 @@ toBearerInfo abi = -- Properties -- -data TestError addr = UnexpectedOutcome - | UnexpectedError SomeException - | UnexpectedlyReleasedListeningSockets - | DidNotTimeout - | DidNotComplainAboutNoSuchListeningSockets - | DoNotExistInNetworkState addr addr - -- ^ LocalAddress, RemoteAddress +data TestError = UnexpectedOutcome + | UnexpectedError SomeException + | UnexpectedlyReleasedListeningSockets + | DidNotTimeout + | DidNotComplainAboutNoSuchListeningSockets + | DoNotExistInNetworkState NetworkAddress NetworkAddress + -- ^ LocalAddress, RemoteAddress deriving Show verify_no_error - :: (forall s . IOSim s (Either (TestError (TestAddress Int)) ())) + :: (forall s . IOSim s (Either TestError ())) -> Property verify_no_error sim = let tr = runSimTrace sim @@ -436,22 +434,24 @@ prop_client_server :: [Payload] -> Property prop_client_server payloads = verify_no_error sim where - sim :: forall s addr . IOSim s (Either (TestError addr) ()) + sim :: forall s. IOSim s (Either TestError ()) sim = clientServerSimulation (map unPayload payloads) prop_connect_to_accepting_socket :: AbsBearerInfo -> Property prop_connect_to_accepting_socket defaultBearerInfo = verify_no_error sim where - serverAddr :: TestAddress Int - serverAddr = TestAddress 0 + serverAddr :: NetworkAddress + serverAddr = EphIPv4Addr 0 - clientAddr :: TestAddress Int - clientAddr = TestAddress 1 + clientAddr :: NetworkAddress + clientAddr = EphIPv4Addr 1 - sim :: forall s . IOSim s (Either (TestError (TestAddress Int)) ()) + sim :: forall s . IOSim s (Either TestError ()) sim = - withSnocket nullTracer (toBearerInfo defaultBearerInfo) Map.empty + withSnocket nullTracer + (toBearerInfo defaultBearerInfo) + Map.empty $ \snocket getState -> withAsync (runServer serverAddr snocket (close snocket) @@ -478,16 +478,17 @@ prop_connect_and_not_close :: AbsBearerInfo -> Property prop_connect_and_not_close defaultBearerInfo = verify_no_error sim where - sim :: forall s . IOSim s (Either (TestError (TestAddress Int)) ()) + sim :: forall s . IOSim s (Either TestError ()) sim = - withSnocket nullTracer (toBearerInfo defaultBearerInfo) Map.empty + withSnocket nullTracer + (toBearerInfo defaultBearerInfo) + Map.empty (\snocket _ -> withAsync - (runServer (TestAddress (0 :: Int)) snocket (\_ -> pure ()) + (runServer (EphIPv4Addr 0) snocket (\_ -> pure ()) acceptOne return) $ \serverAsync -> do - res <- runClient (TestAddress 1) (TestAddress 0) - snocket (\_ -> pure ()) + res <- runClient (EphIPv4Addr 1) (EphIPv4Addr 0) snocket (\_ -> pure ()) _ <- wait serverAsync return res ) @@ -503,14 +504,16 @@ prop_connect_to_not_accepting_socket :: AbsBearerInfo -> Property prop_connect_to_not_accepting_socket defaultBearerInfo = verify_no_error sim where - sim :: forall s addr . IOSim s (Either (TestError addr) ()) + sim :: forall s. IOSim s (Either TestError ()) sim = - withSnocket nullTracer (toBearerInfo defaultBearerInfo) Map.empty + withSnocket nullTracer + (toBearerInfo defaultBearerInfo) + Map.empty $ \snocket _ -> - withAsync (runServer (TestAddress (0 :: Int)) snocket + withAsync (runServer (EphIPv4Addr 0) snocket (close snocket) loop return) $ \_ -> do - res <- runClient (TestAddress 1) (TestAddress 0) + res <- runClient (EphIPv4Addr 1) (EphIPv4Addr 0) snocket (close snocket) case res of -- Should timeout @@ -526,11 +529,12 @@ prop_connect_to_uninitialised_socket :: AbsBearerInfo -> Property prop_connect_to_uninitialised_socket defaultBearerInfo = verify_no_error sim where - sim :: forall s addr . IOSim s (Either (TestError addr) ()) + sim :: forall s. IOSim s (Either TestError ()) sim = - withSnocket nullTracer (toBearerInfo defaultBearerInfo) Map.empty + withSnocket nullTracer + (toBearerInfo defaultBearerInfo) Map.empty $ \snocket _ -> do - res <- runClient (TestAddress (1 :: Int)) (TestAddress 0) + res <- runClient (EphIPv4Addr 1) (EphIPv4Addr 0) snocket (close snocket) case res of -- Should complain about no such listening socket @@ -541,14 +545,15 @@ prop_connect_to_not_listening_socket :: AbsBearerInfo -> Property prop_connect_to_not_listening_socket defaultBearerInfo = verify_no_error sim where - sim :: forall s addr . IOSim s (Either (TestError addr) ()) + sim :: forall s. IOSim s (Either TestError ()) sim = - withSnocket nullTracer (toBearerInfo defaultBearerInfo) Map.empty + withSnocket nullTracer + (toBearerInfo defaultBearerInfo) Map.empty $ \snocket _ -> - withAsync (runServerNotListening (TestAddress (0 :: Int)) snocket + withAsync (runServerNotListening (EphIPv4Addr 0) snocket (close snocket) acceptOne) $ \_ -> do - res <- runClient (TestAddress (1 :: Int)) (TestAddress 0) + res <- runClient (EphIPv4Addr 1) (EphIPv4Addr 0) snocket (close snocket) case res of -- Should complain about no such listening socket @@ -559,15 +564,15 @@ prop_connect_to_not_listening_socket defaultBearerInfo = :: ( MonadThread m , MonadThrow m ) - => TestAddress addr -- ^ Local Address - -> Snocket m fd (TestAddress addr) - -> (fd -> m ()) -- ^ Resource cleanup function (socket close) - -> (m (Accept m fd (TestAddress addr)) -> m (Either err fd)) + => NetworkAddress -- ^ Local Address + -> Snocket m (FD m) NetworkAddress + -> (FD m -> m ()) -- ^ Resource cleanup function (socket close) + -> (m (Accept m (FD m) NetworkAddress) -> m (Either err (FD m))) -- ^ Accepting function -> m (Either err ()) runServerNotListening localAddress snocket closeF acceptF = do labelThisThread "server" - bracket (open snocket TestFamily) + bracket (open snocket AFInet) closeF (\fd -> do bind snocket fd localAddress @@ -581,16 +586,17 @@ prop_simultaneous_open :: AbsBearerInfo -> Property prop_simultaneous_open defaultBearerInfo = verify_no_error sim where - sim :: forall s . IOSim s (Either (TestError (TestAddress Int)) ()) + sim :: forall s . IOSim s (Either TestError ()) sim = - withSnocket nullTracer (toBearerInfo defaultBearerInfo) Map.empty + withSnocket nullTracer + (toBearerInfo defaultBearerInfo) Map.empty $ \snocket getState -> withAsync - (listenAndConnect (TestAddress (0 :: Int)) (TestAddress 1) + (listenAndConnect (EphIPv4Addr 0) (EphIPv4Addr 1) snocket getState) $ \clientAsync -> do - _ <- listenAndConnect (TestAddress 1) (TestAddress 0) - snocket getState + _ <- listenAndConnect (EphIPv4Addr 1) (EphIPv4Addr 0) + snocket getState wait clientAsync @@ -606,8 +612,8 @@ prop_self_connect :: Payload -> Property prop_self_connect (Payload payload) = runSimOrThrow sim where - addr :: TestAddress Int - addr = TestAddress 0 + addr :: NetworkAddress + addr = EphIPv4Addr 0 sim :: forall s. IOSim s Property sim = @@ -642,17 +648,17 @@ runServer :: ( MonadThread m , MonadThrow m ) - => TestAddress addr -- ^ Local Address - -> Snocket m fd (TestAddress addr) + => addr -- ^ Local Address + -> Snocket m fd addr -> (fd -> m ()) -- ^ Resource cleanup function (socket close) - -> (m (Accept m fd (TestAddress addr)) -> m (Either err fd)) + -> (m (Accept m fd addr) -> m (Either err fd)) -- ^ Accepting function -> (Either err fd -> m (Either err fd)) -- ^ Assert NetworkState -> m (Either err ()) runServer localAddress snocket closeF acceptF assertState = do labelThisThread "server" - bracket (open snocket TestFamily) + bracket (open snocket AFInet) closeF (\fd -> do bind snocket fd localAddress @@ -665,7 +671,7 @@ runServer localAddress snocket closeF acceptF assertState = do acceptOne :: MonadMask m => m (Accept m fd addr) - -> m (Either (TestError addr) fd) + -> m (Either TestError fd) acceptOne accept = mask_ $ do accept0 <- accept (accepted, _) <- runAccept accept0 @@ -683,7 +689,7 @@ runClient -> addr -- ^ Remote Address -> Snocket m fd addr -> (fd -> m ()) -- ^ Resource cleanup function (socket close) - -> m (Either (TestError addr) ()) + -> m (Either TestError ()) runClient localAddress remoteAddress snocket closeF = do labelThisThread "client" bracket (openToConnect snocket localAddress) @@ -697,16 +703,15 @@ runClient localAddress remoteAddress snocket closeF = do listenAndConnect :: ( MonadThread m , MonadCatch m - , Ord addr ) - => TestAddress addr -- ^ Local Address - -> TestAddress addr -- ^ Remote Address - -> Snocket m fd (TestAddress addr) - -> m (ObservableNetworkState (TestAddress addr)) - -> m (Either (TestError (TestAddress addr)) ()) + => NetworkAddress -- ^ Local Address + -> NetworkAddress -- ^ Remote Address + -> Snocket m (FD m) NetworkAddress + -> m ObservableNetworkState + -> m (Either TestError ()) listenAndConnect localAddress remoteAddress snocket getState = do labelThisThread "connectingServer" - bracket (open snocket TestFamily) + bracket (open snocket AFInet) (close snocket) $ \fd -> do bind snocket fd localAddress @@ -723,12 +728,12 @@ listenAndConnect localAddress remoteAddress snocket getState = do -- | Asserts that the local address and remote address pair exists in the -- NetworkState. -assertNetworkState :: (Monad m, Ord addr) - => addr -- ^ Local Address - -> addr -- ^ Remote Address - -> m (ObservableNetworkState addr) - -> Either (TestError addr) b - -> m (Either (TestError addr) b) +assertNetworkState :: Monad m + => NetworkAddress -- ^ Local Address + -> NetworkAddress -- ^ Remote Address + -> m ObservableNetworkState + -> Either TestError b + -> m (Either TestError b) assertNetworkState localAddress remoteAddress getState res = do us <- onsConnections <$> getState -- Important to use serverAddr as first argument diff --git a/ouroboros-network/framework/lib/Simulation/Network/Snocket.hs b/ouroboros-network/framework/tests-lib/Simulation/Network/Snocket.hs similarity index 87% rename from ouroboros-network/framework/lib/Simulation/Network/Snocket.hs rename to ouroboros-network/framework/tests-lib/Simulation/Network/Snocket.hs index 646139337ab..02839b2f4e7 100644 --- a/ouroboros-network/framework/lib/Simulation/Network/Snocket.hs +++ b/ouroboros-network/framework/tests-lib/Simulation/Network/Snocket.hs @@ -1,9 +1,14 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} @@ -41,17 +46,17 @@ module Simulation.Network.Snocket , FD , makeFDRawBearer , makeFDBearer - , GlobalAddressScheme (..) - , AddressType (..) + , NetworkAddress (..) , WithAddr (..) + -- * Re-exports + , Natural ) where -import Prelude hiding (read) - import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM qualified as LazySTM import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad (when) +import Control.DeepSeq (NFData (..)) +import Control.Monad (replicateM, when) import Control.Monad.Class.MonadST import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime.SI @@ -59,6 +64,7 @@ import Control.Monad.Class.MonadTimer.SI import Control.Monad.ST.Unsafe (unsafeIOToST) import Control.Tracer (Tracer, contramap, contramapM, traceWith) +import GHC.Generics (Generic) import GHC.IO.Exception import Data.Bifoldable (bitraverse_) @@ -66,6 +72,8 @@ import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as LBS import Data.Foldable (traverse_) import Data.Functor (($>)) +import Data.Hashable +import Data.IP qualified as IP import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Typeable (Typeable) @@ -73,6 +81,7 @@ import Foreign.Marshal (copyBytes) import Foreign.Ptr (castPtr) import Formatting (formatToString, (%+)) import Formatting qualified as F +import NoThunks.Class (InspectHeap (..), NoThunks (..)) import Numeric.Natural (Natural) import Data.Monoid.Synchronisation (FirstToFinish (..)) @@ -80,13 +89,15 @@ import Data.Wedge import Network.Mux (SDUSize (..)) import Network.Mux.Bearer.AttenuatedChannel +import Network.Socket (PortNumber) import Ouroboros.Network.ConnectionId -import Ouroboros.Network.ConnectionManager.Types (AddressType (..)) import Ouroboros.Network.RawBearer import Ouroboros.Network.Snocket +import Ouroboros.Network.Util (PrettyShow (..)) import Test.Ouroboros.Network.Data.Script (Script (..), stepScriptSTM) +import Test.QuickCheck hiding (Result (..)) data Connection m addr = Connection { -- | Attenuated channels of a connection. @@ -141,13 +152,11 @@ mkConnection :: ( MonadDelay m , MonadTimer m , MonadThrow m , MonadThrow (STM m) - , Eq addr ) - => Tracer m (WithAddr (TestAddress addr) - (SnocketTrace m (TestAddress addr))) + => Tracer m (WithAddr (SnocketTrace m)) -> BearerInfo - -> ConnectionId (TestAddress addr) - -> STM m (Connection m (TestAddress addr)) + -> ConnectionId NetworkAddress + -> STM m (Connection m NetworkAddress) mkConnection tr bearerInfo connId@ConnectionId { localAddress, remoteAddress } | localAddress == remoteAddress = do -- we are connecting to onself. On Linux this returns a connection which @@ -227,36 +236,36 @@ normaliseId -- | Simulation network environment consumed by 'simSnocket'. -- -data NetworkState m addr = NetworkState { +data NetworkState m = NetworkState { -- | All listening 'FD's. -- - nsListeningFDs :: StrictTVar m (Map addr (FD m addr)), + nsListeningFDs :: StrictTVar m (Map NetworkAddress (FD m)), -- | Registry of active connections. -- nsConnections :: StrictTVar m - (Map (NormalisedId addr) (Connection m addr)), + (Map (NormalisedId NetworkAddress) (Connection m NetworkAddress)), -- | Get an unused ephemeral address. -- - nsNextEphemeralAddr :: AddressType -> STM m addr, + nsNextEphemeralAddr :: AddressFamily -> STM m NetworkAddress, nsDefaultBearerInfo :: BearerInfo, -- | Get the BearerInfo Script for a given connection. -- - nsAttenuationMap :: Map (NormalisedId addr) + nsAttenuationMap :: Map (NormalisedId NetworkAddress) (LazySTM.TVar m (Script BearerInfo)) } -- | Simulation accessible network environment consumed by 'simSnocket'. -- -newtype ObservableNetworkState addr = ObservableNetworkState { +newtype ObservableNetworkState = ObservableNetworkState { -- | Registry of active connections and respective provider -- - onsConnections :: Map (NormalisedId addr) addr + onsConnections :: Map (NormalisedId NetworkAddress) NetworkAddress } deriving Show @@ -345,23 +354,26 @@ noAttenuation = BearerInfo { biConnectionDelay = 0 -- | Create a new network snocket based on a 'BearerInfo' script. -- newNetworkState - :: forall m peerAddr. + :: forall m. ( MonadLabelledSTM m - , GlobalAddressScheme peerAddr ) => BearerInfo - -> Map (NormalisedId (TestAddress peerAddr)) + -> Map (NormalisedId NetworkAddress) (Script BearerInfo) -- ^ the largest ephemeral address - -> m (NetworkState m (TestAddress peerAddr)) + -> m (NetworkState m) newNetworkState defaultBearerInfo scriptMap = atomically $ do (v :: StrictTVar m Natural) <- newTVar 0 - let nextEphemeralAddr :: AddressType -> STM m (TestAddress peerAddr) - nextEphemeralAddr addrType = do + + let nextEphemeralAddr :: AddressFamily -> STM m NetworkAddress + nextEphemeralAddr addrFamily = do -- TODO: we should use `(\s -> (succ s, s)` but p2p-master does not -- include PR #3172. a <- stateTVar v (\s -> let s' = succ s in (s', s')) - return (ephemeralAddress addrType a) + return $ case addrFamily of + AFInet -> EphIPv4Addr a + AFInet6 -> EphIPv6Addr a + AFLocal addr -> LocalAddr addr scriptMapVars <- traverse LazySTM.newTVar scriptMap s <- NetworkState @@ -392,51 +404,90 @@ deriving instance Show ResourceException instance Exception ResourceException where --- | A type class for global IP address scheme. Every node in the simulation --- has an ephemeral address. Every node in the simulation has an implicit ipv4 --- and ipv6 address (if one is not bound by explicitly). +data NetworkAddress + = EphIPv4Addr Natural + -- ^ a globally unique ephemeral IPv4 address + | EphIPv6Addr Natural + -- ^ a globally unique ephemeral IPv6 address + | IPAddr IP.IP PortNumber + -- ^ IP address + | UnusedAddr + | LocalAddr LocalAddress + -- ^ Local socket + deriving stock (Eq, Ord, Generic) + deriving NoThunks via InspectHeap NetworkAddress + +instance NFData NetworkAddress where + rnf (EphIPv4Addr !_) = () + rnf (EphIPv6Addr !_) = () + rnf (IPAddr !_ !_) = () + rnf UnusedAddr = () + rnf (LocalAddr addr) = rnf addr + +instance Show NetworkAddress where + show (EphIPv4Addr n) = "EphIPv4Addr " ++ show n + show (EphIPv6Addr n) = "EphIPv6Addr " ++ show n + show (IPAddr ip port) = "IPAddr (read \"" ++ show ip ++ "\") " ++ show port + show UnusedAddr = "UnusedAddr" + show (LocalAddr addr) = "LocalAddr (" ++ show addr ++ ")" + +instance PrettyShow NetworkAddress where + prettyShow (EphIPv4Addr n) = "eph:" ++ show n + prettyShow (EphIPv6Addr n) = "eph6:" ++ show n + prettyShow (IPAddr ip port) = show ip ++ ":" ++ show port + prettyShow UnusedAddr = "unused-addr" + prettyShow (LocalAddr addr) = prettyShow addr + + +instance Hashable NetworkAddress where + hashWithSalt s (EphIPv4Addr n) = hashWithSalt s n + hashWithSalt s (EphIPv6Addr n) = hashWithSalt s n + hashWithSalt s (IPAddr (IP.IPv4 ip) port) = hashWithSalt s ( IP.toHostAddress ip + , fromIntegral port :: Integer) + hashWithSalt s (IPAddr (IP.IPv6 ip) port) = hashWithSalt s ( IP.toHostAddress6 ip + , fromIntegral port :: Integer) + hashWithSalt s UnusedAddr = hashWithSalt s ("unusedaddr" :: String) + hashWithSalt s (LocalAddr path) = hashWithSalt s path + +-- | This instance only generates `AFInet` or `AFInet6` addresses. -- -class GlobalAddressScheme addr where - getAddressType :: TestAddress addr -> AddressType - ephemeralAddress :: AddressType -> Natural -> TestAddress addr - - - --- | All negative addresses are ephemeral. Even address are IPv4, while odd --- ones are IPv6. --- -instance GlobalAddressScheme Int where - getAddressType (TestAddress n) = if n `mod` 2 == 0 - then IPv4Address - else IPv6Address - ephemeralAddress IPv4Address n = TestAddress $ (-2) * fromIntegral n - ephemeralAddress IPv6Address n = TestAddress $ (-1) * fromIntegral n + 1 +instance Arbitrary NetworkAddress where + arbitrary = + frequency + [ (1 , EphIPv4Addr <$> arbitrary `suchThat` (> 100)) -- first 100 are reserved + , (1 , EphIPv6Addr <$> arbitrary `suchThat` (> 100)) -- first 100 are reserved + , (3 , IPAddr <$> genIP <*> (fromIntegral <$> chooseInt (0, 9999))) + ] + where + genIP = oneof [ IP.IPv4 . IP.toIPv4 <$> replicateM 4 (choose (0,255)) + , IP.IPv6 . IP.toIPv6 <$> replicateM 8 (choose (0,0xffff)) + ] -- | A bracket which runs a network simulation. When the simulation -- terminates it verifies that all listening sockets and all connections are -- closed. It might throw 'ResourceException'. -- +-- TODO: this function shouldn't be polymorphic over `peerAddr`, it will be +-- easier for tests if it came with a concrete type and sensible QuickCheck +-- instances. This requires moving it to +-- `ouroboros-network:framework-tests-lib` +-- withSnocket - :: forall m peerAddr a. + :: forall m a. ( Alternative (STM m) , MonadDelay m , MonadLabelledSTM m , MonadMask m , MonadTimer m , MonadThrow (STM m) - , GlobalAddressScheme peerAddr - , Ord peerAddr - , Typeable peerAddr - , Show peerAddr ) - => Tracer m (WithAddr (TestAddress peerAddr) - (SnocketTrace m (TestAddress peerAddr))) + => Tracer m (WithAddr (SnocketTrace m)) -> BearerInfo - -> Map (NormalisedId (TestAddress peerAddr)) + -> Map (NormalisedId NetworkAddress) (Script BearerInfo) - -> (Snocket m (FD m (TestAddress peerAddr)) (TestAddress peerAddr) - -> m (ObservableNetworkState (TestAddress peerAddr)) + -> (Snocket m (FD m) NetworkAddress + -> m ObservableNetworkState -> m a) -> m a withSnocket tr defaultBearerInfo scriptMap k = do @@ -451,7 +502,7 @@ withSnocket tr defaultBearerInfo scriptMap k = do return a where -- verify that all sockets are closed - checkResources :: NetworkState m (TestAddress peerAddr) + checkResources :: NetworkState m -> Maybe SomeException -> m (Maybe ResourceException) checkResources NetworkState { nsListeningFDs, nsConnections } err = do @@ -468,8 +519,8 @@ withSnocket tr defaultBearerInfo scriptMap k = do | otherwise -> return Nothing - toState :: NetworkState m (TestAddress peerAddr) - -> m (ObservableNetworkState (TestAddress peerAddr)) + toState :: NetworkState m + -> m ObservableNetworkState toState ns = atomically $ do onsConnections <- fmap connProvider <$> readTVar (nsConnections ns) return (ObservableNetworkState onsConnections) @@ -479,8 +530,8 @@ withSnocket tr defaultBearerInfo scriptMap k = do -- | Channel together with information needed by the other end, e.g. address of -- the connecting host, shared 'SDUSize'. -- -data ChannelWithInfo m addr = ChannelWithInfo { - cwiAddress :: !addr, +data ChannelWithInfo m = ChannelWithInfo { + cwiAddress :: !NetworkAddress, cwiSDUSize :: !SDUSize, cwiChannelLocal :: !(AttenuatedChannel m), cwiChannelRemote :: !(AttenuatedChannel m) @@ -494,7 +545,7 @@ data ChannelWithInfo m addr = ChannelWithInfo { -- | Internal file descriptor type which tracks the file descriptor state -- across 'Snocket' api calls. -- -data FD_ m addr +data FD_ m -- | 'FD_' for uninitialised snockets (either not connected or not -- listening). -- @@ -502,7 +553,7 @@ data FD_ m addr -- (which corresponds to 'socket' system call). -- 'bind' will update the address. = FDUninitialised - !(Maybe addr) + !(Maybe NetworkAddress) -- ^ address (initialised by a 'bind') -- | 'FD_' for snockets in listening state. @@ -510,10 +561,10 @@ data FD_ m addr -- 'FDListening' is created by 'listen' -- | FDListening - !addr + !NetworkAddress -- ^ listening address - !(StrictTBQueue m (ChannelWithInfo m addr)) + !(StrictTBQueue m (ChannelWithInfo m)) -- ^ listening queue; when 'connect' is called; dual 'AttenuatedChannel' -- of 'FDConnected' file descriptor is passed through the listening -- queue. @@ -524,8 +575,8 @@ data FD_ m addr -- | 'FD_' was passed to 'connect' call, if needed an ephemeral address was -- assigned to it. This corresponds to 'SYN_SENT' state. -- - | FDConnecting !(ConnectionId addr) - !(Connection m addr) + | FDConnecting !(ConnectionId NetworkAddress) + !(Connection m NetworkAddress) -- | 'FD_' for snockets in connected state. -- @@ -533,19 +584,19 @@ data FD_ m addr -- corresponds to 'ESTABLISHED' state. -- | FDConnected - !(ConnectionId addr) + !(ConnectionId NetworkAddress) -- ^ local and remote addresses - !(Connection m addr) + !(Connection m NetworkAddress) -- ^ connection -- | 'FD_' of a closed file descriptor; we keep 'ConnectionId' just for -- tracing purposes. -- | FDClosed - !(Wedge (ConnectionId addr) addr) + !(Wedge (ConnectionId NetworkAddress) NetworkAddress) -instance Show addr => Show (FD_ m addr) where +instance Show (FD_ m) where show (FDUninitialised mbAddr) = "FDUninitialised " ++ show mbAddr show (FDListening addr _) = "FDListening " ++ show addr show (FDConnecting connId conn) = concat @@ -565,7 +616,7 @@ instance Show addr => Show (FD_ m addr) where -- | File descriptor type. -- -newtype FD m peerAddr = FD { fdVar :: StrictTVar m (FD_ m peerAddr) } +newtype FD m = FD { fdVar :: StrictTVar m (FD_ m) } data FDRawBearerSendTrace = SendingBytes Int @@ -598,21 +649,20 @@ data FDRawBearerTrace -- plain old 'ByteString' under the hood. This allows us to use the -- 'AttenuatedChannel' inside the `FD_`, even though its send and receive -- methods do not have the right format. -makeFDRawBearer :: forall m addr. +makeFDRawBearer :: forall m. ( MonadST m , MonadThrow m , MonadLabelledSTM m - , Show addr ) => Tracer m FDRawBearerTrace - -> MakeRawBearer m (FD m (TestAddress addr)) + -> MakeRawBearer m (FD m) makeFDRawBearer tracer = MakeRawBearer go where traceSend = traceWith tracer . TraceSend traceRecv = traceWith tracer . TraceRecv - go (FD {fdVar}) = do + go FD {fdVar} = do (bufVar :: StrictTMVar m LBS.ByteString) <- newTMVarIO LBS.empty return RawBearer { send = \src srcSize -> do @@ -663,7 +713,7 @@ makeFDRawBearer tracer = MakeRawBearer go throwIO (invalidError fd_) } - invalidError :: FD_ m (TestAddress addr) -> IOError + invalidError :: FD_ m -> IOError invalidError fd_ = IOError { ioe_handle = Nothing , ioe_type = InvalidArgument @@ -675,13 +725,12 @@ makeFDRawBearer tracer = MakeRawBearer go , ioe_filename = Nothing } -makeFDBearer :: forall addr m. +makeFDBearer :: forall m. ( MonadMonotonicTime m , MonadSTM m , MonadThrow m - , Show addr ) - => MakeBearer m (FD m (TestAddress addr)) + => MakeBearer m (FD m) makeFDBearer = MakeBearer $ \sduTimeout FD { fdVar } _ -> do fd_ <- readTVarIO fdVar case fd_ of @@ -698,7 +747,7 @@ makeFDBearer = MakeBearer $ \sduTimeout FD { fdVar } _ -> do FDClosed {} -> throwIO (invalidError fd_) where - invalidError :: FD_ m (TestAddress addr) -> IOError + invalidError :: FD_ m -> IOError invalidError fd_ = IOError { ioe_handle = Nothing , ioe_type = InvalidArgument @@ -715,9 +764,9 @@ makeFDBearer = MakeBearer $ \sduTimeout FD { fdVar } _ -> do -- -- TODO: use `Ouroboros.Network.ExitPolicy.WithAddr` -data WithAddr addr event = - WithAddr { waLocalAddr :: Maybe addr - , waRemoteAddr :: Maybe addr +data WithAddr event = + WithAddr { waLocalAddr :: Maybe NetworkAddress + , waRemoteAddr :: Maybe NetworkAddress , waEvent :: event } deriving Show @@ -727,7 +776,7 @@ data SockType = ListeningSock | UnknownType deriving Show -mkSockType :: FD_ m addr -> SockType +mkSockType :: FD_ m -> SockType mkSockType FDUninitialised {} = UnknownType mkSockType FDListening {} = ListeningSock mkSockType FDConnecting {} = ConnectionSock @@ -739,22 +788,22 @@ data TimeoutDetail | WaitingToBeAccepted deriving Show -data SnocketTrace m addr - = STConnecting (FD_ m addr) addr - | STConnected (FD_ m addr) OpenType +data SnocketTrace m + = STConnecting (FD_ m) NetworkAddress + | STConnected (FD_ m) OpenType | STBearerInfo BearerInfo - | STConnectError (FD_ m addr) addr IOError + | STConnectError (FD_ m) NetworkAddress IOError | STConnectTimeout TimeoutDetail - | STBindError (FD_ m addr) addr IOError - | STClosing SockType (Wedge (ConnectionId addr) [addr]) + | STBindError (FD_ m) NetworkAddress IOError + | STClosing SockType (Wedge (ConnectionId NetworkAddress) [NetworkAddress]) | STClosed SockType (Maybe (Maybe ConnectionState)) -- ^ TODO: Document meaning of 'Maybe (Maybe OpenState)' | STClosingQueue Bool | STClosedQueue Bool | STAcceptFailure SockType SomeException | STAccepting - | STAccepted addr - | STAttenuatedChannelTrace (ConnectionId addr) AttenuatedChannelTrace + | STAccepted NetworkAddress + | STAttenuatedChannelTrace (ConnectionId NetworkAddress) AttenuatedChannelTrace deriving Show -- | Either simultaneous open or normal open. Unlike in TCP, only one side will @@ -776,36 +825,32 @@ connectTimeout = 120 -- | Simulated 'Snocket' running in 'NetworkState'. A single 'NetworkState' -- should be shared with all nodes in the same network. -- -mkSnocket :: forall m addr. +mkSnocket :: forall m. ( Alternative (STM m) , MonadDelay m , MonadLabelledSTM m , MonadThrow (STM m) , MonadMask m , MonadTimer m - , GlobalAddressScheme addr - , Ord addr - , Show addr ) - => NetworkState m (TestAddress addr) - -> Tracer m (WithAddr (TestAddress addr) - (SnocketTrace m (TestAddress addr))) - -> Snocket m (FD m (TestAddress addr)) (TestAddress addr) -mkSnocket state tr = Snocket { getLocalAddr - , getRemoteAddr - , addrFamily - , open - , openToConnect - , connect - , bind - , listen - , accept - , close - } + => NetworkState m + -> Tracer m (WithAddr (SnocketTrace m)) + -> Snocket m (FD m) NetworkAddress +mkSnocket state tr = + Snocket { getLocalAddr + , getRemoteAddr + , addrFamily + , open + , openToConnect + , connect + , bind + , listen + , accept + , close + } where - getLocalAddrM :: FD m (TestAddress addr) - -> m (Either (FD_ m (TestAddress addr)) - (TestAddress addr)) + getLocalAddrM :: FD m + -> m (Either (FD_ m) NetworkAddress) getLocalAddrM FD { fdVar } = do fd_ <- readTVarIO fdVar return $ case fd_ of @@ -818,9 +863,8 @@ mkSnocket state tr = Snocket { getLocalAddr -> Right localAddress FDClosed {} -> Left fd_ - getRemoteAddrM :: FD m (TestAddress addr) - -> m (Either (FD_ m (TestAddress addr)) - (TestAddress addr)) + getRemoteAddrM :: FD m + -> m (Either (FD_ m) NetworkAddress) getRemoteAddrM FD { fdVar } = do fd_ <- readTVarIO fdVar return $ case fd_ of @@ -832,11 +876,11 @@ mkSnocket state tr = Snocket { getLocalAddr -> Right remoteAddress FDClosed {} -> Left fd_ - traceWith' :: FD m (TestAddress addr) - -> SnocketTrace m (TestAddress addr) + traceWith' :: FD m + -> SnocketTrace m -> m () traceWith' fd = - let tr' :: Tracer m (SnocketTrace m (TestAddress addr)) + let tr' :: Tracer m (SnocketTrace m) tr' = (\ev -> (\a b -> WithAddr (hush a) (hush b) ev) <$> getLocalAddrM fd @@ -848,7 +892,7 @@ mkSnocket state tr = Snocket { getLocalAddr -- Snocket api -- - getLocalAddr :: FD m (TestAddress addr) -> m (TestAddress addr) + getLocalAddr :: FD m -> m NetworkAddress getLocalAddr fd = do maddr <- getLocalAddrM fd case maddr of @@ -857,7 +901,7 @@ mkSnocket state tr = Snocket { getLocalAddr -- return '0.0.0.0:0'. Left fd_ -> throwIO (ioe fd_) where - ioe :: FD_ m (TestAddress addr) -> IOError + ioe :: FD_ m -> IOError ioe fd_ = IOError { ioe_handle = Nothing , ioe_type = InvalidArgument @@ -869,14 +913,14 @@ mkSnocket state tr = Snocket { getLocalAddr , ioe_filename = Nothing } - getRemoteAddr :: FD m (TestAddress addr) -> m (TestAddress addr) + getRemoteAddr :: FD m -> m NetworkAddress getRemoteAddr fd = do maddr <- getRemoteAddrM fd case maddr of Right addr -> return addr Left fd_ -> throwIO (ioe fd_) where - ioe :: FD_ m (TestAddress addr) -> IOError + ioe :: FD_ m -> IOError ioe fd_ = IOError { ioe_handle = Nothing , ioe_type = InvalidArgument @@ -889,22 +933,28 @@ mkSnocket state tr = Snocket { getLocalAddr } - addrFamily :: TestAddress addr -> AddressFamily (TestAddress addr) - addrFamily _ = TestFamily + addrFamily :: NetworkAddress -> AddressFamily + addrFamily = \case + EphIPv4Addr {} -> AFInet + IPAddr IP.IPv4{} _ -> AFInet + UnusedAddr -> AFInet -- arbitrary choice + EphIPv6Addr {} -> AFInet6 + IPAddr IP.IPv6{} _ -> AFInet6 + LocalAddr addr -> AFLocal addr - open :: AddressFamily (TestAddress addr) -> m (FD m (TestAddress addr)) + open :: AddressFamily -> m (FD m) open _ = atomically $ do fdVar <- newTVar (FDUninitialised Nothing) labelTVar fdVar "fd" return FD { fdVar } - openToConnect :: TestAddress addr -> m (FD m (TestAddress addr)) - openToConnect _ = open TestFamily + openToConnect :: NetworkAddress -> m (FD m) + openToConnect = open . addrFamily - connect :: FD m (TestAddress addr) -> TestAddress addr -> m () + connect :: FD m -> NetworkAddress -> m () connect fd@FD { fdVar = fdVarLocal } remoteAddress = do fd_ <- readTVarIO fdVarLocal traceWith' fd (STConnecting fd_ remoteAddress) @@ -917,7 +967,7 @@ mkSnocket state tr = Snocket { getLocalAddr localAddress <- case mbLocalAddr of Just addr -> return addr - Nothing -> nsNextEphemeralAddr state (getAddressType remoteAddress) + Nothing -> nsNextEphemeralAddr state (addrFamily remoteAddress) let connId = ConnectionId { localAddress, remoteAddress } normalisedId = normaliseId connId @@ -1141,7 +1191,7 @@ mkSnocket state tr = Snocket { getLocalAddr , ioe_filename = Nothing } - connectIOError :: ConnectionId (TestAddress addr) -> String -> IOError + connectIOError :: ConnectionId NetworkAddress -> String -> IOError connectIOError connId desc = IOError { ioe_handle = Nothing , ioe_type = OtherError @@ -1154,7 +1204,7 @@ mkSnocket state tr = Snocket { getLocalAddr , ioe_filename = Nothing } - connectedIOError :: FD_ m (TestAddress addr) -> IOError + connectedIOError :: FD_ m -> IOError connectedIOError fd_ = IOError { ioe_handle = Nothing , ioe_type = AlreadyExists @@ -1166,7 +1216,7 @@ mkSnocket state tr = Snocket { getLocalAddr , ioe_filename = Nothing } - invalidError :: FD_ m (TestAddress addr) -> IOError + invalidError :: FD_ m -> IOError invalidError fd_ = IOError { ioe_handle = Nothing , ioe_type = InvalidArgument @@ -1179,7 +1229,7 @@ mkSnocket state tr = Snocket { getLocalAddr } - bind :: FD m (TestAddress addr) -> TestAddress addr -> m () + bind :: FD m -> NetworkAddress -> m () bind fd@FD { fdVar } addr = do res <- atomically $ do fd_ <- readTVar fdVar @@ -1207,7 +1257,7 @@ mkSnocket state tr = Snocket { getLocalAddr } - listen :: FD m (TestAddress addr) -> m () + listen :: FD m -> m () listen fd@FD { fdVar } = atomically $ do fd_ <- readTVar fdVar case fd_ of @@ -1234,7 +1284,7 @@ mkSnocket state tr = Snocket { getLocalAddr bound :: Natural bound = 10 - invalidError :: FD_ m (TestAddress addr) -> IOError + invalidError :: FD_ m -> IOError invalidError fd_ = IOError { ioe_handle = Nothing , ioe_type = InvalidArgument @@ -1247,17 +1297,16 @@ mkSnocket state tr = Snocket { getLocalAddr } - accept :: FD m (TestAddress addr) - -> m (Accept m (FD m (TestAddress addr)) - (TestAddress addr)) + accept :: FD m + -> m (Accept m (FD m) NetworkAddress) accept FD { fdVar } = do time <- getMonotonicTime let deltaAndIOErr = biAcceptFailures (nsDefaultBearerInfo state) return $ accept_ time deltaAndIOErr where -- non-blocking; return 'True' if a connection is in 'SYN_SENT' state - synSent :: TestAddress addr - -> ChannelWithInfo m (TestAddress addr) + synSent :: NetworkAddress + -> ChannelWithInfo m -> STM m Bool synSent localAddress cwi = do connMap <- readTVar (nsConnections state) @@ -1275,8 +1324,7 @@ mkSnocket state tr = Snocket { getLocalAddr accept_ :: Time -> Maybe (DiffTime, IOError) - -> Accept m (FD m (TestAddress addr)) - (TestAddress addr) + -> Accept m (FD m) NetworkAddress accept_ time deltaAndIOErr = Accept $ do ctime <- getMonotonicTime bracketOnError @@ -1400,7 +1448,7 @@ mkSnocket state tr = Snocket { getLocalAddr return (Accepted fdRemote remoteAddress, accept_ time deltaAndIOErr) - invalidError :: FD_ m (TestAddress addr) -> IOError + invalidError :: FD_ m -> IOError invalidError fd = IOError { ioe_handle = Nothing , ioe_type = InvalidArgument @@ -1413,7 +1461,7 @@ mkSnocket state tr = Snocket { getLocalAddr } - close :: FD m (TestAddress addr) + close :: FD m -> m () close FD { fdVar } = uninterruptibleMask_ $ do diff --git a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs index 904c2f58c57..6bdb12d3cf2 100644 --- a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs +++ b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Experiments.hs @@ -268,7 +268,7 @@ withInitiatorOnlyConnectionManager -- ^ series of request possible to do with the bidirectional connection -- manager towards some peer. -> CM.ConnStateIdSupply m - -> Maybe peerAddr + -> [peerAddr] -> TemperatureBundle (ConnectionId peerAddr -> STM m [req]) -- ^ Functions to get the next requests for a given connection -> ProtocolTimeLimits (Handshake UnversionedProtocol Term) @@ -280,7 +280,7 @@ withInitiatorOnlyConnectionManager -> m a) -> m a withInitiatorOnlyConnectionManager name timeouts trTracer tracer stdGen snocket makeBearer connStateIdSupply - localAddr nextRequests handshakeTimeLimits acceptedConnLimit k = do + localAddrs nextRequests handshakeTimeLimits acceptedConnLimit k = do mainThreadId <- myThreadId let muxTracers :: Mx.TracersWithBearer (ConnectionId peerAddr) m muxTracers = Mx.Tracers { @@ -317,9 +317,8 @@ withInitiatorOnlyConnectionManager name timeouts trTracer tracer stdGen snocket trTracer = (WithName name . fmap CM.abstractState) `contramap` trTracer, -- This is actually the low level bearer tracer - ipv4Address = localAddr, - ipv6Address = Nothing, - addressType = \_ -> Just IPv4Address, + ipv4Address = localAddrs, + ipv6Address = [], snocket, makeBearer, withBuffer = \f -> f Nothing, @@ -459,7 +458,7 @@ withBidirectionalConnectionManager -> (socket -> m ()) -- ^ configure socket -> socket -- ^ listening socket - -> Maybe peerAddr + -> [peerAddr] -> acc -- ^ Initial state for the server -> TemperatureBundle (ConnectionId peerAddr -> STM m [req]) @@ -482,7 +481,7 @@ withBidirectionalConnectionManager name timeouts stdGen snocket makeBearer connStateIdSupply confSock socket - localAddress + localAddresses accumulatorInit nextRequests handshakeTimeLimits acceptedConnLimit k = do @@ -516,9 +515,8 @@ withBidirectionalConnectionManager name timeouts trTracer = (WithName name . fmap CM.abstractState) `contramap` trTracer, -- low level bearer tracer - ipv4Address = localAddress, - ipv6Address = Nothing, - addressType = \_ -> Just IPv4Address, + ipv4Address = localAddresses, + ipv6Address = [], snocket, makeBearer, withBuffer = \f -> f Nothing, @@ -765,7 +763,7 @@ unidirectionalExperiment stdGen timeouts snocket makeBearer confSock socket clie nextReqs <- oneshotNextRequests clientAndServerData connStateIdSupply <- atomically $ CM.newConnStateIdSupply (Proxy @m) withInitiatorOnlyConnectionManager - "client" timeouts nullTracer nullTracer stdGen' snocket makeBearer connStateIdSupply Nothing nextReqs + "client" timeouts nullTracer nullTracer stdGen' snocket makeBearer connStateIdSupply [] nextReqs timeLimitsHandshake maxAcceptedConnectionsLimit $ \connectionManager -> withBidirectionalConnectionManager "server" timeouts @@ -773,7 +771,7 @@ unidirectionalExperiment stdGen timeouts snocket makeBearer confSock socket clie nullTracer Mx.nullTracers nullTracer stdGen'' snocket makeBearer connStateIdSupply - confSock socket Nothing + confSock socket [] [accumulatorInit clientAndServerData] noNextRequests timeLimitsHandshake @@ -859,7 +857,7 @@ bidirectionalExperiment nullTracer nullTracer nullTracer nullTracer Mx.nullTracers nullTracer stdGen' snocket makeBearer connStateIdSupply confSock - socket0 (Just localAddr0) + socket0 [localAddr0] [accumulatorInit clientAndServerData0] nextRequests0 noTimeLimitsHandshake @@ -869,7 +867,7 @@ bidirectionalExperiment nullTracer nullTracer nullTracer nullTracer Mx.nullTracers nullTracer stdGen'' snocket makeBearer connStateIdSupply confSock - socket1 (Just localAddr1) + socket1 [localAddr1] [accumulatorInit clientAndServerData1] nextRequests1 noTimeLimitsHandshake diff --git a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Timeouts.hs b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Timeouts.hs index 847b1940f59..de12c7191d3 100644 --- a/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Timeouts.hs +++ b/ouroboros-network/framework/tests-lib/Test/Ouroboros/Network/ConnectionManager/Timeouts.hs @@ -9,7 +9,6 @@ module Test.Ouroboros.Network.ConnectionManager.Timeouts ( verifyAllTimeouts , SimAddr - , SimAddr_ , TestAddr (..) , TestProperty (..) , ArbDataFlow (..) @@ -57,7 +56,6 @@ import Ouroboros.Network.ConnectionManager.Types import Ouroboros.Network.Driver.Limits (ProtocolTimeLimits (..)) import Ouroboros.Network.Protocol.Handshake.Codec (timeLimitsHandshake) import Ouroboros.Network.Protocol.Handshake.Type -import Ouroboros.Network.Snocket qualified as Snocket import Ouroboros.Network.Util (PrettyShow (..)) @@ -387,8 +385,7 @@ groupConnsEither getTransition isFinalTransition = -- | The concrete address type used by simulations. -- -type SimAddr = Snocket.TestAddress SimAddr_ -type SimAddr_ = Int +type SimAddr = Int -- | We use a wrapper for test addresses since the Arbitrary instance for Snocket.TestAddress only -- generates addresses between 1 and 4. @@ -396,7 +393,7 @@ newtype TestAddr = TestAddr { unTestAddr :: SimAddr } deriving (Show, Eq, Ord) instance Arbitrary TestAddr where - arbitrary = TestAddr . Snocket.TestAddress <$> choose (1, 100) + arbitrary = TestAddr <$> choose (1, 100) -- | Test property together with classification. diff --git a/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs b/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs index 4ed434a2876..c3e823ea750 100644 --- a/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs +++ b/ouroboros-network/lib/Ouroboros/Network/Diffusion.hs @@ -15,8 +15,9 @@ module Ouroboros.Network.Diffusion ( run , runM , mkInterfaces - , socketAddressType , module Ouroboros.Network.Diffusion.Types + -- * Utils + , readIPAndPort ) where @@ -41,9 +42,11 @@ import Data.Bits ((.|.)) import System.Posix.Files qualified as Unix #endif import Data.ByteString.Lazy (ByteString) +import Data.Either (partitionEithers) import Data.Hashable (Hashable) import Data.IP qualified as IP import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty qualified as NonEmpty import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (catMaybes) @@ -57,7 +60,6 @@ import Network.Mux qualified as Mx import Network.Mux.Bearer (withReadBufferIO) import Network.Mux.Types import Network.Socket (Socket) -import Network.Socket qualified as Socket import Ouroboros.Network.ConnectionHandler import Ouroboros.Network.ConnectionManager.Core qualified as CM @@ -92,12 +94,6 @@ import Ouroboros.Network.Socket (configureSocket, configureSystemdSocket) import Ouroboros.Network.Util (PrettyShow (..)) -socketAddressType :: Socket.SockAddr -> Maybe AddressType -socketAddressType Socket.SockAddrInet {} = Just IPv4Address -socketAddressType Socket.SockAddrInet6 {} = Just IPv6Address -socketAddressType Socket.SockAddrUnix {} = Nothing - - runM :: forall m ntnFd ntnAddr ntnVersion ntnVersionData ntcFd ntcAddr ntcVersion ntcVersionData @@ -167,7 +163,6 @@ runM Interfaces , diWithBuffer , diNtnConfigureSocket , diNtnConfigureSystemdSocket - , diNtnAddressType , diNtnToPeerAddr , diNtcSnocket , diNtcBearer @@ -221,8 +216,7 @@ runM Interfaces , daSRVPrefix } Configuration - { dcIPv4Address - , dcIPv6Address + { dcAddresses , dcLocalAddress , dcAcceptedConnectionsLimit , dcMode = diffusionMode @@ -369,9 +363,8 @@ runM Interfaces CM.with CM.Arguments { CM.tracer = dtLocalConnectionManagerTracer, CM.trTracer = nullTracer, -- TODO: issue #3320 - CM.ipv4Address = Nothing, - CM.ipv6Address = Nothing, - CM.addressType = const Nothing, + CM.ipv4Address = [], + CM.ipv6Address = [], CM.snocket = diNtcSnocket, CM.makeBearer = diNtcBearer, CM.withBuffer = diWithBuffer, @@ -424,31 +417,24 @@ runM Interfaces epErrorDelay = daRepromoteErrorDelay } - ipv4Address - <- traverse (either (Snocket.getLocalAddr diNtnSnocket) pure) - dcIPv4Address - case ipv4Address of - Just addr | Just IPv4Address <- diNtnAddressType addr - -> pure () - | otherwise - -> throwIO (UnexpectedIPv4Address addr) - Nothing -> pure () - - ipv6Address - <- traverse (either (Snocket.getLocalAddr diNtnSnocket) pure) - dcIPv6Address - case ipv6Address of - Just addr | Just IPv6Address <- diNtnAddressType addr - -> pure () - | otherwise - -> throwIO (UnexpectedIPv6Address addr) - Nothing -> pure () - - lookupReqs <- case (ipv4Address, ipv6Address) of - (Just _ , Nothing) -> return RootPeersDNS.LookupReqAOnly - (Nothing, Just _ ) -> return RootPeersDNS.LookupReqAAAAOnly - (Just _ , Just _ ) -> return RootPeersDNS.LookupReqAAndAAAA - (Nothing, Nothing) -> throwIO NoSocket + addrs <- (either (traverse $ Snocket.getLocalAddr diNtnSnocket) pure) dcAddresses + let (ipv4Addresses, ipv6Addresses) = + partitionEithers + $ catMaybes + $ map (\addr -> + case Snocket.addrFamily diNtnSnocket addr of + Snocket.AFInet -> Just $ Left addr + Snocket.AFInet6 -> Just $ Right addr + Snocket.AFLocal{} -> Nothing + ) + $ NonEmpty.toList + $ addrs + + lookupReqs <- case (ipv4Addresses, ipv6Addresses) of + (_:_, [] ) -> return RootPeersDNS.LookupReqAOnly + ([] , _:_) -> return RootPeersDNS.LookupReqAAAAOnly + (_:_, _:_) -> return RootPeersDNS.LookupReqAAndAAAA + ([] , [] ) -> throwIO NoSocket localRootsVar <- newTVarIO mempty @@ -493,9 +479,8 @@ runM Interfaces CM.trTracer = fmap CM.abstractState `contramap` dtConnectionManagerTransitionTracer, - CM.ipv4Address, - CM.ipv6Address, - CM.addressType = diNtnAddressType, + CM.ipv4Address = ipv4Addresses, + CM.ipv6Address = ipv6Addresses, CM.snocket = diNtnSnocket, CM.makeBearer = diNtnBearer, CM.withBuffer = diWithBuffer, @@ -727,11 +712,7 @@ runM Interfaces withSockets tracer diNtnSnocket (\sock addr -> diNtnConfigureSocket sock (Just addr)) (\sock addr -> diNtnConfigureSystemdSocket sock addr) - ( catMaybes - [ dcIPv4Address - , dcIPv6Address - ] - ) + dcAddresses f -- run node-to-node server @@ -946,7 +927,6 @@ mkInterfaces iocp tracer egressPollInterval = do diNtnConfigureSystemdSocket = configureSystemdSocket (SystemdSocketConfiguration `contramap` tracer), - diNtnAddressType = socketAddressType, diNtnToPeerAddr = curry IP.toSockAddr, diNtcSnocket = Snocket.localSnocket iocp, diNtcBearer = makeLocalBearer, diff --git a/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs b/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs index 8e81ecb13c6..cafe6dd20a2 100644 --- a/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs +++ b/ouroboros-network/lib/Ouroboros/Network/Diffusion/Types.hs @@ -470,13 +470,13 @@ data Arguments extraState extraDebugState extraFlags extraPeers -- | Required Diffusion Arguments to run network layer -- data Configuration extraFlags m ntnFd ntnAddr ntcFd ntcAddr = Configuration { - -- | an @IPv4@ socket ready to accept connections or an @IPv4@ addresses + -- | A list of IPv4, IPv6 addresses or systemd activated sockets. -- - dcIPv4Address :: Maybe (Either ntnFd ntnAddr) - - -- | an @IPv6@ socket ready to accept connections or an @IPv6@ addresses + -- The diffusion will run an inbound server on each of the + -- sockets/addresses. When creating outbound connections, a random local + -- address/interface will be used by the connection manager. -- - , dcIPv6Address :: Maybe (Either ntnFd ntnAddr) + dcAddresses :: Either (NonEmpty ntnFd) (NonEmpty ntnAddr) -- | an @AF_UNIX@ socket ready to accept connections or an @AF_UNIX@ -- socket path or name of `named-pipe` on `Windows`. @@ -760,11 +760,6 @@ data Interfaces ntnFd ntnAddr ntcFd ntcAddr diNtnConfigureSystemdSocket :: ntnFd -> ntnAddr -> m (), - -- | node-to-node address type - -- - diNtnAddressType - :: ntnAddr -> Maybe AddressType, - -- | node-to-node peer address -- diNtnToPeerAddr diff --git a/ouroboros-network/lib/Ouroboros/Network/Diffusion/Utils.hs b/ouroboros-network/lib/Ouroboros/Network/Diffusion/Utils.hs index f4b54bd9c1c..68bb5cb604e 100644 --- a/ouroboros-network/lib/Ouroboros/Network/Diffusion/Utils.hs +++ b/ouroboros-network/lib/Ouroboros/Network/Diffusion/Utils.hs @@ -9,20 +9,73 @@ module Ouroboros.Network.Diffusion.Utils ( withSockets , withLocalSocket + , readIPAndPort ) where +import Control.Applicative ((<|>)) import Control.Monad.Class.MonadThrow import Control.Tracer (Tracer, traceWith) +import Data.Bifunctor (first) +import Data.IP (IP (..), IPv4, IPv6) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NonEmpty import Data.Typeable (Typeable) +import Network.Socket (PortNumber) +import Options.Applicative (ReadM, eitherReader) +import Text.Read (readMaybe) import Ouroboros.Network.Snocket (FileDescriptor, Snocket) import Ouroboros.Network.Snocket qualified as Snocket import Ouroboros.Network.Diffusion.Types + +-- | optparse-applictive parser for `IPv4:Port` or `IPv6:Port`. +-- +-- note: `Read` instances for `IP`, `IPv4`, `IPv6` expect no trailing characters +-- after the address, thus we need custom parser which finds the split position +-- first. +readIPAndPort :: ReadM (IP, PortNumber) +readIPAndPort = (first IPv4 <$> readIPv4AndPort) + <|> (first IPv6 <$> readIPv6AndPort) + where + readIPv4AndPort :: ReadM (IPv4, PortNumber) + readIPv4AndPort = + eitherReader $ \s -> do + case splitWith ':' s of + Nothing -> Left s + Just (addrStr, portStr) -> + maybe (Left s) Right $ + (,) <$> readMaybe addrStr + <*> readMaybe portStr + + + -- parse IPv6 address and port in a form `[::1]:3001` or a UNIX file path + readIPv6AndPort :: ReadM (IPv6, PortNumber) + readIPv6AndPort = + eitherReader $ \s -> + case s of + ('[':s') -> + case splitWith ']' s' of + Just (addrStr, ':' : portStr) -> + maybe (Left s) Right $ + (,) <$> readMaybe addrStr + <*> readMaybe portStr + _ -> Left s + _ -> Left s + + splitWith :: Char -> String -> Maybe (String, String) + splitWith c = go "" + where + go _ [] + = Nothing + go !acc (a:as) + | a == c + = Just (reverse acc, as) + go !acc (a:as) + = go (a:acc) as + -- -- Socket utility functions -- @@ -36,13 +89,18 @@ withSockets :: forall m ntnFd ntnAddr ntcAddr a. -> Snocket m ntnFd ntnAddr -> (ntnFd -> ntnAddr -> m ()) -- ^ configure a socket -> (ntnFd -> ntnAddr -> m ()) -- ^ configure a systemd socket - -> [Either ntnFd ntnAddr] + -> Either (NonEmpty ntnFd) (NonEmpty ntnAddr) -> (NonEmpty ntnFd -> NonEmpty ntnAddr -> m a) -> m a -withSockets tracer sn + +-- create a socket for each address +withSockets tracer + sn configureSocket - configureSystemdSocket - addresses k = go [] addresses + _configureSystemdSocket + (Right addresses) k + = + go [] (NonEmpty.toList addresses) where go !acc (a : as) = withSocket a (\sa -> go (sa : acc) as) go [] [] = throwIO NoSocket @@ -50,15 +108,10 @@ withSockets tracer sn let acc' = NonEmpty.fromList (reverse acc) in (k $! (fst <$> acc')) $! (snd <$> acc') - withSocket :: Either ntnFd ntnAddr + withSocket :: ntnAddr -> ((ntnFd, ntnAddr) -> m a) -> m a - withSocket (Left sock) f = - do !addr <- Snocket.getLocalAddr sn sock - configureSystemdSocket sock addr - f (sock, addr) - `onException` Snocket.close sn sock - withSocket (Right addr) f = + withSocket addr f = bracket (do traceWith tracer (CreatingServerSocket addr) Snocket.open sn (Snocket.addrFamily sn addr)) @@ -72,6 +125,30 @@ withSockets tracer sn traceWith tracer $ ServerSocketUp addr f (sock, addr) +-- systemd activated socket +withSockets _tracer + sn + _configureSocket + configureSystemdSocket + (Left addresses) k + = + go [] (NonEmpty.toList addresses) + where + go !acc (a : as) = withSocket a (\sa -> go (sa : acc) as) + go [] [] = throwIO NoSocket + go !acc [] = + let acc' = NonEmpty.fromList (reverse acc) + in (k $! (fst <$> acc')) $! (snd <$> acc') + + withSocket :: ntnFd + -> ((ntnFd, ntnAddr) -> m a) + -> m a + withSocket sock f = + do !addr <- Snocket.getLocalAddr sn sock + configureSystemdSocket sock addr + f (sock, addr) + `onException` Snocket.close sn sock + withLocalSocket :: forall ntnAddr ntcFd ntcAddr m a. ( MonadThrow m diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 40c057d1f61..7af858aee51 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -31,6 +31,11 @@ flag nightly manual: False default: False +flag optparse-applicative-fork + description: Use optparse-applicative-fork + manual: True + default: False + source-repository head type: git location: https://github.com/intersectmbo/ouroboros-network @@ -335,6 +340,15 @@ library directory, unix, + -- Until https://github.com/IntersectMBO/cardano-cli/pull/1390 is merged we + -- need to allow for `optparse-applicative-fork` + if flag(optparse-applicative-fork) + build-depends: + optparse-applicative-fork + else + build-depends: + optparse-applicative + library framework import: ghc-options visibility: public @@ -377,7 +391,6 @@ library framework Ouroboros.Network.Server.Simple Ouroboros.Network.Snocket Ouroboros.Network.Socket - Simulation.Network.Snocket -- other-extensions: build-depends: @@ -504,6 +517,7 @@ library framework-tests-lib visibility: public hs-source-dirs: framework/tests-lib exposed-modules: + Simulation.Network.Snocket Test.Ouroboros.Network.ConnectionManager.Experiments Test.Ouroboros.Network.ConnectionManager.Timeouts Test.Ouroboros.Network.ConnectionManager.Utils @@ -523,7 +537,11 @@ library framework-tests-lib hashable, io-classes:{io-classes, si-timers, strict-stm}, io-sim, + iproute, + monoidal-synchronisation, + network, network-mux, + nothunks, ouroboros-network:{api, framework, tests-lib}, quickcheck-monoids, random, @@ -925,7 +943,7 @@ library protocols-tests-lib io-classes:{io-classes, si-timers, strict-stm}, io-sim, network-mux, - ouroboros-network:{api, api-tests-lib, framework, protocols, tests-lib}, + ouroboros-network:{api, api-tests-lib, framework, framework-tests-lib, protocols, tests-lib}, pipes, quickcheck-instances, serialise, @@ -981,7 +999,7 @@ library ouroboros-network-tests-lib network, network-mux, nothunks, - ouroboros-network:{ouroboros-network, api, api-tests-lib, framework, protocols, protocols-tests-lib, tests-lib}, + ouroboros-network:{ouroboros-network, api, api-tests-lib, framework, framework-tests-lib, protocols, protocols-tests-lib, tests-lib}, pretty-simple, quickcheck-monoids, random, diff --git a/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/Handshake/Test.hs b/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/Handshake/Test.hs index 450db9fe84c..642c0d7eb74 100644 --- a/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/Handshake/Test.hs +++ b/ouroboros-network/protocols/tests-lib/Ouroboros/Network/Protocol/Handshake/Test.hs @@ -53,7 +53,6 @@ import Ouroboros.Network.Channel import Ouroboros.Network.CodecCBORTerm import Ouroboros.Network.Driver.Simple (runConnectedPeers, runConnectedPeersAsymmetric, runPeer) -import Ouroboros.Network.Snocket (TestAddress (..)) import Ouroboros.Network.Snocket qualified as Snocket import Simulation.Network.Snocket @@ -840,21 +839,21 @@ prop_channel_simultaneous_open_sim codec versionDataCodec attenuation Map.empty $ \sn _ -> do - let addr, addr' :: TestAddress Int - addr = Snocket.TestAddress 1 - addr' = Snocket.TestAddress 2 + let addr, addr' :: NetworkAddress + addr = EphIPv4Addr 1 + addr' = EphIPv4Addr 2 -- listening snockets - bracket (Snocket.open sn Snocket.TestFamily) + bracket (Snocket.open sn Snocket.AFInet) (Snocket.close sn) $ \fdLst -> - bracket (Snocket.open sn Snocket.TestFamily) + bracket (Snocket.open sn Snocket.AFInet) (Snocket.close sn) $ \fdLst' -> do Snocket.bind sn fdLst addr Snocket.bind sn fdLst' addr' Snocket.listen sn fdLst Snocket.listen sn fdLst' -- connection snockets - bracket ((,) <$> Snocket.open sn Snocket.TestFamily - <*> Snocket.open sn Snocket.TestFamily + bracket ((,) <$> Snocket.open sn Snocket.AFInet + <*> Snocket.open sn Snocket.AFInet ) (\(fdConn, fdConn') -> -- we need concurrently close both sockets: they need to @@ -886,8 +885,7 @@ prop_channel_simultaneous_open_sim codec versionDataCodec serverVersions -prop_channel_simultaneous_open_SimNet :: ArbitraryVersions - -> Property +prop_channel_simultaneous_open_SimNet :: ArbitraryVersions -> Property prop_channel_simultaneous_open_SimNet (ArbitraryVersions clientVersions serverVersions) = runSimOrThrow $ prop_channel_simultaneous_open_sim diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs index 30d7823744f..af0557cfbe8 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node.hs @@ -15,14 +15,12 @@ module Test.Ouroboros.Network.Diffusion.Node , run -- * node types , NtNAddr - , NtNFD , NtNVersion , NtNVersionData , NtCAddr - , NtCFD , NtCVersion , NtCVersionData - , Node.NtNAddr_ (..) + , NetworkAddress (..) -- * extra types used by the node , AcceptedConnectionsLimit (..) , DiffusionMode (..) @@ -52,6 +50,7 @@ import Control.Tracer (Tracer (..), nullTracer) import Codec.CBOR.Term qualified as CBOR import Data.Foldable as Foldable (foldl') import Data.IP (IP (..)) +import Data.List.NonEmpty qualified as NonEmpty import Data.Map (Map) import Data.Set (Set) import Data.Set qualified as Set @@ -106,15 +105,14 @@ import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency, LocalRootConfig, WarmValency) import Ouroboros.Network.PeerSelection.Types (PublicExtraPeersAPI (..)) import Ouroboros.Network.Server.RateLimiting (AcceptedConnectionsLimit (..)) -import Ouroboros.Network.Snocket (MakeBearer, Snocket, TestAddress (..), - invalidFileDescriptor) +import Ouroboros.Network.Snocket (MakeBearer, Snocket, invalidFileDescriptor) import Ouroboros.Network.Util (PrettyShow (..)) import Ouroboros.Network.TxSubmission.Inbound.V2.Policy (TxDecisionPolicy) import Ouroboros.Network.TxSubmission.Inbound.V2.Registry (txCountersThreadV2) import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TraceTxLogic) -import Simulation.Network.Snocket (AddressType (..), FD) +import Simulation.Network.Snocket (FD, NetworkAddress (..)) import Test.Ouroboros.Network.Data.Script import Test.Ouroboros.Network.Diffusion.Node.ChainDB (addBlock, @@ -131,12 +129,11 @@ import Test.Ouroboros.Network.TxSubmission.Types (Tx) data Interfaces extraAPI m = Interfaces - { iNtnSnocket :: Snocket m (NtNFD m) NtNAddr - , iNtnBearer :: MakeBearer m (NtNFD m) + { iSnocket :: Snocket m (FD m) NetworkAddress + , iNtnBearer :: MakeBearer m (FD m) , iAcceptVersion :: NtNVersionData -> NtNVersionData -> Accept NtNVersionData , iNtnDomainResolver :: DNSLookupType -> [DomainAccessPoint] -> m (Map DomainAccessPoint (Set NtNAddr)) - , iNtcSnocket :: Snocket m (NtCFD m) NtCAddr - , iNtcBearer :: MakeBearer m (NtCFD m) + , iNtcBearer :: MakeBearer m (FD m) , iRng :: StdGen , iDomainMap :: StrictTVar m (Map (Domain, TYPE) MockDNSLookupResult) , iLedgerPeersConsensusInterface @@ -145,9 +142,6 @@ data Interfaces extraAPI m = Interfaces , iSRVPrefix :: SRVPrefix } -type NtNFD m = FD m NtNAddr -type NtCFD m = FD m NtCAddr - data Arguments extraChurnArgs extraFlags m = Arguments { aIPAddress :: NtNAddr , aAcceptedLimits :: AcceptedConnectionsLimit @@ -263,19 +257,18 @@ run blockGeneratorArgs ni na dnsLookupDelayScriptVar <- newTVarIO (aDNSLookupDelayScript na) let -- diffusion interfaces - interfaces :: Diffusion.Interfaces (NtNFD m) NtNAddr - (NtCFD m) NtCAddr + interfaces :: Diffusion.Interfaces (FD m) NtNAddr + (FD m) NtCAddr resolver m interfaces = Diffusion.Interfaces - { Diffusion.diNtnSnocket = iNtnSnocket ni + { Diffusion.diNtnSnocket = iSnocket ni , Diffusion.diNtnBearer = iNtnBearer ni , Diffusion.diWithBuffer = \f -> f Nothing , Diffusion.diNtnConfigureSocket = \_ _ -> return () , Diffusion.diNtnConfigureSystemdSocket = \_ _ -> return () - , Diffusion.diNtnAddressType = ntnAddressType - , Diffusion.diNtnToPeerAddr = \a b -> TestAddress (Node.IPAddr a b) - , Diffusion.diNtcSnocket = iNtcSnocket ni + , Diffusion.diNtnToPeerAddr = \a b -> Node.IPAddr a b + , Diffusion.diNtcSnocket = iSnocket ni , Diffusion.diNtcBearer = iNtcBearer ni , Diffusion.diNtcGetFileDescriptor = \_ -> pure invalidFileDescriptor , Diffusion.diNtcConfigureSocketFile = \_ -> pure () @@ -423,13 +416,6 @@ run blockGeneratorArgs ni na . map blockHeader . toOldestFirst - ntnAddressType :: NtNAddr -> Maybe AddressType - ntnAddressType (TestAddress (Node.EphemeralIPv4Addr _)) = Just IPv4Address - ntnAddressType (TestAddress (Node.EphemeralIPv6Addr _)) = Just IPv6Address - ntnAddressType (TestAddress (Node.IPAddr (IPv4 _) _)) = Just IPv4Address - ntnAddressType (TestAddress (Node.IPAddr (IPv6 _) _)) = Just IPv6Address - ntnAddressType (TestAddress Node.UnusedAddr) = Just IPv4Address - -- various pseudo random generators (diffStgGen, keepAliveStdGen) = splitGen (iRng ni) @@ -456,10 +442,11 @@ run blockGeneratorArgs ni na decodeData _ _ = Left (Text.pack "unversionedDataCodec: unexpected term") mkArgs :: StrictTVar m (PublicPeerSelectionState NtNAddr) - -> Diffusion.Configuration extraFlags m (NtNFD m) NtNAddr (NtCFD m) NtCAddr + -> Diffusion.Configuration extraFlags m (FD m) NtNAddr (FD m) NtCAddr mkArgs dcPublicPeerSelectionVar = Diffusion.Configuration - { Diffusion.dcIPv4Address = Right <$> (ntnToIPv4 . aIPAddress) na - , Diffusion.dcIPv6Address = Right <$> (ntnToIPv6 . aIPAddress) na + { Diffusion.dcAddresses = Right $ NonEmpty.fromList $ + (ntnToIPv4 . aIPAddress $ na) + ++ (ntnToIPv6 . aIPAddress $ na) , Diffusion.dcLocalAddress = Nothing , Diffusion.dcAcceptedConnectionsLimit = aAcceptedLimits na @@ -482,15 +469,15 @@ run blockGeneratorArgs ni na --- Utils -ntnToIPv4 :: NtNAddr -> Maybe NtNAddr -ntnToIPv4 ntnAddr@(TestAddress (Node.EphemeralIPv4Addr _)) = Just ntnAddr -ntnToIPv4 ntnAddr@(TestAddress (Node.IPAddr (IPv4 _) _)) = Just ntnAddr -ntnToIPv4 (TestAddress _) = Nothing +ntnToIPv4 :: NtNAddr -> [NtNAddr] +ntnToIPv4 ntnAddr@(Node.EphIPv4Addr _) = [ntnAddr] +ntnToIPv4 ntnAddr@(Node.IPAddr (IPv4 _) _) = [ntnAddr] +ntnToIPv4 _ = [] -ntnToIPv6 :: NtNAddr -> Maybe NtNAddr -ntnToIPv6 ntnAddr@(TestAddress (Node.EphemeralIPv6Addr _)) = Just ntnAddr -ntnToIPv6 ntnAddr@(TestAddress (Node.IPAddr (IPv6 _) _)) = Just ntnAddr -ntnToIPv6 (TestAddress _) = Nothing +ntnToIPv6 :: NtNAddr -> [NtNAddr] +ntnToIPv6 ntnAddr@(Node.EphIPv6Addr _) = [ntnAddr] +ntnToIPv6 ntnAddr@(Node.IPAddr (IPv6 _) _) = [ntnAddr] +ntnToIPv6 _ = [] -- -- Constants diff --git a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs index 66ccd7c1bb2..03f40cb25ea 100644 --- a/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs +++ b/ouroboros-network/tests/lib/Test/Ouroboros/Network/Diffusion/Node/Kernel.hs @@ -9,7 +9,7 @@ module Test.Ouroboros.Network.Diffusion.Node.Kernel ( -- * Common types NtNAddr - , NtNAddr_ (..) + , NetworkAddress (..) , encodeNtNAddr , decodeNtNAddr , ntnAddrToRelayAccessPoint @@ -34,7 +34,7 @@ import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM qualified as LazySTM import Control.Concurrent.Class.MonadSTM.Strict import Control.DeepSeq (NFData (..)) -import Control.Monad (replicateM, when) +import Control.Monad (when) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow @@ -44,15 +44,13 @@ import Control.Monad.Class.MonadTimer.SI import Codec.CBOR.Decoding qualified as CBOR import Codec.CBOR.Encoding qualified as CBOR import Data.ByteString.Char8 qualified as BSC -import Data.Hashable (Hashable) -import Data.IP (IP (..), fromIPv4w, fromIPv6w, toIPv4, toIPv4w, toIPv6, toIPv6w) +import Data.IP (IP (..)) import Data.IP qualified as IP import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Monoid.Synchronisation import Data.Void (Void) import GHC.Generics (Generic) -import Numeric.Natural (Natural) import System.Random (RandomGen, SplitGen, StdGen) import System.Random qualified as Random @@ -70,7 +68,7 @@ import Ouroboros.Network.Mock.ConcreteBlock (Block) import Ouroboros.Network.Mock.ConcreteBlock qualified as ConcreteBlock import Ouroboros.Network.Mock.ProducerState -import Simulation.Network.Snocket (AddressType (..), GlobalAddressScheme (..)) +import Simulation.Network.Snocket (NetworkAddress (..)) import Ouroboros.Network.PeerSelection (PeerSharing, RelayAccessPoint (..)) import Ouroboros.Network.PeerSelection.Governor (PublicPeerSelectionState, @@ -79,7 +77,6 @@ import Ouroboros.Network.PeerSharing (PeerSharingAPI, PeerSharingRegistry (..), newPeerSharingAPI, newPeerSharingRegistry, ps_POLICY_PEER_SHARE_MAX_PEERS, ps_POLICY_PEER_SHARE_STICKY_TIME) import Ouroboros.Network.Protocol.Handshake.Unversioned -import Ouroboros.Network.Snocket (TestAddress (..)) import Ouroboros.Network.TxSubmission.Inbound.V2.Registry (PeerTxRegistry, SharedTxStateVar, TxSubmissionCountersVar, newPeerTxRegistry, newSharedTxStateVar, newTxSubmissionCountersVar) @@ -90,64 +87,9 @@ import Test.Ouroboros.Network.Diffusion.Node.ChainDB (ChainDB (..)) import Test.Ouroboros.Network.Diffusion.Node.ChainDB qualified as ChainDB import Test.Ouroboros.Network.OrphanInstances () import Test.Ouroboros.Network.TxSubmission.Types (Mempool, Tx, newMempool) -import Test.QuickCheck (Arbitrary (..), choose, chooseInt, frequency, oneof) --- | Node-to-node address type. --- -data NtNAddr_ - = EphemeralIPv4Addr Natural - | EphemeralIPv6Addr Natural - | IPAddr IP.IP PortNumber - | UnusedAddr - deriving (Eq, Ord, Generic) - --- we need to work around the lack of the `NFData IP` instance -instance NFData NtNAddr_ where - rnf (EphemeralIPv4Addr p) = p `seq` () - rnf (EphemeralIPv6Addr p) = p `seq` () - rnf (IPAddr (IP.IPv4 ip) port) = ip `seq` port `seq` () - rnf (IPAddr (IP.IPv6 ip) port) = rnf (IP.fromIPv6w ip) `seq` port `seq` () - rnf UnusedAddr = () - -instance Arbitrary NtNAddr_ where - arbitrary = do - -- TODO: Move this IP generator to ouroboros-network-testing - a <- oneof [ IPv6 . toIPv6 <$> replicateM 8 (choose (0,0xffff)) - , IPv4 . toIPv4 <$> replicateM 4 (choose (0,255)) - ] - frequency - [ (1 , EphemeralIPv4Addr . fromInteger <$> arbitrary) - , (1 , EphemeralIPv6Addr . fromInteger <$> arbitrary) - , (3 , IPAddr a . read . show <$> chooseInt (0, 9999)) - ] - -instance Show NtNAddr_ where - show (EphemeralIPv4Addr n) = "EphemeralIPv4Addr " ++ show n - show (EphemeralIPv6Addr n) = "EphemeralIPv6Addr " ++ show n - show (IPAddr ip port) = "IPAddr (read \"" ++ show ip ++ "\") " ++ show port - show UnusedAddr = "UnusedAddr" - -instance PrettyShow NtNAddr_ where - prettyShow (EphemeralIPv4Addr n) = "eph.v4." ++ show n - prettyShow (EphemeralIPv6Addr n) = "eph.v6" ++ show n - prettyShow (IPAddr ip port) = show ip ++ ":" ++ show port - prettyShow UnusedAddr = "UnusedAddr" - -instance GlobalAddressScheme NtNAddr_ where - getAddressType (TestAddress addr) = - case addr of - EphemeralIPv4Addr _ -> IPv4Address - EphemeralIPv6Addr _ -> IPv6Address - IPAddr (IP.IPv4 {}) _ -> IPv4Address - IPAddr (IP.IPv6 {}) _ -> IPv6Address - UnusedAddr -> IPv4Address - ephemeralAddress IPv4Address = TestAddress . EphemeralIPv4Addr - ephemeralAddress IPv6Address = TestAddress . EphemeralIPv6Addr - -instance Hashable NtNAddr_ - -type NtNAddr = TestAddress NtNAddr_ +type NtNAddr = NetworkAddress type NtNVersion = UnversionedProtocol data NtNVersionData = NtNVersionData { ntnDiffusionMode :: DiffusionMode @@ -171,43 +113,44 @@ instance Acceptable NtNVersionData where ntnPeerSharing = ntnPeerSharing <> ntnPeerSharing' } -type NtCAddr = TestAddress Int +type NtCAddr = NetworkAddress type NtCVersion = UnversionedProtocol type NtCVersionData = UnversionedProtocolData ntnAddrToRelayAccessPoint :: NtNAddr -> Maybe RelayAccessPoint -ntnAddrToRelayAccessPoint (TestAddress (IPAddr ip port)) = +ntnAddrToRelayAccessPoint (IPAddr ip port) = Just (RelayAccessAddress ip port) ntnAddrToRelayAccessPoint _ = Nothing -encodeNtNAddr :: NtNAddr -> CBOR.Encoding -encodeNtNAddr (TestAddress (EphemeralIPv4Addr nat)) = CBOR.encodeListLen 2 - <> CBOR.encodeWord 0 - <> CBOR.encodeWord (fromIntegral nat) -encodeNtNAddr (TestAddress (EphemeralIPv6Addr nat)) = CBOR.encodeListLen 2 - <> CBOR.encodeWord 1 - <> CBOR.encodeWord (fromIntegral nat) -encodeNtNAddr (TestAddress (IPAddr ip pn)) = CBOR.encodeListLen 3 +encodeNtNAddr :: NetworkAddress -> CBOR.Encoding +encodeNtNAddr (EphIPv4Addr nat) = CBOR.encodeListLen 2 + <> CBOR.encodeWord 0 + <> CBOR.encodeWord (fromIntegral nat) +encodeNtNAddr (EphIPv6Addr nat) = CBOR.encodeListLen 2 + <> CBOR.encodeWord 1 + <> CBOR.encodeWord (fromIntegral nat) +encodeNtNAddr (IPAddr ip pn) = CBOR.encodeListLen 3 <> CBOR.encodeWord 2 <> encodeIP ip <> encodePortNumber pn -encodeNtNAddr (TestAddress UnusedAddr) = error "impossible" +encodeNtNAddr (UnusedAddr) = error "impossible" +encodeNtNAddr LocalAddr{} = error "invariant violation" decodeNtNAddr :: CBOR.Decoder s NtNAddr decodeNtNAddr = do _ <- CBOR.decodeListLen tok <- CBOR.decodeWord case tok of - 0 -> TestAddress . EphemeralIPv4Addr . fromIntegral <$> CBOR.decodeWord - 1 -> TestAddress . EphemeralIPv6Addr . fromIntegral <$> CBOR.decodeWord - 2 -> TestAddress <$> (IPAddr <$> decodeIP <*> decodePortNumber) + 0 -> EphIPv4Addr . fromIntegral <$> CBOR.decodeWord + 1 -> EphIPv6Addr . fromIntegral <$> CBOR.decodeWord + 2 -> IPAddr <$> decodeIP <*> decodePortNumber _ -> fail ("decodeNtNAddr: unknown tok:" ++ show tok) encodeIP :: IP -> CBOR.Encoding encodeIP (IPv4 ip) = CBOR.encodeListLen 2 <> CBOR.encodeWord 0 - <> CBOR.encodeWord32 (fromIPv4w ip) -encodeIP (IPv6 ip) = case fromIPv6w ip of + <> CBOR.encodeWord32 (IP.fromIPv4w ip) +encodeIP (IPv6 ip) = case IP.fromIPv6w ip of (w1, w2, w3, w4) -> CBOR.encodeListLen 5 <> CBOR.encodeWord 1 <> CBOR.encodeWord32 w1 @@ -220,13 +163,13 @@ decodeIP = do _ <- CBOR.decodeListLen tok <- CBOR.decodeWord case tok of - 0 -> IPv4 . toIPv4w <$> CBOR.decodeWord32 + 0 -> IPv4 . IP.toIPv4w <$> CBOR.decodeWord32 1 -> do w1 <- CBOR.decodeWord32 w2 <- CBOR.decodeWord32 w3 <- CBOR.decodeWord32 w4 <- CBOR.decodeWord32 - return (IPv6 (toIPv6w (w1, w2, w3, w4))) + return (IPv6 (IP.toIPv6w (w1, w2, w3, w4))) _ -> fail ("decodeIP: unknown tok:" ++ show tok)