Catch ErrorCall in runHandler and expose it as a message with status 200

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/9340
GitOrigin-RevId: b18fe167c8d26027d70da239606bd66d61e9bb43

server/src-lib/Hasura/Logging.hs

@@ -17,6 +17,7 @@ module Hasura.Logging
     UnstructuredLog (..),
     Logger (..),
     LogLevel (..),
+    UnhandledInternalErrorLog (..),
     mkLogger,
     nullLogger,
     LoggerCtx (..),
@@ -42,7 +43,7 @@ module Hasura.Logging
 where
 
 import Control.AutoUpdate qualified as Auto
-import Control.Exception (catch)
+import Control.Exception (ErrorCall (ErrorCallWithLocation), catch)
 import Control.FoldDebounce qualified as FDebounce
 import Control.Monad.Trans.Control
 import Control.Monad.Trans.Managed (ManagedT (..), allocate)
@@ -56,6 +57,7 @@ import Data.HashSet qualified as Set
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.SerializableBlob qualified as SB
+import Data.String (fromString)
 import Data.Text qualified as T
 import Data.Time.Clock qualified as Time
 import Data.Time.Format qualified as Format
@@ -130,6 +132,7 @@ instance J.FromJSON (EngineLogType Hasura) where
 data InternalLogTypes
   = -- | mostly for debug logs - see @debugT@, @debugBS@ and @debugLBS@ functions
     ILTUnstructured
+  | ILTUnhandledInternalError
   | ILTEventTrigger
   | ILTEventTriggerProcess
   | ILTScheduledTrigger
@@ -150,6 +153,7 @@ instance Hashable InternalLogTypes
 instance Witch.From InternalLogTypes Text where
   from = \case
     ILTUnstructured -> "unstructured"
+    ILTUnhandledInternalError -> "unhandled-internal-error"
     ILTEventTrigger -> "event-trigger"
     ILTEventTriggerProcess -> "event-trigger-process"
     ILTScheduledTrigger -> "scheduled-trigger"
@@ -264,6 +268,22 @@ data LoggerCtx impl = LoggerCtx
     _lcEnabledLogTypes :: !(Set.HashSet (EngineLogType impl))
   }
 
+-- * Unhandled Internal Errors
+
+-- | We expect situations where there are code paths that should not occur and we throw
+--   an 'error' on this code paths. If our assumptions are incorrect and infact
+--   these errors do occur, we want to log them.
+newtype UnhandledInternalErrorLog = UnhandledInternalErrorLog ErrorCall
+
+instance ToEngineLog UnhandledInternalErrorLog Hasura where
+  toEngineLog (UnhandledInternalErrorLog (ErrorCallWithLocation err loc)) =
+    ( LevelError,
+      ELTInternal ILTUnhandledInternalError,
+      J.object [("error", fromString err), ("location", fromString loc)]
+    )
+
+-- * LoggerSettings
+
 data LoggerSettings = LoggerSettings
   { -- | should current time be cached (refreshed every sec)
     _lsCachedTimestamp :: !Bool,

server/src-lib/Hasura/Server/App.hs

@@ -27,6 +27,7 @@ where
 
 import Control.Concurrent.Async.Lifted.Safe qualified as LA
 import Control.Exception (IOException, throwIO, try)
+import Control.Exception.Lifted (ErrorCall (..), catch)
 import Control.Monad.Morph (hoist)
 import Control.Monad.Stateless
 import Control.Monad.Trans.Control (MonadBaseControl)
@@ -164,10 +165,15 @@ instance MonadTrans Handler where
 instance (Monad m) => UserInfoM (Handler m) where
   askUserInfo = asks hcUser
 
-runHandler :: (HasResourceLimits m, MonadBaseControl IO m) => HandlerCtx -> Handler m a -> m (Either QErr a)
-runHandler ctx (Handler r) = do
+runHandler :: (HasResourceLimits m, MonadBaseControl IO m) => L.Logger L.Hasura -> HandlerCtx -> Handler m a -> m (Either QErr a)
+runHandler logger ctx (Handler r) = do
   handlerLimit <- askHTTPHandlerLimit
-  runExceptT $ flip runReaderT ctx $ runResourceLimits handlerLimit r
+  runExceptT (runReaderT (runResourceLimits handlerLimit r) ctx)
+    `catch` \errorCallWithLoc@(ErrorCallWithLocation txt _) -> do
+      liftBase $ L.unLogger logger $ L.UnhandledInternalErrorLog errorCallWithLoc
+      pure
+        $ throw500WithDetail "Internal Server Error"
+        $ object [("error", fromString txt)]
 
 data APIResp
   = JSONResp !(HttpResponse EncJSON)
@@ -360,14 +366,14 @@ mkSpockAction appStateRef qErrEncoder qErrModifier apiHandler = do
       -- in the case of a simple get/post we don't have to send the webhook anything
       AHGet handler -> do
         (userInfo, authHeaders, handlerState, includeInternal, extraUserInfo) <- getInfo Nothing
-        res <- lift $ runHandler handlerState handler
+        res <- lift $ runHandler (_lsLogger appEnvLoggers) handlerState handler
         pure (res, userInfo, authHeaders, includeInternal, Nothing, extraUserInfo)
       AHPost handler -> do
         (userInfo, authHeaders, handlerState, includeInternal, extraUserInfo) <- getInfo Nothing
         (queryJSON, parsedReq) <-
           runExcept (parseBody reqBody) `onLeft` \e -> do
             logErrorAndResp (Just userInfo) requestId req (reqBody, Nothing) includeInternal origHeaders extraUserInfo (qErrModifier e)
-        res <- lift $ runHandler handlerState $ handler parsedReq
+        res <- lift $ runHandler (_lsLogger appEnvLoggers) handlerState $ handler parsedReq
         pure (res, userInfo, authHeaders, includeInternal, Just queryJSON, extraUserInfo)
       -- in this case we parse the request _first_ and then send the request to the webhook for auth
       AHGraphQLRequest handler -> do
@@ -379,7 +385,7 @@ mkSpockAction appStateRef qErrEncoder qErrModifier apiHandler = do
             logErrorAndResp (Just userInfo) requestId req (reqBody, Nothing) False origHeaders extraUserInfo (qErrModifier e)
         (userInfo, authHeaders, handlerState, includeInternal, extraUserInfo) <- getInfo (Just parsedReq)
 
-        res <- lift $ runHandler handlerState $ handler parsedReq
+        res <- lift $ runHandler (_lsLogger appEnvLoggers) handlerState $ handler parsedReq
         pure (res, userInfo, authHeaders, includeInternal, Just queryJSON, extraUserInfo)
 
     -- https://opentelemetry.io/docs/reference/specification/trace/semantic_conventions/span-general/#general-identity-attributes