Fixes async exceptions in connectionLoop

- Tweaks in the MultiNodeScriptPruning generator;
IntersectMBO · Sep 15, 2021 · e7e957c · e7e957c
1 parent b923be2
commit e7e957c
Showing 1 changed file with 38 additions and 22 deletions.
diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs
@@ -23,11 +23,9 @@
 
 module Test.Ouroboros.Network.Server2
   ( tests
-  , prop
   ) where
 
-import           Control.Applicative ((<|>))
-import           Control.Exception (AssertionFailed)
+import           Control.Exception (AssertionFailed, SomeAsyncException (SomeAsyncException))
 import           Control.Monad (replicateM, when, (>=>))
 import           Control.Monad.Class.MonadAsync
 import           Control.Monad.Class.MonadThrow
@@ -113,16 +111,15 @@ import           Test.Ouroboros.Network.Orphans ()  -- ShowProxy ReqResp instanc
 import           Test.Simulation.Network.Snocket hiding (tests)
 import           Test.Ouroboros.Network.ConnectionManager (verifyAbstractTransition)
 
-import qualified Debug.Trace as Debug
-
 tests :: TestTree
 tests =
   testGroup "Ouroboros.Network.Server2"
   [ testProperty "unidirectional_IO"  prop_unidirectional_IO
   , testProperty "unidirectional_Sim" prop_unidirectional_Sim
   , testProperty "bidirectional_IO"   prop_bidirectional_IO
   , testProperty "bidirectional_Sim"  prop_bidirectional_Sim
-  , testProperty "multinode_Sim_Pruning" prop_multinode_Sim_Pruning
+  , testProperty "multinode_Sim_Pruning_Transitions"
+                 prop_multinode_Sim_Pruning_Transitions
   , testProperty "multinode_Sim"      prop_multinode_Sim
   , testProperty "unit_connection_terminated_when_negotiating"
                  unit_connection_terminated_when_negotiating
@@ -598,7 +595,7 @@ withBidirectionalConnectionManager name timeouts
           `catch` \(e :: SomeException) -> do
             throwIO e
   where
-    -- for a bidirectional mux we need to define 'Mu.xMiniProtocolInfo' for each
+    -- for a bidirectional mux we need to define 'Mux.MiniProtocolInfo' for each
     -- protocol for each direction.
     serverMiniProtocolBundle :: Mux.MiniProtocolBundle InitiatorResponderMode
     serverMiniProtocolBundle = Mux.MiniProtocolBundle
@@ -1258,8 +1255,7 @@ prop_generator_MultiNodeScript (MultiNodeScript script) =
 instance Arbitrary req =>
          Arbitrary (MultiNodeScriptPruning req) where
   arbitrary = do
-      -- Positive len <- scale (* 3) arbitrary
-      Positive len <- scale ((* 2) . (`div` 3)) arbitrary
+      Positive len <- scale (* 3) arbitrary
       MultiNodeScriptPruning <$> go (ScriptState [] [] [] [] []) (len :: Integer)
     where
       -- Divide delays by 100 to avoid running in to protocol and SDU timeouts if waiting
@@ -1277,10 +1273,10 @@ instance Arbitrary req =>
                     [ (4, InboundConnection       <$> delay <*> elements possibleInboundConnections)        | not $ null possibleInboundConnections] ++
                     [ (4, OutboundConnection      <$> delay <*> elements possibleOutboundConnections)       | not $ null possibleOutboundConnections] ++
                     [ (4, CloseInboundConnection  <$> delay <*> elements inboundConnections)                | not $ null inboundConnections ] ++
-                    [ (16, CloseOutboundConnection <$> delay <*> elements outboundConnections)              | not $ null outboundConnections ] ++
+                    [ (20, CloseOutboundConnection <$> delay <*> elements outboundConnections)              | not $ null outboundConnections ] ++
                     [ (16, InboundMiniprotocols   <$> delay <*> elements inboundConnections  <*> genBundle) | not $ null inboundConnections ] ++
-                    [ (16, OutboundMiniprotocols  <$> delay <*> elements outboundConnections <*> genBundle)  | not $ null outboundConnections ] ++
-                    [ (2, ShutdownClientServer    <$> delay <*> elements possibleStoppable)                 | not $ null possibleStoppable ]
+                    [ (4, OutboundMiniprotocols  <$> delay <*> elements outboundConnections <*> genBundle)  | not $ null outboundConnections ] ++
+                    [ (1, ShutdownClientServer    <$> delay <*> elements possibleStoppable)                 | not $ null possibleStoppable ]
         case event of
           StartServer _ c _ -> do
             inboundConnection <- InboundConnection <$> delay <*> pure c
@@ -1604,7 +1600,10 @@ multinodeExperiment inboundTrTracer trTracer cmTracer inboundTracer
                         TokWarm        -> "warm"
                         TokEstablished -> "cold"
                   q <$ labelTQueue q ("protoVar." ++ temp ++ "@" ++ show localAddr)
-            connHandle <- try @_ @SomeException
+            connHandle <- tryJust (\(e :: SomeException) ->
+                                       case fromException e of
+                                         Just SomeAsyncException {} -> Nothing
+                                         _                          -> Just e)
                           $ requestOutboundConnection cm remoteAddr
             case connHandle of
               Left _ ->
@@ -1633,12 +1632,20 @@ multinodeExperiment inboundTrTracer trTracer cmTracer inboundTracer
               -- We want to throw because the generator invariant should never put us in
               -- this case
               Nothing -> throwIO (NoActiveConnection localAddr remoteAddr)
-              Just (Handle mux muxBundle _) ->
+              Just (Handle mux muxBundle _) -> do
                 -- TODO:
                 -- At times this throws 'ProtocolAlreadyRunning'.
-                void $ try @_ @SomeException
+                r <- tryJust (\(e :: SomeException) ->
+                                  case fromException e of
+                                    Just SomeAsyncException {} -> Nothing -- rethrown
+                                    _                          -> Just e)
                      $ runInitiatorProtocols muxMode mux muxBundle
-            go unregister connMap
+                case r of
+                  -- Lost connection to peer
+                  Left  {} -> do
+                    atomically $ modifyTVar connVar (Map.delete (connId remoteAddr))
+                    go unregister (Map.delete remoteAddr connMap)
+                  Right {} -> go unregister connMap
           Shutdown -> return ()
           where
             connId remoteAddr = ConnectionId { localAddress  = localAddr
@@ -1734,6 +1741,12 @@ mkProperty TestProperty { tpProperty
    . tabulate "Transitions"         (map ppTransition tpTransitions)
    $ tpProperty
 
+mkPropertyPruning :: TestProperty -> Property
+mkPropertyPruning tp@TestProperty { tpNumberOfPrunings = Sum numberOfPrunings_ } =
+     cover 25 (numberOfPrunings_ > 0) "Prunings"
+   . mkProperty
+   $ tp
+
 newtype AllProperty = AllProperty { getAllProperty :: Property }
 
 instance Semigroup AllProperty where
@@ -2093,11 +2106,14 @@ prop_multinode_Sim serverAcc (ArbDataFlow dataFlow) absBi script@(MultiNodeScrip
         Nothing -> IdleConn
         Just {} -> ActiveConn
 
-prop = prop_multinode_Sim_Pruning 0 (Small 10) (MultiNodeScriptPruning [StartServer 0 (TestAddr {unTestAddr = TestAddress 46}) 0,OutboundConnection 0 (TestAddr {unTestAddr = TestAddress 46}),StartServer 0 (TestAddr {unTestAddr = TestAddress 73}) 0,InboundConnection 0 (TestAddr {unTestAddr = TestAddress 73}),OutboundConnection 0 (TestAddr {unTestAddr = TestAddress 73}),InboundMiniprotocols 0 (TestAddr {unTestAddr = TestAddress 73}) (Bundle {withHot = WithHot [], withWarm = WithWarm [], withEstablished = WithEstablished [0]}),StartServer 0 (TestAddr {unTestAddr = TestAddress 100}) 0,OutboundConnection 0 (TestAddr {unTestAddr = TestAddress 100}),CloseOutboundConnection 0 (TestAddr {unTestAddr = TestAddress 73}),OutboundMiniprotocols 0 (TestAddr {unTestAddr = TestAddress 46}) (Bundle {withHot = WithHot [], withWarm = WithWarm [], withEstablished = WithEstablished []})])
-
--- | Property wrapping `multinodeExperiment` that has a generator optimized for triggering pruning.
-prop_multinode_Sim_Pruning :: Int -> Small Word32 -> MultiNodeScriptPruning Int -> Property
-prop_multinode_Sim_Pruning serverAcc (Small bound) (MultiNodeScriptPruning l) =
+-- | Property wrapping `multinodeExperiment` that has a generator optimized for triggering
+-- pruning, and random generated number of connections hard limit.
+--
+-- This test tests if with a higher chance of pruning happening and a smaller number of
+-- connections hard limit we do not end up triggering any illegal transition.
+--
+prop_multinode_Sim_Pruning_Transitions :: Int -> Small Word32 -> MultiNodeScriptPruning Int -> Property
+prop_multinode_Sim_Pruning_Transitions serverAcc (Small bound) (MultiNodeScriptPruning l) =
   let trace = runSimTrace sim
         where
           sim :: IOSim s ()
@@ -2142,7 +2158,7 @@ prop_multinode_Sim_Pruning serverAcc (Small bound) (MultiNodeScriptPruning l) =
    . counterexample (ppScript (MultiNodeScript l))
    . counterexample ("\nAbstractTransition Trace\n" ++ (intercalate "\n" . map show $ Octopus.toList evs))
    . counterexample ("\nConnectionManager Trace\n" ++ (intercalate "\n" . map show $ Octopus.toList evs'))
-   . mkProperty
+   . mkPropertyPruning
    . bifoldMap
       ( \ case
           MainReturn {} -> mempty