Skip to content

Commit

Permalink
Added InboundGovernor transition order test
Browse files Browse the repository at this point in the history 
Fixed issue in inboundGovernor function where in case of Async
exceptions we wouldn't log the final transitions for the connections.
  • Loading branch information
@bolt12 @coot
bolt12 authored and coot committed Nov 11, 2021
1 parent b4624c0 commit 7bd91a3
Show file tree
Hide file tree
Showing 2 changed files with 163 additions and 38 deletions.
87 changes: 55 additions & 32 deletions ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
)
Expand All @@ -104,20 +105,39 @@ 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 we do not have access to the most recentversion of the state
-- and might be truncating transitions.
st <- atomically $ newTVar emptyState
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)
Expand All @@ -135,7 +155,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
Expand Down Expand Up @@ -241,8 +261,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

Expand All @@ -252,8 +271,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 {
Expand All @@ -274,8 +292,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
Expand All @@ -297,9 +314,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
Expand All @@ -309,8 +326,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
Expand All @@ -326,8 +343,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}
Expand All @@ -350,14 +367,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
Expand All @@ -372,9 +389,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
Expand All @@ -386,8 +402,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
Expand All @@ -408,8 +423,16 @@ 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')

mask_ $ do
atomically $ writeTVar st state'
case mbConnId of
Just cid -> traceWith trTracer (mkRemoteTransitionTrace cid state state')
Nothing -> pure ()

inboundGovernorLoop st


-- | Run a responder mini-protocol.
Expand Down
114 changes: 108 additions & 6 deletions ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -131,6 +131,8 @@ tests =
prop_inbound_governor_no_unsupported_state
, testProperty "connection_manager_valid_transition_order"
prop_connection_manager_valid_transition_order
, testProperty "inbound_governor_valid_transition_order"
prop_inbound_governor_valid_transition_order
, testProperty "unit_connection_terminated_when_negotiating"
unit_connection_terminated_when_negotiating
, testGroup "generators"
Expand Down Expand Up @@ -1929,13 +1931,42 @@ verifyAbstractTransitionOrder (h:t) = go t h
-- 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)))
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 a 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`.
--
Expand Down Expand Up @@ -2005,6 +2036,10 @@ prop_connection_manager_valid_transitions serverAcc (ArbDataFlow dataFlow)
(Script (toBearerInfo absBi :| [noAttenuation]))
maxAcceptedConnectionsLimit l

-- | Property wrapping `multinodeExperiment`.
--
-- Note: this test validates the order of connection manager state changes.
--
prop_connection_manager_valid_transition_order :: Int
-> ArbDataFlow
-> AbsBearerInfo
Expand Down Expand Up @@ -2125,6 +2160,45 @@ prop_inbound_governor_no_unsupported_state serverAcc (ArbDataFlow dataFlow)
(Script (toBearerInfo absBi :| [noAttenuation]))
maxAcceptedConnectionsLimit l

-- | Property wrapping `multinodeExperiment`.
--
-- Note: this test validates the order of inbound governor state changes.
--
prop_inbound_governor_valid_transition_order :: Int
-> ArbDataFlow
-> AbsBearerInfo
-> MultiNodeScript Int TestAddr
-> Property
prop_inbound_governor_valid_transition_order 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.
--
Expand Down Expand Up @@ -2435,6 +2509,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 'Trace'
. (\(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)
Expand Down Expand Up @@ -2514,6 +2616,7 @@ showCEvs (CloseInboundConnection{}) = "CloseInboundConnection"
showCEvs (CloseOutboundConnection{}) = "CloseOutboundConnection"
showCEvs (ShutdownClientServer{}) = "ShutdownClientServer"


-- classify negotiated data flow
classifyPrunings :: [ConnectionManagerTrace SimAddr (ConnectionHandlerTrace UnversionedProtocol DataFlowProtocolData)] -> Sum Int
classifyPrunings =
Expand Down Expand Up @@ -2613,7 +2716,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.
Expand Down

0 comments on commit 7bd91a3

Please sign in to comment.