{-|
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.Text                 as T
import qualified Hasql.Pool                as P
import qualified Hasql.Session             as H
import qualified Network.HTTP.Types.Status as HT

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         (PgArg (..),
                                           ProcDescription (..))
import PostgREST.DbStructure.Relationship (Cardinality (..),
                                           Junction (..),
                                           Relationship (..))
import PostgREST.DbStructure.Table        (Column (..), Table (..))

import Protolude      hiding (toS)
import Protolude.Conv (toS, toSL)


class (JSON.ToJSON a) => PgrstError a where
  status   :: a -> HT.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
  | InvalidFilters
  | UnacceptableSchema [Text]
  | ContentTypeError [ByteString]
  | UnsupportedVerb                -- Unreachable?

instance PgrstError ApiRequestError where
  status :: ApiRequestError -> Status
status ApiRequestError
InvalidRange            = Status
HT.status416
  status ApiRequestError
InvalidFilters          = Status
HT.status405
  status (InvalidBody ByteString
_)         = Status
HT.status400
  status ApiRequestError
UnsupportedVerb         = Status
HT.status405
  status ApiRequestError
ActionInappropriate     = Status
HT.status405
  status (ParseRequestError Text
_ Text
_) = Status
HT.status400
  status (NoRelBetween Text
_ Text
_)      = Status
HT.status400
  status AmbiguousRelBetween{}   = Status
HT.status300
  status (AmbiguousRpc [ProcDescription]
_)        = Status
HT.status300
  status NoRpc{}                 = Status
HT.status404
  status (UnacceptableSchema [Text]
_)  = Status
HT.status406
  status (ContentTypeError [ByteString]
_)    = Status
HT.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
forall a b. StringConv a b => a -> b
toS ByteString
errorMessage :: Text)]
  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
"By following the 'details' key, disambiguate the request by changing the url to /origin?select=relationship(*) or /origin?select=target!relationship(*)" :: Text),
    Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"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
"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
"Overloaded functions with the same argument name but different types are not supported" :: 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
", " [PgArg -> Text
pgaName PgArg
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" => " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PgArg -> Text
pgaType PgArg
a | PgArg
a <- ProcDescription -> [PgArg]
pdArgs ProcDescription
p] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")" | ProcDescription
p <- [ProcDescription]
procs])]
  toJSON (NoRpc Text
schema Text
procName [Text]
payloadKeys Bool
hasPreferSingleObject)  = [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 arguments, 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
<> (if Bool
hasPreferSingleObject then Text
" function with a single json or jsonb argument" else Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " [Text]
payloadKeys Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")" 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
<> ([Char] -> Text
forall a b. StringConv a b => a -> b
toS ([Char] -> Text)
-> ([ByteString] -> [Char]) -> [ByteString] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ([[Char]] -> [Char])
-> ([ByteString] -> [[Char]]) -> [ByteString] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> [Char]) -> [ByteString] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map ByteString -> [Char]
forall a b. StringConv a b => a -> b
toS) [ByteString]
cts :: Text)]

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
"origin"      Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Table -> Text
fmtTbl Table
relTable
  , Text
"target"      Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Table -> Text
fmtTbl Table
relForeignTable
  ] [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
"m2m" :: 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
"m2o" :: 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
"o2m" :: 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))
      ]

data PgError = PgError Authenticated P.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
HT.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 P.UsageError where
  toJSON :: UsageError -> Value
toJSON (P.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
.= (ByteString -> Text
forall a b. StringConv a b => a -> b
toSL (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 (P.SessionError QueryError
e) = QueryError -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON QueryError
e -- H.Error

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

instance JSON.ToJSON H.CommandError where
  toJSON :: CommandError -> Value
toJSON (H.ResultError (H.ServerError ByteString
c ByteString
m ConnectionError
d ConnectionError
h)) = case ByteString -> [Char]
forall a b. StringConv a b => a -> b
toS 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
forall a b. StringConv a b => a -> b
toS 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
forall a b. StringConv a b => a -> b
toS ConnectionError
h :: Maybe Text)]

    [Char]
_         -> [Pair] -> Value
JSON.object [
        Text
"code"    Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (ByteString -> Text
forall a b. StringConv a b => a -> b
toS ByteString
c      :: Text),
        Text
"message" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (ByteString -> Text
forall a b. StringConv a b => a -> b
toS 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
forall a b. StringConv a b => a -> b
toS 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
forall a b. StringConv a b => a -> b
toS ConnectionError
h :: Maybe Text)]

  toJSON (H.ResultError (H.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 (H.ResultError (H.RowError Int
i RowError
H.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 (H.ResultError (H.RowError Int
i RowError
H.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 (H.ResultError (H.RowError Int
i (H.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 (H.ResultError (H.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 (H.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
forall a b. StringConv a b => a -> b
toS ConnectionError
d :: Maybe Text)]

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

    ResultError
_                       -> Status
HT.status500

checkIsFatal :: PgError -> Maybe Text
checkIsFatal :: PgError -> Maybe Text
checkIsFatal (PgError Bool
_ (P.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
$ ByteString -> Text
forall a b. StringConv a b => a -> b
toS ByteString
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` ByteString -> [Char]
forall a b. StringConv a b => a -> b
toS ByteString
failureMessage
        failureMessage :: ByteString
failureMessage = ByteString -> ConnectionError -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
forall a. Monoid a => a
mempty ConnectionError
e
checkIsFatal (PgError Bool
_ (P.SessionError (H.QueryError ByteString
_ [Text]
_ (H.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.
      H.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.
      H.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.
      H.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
HT.status500
  status Error
GucStatusError          = Status
HT.status500
  status (BinaryFieldError ContentType
_)    = Status
HT.status406
  status Error
ConnectionLostError     = Status
HT.status503
  status Error
PutMatchingPkError      = Status
HT.status400
  status Error
PutRangeNotAllowedError = Status
HT.status400
  status Error
JwtTokenMissing         = Status
HT.status500
  status (JwtTokenInvalid Text
_)     = Status
HT.unauthorized401
  status (SingularityError Integer
_)    = Status
HT.status406
  status Error
NotFound                = Status
HT.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
forall a b. StringConv a b => a -> b
toS (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
forall a b. StringConv a b => a -> b
toS (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