mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-17 20:41:49 +03:00
409 lines
12 KiB
Haskell
409 lines
12 KiB
Haskell
{-# LANGUAGE Arrows #-}
|
|
|
|
module Hasura.Base.Error
|
|
( Code(..)
|
|
, QErr(..)
|
|
, encodeJSONPath
|
|
, encodeQErr
|
|
, encodeGQLErr
|
|
, noInternalQErrEnc
|
|
, err400
|
|
, err404
|
|
, err405
|
|
, err401
|
|
, err409
|
|
, err500
|
|
, internalError
|
|
|
|
, QErrM
|
|
, throw400
|
|
, throw404
|
|
, throw405
|
|
, throw409
|
|
, throw500
|
|
, throw500WithDetail
|
|
, throw401
|
|
|
|
, iResultToMaybe
|
|
|
|
-- Aeson helpers
|
|
, runAesonParser
|
|
, decodeValue
|
|
|
|
-- Modify error messages
|
|
, modifyErr
|
|
, modifyErrAndSet500
|
|
, modifyQErr
|
|
, modifyErrA
|
|
|
|
-- Attach context
|
|
, withPathK
|
|
, withPathKA
|
|
, withPathI
|
|
, withPathIA
|
|
, indexedFoldM
|
|
, indexedFoldlA'
|
|
, indexedForM
|
|
, indexedMapM
|
|
, indexedTraverseA
|
|
, indexedForM_
|
|
, indexedMapM_
|
|
, indexedTraverseA_
|
|
) where
|
|
|
|
import Hasura.Prelude
|
|
|
|
import Control.Arrow.Extended
|
|
import Data.Aeson
|
|
import Data.Aeson.Internal
|
|
import Data.Aeson.Types
|
|
|
|
import qualified Data.Text as T
|
|
import qualified Database.PG.Query as Q
|
|
import qualified Network.HTTP.Types as N
|
|
|
|
data Code
|
|
= PermissionDenied
|
|
| NotNullViolation
|
|
| NotExists
|
|
| AlreadyExists
|
|
| PostgresError
|
|
| PostgresMaxConnectionsError
|
|
| MSSQLError
|
|
| DatabaseConnectionTimeout
|
|
| BigQueryError
|
|
| NotSupported
|
|
| DependencyError
|
|
| InvalidHeaders
|
|
| InvalidJSON
|
|
| AccessDenied
|
|
| ParseFailed
|
|
| ConstraintError
|
|
| PermissionError
|
|
| NotFound
|
|
| Unexpected
|
|
| UnexpectedPayload
|
|
| NoUpdate
|
|
| AlreadyTracked
|
|
| AlreadyUntracked
|
|
| InvalidParams
|
|
| AlreadyInit
|
|
| ConstraintViolation
|
|
| DataException
|
|
| BadRequest
|
|
| MethodNotAllowed
|
|
| Conflict
|
|
| InvalidConfiguration
|
|
-- Graphql error
|
|
| NoTables
|
|
| ValidationFailed
|
|
| Busy
|
|
-- JWT Auth errors
|
|
| JWTRoleClaimMissing
|
|
| JWTInvalidClaims
|
|
| JWTInvalid
|
|
| JWTInvalidKey
|
|
-- Remote schemas
|
|
| RemoteSchemaError
|
|
| RemoteSchemaConflicts
|
|
| CoercionError
|
|
-- Websocket/Subscription errors
|
|
| StartFailed
|
|
| InvalidCustomTypes
|
|
-- Actions Webhook code
|
|
| ActionWebhookCode !Text
|
|
-- Custom code for extending this sum-type easily
|
|
| CustomCode !Text
|
|
deriving (Eq)
|
|
|
|
instance Show Code where
|
|
show = \case
|
|
NotNullViolation -> "not-null-violation"
|
|
DataException -> "data-exception"
|
|
BadRequest -> "bad-request"
|
|
ConstraintViolation -> "constraint-violation"
|
|
PermissionDenied -> "permission-denied"
|
|
NotExists -> "not-exists"
|
|
AlreadyExists -> "already-exists"
|
|
AlreadyTracked -> "already-tracked"
|
|
AlreadyUntracked -> "already-untracked"
|
|
PostgresError -> "postgres-error"
|
|
PostgresMaxConnectionsError -> "postgres-max-connections-error"
|
|
MSSQLError -> "mssql-error"
|
|
DatabaseConnectionTimeout -> "connection-timeout-error"
|
|
-- TODO (Naveen): We don't use the above error anywhere, do we remove this?
|
|
NotSupported -> "not-supported"
|
|
DependencyError -> "dependency-error"
|
|
InvalidHeaders -> "invalid-headers"
|
|
InvalidJSON -> "invalid-json"
|
|
AccessDenied -> "access-denied"
|
|
ParseFailed -> "parse-failed"
|
|
ConstraintError -> "constraint-error"
|
|
PermissionError -> "permission-error"
|
|
NotFound -> "not-found"
|
|
Unexpected -> "unexpected"
|
|
UnexpectedPayload -> "unexpected-payload"
|
|
NoUpdate -> "no-update"
|
|
InvalidParams -> "invalid-params"
|
|
AlreadyInit -> "already-initialised"
|
|
NoTables -> "no-tables"
|
|
ValidationFailed -> "validation-failed"
|
|
Busy -> "busy"
|
|
JWTRoleClaimMissing -> "jwt-missing-role-claims"
|
|
JWTInvalidClaims -> "jwt-invalid-claims"
|
|
JWTInvalid -> "invalid-jwt"
|
|
JWTInvalidKey -> "invalid-jwt-key"
|
|
RemoteSchemaError -> "remote-schema-error"
|
|
RemoteSchemaConflicts -> "remote-schema-conflicts"
|
|
CoercionError -> "coercion-error"
|
|
StartFailed -> "start-failed"
|
|
InvalidCustomTypes -> "invalid-custom-types"
|
|
MethodNotAllowed -> "method-not-allowed"
|
|
Conflict -> "conflict"
|
|
BigQueryError -> "bigquery-error"
|
|
InvalidConfiguration -> "invalid-configuration"
|
|
ActionWebhookCode t -> T.unpack t
|
|
CustomCode t -> T.unpack t
|
|
|
|
data QErr
|
|
= QErr
|
|
{ qePath :: !JSONPath
|
|
, qeStatus :: !N.Status
|
|
, qeError :: !Text
|
|
, qeCode :: !Code
|
|
, qeInternal :: !(Maybe Value)
|
|
} deriving (Show, Eq)
|
|
|
|
instance ToJSON QErr where
|
|
toJSON (QErr jPath _ msg code Nothing) =
|
|
object
|
|
[ "path" .= encodeJSONPath jPath
|
|
, "error" .= msg
|
|
, "code" .= show code
|
|
]
|
|
toJSON (QErr jPath _ msg code (Just ie)) =
|
|
object
|
|
[ "path" .= encodeJSONPath jPath
|
|
, "error" .= msg
|
|
, "code" .= show code
|
|
, "internal" .= ie
|
|
]
|
|
|
|
noInternalQErrEnc :: QErr -> Value
|
|
noInternalQErrEnc (QErr jPath _ msg code _) =
|
|
object
|
|
[ "path" .= encodeJSONPath jPath
|
|
, "error" .= msg
|
|
, "code" .= show code
|
|
]
|
|
|
|
encodeGQLErr :: Bool -> QErr -> Value
|
|
encodeGQLErr includeInternal (QErr jPath _ msg code mIE) =
|
|
object
|
|
[ "message" .= msg
|
|
, "extensions" .= extnsObj
|
|
]
|
|
where
|
|
extnsObj = object $ bool codeAndPath
|
|
(codeAndPath ++ internal) 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
|
|
encodeQErr True = toJSON
|
|
encodeQErr _ = noInternalQErrEnc
|
|
|
|
encodeJSONPath :: JSONPath -> String
|
|
encodeJSONPath = format "$"
|
|
where
|
|
format pfx [] = pfx
|
|
format pfx (Index idx:parts) = format (pfx ++ "[" ++ show idx ++ "]") parts
|
|
format pfx (Key key:parts) = format (pfx ++ formatKey key) parts
|
|
|
|
formatKey key
|
|
| specialChars sKey = "['" ++ sKey ++ "']"
|
|
| otherwise = "." ++ sKey
|
|
where
|
|
sKey = T.unpack key
|
|
specialChars [] = True
|
|
-- first char must not be number
|
|
specialChars (c:xs) = notElem c (alphabet ++ "_") ||
|
|
any (`notElem` (alphaNumerics ++ "_-")) xs
|
|
|
|
-- Postgres Connection Errors
|
|
instance Q.FromPGConnErr QErr where
|
|
-- | According to <https://github.com/hasura/graphql-engine-mono/issues/800>
|
|
-- we want to track when we receive max connections reached error from
|
|
-- Postgres. But @libpq@ does not provide any structured errors for connection
|
|
-- errors [1]. It only provides an error message as string. So to capture max
|
|
-- connections error we are resorting to substring matching here. This will,
|
|
-- obviously, fail if the error message changes in libpq.
|
|
-- [1]: <https://www.postgresql.org/docs/current/libpq-status.html#LIBPQ-PQERRORMESSAGE>
|
|
fromPGConnErr c
|
|
| "too many clients" `T.isInfixOf` (Q.getConnErr c) =
|
|
let e = err500 PostgresMaxConnectionsError "max connections reached on postgres"
|
|
in e {qeInternal = Just $ toJSON c}
|
|
|
|
fromPGConnErr c =
|
|
let e = err500 PostgresError "connection error"
|
|
in e {qeInternal = Just $ toJSON c}
|
|
|
|
-- Postgres Transaction error
|
|
instance Q.FromPGTxErr QErr where
|
|
fromPGTxErr txe =
|
|
let e = err500 PostgresError "postgres tx error"
|
|
in e {qeInternal = Just $ toJSON txe}
|
|
|
|
err400 :: Code -> Text -> QErr
|
|
err400 c t = QErr [] N.status400 t c Nothing
|
|
|
|
err404 :: Code -> Text -> QErr
|
|
err404 c t = QErr [] N.status404 t c Nothing
|
|
|
|
err405 :: Code -> Text -> QErr
|
|
err405 c t = QErr [] N.status405 t c Nothing
|
|
|
|
err401 :: Code -> Text -> QErr
|
|
err401 c t = QErr [] N.status401 t c Nothing
|
|
|
|
err409 :: Code -> Text -> QErr
|
|
err409 c t = QErr [] N.status409 t c Nothing
|
|
|
|
err500 :: Code -> Text -> QErr
|
|
err500 c t = QErr [] N.status500 t c Nothing
|
|
|
|
type QErrM m = (MonadError QErr m)
|
|
|
|
throw400 :: (QErrM m) => Code -> Text -> m a
|
|
throw400 c t = throwError $ err400 c t
|
|
|
|
throw404 :: (QErrM m) => Text -> m a
|
|
throw404 t = throwError $ err404 NotFound t
|
|
|
|
-- | MethodNotAllowed
|
|
throw405 :: (QErrM m) => Text -> m a
|
|
throw405 t = throwError $ err405 MethodNotAllowed t
|
|
|
|
-- | AccessDenied
|
|
throw401 :: (QErrM m) => Text -> m a
|
|
throw401 t = throwError $ err401 AccessDenied t
|
|
|
|
-- | Conflict
|
|
throw409 :: (QErrM m) => Text -> m a
|
|
throw409 t = throwError $ err409 Conflict t
|
|
|
|
throw500 :: (QErrM m) => Text -> m a
|
|
throw500 t = throwError $ internalError t
|
|
|
|
internalError :: Text -> QErr
|
|
internalError = err500 Unexpected
|
|
|
|
throw500WithDetail :: (QErrM m) => Text -> Value -> m a
|
|
throw500WithDetail t detail =
|
|
throwError $ (err500 Unexpected t) {qeInternal = Just detail}
|
|
|
|
modifyQErr :: (QErrM m)
|
|
=> (QErr -> QErr) -> m a -> m a
|
|
modifyQErr f a = catchError a (throwError . f)
|
|
|
|
modifyErr :: (QErrM m)
|
|
=> (Text -> Text)
|
|
-> m a -> m a
|
|
modifyErr f = modifyQErr (liftTxtMod f)
|
|
|
|
modifyErrA :: (ArrowError QErr arr) => arr (e, s) a -> arr (e, (Text -> Text, s)) a
|
|
modifyErrA f = proc (e, (g, s)) -> (| mapErrorA (f -< (e, s)) |) (liftTxtMod g)
|
|
|
|
liftTxtMod :: (Text -> Text) -> QErr -> QErr
|
|
liftTxtMod f (QErr path st s c i) = QErr path st (f s) c i
|
|
|
|
modifyErrAndSet500 :: (QErrM m)
|
|
=> (Text -> Text)
|
|
-> m a -> m a
|
|
modifyErrAndSet500 f = modifyQErr (liftTxtMod500 f)
|
|
|
|
liftTxtMod500 :: (Text -> Text) -> QErr -> QErr
|
|
liftTxtMod500 f (QErr path _ s c i) = QErr path N.status500 (f s) c i
|
|
|
|
withPathE :: (ArrowError QErr arr) => arr (e, s) a -> arr (e, (JSONPathElement, s)) a
|
|
withPathE f = proc (e, (pe, s)) -> (| mapErrorA ((e, s) >- f) |) (injectPrefix pe)
|
|
where
|
|
injectPrefix pe (QErr path st msg code i) = QErr (pe:path) st msg code i
|
|
|
|
withPathKA :: (ArrowError QErr arr) => arr (e, s) a -> arr (e, (Text, s)) a
|
|
withPathKA f = second (first $ arr Key) >>> withPathE f
|
|
|
|
withPathK :: (QErrM m) => Text -> m a -> m a
|
|
withPathK a = runKleisli proc m -> (| withPathKA (m >- bindA) |) a
|
|
|
|
withPathIA :: (ArrowError QErr arr) => arr (e, s) a -> arr (e, (Int, s)) a
|
|
withPathIA f = second (first $ arr Index) >>> withPathE f
|
|
|
|
withPathI :: (QErrM m) => Int -> m a -> m a
|
|
withPathI a = runKleisli proc m -> (| withPathIA (m >- bindA) |) a
|
|
|
|
indexedFoldlA'
|
|
:: (ArrowChoice arr, ArrowError QErr arr, Foldable t)
|
|
=> arr (e, (b, (a, s))) b -> arr (e, (b, (t a, s))) b
|
|
indexedFoldlA' f = proc (e, (acc0, (xs, s))) ->
|
|
(| foldlA' (\acc (i, v) -> (| withPathIA ((e, (acc, (v, s))) >- f) |) i)
|
|
|) acc0 (zip [0..] (toList xs))
|
|
|
|
indexedFoldM :: (QErrM m, Foldable t) => (b -> a -> m b) -> b -> t a -> m b
|
|
indexedFoldM f acc0 = runKleisli proc xs ->
|
|
(| indexedFoldlA' (\acc v -> f acc v >- bindA) |) acc0 xs
|
|
|
|
indexedTraverseA_
|
|
:: (ArrowChoice arr, ArrowError QErr arr, Foldable t)
|
|
=> arr (e, (a, s)) b -> arr (e, (t a, s)) ()
|
|
indexedTraverseA_ f = proc (e, (xs, s)) ->
|
|
(| indexedFoldlA' (\() x -> do { (e, (x, s)) >- f; () >- returnA }) |) () xs
|
|
|
|
indexedMapM_ :: (QErrM m, Foldable t) => (a -> m b) -> t a -> m ()
|
|
indexedMapM_ f = runKleisli proc xs -> (| indexedTraverseA_ (\x -> f x >- bindA) |) xs
|
|
|
|
indexedForM_ :: (QErrM m, Foldable t) => t a -> (a -> m b) -> m ()
|
|
indexedForM_ = flip indexedMapM_
|
|
|
|
indexedTraverseA
|
|
:: (ArrowChoice arr, ArrowError QErr arr)
|
|
=> arr (e, (a, s)) b -> arr (e, ([a], s)) [b]
|
|
indexedTraverseA f = proc (e, (xs, s)) ->
|
|
(| traverseA (\(i, x) -> (| withPathIA ((e, (x, s)) >- f) |) i)
|
|
|) (zip [0..] (toList xs))
|
|
|
|
indexedMapM :: (QErrM m) => (a -> m b) -> [a] -> m [b]
|
|
indexedMapM f = traverse (\(i, x) -> withPathI i (f x)) . zip [0..]
|
|
|
|
indexedForM :: (QErrM m) => [a] -> (a -> m b) -> m [b]
|
|
indexedForM = flip indexedMapM
|
|
|
|
liftIResult :: (QErrM m) => IResult a -> m a
|
|
liftIResult (IError path msg) =
|
|
throwError $ QErr path N.status400 (T.pack $ formatMsg msg) ParseFailed Nothing
|
|
liftIResult (ISuccess a) =
|
|
return a
|
|
|
|
iResultToMaybe :: IResult a -> Maybe a
|
|
iResultToMaybe (IError _ _) = Nothing
|
|
iResultToMaybe (ISuccess a) = Just a
|
|
|
|
formatMsg :: String -> String
|
|
formatMsg str = case T.splitOn "the key " txt of
|
|
[_, txt2] -> case T.splitOn " was not present" txt2 of
|
|
[key, _] -> "the key '" ++ T.unpack key ++ "' was not present"
|
|
_ -> str
|
|
_ -> str
|
|
where
|
|
txt = T.pack str
|
|
|
|
runAesonParser :: (QErrM m) => (v -> Parser a) -> v -> m a
|
|
runAesonParser p =
|
|
liftIResult . iparse p
|
|
|
|
decodeValue :: (FromJSON a, QErrM m) => Value -> m a
|
|
decodeValue = liftIResult . ifromJSON
|