{-|
Module      : PostgREST.Error
Description : PostgREST error HTTP responses
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE RecordWildCards #-}

module PostgREST.Error
  ( errorResponseFor
  , ApiRequestError(..)
  , PgError(..)
  , Error(..)
  , errorPayload
  , checkIsFatal
  , singularityError
  ) 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 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.ContentType (ContentType (..))
import qualified PostgREST.ContentType as ContentType

import PostgREST.DbStructure.Proc         (ProcDescription (..),
                                           ProcParam (..))
import PostgREST.DbStructure.Relationship (Cardinality (..),
                                           Junction (..),
                                           Relationship (..))
import PostgREST.DbStructure.Table        (Column (..), Table (..))

import Protolude


class (JSON.ToJSON a) => PgrstError a where
  status   :: a -> HTTP.Status
  headers  :: a -> [Header]

  errorPayload :: a -> LByteString
  errorPayload = a -> LByteString
forall a. ToJSON a => a -> LByteString
JSON.encode

  errorResponseFor :: a -> Response
  errorResponseFor a
err = Status -> ResponseHeaders -> LByteString -> Response
responseLBS (a -> Status
forall a. PgrstError a => a -> Status
status a
err) (a -> ResponseHeaders
forall a. PgrstError a => a -> ResponseHeaders
headers a
err) (LByteString -> Response) -> LByteString -> Response
forall a b. (a -> b) -> a -> b
$ a -> LByteString
forall a. PgrstError a => a -> LByteString
errorPayload a
err



data ApiRequestError
  = ActionInappropriate
  | InvalidRange
  | InvalidBody ByteString
  | ParseRequestError Text Text
  | NoRelBetween Text Text
  | AmbiguousRelBetween Text Text [Relationship]
  | AmbiguousRpc [ProcDescription]
  | NoRpc Text Text [Text] Bool ContentType Bool
  | InvalidFilters
  | UnacceptableSchema [Text]
  | ContentTypeError [ByteString]
  | UnsupportedVerb                -- Unreachable?

instance PgrstError ApiRequestError where
  status :: ApiRequestError -> Status
status ApiRequestError
InvalidRange            = Status
HTTP.status416
  status ApiRequestError
InvalidFilters          = Status
HTTP.status405
  status (InvalidBody ByteString
_)         = Status
HTTP.status400
  status ApiRequestError
UnsupportedVerb         = Status
HTTP.status405
  status ApiRequestError
ActionInappropriate     = Status
HTTP.status405
  status (ParseRequestError Text
_ Text
_) = Status
HTTP.status400
  status (NoRelBetween Text
_ Text
_)      = Status
HTTP.status400
  status AmbiguousRelBetween{}   = Status
HTTP.status300
  status (AmbiguousRpc [ProcDescription]
_)        = Status
HTTP.status300
  status NoRpc{}                 = Status
HTTP.status404
  status (UnacceptableSchema [Text]
_)  = Status
HTTP.status406
  status (ContentTypeError [ByteString]
_)    = Status
HTTP.status415

  headers :: ApiRequestError -> ResponseHeaders
headers ApiRequestError
_ = [ContentType -> Header
ContentType.toHeader ContentType
CTApplicationJSON]

instance JSON.ToJSON ApiRequestError where
  toJSON :: ApiRequestError -> Value
toJSON (ParseRequestError Text
message Text
details) = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
message, Text
"details" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
details]
  toJSON ApiRequestError
ActionInappropriate = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Bad Request" :: Text)]
  toJSON (InvalidBody ByteString
errorMessage) = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ByteString -> Text
T.decodeUtf8 ByteString
errorMessage]
  toJSON ApiRequestError
InvalidRange = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"HTTP Range error" :: Text)]
  toJSON (NoRelBetween Text
parent Text
child) = [Pair] -> Value
JSON.object [
    Text
"hint"    Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"If a new foreign key between these entities was created in the database, try reloading the schema cache." :: Text),
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Could not find a relationship between " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
parent Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
child Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in the schema cache" :: Text)]
  toJSON (AmbiguousRelBetween Text
parent Text
child [Relationship]
rels) = [Pair] -> Value
JSON.object [
    Text
"hint"    Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Try changing '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
child Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' to one of the following: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Relationship] -> Text
relHint [Relationship]
rels Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Find the desired relationship in the 'details' key." :: Text),
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Could not embed because more than one relationship was found for '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
parent Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' and '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
child Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'" :: Text),
    Text
"details" Text -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Relationship -> Value
compressedRel (Relationship -> Value) -> [Relationship] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Relationship]
rels) ]
  toJSON (AmbiguousRpc [ProcDescription]
procs)  = [Pair] -> Value
JSON.object [
    Text
"hint"    Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Try renaming the parameters or the function itself in the database so function overloading can be resolved" :: Text),
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Could not choose the best candidate function between: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [ProcDescription -> Text
pdSchema ProcDescription
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ProcDescription -> Text
pdName ProcDescription
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [ProcParam -> Text
ppName ProcParam
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" => " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ProcParam -> Text
ppType ProcParam
a | ProcParam
a <- ProcDescription -> [ProcParam]
pdParams ProcDescription
p] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")" | ProcDescription
p <- [ProcDescription]
procs])]
  toJSON (NoRpc Text
schema Text
procName [Text]
argumentKeys Bool
hasPreferSingleObject ContentType
contentType Bool
isInvPost)  =
    let prms :: Text
prms = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
argumentKeys Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")" in [Pair] -> Value
JSON.object [
    Text
"hint"    Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"If a new function was created in the database with this name and parameters, try reloading the schema cache." :: Text),
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Could not find the " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
procName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
      (case (Bool
hasPreferSingleObject, Bool
isInvPost, ContentType
contentType) of
        (Bool
True, Bool
_, ContentType
_)                 -> Text
" function with a single json or jsonb parameter"
        (Bool
_, Bool
True, ContentType
CTTextPlain)       -> Text
" function with a single unnamed text parameter"
        (Bool
_, Bool
True, ContentType
CTOctetStream)     -> Text
" function with a single unnamed bytea parameter"
        (Bool
_, Bool
True, ContentType
CTApplicationJSON) -> Text
prms Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" function or the " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
schema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
procName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
" function with a single unnamed json or jsonb parameter"
        (Bool, Bool, ContentType)
_                            -> Text
prms Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" function") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
      Text
" in the schema cache")]
  toJSON ApiRequestError
UnsupportedVerb = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Unsupported HTTP verb" :: Text)]
  toJSON ApiRequestError
InvalidFilters = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Filters must include all and only primary key columns with 'eq' operators" :: Text)]
  toJSON (UnacceptableSchema [Text]
schemas) = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"The schema must be one of the following: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
schemas)]
  toJSON (ContentTypeError [ByteString]
cts)    = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"None of these Content-Types are available: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " ((ByteString -> Text) -> [ByteString] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ByteString -> Text
T.decodeUtf8 [ByteString]
cts))]

compressedRel :: Relationship -> JSON.Value
compressedRel :: Relationship -> Value
compressedRel Relationship{[Column]
Table
Cardinality
relCardinality :: Relationship -> Cardinality
relForeignColumns :: Relationship -> [Column]
relForeignTable :: Relationship -> Table
relColumns :: Relationship -> [Column]
relTable :: Relationship -> Table
relCardinality :: Cardinality
relForeignColumns :: [Column]
relForeignTable :: Table
relColumns :: [Column]
relTable :: Table
..} =
  let
    fmtTbl :: Table -> Text
fmtTbl Table{Bool
Maybe Text
Text
tableDeletable :: Table -> Bool
tableUpdatable :: Table -> Bool
tableInsertable :: Table -> Bool
tableDescription :: Table -> Maybe Text
tableName :: Table -> Text
tableSchema :: Table -> Text
tableDeletable :: Bool
tableUpdatable :: Bool
tableInsertable :: Bool
tableDescription :: Maybe Text
tableName :: Text
tableSchema :: Text
..} = Text
tableSchema Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName
    fmtEls :: [Text] -> Text
fmtEls [Text]
els = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
els Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
  in
  [Pair] -> Value
JSON.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
    (Text
"embedding" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Table -> Text
tableName Table
relTable Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Table -> Text
tableName Table
relForeignTable :: Text))
    Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: case Cardinality
relCardinality of
        M2M Junction{[Column]
Text
Table
junColumns2 :: Junction -> [Column]
junConstraint2 :: Junction -> Text
junColumns1 :: Junction -> [Column]
junConstraint1 :: Junction -> Text
junTable :: Junction -> Table
junColumns2 :: [Column]
junConstraint2 :: Text
junColumns1 :: [Column]
junConstraint1 :: Text
junTable :: Table
..} -> [
            Text
"cardinality" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"many-to-many" :: Text)
          , Text
"relationship" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Table -> Text
fmtTbl Table
junTable Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
fmtEls [Text
junConstraint1] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
fmtEls [Text
junConstraint2])
          ]
        M2O Text
cons -> [
            Text
"cardinality" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"many-to-one" :: Text)
          , Text
"relationship" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
cons Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
fmtEls (Column -> Text
colName (Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Column]
relColumns) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
fmtEls (Column -> Text
colName (Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Column]
relForeignColumns))
          ]
        O2M Text
cons -> [
            Text
"cardinality" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"one-to-many" :: Text)
          , Text
"relationship" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
cons Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
fmtEls (Column -> Text
colName (Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Column]
relColumns) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
fmtEls (Column -> Text
colName (Column -> Text) -> [Column] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Column]
relForeignColumns))
          ]

relHint :: [Relationship] -> Text
relHint :: [Relationship] -> Text
relHint [Relationship]
rels = Text -> [Text] -> Text
T.intercalate Text
", " (Relationship -> Text
hintList (Relationship -> Text) -> [Relationship] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Relationship]
rels)
  where
    hintList :: Relationship -> Text
hintList Relationship{[Column]
Table
Cardinality
relCardinality :: Cardinality
relForeignColumns :: [Column]
relForeignTable :: Table
relColumns :: [Column]
relTable :: Table
relCardinality :: Relationship -> Cardinality
relForeignColumns :: Relationship -> [Column]
relForeignTable :: Relationship -> Table
relColumns :: Relationship -> [Column]
relTable :: Relationship -> Table
..} =
      let buildHint :: Text -> Text
buildHint Text
rel = Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Table -> Text
tableName Table
relForeignTable Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"!" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rel Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'" in
      case Cardinality
relCardinality of
        M2M Junction{[Column]
Text
Table
junColumns2 :: [Column]
junConstraint2 :: Text
junColumns1 :: [Column]
junConstraint1 :: Text
junTable :: Table
junColumns2 :: Junction -> [Column]
junConstraint2 :: Junction -> Text
junColumns1 :: Junction -> [Column]
junConstraint1 :: Junction -> Text
junTable :: Junction -> Table
..} -> Text -> Text
buildHint (Table -> Text
tableName Table
junTable)
        M2O Text
cons         -> Text -> Text
buildHint Text
cons
        O2M Text
cons         -> Text -> Text
buildHint Text
cons

data PgError = PgError Authenticated SQL.UsageError
type Authenticated = Bool

instance PgrstError PgError where
  status :: PgError -> Status
status (PgError Bool
authed UsageError
usageError) = Bool -> UsageError -> Status
pgErrorStatus Bool
authed UsageError
usageError

  headers :: PgError -> ResponseHeaders
headers PgError
err =
    if PgError -> Status
forall a. PgrstError a => a -> Status
status PgError
err Status -> Status -> Bool
forall a. Eq a => a -> a -> Bool
== Status
HTTP.status401
       then [ContentType -> Header
ContentType.toHeader ContentType
CTApplicationJSON, (HeaderName
"WWW-Authenticate", ByteString
"Bearer") :: Header]
       else [ContentType -> Header
ContentType.toHeader ContentType
CTApplicationJSON]

instance JSON.ToJSON PgError where
  toJSON :: PgError -> Value
toJSON (PgError Bool
_ UsageError
usageError) = UsageError -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON UsageError
usageError

instance JSON.ToJSON SQL.UsageError where
  toJSON :: UsageError -> Value
toJSON (SQL.ConnectionError ConnectionError
e) = [Pair] -> Value
JSON.object [
    Text
"code"    Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"" :: Text),
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Database connection error. Retrying the connection." :: Text),
    Text
"details" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (OnDecodeError -> ByteString -> Text
T.decodeUtf8With OnDecodeError
T.lenientDecode (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ConnectionError -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" ConnectionError
e :: Text)]
  toJSON (SQL.SessionError QueryError
e) = QueryError -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON QueryError
e -- SQL.Error

instance JSON.ToJSON SQL.QueryError where
  toJSON :: QueryError -> Value
toJSON (SQL.QueryError ByteString
_ [Text]
_ CommandError
e) = CommandError -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON CommandError
e

instance JSON.ToJSON SQL.CommandError where
  toJSON :: CommandError -> Value
toJSON (SQL.ResultError (SQL.ServerError ByteString
c ByteString
m ConnectionError
d ConnectionError
h)) = case ByteString -> [Char]
BS.unpack ByteString
c of
    Char
'P':Char
'T':[Char]
_ -> [Pair] -> Value
JSON.object [
        Text
"details" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (ByteString -> Text) -> ConnectionError -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
T.decodeUtf8 ConnectionError
d,
        Text
"hint"    Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (ByteString -> Text) -> ConnectionError -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
T.decodeUtf8 ConnectionError
h]

    [Char]
_         -> [Pair] -> Value
JSON.object [
        Text
"code"    Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (ByteString -> Text
T.decodeUtf8 ByteString
c      :: Text),
        Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (ByteString -> Text
T.decodeUtf8 ByteString
m      :: Text),
        Text
"details" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ((ByteString -> Text) -> ConnectionError -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
T.decodeUtf8 ConnectionError
d :: Maybe Text),
        Text
"hint"    Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ((ByteString -> Text) -> ConnectionError -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
T.decodeUtf8 ConnectionError
h :: Maybe Text)]

  toJSON (SQL.ResultError (SQL.UnexpectedResult Text
m)) = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
m :: Text)]
  toJSON (SQL.ResultError (SQL.RowError Int
i RowError
SQL.EndOfInput)) = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Row error: end of input" :: Text),
    Text
"details" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Attempt to parse more columns than there are in the result" :: Text),
    Text
"hint"    Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ((Text
"Row number " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a b. (Show a, ConvertText [Char] b) => a -> b
show Int
i) :: Text)]
  toJSON (SQL.ResultError (SQL.RowError Int
i RowError
SQL.UnexpectedNull)) = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Row error: unexpected null" :: Text),
    Text
"details" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Attempt to parse a NULL as some value." :: Text),
    Text
"hint"    Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ((Text
"Row number " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a b. (Show a, ConvertText [Char] b) => a -> b
show Int
i) :: Text)]
  toJSON (SQL.ResultError (SQL.RowError Int
i (SQL.ValueError Text
d))) = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Row error: Wrong value parser used" :: Text),
    Text
"details" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
d,
    Text
"hint"    Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ((Text
"Row number " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a b. (Show a, ConvertText [Char] b) => a -> b
show Int
i) :: Text)]
  toJSON (SQL.ResultError (SQL.UnexpectedAmountOfRows Int
i)) = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Unexpected amount of rows" :: Text),
    Text
"details" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
i]
  toJSON (SQL.ClientError ConnectionError
d) = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Database client error. Retrying the connection." :: Text),
    Text
"details" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ((ByteString -> Text) -> ConnectionError -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
T.decodeUtf8 ConnectionError
d :: Maybe Text)]

pgErrorStatus :: Bool -> SQL.UsageError -> HTTP.Status
pgErrorStatus :: Bool -> UsageError -> Status
pgErrorStatus Bool
_      (SQL.ConnectionError ConnectionError
_)                                      = Status
HTTP.status503
pgErrorStatus Bool
_      (SQL.SessionError (SQL.QueryError ByteString
_ [Text]
_ (SQL.ClientError ConnectionError
_)))      = Status
HTTP.status503
pgErrorStatus Bool
authed (SQL.SessionError (SQL.QueryError ByteString
_ [Text]
_ (SQL.ResultError ResultError
rError))) =
  case ResultError
rError of
    (SQL.ServerError ByteString
c ByteString
m ConnectionError
_ ConnectionError
_) ->
      case ByteString -> [Char]
BS.unpack ByteString
c of
        Char
'0':Char
'8':[Char]
_ -> Status
HTTP.status503 -- pg connection err
        Char
'0':Char
'9':[Char]
_ -> Status
HTTP.status500 -- triggered action exception
        Char
'0':Char
'L':[Char]
_ -> Status
HTTP.status403 -- invalid grantor
        Char
'0':Char
'P':[Char]
_ -> Status
HTTP.status403 -- invalid role specification
        [Char]
"23503"   -> Status
HTTP.status409 -- foreign_key_violation
        [Char]
"23505"   -> Status
HTTP.status409 -- unique_violation
        [Char]
"25006"   -> Status
HTTP.status405 -- read_only_sql_transaction
        Char
'2':Char
'5':[Char]
_ -> Status
HTTP.status500 -- invalid tx state
        Char
'2':Char
'8':[Char]
_ -> Status
HTTP.status403 -- invalid auth specification
        Char
'2':Char
'D':[Char]
_ -> Status
HTTP.status500 -- invalid tx termination
        Char
'3':Char
'8':[Char]
_ -> Status
HTTP.status500 -- external routine exception
        Char
'3':Char
'9':[Char]
_ -> Status
HTTP.status500 -- external routine invocation
        Char
'3':Char
'B':[Char]
_ -> Status
HTTP.status500 -- savepoint exception
        Char
'4':Char
'0':[Char]
_ -> Status
HTTP.status500 -- tx rollback
        Char
'5':Char
'3':[Char]
_ -> Status
HTTP.status503 -- insufficient resources
        Char
'5':Char
'4':[Char]
_ -> Status
HTTP.status413 -- too complex
        Char
'5':Char
'5':[Char]
_ -> Status
HTTP.status500 -- obj not on prereq state
        Char
'5':Char
'7':[Char]
_ -> Status
HTTP.status500 -- operator intervention
        Char
'5':Char
'8':[Char]
_ -> Status
HTTP.status500 -- system error
        Char
'F':Char
'0':[Char]
_ -> Status
HTTP.status500 -- conf file error
        Char
'H':Char
'V':[Char]
_ -> Status
HTTP.status500 -- foreign data wrapper error
        [Char]
"P0001"   -> Status
HTTP.status400 -- default code for "raise"
        Char
'P':Char
'0':[Char]
_ -> Status
HTTP.status500 -- PL/pgSQL Error
        Char
'X':Char
'X':[Char]
_ -> Status
HTTP.status500 -- internal Error
        [Char]
"42883"   -> Status
HTTP.status404 -- undefined function
        [Char]
"42P01"   -> Status
HTTP.status404 -- undefined table
        [Char]
"42501"   -> if Bool
authed then Status
HTTP.status403 else Status
HTTP.status401 -- insufficient privilege
        Char
'P':Char
'T':[Char]
n -> Status -> Maybe Status -> Status
forall a. a -> Maybe a -> a
fromMaybe Status
HTTP.status500 (Int -> ByteString -> Status
HTTP.mkStatus (Int -> ByteString -> Status)
-> Maybe Int -> Maybe (ByteString -> Status)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
n Maybe (ByteString -> Status) -> ConnectionError -> Maybe Status
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ByteString -> ConnectionError
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
m)
        [Char]
_         -> Status
HTTP.status400

    ResultError
_                       -> Status
HTTP.status500

checkIsFatal :: PgError -> Maybe Text
checkIsFatal :: PgError -> Maybe Text
checkIsFatal (PgError Bool
_ (SQL.ConnectionError ConnectionError
e))
  | Bool
isAuthFailureMessage = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
forall a b. ConvertText a b => a -> b
toS [Char]
failureMessage
  | Bool
otherwise = Maybe Text
forall a. Maybe a
Nothing
  where isAuthFailureMessage :: Bool
isAuthFailureMessage = [Char]
"FATAL:  password authentication failed" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
failureMessage
        failureMessage :: [Char]
failureMessage = ByteString -> [Char]
BS.unpack (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> ConnectionError -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
forall a. Monoid a => a
mempty ConnectionError
e
checkIsFatal (PgError Bool
_ (SQL.SessionError (SQL.QueryError ByteString
_ [Text]
_ (SQL.ResultError ResultError
serverError))))
  = case ResultError
serverError of
      -- Check for a syntax error (42601 is the pg code). This would mean the error is on our part somehow, so we treat it as fatal.
      SQL.ServerError ByteString
"42601" ByteString
_ ConnectionError
_ ConnectionError
_
        -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Hint: This is probably a bug in PostgREST, please report it at https://github.com/PostgREST/postgrest/issues"
      -- Check for a "prepared statement <name> already exists" error (Code 42P05: duplicate_prepared_statement).
      -- This would mean that a connection pooler in transaction mode is being used
      -- while prepared statements are enabled in the PostgREST configuration,
      -- both of which are incompatible with each other.
      SQL.ServerError ByteString
"42P05" ByteString
_ ConnectionError
_ ConnectionError
_
        -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Hint: If you are using connection poolers in transaction mode, try setting db-prepared-statements to false."
      -- Check for a "transaction blocks not allowed in statement pooling mode" error (Code 08P01: protocol_violation).
      -- This would mean that a connection pooler in statement mode is being used which is not supported in PostgREST.
      SQL.ServerError ByteString
"08P01" ByteString
"transaction blocks not allowed in statement pooling mode" ConnectionError
_ ConnectionError
_
        -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Hint: Connection poolers in statement mode are not supported."
      ResultError
_ -> Maybe Text
forall a. Maybe a
Nothing
checkIsFatal PgError
_ = Maybe Text
forall a. Maybe a
Nothing


data Error
  = GucHeadersError
  | GucStatusError
  | BinaryFieldError ContentType
  | ConnectionLostError
  | PutMatchingPkError
  | PutRangeNotAllowedError
  | JwtTokenMissing
  | JwtTokenInvalid Text
  | SingularityError Integer
  | NotFound
  | ApiRequestError ApiRequestError
  | PgErr PgError

instance PgrstError Error where
  status :: Error -> Status
status Error
GucHeadersError         = Status
HTTP.status500
  status Error
GucStatusError          = Status
HTTP.status500
  status (BinaryFieldError ContentType
_)    = Status
HTTP.status406
  status Error
ConnectionLostError     = Status
HTTP.status503
  status Error
PutMatchingPkError      = Status
HTTP.status400
  status Error
PutRangeNotAllowedError = Status
HTTP.status400
  status Error
JwtTokenMissing         = Status
HTTP.status500
  status (JwtTokenInvalid Text
_)     = Status
HTTP.unauthorized401
  status (SingularityError Integer
_)    = Status
HTTP.status406
  status Error
NotFound                = Status
HTTP.status404
  status (PgErr PgError
err)             = PgError -> Status
forall a. PgrstError a => a -> Status
status PgError
err
  status (ApiRequestError ApiRequestError
err)   = ApiRequestError -> Status
forall a. PgrstError a => a -> Status
status ApiRequestError
err

  headers :: Error -> ResponseHeaders
headers (SingularityError Integer
_)     = [ContentType -> Header
ContentType.toHeader ContentType
CTSingularJSON]
  headers (JwtTokenInvalid Text
m)      = [ContentType -> Header
ContentType.toHeader ContentType
CTApplicationJSON, Text -> Header
invalidTokenHeader Text
m]
  headers (PgErr PgError
err)              = PgError -> ResponseHeaders
forall a. PgrstError a => a -> ResponseHeaders
headers PgError
err
  headers (ApiRequestError ApiRequestError
err)    = ApiRequestError -> ResponseHeaders
forall a. PgrstError a => a -> ResponseHeaders
headers ApiRequestError
err
  headers Error
_                        = [ContentType -> Header
ContentType.toHeader ContentType
CTApplicationJSON]

instance JSON.ToJSON Error where
  toJSON :: Error -> Value
toJSON Error
GucHeadersError           = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"response.headers guc must be a JSON array composed of objects with a single key and a string value" :: Text)]
  toJSON Error
GucStatusError           = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"response.status guc must be a valid status code" :: Text)]
  toJSON (BinaryFieldError ContentType
ct)          = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ((ByteString -> Text
T.decodeUtf8 (ContentType -> ByteString
ContentType.toMime ContentType
ct) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" requested but more than one column was selected") :: Text)]
  toJSON Error
ConnectionLostError       = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Database connection lost. Retrying the connection." :: Text)]

  toJSON Error
PutRangeNotAllowedError   = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Range header and limit/offset querystring parameters are not allowed for PUT" :: Text)]
  toJSON Error
PutMatchingPkError        = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Payload values do not match URL in primary key column(s)" :: Text)]

  toJSON (SingularityError Integer
n)      = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"JSON object requested, multiple (or no) rows returned" :: Text),
    Text
"details" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Text] -> Text
T.unwords [Text
"Results contain", Integer -> Text
forall a b. (Show a, ConvertText [Char] b) => a -> b
show Integer
n, Text
"rows,", ByteString -> Text
T.decodeUtf8 (ContentType -> ByteString
ContentType.toMime ContentType
CTSingularJSON), Text
"requires 1 row"]]

  toJSON Error
JwtTokenMissing           = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"Server lacks JWT secret" :: Text)]
  toJSON (JwtTokenInvalid Text
message) = [Pair] -> Value
JSON.object [
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
message :: Text)]
  toJSON Error
NotFound = [Pair] -> Value
JSON.object []
  toJSON (PgErr PgError
err) = PgError -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON PgError
err
  toJSON (ApiRequestError ApiRequestError
err) = ApiRequestError -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON ApiRequestError
err

invalidTokenHeader :: Text -> Header
invalidTokenHeader :: Text -> Header
invalidTokenHeader Text
m =
  (HeaderName
"WWW-Authenticate", ByteString
"Bearer error=\"invalid_token\", " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"error_description=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
encodeUtf8 (Text -> Text
forall a b. (Show a, ConvertText [Char] b) => a -> b
show Text
m))

singularityError :: (Integral a) => a -> Error
singularityError :: a -> Error
singularityError = Integer -> Error
SingularityError (Integer -> Error) -> (a -> Integer) -> a -> Error
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Integer
forall a. Integral a => a -> Integer
toInteger