Log unexpected internal failures in addition to only replying to client.

  Closes #383.

CHANGELOG.md

@@ -16,6 +16,8 @@ pre: "<b>5. </b>"
 
 - A new transaction submission error: [ConflictingInputsAndReferences](https://ogmios.dev/mini-protocols/local-tx-submission#schema-3164/ConflictingInputsAndReferences) (`code=3164`).
 
+- The server now reports (log) unexpected failures happening during protocol execution instead of only replying to clients with an error. See [#383](https://github.com/CardanoSolutions/ogmios/pull/383).
+
 #### Changed
 
   > [!WARNING]

server/src/Ogmios/App/Protocol.hs

@@ -181,8 +181,18 @@ onUnmatchedMessage opts blob = do
         fail "unknown method in 'method' (beware names are case-sensitive)."
 
 -- | 'catch-all' handler which turns unexpected exception as internal errors.
-defaultWithInternalError :: MonadCatch m => Rpc.Options -> m a -> (Json -> m ()) -> Rpc.ToResponse r -> m a -> m a
-defaultWithInternalError opts continue yield toResponse = handle $ \(e :: SomeException) -> do
-    let (Rpc.Response _ mirror _) = toResponse (error "unused and unevaluated")
-    yield $ Rpc.ko opts $ Rpc.internalError mirror (displayException e)
-    continue
+defaultWithInternalError
+    :: MonadCatch m
+    => (SomeException -> m ())
+    -> Rpc.Options
+    -> m a
+    -> (Json -> m ())
+    -> Rpc.ToResponse r
+    -> m a
+    -> m a
+defaultWithInternalError reportException opts continue yield toResponse = do
+    handle $ \(e :: SomeException) -> do
+        let (Rpc.Response _ mirror _) = toResponse (error "unused and unevaluated")
+        reportException e
+        yield $ Rpc.ko opts $ Rpc.internalError mirror (displayException e)
+        continue

server/src/Ogmios/App/Server/WebSocket.hs

@@ -350,7 +350,11 @@ withOuroborosClients tr opts codecs maxInFlight sensors exUnitsEvaluator getGene
              }
   where
     catchError :: forall b r. m b -> (Json -> m ()) -> Rpc.ToResponse r -> m b -> m b
-    catchError = defaultWithInternalError opts
+    catchError =
+        defaultWithInternalError reportException opts
+      where
+        reportException =
+            logWith tr . WebSocketUnknownException . toText . displayException
 
     yield :: Json -> m ()
     yield = send conn . jsonToByteString

server/test/unit/Ogmios/App/Protocol/StateQuerySpec.hs

@@ -220,7 +220,7 @@ withStateQueryClient action seed = do
     (recvQ, sendQ) <- atomically $ (,) <$> newTQueue <*> newTQueue
     let innerCodecs = mkStateQueryCodecs Rpc.defaultOptions encodePoint encodeAcquireFailure encodeAcquireExpired
     let getGenesisConfig = let nope = error "unimplemented" in StateQuery.GetGenesisConfig nope nope nope nope
-    let catchError = defaultWithInternalError Rpc.defaultOptions
+    let catchError = defaultWithInternalError (const $ return ()) Rpc.defaultOptions
     let client = mkStateQueryClient nullTracer catchError innerCodecs getGenesisConfig recvQ (atomically . writeTQueue sendQ)
     let codec = codecs defaultSlotsPerEpoch nodeToClientV_Latest & cStateQueryCodec
     withMockChannel (stateQueryMockPeer seed codec) $ \channel -> do

server/test/unit/Ogmios/App/Protocol/TxMonitorSpec.hs

@@ -224,7 +224,7 @@ withTxMonitorClient action seed = do
     (recvQ, sendQ) <- atomically $ (,) <$> newTQueue <*> newTQueue
     let opts = Rpc.defaultOptions
     let innerCodecs = mkTxMonitorCodecs opts encodeGenTxId (encodeTx (MetadataNoSchema, omitOptionalCbor))
-    let client = mkTxMonitorClient (defaultWithInternalError opts) innerCodecs recvQ (atomically . writeTQueue sendQ) NodeToClientV_16
+    let client = mkTxMonitorClient (defaultWithInternalError (const $ return ()) opts) innerCodecs recvQ (atomically . writeTQueue sendQ) NodeToClientV_16
     let codec = codecs defaultSlotsPerEpoch nodeToClientV_Latest & cTxMonitorCodec
     withMockChannel (txMonitorMockPeer seed codec) $ \channel -> do
         result <- race