{-| Module : PostgREST.Error Description : PostgREST error HTTP responses -} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE RecordWildCards #-} module PostgREST.Error ( errorResponseFor , ApiRequestError(..) , PgError(..) , Error(..) , errorPayload , status ) where import qualified Data.Aeson as JSON import qualified Data.ByteString.Char8 as BS import qualified Data.CaseInsensitive as CI import qualified Data.FuzzySet as Fuzzy import qualified Data.HashMap.Strict as HM import qualified Data.Map.Internal as M import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T import qualified Hasql.Pool as SQL import qualified Hasql.Session as SQL import qualified Network.HTTP.Types.Status as HTTP import Data.Aeson ((.:), (.:?), (.=)) import Network.Wai (Response, responseLBS) import Network.HTTP.Types.Header (Header) import PostgREST.ApiRequest.Types (ApiRequestError (..), QPError (..), RaiseError (..), RangeError (..)) import PostgREST.MediaType (MediaType (..)) import qualified PostgREST.MediaType as MediaType import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..), Schema) import PostgREST.SchemaCache.Relationship (Cardinality (..), Junction (..), Relationship (..), RelationshipsMap) import PostgREST.SchemaCache.Routine (Routine (..), RoutineParam (..)) import Protolude class (JSON.ToJSON a) => PgrstError a where status :: a -> HTTP.Status headers :: a -> [Header] errorPayload :: a -> LByteString errorPayload = JSON.encode errorResponseFor :: a -> Response errorResponseFor err = let baseHeader = MediaType.toContentType MTApplicationJSON in responseLBS (status err) (baseHeader : headers err) $ errorPayload err instance PgrstError ApiRequestError where status AggregatesNotAllowed{} = HTTP.status400 status AmbiguousRelBetween{} = HTTP.status300 status AmbiguousRpc{} = HTTP.status300 status MediaTypeError{} = HTTP.status406 status InvalidBody{} = HTTP.status400 status InvalidFilters = HTTP.status405 status InvalidPreferences{} = HTTP.status400 status InvalidRpcMethod{} = HTTP.status405 status InvalidRange{} = HTTP.status416 status NotFound = HTTP.status404 status NoRelBetween{} = HTTP.status400 status NoRpc{} = HTTP.status404 status NotEmbedded{} = HTTP.status400 status PutLimitNotAllowedError = HTTP.status400 status QueryParamError{} = HTTP.status400 status RelatedOrderNotToOne{} = HTTP.status400 status SpreadNotToOne{} = HTTP.status400 status UnacceptableFilter{} = HTTP.status400 status UnacceptableSchema{} = HTTP.status406 status UnsupportedMethod{} = HTTP.status405 status LimitNoOrderError = HTTP.status400 status ColumnNotFound{} = HTTP.status400 status GucHeadersError = HTTP.status500 status GucStatusError = HTTP.status500 status OffLimitsChangesError{} = HTTP.status400 status PutMatchingPkError = HTTP.status400 status SingularityError{} = HTTP.status406 status PGRSTParseError{} = HTTP.status500 status MaxAffectedViolationError{} = HTTP.status400 headers _ = mempty toJsonPgrstError :: ErrorCode -> Text -> Maybe JSON.Value -> Maybe JSON.Value -> JSON.Value toJsonPgrstError code msg details hint = JSON.object [ "code" .= code , "message" .= msg , "details" .= details , "hint" .= hint ] instance JSON.ToJSON ApiRequestError where toJSON (QueryParamError (QPError message details)) = toJsonPgrstError ApiRequestErrorCode00 message (Just (JSON.String details)) Nothing toJSON (InvalidRpcMethod method) = toJsonPgrstError ApiRequestErrorCode01 ("Cannot use the " <> T.decodeUtf8 method <> " method on RPC") Nothing Nothing toJSON (InvalidBody errorMessage) = toJsonPgrstError ApiRequestErrorCode02 (T.decodeUtf8 errorMessage) Nothing Nothing toJSON (InvalidRange rangeError) = toJsonPgrstError ApiRequestErrorCode03 "Requested range not satisfiable" (Just $ case rangeError of NegativeLimit -> "Limit should be greater than or equal to zero." LowerGTUpper -> "The lower boundary must be lower than or equal to the upper boundary in the Range header." OutOfBounds lower total -> JSON.String $ "An offset of " <> lower <> " was requested, but there are only " <> total <> " rows.") Nothing toJSON InvalidFilters = toJsonPgrstError ApiRequestErrorCode05 "Filters must include all and only primary key columns with 'eq' operators" Nothing Nothing toJSON (UnacceptableSchema schemas) = toJsonPgrstError ApiRequestErrorCode06 ("The schema must be one of the following: " <> T.intercalate ", " schemas) Nothing Nothing toJSON (MediaTypeError cts) = toJsonPgrstError ApiRequestErrorCode07 ("None of these media types are available: " <> T.intercalate ", " (map T.decodeUtf8 cts)) Nothing Nothing toJSON NotFound = JSON.object [] toJSON (NotEmbedded resource) = toJsonPgrstError ApiRequestErrorCode08 ("'" <> resource <> "' is not an embedded resource in this request") Nothing (Just $ JSON.String $ "Verify that '" <> resource <> "' is included in the 'select' query parameter.") toJSON LimitNoOrderError = toJsonPgrstError ApiRequestErrorCode09 "A 'limit' was applied without an explicit 'order'" Nothing (Just "Apply an 'order' using unique column(s)") toJSON (OffLimitsChangesError n maxs) = toJsonPgrstError ApiRequestErrorCode10 "The maximum number of rows allowed to change was surpassed" (Just $ JSON.String $ T.unwords ["Results contain", show n, "rows changed but the maximum number allowed is", show maxs]) Nothing toJSON GucHeadersError = toJsonPgrstError ApiRequestErrorCode11 "response.headers guc must be a JSON array composed of objects with a single key and a string value" Nothing Nothing toJSON GucStatusError = toJsonPgrstError ApiRequestErrorCode12 "response.status guc must be a valid status code" Nothing Nothing toJSON PutLimitNotAllowedError = toJsonPgrstError ApiRequestErrorCode14 "limit/offset querystring parameters are not allowed for PUT" Nothing Nothing toJSON PutMatchingPkError = toJsonPgrstError ApiRequestErrorCode15 "Payload values do not match URL in primary key column(s)" Nothing Nothing toJSON (SingularityError n) = toJsonPgrstError ApiRequestErrorCode16 "JSON object requested, multiple (or no) rows returned" (Just $ JSON.String $ T.unwords ["The result contains", show n, "rows"]) Nothing toJSON (UnsupportedMethod method) = toJsonPgrstError ApiRequestErrorCode17 ("Unsupported HTTP method: " <> T.decodeUtf8 method) Nothing Nothing toJSON (RelatedOrderNotToOne origin target) = toJsonPgrstError ApiRequestErrorCode18 ("A related order on '" <> target <> "' is not possible") (Just $ JSON.String $ "'" <> origin <> "' and '" <> target <> "' do not form a many-to-one or one-to-one relationship") Nothing toJSON (SpreadNotToOne origin target) = toJsonPgrstError ApiRequestErrorCode19 ("A spread operation on '" <> target <> "' is not possible") (Just $ JSON.String $ "'" <> origin <> "' and '" <> target <> "' do not form a many-to-one or one-to-one relationship") Nothing toJSON (UnacceptableFilter target) = toJsonPgrstError ApiRequestErrorCode20 ("Bad operator on the '" <> target <> "' embedded resource") (Just "Only is null or not is null filters are allowed on embedded resources") Nothing toJSON (PGRSTParseError raiseErr) = toJsonPgrstError ApiRequestErrorCode21 "Could not parse JSON in the \"RAISE SQLSTATE 'PGRST'\" error" (Just $ JSON.String $ pgrstParseErrorDetails raiseErr) (Just $ JSON.String $ pgrstParseErrorHint raiseErr) toJSON (InvalidPreferences prefs) = toJsonPgrstError ApiRequestErrorCode22 "Invalid preferences given with handling=strict" (Just $ JSON.String $ T.decodeUtf8 ("Invalid preferences: " <> BS.intercalate ", " prefs)) Nothing toJSON AggregatesNotAllowed = toJsonPgrstError ApiRequestErrorCode23 "Use of aggregate functions is not allowed" Nothing Nothing toJSON (MaxAffectedViolationError n) = toJsonPgrstError ApiRequestErrorCode24 "Query result exceeds max-affected preference constraint" (Just $ JSON.String $ T.unwords ["The query affects", show n, "rows"]) Nothing toJSON (NoRelBetween parent child embedHint schema allRels) = toJsonPgrstError SchemaCacheErrorCode00 ("Could not find a relationship between '" <> parent <> "' and '" <> child <> "' in the schema cache") (Just $ JSON.String $ "Searched for a foreign key relationship between '" <> parent <> "' and '" <> child <> maybe mempty ("' using the hint '" <>) embedHint <> "' in the schema '" <> schema <> "', but no matches were found.") (JSON.String <$> noRelBetweenHint parent child schema allRels) toJSON (AmbiguousRelBetween parent child rels) = toJsonPgrstError SchemaCacheErrorCode01 ("Could not embed because more than one relationship was found for '" <> parent <> "' and '" <> child <> "'") (Just $ JSON.toJSONList (compressedRel <$> rels)) (Just $ JSON.String $ "Try changing '" <> child <> "' to one of the following: " <> relHint rels <> ". Find the desired relationship in the 'details' key.") toJSON (NoRpc schema procName argumentKeys hasPreferSingleObject contentType isInvPost allProcs overloadedProcs) = let func = schema <> "." <> procName prms = T.intercalate ", " argumentKeys prmsMsg = "(" <> prms <> ")" prmsDet = " with parameter" <> (if length argumentKeys > 1 then "s " else " ") <> prms fmtPrms p = if null argumentKeys then " without parameters" else p onlySingleParams = hasPreferSingleObject || (isInvPost && contentType `elem` [MTTextPlain, MTTextXML, MTOctetStream]) in toJsonPgrstError SchemaCacheErrorCode02 ("Could not find the function " <> func <> (if onlySingleParams then "" else fmtPrms prmsMsg) <> " in the schema cache") (Just $ JSON.String $ "Searched for the function " <> func <> (case (hasPreferSingleObject, isInvPost, contentType) of (True, _, _) -> " with a single json/jsonb parameter" (_, True, MTTextPlain) -> " with a single unnamed text parameter" (_, True, MTTextXML) -> " with a single unnamed xml parameter" (_, True, MTOctetStream) -> " with a single unnamed bytea parameter" (_, True, MTApplicationJSON) -> fmtPrms prmsDet <> " or with a single unnamed json/jsonb parameter" _ -> fmtPrms prmsDet) <> ", but no matches were found in the schema cache.") -- The hint will be null in the case of single unnamed parameter functions (if onlySingleParams then Nothing else JSON.String <$> noRpcHint schema procName argumentKeys allProcs overloadedProcs) toJSON (AmbiguousRpc procs) = toJsonPgrstError SchemaCacheErrorCode03 ("Could not choose the best candidate function between: " <> T.intercalate ", " [pdSchema p <> "." <> pdName p <> "(" <> T.intercalate ", " [ppName a <> " => " <> ppType a | a <- pdParams p] <> ")" | p <- procs]) Nothing (Just "Try renaming the parameters or the function itself in the database so function overloading can be resolved") toJSON (ColumnNotFound relName colName) = toJsonPgrstError SchemaCacheErrorCode04 ("Could not find the '" <> colName <> "' column of '" <> relName <> "' in the schema cache") Nothing Nothing -- | -- If no relationship is found then: -- -- Looks for parent suggestions if parent not found -- Looks for child suggestions if parent is found but child is not -- Gives no suggestions if both are found (it means that there is a problem with the embed hint) -- -- >>> :set -Wno-missing-fields -- >>> let qi t = QualifiedIdentifier "api" t -- >>> let rel ft = Relationship{relForeignTable = qi ft} -- >>> let rels = HM.fromList [((qi "films", "api"), [rel "directors", rel "roles", rel "actors"])] -- -- >>> noRelBetweenHint "film" "directors" "api" rels -- Just "Perhaps you meant 'films' instead of 'film'." -- -- >>> noRelBetweenHint "films" "role" "api" rels -- Just "Perhaps you meant 'roles' instead of 'role'." -- -- >>> noRelBetweenHint "films" "role" "api" rels -- Just "Perhaps you meant 'roles' instead of 'role'." -- -- >>> noRelBetweenHint "films" "actors" "api" rels -- Nothing -- -- >>> noRelBetweenHint "noclosealternative" "roles" "api" rels -- Nothing -- -- >>> noRelBetweenHint "films" "noclosealternative" "api" rels -- Nothing -- -- >>> noRelBetweenHint "films" "noclosealternative" "noclosealternative" rels -- Nothing -- noRelBetweenHint :: Text -> Text -> Schema -> RelationshipsMap -> Maybe Text noRelBetweenHint parent child schema allRels = ("Perhaps you meant '" <>) <$> if isJust findParent then (<> "' instead of '" <> child <> "'.") <$> suggestChild else (<> "' instead of '" <> parent <> "'.") <$> suggestParent where findParent = HM.lookup (QualifiedIdentifier schema parent, schema) allRels fuzzySetOfParents = Fuzzy.fromList [qiName (fst p) | p <- HM.keys allRels, snd p == schema] fuzzySetOfChildren = Fuzzy.fromList [qiName (relForeignTable c) | c <- fromMaybe [] findParent] suggestParent = Fuzzy.getOne fuzzySetOfParents parent -- Do not give suggestion if the child is found in the relations (weight = 1.0) suggestChild = headMay [snd k | k <- Fuzzy.get fuzzySetOfChildren child, fst k < 1.0] -- | -- If no function is found with the given name, it does a fuzzy search to all the functions -- in the same schema and shows the best match as hint. -- -- >>> :set -Wno-missing-fields -- >>> let procs = [(QualifiedIdentifier "api" "test"), (QualifiedIdentifier "api" "another"), (QualifiedIdentifier "private" "other")] -- -- >>> noRpcHint "api" "testt" ["val", "param", "name"] procs [] -- Just "Perhaps you meant to call the function api.test" -- -- >>> noRpcHint "api" "other" [] procs [] -- Just "Perhaps you meant to call the function api.another" -- -- >>> noRpcHint "api" "noclosealternative" [] procs [] -- Nothing -- -- If a function is found with the given name, but no params match, then it does a fuzzy search -- to all the overloaded functions' params using the form "param1, param2, param3, ..." -- and shows the best match as hint. -- -- >>> let procsDesc = [Function {pdParams = [RoutineParam {ppName="val"}, RoutineParam {ppName="param"}, RoutineParam {ppName="name"}]}, Function {pdParams = [RoutineParam {ppName="id"}, RoutineParam {ppName="attr"}]}] -- -- >>> noRpcHint "api" "test" ["vall", "pqaram", "nam"] procs procsDesc -- Just "Perhaps you meant to call the function api.test(name, param, val)" -- -- >>> noRpcHint "api" "test" ["val", "param"] procs procsDesc -- Just "Perhaps you meant to call the function api.test(name, param, val)" -- -- >>> noRpcHint "api" "test" ["id", "attrs"] procs procsDesc -- Just "Perhaps you meant to call the function api.test(attr, id)" -- -- >>> noRpcHint "api" "test" ["id"] procs procsDesc -- Just "Perhaps you meant to call the function api.test(attr, id)" -- -- >>> noRpcHint "api" "test" ["noclosealternative"] procs procsDesc -- Nothing -- noRpcHint :: Text -> Text -> [Text] -> [QualifiedIdentifier] -> [Routine] -> Maybe Text noRpcHint schema procName params allProcs overloadedProcs = fmap (("Perhaps you meant to call the function " <> schema <> ".") <>) possibleProcs where fuzzySetOfProcs = Fuzzy.fromList [qiName k | k <- allProcs, qiSchema k == schema] fuzzySetOfParams = Fuzzy.fromList $ listToText <$> [[ppName prm | prm <- pdParams ov] | ov <- overloadedProcs] -- Cannot do a fuzzy search like: Fuzzy.getOne [[Text]] [Text], where [[Text]] is the list of params for each -- overloaded function and [Text] the given params. This converts those lists to text to make fuzzy search possible. -- E.g. ["val", "param", "name"] into "(name, param, val)" listToText = ("(" <>) . (<> ")") . T.intercalate ", " . sort possibleProcs | null overloadedProcs = Fuzzy.getOne fuzzySetOfProcs procName | otherwise = (procName <>) <$> Fuzzy.getOne fuzzySetOfParams (listToText params) compressedRel :: Relationship -> JSON.Value -- An ambiguousness error cannot happen for computed relationships TODO refactor so this mempty is not needed compressedRel ComputedRelationship{} = JSON.object mempty compressedRel Relationship{..} = let fmtEls els = "(" <> T.intercalate ", " els <> ")" in JSON.object $ ("embedding" .= (qiName relTable <> " with " <> qiName relForeignTable :: Text)) : case relCardinality of M2M Junction{..} -> [ "cardinality" .= ("many-to-many" :: Text) , "relationship" .= (qiName junTable <> " using " <> junConstraint1 <> fmtEls (snd <$> junColsSource) <> " and " <> junConstraint2 <> fmtEls (snd <$> junColsTarget)) ] M2O cons relColumns -> [ "cardinality" .= ("many-to-one" :: Text) , "relationship" .= (cons <> " using " <> qiName relTable <> fmtEls (fst <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (snd <$> relColumns)) ] O2O cons relColumns _ -> [ "cardinality" .= ("one-to-one" :: Text) , "relationship" .= (cons <> " using " <> qiName relTable <> fmtEls (fst <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (snd <$> relColumns)) ] O2M cons relColumns -> [ "cardinality" .= ("one-to-many" :: Text) , "relationship" .= (cons <> " using " <> qiName relTable <> fmtEls (fst <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (snd <$> relColumns)) ] relHint :: [Relationship] -> Text relHint rels = T.intercalate ", " (hintList <$> rels) where hintList Relationship{..} = let buildHint rel = "'" <> qiName relForeignTable <> "!" <> rel <> "'" in case relCardinality of M2M Junction{..} -> buildHint (qiName junTable) M2O cons _ -> buildHint cons O2O cons _ _ -> buildHint cons O2M cons _ -> buildHint cons -- An ambiguousness error cannot happen for computed relationships TODO refactor so this mempty is not needed hintList ComputedRelationship{} = mempty pgrstParseErrorDetails :: RaiseError -> Text pgrstParseErrorDetails err = case err of MsgParseError m -> "Invalid JSON value for MESSAGE: '" <> T.decodeUtf8 m <> "'" DetParseError d -> "Invalid JSON value for DETAIL: '" <> T.decodeUtf8 d <> "'" NoDetail -> "DETAIL is missing in the RAISE statement" pgrstParseErrorHint :: RaiseError -> Text pgrstParseErrorHint err = case err of MsgParseError _ -> "MESSAGE must be a JSON object with obligatory keys: 'code', 'message' and optional keys: 'details', 'hint'." _ -> "DETAIL must be a JSON object with obligatory keys: 'status', 'headers' and optional key: 'status_text'." data PgError = PgError Authenticated SQL.UsageError type Authenticated = Bool instance PgrstError PgError where status (PgError authed usageError) = pgErrorStatus authed usageError headers (PgError _ (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ResultError (SQL.ServerError "PGRST" m d _ _p))))) = case parseRaisePGRST m d of Right (_, r) -> map intoHeader (M.toList $ getHeaders r) Left e -> headers e where intoHeader (k,v) = (CI.mk $ T.encodeUtf8 k, T.encodeUtf8 v) headers err = if status err == HTTP.status401 then [("WWW-Authenticate", "Bearer") :: Header] else mempty instance JSON.ToJSON PgError where toJSON (PgError _ usageError) = JSON.toJSON usageError instance JSON.ToJSON SQL.UsageError where toJSON (SQL.ConnectionUsageError e) = toJsonPgrstError ConnectionErrorCode00 "Database connection error. Retrying the connection." (Just $ JSON.String $ T.decodeUtf8With T.lenientDecode $ fromMaybe "" e) Nothing toJSON (SQL.SessionUsageError e) = JSON.toJSON e -- SQL.Error toJSON SQL.AcquisitionTimeoutUsageError = toJsonPgrstError ConnectionErrorCode03 "Timed out acquiring connection from connection pool." Nothing Nothing instance JSON.ToJSON SQL.QueryError where toJSON (SQL.QueryError _ _ e) = JSON.toJSON e instance JSON.ToJSON SQL.CommandError where -- Special error raised with code PGRST, to allow full response control toJSON (SQL.ResultError (SQL.ServerError "PGRST" m d _ _p)) = case parseRaisePGRST m d of Right (r, _) -> JSON.object [ "code" .= getCode r, "message" .= getMessage r, "details" .= checkMaybe (getDetails r), "hint" .= checkMaybe (getHint r)] Left e -> JSON.toJSON e where checkMaybe = maybe JSON.Null JSON.String toJSON (SQL.ResultError (SQL.ServerError c m d h _p)) = JSON.object [ "code" .= (T.decodeUtf8 c :: Text), "message" .= (T.decodeUtf8 m :: Text), "details" .= (fmap T.decodeUtf8 d :: Maybe Text), "hint" .= (fmap T.decodeUtf8 h :: Maybe Text)] toJSON (SQL.ResultError resultError) = toJsonPgrstError InternalErrorCode00 (show resultError) Nothing Nothing toJSON (SQL.ClientError d) = toJsonPgrstError ConnectionErrorCode01 "Database client error. Retrying the connection." (JSON.String <$> fmap T.decodeUtf8 d) Nothing pgErrorStatus :: Bool -> SQL.UsageError -> HTTP.Status pgErrorStatus _ (SQL.ConnectionUsageError _) = HTTP.status503 pgErrorStatus _ SQL.AcquisitionTimeoutUsageError = HTTP.status504 pgErrorStatus _ (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ClientError _))) = HTTP.status503 pgErrorStatus authed (SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ResultError rError))) = case rError of (SQL.ServerError c m d _ _) -> case BS.unpack c of '0':'8':_ -> HTTP.status503 -- pg connection err '0':'9':_ -> HTTP.status500 -- triggered action exception '0':'L':_ -> HTTP.status403 -- invalid grantor '0':'P':_ -> HTTP.status403 -- invalid role specification "23503" -> HTTP.status409 -- foreign_key_violation "23505" -> HTTP.status409 -- unique_violation "25006" -> HTTP.status405 -- read_only_sql_transaction "21000" -> -- cardinality_violation if BS.isSuffixOf "requires a WHERE clause" m then HTTP.status400 -- special case for pg-safeupdate, which we consider as client error else HTTP.status500 -- generic function or view server error, e.g. "more than one row returned by a subquery used as an expression" '2':'5':_ -> HTTP.status500 -- invalid tx state '2':'8':_ -> HTTP.status403 -- invalid auth specification '2':'D':_ -> HTTP.status500 -- invalid tx termination '3':'8':_ -> HTTP.status500 -- external routine exception '3':'9':_ -> HTTP.status500 -- external routine invocation '3':'B':_ -> HTTP.status500 -- savepoint exception '4':'0':_ -> HTTP.status500 -- tx rollback "53400" -> HTTP.status500 -- config limit exceeded '5':'3':_ -> HTTP.status503 -- insufficient resources '5':'4':_ -> HTTP.status500 -- too complex '5':'5':_ -> HTTP.status500 -- obj not on prereq state "57P01" -> HTTP.status503 -- terminating connection due to administrator command '5':'7':_ -> HTTP.status500 -- operator intervention '5':'8':_ -> HTTP.status500 -- system error 'F':'0':_ -> HTTP.status500 -- conf file error 'H':'V':_ -> HTTP.status500 -- foreign data wrapper error "P0001" -> HTTP.status400 -- default code for "raise" 'P':'0':_ -> HTTP.status500 -- PL/pgSQL Error 'X':'X':_ -> HTTP.status500 -- internal Error "42883"-> if BS.isPrefixOf "function xmlagg(" m then HTTP.status406 else HTTP.status404 -- undefined function "42P01" -> HTTP.status404 -- undefined table "42P17" -> HTTP.status500 -- infinite recursion "42501" -> if authed then HTTP.status403 else HTTP.status401 -- insufficient privilege 'P':'T':n -> fromMaybe HTTP.status500 (HTTP.mkStatus <$> readMaybe n <*> pure m) "PGRST" -> case parseRaisePGRST m d of Right (_, r) -> maybe (toEnum $ getStatus r) (HTTP.mkStatus (getStatus r) . T.encodeUtf8) (getStatusText r) Left e -> status e _ -> HTTP.status400 _ -> HTTP.status500 data Error = ApiRequestError ApiRequestError | JwtTokenInvalid Text | JwtTokenMissing | JwtTokenRequired | NoSchemaCacheError | PgErr PgError instance PgrstError Error where status (ApiRequestError err) = status err status JwtTokenInvalid{} = HTTP.unauthorized401 status JwtTokenMissing = HTTP.status500 status JwtTokenRequired = HTTP.unauthorized401 status NoSchemaCacheError = HTTP.status503 status (PgErr err) = status err headers (ApiRequestError err) = headers err headers (JwtTokenInvalid m) = [invalidTokenHeader m] headers JwtTokenRequired = [requiredTokenHeader] headers (PgErr err) = headers err headers _ = mempty instance JSON.ToJSON Error where toJSON NoSchemaCacheError = toJsonPgrstError ConnectionErrorCode02 "Could not query the database for the schema cache. Retrying." Nothing Nothing toJSON JwtTokenMissing = toJsonPgrstError JWTErrorCode00 "Server lacks JWT secret" Nothing Nothing toJSON (JwtTokenInvalid message) = toJsonPgrstError JWTErrorCode01 message Nothing Nothing toJSON JwtTokenRequired = toJsonPgrstError JWTErrorCode02 "Anonymous access is disabled" Nothing Nothing toJSON (PgErr err) = JSON.toJSON err toJSON (ApiRequestError err) = JSON.toJSON err invalidTokenHeader :: Text -> Header invalidTokenHeader m = ("WWW-Authenticate", "Bearer error=\"invalid_token\", " <> "error_description=" <> encodeUtf8 (show m)) requiredTokenHeader :: Header requiredTokenHeader = ("WWW-Authenticate", "Bearer") -- For parsing byteString to JSON Object, used for allowing full response control data PgRaiseErrMessage = PgRaiseErrMessage { getCode :: Text, getMessage :: Text, getDetails :: Maybe Text, getHint :: Maybe Text } data PgRaiseErrDetails = PgRaiseErrDetails { getStatus :: Int, getStatusText :: Maybe Text, getHeaders :: Map Text Text } instance JSON.FromJSON PgRaiseErrMessage where parseJSON (JSON.Object m) = PgRaiseErrMessage <$> m .: "code" <*> m .: "message" <*> m .:? "details" <*> m .:? "hint" parseJSON _ = mzero instance JSON.FromJSON PgRaiseErrDetails where parseJSON (JSON.Object d) = PgRaiseErrDetails <$> d .: "status" <*> d .:? "status_text" <*> d .: "headers" parseJSON _ = mzero parseRaisePGRST :: ByteString -> Maybe ByteString -> Either ApiRequestError (PgRaiseErrMessage, PgRaiseErrDetails) parseRaisePGRST m d = do msgJson <- maybeToRight (PGRSTParseError $ MsgParseError m) (JSON.decodeStrict m) det <- maybeToRight (PGRSTParseError NoDetail) d detJson <- maybeToRight (PGRSTParseError $ DetParseError det) (JSON.decodeStrict det) return (msgJson, detJson) -- Error codes are grouped by common modules or characteristics data ErrorCode -- PostgreSQL connection errors = ConnectionErrorCode00 | ConnectionErrorCode01 | ConnectionErrorCode02 | ConnectionErrorCode03 -- API Request errors | ApiRequestErrorCode00 | ApiRequestErrorCode01 | ApiRequestErrorCode02 | ApiRequestErrorCode03 -- | ApiRequestErrorCode04 -- no longer used (used to be mapped to ParseRequestError) | ApiRequestErrorCode05 | ApiRequestErrorCode06 | ApiRequestErrorCode07 | ApiRequestErrorCode08 | ApiRequestErrorCode09 | ApiRequestErrorCode10 | ApiRequestErrorCode11 -- | ApiRequestErrorCode13 -- no longer used (used to be mapped to BinaryFieldError) | ApiRequestErrorCode12 | ApiRequestErrorCode14 | ApiRequestErrorCode15 | ApiRequestErrorCode16 | ApiRequestErrorCode17 | ApiRequestErrorCode18 | ApiRequestErrorCode19 | ApiRequestErrorCode20 | ApiRequestErrorCode21 | ApiRequestErrorCode22 | ApiRequestErrorCode23 | ApiRequestErrorCode24 -- Schema Cache errors | SchemaCacheErrorCode00 | SchemaCacheErrorCode01 | SchemaCacheErrorCode02 | SchemaCacheErrorCode03 | SchemaCacheErrorCode04 -- JWT authentication errors | JWTErrorCode00 | JWTErrorCode01 | JWTErrorCode02 -- Internal errors related to the Hasql library | InternalErrorCode00 instance JSON.ToJSON ErrorCode where toJSON e = JSON.toJSON (buildErrorCode e) -- New group of errors will be added at the end of all the groups and will have the next prefix in the sequence -- New errors are added at the end of the group they belong to and will have the next code in the sequence buildErrorCode :: ErrorCode -> Text buildErrorCode code = case code of -- Keep the "PGRST" prefix in every code for an easier search/grep ConnectionErrorCode00 -> "PGRST000" ConnectionErrorCode01 -> "PGRST001" ConnectionErrorCode02 -> "PGRST002" ConnectionErrorCode03 -> "PGRST003" ApiRequestErrorCode00 -> "PGRST100" ApiRequestErrorCode01 -> "PGRST101" ApiRequestErrorCode02 -> "PGRST102" ApiRequestErrorCode03 -> "PGRST103" ApiRequestErrorCode05 -> "PGRST105" ApiRequestErrorCode06 -> "PGRST106" ApiRequestErrorCode07 -> "PGRST107" ApiRequestErrorCode08 -> "PGRST108" ApiRequestErrorCode09 -> "PGRST109" ApiRequestErrorCode10 -> "PGRST110" ApiRequestErrorCode11 -> "PGRST111" ApiRequestErrorCode12 -> "PGRST112" ApiRequestErrorCode14 -> "PGRST114" ApiRequestErrorCode15 -> "PGRST115" ApiRequestErrorCode16 -> "PGRST116" ApiRequestErrorCode17 -> "PGRST117" ApiRequestErrorCode18 -> "PGRST118" ApiRequestErrorCode19 -> "PGRST119" ApiRequestErrorCode20 -> "PGRST120" ApiRequestErrorCode21 -> "PGRST121" ApiRequestErrorCode22 -> "PGRST122" ApiRequestErrorCode23 -> "PGRST123" ApiRequestErrorCode24 -> "PGRST124" SchemaCacheErrorCode00 -> "PGRST200" SchemaCacheErrorCode01 -> "PGRST201" SchemaCacheErrorCode02 -> "PGRST202" SchemaCacheErrorCode03 -> "PGRST203" SchemaCacheErrorCode04 -> "PGRST204" JWTErrorCode00 -> "PGRST300" JWTErrorCode01 -> "PGRST301" JWTErrorCode02 -> "PGRST302" InternalErrorCode00 -> "PGRSTX00"