network-mux: mux runtime exceptions

These are seprate from `MuxError` as they indicate either internal bug or misuse of network-mux api.
IntersectMBO · Sep 17, 2021 · c0f55a3 · c0f55a3
1 parent 5074bf2
commit c0f55a3
Show file tree

Hide file tree

Showing 5 changed files with 42 additions and 12 deletions.
diff --git a/network-mux/src/Network/Mux.hs b/network-mux/src/Network/Mux.hs
@@ -294,7 +294,7 @@ miniProtocolJob tracer egressQueue
         readTVar w >>= check . BL.null
         writeTVar miniProtocolStatusVar StatusIdle
         putTMVar completionVar (Right result)
-          `orElse` (throwSTM (MuxError (MuxBlockedOnCompletionVar miniProtocolNum) ""))
+          `orElse` throwSTM (MuxBlockedOnCompletionVar miniProtocolNum)
         case remainder of
           Just trailing ->
             modifyTVar miniProtocolIngressQueue (BL.append trailing)
@@ -308,8 +308,7 @@ miniProtocolJob tracer egressQueue
       atomically $
         putTMVar completionVar (Left e)
         `orElse`
-        throwSTM (MuxError (MuxBlockedOnCompletionVar miniProtocolNum)
-                           ("when caught: " ++ show e))
+        throwSTM (MuxBlockedOnCompletionVar miniProtocolNum)
       return (MiniProtocolException miniProtocolNum miniProtocolDirEnum e)
 
     miniProtocolDirEnum :: MiniProtocolDir
@@ -594,6 +593,7 @@ traceMuxBearerState :: Tracer m MuxTrace -> MuxBearerState -> m ()
 traceMuxBearerState tracer state =
     traceWith tracer (MuxTraceState state)
 
+
 --
 -- Starting mini-protocol threads
 --
@@ -627,6 +627,7 @@ traceMuxBearerState tracer state =
 --
 runMiniProtocol :: forall mode m a.
                    ( MonadSTM   m
+                   , MonadThrow m
                    , MonadThrow (STM m)
                    )
                 => Mux mode m
@@ -653,8 +654,7 @@ runMiniProtocol Mux { muxMiniProtocols, muxControlCmdQueue , muxStatus}
       -- indicate a thread is running (or ready to start on demand)
       status <- readTVar miniProtocolStatusVar
       unless (status == StatusIdle) $
-        error $ "runMiniProtocol: protocol thread already running for "
-             ++ show ptclNum ++ " " ++ show ptclDir'
+        throwSTM (ProtocolAlreadyRunning ptclNum ptclDir' status)
       let !status' = case startMode of
                        StartOnDemand -> StatusStartOnDemand
                        StartEagerly  -> StatusRunning
@@ -673,8 +673,7 @@ runMiniProtocol Mux { muxMiniProtocols, muxControlCmdQueue , muxStatus}
     -- It is a programmer error to get the wrong protocol, but this is also
     -- very easy to avoid.
   | otherwise
-  = error $ "runMiniProtocol: no such protocol num and mode in this mux: "
-         ++ show ptclNum ++ " " ++ show ptclDir'
+  = throwIO (UnknownProtocol ptclNum ptclDir')
   where
     ptclDir' = protocolDirEnum ptclDir
 

diff --git a/network-mux/src/Network/Mux/Trace.hs b/network-mux/src/Network/Mux/Trace.hs
@@ -67,8 +67,8 @@ data MuxErrorType = MuxUnknownMiniProtocol
                   -- ^ Result of runMiniProtocol's completionAction in case of
                   -- an error or mux being closed while a mini-protocol was
                   -- still running, this is not a clean exit.
-                  | MuxBlockedOnCompletionVar !MiniProtocolNum
-                  -- ^  Mux blocked on @completionVar@.
+                  | MuxCleanShutdown
+                  -- ^ Mux stopped by 'stopMux'
                   deriving (Show, Eq)
 
 instance Exception MuxError where

diff --git a/network-mux/src/Network/Mux/Types.hs b/network-mux/src/Network/Mux/Types.hs
@@ -39,10 +39,13 @@ module Network.Mux.Types (
     , msLength
     , RemoteClockModel (..)
     , remoteClockPrecision
+
+    , MuxRuntimeError (..)
     ) where
 
 import           Prelude hiding (read)
 
+import           Control.Exception (Exception)
 import           Data.Functor (void)
 import           Data.Ix (Ix (..))
 import           Data.Word
@@ -173,7 +176,7 @@ data MiniProtocolState mode m = MiniProtocolState {
      }
 
 data MiniProtocolStatus = StatusIdle | StatusStartOnDemand | StatusRunning
-  deriving Eq
+  deriving (Eq, Show)
 
 data MuxSDUHeader = MuxSDUHeader {
       mhTimestamp :: !RemoteClockModel
@@ -255,3 +258,15 @@ muxBearerAsChannel bearer ptclNum ptclDir =
 
       noTimeout :: TimeoutFn m
       noTimeout _ r = Just <$> r
+
+--
+-- Errors
+--
+
+data MuxRuntimeError =
+    ProtocolAlreadyRunning    !MiniProtocolNum !MiniProtocolDir !MiniProtocolStatus
+  | UnknownProtocol           !MiniProtocolNum !MiniProtocolDir
+  | MuxBlockedOnCompletionVar !MiniProtocolNum
+  deriving Show
+
+instance Exception MuxRuntimeError
diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs
@@ -96,6 +96,7 @@ import qualified Codec.CBOR.Term as CBOR
 
 import           Network.TypedProtocol (Peer)
 import           Network.Mux (WithMuxBearer (..))
+import           Network.Mux.Types (MuxRuntimeError (..))
 
 import           Ouroboros.Network.Codec
 import           Ouroboros.Network.Driver (TraceSendRecv(..))
@@ -364,7 +365,7 @@ networkErrorPolicies = ErrorPolicies
                       MuxIngressQueueOverRun       -> Just ourBug
                       MuxInitiatorOnly             -> Just ourBug
                       MuxShutdown {}               -> Just ourBug
-                      MuxBlockedOnCompletionVar {} -> Just ourBug
+                      MuxCleanShutdown             -> Just ourBug
 
                       -- in case of bearer closed / or IOException we suspend
                       -- the peer for a short time
@@ -376,6 +377,13 @@ networkErrorPolicies = ErrorPolicies
                       MuxSDUReadTimeout       -> Just (SuspendPeer shortDelay shortDelay)
                       MuxSDUWriteTimeout      -> Just (SuspendPeer shortDelay shortDelay)
 
+      , ErrorPolicy
+          $ \(e :: MuxRuntimeError)
+                -> case e of
+                     ProtocolAlreadyRunning {}    -> Just ourBug
+                     UnknownProtocol {}           -> Just ourBug
+                     MuxBlockedOnCompletionVar {} -> Just ourBug
+
         -- Error thrown by 'IOManager', this is fatal on Windows, and it will
         -- never fire on other platofrms.
       , ErrorPolicy

diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs
@@ -105,6 +105,7 @@ import           Data.Word
 import qualified Codec.CBOR.Read as CBOR
 import qualified Codec.CBOR.Term as CBOR
 import           Network.Mux (WithMuxBearer (..))
+import           Network.Mux.Types (MuxRuntimeError (..))
 import qualified Network.Socket as Socket
 
 import           Ouroboros.Network.Codec
@@ -579,7 +580,14 @@ remoteNetworkErrorPolicy = ErrorPolicies {
                         MuxSDUReadTimeout            -> Just (SuspendPeer shortDelay shortDelay)
                         MuxSDUWriteTimeout           -> Just (SuspendPeer shortDelay shortDelay)
                         MuxShutdown {}               -> Just (SuspendPeer shortDelay shortDelay)
-                        MuxBlockedOnCompletionVar {} -> Just (SuspendPeer shortDelay shortDelay)
+                        MuxCleanShutdown             -> Just (SuspendPeer shortDelay shortDelay)
+
+        , ErrorPolicy
+            $ \(e :: MuxRuntimeError)
+                  -> case e of
+                       ProtocolAlreadyRunning {}    -> Just (SuspendPeer shortDelay shortDelay)
+                       UnknownProtocol {}           -> Just Throw
+                       MuxBlockedOnCompletionVar {} -> Just (SuspendPeer shortDelay shortDelay)
 
           -- Error policy for TxSubmission protocol: outbound side (client role)
         , ErrorPolicy