hasura · codingkarthik · Apr 8, 2020 · Apr 9, 2020 · Apr 9, 2020 · Apr 9, 2020
diff --git a/CHANGELOG.md b/CHANGELOG.md
@@ -91,6 +91,7 @@ Read more about check constraints on [Postgres Docs](https://www.postgresql.org/
 - docs: add note on pg versions for actions (#4034)
 - docs: add latest prerelease build info (close #4041) (#4048)
 - docs: add AuthGuardian JWT guide (#3958)
+- server: add ability to accept custom json (extensions) while error handling actions (#4001)
 
 ## `v1.2.0-beta.2`
 

@@ -59,7 +59,7 @@ An error object looks like:
 
     {
       "message": "<mandatory error message>",
-      "code": "<optional error code>"
+      "extensions": "<optional custom json>"
     }
 
 The HTTP status code must be ``4xx`` for an error response.

@@ -111,7 +111,7 @@ defaultTxErrorHandler = mkTxErrorHandler (const False)
 mkTxErrorHandler :: (PGErrorType -> Bool) -> Q.PGTxErr -> QErr
 mkTxErrorHandler isExpectedError txe = fromMaybe unexpectedError expectedError
   where
-    unexpectedError = (internalError "database query error") { qeInternal = Just $ J.toJSON txe }
+    unexpectedError = (internalError "postgres query error") { qeExtra = Just $ EEInternal $ J.toJSON txe }
     expectedError = uncurry err400 <$> do
       errorDetail <- Q.getPGStmtErr txe
       message <- Q.edMessage errorDetail

@@ -163,7 +163,7 @@ getExecPlanPartial userInfo sc enableAL req = do
 
     modErr e =
       let msg = "query is not in any of the allowlists"
-      in e{qeInternal = Just $ J.object [ "message" J..= J.String msg]}
+      in e{qeExtra = Just $ EEInternal $ J.object [ "message" J..= J.String msg]}
 
 
 -- An execution operation, in case of

@@ -82,7 +82,7 @@ fetchRemoteSchema manager name def@(RemoteSchemaInfo url headerConf _ timeout) =
 
     throwWithInternal msg v =
       let err = err400 RemoteSchemaError $ T.pack msg
-      in throwError err{qeInternal = Just $ J.toJSON v}
+      in throwError err{qeExtra = Just $ EEInternal $ J.toJSON v}
 
     httpExceptMsg =
       "HTTP exception occurred while sending the request to " <> show url

@@ -63,9 +63,9 @@ $(J.deriveJSON (J.aesonDrop 4 J.snakeCase) ''ActionWebhookPayload)
 data ActionWebhookErrorResponse
   = ActionWebhookErrorResponse
   { _awerMessage :: !Text
-  , _awerCode    :: !(Maybe Text)
+  , _awerExtensions :: !(Maybe J.Value)
   } deriving (Show, Eq)
-$(J.deriveJSON (J.aesonDrop 5 J.snakeCase) ''ActionWebhookErrorResponse)
+$(J.deriveFromJSON (J.aesonDrop 5 J.snakeCase) ''ActionWebhookErrorResponse)
 
 data ActionWebhookResponse
   = AWRArray ![J.Object]
@@ -320,7 +320,7 @@ asyncActionsProcessor cacheRef pgPool httpManager = forever $ do
         update hdb_catalog.hdb_action_log
         set errors = $1, status = 'error'
         where id = $2
-      |] (Q.AltJ e, actionId) False
+      |] (Q.AltJ $ encodeGQLErr True e, actionId) False -- includeInternal set to true due to the status 500 errors
 
     setCompleted :: UUID.UUID -> J.Value -> IO ()
     setCompleted actionId responsePayload =
@@ -398,7 +398,7 @@ callWebhook manager outputType outputFields reqHeaders confHeaders
 
       if | HTTP.statusIsSuccessful responseStatus  -> do
              let expectingArray = isListType outputType
-                 addInternalToErr e = e{qeInternal = Just webhookResponseObject}
+                 addInternalToErr e = e{qeExtra = Just $ EEInternal $ webhookResponseObject}
              -- Incase any error, add webhook response in internal
              modifyQErr addInternalToErr $ do
                webhookResponse <- decodeValue responseValue
@@ -414,10 +414,10 @@ callWebhook manager outputType outputFields reqHeaders confHeaders
                pure (webhookResponse, mkSetCookieHeaders responseWreq)
 
          | HTTP.statusIsClientError responseStatus -> do
-             ActionWebhookErrorResponse message maybeCode <-
+             ActionWebhookErrorResponse message maybeExtension <-
                modifyErr ("webhook response: " <>) $ decodeValue responseValue
-             let code = maybe Unexpected ActionWebhookCode maybeCode
-                 qErr = QErr [] responseStatus message code Nothing
+             let qErr = QErr [] responseStatus message Unexpected $
+                   (maybe Nothing (Just . EEExtensions) maybeExtension)
              throwError qErr
 
          | otherwise ->

@@ -101,7 +101,7 @@ runRunSQL RunSQL {..} = do
       fmap (encJFromJValue @RunSQLRes) . liftTx . Q.multiQE rawSqlErrHandler . Q.fromText
       where
         rawSqlErrHandler txe =
-          (err400 PostgresError "query execution failed") { qeInternal = Just $ toJSON txe }
+          (err400 PostgresError "query execution failed") { qeExtra = Just $ EEInternal $ toJSON txe }
 
     -- see Note [Checking metadata consistency in run_sql]
     containsDDLKeyword :: Text -> Bool

@@ -499,7 +499,7 @@ withMetadataCheck cascade action = do
     checkNewInconsistentMeta originalInconsMeta currentInconsMeta =
       unless (null newInconsistentObjects) $
         throwError (err500 Unexpected "cannot continue due to newly found inconsistent metadata")
-          { qeInternal = Just $ toJSON newInconsistentObjects }
+          { qeExtra = Just $ EEInternal $ toJSON newInconsistentObjects }
       where
         diffInconsistentObjects = M.difference `on` groupInconsistentMetadataById
         newInconsistentObjects = nub $ concatMap toList $

@@ -66,7 +66,7 @@ performIteration iterationNumber cache inconsistencies dependencies = do
           -- unless we did something very wrong, so halt the process and abort with some
           -- debugging information.
           throwError (err500 Unexpected "schema dependency resolution failed to terminate")
-            { qeInternal = Just $ object
+            { qeExtra = Just $ EEInternal $ object
                 [ "inconsistent_objects" .= object
                   [ "old" .= inconsistencies
                   , "new" .= newInconsistencies ]

@@ -3,6 +3,7 @@
 module Hasura.RQL.Types.Error
        ( Code(..)
        , QErr(..)
+       , ErrorExtra(..)
        , encodeQErr
        , encodeGQLErr
        , noInternalQErrEnc
@@ -138,13 +139,31 @@ instance Show Code where
     InvalidCustomTypes    -> "invalid-custom-types"
     ActionWebhookCode t   -> T.unpack t
 
+-- ErrorExtra is a data type used to give
+-- additional information of the error
+-- occurred in JSON format.
+-- EEInternal is used when there's an error in the HGE
+-- or Postgres
+-- EEExtensions is used when the error has occurred outside
+-- hasura and we get an custom JSON error object
+-- Eg: Actions error handling of client side errors
+data ErrorExtra
+  = EEInternal !Value
+  | EEExtensions !Value
+  deriving (Show, Eq)
+
+instance ToJSON ErrorExtra where
+  toJSON = \case
+    EEInternal v -> v
+    EEExtensions v -> v
+
 data QErr
   = QErr
   { qePath     :: !JSONPath
   , qeStatus   :: !N.Status
   , qeError    :: !T.Text
   , qeCode     :: !Code
-  , qeInternal :: !(Maybe Value)
+  , qeExtra    :: !(Maybe ErrorExtra)
   } deriving (Show, Eq)
 
 instance ToJSON QErr where
@@ -154,12 +173,12 @@ instance ToJSON QErr where
     , "error" .= msg
     , "code"  .= show code
     ]
-  toJSON (QErr jPath _ msg code (Just ie)) =
+  toJSON (QErr jPath _ msg code (Just err)) =
     object
     [ "path"  .= encodeJSONPath jPath
     , "error" .= msg
     , "code"  .= show code
-    , "internal" .= ie
+    , "internal" .= err
     ]
 
 noInternalQErrEnc :: QErr -> Value
@@ -171,18 +190,21 @@ noInternalQErrEnc (QErr jPath _ msg code _) =
   ]
 
 encodeGQLErr :: Bool -> QErr -> Value
-encodeGQLErr includeInternal (QErr jPath _ msg code mIE) =
+encodeGQLErr includeInternal (QErr jPath _ msg code mExtra) =
   object
   [ "message" .= msg
   , "extensions" .= extnsObj
   ]
   where
-    extnsObj = object $ bool codeAndPath
-               (codeAndPath ++ internal) includeInternal
+    extnsObj = case mExtra of
+      Nothing -> object codeAndPath
+      Just (EEExtensions v) -> v
+      Just (EEInternal v) -> object $
+        bool codeAndPath (codeAndPath ++ ["internal" .= v]) includeInternal
+
     codeAndPath = [ "code" .= show code
                   , "path" .= encodeJSONPath jPath
                   ]
-    internal = maybe [] (\ie -> ["internal" .= ie]) mIE
 
 -- whether internal should be included or not
 encodeQErr :: Bool -> QErr -> Value
@@ -203,12 +225,12 @@ encodeJSONPath = format "$"
 instance Q.FromPGConnErr QErr where
   fromPGConnErr c =
     let e = err500 PostgresError "connection error"
-    in e {qeInternal = Just $ toJSON c}
+    in e {qeExtra = Just $ EEInternal $ toJSON c}
 
 instance Q.FromPGTxErr QErr where
   fromPGTxErr txe =
     let e = err500 PostgresError "postgres tx error"
-    in e {qeInternal = Just $ toJSON txe}
+    in e {qeExtra = Just $ EEInternal $ toJSON txe}
 
 err400 :: Code -> T.Text -> QErr
 err400 c t = QErr [] N.status400 t c Nothing
@@ -241,7 +263,7 @@ internalError = err500 Unexpected
 
 throw500WithDetail :: (QErrM m) => T.Text -> Value -> m a
 throw500WithDetail t detail =
-  throwError $ (err500 Unexpected t) {qeInternal = Just detail}
+  throwError $ (err500 Unexpected t) {qeExtra = Just $ EEInternal detail}
 
 modifyQErr :: (QErrM m)
            => (QErr -> QErr) -> m a -> m a

@@ -146,11 +146,11 @@ buildSchemaCacheFor objectId = do
 
   for_ (M.lookup objectId newInconsistentObjects) $ \matchingObjects -> do
     let reasons = T.intercalate ", " $ map imReason $ toList matchingObjects
-    throwError (err400 ConstraintViolation reasons) { qeInternal = Just $ toJSON matchingObjects }
+    throwError (err400 ConstraintViolation reasons) { qeExtra = Just $ EEInternal $ toJSON matchingObjects }
 
   unless (null newInconsistentObjects) $
     throwError (err400 Unexpected "cannot continue due to new inconsistent metadata")
-      { qeInternal = Just $ toJSON (nub . concatMap toList $ M.elems newInconsistentObjects) }
+      { qeExtra = Just $ EEInternal $ toJSON (nub . concatMap toList $ M.elems newInconsistentObjects) }
 
 -- | Like 'buildSchemaCache', but fails if there is any inconsistent metadata.
 buildSchemaCacheStrict :: (QErrM m, CacheRWM m) => m ()
@@ -160,7 +160,7 @@ buildSchemaCacheStrict = do
   let inconsObjs = scInconsistentObjs sc
   unless (null inconsObjs) $ do
     let err = err400 Unexpected "cannot continue due to inconsistent metadata"
-    throwError err{ qeInternal = Just $ toJSON inconsObjs }
+    throwError err{ qeExtra = Just $ EEInternal $ toJSON inconsObjs }
 
 -- | Executes the given action, and if any new 'InconsistentMetadata's are added to the schema
 -- cache as a result of its execution, raises an error.
@@ -175,6 +175,6 @@ withNewInconsistentObjsCheck action = do
         nub $ concatMap toList $ M.elems (currentObjects `diffInconsistentObjects` originalObjects)
   unless (null newInconsistentObjects) $
     throwError (err500 Unexpected "cannot continue due to newly found inconsistent metadata")
-      { qeInternal = Just $ toJSON newInconsistentObjects }
+      { qeExtra = Just $ EEInternal $ toJSON newInconsistentObjects }
 
   pure result
@@ -77,7 +77,7 @@ instance ToEngineLog MigrationResult Hasura where
     }
 
 -- A migration and (hopefully) also its inverse if we have it.
--- Polymorphic because `m` can be any `MonadTx`, `MonadIO` when 
+-- Polymorphic because `m` can be any `MonadTx`, `MonadIO` when
 -- used in the `migrations` function below.
 data MigrationPair m = MigrationPair
   { mpMigrate :: m ()
@@ -132,7 +132,7 @@ migrateCatalog migrationTime = do
               _            -> requiredError
           where
             requiredError =
-              (err500 PostgresError requiredMessage) { qeInternal = Just $ A.toJSON e }
+              (err500 PostgresError requiredMessage) { qeExtra = Just $ EEInternal $ A.toJSON e }
             requiredMessage =
               "pgcrypto extension is required, but it could not be created;"
               <> " encountered unknown postgres error"
@@ -159,12 +159,12 @@ migrateCatalog migrationTime = do
           pure (MRMigrated previousVersion, schemaCache)
       where
         neededMigrations = dropWhile ((/= previousVersion) . fst) (migrations False)
-        
+
     buildCacheAndRecreateSystemMetadata :: m (RebuildableSchemaCache m)
     buildCacheAndRecreateSystemMetadata = do
       schemaCache <- buildRebuildableSchemaCache
       view _2 <$> runCacheRWT schemaCache recreateSystemMetadata
-      
+
     updateCatalogVersion = setCatalogVersion latestCatalogVersionString migrationTime
 
     doesSchemaExist schemaName =
@@ -197,29 +197,29 @@ downgradeCatalog opts time = do
     downgradeFrom previousVersion
         | previousVersion == dgoTargetVersion opts = do
             pure MRNothingToDo
-        | otherwise = 
+        | otherwise =
             case neededDownMigrations (dgoTargetVersion opts) of
-              Left reason -> 
+              Left reason ->
                 throw400 NotSupported $
                   "This downgrade path (from "
-                    <> previousVersion <> " to " 
-                    <> dgoTargetVersion opts <> 
+                    <> previousVersion <> " to "
+                    <> dgoTargetVersion opts <>
                     ") is not supported, because "
                     <> reason
               Right path -> do
-                sequence_ path 
+                sequence_ path
                 unless (dgoDryRun opts) do
                   setCatalogVersion (dgoTargetVersion opts) time
                 pure (MRMigrated previousVersion)
-      
+
       where
-        neededDownMigrations newVersion = 
-          downgrade previousVersion newVersion 
+        neededDownMigrations newVersion =
+          downgrade previousVersion newVersion
             (reverse (migrations (dgoDryRun opts)))
 
-        downgrade 
+        downgrade
           :: T.Text
-          -> T.Text 
+          -> T.Text
           -> [(T.Text, MigrationPair m)]
           -> Either T.Text [m ()]
         downgrade lower upper = skipFutureDowngrades where
@@ -237,7 +237,7 @@ downgradeCatalog opts time = do
             | otherwise = skipFutureDowngrades xs
 
           dropOlderDowngrades [] = Left "the target version is unrecognized."
-          dropOlderDowngrades ((x, MigrationPair{ mpDown = Nothing }):_) = 
+          dropOlderDowngrades ((x, MigrationPair{ mpDown = Nothing }):_) =
             Left $ "there is no available migration back to version " <> x <> "."
           dropOlderDowngrades ((x, MigrationPair{ mpDown = Just y }):xs)
             | x == upper = Right [y]
@@ -271,7 +271,7 @@ migrations dryRun =
             if exists
               then [| Just (runTxOrPrint $(Q.sqlFromFile path)) |]
               else [| Nothing |]
-                 
+
           migrationsFromFile = map $ \(to :: Integer) ->
             let from = to - 1
             in [| ( $(TH.lift $ T.pack (show from))
@@ -288,7 +288,7 @@ migrations dryRun =
   where
     runTxOrPrint :: Q.Query -> m ()
     runTxOrPrint
-      | dryRun = 
+      | dryRun =
           liftIO . TIO.putStrLn . Q.getQueryText
       | otherwise = runTx