Added read-only ObservableNetworkState in Snocket

IntersectMBO · Nov 30, 2021 · 0f399e3 · 0f399e3
1 parent 2c05038
commit 0f399e3
Show file tree

Hide file tree

Showing 4 changed files with 24 additions and 7 deletions.
diff --git a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs
@@ -23,12 +23,14 @@ module Simulation.Network.Snocket
   (
   -- * Simulated Snocket
     withSnocket
+  , ObservableNetworkState (..)
   , ResourceException (..)
   , SnocketTrace (..)
   , TimeoutDetail (..)
   , SockType (..)
   , OpenType (..)
 
+  , NormalisedId (..)
   , BearerInfo (..)
   , IOErrType (..)
   , IOErrThrowOrReturn (..)
@@ -207,6 +209,15 @@ data NetworkState m addr = NetworkState {
 
     }
 
+-- | Simulation accessible network environment consumed by 'simSnocket'.
+--
+newtype ObservableNetworkState addr = ObservableNetworkState {
+      -- | Registry of active connections and respective provider
+      --
+      onsConnections :: Map (NormalisedId addr) addr
+    }
+    deriving Show
+
 
 -- | Error types.
 --
@@ -378,11 +389,12 @@ withSnocket
                           (SnocketTrace m (TestAddress peerAddr)))
     -> Script BearerInfo
     -> (Snocket m (FD m (TestAddress peerAddr)) (TestAddress peerAddr)
+        -> m (ObservableNetworkState (TestAddress peerAddr))
         -> m a)
     -> m a
 withSnocket tr script k = do
     st <- newNetworkState script
-    a <- k (mkSnocket st tr)
+    a <- k (mkSnocket st tr) (toState st)
          `catch`
          \e -> do re <- checkResources st (Just e)
                   traverse_ throwIO re
@@ -409,6 +421,11 @@ withSnocket tr script k = do
          |  otherwise
          -> return   Nothing
 
+    toState :: NetworkState m (TestAddress peerAddr)
+               -> m (ObservableNetworkState (TestAddress peerAddr))
+    toState ns = atomically $ do
+        onsConnections <- fmap connProvider <$> readTVar (nsConnections ns)
+        return (ObservableNetworkState onsConnections)
 
 
 

diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs
@@ -852,7 +852,7 @@ prop_unidirectional_Sim :: NonFailingBearerInfoScript
 prop_unidirectional_Sim (NonFailingBearerInfoScript script) clientAndServerData =
   simulatedPropertyWithTimeout 7200 $
     withSnocket nullTracer
-                (toBearerInfo <$> script) $ \snock ->
+                (toBearerInfo <$> script) $ \snock _ ->
       bracket (Snocket.open snock Snocket.TestFamily)
               (Snocket.close snock) $ \fd -> do
         Snocket.bind   snock fd serverAddr
@@ -1012,7 +1012,7 @@ prop_bidirectional_Sim (NonFailingBearerInfoScript script) data0 data1 =
   simulatedPropertyWithTimeout 7200 $
     withSnocket sayTracer
                 (toBearerInfo <$> script)
-                $ \snock ->
+                $ \snock _ ->
       bracket ((,) <$> Snocket.open snock Snocket.TestFamily
                    <*> Snocket.open snock Snocket.TestFamily)
               (\ (socket0, socket1) -> Snocket.close snock socket0 >>
@@ -2580,7 +2580,7 @@ unit_server_accept_error ioErrType ioErrThrowOrReturn =
                  )
         $ withSnocket nullTracer
                       (singletonScript bearerAttenuation )
-        $ \snock ->
+        $ \snock _ ->
            bracket ((,) <$> Snocket.open snock Snocket.TestFamily
                         <*> Snocket.open snock Snocket.TestFamily)
                    (\ (socket0, socket1) -> Snocket.close snock socket0 >>
@@ -2663,7 +2663,7 @@ multiNodeSim serverAcc dataFlow script acceptedConnLimit l = do
       mb <- timeout 7200
                     ( withSnocket nullTracer
                                   script
-              $ \snocket ->
+              $ \snocket _ ->
                  multinodeExperiment (Tracer traceM)
                                      (Tracer traceM)
                                      (Tracer traceM)

diff --git a/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs b/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs
@@ -180,7 +180,7 @@ clientServerSimulation
     -> [payload]
     -> m (Maybe Bool)
 clientServerSimulation script payloads =
-    withSnocket nullTracer script $ \snocket ->
+    withSnocket nullTracer script $ \snocket _ ->
       withAsync (server snocket) $ \_serverAsync -> do
         res <- untilSuccess (client snocket)
         return (Just 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
@@ -999,7 +999,7 @@ prop_channel_simultaneous_open_sim codec versionDataCodec
     let attenuation = noAttenuation { biConnectionDelay = 1 } in
     withSnocket nullTracer
                 (singletonScript attenuation)
-              $ \sn -> do
+              $ \sn _ -> do
       let addr, addr' :: TestAddress Int
           addr  = Snocket.TestAddress 1
           addr' = Snocket.TestAddress 2