Wrap in-protocol exceptions and yield a corresponding internal failure

The server now return an `internalError` when an unexpected error occurs in the communication between Ogmios and the node. Before, Ogmios would simply log an exception and no response would be sent back to client applications. Now, clients correctly receive an unsuccessful response with the same `id` as present in the request. Fixes #346.
CardanoSolutions · Nov 5, 2023 · f1851d4 · f1851d4
1 parent dd75b33
commit f1851d4
Show file tree

Hide file tree

Showing 7 changed files with 75 additions and 36 deletions.
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -17,7 +17,7 @@ pre: "<b>5. </b>"
 
 #### Changed
 
-- N/A
+- The server now return an `internalError` when an unexpected error occurs in the communication between Ogmios and the node. Before, Ogmios would simply log an exception and no response would be sent back to client applications. Now, clients correctly receive an unsuccessful response with the same `id` as present in the request. See [#346](https://github.com/CardanoSolutions/ogmios/issues/346).
 
 #### Removed
 

diff --git a/server/modules/json-rpc/src/Codec/Json/Rpc.hs b/server/modules/json-rpc/src/Codec/Json/Rpc.hs
@@ -218,10 +218,10 @@ ok toResult =
 --
 -- since @1.0.0
 ko :: Fault -> Json.Encoding
-ko Fault{faultCode,faultMessage,faultMirror} =
+ko Fault{faultCode,faultMessage,faultId} =
     mkResponse
         (\_resolve reject () -> reject faultCode faultMessage Nothing)
-        (Response Nothing faultMirror ())
+        (Response Nothing faultId ())
 {-# INLINEABLE ko #-}
 
 -- | Serialize a given request to JSON

diff --git a/server/modules/json-rpc/src/Codec/Json/Rpc/Handler.hs b/server/modules/json-rpc/src/Codec/Json/Rpc/Handler.hs
@@ -109,7 +109,7 @@ instance ToJSON FaultCode where
 --
 -- @since 1.0.0
 data Fault = Fault
-    { faultMirror :: Mirror
+    { faultId :: Mirror
     , faultCode :: FaultCode
     , faultMessage :: String
     } deriving (Generic, Show)

diff --git a/server/src/Ogmios/App/Protocol.hs b/server/src/Ogmios/App/Protocol.hs
@@ -6,6 +6,7 @@
 
 module Ogmios.App.Protocol
     ( onUnmatchedMessage
+    , defaultWithInternalError
     ) where
 
 import Ogmios.Prelude
@@ -19,6 +20,9 @@ import Data.List
 import GHC.Generics
     ( Rep
     )
+import Ogmios.Control.Exception
+    ( MonadCatch (..)
+    )
 import Ogmios.Data.EraTranslation
     ( MultiEraUTxO
     )
@@ -177,3 +181,10 @@ onUnmatchedMessage blob = do
         fail "unknown method in 'method' (beware names are case-sensitive)."
       where
         opts = Rpc.defaultOptions
+
+-- | 'catch-all' handler which turns unexpected exception as internal errors.
+defaultWithInternalError :: MonadCatch m => m a -> (Json -> m ()) -> Rpc.ToResponse r -> m a -> m a
+defaultWithInternalError continue yield toResponse = handle $ \(e :: SomeException) -> do
+    let (Rpc.Response _ mirror _) = toResponse (error "unused and unevaluated")
+    yield $ Rpc.ko $ Rpc.internalError mirror (displayException e)
+    continue
diff --git a/server/src/Ogmios/App/Protocol/StateQuery.hs b/server/src/Ogmios/App/Protocol/StateQuery.hs
@@ -55,8 +55,12 @@ import Data.Aeson
     ( ToJSON (..)
     , genericToEncoding
     )
+import Ogmios.App.Protocol
+    ( defaultWithInternalError
+    )
 import Ogmios.Control.Exception
-    ( MonadThrow
+    ( MonadCatch
+    , MonadThrow
     )
 import Ogmios.Control.MonadLog
     ( HasSeverityAnnotation (..)
@@ -114,6 +118,7 @@ import qualified Ouroboros.Network.Protocol.LocalStateQuery.Client as LSQ
 mkStateQueryClient
     :: forall m crypto block point query.
         ( MonadThrow m
+        , MonadCatch m
         , MonadSTM m
         , MonadLog m
         , block ~ HardForkBlock (CardanoEras crypto)
@@ -141,12 +146,14 @@ mkStateQueryClient tr StateQueryCodecs{..} GetGenesisConfig{..} queue yield =
         :: m (LSQ.ClientStIdle block point query m ())
     clientStIdle = await >>= \case
         MsgAcquireLedgerState (AcquireLedgerState pt) toResponse ->
-            pure $ LSQ.SendMsgAcquire (Just pt) (clientStAcquiring pt toResponse)
+            defaultWithInternalError clientStIdle yield toResponse $ do
+                pure $ LSQ.SendMsgAcquire (Just pt) (clientStAcquiring pt toResponse)
         MsgReleaseLedgerState ReleaseLedgerState toResponse -> do
             yield $ encodeReleaseLedgerStateResponse (toResponse ReleaseLedgerStateResponse)
             clientStIdle
         MsgQueryLedgerState query toResponse -> do
-            pure $ LSQ.SendMsgAcquire Nothing (clientStAcquiringTip query toResponse)
+            defaultWithInternalError clientStIdle yield toResponse $ do
+                pure $ LSQ.SendMsgAcquire Nothing (clientStAcquiringTip query toResponse)
 
     clientStAcquiring
         :: Point block
@@ -237,12 +244,13 @@ mkStateQueryClient tr StateQueryCodecs{..} GetGenesisConfig{..} queue yield =
         -> m (LSQ.ClientStAcquired block point query m ())
     clientStAcquired pt = await >>= \case
         MsgAcquireLedgerState (AcquireLedgerState pt') toResponse ->
-            pure $ LSQ.SendMsgReAcquire (Just pt') (clientStAcquiring pt' toResponse)
+            defaultWithInternalError (clientStAcquired pt) yield toResponse $ do
+                pure $ LSQ.SendMsgReAcquire (Just pt') (clientStAcquiring pt' toResponse)
         MsgReleaseLedgerState ReleaseLedgerState toResponse -> do
             yield $ encodeReleaseLedgerStateResponse (toResponse ReleaseLedgerStateResponse)
             pure $ LSQ.SendMsgRelease clientStIdle
         MsgQueryLedgerState Query{rawQuery = query,queryInEra} toResponse ->
-            withCurrentEra queryInEra $ \case
+            defaultWithInternalError (clientStAcquired pt) yield toResponse $ withCurrentEra queryInEra $ \case
                 Nothing -> do
                     let response = QueryUnavailableInCurrentEra
                     yield $ encodeQueryLedgerStateResponse $ toResponse response

diff --git a/server/src/Ogmios/App/Protocol/TxMonitor.hs b/server/src/Ogmios/App/Protocol/TxMonitor.hs
@@ -45,6 +45,12 @@ import Ogmios.Prelude hiding
     ( id
     )
 
+import Ogmios.App.Protocol
+    ( defaultWithInternalError
+    )
+import Ogmios.Control.Exception
+    ( MonadCatch
+    )
 import Ogmios.Control.MonadSTM
     ( MonadSTM (..)
     )
@@ -81,6 +87,7 @@ import Ouroboros.Network.Protocol.LocalTxMonitor.Client
 mkTxMonitorClient
     :: forall m block.
         ( MonadSTM m
+        , MonadCatch m
         , HasTxId (GenTx block)
         )
     => TxMonitorCodecs block
@@ -100,9 +107,10 @@ mkTxMonitorClient TxMonitorCodecs{..} queue yield =
         :: m (ClientStIdle (GenTxId block) (GenTx block) SlotNo m ())
     clientStIdle = await >>= \case
         MsgAcquireMempool AcquireMempool toResponse ->
-            pure $ SendMsgAcquire $ \slot -> do
-                yield $ encodeAcquireMempoolResponse $ toResponse $ AcquireMempoolResponse slot
-                clientStAcquired
+            defaultWithInternalError clientStIdle yield toResponse $ do
+                pure $ SendMsgAcquire $ \slot -> do
+                    yield $ encodeAcquireMempoolResponse $ toResponse $ AcquireMempoolResponse slot
+                    clientStAcquired
         MsgNextTransaction NextTransaction{} toResponse -> do
             yield $ encodeNextTransactionResponse $ toResponse NextTransactionMustAcquireFirst
             clientStIdle
@@ -118,29 +126,34 @@ mkTxMonitorClient TxMonitorCodecs{..} queue yield =
 
     clientStAcquired
         :: m (ClientStAcquired (GenTxId block) (GenTx block) SlotNo m ())
-    clientStAcquired = await <&> \case
+    clientStAcquired = await >>= \case
         MsgAcquireMempool AcquireMempool toResponse ->
-            SendMsgAwaitAcquire $ \slot -> do
-                yield $ encodeAcquireMempoolResponse $ toResponse $ AcquireMempoolResponse slot
-                clientStAcquired
+            defaultWithInternalError clientStAcquired yield toResponse $ do
+                pure $ SendMsgAwaitAcquire $ \slot -> do
+                    yield $ encodeAcquireMempoolResponse $ toResponse $ AcquireMempoolResponse slot
+                    clientStAcquired
         MsgNextTransaction NextTransaction{fields} toResponse ->
-            SendMsgNextTx $ \mTx -> do
-                let response = case fields of
-                        Nothing ->
-                            NextTransactionResponseId (txId <$> mTx)
-                        Just NextTransactionAllFields ->
-                            NextTransactionResponseTx mTx
-                yield $ encodeNextTransactionResponse $ toResponse response
-                clientStAcquired
+            defaultWithInternalError clientStAcquired yield toResponse $ do
+                pure $ SendMsgNextTx $ \mTx -> do
+                    let response = case fields of
+                            Nothing ->
+                                NextTransactionResponseId (txId <$> mTx)
+                            Just NextTransactionAllFields ->
+                                NextTransactionResponseTx mTx
+                    yield $ encodeNextTransactionResponse $ toResponse response
+                    clientStAcquired
         MsgHasTransaction HasTransaction{id} toResponse ->
-            SendMsgHasTx id $ \has -> do
-                yield $ encodeHasTransactionResponse $ toResponse $ HasTransactionResponse{has}
-                clientStAcquired
+            defaultWithInternalError clientStAcquired yield toResponse $ do
+                pure $ SendMsgHasTx id $ \has -> do
+                    yield $ encodeHasTransactionResponse $ toResponse $ HasTransactionResponse{has}
+                    clientStAcquired
         MsgSizeOfMempool SizeOfMempool toResponse ->
-            SendMsgGetSizes $ \mempool -> do
-                yield $ encodeSizeOfMempoolResponse $ toResponse $ SizeOfMempoolResponse{mempool}
-                clientStAcquired
+            defaultWithInternalError clientStAcquired yield toResponse $ do
+                pure $ SendMsgGetSizes $ \mempool -> do
+                    yield $ encodeSizeOfMempoolResponse $ toResponse $ SizeOfMempoolResponse{mempool}
+                    clientStAcquired
         MsgReleaseMempool ReleaseMempool toResponse ->
-            SendMsgRelease $ do
-                yield $ encodeReleaseMempoolResponse $ toResponse Released
-                clientStIdle
+            defaultWithInternalError clientStAcquired yield toResponse $ do
+                pure $ SendMsgRelease $ do
+                    yield $ encodeReleaseMempoolResponse $ toResponse Released
+                    clientStIdle
diff --git a/server/src/Ogmios/App/Protocol/TxSubmission.hs b/server/src/Ogmios/App/Protocol/TxSubmission.hs
@@ -54,6 +54,12 @@ import Data.Type.Equality
     ( testEquality
     , (:~:) (..)
     )
+import Ogmios.App.Protocol
+    ( defaultWithInternalError
+    )
+import Ogmios.Control.Exception
+    ( MonadCatch
+    )
 import Ogmios.Control.MonadSTM
     ( MonadSTM (..)
     , TQueue
@@ -145,6 +151,7 @@ import qualified Ouroboros.Network.Protocol.LocalStateQuery.Client as LSQ
 mkTxSubmissionClient
     :: forall m block.
         ( MonadSTM m
+        , MonadCatch m
         , HasTxId (SerializedTransaction block)
         )
     => TxSubmissionCodecs block
@@ -166,8 +173,8 @@ mkTxSubmissionClient TxSubmissionCodecs{..} ExecutionUnitsEvaluator{..} queue yi
         :: m (LocalTxClientStIdle (SerializedTransaction block) (SubmitTransactionError block) m ())
     clientStIdle = await >>= \case
         MsgSubmitTransaction SubmitTransaction{transaction = request} toResponse -> do
-            case request of
-                MultiEraDecoderSuccess transaction ->
+            defaultWithInternalError clientStIdle yield toResponse $ case request of
+                MultiEraDecoderSuccess transaction -> do
                     pure $ SendMsgSubmitTx transaction $ \result -> do
                         mkSubmitTransactionResponse transaction result
                             & toResponse
@@ -182,7 +189,7 @@ mkTxSubmissionClient TxSubmissionCodecs{..} ExecutionUnitsEvaluator{..} queue yi
                     clientStIdle
 
         MsgEvaluateTransaction EvaluateTransaction{additionalUtxo, transaction = request} toResponse -> do
-            case request of
+            defaultWithInternalError clientStIdle yield toResponse $ case request of
                 MultiEraDecoderSuccess transaction -> do
                     result <- evaluateExecutionUnitsM (additionalUtxo, transaction)
                     result