diff --git a/CHANGELOG.md b/CHANGELOG.md index 07cdf62b24..755724993e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,7 +17,7 @@ pre: "5. " #### 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 index bda100e0b8..18870a4ba5 100644 --- 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 index b2b6971fb0..4bfe6ea0ae 100644 --- 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 index adf400e071..4b0e8f1748 100644 --- 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 index 88cc629737..ffedf547a5 100644 --- 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 index 23a7b02905..a4eda50d20 100644 --- 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 index 878a50ad6a..3d0b34c5c0 100644 --- 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