sim-net: provide GlobalAddressScheme type class

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,21 +338,19 @@ withSnocket
        , MonadTime  m
        , MonadTimer m
        , MonadThrow (STM m)
-       , Enum     peerAddr
+       , GlobalAddressScheme peerAddr
        , Ord      peerAddr
        , Typeable peerAddr
        , Show     peerAddr
        )
     => 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)

ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs

@@ -759,7 +759,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
@@ -912,7 +912,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 >>
@@ -1571,7 +1571,6 @@ prop_multinode_Sim serverAcc (ArbDataFlow dataFlow) script =
             mb <- timeout 7200
                     ( withSnocket debugTracer
                                   (singletonScript noAttenuation)
-                                  (Snocket.TestAddress 10)
                     $ \snocket ->
                        multinodeExperiment (Tracer traceM)
                                            snocket

ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs

@@ -184,7 +184,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)
         return (Just res)

ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/Handshake/Test.hs

@@ -997,9 +997,10 @@ prop_channel_simultaneous_open_sim codec versionDataCodec
     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 ->

ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs

@@ -53,8 +53,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 (..))
@@ -178,7 +177,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 (Node.IPAddr a b)
               , Diff.P2P.diNtnDomainResolver     = iNtnDomainResolver ni
               , Diff.P2P.diNtcSnocket            = iNtcSnocket ni
               , Diff.P2P.diNtcHandshakeArguments =

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