diff --git a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs index 5707244fdb2..9981b8d59ce 100644 --- a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs +++ b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiWayIf #-} @@ -33,6 +34,9 @@ module Simulation.Network.Snocket , Script (..) , singletonScript , SDUSize + + , GlobalAddressScheme (..) + , AddressType (..) ) where import Prelude hiding (read) @@ -63,6 +67,7 @@ import Network.Mux.Types (MuxBearer, SDUSize (..)) import Network.Mux.Trace (MuxTrace) import Ouroboros.Network.ConnectionId +import Ouroboros.Network.ConnectionManager.Types (AddressType (..)) import Ouroboros.Network.Snocket @@ -194,7 +199,7 @@ data NetworkState m addr = NetworkState { -- | Get an unused ephemeral address. -- - nsNextEphemeralAddr :: STM m addr, + nsNextEphemeralAddr :: AddressType -> STM m addr, nsBearerInfo :: LazySTM.TVar m (Script BearerInfo) @@ -266,25 +271,27 @@ noAttenuation = BearerInfo { biConnectionDelay = 0 -- newNetworkState :: forall m peerAddr. - ( MonadSTM m - , Enum peerAddr + ( MonadSTM m + , GlobalAddressScheme peerAddr ) => Script BearerInfo - -> peerAddr -- ^ the largest ephemeral address -> m (NetworkState m (TestAddress peerAddr)) -newNetworkState bearerInfoScript peerAddr = atomically $ +newNetworkState bearerInfoScript = atomically $ do + (v :: StrictTVar m Natural) <- newTVar 0 + let nextEphemeralAddr :: AddressType -> STM m (TestAddress peerAddr) + nextEphemeralAddr addrType = 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) NetworkState -- nsListeningFDs <$> newTVar Map.empty -- nsConnections <*> newTVar Map.empty -- nsNextEphemeralAddr - <*> do (v :: StrictTVar m peerAddr) <- newTVar peerAddr - return $ do - a <- readTVar v - writeTVar v (pred a) - return (TestAddress a) + <*> pure nextEphemeralAddr -- nsBearerInfo <*> initScriptSTM bearerInfoScript @@ -298,6 +305,27 @@ instance (Typeable addr, Show addr) => Exception (ResourceException addr) +-- | A type class for global IP address scheme. Every node in the simulation +-- has an ephemeral address. Every node in the simulation has an implicity ipv4 +-- and ipv6 address (if one is not bound by explicitly). +-- +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 + + -- | 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'. @@ -310,7 +338,7 @@ withSnocket , MonadTime m , MonadTimer m , MonadThrow (STM m) - , Enum peerAddr + , GlobalAddressScheme peerAddr , Ord peerAddr , Typeable peerAddr , Show peerAddr @@ -318,13 +346,11 @@ withSnocket => Tracer m (WithAddr (TestAddress peerAddr) (SnocketTrace m (TestAddress peerAddr))) -> Script BearerInfo - -> TestAddress peerAddr - -- ^ the largest ephemeral address -> (Snocket m (FD m (TestAddress peerAddr)) (TestAddress peerAddr) -> m a) -> m a -withSnocket tr script (TestAddress peerAddr) k = do - st <- newNetworkState script peerAddr +withSnocket tr script k = do + st <- newNetworkState script a <- k (mkSnocket st tr) `catch` \e -> do re <- checkResources st (Just e) @@ -500,6 +526,7 @@ mkSnocket :: forall m addr. , MonadMask m , MonadTime m , MonadTimer m + , GlobalAddressScheme addr , Ord addr , Show addr ) @@ -627,7 +654,7 @@ mkSnocket state tr = Snocket { getLocalAddr localAddress <- case mbLocalAddr of Just addr -> return addr - Nothing -> nsNextEphemeralAddr state + Nothing -> nsNextEphemeralAddr state (getAddressType remoteAddress) let connId = ConnectionId { localAddress, remoteAddress } conMap <- readTVar (nsConnections state) diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs index 9cb8ef78bd4..054c095da17 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs @@ -756,7 +756,7 @@ prop_unidirectional_Sim clientAndServerData = simulatedPropertyWithTimeout 7200 $ withSnocket nullTracer (singletonScript noAttenuation) - (Snocket.TestAddress 10) $ \snock -> + $ \ snock -> bracket (Snocket.open snock Snocket.TestFamily) (Snocket.close snock) $ \fd -> do Snocket.bind snock fd serverAddr @@ -909,7 +909,7 @@ prop_bidirectional_Sim (NonFailingBearerInfoScript script) data0 data1 = simulatedPropertyWithTimeout 7200 $ withSnocket debugTracer script' - (Snocket.TestAddress 10) $ \snock -> + $ \ snock -> bracket ((,) <$> Snocket.open snock Snocket.TestFamily <*> Snocket.open snock Snocket.TestFamily) (\ (socket0, socket1) -> Snocket.close snock socket0 >> @@ -1567,7 +1567,6 @@ prop_multinode_Sim serverAcc (ArbDataFlow dataFlow) script = mb <- timeout 7200 ( withSnocket debugTracer (singletonScript noAttenuation) - (Snocket.TestAddress 10) $ \snocket -> multinodeExperiment (Tracer traceM) snocket diff --git a/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs b/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs index 50e603a35b0..b13e665bb4d 100644 --- a/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs +++ b/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs @@ -186,7 +186,7 @@ clientServerSimulation -> [payload] -> m (Maybe Bool) clientServerSimulation script payloads = - withSnocket nullTracer script (TestAddress 0) $ \snocket -> + withSnocket nullTracer script $ \snocket -> withAsync (server snocket) $ \_serverAsync -> do res <- untilSuccess (client snocket) say $ "SIMULATION RESULT: " ++ show res diff --git a/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/Handshake/Test.hs b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/Handshake/Test.hs index 376b5c90e8f..0a739f37b33 100644 --- a/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/Handshake/Test.hs +++ b/ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/Handshake/Test.hs @@ -634,9 +634,10 @@ prop_channel_simultaneous_open_SimNet let attenuation = noAttenuation { biConnectionDelay = 1 } in withSnocket nullTracer (singletonScript attenuation) - (TestAddress (0 :: Int)) $ \sn -> do - let addr = Snocket.TestAddress 1 - addr' = Snocket.TestAddress 2 + $ \sn -> do + let addr, addr' :: TestAddress Int + addr = TestAddress 1 + addr' = TestAddress 3 -- listening snockets bracket (Snocket.open sn Snocket.TestFamily) (Snocket.close sn) $ \fdLst -> diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs index 06c245c0c1f..6495f1f9175 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs @@ -52,8 +52,7 @@ import Network.DNS (Domain) import Network.Mux.Bearer.AttenuatedChannel (CloseError) import Ouroboros.Network.BlockFetch.Decision (FetchMode (..)) -import Ouroboros.Network.ConnectionManager.Types (AddressType (..), - DataFlow (..)) +import Ouroboros.Network.ConnectionManager.Types (DataFlow (..)) import qualified Ouroboros.Network.Diffusion as Diff import qualified Ouroboros.Network.Diffusion.P2P as Diff.P2P import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..)) @@ -80,8 +79,8 @@ import Ouroboros.Network.Testing.ConcreteBlock (Block) import Simulation.Network.Snocket import Test.Ouroboros.Network.Diffusion.Node.NodeKernel (NtNAddr, - NtNVersion, NtNVersionData (..), NtCAddr, NtCVersion, - NtCVersionData) + NtNAddr_ (..), NtNVersion, NtNVersionData (..), NtCAddr, + NtCVersion, NtCVersionData) import Test.Ouroboros.Network.PeerSelection.RootPeersDNS (mockDNSActions) import qualified Test.Ouroboros.Network.Diffusion.Node.NodeKernel as Node import qualified Test.Ouroboros.Network.Diffusion.Node.MiniProtocols as Node @@ -171,7 +170,7 @@ run blockGeneratorArgs limits ni na = case ntnDiffusionMode of InitiatorOnlyDiffusionMode -> Unidirectional InitiatorAndResponderDiffusionMode -> Duplex - , Diff.P2P.diNtnToPeerAddr = \a b -> TestAddress (a, b) + , Diff.P2P.diNtnToPeerAddr = \a b -> TestAddress (IPAddr a b) , Diff.P2P.diNtnDomainResolver = iNtnDomainResolver ni , Diff.P2P.diNtcSnocket = iNtcSnocket ni , Diff.P2P.diNtcHandshakeArguments = diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs index 114111720ca..a93b5a93a49 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs @@ -7,6 +7,7 @@ module Test.Ouroboros.Network.Diffusion.Node.NodeKernel ( -- * Common types NtNAddr + , NtNAddr_ (..) , NtNVersion , NtNVersionData (..) , NtCAddr @@ -37,6 +38,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Typeable (Typeable) import Data.Void (Void) +import Numeric.Natural (Natural) import System.Random (StdGen, randomR) @@ -58,8 +60,34 @@ import Ouroboros.Network.Snocket (TestAddress (..)) import Ouroboros.Network.Testing.ConcreteBlock (Block) import qualified Ouroboros.Network.Testing.ConcreteBlock as ConcreteBlock +import Simulation.Network.Snocket (AddressType (..), + GlobalAddressScheme (..)) -type NtNAddr = TestAddress (IP.IP, PortNumber) + +-- | Node-to-node address type. +-- +data NtNAddr_ + = EphemeralIPv4Addr Natural + | EphemeralIPv6Addr Natural + | IPAddr IP.IP PortNumber + deriving (Eq, Ord) + +instance Show NtNAddr_ where + show (EphemeralIPv4Addr n) = "ephemeral:" ++ show n + show (EphemeralIPv6Addr n) = "ephemeral6:" ++ show n + show (IPAddr ip port) = show ip ++ ":" ++ show port + +instance GlobalAddressScheme NtNAddr_ where + getAddressType (TestAddress addr) = + case addr of + EphemeralIPv4Addr _ -> IPv4Address + EphemeralIPv6Addr _ -> IPv6Address + IPAddr (IP.IPv4 {}) _ -> IPv4Address + IPAddr (IP.IPv6 {}) _ -> IPv6Address + ephemeralAddress IPv4Address = TestAddress . EphemeralIPv4Addr + ephemeralAddress IPv6Address = TestAddress . EphemeralIPv6Addr + +type NtNAddr = TestAddress NtNAddr_ type NtNVersion = UnversionedProtocol data NtNVersionData = NtNVersionData { ntnDiffusionMode :: DiffusionMode } type NtCAddr = TestAddress Int