Expand snocket tests with various scenarios

NOTE: Missing close tests

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

@@ -9,6 +9,7 @@
 {-# LANGUAGE PolyKinds           #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections       #-}
+{-# LANGUAGE RankNTypes          #-}
 
 {-# OPTIONS_GHC -Wno-unused-imports #-}
 
@@ -89,6 +90,14 @@ tests =
           prop_generator_NonFailingBeararInfoScript
       ]
     , testProperty "client-server" prop_client_server
+    , testProperty "connect_to_accepting_socket"
+                   prop_connect_to_accepting_socket
+    , testProperty "connect_to_not_accepting_socket"
+                   prop_connect_to_not_accepting_socket
+    , testProperty "connect_to_uninitialised_socket"
+                   prop_connect_to_uninitialised_socket
+    , testProperty "simultaneous_open"
+                   prop_simultaneous_open
     ]
 
 type TestAddr      = TestAddress Int
@@ -188,13 +197,13 @@ clientServerSimulation
        )
     => Script BearerInfo
     -> [payload]
-    -> m (Maybe Bool)
+    -> m (Either SomeException ())
 clientServerSimulation script payloads =
     withSnocket nullTracer script $ \snocket ->
-      withAsync (server snocket) $ \_serverAsync -> do
-        res <- untilSuccess (client snocket)
-        return (Just res)
-
+      withAsync (server' snocket) $ \_serverAsync -> do
+        res <- untilSuccess (client' snocket)
+        say $ "SIMULATION RESULT: " ++ show res
+        return (Right ())
   where
     reqRespProtocolNum :: MiniProtocolNum
     reqRespProtocolNum = MiniProtocolNum 0
@@ -208,9 +217,9 @@ clientServerSimulation script payloads =
     clientPeer :: Peer (ReqResp payload payload) AsClient StIdle m Bool
     clientPeer = reqRespClientPeer (pingClient payloads)
 
-    server :: TestSnocket m
+    server' :: TestSnocket m
            -> m ()
-    server snocket = do
+    server' snocket = do
         labelThisThread "server"
         threadsVar <- newTVarIO Set.empty
         bracket (open snocket TestFamily)
@@ -280,9 +289,9 @@ clientServerSimulation script payloads =
                   say $ "SERVER HANDLER " ++ show res
 
 
-    client :: TestSnocket m
+    client' :: TestSnocket m
            -> m Bool
-    client snocket = do
+    client' snocket = do
         labelThisThread "client"
         bracket (openToConnect snocket serverAddr)
                 (close snocket)
@@ -506,7 +515,6 @@ toBearerInfo abi =
         biSDUSize              = toSduSize (abiSDUSize abi)
       }
 
-
 instance Arbitrary AbsBearerInfo where
     arbitrary =
         AbsBearerInfo <$> arbitrary
@@ -627,28 +635,170 @@ prop_generator_NonFailingBeararInfoScript (NonFailingBearerInfoScript s) = not (
 
 prop_client_server :: [ByteString] -> BearerInfoScript -> Property
 prop_client_server payloads (BearerInfoScript script) =
-    let tr = runSimTrace $ clientServerSimulation script' payloads
-    in -- Debug.traceShow script $
-       case traceResult True tr of
-         Left e         -> counterexample
-                             (unlines
-                               [ "=== Say Events ==="
-                               , unlines (selectTraceEventsSay' tr)
-                               , "=== Error ==="
-                               , show e ++ "\n"
-                               , "=== Trace Events ==="
-                               , unlines (show `map` traceEvents tr)
-                               ])
-                             False
-         Right Nothing  -> property False
-         Right (Just b) -> property b
+  prop_connect_to_template sim
   where
+    sim :: forall s . IOSim s (Either SomeException ())
+    sim = clientServerSimulation script' payloads
+
     script' = toBearerInfo <$> script
 
+data TestError = UnexpectedOutcome
+  deriving (Show, Eq)
+
+instance Exception TestError
+
+prop_connect_to_template :: (forall s . IOSim s (Either SomeException ())) -> Property
+prop_connect_to_template sim =
+  let tr = runSimTrace sim
+   in case traceResult True tr of
+     Left e -> counterexample
+                (unlines
+                  [ "=== Say Events ==="
+                  , unlines (selectTraceEventsSay' tr)
+                  , "=== Trace Events ==="
+                  , unlines (show `map` traceEvents tr)
+                  , "=== Error ==="
+                  , show e ++ "\n"
+                  ])
+                False
+     Right (Left e) -> counterexample
+                        (unlines
+                          [ "=== Say Events ==="
+                          , unlines (selectTraceEventsSay' tr)
+                          , "=== Trace Events ==="
+                          , unlines (show `map` traceEvents tr)
+                          , "=== Error ==="
+                          , show e ++ "\n"
+                          ])
+                        False
+     Right (Right _) -> property True
+
+prop_connect_to_accepting_socket :: BearerInfoScript -> Property
+prop_connect_to_accepting_socket (BearerInfoScript script) =
+  prop_connect_to_template sim
+  where
+    sim :: forall s . IOSim s (Either SomeException ())
+    sim =
+      withSnocket nullTracer (toBearerInfo <$> script) $ \snocket ->
+        withAsync (server (TestAddress (0 :: Int)) snocket accept') $ \serverAsync -> do
+          res <- client (TestAddress 1) (TestAddress 0) snocket
+          _ <- wait serverAsync
+          return res
+
+prop_connect_to_not_accepting_socket :: BearerInfoScript -> Property
+prop_connect_to_not_accepting_socket (BearerInfoScript script) =
+  prop_connect_to_template sim
+  where
+    sim :: forall s . IOSim s (Either SomeException ())
+    sim =
+      withSnocket nullTracer (toBearerInfo <$> script) $ \snocket ->
+        withAsync (server (TestAddress (0 :: Int)) snocket loop) $ \_serverAsync -> do
+          res <- client (TestAddress 1) (TestAddress 0) snocket
+          case res of
+            -- Should timeout
+            Left _ -> return (Right ())
+            Right _ -> return (Left (toException UnexpectedOutcome))
+
+prop_connect_to_uninitialised_socket :: BearerInfoScript -> Property
+prop_connect_to_uninitialised_socket (BearerInfoScript script) =
+  prop_connect_to_template sim
+  where
+    sim :: forall s . IOSim s (Either SomeException ())
+    sim =
+      withSnocket nullTracer (toBearerInfo <$> script) $ \snocket -> do
+        res <- client (TestAddress (1 :: Int)) (TestAddress 0) snocket
+        case res of
+          -- Should complain about no such listening socket
+          Left _ -> return (Right ())
+          Right _ -> return (Left (toException UnexpectedOutcome))
+
+prop_simultaneous_open :: BearerInfoScript -> Property
+prop_simultaneous_open (BearerInfoScript script) =
+  prop_connect_to_template sim
+  where
+    sim :: forall s . IOSim s (Either SomeException ())
+    sim =
+      withSnocket nullTracer (toBearerInfo <$> script) $ \snocket -> do
+        withAsync (connectingServer (TestAddress (0 :: Int)) (TestAddress 1) snocket)
+          $ \clientAsync -> do
+            _ <- connectingServer (TestAddress 1) (TestAddress 0) snocket
+            wait clientAsync
 
 --
 -- Utils
 --
 
+server
+  :: ( MonadThread m
+    , MonadThrow m
+    )
+  => TestAddress addr
+  -> Snocket m fd (TestAddress addr)
+  -> (Snocket m fd (TestAddress addr) -> m (Accept m fd (TestAddress addr)) -> m b)
+  -> m b
+server localAddress snocket acceptF = do
+    labelThisThread "server"
+    bracket (open snocket TestFamily)
+            (close snocket)
+            (\fd -> do
+              bind snocket fd localAddress
+              listen snocket fd
+              acceptF snocket (accept snocket fd)
+            )
+
+loop :: MonadDelay m => a -> b -> m c
+loop t a = do
+  threadDelay 10000
+  loop t a
+
+accept' :: MonadMask m => Snocket m fd addr -> m (Accept m fd addr) -> m Bool
+accept' snocket accept = mask $ \unmask -> do
+  accept0 <- accept
+  (accepted, _) <- runAccept accept0 unmask
+  case accepted of
+    Accepted fd' _ -> do
+      close snocket fd'
+      return True
+    AcceptFailure _ ->
+      return False
+
+client
+ :: ( MonadThread m
+    , MonadCatch m
+    )
+ => addr
+ -> addr
+ -> Snocket m fd addr
+ -> m (Either SomeException ())
+client localAddress remoteAddress snocket = do
+    labelThisThread "client"
+    bracket (openToConnect snocket localAddress)
+            (close snocket)
+            $ \fd -> do
+              bind snocket fd localAddress
+              Right <$> connect snocket fd remoteAddress
+              `catch` (\(e :: SomeException) -> return (Left e))
+
+connectingServer
+  :: ( MonadThread m
+    , MonadCatch m
+    )
+ => TestAddress addr
+ -> TestAddress addr
+ -> Snocket m fd (TestAddress addr) -> m (Either SomeException ())
+connectingServer localAddress remoteAddress snocket = do
+    labelThisThread "connectingServer"
+    bracket (open snocket TestFamily)
+            (close snocket)
+            $ \fd -> do
+              bind snocket fd localAddress
+              listen snocket fd
+              bracket (openToConnect snocket localAddress)
+                      (close snocket)
+                      $ \fd' -> do
+                        bind snocket fd' localAddress
+                        Right <$> connect snocket fd' remoteAddress
+                        `catch` (\(e :: SomeException) -> return (Left e))
+
 traceTime :: MonadMonotonicTime m => Tracer m (Time, a) -> Tracer m a
 traceTime = contramapM (\a -> (,a) <$> getMonotonicTime)