server-test: IOSim versions of existing IO properties

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

@@ -5,6 +5,7 @@
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE KindSignatures      #-}
 {-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections       #-}
 {-# LANGUAGE TypeApplications    #-}
@@ -27,13 +28,15 @@ import qualified Control.Monad.Class.MonadSTM as LazySTM
 import           Control.Monad.Class.MonadSay
 import           Control.Monad.Class.MonadTime
 import           Control.Monad.Class.MonadTimer
-import           Control.Tracer (contramap, nullTracer)
+import           Control.Monad.IOSim
+import           Control.Tracer (Tracer (..), contramap, nullTracer)
 
 import           Codec.Serialise.Class (Serialise)
 import           Data.ByteString.Lazy (ByteString)
 import           Data.Functor (($>), (<&>))
 import           Data.List (mapAccumL)
 import           Data.List.NonEmpty (NonEmpty (..))
+import           Data.Maybe (fromMaybe)
 import           Data.Typeable (Typeable)
 import           Data.Void (Void)
 
@@ -72,18 +75,23 @@ import qualified Ouroboros.Network.Server2 as Server
 import           Ouroboros.Network.Snocket (Snocket, socketSnocket)
 import qualified Ouroboros.Network.Snocket as Snocket
 
+import           Simulation.Network.Snocket
+
 import           Test.Ouroboros.Network.Orphans ()  -- ShowProxy ReqResp instance
+import           Test.Simulation.Network.Snocket (NonFailingBearerInfoScript(..), toBearerInfo)
 
 tests :: TestTree
 tests =
   testGroup "Ouroboros.Network.Server2"
-  [ testProperty "unidirectional_IO" prop_unidirectional_IO
-  , testProperty "bidirectional_IO"  prop_bidirectional_IO
+  [ testProperty "unidirectional_IO"  prop_unidirectional_IO
+  , testProperty "unidirectional_Sim" prop_unidirectional_Sim
+  , testProperty "bidirectional_IO"   prop_bidirectional_IO
+  , testProperty "bidirectional_Sim"  prop_bidirectional_Sim
   ]
 
 
 --
--- Server tests (IO only)
+-- Server tests
 --
 
 -- | The protocol will run three instances of  `ReqResp` protocol; one for each
@@ -386,7 +394,7 @@ withInitiatorOnlyConnectionManager
                   (reqs : rest) -> do
                     writeTVar requestsVar rest $> reqs
                   [] -> pure []
-            pure $ 
+            pure $
               reqRespClientPeer (reqRespClientMap reqs)))
 
 
@@ -404,7 +412,7 @@ outboundIdleTimeout :: DiffTime
 outboundIdleTimeout = 0.1
 
 
--- 
+--
 -- Rethrow policies
 --
 
@@ -667,7 +675,7 @@ withBidirectionalConnectionManager name snocket socket localAddress
                   (reqs : rest) -> do
                     writeTVar requestsVar rest $> reqs
                   [] -> pure []
-            pure $ 
+            pure $
               reqRespClientPeer
               (reqRespClientMap reqs)))
         (MuxPeer
@@ -827,6 +835,18 @@ unidirectionalExperiment snocket socket clientAndServerData = do
                 (property True)
                 $ zip rs (expectedResult clientAndServerData clientAndServerData)
 
+prop_unidirectional_Sim :: ClientAndServerData Int Int Int -> Property
+prop_unidirectional_Sim clientAndServerData =
+  simulatedPropertyWithTimeout 7200 $ do
+    net   <- newNetworkState (singletonScript noAttenuation) 10
+    let snock = mkSnocket net debugTracer
+    fd <- Snocket.open snock Snocket.TestFamily
+    Snocket.bind   snock fd serverAddr
+    Snocket.listen snock fd
+    unidirectionalExperiment snock fd clientAndServerData
+  where
+    serverAddr = Snocket.TestAddress (0 :: Int)
+
 prop_unidirectional_IO
   :: ClientAndServerData Int Int Int
   -> Property
@@ -960,6 +980,26 @@ bidirectionalExperiment
                 ))
 
 
+prop_bidirectional_Sim :: NonFailingBearerInfoScript -> ClientAndServerData Int Int Int -> ClientAndServerData Int Int Int -> Property
+prop_bidirectional_Sim (NonFailingBearerInfoScript script) data0 data1 =
+  simulatedPropertyWithTimeout 7200 $ do
+    net <- newNetworkState script' 10
+    let snock = mkSnocket net debugTracer
+    bracket ((,) <$> Snocket.open snock Snocket.TestFamily
+                 <*> Snocket.open snock Snocket.TestFamily)
+            (\ (socket0, socket1) -> Snocket.close snock socket0 >>
+                                     Snocket.close snock socket1)
+      $ \ (socket0, socket1) -> do
+        let addr0 = Snocket.TestAddress (0 :: Int)
+            addr1 = Snocket.TestAddress 1
+        Snocket.bind   snock socket0 addr0
+        Snocket.bind   snock socket1 addr1
+        Snocket.listen snock socket0
+        Snocket.listen snock socket1
+        bidirectionalExperiment snock socket0 socket1 addr0 addr1 data0 data1
+  where
+    script' = toBearerInfo <$> script
+
 prop_bidirectional_IO
     :: ClientAndServerData Int Int Int
     -> ClientAndServerData Int Int Int
@@ -1007,19 +1047,27 @@ prop_bidirectional_IO data0 data1 =
 -- Utils
 --
 
-{-
 debugTracer :: (MonadSay m, MonadTime m, Show a) => Tracer m a
 debugTracer = Tracer $
   \msg -> (,msg) <$> getCurrentTime >>= say . show
--}
 
 withLock :: ( MonadSTM   m
             , MonadThrow m
             )
          => StrictTMVar m ()
          -> m a
          -> m a
-withLock v m = 
+withLock v m =
     bracket (atomically $ takeTMVar v)
             (atomically . putTMVar v)
             (const m)
+
+simulatedPropertyWithTimeout :: DiffTime -> (forall s. IOSim s Property) -> Property
+simulatedPropertyWithTimeout t test =
+  counterexample ("\nTrace:\n" ++ ppTrace_ tr) $
+  case traceResult False tr of
+    Left failure ->
+      counterexample ("Failure:\n" ++ displayException failure) False
+    Right prop -> fromMaybe (counterexample "timeout" $ property False) prop
+  where
+    tr = runSimTrace $ timeout t test