Stop logging internal actions errors

PR-URL: hasura/graphql-engine-mono#11072
GitOrigin-RevId: 565fe917fe367f7438e6c14b8ac50b4310212241

.ghcversion

@@ -1 +1 @@
-9.6.5
+9.10.1

scripts/make/ghcid.mk

@@ -66,6 +66,11 @@ ghcid-test-harness:
 ghcid-pg-client:
 	$(call run_ghcid,pg-client)
 
+.PHONY: ghcid-hasura-base
+## ghcid-hasura-base: build and watch hasura-base in ghcid
+ghcid-hasura-base:
+	$(call run_ghcid,hasura-base)
+
 .PHONY: ghcid-api-tests-pro
 ## ghcid-api-tests-pro: build and watch api-tests in pro
 ghcid-api-tests-pro:

server/lib/hasura-base/src/Hasura/Base/Error.hs

@@ -5,6 +5,7 @@ module Hasura.Base.Error
   ( Code (..),
     QErr (..),
     QErrExtra (..),
+    IncludeInternalErrors (..),
     overrideQErrStatus,
     prefixQErr,
     showQErr,
@@ -227,11 +228,16 @@ prefixQErr prefix err = err {qeError = prefix <> qeError err}
 showQErr :: QErr -> Text
 showQErr = TL.toStrict . TL.decodeUtf8 . encode
 
-encodeGQLErr :: Bool -> QErr -> Encoding
+data IncludeInternalErrors = IncludeInternalErrors | HideInternalErrors
+  deriving (Eq, Ord, Show)
+
+encodeGQLErr :: IncludeInternalErrors -> QErr -> Encoding
 encodeGQLErr includeInternal (QErr jPath _ msg code maybeExtra) =
   pairs (("message" .= msg) <> (J.pair "extensions" extnsObj))
   where
-    appendIf cond a b = if cond then a <> b else a
+    appendInternal a b = case includeInternal of
+      IncludeInternalErrors -> a <> b
+      HideInternalErrors -> a
 
     extnsObj = case maybeExtra of
       Nothing -> pairs codeAndPath
@@ -240,15 +246,15 @@ encodeGQLErr includeInternal (QErr jPath _ msg code maybeExtra) =
       -- contains a `code` field:
       Just (ExtraExtensions v) -> toEncoding v
       Just (ExtraInternal v) ->
-        pairs $ appendIf includeInternal codeAndPath ("internal" .= v)
+        pairs $ appendInternal codeAndPath ("internal" .= v)
     codeAndPath =
       ("path" .= encodeJSONPath jPath)
         <> ("code" .= code)
 
 -- whether internal should be included or not
-encodeQErr :: Bool -> QErr -> Encoding
-encodeQErr True = toEncoding
-encodeQErr False = toEncoding . removeInternalErr
+encodeQErr :: IncludeInternalErrors -> QErr -> Encoding
+encodeQErr IncludeInternalErrors = toEncoding
+encodeQErr HideInternalErrors = toEncoding . removeInternalErr
   where
     removeInternalErr :: QErr -> QErr
     removeInternalErr err = err {qeInternal = Nothing}

server/src-lib/Hasura/App.hs

@@ -1356,6 +1356,7 @@ mkHGEServer setupHook appStateRef consoleType ekgStore = do
           (leActionEvents lockedEventsCtx)
           Nothing
           appEnvAsyncActionsFetchBatchSize
+          HideInternalErrors
           (acHeaderPrecedence <$> getAppContext appStateRef)
 
       -- start a background thread to handle async action live queries

server/src-lib/Hasura/GraphQL/Execute.hs

@@ -388,6 +388,7 @@ getResolvedExecPlan
   traceQueryStatus = do
     let gCtx = makeGQLContext userInfo sc queryType
         tracesPropagator = getOtelTracesPropagator $ scOpenTelemetryConfig sc
+        includeInternalErrors = Init.shouldIncludeInternal (_uiRole userInfo) responseErrorsConfig
 
     -- Construct the full 'ResolvedExecutionPlan' from the 'queryParts :: SingleOperation'.
     (parameterizedQueryHash, resolvedExecPlan, modelInfoList') <-
@@ -435,6 +436,7 @@ getResolvedExecPlan
               (scSetGraphqlIntrospectionOptions sc)
               reqId
               maybeOperationName
+              includeInternalErrors
               headerPrecedence
               traceQueryStatus
           Tracing.attachMetadata [("graphql.operation.type", "mutation")]

server/src-lib/Hasura/GraphQL/Execute/Action.hs

@@ -156,9 +156,10 @@ resolveActionExecution ::
   IR.AnnActionExecution Void ->
   ActionExecContext ->
   Maybe GQLQueryText ->
+  IncludeInternalErrors ->
   HeaderPrecedence ->
   ActionExecution
-resolveActionExecution httpManager env logger tracesPropagator prometheusMetrics IR.AnnActionExecution {..} ActionExecContext {..} gqlQueryText headerPrecedence =
+resolveActionExecution httpManager env logger tracesPropagator prometheusMetrics IR.AnnActionExecution {..} ActionExecContext {..} gqlQueryText includeInternalErrors headerPrecedence =
   ActionExecution $ first (encJFromOrderedValue . makeActionResponseNoRelations _aaeFields _aaeOutputType _aaeOutputFields True) <$> runWebhook
   where
     handlerPayload = ActionWebhookPayload (ActionContext _aaeName) _aecSessionVariables _aaePayload gqlQueryText
@@ -186,6 +187,7 @@ resolveActionExecution httpManager env logger tracesPropagator prometheusMetrics
           _aaeTimeOut
           _aaeRequestTransform
           _aaeResponseTransform
+          includeInternalErrors
           headerPrecedence
 
 throwUnexpected :: (MonadError QErr m) => Text -> m ()
@@ -382,9 +384,10 @@ resolveAsyncActionQuery userInfo annAction responseErrorsConfig =
                       IR.AsyncId -> mkAnnFldFromPGCol idColumn
                       IR.AsyncCreatedAt -> mkAnnFldFromPGCol createdAtColumn
                       IR.AsyncErrors ->
-                        if (shouldIncludeInternal (_uiRole userInfo) responseErrorsConfig)
-                          then RS.mkAnnColumnField (fst errorsColumn) (ColumnScalar (snd errorsColumn)) NoRedaction Nothing
-                          else
+                        case shouldIncludeInternal (_uiRole userInfo) responseErrorsConfig of
+                          IncludeInternalErrors ->
+                            RS.mkAnnColumnField (fst errorsColumn) (ColumnScalar (snd errorsColumn)) NoRedaction Nothing
+                          HideInternalErrors ->
                             RS.mkAnnColumnField
                               (fst errorsColumn)
                               (ColumnScalar (snd errorsColumn))
@@ -418,7 +421,9 @@ resolveAsyncActionQuery userInfo annAction responseErrorsConfig =
     mkQErrFromErrorValue :: J.Value -> QErr
     mkQErrFromErrorValue actionLogResponseError =
       let internal = ExtraInternal <$> (actionLogResponseError ^? key "internal")
-          internal' = if shouldIncludeInternal (_uiRole userInfo) responseErrorsConfig then internal else Nothing
+          internal' = case shouldIncludeInternal (_uiRole userInfo) responseErrorsConfig of
+            IncludeInternalErrors -> internal
+            HideInternalErrors -> Nothing
           errorMessageText = fromMaybe "internal: error in parsing the action log" $ actionLogResponseError ^? key "error" . _String
           codeMaybe = actionLogResponseError ^? key "code" . _String
           code = maybe Unexpected ActionWebhookCode codeMaybe
@@ -490,9 +495,10 @@ asyncActionsProcessor ::
   STM.TVar (Set LockedActionEventId) ->
   Maybe GH.GQLQueryText ->
   Int ->
+  IncludeInternalErrors ->
   IO HeaderPrecedence ->
   m (Forever m)
-asyncActionsProcessor getEnvHook logger getSCFromRef' getFetchInterval lockedActionEvents gqlQueryText fetchBatchSize getHeaderPrecedence =
+asyncActionsProcessor getEnvHook logger getSCFromRef' getFetchInterval lockedActionEvents gqlQueryText fetchBatchSize includeInternalErrors getHeaderPrecedence =
   return
     $ Forever ()
     $ const
@@ -573,6 +579,7 @@ asyncActionsProcessor getEnvHook logger getSCFromRef' getFetchInterval lockedAct
                   timeout
                   metadataRequestTransform
                   metadataResponseTransform
+                  includeInternalErrors
                   headerPrecedence
             resE <-
               setActionStatus actionId $ case eitherRes of
@@ -605,6 +612,7 @@ callWebhook ::
   Timeout ->
   Maybe RequestTransform ->
   Maybe MetadataResponseTransform ->
+  IncludeInternalErrors ->
   HeaderPrecedence ->
   m (ActionWebhookResponse, HTTP.ResponseHeaders)
 callWebhook
@@ -624,6 +632,7 @@ callWebhook
   timeoutSeconds
   metadataRequestTransform
   metadataResponseTransform
+  includeInternalErrors
   headerPrecedence = do
     resolvedConfHeaders <- makeHeadersFromConf env confHeaders
     let clientHeaders = if forwardClientHeaders then mkClientHeadersForward ignoredClientHeaders reqHeaders else mempty
@@ -684,9 +693,9 @@ callWebhook
 
     case httpResponse of
       Left e ->
-        throw500WithDetail "http exception when calling webhook"
-          $ J.toJSON
-          $ ActionInternalError (getHttpExceptionJson (ShowErrorInfo True) $ HttpException e) requestInfo Nothing
+        let msg = "http exception when calling webhook"
+         in throwInternalError msg includeInternalErrors
+              $ ActionInternalError (getHttpExceptionJson (ShowErrorInfo True) $ HttpException e) requestInfo Nothing
       Right responseWreq -> do
         -- TODO(SOLOMON): Remove 'wreq'
         let responseBody = responseWreq ^. Wreq.responseBody
@@ -722,23 +731,34 @@ callWebhook
             (pmActionBytesReceived prometheusMetrics)
             responseBodySize
         logger :: (L.Logger L.Hasura) <- asks getter
-        L.unLoggerTracing logger $ ActionHandlerLog req transformedReq requestBodySize transformedReqSize responseBodySize actionName actionType
+        L.unLoggerTracing logger
+          $ ActionHandlerLog
+            req
+            transformedReq
+            requestBodySize
+            transformedReqSize
+            responseBodySize
+            actionName
+            actionType
 
         case J.eitherDecode transformedResponseBody of
           Left e -> do
             let responseInfo = mkResponseInfo $ J.String $ bsToTxt $ BL.toStrict responseBody
-            throw500WithDetail "not a valid json response from webhook"
-              $ J.toJSON
-              $ ActionInternalError (J.toJSON $ "invalid JSON: " <> e) requestInfo
-              $ Just responseInfo
+                msg = "not a valid json response from webhook"
+             in throwInternalError msg includeInternalErrors
+                  $ ActionInternalError (J.toJSON $ "invalid JSON: " <> e) requestInfo
+                  $ Just responseInfo
           Right responseValue -> do
             let responseInfo = mkResponseInfo responseValue
                 addInternalToErr e =
-                  let actionInternalError =
-                        J.toJSON
-                          $ ActionInternalError (J.String "unexpected response") requestInfo
-                          $ Just responseInfo
-                   in e {qeInternal = Just $ ExtraInternal actionInternalError}
+                  case includeInternalErrors of
+                    HideInternalErrors -> e
+                    IncludeInternalErrors ->
+                      let actionInternalError =
+                            J.toJSON
+                              $ ActionInternalError (J.String "unexpected response") requestInfo
+                              $ Just responseInfo
+                       in e {qeInternal = Just $ ExtraInternal actionInternalError}
 
             if
               | HTTP.statusIsSuccessful responseStatus -> do
@@ -757,10 +777,19 @@ callWebhook
                         J.toJSON
                           $ "expecting 2xx or 4xx status code, but found "
                           ++ show (HTTP.statusCode responseStatus)
-                  throw500WithDetail "internal error"
-                    $ J.toJSON
-                    $ ActionInternalError err requestInfo
-                    $ Just responseInfo
+                      msg = "internal error"
+                   in throwInternalError msg includeInternalErrors
+                        $ ActionInternalError err requestInfo
+                        $ Just responseInfo
+
+throwInternalError :: (MonadError QErr m) => Text -> IncludeInternalErrors -> ActionInternalError -> m a
+throwInternalError msg includeInternalErrors actionInternalError =
+  case includeInternalErrors of
+    HideInternalErrors -> throwError (internalError msg)
+    IncludeInternalErrors ->
+      throw500WithDetail msg
+        $ J.toJSON
+        $ actionInternalError
 
 processOutputSelectionSet ::
   TF.ArgumentExp v ->

server/src-lib/Hasura/GraphQL/Execute/Mutation.hs

@@ -58,13 +58,14 @@ convertMutationAction ::
   HTTP.RequestHeaders ->
   Maybe GH.GQLQueryText ->
   ActionMutation Void ->
+  IncludeInternalErrors ->
   HeaderPrecedence ->
   m ActionExecutionPlan
-convertMutationAction env logger tracesPropagator prometheusMetrics userInfo reqHeaders gqlQueryText action headerPrecedence = do
+convertMutationAction env logger tracesPropagator prometheusMetrics userInfo reqHeaders gqlQueryText action includeInternalErrors headerPrecedence = do
   httpManager <- askHTTPManager
   case action of
     AMSync s ->
-      pure $ AEPSync $ resolveActionExecution httpManager env logger tracesPropagator prometheusMetrics s actionExecContext gqlQueryText headerPrecedence
+      pure $ AEPSync $ resolveActionExecution httpManager env logger tracesPropagator prometheusMetrics s actionExecContext gqlQueryText includeInternalErrors headerPrecedence
     AMAsync s ->
       AEPAsyncMutation <$> resolveActionMutationAsync s reqHeaders userSession
   where
@@ -97,6 +98,7 @@ convertMutationSelectionSet ::
   RequestId ->
   -- | Graphql Operation Name
   Maybe G.Name ->
+  IncludeInternalErrors ->
   HeaderPrecedence ->
   TraceQueryStatus ->
   m (ExecutionPlan, ParameterizedQueryHash, [ModelInfoPart])
@@ -116,6 +118,7 @@ convertMutationSelectionSet
   introspectionDisabledRoles
   reqId
   maybeOperationName
+  includeInternalErrors
   headerPrecedence
   traceQueryStatus = do
     mutationParser <-
@@ -130,7 +133,6 @@ convertMutationSelectionSet
     -- Process directives on the mutation
     _dirMap <- toQErr $ runParse (parseDirectives customDirectives (G.DLExecutable G.EDLMUTATION) resolvedDirectives)
     let parameterizedQueryHash = calculateParameterizedQueryHash resolvedSelSet
-
         resolveExecutionSteps rootFieldName rootFieldUnpreparedValue = Tracing.newSpan ("Resolve execution step for " <>> rootFieldName) Tracing.SKInternal do
           case rootFieldUnpreparedValue of
             RFDB sourceName exists ->
@@ -161,7 +163,7 @@ convertMutationSelectionSet
               (actionName, _fch) <- pure $ case noRelsDBAST of
                 AMSync s -> (_aaeName s, _aaeForwardClientHeaders s)
                 AMAsync s -> (_aamaName s, _aamaForwardClientHeaders s)
-              plan <- convertMutationAction env logger tracesPropagator prometheusMetrics userInfo reqHeaders (Just (GH._grQuery gqlUnparsed)) noRelsDBAST headerPrecedence
+              plan <- convertMutationAction env logger tracesPropagator prometheusMetrics userInfo reqHeaders (Just (GH._grQuery gqlUnparsed)) noRelsDBAST includeInternalErrors headerPrecedence
               let actionsModel = ModelInfoPart (toTxt actionName) ModelTypeAction Nothing Nothing (ModelOperationType G.OperationTypeMutation)
               pure $ (ExecStepAction plan (ActionsInfo actionName _fch) remoteJoins, [actionsModel]) -- `_fch` represents the `forward_client_headers` option from the action
               -- definition which is currently being ignored for actions that are mutations

server/src-lib/Hasura/GraphQL/Execute/Query.hs

@@ -38,7 +38,7 @@ import Hasura.RQL.Types.GraphqlSchemaIntrospection
 import Hasura.RQL.Types.Schema.Options as Options
 import Hasura.RemoteSchema.Metadata.Base (RemoteSchemaName (..))
 import Hasura.SQL.AnyBackend qualified as AB
-import Hasura.Server.Init.Config (ResponseInternalErrorsConfig (..))
+import Hasura.Server.Init.Config (ResponseInternalErrorsConfig (..), shouldIncludeInternal)
 import Hasura.Server.Prometheus (PrometheusMetrics (..))
 import Hasura.Server.Types (HeaderPrecedence, MonadGetPolicies, RequestId (..), TraceQueryStatus)
 import Hasura.Services.Network
@@ -167,6 +167,7 @@ convertQuerySelSet
                         s
                         (ActionExecContext reqHeaders (_uiSession userInfo))
                         (Just (GH._grQuery gqlUnparsed))
+                        (shouldIncludeInternal (_uiRole userInfo) responseErrorsConfig)
                         headerPrecedence,
                     _aaeName s,
                     _aaeForwardClientHeaders s

server/src-lib/Hasura/GraphQL/Execute/Subscription/Poll/LiveQuery.hs

@@ -238,7 +238,7 @@ pollLiveQuery pollerId pollerResponseState lqOpts (sourceName, sourceConfig) rol
     getCohortOperations cohorts = \case
       Left e ->
         -- TODO: this is internal error
-        let resp = throwError $ GQExecError [encodeGQLErr False e]
+        let resp = throwError $ GQExecError [encodeGQLErr HideInternalErrors e]
          in [(resp, cohortId, Nothing, snapshot) | (cohortId, snapshot) <- cohorts]
       Right responses -> do
         let cohortSnapshotMap = HashMap.fromList cohorts

server/src-lib/Hasura/GraphQL/Execute/Subscription/Poll/StreamingQuery.hs

@@ -515,7 +515,7 @@ pollStreamingQuery pollerId pollerResponseState streamingQueryOpts (sourceName,
 
     getCohortOperations cohorts = \case
       Left e ->
-        let resp = throwError $ GQExecError [encodeGQLErr False e]
+        let resp = throwError $ GQExecError [encodeGQLErr HideInternalErrors e]
          in [(resp, cohortId, Nothing, Nothing, snapshot) | (cohortId, snapshot) <- cohorts]
       Right responses -> do
         let cohortSnapshotMap = HashMap.fromList cohorts

server/src-lib/Hasura/GraphQL/Transport/HTTP/Protocol.hs

@@ -208,7 +208,7 @@ getOpNameFromParsedReq reqParsed =
   where
     execDefs = unGQLExecDoc $ _grQuery reqParsed
 
-encodeGQErr :: Bool -> QErr -> J.Encoding
+encodeGQErr :: IncludeInternalErrors -> QErr -> J.Encoding
 encodeGQErr includeInternal qErr =
   J.pairs (J.pair "errors" $ J.list id [encodeGQLErr includeInternal qErr])
 

server/src-lib/Hasura/GraphQL/Transport/WSServerApp.hs

@@ -142,6 +142,7 @@ createWSServerEnv appStateRef = do
       appEnvServerMetrics
       appEnvPrometheusMetrics
       appEnvTraceSamplingPolicy
+      appEnvLoggingSettings
 
 mkWSActions :: L.Logger L.Hasura -> WSSubProtocol -> WS.WSActions WSConnData
 mkWSActions logger subProtocol =

server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs

@@ -371,7 +371,7 @@ onConn wsId requestHead ipAddress onConnHActions = do
           (HTTP.statusCode $ qeStatus qErr)
           (HTTP.statusMessage $ qeStatus qErr)
           []
-          (LBS.toStrict $ J.encodingToLazyByteString $ encodeGQLErr False qErr)
+          (LBS.toStrict $ J.encodingToLazyByteString $ encodeGQLErr HideInternalErrors qErr)
 
     checkPath = case WS.requestPath requestHead of
       "/v1alpha1/graphql" -> return (ERTLegacy, E.QueryHasura)
@@ -881,6 +881,7 @@ onStart enabledLogTypes agentLicenseKey serverEnv wsConn shouldCaptureVariables
       _keepAliveDelay
       _serverMetrics
       prometheusMetrics
+      _loggerSettings
       _ = serverEnv
 
     -- Hook to retrieve the latest subscription options(live query + stream query options) from the `appStateRef`
@@ -909,7 +910,7 @@ onStart enabledLogTypes agentLicenseKey serverEnv wsConn shouldCaptureVariables
       sendMsg wsConn
         $ SMErr
         $ ErrorMsg opId
-        $ errFn False
+        $ errFn HideInternalErrors
         $ err400 StartFailed e
       liftIO $ logOpEv (ODProtoErr e) Nothing Nothing
       liftIO $ reportGQLQueryError granularPrometheusMetricsState mOpName Nothing Nothing
@@ -928,7 +929,7 @@ onStart enabledLogTypes agentLicenseKey serverEnv wsConn shouldCaptureVariables
       QErr ->
       ExceptT () m ()
     postExecErr granularPrometheusMetricsState reqId gqlOpType mOpName pqh qErr = do
-      let errFn = getErrFn errRespTy False
+      let errFn = getErrFn errRespTy HideInternalErrors
       liftIO $ logOpEv (ODQueryErr qErr) (Just reqId) Nothing
       postExecErr' granularPrometheusMetricsState gqlOpType mOpName pqh $ GQExecError $ pure $ errFn qErr
 
@@ -947,8 +948,8 @@ onStart enabledLogTypes agentLicenseKey serverEnv wsConn shouldCaptureVariables
       let errFn = getErrFn errRespTy
       logOpEv (ODQueryErr qErr) (Just reqId) Nothing
       let err = case errRespTy of
-            ERTLegacy -> errFn False qErr
-            ERTGraphqlCompliant -> fmtErrorMessage [errFn False qErr]
+            ERTLegacy -> errFn HideInternalErrors qErr
+            ERTGraphqlCompliant -> fmtErrorMessage [errFn HideInternalErrors qErr]
       sendMsg wsConn (SMErr $ ErrorMsg opId err)
 
     sendSuccResp ::