Added InboundGovernor transition order test

Fixed issue in inboundGovernor function where in case of Async
exceptions we wouldn't log the final transitions for the connections.

ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs

@@ -35,11 +35,11 @@ module Ouroboros.Network.InboundGovernor
 
 import Control.Exception (SomeAsyncException (..), assert)
 import Control.Applicative (Alternative (..), (<|>))
-import Control.Monad (foldM, when)
+import Control.Monad (foldM)
 import Control.Monad.Class.MonadAsync
 import qualified Control.Monad.Class.MonadSTM as LazySTM
 import Control.Monad.Class.MonadSTM.Strict
-import Control.Monad.Class.MonadThrow hiding (handle)
+import Control.Monad.Class.MonadThrow
 import Control.Monad.Class.MonadTime
 import Control.Monad.Class.MonadTimer
 import Control.Tracer (Tracer, traceWith)
@@ -91,6 +91,7 @@ inboundGovernor :: forall (muxMode :: MuxMode) socket peerAddr versionNumber m a
  , MonadThrow (STM m)
  , MonadTime m
  , MonadTimer m
+ , MonadMask m
  , Ord peerAddr
  , HasResponder muxMode ~ True
  )
@@ -104,20 +105,36 @@ inboundGovernor :: forall (muxMode :: MuxMode) socket peerAddr versionNumber m a
  -> m Void
 inboundGovernor trTracer tracer serverControlChannel inboundIdleTimeout
  connectionManager observableStateVar = do
- let state = InboundGovernorState {
+ -- State needs to be a TVar, otherwise, when catching the exception inside the loop
+ st <- atomically $ newTVar emptyState
+ mask_ $ inboundGovernorLoop st
+ `catch`
+ (\(e :: SomeAsyncException) -> do
+ state <- atomically $ readTVar st
+ _ <- Map.traverseWithKey
+ (\connId _ ->
+ traceWith trTracer (mkRemoteTransitionTrace connId state emptyState)
+ )
+ (igsConnections state)
+
+ throwIO e
+ )
+ where
+ emptyState :: InboundGovernorState muxMode peerAddr m a b
+ emptyState = InboundGovernorState {
  igsConnections = Map.empty,
  igsObservableVar = observableStateVar,
  igsCountersCache = mempty
  }
- inboundGovernorLoop state
- where
+
  -- The inbound protocol governor recursive loop. The 'igsConnections' is
  -- updated as we recurs.
  --
  inboundGovernorLoop
- :: InboundGovernorState muxMode peerAddr m a b
+ :: StrictTVar m (InboundGovernorState muxMode peerAddr m a b)
  -> m Void
- inboundGovernorLoop !state = do
+ inboundGovernorLoop !st = do
+ state <- atomically $ readTVar st
  mapTraceWithCache TrInboundGovernorCounters
  tracer
  (igsCountersCache state)
@@ -135,7 +152,7 @@ inboundGovernor trTracer tracer serverControlChannel inboundIdleTimeout
  <|> firstPeerDemotedToCold state
  <|> (NewConnection <$> ControlChannel.readMessage
  serverControlChannel)
- case event of
+ (mbConnId, state') <- case event of
  NewConnection
  -- new connection has been announced by either accept loop or
  -- by connection manager (in which case the connection is in
@@ -241,8 +258,7 @@ inboundGovernor trTracer tracer serverControlChannel inboundIdleTimeout
 
  -- update state and continue the recursive loop
  let state' = state { igsConnections }
- traceWith trTracer (mkRemoteTransitionTrace connId state state')
- inboundGovernorLoop state'
+ return (Just connId, state')
 
  MuxFinished connId merr -> do
 
@@ -252,8 +268,7 @@ inboundGovernor trTracer tracer serverControlChannel inboundIdleTimeout
 
  -- the connection manager does should realise this on itself.
  let state' = unregisterConnection connId state
- traceWith trTracer (mkRemoteTransitionTrace connId state state')
- inboundGovernorLoop state'
+ return (Just connId, state')
 
  MiniProtocolTerminated
  Terminated {
@@ -274,8 +289,7 @@ inboundGovernor trTracer tracer serverControlChannel inboundIdleTimeout
  TrResponderErrored tConnId num e
 
  let state' = unregisterConnection tConnId state
- traceWith trTracer (mkRemoteTransitionTrace tConnId state state')
- inboundGovernorLoop state'
+ return (Just tConnId, state')
 
  Right _ -> do
  result
@@ -297,9 +311,9 @@ inboundGovernor trTracer tracer serverControlChannel inboundIdleTimeout
  $ state
 
  -- remote state is only updated when 'isHot' is 'True'
- when isHot
- $ traceWith trTracer (mkRemoteTransitionTrace tConnId state state')
- inboundGovernorLoop state'
+ if isHot
+ then return (Just tConnId, state')
+  else return (Nothing, state')
 
  Left err -> do
  -- there is no way to recover from synchronous exceptions; we
@@ -309,8 +323,8 @@ inboundGovernor trTracer tracer serverControlChannel inboundIdleTimeout
  Mux.stopMux tMux
 
  let state' = unregisterConnection tConnId state
- traceWith trTracer (mkRemoteTransitionTrace tConnId state state')
- inboundGovernorLoop state'
+
+ return (Just tConnId, state')
 
 
  WaitIdleRemote connId -> do
@@ -326,8 +340,8 @@ inboundGovernor trTracer tracer serverControlChannel inboundIdleTimeout
  !timeoutSTM = LazySTM.readTVar v >>= check
 
  let state' = updateRemoteState connId (RemoteIdle timeoutSTM) state
- traceWith trTracer (mkRemoteTransitionTrace connId state state')
- inboundGovernorLoop state'
+
+ return (Just connId, state')
 
  -- @
  -- PromotedToWarm^{Duplex}_{Remote}
@@ -350,14 +364,14 @@ inboundGovernor trTracer tracer serverControlChannel inboundIdleTimeout
  connId
  RemoteWarm
  state
- traceWith trTracer (mkRemoteTransitionTrace connId state state')
- inboundGovernorLoop state'
+
+ return (Just connId, state')
 
  RemotePromotedToHot connId -> do
  traceWith tracer (TrPromotedToHotRemote connId)
  let state' = updateRemoteState connId RemoteHot state
- traceWith trTracer (mkRemoteTransitionTrace connId state state')
- inboundGovernorLoop state'
+
+ return (Just connId, state')
 
  CommitRemote connId -> do
  res <- unregisterInboundConnection connectionManager
@@ -372,9 +386,8 @@ inboundGovernor trTracer tracer serverControlChannel inboundIdleTimeout
  -- @'InOutboundState' 'Unidirectional'@,
  -- @'InTerminatingState'@,
  -- @'InTermiantedState'@.
- let state' = unregisterConnection connId state 
- traceWith trTracer (mkRemoteTransitionTrace connId state state')
- inboundGovernorLoop state'
+ let state' = unregisterConnection connId state
+ return (Just connId, state')
 
  OperationSuccess transition ->
  case transition of
@@ -386,8 +399,7 @@ inboundGovernor trTracer tracer serverControlChannel inboundIdleTimeout
  -- → TerminatingState
  -- @
  let state' = unregisterConnection connId state
- traceWith trTracer (mkRemoteTransitionTrace connId state state')
- inboundGovernorLoop state'
+ return (Just connId, state')
 
  -- the connection is still used by p2p-governor, carry on but put
  -- it in 'RemoteCold' state. This will ensure we keep ready to
@@ -408,8 +420,15 @@ inboundGovernor trTracer tracer serverControlChannel inboundIdleTimeout
  -- manager was requested outbound connection.
  KeepTr -> do
  let state' = updateRemoteState connId RemoteCold state
- traceWith trTracer (mkRemoteTransitionTrace connId state state')
- inboundGovernorLoop state'
+
+ return (Just connId, state')
+
+ atomically $ writeTVar st state'
+ case mbConnId of
+ Just cid -> traceWith trTracer (mkRemoteTransitionTrace cid state state')
+ Nothing -> pure ()
+
+ inboundGovernorLoop st
 
 
 -- | Run a responder mini-protocol.

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

@@ -128,6 +128,8 @@ tests =
  prop_multinode_ig_Sim
  , testProperty "multinode_cm_order_Sim"
  prop_multinode_cm_order_Sim
+ , testProperty "multinode_ig_order_Sim"
+ prop_multinode_ig_order_Sim
  , testProperty "unit_connection_terminated_when_negotiating"
  unit_connection_terminated_when_negotiating
  , testGroup "generators"
@@ -1958,13 +1960,42 @@ verifyAbstractTransitionOrder (h:t) = go t h
  -- 'fromState', in order for the transition chain to be correct.
  go (next@(Transition nextFromState _) : ts)
  curr@(Transition _ currToState) =
- (AllProperty
- $ counterexample
-  ("\nUnexpected transition order!\nWent from: "
-  ++ show curr ++ "\nto: " ++ show next)
-  (property (currToState == nextFromState)))
+ AllProperty
+ (counterexample
+ ("\nUnexpected transition order!\nWent from: "
+ ++ show curr ++ "\nto: " ++ show next)
+ (property (currToState == nextFromState)))
  <> go ts next
 
+-- Assuming all transitions in the transition list are valid, we only need to
+-- look at the 'toState' of the current transition and the 'fromState' of the
+-- next transition.
+verifyRemoteTransitionOrder :: [RemoteTransition]
+ -> AllProperty
+verifyRemoteTransitionOrder [] = mempty
+verifyRemoteTransitionOrder (h:t) = go t h
+ where
+ go :: [RemoteTransition] -> RemoteTransition -> AllProperty
+ -- All transitions must end in the 'Nothing' (final) state, and since
+ -- we assume all transitions are valid we do not have to check the
+ -- 'fromState' .
+ go [] (Transition _ Nothing) = mempty
+ go [] tr@(Transition _ _) =
+ AllProperty
+ $ counterexample
+ ("\nUnexpected last transition: " ++ show tr)
+ (property False)
+ -- All transitions have to be in correct order, which means that the current
+ -- state we are looking at (current toState) needs to be equal to the next
+ -- 'fromState', in order for the transition chain to be correct.
+ go (next@(Transition nextFromState _) : ts)
+ curr@(Transition _ currToState) =
+ AllProperty
+ (counterexample
+ ("\nUnexpected transition order!\nWent from: "
+ ++ show curr ++ "\nto: " ++ show next)
+ (property (currToState == nextFromState)))
+ <> go ts next
 
 -- | Property wrapping `multinodeExperiment`.
 --
@@ -2033,13 +2064,12 @@ prop_multinode_cm_order_Sim :: Int -> ArbDataFlow -> AbsBearerInfo -> MultiNodeS
 prop_multinode_cm_order_Sim serverAcc (ArbDataFlow dataFlow) absBi script@(MultiNodeScript l) =
  let trace = runSimTrace sim
 
- evsATT :: Octopus (Value ()) (AbstractTransitionTrace SimAddr)
- evsATT = octopusWithNameTraceEvents trace
+ evsATT :: Trace (SimResult ()) (AbstractTransitionTrace SimAddr)
+ evsATT = traceWithNameTraceEvents trace
 
  in tabulate "ConnectionEvents" (map showCEvs l)
  . counterexample (ppScript script)
- . counterexample (ppOctopus show show evsATT)
- -- . counterexample (ppTrace_ trace)
+ . counterexample (Trace.ppTrace show show evsATT)
  . getAllProperty
  . bifoldMap
  ( \ case
@@ -2130,6 +2160,36 @@ prop_multinode_ig_Sim serverAcc (ArbDataFlow dataFlow) absBi script@(MultiNodeSc
  (Script (toBearerInfo absBi :| [noAttenuation]))
  maxAcceptedConnectionsLimit l
 
+prop_multinode_ig_order_Sim :: Int -> ArbDataFlow -> AbsBearerInfo -> MultiNodeScript Int TestAddr -> Property
+prop_multinode_ig_order_Sim serverAcc (ArbDataFlow dataFlow) absBi script@(MultiNodeScript l) =
+ let trace = runSimTrace sim
+
+ evsRTT :: Trace (SimResult ()) (RemoteTransitionTrace SimAddr)
+ evsRTT = traceWithNameTraceEvents trace
+
+ evsIGT :: Trace (SimResult ()) (InboundGovernorTrace SimAddr)
+ evsIGT = traceWithNameTraceEvents trace
+
+ in tabulate "ConnectionEvents" (map showCEvs l)
+ . counterexample (Trace.ppTrace show show evsIGT)
+ . counterexample (ppScript script)
+ . counterexample (Trace.ppTrace show show evsRTT)
+ . getAllProperty
+ . bifoldMap
+ ( \ case
+ MainReturn {} -> mempty
+ _ -> AllProperty (property False)
+ )
+ verifyRemoteTransitionOrder
+ . splitRemoteConns
+ $ evsRTT
+ where
+ sim :: IOSim s ()
+ sim = multiNodeSim serverAcc dataFlow
+ (Script (toBearerInfo absBi :| [noAttenuation]))
+ maxAcceptedConnectionsLimit l
+
+
 -- | Property wrapping `multinodeExperiment` that has a generator optimized for triggering
 -- pruning, and random generated number of connections hard limit.
 --
@@ -2434,6 +2494,34 @@ splitConns =
  )
  Map.empty
 
+splitRemoteConns :: Trace (SimResult ()) (RemoteTransitionTrace SimAddr)
+ -> Trace (SimResult ()) [RemoteTransition]
+splitRemoteConns =
+ bimap id fromJust
+ . Trace.filter isJust
+ -- there might be some connections in the state, push them onto the 'Octopus'
+ . (\(s, o) -> foldr (\a as -> Trace.Cons (Just a) as) o (Map.elems s))
+ . bimapAccumL
+ ( \ s a -> ( s, a))
+ ( \ s TransitionTrace { ttPeerAddr, ttTransition } ->
+ case ttTransition of
+ Transition _ Nothing ->
+ case ttPeerAddr `Map.lookup` s of
+ Nothing -> ( Map.insert ttPeerAddr [ttTransition] s
+ , Nothing
+ )
+ Just trs -> ( Map.delete ttPeerAddr s
+ , Just (reverse $ ttTransition : trs)
+ )
+ _ -> ( Map.alter ( \ case
+ Nothing -> Just [ttTransition]
+ Just as -> Just (ttTransition : as)
+ ) ttPeerAddr s
+ , Nothing
+ )
+ )
+ Map.empty
+
 ppTransition :: AbstractTransition -> String
 ppTransition Transition {fromState, toState} =
  printf "%-30s → %s" (show fromState) (show toState)
@@ -2501,7 +2589,6 @@ sayTracer :: (MonadSay m, MonadTime m, Show a) => Tracer m a
 sayTracer = Tracer $
  \msg -> (,msg) <$> getCurrentTime >>= say . show
 
-
 showCEvs :: ConnectionEvent req peerAddr -> String
 showCEvs (StartClient{}) = "StartClient"
 showCEvs (StartServer{}) = "StartServer"
@@ -2610,7 +2697,6 @@ makeBundle f = Bundle (WithHot $ f TokHot)
  (WithEstablished $ f TokEstablished)
 
 
-
 -- TODO: we should use @traceResult True@; the `prop_unidirectional_Sim` and
 -- `prop_bidirectional_Sim` test are failing with `<<io-sim sloppy shutdown>>`
 -- exception.