diff --git a/.gitignore b/.gitignore index af81dde65d..9a34545196 100644 --- a/.gitignore +++ b/.gitignore @@ -13,7 +13,6 @@ site *#* .#* *.swp -result* dist-* postgrest.hp postgrest.prof diff --git a/postgrest.cabal b/postgrest.cabal index 1524f5397b..4a8f6b8f48 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -66,6 +66,15 @@ library PostgREST.SchemaCache.Representations PostgREST.SchemaCache.Table PostgREST.Error + PostgREST.Error.Algebra + PostgREST.Error.ApiRequestError + PostgREST.Error.Error + PostgREST.Error.PgError + PostgREST.Error.PgError.CommandError + PostgREST.Error.PgError.ResultError + PostgREST.Error.PgError.ResultError.RaisePgrst + PostgREST.Error.PgError.UsageError + PostgREST.Error.SchemaCacheError PostgREST.Listener PostgREST.Logger PostgREST.MainTx diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index 39217610cf..9e16404d0a 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -2,8 +2,6 @@ Module : PostgREST.Error Description : PostgREST error HTTP responses -} -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE RecordWildCards #-} module PostgREST.Error ( errorResponseFor @@ -20,799 +18,8 @@ module PostgREST.Error , status ) where -import qualified Data.Aeson as JSON -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as LBS -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 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.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 PostgREST.SchemaCache.Table (Table (..)) -import Protolude - - -class (ErrorBody a, 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 - cLHeader body = (,) "Content-Length" (show $ LBS.length body) :: Header - in - responseLBS (status err) (baseHeader : cLHeader (errorPayload err) : headers err) $ errorPayload err - -class ErrorBody a where - code :: a -> Text - message :: a -> Text - details :: a -> Maybe JSON.Value - hint :: a -> Maybe JSON.Value - -data ApiRequestError - = AggregatesNotAllowed - | MediaTypeError [ByteString] - | InvalidBody ByteString - | InvalidFilters - | InvalidPreferences [ByteString] - | InvalidRange RangeError - | InvalidRpcMethod ByteString - | NotEmbedded Text - | NotImplemented Text - | PutLimitNotAllowedError - | QueryParamError QPError - | RelatedOrderNotToOne Text Text - | UnacceptableFilter Text - | UnacceptableSchema Text [Text] - | UnsupportedMethod ByteString - | GucHeadersError - | GucStatusError - | PutMatchingPkError - | SingularityError Integer - | PGRSTParseError RaiseError - | MaxAffectedViolationError Integer - | InvalidResourcePath - | OpenAPIDisabled - | MaxAffectedRpcViolation - deriving Show - -data QPError = QPError Text Text - deriving Show - -data RaiseError - = MsgParseError ByteString - | DetParseError ByteString - | NoDetail - deriving Show - -data RangeError - = NegativeLimit - | LowerGTUpper - | OutOfBounds Text Text - deriving Show - -instance PgrstError ApiRequestError where - status AggregatesNotAllowed{} = HTTP.status400 - 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 NotEmbedded{} = HTTP.status400 - status NotImplemented{} = HTTP.status400 - status PutLimitNotAllowedError = HTTP.status400 - status QueryParamError{} = HTTP.status400 - status RelatedOrderNotToOne{} = HTTP.status400 - status UnacceptableFilter{} = HTTP.status400 - status UnacceptableSchema{} = HTTP.status406 - status UnsupportedMethod{} = HTTP.status405 - status GucHeadersError = HTTP.status500 - status GucStatusError = HTTP.status500 - status PutMatchingPkError = HTTP.status400 - status SingularityError{} = HTTP.status406 - status PGRSTParseError{} = HTTP.status500 - status MaxAffectedViolationError{} = HTTP.status400 - status InvalidResourcePath = HTTP.status404 - status OpenAPIDisabled = HTTP.status404 - status MaxAffectedRpcViolation = HTTP.status400 - - headers _ = mempty - --- Error codes: --- --- Error codes are grouped by common modules or characteristics --- New group of errors will be added at the end of all the groups and will have the next prefix in the sequence --- Keep the "PGRST" prefix in every code for an easier search/grep --- They are grouped as following: --- --- PGRST0xx -> Connection Error --- PGRST1xx -> ApiRequest Error --- PGRST2xx -> SchemaCache Error --- PGRST3xx -> JWT authentication Error --- PGRSTXxx -> Internal Hasql Error - -instance ErrorBody ApiRequestError where - -- CODE: Text - code QueryParamError{} = "PGRST100" - code InvalidRpcMethod{} = "PGRST101" - code InvalidBody{} = "PGRST102" - code InvalidRange{} = "PGRST103" - -- code ParseRequestError = "PGRST104" -- no longer used - code InvalidFilters = "PGRST105" - code UnacceptableSchema{} = "PGRST106" - code MediaTypeError{} = "PGRST107" - code NotEmbedded{} = "PGRST108" - -- code LimitNoOrderError = "PGRST109" -- no longer used - -- code OffLimitsChangesError = "PGRST110" -- no longer used - code GucHeadersError = "PGRST111" - code GucStatusError = "PGRST112" - -- code BinaryFieldError = "PGRST113" -- no longer used - code PutLimitNotAllowedError = "PGRST114" - code PutMatchingPkError = "PGRST115" - code SingularityError{} = "PGRST116" - code UnsupportedMethod{} = "PGRST117" - code RelatedOrderNotToOne{} = "PGRST118" - -- code SpreadNotToOne = "PGRST109" -- no longer used - code UnacceptableFilter{} = "PGRST120" - code PGRSTParseError{} = "PGRST121" - code InvalidPreferences{} = "PGRST122" - code AggregatesNotAllowed = "PGRST123" - code MaxAffectedViolationError{} = "PGRST124" - code InvalidResourcePath = "PGRST125" - code OpenAPIDisabled = "PGRST126" - code NotImplemented{} = "PGRST127" - code MaxAffectedRpcViolation = "PGRST128" - - -- MESSAGE: Text - message (QueryParamError (QPError msg _)) = msg - message (InvalidRpcMethod method) = "Cannot use the " <> T.decodeUtf8 method <> " method on RPC" - message (InvalidBody errorMessage) = T.decodeUtf8 errorMessage - message (InvalidRange _) = "Requested range not satisfiable" - message InvalidFilters = "Filters must include all and only primary key columns with 'eq' operators" - message (UnacceptableSchema sch _) = "Invalid schema: " <> sch - message (MediaTypeError cts) = "None of these media types are available: " <> T.intercalate ", " (map T.decodeUtf8 cts) - message (NotEmbedded resource) = "'" <> resource <> "' is not an embedded resource in this request" - message GucHeadersError = "response.headers guc must be a JSON array composed of objects with a single key and a string value" - message GucStatusError = "response.status guc must be a valid status code" - message PutLimitNotAllowedError = "limit/offset querystring parameters are not allowed for PUT" - message PutMatchingPkError = "Payload values do not match URL in primary key column(s)" - message (SingularityError _) = "Cannot coerce the result to a single JSON object" - message (UnsupportedMethod method) = "Unsupported HTTP method: " <> T.decodeUtf8 method - message (RelatedOrderNotToOne _ target) = "A related order on '" <> target <> "' is not possible" - message (UnacceptableFilter target) = "Bad operator on the '" <> target <> "' embedded resource" - message (PGRSTParseError _) = "Could not parse JSON in the \"RAISE SQLSTATE 'PGRST'\" error" - message (InvalidPreferences _) = "Invalid preferences given with handling=strict" - message AggregatesNotAllowed = "Use of aggregate functions is not allowed" - message (MaxAffectedViolationError _) = "Query result exceeds max-affected preference constraint" - message InvalidResourcePath = "Invalid path specified in request URL" - message OpenAPIDisabled = "Root endpoint metadata is disabled" - message (NotImplemented _) = "Feature not implemented" - message MaxAffectedRpcViolation = "Function must return SETOF or TABLE when max-affected preference is used with handling=strict" - - -- DETAILS: Maybe JSON.Value - details (QueryParamError (QPError _ dets)) = Just $ JSON.String dets - details (InvalidRange rangeError) = 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." - details (SingularityError n) = Just $ JSON.String $ T.unwords ["The result contains", show n, "rows"] - details (RelatedOrderNotToOne origin target) = Just $ JSON.String $ "'" <> origin <> "' and '" <> target <> "' do not form a many-to-one or one-to-one relationship" - details (UnacceptableFilter _) = Just "Only is null or not is null filters are allowed on embedded resources" - details (PGRSTParseError raiseErr) = Just $ JSON.String $ pgrstParseErrorDetails raiseErr - details (InvalidPreferences prefs) = Just $ JSON.String $ T.decodeUtf8 ("Invalid preferences: " <> BS.intercalate ", " prefs) - details (MaxAffectedViolationError n) = Just $ JSON.String $ T.unwords ["The query affects", show n, "rows"] - details (NotImplemented details') = Just $ JSON.String details' - - details _ = Nothing - - -- HINT: Maybe JSON.Value - hint (NotEmbedded resource) = Just $ JSON.String $ "Verify that '" <> resource <> "' is included in the 'select' query parameter." - hint (PGRSTParseError raiseErr) = Just $ JSON.String $ pgrstParseErrorHint raiseErr - hint (UnacceptableSchema _ schemas) = Just $ JSON.String $ "Only the following schemas are exposed: " <> T.intercalate ", " schemas - - hint _ = Nothing - -instance JSON.ToJSON ApiRequestError where - toJSON err = toJsonPgrstError - (code err) (message err) (details err) (hint err) - -data SchemaCacheError - = AmbiguousRelBetween Text Text [Relationship] - | AmbiguousRpc [Routine] - | NoRelBetween Text Text (Maybe Text) Text RelationshipsMap - | NoRpc Text Text [Text] MediaType Bool [QualifiedIdentifier] [Routine] - | ColumnNotFound Text Text - | TableNotFound Text Text [Table] - deriving Show - -instance PgrstError SchemaCacheError where - status AmbiguousRelBetween{} = HTTP.status300 - status AmbiguousRpc{} = HTTP.status300 - status NoRelBetween{} = HTTP.status400 - status NoRpc{} = HTTP.status404 - status ColumnNotFound{} = HTTP.status400 - status TableNotFound{} = HTTP.status404 - - headers _ = mempty - -instance ErrorBody SchemaCacheError where - code NoRelBetween{} = "PGRST200" - code AmbiguousRelBetween{} = "PGRST201" - code NoRpc{} = "PGRST202" - code AmbiguousRpc{} = "PGRST203" - code ColumnNotFound{} = "PGRST204" - code TableNotFound{} = "PGRST205" - - message (NoRelBetween parent child _ _ _) = "Could not find a relationship between '" <> parent <> "' and '" <> child <> "' in the schema cache" - message (AmbiguousRelBetween parent child _) = "Could not embed because more than one relationship was found for '" <> parent <> "' and '" <> child <> "'" - message (NoRpc schema procName argumentKeys contentType isInvPost _ _) = "Could not find the function " <> func <> (if onlySingleParams then "" else fmtPrms prmsMsg) <> " in the schema cache" - where - onlySingleParams = isInvPost && contentType `elem` [MTTextPlain, MTTextXML, MTOctetStream] - func = schema <> "." <> procName - prms = T.intercalate ", " argumentKeys - prmsMsg = "(" <> prms <> ")" - fmtPrms p = if null argumentKeys then " without parameters" else p - message (AmbiguousRpc procs) = "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] - message (ColumnNotFound rel col) = "Could not find the '" <> col <> "' column of '" <> rel <> "' in the schema cache" - message (TableNotFound schemaName relName _) = "Could not find the table '" <> schemaName <> "." <> relName <> "' in the schema cache" - - details (NoRelBetween parent child embedHint schema _) = 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." - details (AmbiguousRelBetween _ _ rels) = Just $ JSON.toJSONList (compressedRel <$> rels) - details (NoRpc schema procName argumentKeys contentType isInvPost _ _) = - Just $ JSON.String $ "Searched for the function " <> func <> - (case (isInvPost, contentType) of - (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." - where - func = schema <> "." <> procName - prms = T.intercalate ", " argumentKeys - prmsDet = " with parameter" <> (if length argumentKeys > 1 then "s " else " ") <> prms - fmtPrms p = if null argumentKeys then " without parameters" else p - - details _ = Nothing - - hint (NoRelBetween parent child _ schema allRels) = JSON.String <$> noRelBetweenHint parent child schema allRels - hint (AmbiguousRelBetween _ child rels) = Just $ JSON.String $ "Try changing '" <> child <> "' to one of the following: " <> relHint rels <> ". Find the desired relationship in the 'details' key." - -- The hint will be null in the case of single unnamed parameter functions - hint (NoRpc schema procName argumentKeys contentType isInvPost allProcs overloadedProcs) = - if onlySingleParams - then Nothing - else JSON.String <$> noRpcHint schema procName argumentKeys allProcs overloadedProcs - where - onlySingleParams = isInvPost && contentType `elem` [MTTextPlain, MTTextXML, MTOctetStream] - hint (AmbiguousRpc _) = Just "Try renaming the parameters or the function itself in the database so function overloading can be resolved" - hint (TableNotFound schemaName relName tbls) = JSON.String <$> tableNotFoundHint schemaName relName tbls - - hint _ = Nothing - -instance JSON.ToJSON SchemaCacheError where - toJSON err = toJsonPgrstError - (code err) (message err) (details err) (hint err) - -toJsonPgrstError :: Text -> Text -> Maybe JSON.Value -> Maybe JSON.Value -> JSON.Value -toJsonPgrstError code' message' details' hint' = JSON.object [ - "code" .= code' - , "message" .= message' - , "details" .= details' - , "hint" .= hint' - ] - --- | --- 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) - --- | --- Do a fuzzy search in all tables in the same schema and return closest result -tableNotFoundHint :: Text -> Text -> [Table] -> Maybe Text -tableNotFoundHint schema tblName tblList - = fmap (\tbl -> "Perhaps you meant the table '" <> schema <> "." <> tbl <> "'") perhapsTable - where - perhapsTable = Fuzzy.getOne fuzzyTableSet tblName - fuzzyTableSet = Fuzzy.fromList [ tableName tbl | tbl <- tblList, tableSchema tbl == schema] - - -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 - deriving Show - -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 - -proxyStatusHeader :: Text -> Header -proxyStatusHeader code' = ("Proxy-Status", "PostgREST; error=" <> T.encodeUtf8 code') - -instance JSON.ToJSON PgError where - toJSON (PgError _ usageError) = toJsonPgrstError - (code usageError) (message usageError) (details usageError) (hint usageError) - -instance ErrorBody PgError where - code (PgError _ usageError) = code usageError - message (PgError _ usageError) = message usageError - details (PgError _ usageError) = details usageError - hint (PgError _ usageError) = hint usageError - -instance JSON.ToJSON SQL.UsageError where - toJSON err = toJsonPgrstError - (code err) (message err) (details err) (hint err) - -instance ErrorBody SQL.UsageError where - code (SQL.ConnectionUsageError _) = "PGRST000" - code (SQL.SessionUsageError (SQL.QueryError _ _ e)) = code e - code SQL.AcquisitionTimeoutUsageError = "PGRST003" - - message (SQL.ConnectionUsageError _) = "Database connection error. Retrying the connection." - message (SQL.SessionUsageError (SQL.QueryError _ _ e)) = message e - message SQL.AcquisitionTimeoutUsageError = "Timed out acquiring connection from connection pool." - - details (SQL.ConnectionUsageError e) = JSON.String . T.decodeUtf8 <$> e - details (SQL.SessionUsageError (SQL.QueryError _ _ e)) = details e - details SQL.AcquisitionTimeoutUsageError = Nothing - - hint (SQL.ConnectionUsageError _) = Nothing - hint (SQL.SessionUsageError (SQL.QueryError _ _ e)) = hint e - hint SQL.AcquisitionTimeoutUsageError = Nothing - -instance JSON.ToJSON SQL.CommandError where - toJSON err = toJsonPgrstError - (code err) (message err) (details err) (hint err) - -instance ErrorBody SQL.CommandError where - -- Special error raised with code PGRST, to allow full response control - code (SQL.ResultError (SQL.ServerError "PGRST" m d _ _)) = - case parseRaisePGRST m d of - Right (r, _) -> getCode r - Left e -> code e - code (SQL.ResultError (SQL.ServerError c _ _ _ _)) = T.decodeUtf8 c - - code (SQL.ResultError _) = "PGRSTX00" -- Internal Error - - code (SQL.ClientError _) = "PGRST001" - - message (SQL.ResultError (SQL.ServerError "PGRST" m d _ _)) = - case parseRaisePGRST m d of - Right (r, _) -> getMessage r - Left e -> message e - message (SQL.ResultError (SQL.ServerError _ m _ _ _)) = T.decodeUtf8 m - message (SQL.ResultError resultError) = show resultError -- We never really return this error, because we kill pgrst thread early in App.hs - message (SQL.ClientError _) = "Database client error. Retrying the connection." - - details (SQL.ResultError (SQL.ServerError "PGRST" m d _ _)) = - case parseRaisePGRST m d of - Right (r, _) -> JSON.String <$> getDetails r - Left e -> details e - details (SQL.ResultError (SQL.ServerError _ _ d _ _)) = JSON.String . T.decodeUtf8 <$> d - details (SQL.ClientError d) = JSON.String . T.decodeUtf8 <$> d - - details _ = Nothing - - hint (SQL.ResultError (SQL.ServerError "PGRST" m d _ _p)) = - case parseRaisePGRST m d of - Right (r, _) -> JSON.String <$> getHint r - Left e -> hint e - hint (SQL.ResultError (SQL.ServerError _ _ _ h _)) = JSON.String . T.decodeUtf8 <$> h - - hint _ = 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" - "22023" -> -- invalid_parameter_value. Catch nonexistent role error, see https://github.com/PostgREST/postgrest/issues/3601 - if BS.isPrefixOf "role" m && BS.isSuffixOf "does not exist" m - then HTTP.status401 -- role in jwt does not exist - else HTTP.status400 - '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 - | SchemaCacheErr SchemaCacheError - | JwtErr JwtError - | NoSchemaCacheError - | PgErr PgError - deriving Show - -data JwtError - = JwtDecodeErr JwtDecodeError - | JwtSecretMissing - | JwtTokenRequired - | JwtClaimsErr JwtClaimsError - deriving Show - -data JwtDecodeError - = EmptyAuthHeader - | UnexpectedParts Int - | KeyError Text - | BadAlgorithm Text - | BadCrypto - | UnsupportedTokenType - | UnreachableDecodeError - deriving Show - -data JwtClaimsError - = JWTExpired - | JWTNotYetValid - | JWTIssuedAtFuture - | JWTNotInAudience - | ParsingClaimsFailed - | ExpClaimNotNumber - | NbfClaimNotNumber - | IatClaimNotNumber - | AudClaimNotStringOrArray - deriving Show - -instance PgrstError Error where - status (ApiRequestError err) = status err - status (SchemaCacheErr err) = status err - status (JwtErr err) = status err - status NoSchemaCacheError = HTTP.status503 - status (PgErr err) = status err - - headers (ApiRequestError err) = proxyStatusHeader (code err) : headers err - headers (SchemaCacheErr err) = proxyStatusHeader (code err) : headers err - headers (JwtErr err) = proxyStatusHeader (code err) : headers err - headers (PgErr err) = proxyStatusHeader (code err) : headers err - headers err@NoSchemaCacheError = proxyStatusHeader (code err) : mempty - -instance JSON.ToJSON Error where - toJSON err = toJsonPgrstError - (code err) (message err) (details err) (hint err) - -instance ErrorBody Error where - code (ApiRequestError err) = code err - code (SchemaCacheErr err) = code err - code (JwtErr err) = code err - code NoSchemaCacheError = "PGRST002" - code (PgErr err) = code err - - message (ApiRequestError err) = message err - message (SchemaCacheErr err) = message err - message (JwtErr err) = message err - message NoSchemaCacheError = "Could not query the database for the schema cache. Retrying." - message (PgErr err) = message err - - details (ApiRequestError err) = details err - details (SchemaCacheErr err) = details err - details (JwtErr err) = details err - details NoSchemaCacheError = Nothing - details (PgErr err) = details err - - hint (ApiRequestError err) = hint err - hint (SchemaCacheErr err) = hint err - hint (JwtErr err) = hint err - hint NoSchemaCacheError = Nothing - hint (PgErr err) = hint err - -instance PgrstError JwtError where - status JwtDecodeErr{} = HTTP.unauthorized401 - status JwtSecretMissing = HTTP.status500 - status JwtTokenRequired = HTTP.unauthorized401 - status JwtClaimsErr{} = HTTP.unauthorized401 - - headers e@(JwtDecodeErr _) = [invalidTokenHeader $ message e] - headers JwtTokenRequired = [requiredTokenHeader] - headers e@(JwtClaimsErr _) = [invalidTokenHeader $ message e] - headers _ = mempty - -instance JSON.ToJSON JwtError where - toJSON err = toJsonPgrstError - (code err) (message err) (details err) (hint err) - -instance ErrorBody JwtError where - code JwtSecretMissing = "PGRST300" - code (JwtDecodeErr _) = "PGRST301" - code JwtTokenRequired = "PGRST302" - code (JwtClaimsErr _) = "PGRST303" - - message JwtSecretMissing = "Server lacks JWT secret" - message (JwtDecodeErr e) = case e of - EmptyAuthHeader -> "Empty JWT is sent in Authorization header" - UnexpectedParts n -> "Expected 3 parts in JWT; got " <> show n - KeyError _ -> "No suitable key or wrong key type" - BadAlgorithm _ -> "Wrong or unsupported encoding algorithm" - BadCrypto -> "JWT cryptographic operation failed" - UnsupportedTokenType -> "Unsupported token type" - UnreachableDecodeError -> "JWT couldn't be decoded" - message JwtTokenRequired = "Anonymous access is disabled" - message (JwtClaimsErr e) = case e of - JWTExpired -> "JWT expired" - JWTNotYetValid -> "JWT not yet valid" - JWTIssuedAtFuture -> "JWT issued at future" - JWTNotInAudience -> "JWT not in audience" - ParsingClaimsFailed -> "Parsing claims failed" - ExpClaimNotNumber -> "The JWT 'exp' claim must be a number" - NbfClaimNotNumber -> "The JWT 'nbf' claim must be a number" - IatClaimNotNumber -> "The JWT 'iat' claim must be a number" - AudClaimNotStringOrArray -> "The JWT 'aud' claim must be a string or an array of strings" - - details (JwtDecodeErr jde) = case jde of - KeyError dets -> Just $ JSON.String dets - BadAlgorithm dets -> Just $ JSON.String dets - _ -> Nothing - details _ = Nothing - - hint _ = Nothing - -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) +import PostgREST.Error.Algebra +import PostgREST.Error.ApiRequestError +import PostgREST.Error.Error +import PostgREST.Error.PgError +import PostgREST.Error.SchemaCacheError diff --git a/src/PostgREST/Error/Algebra.hs b/src/PostgREST/Error/Algebra.hs new file mode 100644 index 0000000000..c116bb59d2 --- /dev/null +++ b/src/PostgREST/Error/Algebra.hs @@ -0,0 +1,38 @@ +module PostgREST.Error.Algebra where + +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Lazy as LBS +import qualified Network.HTTP.Types as HTTP +import qualified PostgREST.MediaType as MediaType + +import Network.Wai (Response, responseLBS) +import Protolude + +class (ErrorBody a, JSON.ToJSON a) => PgrstError a where + status :: a -> HTTP.Status + headers :: a -> [HTTP.Header] + + errorPayload :: a -> LByteString + errorPayload = JSON.encode + + errorResponseFor :: a -> Response + errorResponseFor err = + let + baseHeader = MediaType.toContentType MediaType.MTApplicationJSON + cLHeader body = (,) "Content-Length" (show $ LBS.length body) :: HTTP.Header + in + responseLBS (status err) (baseHeader : cLHeader (errorPayload err) : headers err) $ errorPayload err + +class ErrorBody a where + code :: a -> Text + message :: a -> Text + details :: a -> Maybe JSON.Value + hint :: a -> Maybe JSON.Value + +toJsonPgrstError :: Text -> Text -> Maybe JSON.Value -> Maybe JSON.Value -> JSON.Value +toJsonPgrstError code' message' details' hint' = JSON.object [ + "code" JSON..= code' + , "message" JSON..= message' + , "details" JSON..= details' + , "hint" JSON..= hint' + ] diff --git a/src/PostgREST/Error/ApiRequestError.hs b/src/PostgREST/Error/ApiRequestError.hs new file mode 100644 index 0000000000..3469f3bac1 --- /dev/null +++ b/src/PostgREST/Error/ApiRequestError.hs @@ -0,0 +1,196 @@ +module PostgREST.Error.ApiRequestError + ( ApiRequestError(..), + QPError(..), + RaiseError(..), + RangeError(..), + ) where + +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Char8 as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Network.HTTP.Types.Status as HTTP + +import PostgREST.Error.Algebra +import Protolude + +data ApiRequestError + = AggregatesNotAllowed + | MediaTypeError [ByteString] + | InvalidBody ByteString + | InvalidFilters + | InvalidPreferences [ByteString] + | InvalidRange RangeError + | InvalidRpcMethod ByteString + | NotEmbedded Text + | NotImplemented Text + | PutLimitNotAllowedError + | QueryParamError QPError + | RelatedOrderNotToOne Text Text + | UnacceptableFilter Text + | UnacceptableSchema Text [Text] + | UnsupportedMethod ByteString + | GucHeadersError + | GucStatusError + | PutMatchingPkError + | SingularityError Integer + | PGRSTParseError RaiseError + | MaxAffectedViolationError Integer + | InvalidResourcePath + | OpenAPIDisabled + | MaxAffectedRpcViolation + deriving Show + +data QPError = QPError Text Text + deriving Show + +data RaiseError + = MsgParseError ByteString + | DetParseError ByteString + | NoDetail + deriving Show + +data RangeError + = NegativeLimit + | LowerGTUpper + | OutOfBounds Text Text + deriving Show + +instance PgrstError ApiRequestError where + status AggregatesNotAllowed{} = HTTP.status400 + 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 NotEmbedded{} = HTTP.status400 + status NotImplemented{} = HTTP.status400 + status PutLimitNotAllowedError = HTTP.status400 + status QueryParamError{} = HTTP.status400 + status RelatedOrderNotToOne{} = HTTP.status400 + status UnacceptableFilter{} = HTTP.status400 + status UnacceptableSchema{} = HTTP.status406 + status UnsupportedMethod{} = HTTP.status405 + status GucHeadersError = HTTP.status500 + status GucStatusError = HTTP.status500 + status PutMatchingPkError = HTTP.status400 + status SingularityError{} = HTTP.status406 + status PGRSTParseError{} = HTTP.status500 + status MaxAffectedViolationError{} = HTTP.status400 + status InvalidResourcePath = HTTP.status404 + status OpenAPIDisabled = HTTP.status404 + status MaxAffectedRpcViolation = HTTP.status400 + + headers _ = mempty + +-- Error codes: +-- +-- Error codes are grouped by common modules or characteristics +-- New group of errors will be added at the end of all the groups and will have the next prefix in the sequence +-- Keep the "PGRST" prefix in every code for an easier search/grep +-- They are grouped as following: +-- +-- PGRST0xx -> Connection Error +-- PGRST1xx -> ApiRequest Error +-- PGRST2xx -> SchemaCache Error +-- PGRST3xx -> JWT authentication Error +-- PGRSTXxx -> Internal Hasql Error + +instance ErrorBody ApiRequestError where + -- CODE: Text + code QueryParamError{} = "PGRST100" + code InvalidRpcMethod{} = "PGRST101" + code InvalidBody{} = "PGRST102" + code InvalidRange{} = "PGRST103" + -- code ParseRequestError = "PGRST104" -- no longer used + code InvalidFilters = "PGRST105" + code UnacceptableSchema{} = "PGRST106" + code MediaTypeError{} = "PGRST107" + code NotEmbedded{} = "PGRST108" + -- code LimitNoOrderError = "PGRST109" -- no longer used + -- code OffLimitsChangesError = "PGRST110" -- no longer used + code GucHeadersError = "PGRST111" + code GucStatusError = "PGRST112" + -- code BinaryFieldError = "PGRST113" -- no longer used + code PutLimitNotAllowedError = "PGRST114" + code PutMatchingPkError = "PGRST115" + code SingularityError{} = "PGRST116" + code UnsupportedMethod{} = "PGRST117" + code RelatedOrderNotToOne{} = "PGRST118" + -- code SpreadNotToOne = "PGRST109" -- no longer used + code UnacceptableFilter{} = "PGRST120" + code PGRSTParseError{} = "PGRST121" + code InvalidPreferences{} = "PGRST122" + code AggregatesNotAllowed = "PGRST123" + code MaxAffectedViolationError{} = "PGRST124" + code InvalidResourcePath = "PGRST125" + code OpenAPIDisabled = "PGRST126" + code NotImplemented{} = "PGRST127" + code MaxAffectedRpcViolation = "PGRST128" + + -- MESSAGE: Text + message (QueryParamError (QPError msg _)) = msg + message (InvalidRpcMethod method) = "Cannot use the " <> T.decodeUtf8 method <> " method on RPC" + message (InvalidBody errorMessage) = T.decodeUtf8 errorMessage + message (InvalidRange _) = "Requested range not satisfiable" + message InvalidFilters = "Filters must include all and only primary key columns with 'eq' operators" + message (UnacceptableSchema sch _) = "Invalid schema: " <> sch + message (MediaTypeError cts) = "None of these media types are available: " <> T.intercalate ", " (map T.decodeUtf8 cts) + message (NotEmbedded resource) = "'" <> resource <> "' is not an embedded resource in this request" + message GucHeadersError = "response.headers guc must be a JSON array composed of objects with a single key and a string value" + message GucStatusError = "response.status guc must be a valid status code" + message PutLimitNotAllowedError = "limit/offset querystring parameters are not allowed for PUT" + message PutMatchingPkError = "Payload values do not match URL in primary key column(s)" + message (SingularityError _) = "Cannot coerce the result to a single JSON object" + message (UnsupportedMethod method) = "Unsupported HTTP method: " <> T.decodeUtf8 method + message (RelatedOrderNotToOne _ target) = "A related order on '" <> target <> "' is not possible" + message (UnacceptableFilter target) = "Bad operator on the '" <> target <> "' embedded resource" + message (PGRSTParseError _) = "Could not parse JSON in the \"RAISE SQLSTATE 'PGRST'\" error" + message (InvalidPreferences _) = "Invalid preferences given with handling=strict" + message AggregatesNotAllowed = "Use of aggregate functions is not allowed" + message (MaxAffectedViolationError _) = "Query result exceeds max-affected preference constraint" + message InvalidResourcePath = "Invalid path specified in request URL" + message OpenAPIDisabled = "Root endpoint metadata is disabled" + message (NotImplemented _) = "Feature not implemented" + message MaxAffectedRpcViolation = "Function must return SETOF or TABLE when max-affected preference is used with handling=strict" + + -- DETAILS: Maybe JSON.Value + details (QueryParamError (QPError _ dets)) = Just $ JSON.String dets + details (InvalidRange rangeError) = 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." + details (SingularityError n) = Just $ JSON.String $ T.unwords ["The result contains", show n, "rows"] + details (RelatedOrderNotToOne origin target) = Just $ JSON.String $ "'" <> origin <> "' and '" <> target <> "' do not form a many-to-one or one-to-one relationship" + details (UnacceptableFilter _) = Just "Only is null or not is null filters are allowed on embedded resources" + details (PGRSTParseError raiseErr) = Just $ JSON.String $ pgrstParseErrorDetails raiseErr + details (InvalidPreferences prefs) = Just $ JSON.String $ T.decodeUtf8 ("Invalid preferences: " <> BS.intercalate ", " prefs) + details (MaxAffectedViolationError n) = Just $ JSON.String $ T.unwords ["The query affects", show n, "rows"] + details (NotImplemented details') = Just $ JSON.String details' + + details _ = Nothing + + -- HINT: Maybe JSON.Value + hint (NotEmbedded resource) = Just $ JSON.String $ "Verify that '" <> resource <> "' is included in the 'select' query parameter." + hint (PGRSTParseError raiseErr) = Just $ JSON.String $ pgrstParseErrorHint raiseErr + hint (UnacceptableSchema _ schemas) = Just $ JSON.String $ "Only the following schemas are exposed: " <> T.intercalate ", " schemas + + hint _ = Nothing + +instance JSON.ToJSON ApiRequestError where + toJSON err = toJsonPgrstError + (code err) (message err) (details err) (hint err) + +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'." + +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" diff --git a/src/PostgREST/Error/Error.hs b/src/PostgREST/Error/Error.hs new file mode 100644 index 0000000000..0151000374 --- /dev/null +++ b/src/PostgREST/Error/Error.hs @@ -0,0 +1,157 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module PostgREST.Error.Error + ( Error (..) + , JwtError (..) + , JwtDecodeError (..) + , JwtClaimsError (..) + ) where + +import qualified Data.Aeson as JSON +import qualified Data.Text.Encoding as T +import qualified Network.HTTP.Types as HTTP + +import PostgREST.Error.Algebra +import PostgREST.Error.ApiRequestError +import PostgREST.Error.PgError +import PostgREST.Error.SchemaCacheError +import Protolude + +data Error + = ApiRequestError ApiRequestError + | SchemaCacheErr SchemaCacheError + | JwtErr JwtError + | NoSchemaCacheError + | PgErr PgError + deriving Show + +data JwtError + = JwtDecodeErr JwtDecodeError + | JwtSecretMissing + | JwtTokenRequired + | JwtClaimsErr JwtClaimsError + deriving Show + +data JwtDecodeError + = EmptyAuthHeader + | UnexpectedParts Int + | KeyError Text + | BadAlgorithm Text + | BadCrypto + | UnsupportedTokenType + | UnreachableDecodeError + deriving Show + +data JwtClaimsError + = JWTExpired + | JWTNotYetValid + | JWTIssuedAtFuture + | JWTNotInAudience + | ParsingClaimsFailed + | ExpClaimNotNumber + | NbfClaimNotNumber + | IatClaimNotNumber + | AudClaimNotStringOrArray + deriving Show + +instance PgrstError Error where + status (ApiRequestError err) = status err + status (SchemaCacheErr err) = status err + status (JwtErr err) = status err + status NoSchemaCacheError = HTTP.status503 + status (PgErr err) = status err + + headers (ApiRequestError err) = proxyStatusHeader (code err) : headers err + headers (SchemaCacheErr err) = proxyStatusHeader (code err) : headers err + headers (JwtErr err) = proxyStatusHeader (code err) : headers err + headers (PgErr err) = proxyStatusHeader (code err) : headers err + headers err@NoSchemaCacheError = proxyStatusHeader (code err) : mempty + +instance JSON.ToJSON Error where + toJSON err = toJsonPgrstError + (code err) (message err) (details err) (hint err) + +instance ErrorBody Error where + code (ApiRequestError err) = code err + code (SchemaCacheErr err) = code err + code (JwtErr err) = code err + code NoSchemaCacheError = "PGRST002" + code (PgErr err) = code err + + message (ApiRequestError err) = message err + message (SchemaCacheErr err) = message err + message (JwtErr err) = message err + message NoSchemaCacheError = "Could not query the database for the schema cache. Retrying." + message (PgErr err) = message err + + details (ApiRequestError err) = details err + details (SchemaCacheErr err) = details err + details (JwtErr err) = details err + details NoSchemaCacheError = Nothing + details (PgErr err) = details err + + hint (ApiRequestError err) = hint err + hint (SchemaCacheErr err) = hint err + hint (JwtErr err) = hint err + hint NoSchemaCacheError = Nothing + hint (PgErr err) = hint err + +instance PgrstError JwtError where + status JwtDecodeErr{} = HTTP.unauthorized401 + status JwtSecretMissing = HTTP.status500 + status JwtTokenRequired = HTTP.unauthorized401 + status JwtClaimsErr{} = HTTP.unauthorized401 + + headers e@(JwtDecodeErr _) = [invalidTokenHeader $ message e] + headers JwtTokenRequired = [requiredTokenHeader] + headers e@(JwtClaimsErr _) = [invalidTokenHeader $ message e] + headers _ = mempty + +instance JSON.ToJSON JwtError where + toJSON err = toJsonPgrstError + (code err) (message err) (details err) (hint err) + +instance ErrorBody JwtError where + code JwtSecretMissing = "PGRST300" + code (JwtDecodeErr _) = "PGRST301" + code JwtTokenRequired = "PGRST302" + code (JwtClaimsErr _) = "PGRST303" + + message JwtSecretMissing = "Server lacks JWT secret" + message (JwtDecodeErr e) = case e of + EmptyAuthHeader -> "Empty JWT is sent in Authorization header" + UnexpectedParts n -> "Expected 3 parts in JWT; got " <> show n + KeyError _ -> "No suitable key or wrong key type" + BadAlgorithm _ -> "Wrong or unsupported encoding algorithm" + BadCrypto -> "JWT cryptographic operation failed" + UnsupportedTokenType -> "Unsupported token type" + UnreachableDecodeError -> "JWT couldn't be decoded" + message JwtTokenRequired = "Anonymous access is disabled" + message (JwtClaimsErr e) = case e of + JWTExpired -> "JWT expired" + JWTNotYetValid -> "JWT not yet valid" + JWTIssuedAtFuture -> "JWT issued at future" + JWTNotInAudience -> "JWT not in audience" + ParsingClaimsFailed -> "Parsing claims failed" + ExpClaimNotNumber -> "The JWT 'exp' claim must be a number" + NbfClaimNotNumber -> "The JWT 'nbf' claim must be a number" + IatClaimNotNumber -> "The JWT 'iat' claim must be a number" + AudClaimNotStringOrArray -> "The JWT 'aud' claim must be a string or an array of strings" + + details (JwtDecodeErr jde) = case jde of + KeyError dets -> Just $ JSON.String dets + BadAlgorithm dets -> Just $ JSON.String dets + _ -> Nothing + details _ = Nothing + + hint _ = Nothing + +invalidTokenHeader :: Text -> HTTP.Header +invalidTokenHeader m = + ("WWW-Authenticate", "Bearer error=\"invalid_token\", " <> "error_description=" <> encodeUtf8 (show m)) + +requiredTokenHeader :: HTTP.Header +requiredTokenHeader = ("WWW-Authenticate", "Bearer") + +proxyStatusHeader :: Text -> HTTP.Header +proxyStatusHeader code' = ("Proxy-Status", "PostgREST; error=" <> T.encodeUtf8 code') diff --git a/src/PostgREST/Error/PgError.hs b/src/PostgREST/Error/PgError.hs new file mode 100644 index 0000000000..063c8d9686 --- /dev/null +++ b/src/PostgREST/Error/PgError.hs @@ -0,0 +1,41 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ViewPatterns #-} + +module PostgREST.Error.PgError + ( PgError(..), + Authenticated, + ) where + +import qualified Data.Aeson as JSON +import qualified Hasql.Pool as SQL +import qualified Network.HTTP.Types as HTTP +import qualified PostgREST.Error.PgError.UsageError as UsageError + +import PostgREST.Error.Algebra +import Protolude + +data PgError = PgError Authenticated SQL.UsageError + deriving Show + +type Authenticated = Bool + +instance PgrstError PgError where + status (PgError authed usageError) = UsageError.pgErrorStatus authed usageError + + headers (PgError _ (UsageError.maybeHeaders -> Just matchingHeaders)) = + matchingHeaders + + headers err = + if status err == HTTP.status401 + then [("WWW-Authenticate", "Bearer") :: HTTP.Header] + else mempty + +instance JSON.ToJSON PgError where + toJSON (PgError _ usageError) = toJsonPgrstError + (code usageError) (message usageError) (details usageError) (hint usageError) + +instance ErrorBody PgError where + code (PgError _ usageError) = code usageError + message (PgError _ usageError) = message usageError + details (PgError _ usageError) = details usageError + hint (PgError _ usageError) = hint usageError diff --git a/src/PostgREST/Error/PgError/CommandError.hs b/src/PostgREST/Error/PgError/CommandError.hs new file mode 100644 index 0000000000..17477f8e7c --- /dev/null +++ b/src/PostgREST/Error/PgError/CommandError.hs @@ -0,0 +1,42 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module PostgREST.Error.PgError.CommandError where + +import qualified Data.Aeson as JSON +import qualified Data.Text.Encoding as T +import qualified Hasql.Session as SQL +import qualified Network.HTTP.Types as HTTP +import PostgREST.Error.Algebra +import qualified PostgREST.Error.PgError.ResultError as ResultError +import Protolude + +instance JSON.ToJSON SQL.CommandError where + toJSON err = + toJsonPgrstError + (code err) + (message err) + (details err) + (hint err) + +instance ErrorBody SQL.CommandError where + -- Special error raised with code PGRST, to allow full response control + code (SQL.ResultError resultError) = code resultError + code (SQL.ClientError _) = "PGRST001" + + message (SQL.ResultError resultError) = message resultError + message (SQL.ClientError _) = "Database client error. Retrying the connection." + + details (SQL.ResultError resultError) = details resultError + details (SQL.ClientError d) = JSON.String . T.decodeUtf8 <$> d + + hint (SQL.ResultError resultError) = hint resultError + hint _ = Nothing + +pgErrorStatus :: Bool -> SQL.CommandError -> HTTP.Status +pgErrorStatus _ (SQL.ClientError _) = HTTP.status503 +pgErrorStatus authed (SQL.ResultError rError) = + ResultError.pgErrorStatus authed rError + +maybeHeaders :: SQL.CommandError -> Maybe [HTTP.Header] +maybeHeaders (SQL.ResultError rError) = ResultError.maybeHeaders rError +maybeHeaders _ = Nothing diff --git a/src/PostgREST/Error/PgError/ResultError.hs b/src/PostgREST/Error/PgError/ResultError.hs new file mode 100644 index 0000000000..cca480dfad --- /dev/null +++ b/src/PostgREST/Error/PgError/ResultError.hs @@ -0,0 +1,109 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module PostgREST.Error.PgError.ResultError + ( pgErrorStatus, + maybeHeaders, + ) where + +import qualified Data.Aeson as JSON +import qualified Data.ByteString.Char8 as BS +import qualified Data.CaseInsensitive as CI +import qualified Data.Map.Internal as M +import qualified Data.Text.Encoding as T +import qualified Hasql.Session as SQL +import qualified Network.HTTP.Types as HTTP +import qualified PostgREST.Error.PgError.ResultError.RaisePgrst as RaisePgrst + +import PostgREST.Error.Algebra +import Protolude + +instance ErrorBody SQL.ResultError where + -- Special error raised with code PGRST, to allow full response control + code (SQL.ServerError "PGRST" m d _ _) = + case RaisePgrst.parseRaisePGRST m d of + Right (r, _) -> RaisePgrst.getCode r + Left e -> code e + code (SQL.ServerError c _ _ _ _) = T.decodeUtf8 c + code _ = "PGRSTX00" -- Internal Error + + message (SQL.ServerError "PGRST" m d _ _) = + case RaisePgrst.parseRaisePGRST m d of + Right (r, _) -> RaisePgrst.getMessage r + Left e -> message e + message (SQL.ServerError _ m _ _ _) = T.decodeUtf8 m + message resultError = show resultError -- We never really return this error, because we kill pgrst thread early in App.hs + + details (SQL.ServerError "PGRST" m d _ _) = + case RaisePgrst.parseRaisePGRST m d of + Right (r, _) -> JSON.String <$> RaisePgrst.getDetails r + Left e -> details e + details (SQL.ServerError _ _ d _ _) = JSON.String . T.decodeUtf8 <$> d + details _ = Nothing + + hint (SQL.ServerError "PGRST" m d _ _p) = + case RaisePgrst.parseRaisePGRST m d of + Right (r, _) -> JSON.String <$> RaisePgrst.getHint r + Left e -> hint e + hint (SQL.ServerError _ _ _ h _) = JSON.String . T.decodeUtf8 <$> h + hint _ = Nothing + +pgErrorStatus :: Bool -> SQL.ResultError -> HTTP.Status +pgErrorStatus authed 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" + "22023" -> -- invalid_parameter_value. Catch nonexistent role error, see https://github.com/PostgREST/postgrest/issues/3601 + if BS.isPrefixOf "role" m && BS.isSuffixOf "does not exist" m + then HTTP.status401 -- role in jwt does not exist + else HTTP.status400 + '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 RaisePgrst.parseRaisePGRST m d of + Right (_, r) -> maybe (toEnum $ RaisePgrst.getStatus r) (HTTP.mkStatus (RaisePgrst.getStatus r) . T.encodeUtf8) (RaisePgrst.getStatusText r) + Left e -> status e + _ -> HTTP.status400 + _ -> HTTP.status500 + +maybeHeaders :: SQL.ResultError -> Maybe [HTTP.Header] +maybeHeaders (SQL.ServerError "PGRST" m d _ _p) = + Just $ case RaisePgrst.parseRaisePGRST m d of + Right (_, r) -> map intoHeader (M.toList $ RaisePgrst.getHeaders r) + Left e -> headers e + where + intoHeader (k,v) = (CI.mk $ T.encodeUtf8 k, T.encodeUtf8 v) +maybeHeaders _ = Nothing diff --git a/src/PostgREST/Error/PgError/ResultError/RaisePgrst.hs b/src/PostgREST/Error/PgError/ResultError/RaisePgrst.hs new file mode 100644 index 0000000000..c732be0c09 --- /dev/null +++ b/src/PostgREST/Error/PgError/ResultError/RaisePgrst.hs @@ -0,0 +1,46 @@ +module PostgREST.Error.PgError.ResultError.RaisePgrst where + +import qualified Data.Aeson as JSON +import qualified PostgREST.Error.ApiRequestError as ApiRequestError +import Protolude + +-- 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 + } + +instance JSON.FromJSON PgRaiseErrMessage where + parseJSON (JSON.Object m) = + PgRaiseErrMessage + <$> m JSON..: "code" + <*> m JSON..: "message" + <*> m JSON..:? "details" + <*> m JSON..:? "hint" + parseJSON _ = mzero + +data PgRaiseErrDetails = PgRaiseErrDetails + { getStatus :: Int, + getStatusText :: Maybe Text, + getHeaders :: Map Text Text + } + +instance JSON.FromJSON PgRaiseErrDetails where + parseJSON (JSON.Object d) = + PgRaiseErrDetails + <$> d JSON..: "status" + <*> d JSON..:? "status_text" + <*> d JSON..: "headers" + parseJSON _ = mzero + +parseRaisePGRST :: + ByteString -> + Maybe ByteString -> + Either ApiRequestError.ApiRequestError (PgRaiseErrMessage, PgRaiseErrDetails) +parseRaisePGRST m d = do + msgJson <- maybeToRight (ApiRequestError.PGRSTParseError $ ApiRequestError.MsgParseError m) (JSON.decodeStrict m) + det <- maybeToRight (ApiRequestError.PGRSTParseError ApiRequestError.NoDetail) d + detJson <- maybeToRight (ApiRequestError.PGRSTParseError $ ApiRequestError.DetParseError det) (JSON.decodeStrict det) + return (msgJson, detJson) diff --git a/src/PostgREST/Error/PgError/UsageError.hs b/src/PostgREST/Error/PgError/UsageError.hs new file mode 100644 index 0000000000..71c364a163 --- /dev/null +++ b/src/PostgREST/Error/PgError/UsageError.hs @@ -0,0 +1,46 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module PostgREST.Error.PgError.UsageError where + +import qualified Data.Aeson as JSON +import qualified Data.Text.Encoding as T +import qualified Hasql.Pool as SQL +import qualified Hasql.Session as SQL +import qualified Network.HTTP.Types as HTTP +import qualified PostgREST.Error.PgError.CommandError as CommandError + +import PostgREST.Error.Algebra +import Protolude + + +instance JSON.ToJSON SQL.UsageError where + toJSON err = toJsonPgrstError + (code err) (message err) (details err) (hint err) + +instance ErrorBody SQL.UsageError where + code (SQL.ConnectionUsageError _) = "PGRST000" + code (SQL.SessionUsageError (SQL.QueryError _ _ e)) = code e + code SQL.AcquisitionTimeoutUsageError = "PGRST003" + + message (SQL.ConnectionUsageError _) = "Database connection error. Retrying the connection." + message (SQL.SessionUsageError (SQL.QueryError _ _ e)) = message e + message SQL.AcquisitionTimeoutUsageError = "Timed out acquiring connection from connection pool." + + details (SQL.ConnectionUsageError e) = JSON.String . T.decodeUtf8 <$> e + details (SQL.SessionUsageError (SQL.QueryError _ _ e)) = details e + details SQL.AcquisitionTimeoutUsageError = Nothing + + hint (SQL.ConnectionUsageError _) = Nothing + hint (SQL.SessionUsageError (SQL.QueryError _ _ e)) = hint e + hint SQL.AcquisitionTimeoutUsageError = Nothing + +pgErrorStatus :: Bool -> SQL.UsageError -> HTTP.Status +pgErrorStatus _ (SQL.ConnectionUsageError _) = HTTP.status503 +pgErrorStatus _ SQL.AcquisitionTimeoutUsageError = HTTP.status504 +pgErrorStatus authed (SQL.SessionUsageError (SQL.QueryError _ _ commandError)) = + CommandError.pgErrorStatus authed commandError + +maybeHeaders :: SQL.UsageError -> Maybe [HTTP.Header] +maybeHeaders (SQL.SessionUsageError (SQL.QueryError _ _ commandError)) = + CommandError.maybeHeaders commandError +maybeHeaders _ = Nothing diff --git a/src/PostgREST/Error/SchemaCacheError.hs b/src/PostgREST/Error/SchemaCacheError.hs new file mode 100644 index 0000000000..f5b9489191 --- /dev/null +++ b/src/PostgREST/Error/SchemaCacheError.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE RecordWildCards #-} +module PostgREST.Error.SchemaCacheError + ( SchemaCacheError (..), + ) where + +import qualified Data.Aeson as JSON +import qualified Data.FuzzySet as Fuzzy +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import qualified Network.HTTP.Types.Status as HTTP + +import PostgREST.MediaType (MediaType (..)) +import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier (..), + Schema) +import PostgREST.SchemaCache.Relationship (Cardinality (..), + Junction (..), + Relationship (..), + RelationshipsMap) +import PostgREST.SchemaCache.Routine (Routine (..), + RoutineParam (..)) +import PostgREST.SchemaCache.Table (Table (..)) +import PostgREST.Error.Algebra +import Protolude + +data SchemaCacheError + = AmbiguousRelBetween Text Text [Relationship] + | AmbiguousRpc [Routine] + | NoRelBetween Text Text (Maybe Text) Text RelationshipsMap + | NoRpc Text Text [Text] MediaType Bool [QualifiedIdentifier] [Routine] + | ColumnNotFound Text Text + | TableNotFound Text Text [Table] + deriving Show + +instance PgrstError SchemaCacheError where + status AmbiguousRelBetween{} = HTTP.status300 + status AmbiguousRpc{} = HTTP.status300 + status NoRelBetween{} = HTTP.status400 + status NoRpc{} = HTTP.status404 + status ColumnNotFound{} = HTTP.status400 + status TableNotFound{} = HTTP.status404 + + headers _ = mempty + +instance ErrorBody SchemaCacheError where + code NoRelBetween{} = "PGRST200" + code AmbiguousRelBetween{} = "PGRST201" + code NoRpc{} = "PGRST202" + code AmbiguousRpc{} = "PGRST203" + code ColumnNotFound{} = "PGRST204" + code TableNotFound{} = "PGRST205" + + message (NoRelBetween parent child _ _ _) = "Could not find a relationship between '" <> parent <> "' and '" <> child <> "' in the schema cache" + message (AmbiguousRelBetween parent child _) = "Could not embed because more than one relationship was found for '" <> parent <> "' and '" <> child <> "'" + message (NoRpc schema procName argumentKeys contentType isInvPost _ _) = "Could not find the function " <> func <> (if onlySingleParams then "" else fmtPrms prmsMsg) <> " in the schema cache" + where + onlySingleParams = isInvPost && contentType `elem` [MTTextPlain, MTTextXML, MTOctetStream] + func = schema <> "." <> procName + prms = T.intercalate ", " argumentKeys + prmsMsg = "(" <> prms <> ")" + fmtPrms p = if null argumentKeys then " without parameters" else p + message (AmbiguousRpc procs) = "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] + message (ColumnNotFound rel col) = "Could not find the '" <> col <> "' column of '" <> rel <> "' in the schema cache" + message (TableNotFound schemaName relName _) = "Could not find the table '" <> schemaName <> "." <> relName <> "' in the schema cache" + + details (NoRelBetween parent child embedHint schema _) = 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." + details (AmbiguousRelBetween _ _ rels) = Just $ JSON.toJSONList (compressedRel <$> rels) + details (NoRpc schema procName argumentKeys contentType isInvPost _ _) = + Just $ JSON.String $ "Searched for the function " <> func <> + (case (isInvPost, contentType) of + (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." + where + func = schema <> "." <> procName + prms = T.intercalate ", " argumentKeys + prmsDet = " with parameter" <> (if length argumentKeys > 1 then "s " else " ") <> prms + fmtPrms p = if null argumentKeys then " without parameters" else p + + details _ = Nothing + + hint (NoRelBetween parent child _ schema allRels) = JSON.String <$> noRelBetweenHint parent child schema allRels + hint (AmbiguousRelBetween _ child rels) = Just $ JSON.String $ "Try changing '" <> child <> "' to one of the following: " <> relHint rels <> ". Find the desired relationship in the 'details' key." + -- The hint will be null in the case of single unnamed parameter functions + hint (NoRpc schema procName argumentKeys contentType isInvPost allProcs overloadedProcs) = + if onlySingleParams + then Nothing + else JSON.String <$> noRpcHint schema procName argumentKeys allProcs overloadedProcs + where + onlySingleParams = isInvPost && contentType `elem` [MTTextPlain, MTTextXML, MTOctetStream] + hint (AmbiguousRpc _) = Just "Try renaming the parameters or the function itself in the database so function overloading can be resolved" + hint (TableNotFound schemaName relName tbls) = JSON.String <$> tableNotFoundHint schemaName relName tbls + + hint _ = Nothing + +instance JSON.ToJSON SchemaCacheError where + toJSON err = toJsonPgrstError + (code err) (message err) (details err) (hint err) + +-- | +-- Do a fuzzy search in all tables in the same schema and return closest result +tableNotFoundHint :: Text -> Text -> [Table] -> Maybe Text +tableNotFoundHint schema tblName tblList + = fmap (\tbl -> "Perhaps you meant the table '" <> schema <> "." <> tbl <> "'") perhapsTable + where + perhapsTable = Fuzzy.getOne fuzzyTableSet tblName + fuzzyTableSet = Fuzzy.fromList [ tableName tbl | tbl <- tblList, tableSchema tbl == schema] + +-- | +-- 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) + +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 + +-- | +-- 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] + +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" JSON..= (qiName relTable <> " with " <> qiName relForeignTable :: Text)) + : case relCardinality of + M2M Junction{..} -> [ + "cardinality" JSON..= ("many-to-many" :: Text) + , "relationship" JSON..= (qiName junTable <> " using " <> junConstraint1 <> fmtEls (snd <$> junColsSource) <> " and " <> junConstraint2 <> fmtEls (snd <$> junColsTarget)) + ] + M2O cons relColumns -> [ + "cardinality" JSON..= ("many-to-one" :: Text) + , "relationship" JSON..= (cons <> " using " <> qiName relTable <> fmtEls (fst <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (snd <$> relColumns)) + ] + O2O cons relColumns _ -> [ + "cardinality" JSON..= ("one-to-one" :: Text) + , "relationship" JSON..= (cons <> " using " <> qiName relTable <> fmtEls (fst <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (snd <$> relColumns)) + ] + O2M cons relColumns -> [ + "cardinality" JSON..= ("one-to-many" :: Text) + , "relationship" JSON..= (cons <> " using " <> qiName relTable <> fmtEls (fst <$> relColumns) <> " and " <> qiName relForeignTable <> fmtEls (snd <$> relColumns)) + ]