Small refactor around error responses and more tests (#1282)

* Fix #880, Clean and consolidate error responses * Fix #1285, Abort on fatal errors * Add / Detail tests
2019-05-22 09:30:33 -05:00
parent e2d917f7b9
commit 1cf54e6575
17 changed files with 500 additions and 284 deletions
@@ -1,16 +1,18 @@
-{-# LANGUAGE LambdaCase #-}
 {-|
 Module      : PostgREST.ApiRequest
 Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
 -}
-module PostgREST.ApiRequest ( ApiRequest(..)
-                            , ContentType(..)
-                            , Action(..)
-                            , Target(..)
-                            , PreferRepresentation (..)
-                            , mutuallyAgreeable
-                            , userApiRequest
-                            ) where
+{-# LANGUAGE LambdaCase #-}
+
+module PostgREST.ApiRequest ( 
+  ApiRequest(..)
+, ContentType(..)
+, Action(..)
+, Target(..)
+, PreferRepresentation (..)
+, mutuallyAgreeable
+, userApiRequest
+) where

 import           Protolude
 import qualified Data.Aeson                as JSON
@@ -35,6 +37,7 @@ import           Network.Wai.Parse         (parseHttpAccept)
 import           PostgREST.RangeQuery      (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset)
 import           Data.Ranged.Boundaries
 import           PostgREST.Types
+import           PostgREST.Error           (ApiRequestError(..))
 import           Data.Ranged.Ranges        (Range(..), rangeIntersection, emptyRange)
 import qualified Data.CaseInsensitive      as CI
 import           Web.Cookie                (parseCookiesText)
@@ -11,7 +11,6 @@ import           Data.Aeson                as JSON
 import qualified Data.ByteString.Char8     as BS
 import           Data.Maybe
 import           Data.IORef                (IORef, readIORef)
-import           Data.Text                 (intercalate)
 import           Data.Time.Clock           (UTCTime)
 import qualified Data.Set                  as S

@@ -42,10 +41,8 @@ import           PostgREST.DbRequestBuilder( readRequest
                                           , mutateRequest
                                           , fieldNames
                                           )
-import           PostgREST.Error           ( simpleError, pgError
-                                           , apiRequestError
-                                           , singularityError, binaryFieldError
-                                           , connectionLostError, gucHeadersError
+import           PostgREST.Error           ( SimpleError(..), PgError(..)
+                                           , errorResponseFor
                                           )
 import           PostgREST.RangeQuery      (allRange, rangeOffset)
 import           PostgREST.Middleware
@@ -73,14 +70,14 @@ postgrest conf refDbStructure pool getTime worker =
    body <- strictRequestBody req
    maybeDbStructure <- readIORef refDbStructure
    case maybeDbStructure of
-      Nothing -> respond connectionLostError
+      Nothing -> respond . errorResponseFor $ ConnectionLostError
      Just dbStructure -> do
        response <- do
          -- Need to parse ?columns early because findProc needs it to solve overloaded functions
          let apiReq = userApiRequest (configSchema conf) req body
              apiReqCols = (,) <$> apiReq <*> (pRequestColumns =<< iColumns <$> apiReq)
          case apiReqCols of
-            Left err -> return $ apiRequestError err
+            Left err -> return . errorResponseFor $ err
            Right (apiRequest, maybeCols) -> do
              eClaims <- jwtClaims jwtSecret (configJwtAudience conf) (toS $ iJWT apiRequest) time (rightToMaybe $ configRoleClaimKey conf)
              let authed = containsRole eClaims
@@ -94,7 +91,7 @@ postgrest conf refDbStructure pool getTime worker =
                  handleReq = runWithClaims conf eClaims (app dbStructure proc cols conf) apiRequest
                  txMode = transactionMode proc (iAction apiRequest)
              response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq
-              return $ either (pgError authed) identity response
+              return $ either (errorResponseFor . PgError authed) identity response
        when (responseStatus response == status503) worker
        respond response

@@ -133,7 +130,7 @@ app dbStructure proc cols conf apiRequest =
                  canonical = iCanonicalQS apiRequest
              return $
                if contentType == CTSingularJSON && queryTotal /= 1
-                  then singularityError (toInteger queryTotal)
+                  then errorResponseFor . singularityError $ queryTotal
                  else responseLBS status
                    [toHeader contentType, contentRange,
                      ("Content-Location",
@@ -170,7 +167,7 @@ app dbStructure proc cols conf apiRequest =
                 && iPreferRepresentation apiRequest == Full
                then do
                  HT.condemn
-                  return $ singularityError (toInteger queryTotal)
+                  return . errorResponseFor . singularityError $ queryTotal
              else
                return . responseLBS status201 headers $
                  if iPreferRepresentation apiRequest == Full
@@ -199,7 +196,7 @@ app dbStructure proc cols conf apiRequest =
              case (contentType, iPreferRepresentation apiRequest) of
                (CTSingularJSON, Full)
                      | queryTotal == 1 -> return $ responseLBS status fullHeaders (toS body)
-                      | otherwise       -> HT.condemn >> return (singularityError queryTotal)
+                      | otherwise       -> HT.condemn >> (return . errorResponseFor . singularityError) queryTotal

                (_, Full) ->
                  return $ responseLBS status fullHeaders (toS body)
@@ -217,11 +214,11 @@ app dbStructure proc cols conf apiRequest =
                               PJObject -> True
                  colNames = colName <$> tableCols dbStructure tSchema tName
              if topLevelRange /= allRange
-                then return $ simpleError status400 [] "Range header and limit/offset querystring parameters are not allowed for PUT"
+                then return . errorResponseFor $ PutRangeNotAllowedError
              else if not isSingle
-                then return $ simpleError status400 [] "PUT payload must contain a single row"
+                then return . errorResponseFor $ PutSingletonError
              else if S.fromList colNames /= pjKeys
-                then return $ simpleError status400 [] "You must specify all columns in the payload when using PUT"
+                then return . errorResponseFor $ PutPayloadIncompleteError
              else do
                row <- H.statement (toS pjRaw) $
                       createWriteStatement sq mq (contentType == CTSingularJSON) False
@@ -233,7 +230,7 @@ app dbStructure proc cols conf apiRequest =
                if queryTotal /= 1
                  then do
                    HT.condemn
-                    return $ simpleError status400 [] "Payload values do not match URL in primary key column(s)"
+                    return . errorResponseFor $ PutMatchingPkError
                  else
                    return $ if iPreferRepresentation apiRequest == Full
                      then responseLBS status200 [toHeader contentType] (toS body)
@@ -256,7 +253,7 @@ app dbStructure proc cols conf apiRequest =
                 && iPreferRepresentation apiRequest == Full
                then do
                  HT.condemn
-                  return $ singularityError (toInteger queryTotal)
+                  return . errorResponseFor . singularityError $ queryTotal
                else
                  return $ if iPreferRepresentation apiRequest == Full
                    then responseLBS status200 [toHeader contentType, r] (toS body)
@@ -293,12 +290,12 @@ app dbStructure proc cols conf apiRequest =
                  (status, contentRange) = rangeHeader queryTotal tableTotal
                  decodedHeaders = first toS $ JSON.eitherDecode $ toS jsonHeaders :: Either Text [GucHeader]
              case decodedHeaders of
-                Left _ -> return gucHeadersError
+                Left _ -> return . errorResponseFor $ GucHeadersError
                Right hs ->
                  if singular && queryTotal /= 1
                    then do
                      HT.condemn
-                      return $ singularityError (toInteger queryTotal)
+                      return . errorResponseFor . singularityError $ queryTotal
                    else return $ responseLBS status ([toHeader contentType, contentRange] ++ toHeaders hs) (toS body)

        (ActionInspect, TargetRoot, Nothing) -> do
@@ -355,17 +352,14 @@ responseContentTypeOrError accepts action = serves contentTypesForRequest accept
        ActionSingleUpsert ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
    serves sProduces cAccepts =
      case mutuallyAgreeable sProduces cAccepts of
-        Nothing -> do
-          let failed = intercalate ", " $ map (toS . toMime) cAccepts
-          Left $ simpleError status415 [] $
-            "None of these Content-Types are available: " <> failed
+        Nothing -> Left . errorResponseFor . ContentTypeError . map toMime $ cAccepts
        Just ct -> Right ct

 binaryField :: ContentType -> [FieldName] -> Either Response (Maybe FieldName)
 binaryField CTOctetStream fldNames =
  if length fldNames == 1 && fieldName /= Just "*"
    then Right fieldName
-    else Left binaryFieldError
+    else Left . errorResponseFor $ BinaryFieldError
  where
    fieldName = headMay fldNames
 binaryField _ _ = Right Nothing
@@ -399,3 +393,6 @@ contentRangeH lower upper total =

 extractQueryResult :: Maybe ResultsWithCount -> ResultsWithCount
 extractQueryResult = fromMaybe (Nothing, 0, [], "")
+
+singularityError :: (Integral a) => a -> SimpleError
+singularityError = SingularityError . toInteger
@@ -1,5 +1,3 @@
-{-# LANGUAGE LambdaCase, TemplateHaskell #-}
-{-# OPTIONS_GHC -fno-warn-type-defaults #-}
 {-|
 Module      : PostgREST.Config
 Description : Manages PostgREST configuration options.
@@ -14,6 +12,9 @@ turned in configurable behaviour if needed.

 Other hardcoded options such as the minimum version number also belong here.
 -}
+{-# LANGUAGE LambdaCase, TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-type-defaults #-}
+
 module PostgREST.Config ( prettyVersion
                        , docsVersion
                        , readOptions
@@ -50,8 +51,8 @@ import           Network.Wai.Middleware.Cors  (CorsResourcePolicy (..))
 import           Options.Applicative          hiding (str)
 import           Paths_postgrest              (version)
 import           PostgREST.Parsers            (pRoleClaimKey)
-import           PostgREST.Types              (ApiRequestError(..),
-                                               JSPath, JSPathExp(..))
+import           PostgREST.Types              (JSPath, JSPathExp(..))
+import           PostgREST.Error              (ApiRequestError(..))
 import           Protolude                    hiding (hPutStrLn, take,
                                               intercalate, (<>))
 import           System.IO                    (hPrint)
@@ -11,6 +11,7 @@ A query tree is built in case of resource embedding. By inferring the relationsh
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE NamedFieldPuns #-}
+
 module PostgREST.DbRequestBuilder (
  readRequest
 , mutateRequest
@@ -31,26 +32,26 @@ import           Data.Either.Combinators   (mapLeft)

 import           Network.Wai

-import           Data.Foldable (foldr1)
+import           Data.Foldable             (foldr1)
 import qualified Data.HashMap.Strict       as M

-import           PostgREST.ApiRequest   ( ApiRequest(..)
-                                        , PreferRepresentation(..)
-                                        , Action(..), Target(..)
-                                        , PreferRepresentation (..)
-                                        )
-import           PostgREST.Error           (apiRequestError)
+import           PostgREST.ApiRequest      ( ApiRequest(..)
+                                           , PreferRepresentation(..)
+                                           , Action(..), Target(..)
+                                           , PreferRepresentation (..)
+                                           )
+import           PostgREST.Error           (ApiRequestError(..), errorResponseFor)
 import           PostgREST.Parsers
 import           PostgREST.RangeQuery      (NonnegRange, restrictRange, allRange)
 import           PostgREST.Types

-import           Protolude                hiding (from)
-import           Text.Regex.TDFA         ((=~))
-import           Unsafe                  (unsafeHead)
+import           Protolude                 hiding (from)
+import           Text.Regex.TDFA           ((=~))
+import           Unsafe                    (unsafeHead)

 readRequest :: Maybe Integer -> [Relation] -> Maybe ProcDescription -> ApiRequest -> Either Response ReadRequest
 readRequest maxRows allRels proc apiRequest  =
-  mapLeft apiRequestError $
+  mapLeft errorResponseFor $
  treeRestrictRange maxRows =<<
  augumentRequestWithJoin schema relations =<<
  addFiltersOrdersRanges apiRequest <*>
@@ -319,7 +320,7 @@ addProperty f (targetNodeName:remainingPath, a) (Node rn forest) =
    pathNode = find (\(Node (_,(nodeName,_,alias,_,_)) _) -> nodeName == targetNodeName || alias == Just targetNodeName) forest

 mutateRequest :: ApiRequest -> TableName -> S.Set FieldName -> [FieldName] -> [FieldName] -> Either Response MutateRequest
-mutateRequest apiRequest tName cols pkCols fldNames = mapLeft apiRequestError $
+mutateRequest apiRequest tName cols pkCols fldNames = mapLeft errorResponseFor $
  case action of
    ActionCreate -> Right $ Insert tName cols ((,) <$> iPreferResolution apiRequest <*> Just pkCols) [] returnings
    ActionUpdate -> Update tName cols <$> combinedLogic <*> pure returnings
@@ -7,14 +7,12 @@ Description : PostgREST error HTTP responses
 {-# LANGUAGE TypeSynonymInstances #-}

 module PostgREST.Error (
-  apiRequestError
-, pgError
-, simpleError
-, singularityError
-, binaryFieldError
-, connectionLostError
-, encodeError
-, gucHeadersError
+  errorResponseFor
+, ApiRequestError(..)
+, PgError(..)
+, SimpleError(..)
+, errorPayload
+, checkIsFatal
 ) where

 import           Protolude
@@ -29,73 +27,41 @@ import           Network.Wai               (Response, responseLBS)
 import           PostgREST.Types
 import           Text.Read                 (readMaybe)

-apiRequestError :: ApiRequestError -> Response
-apiRequestError err =
-  errorResponse status
-    [toHeader CTApplicationJSON] err
-  where
-    status =
-      case err of
-        ActionInappropriate -> HT.status405
-        UnsupportedVerb -> HT.status405
-        InvalidBody _ -> HT.status400
-        ParseRequestError _ _ -> HT.status400
-        NoRelationBetween _ _ -> HT.status400
-        InvalidRange -> HT.status416
-        UnknownRelation -> HT.status404
-        InvalidFilters -> HT.status405

-simpleError :: HT.Status -> [Header] -> Text -> Response
-simpleError status hdrs message =
-  errorResponse status (toHeader CTApplicationJSON : hdrs) $
-    JSON.object ["message" .= message]
+class (JSON.ToJSON a) => PgrstError a where
+  status   :: a -> HT.Status
+  headers  :: a -> [Header]

-errorResponse :: JSON.ToJSON a => HT.Status -> [Header] -> a -> Response
-errorResponse status hdrs e =
-  responseLBS status hdrs $ encodeError e
+  errorPayload :: a -> LByteString
+  errorPayload = JSON.encode

-pgError :: Bool -> P.UsageError -> Response
-pgError authed e =
-  let status = httpStatus authed e
-      jsonType = toHeader CTApplicationJSON
-      wwwAuth = ("WWW-Authenticate", "Bearer")
-      hdrs = if status == HT.status401
-                then [jsonType, wwwAuth]
-                else [jsonType] in
-  responseLBS status hdrs (encodeError e)
-
-singularityError :: (Integral a, Show a) => a -> Response
-singularityError numRows =
-  responseLBS HT.status406
-    [toHeader CTSingularJSON]
-    $ toS . formatGeneralError
-      "JSON object requested, multiple (or no) rows returned"
-      $ unwords
-        [ "Results contain", show numRows, "rows,"
-        , toS (toMime CTSingularJSON), "requires 1 row"
-        ]
-  where
-    formatGeneralError :: Text -> Text -> Text
-    formatGeneralError message details = toS . JSON.encode $
-      JSON.object ["message" .= message, "details" .= details]
+  errorResponseFor :: a -> Response
+  errorResponseFor err = responseLBS (status err) (headers err) $ errorPayload err


-binaryFieldError :: Response
-binaryFieldError =
-  simpleError HT.status406 [] (toS (toMime CTOctetStream) <>
-  " requested but a single column was not selected")

-gucHeadersError :: Response
-gucHeadersError =
- simpleError HT.status500 []
- "response.headers guc must be a JSON array composed of objects with a single key and a string value"
+data ApiRequestError
+  = ActionInappropriate
+  | InvalidRange
+  | InvalidBody ByteString
+  | ParseRequestError Text Text
+  | NoRelationBetween Text Text
+  | InvalidFilters
+  | UnknownRelation                -- Unreachable?
+  | UnsupportedVerb                -- Unreachable?
+  deriving (Show, Eq)

-connectionLostError :: Response
-connectionLostError =
-  simpleError HT.status503 [] "Database connection lost, retrying the connection."
+instance PgrstError ApiRequestError where
+  status InvalidRange            = HT.status416
+  status InvalidFilters          = HT.status405
+  status (InvalidBody _)         = HT.status400
+  status UnsupportedVerb         = HT.status405
+  status UnknownRelation         = HT.status404
+  status ActionInappropriate     = HT.status405
+  status (ParseRequestError _ _) = HT.status400
+  status (NoRelationBetween _ _) = HT.status400

-encodeError :: JSON.ToJSON a => a -> LByteString
-encodeError = JSON.encode
+  headers _ = [toHeader CTApplicationJSON]

 instance JSON.ToJSON ApiRequestError where
  toJSON (ParseRequestError message details) = JSON.object [
@@ -115,9 +81,24 @@ instance JSON.ToJSON ApiRequestError where
  toJSON InvalidFilters = JSON.object [
    "message" .= ("Filters must include all and only primary key columns with 'eq' operators" :: Text)]

+
+data PgError = PgError Authenticated P.UsageError
+type Authenticated = Bool
+
+instance PgrstError PgError where
+  status (PgError authed usageError) = pgErrorStatus authed usageError
+
+  headers err =
+    if status err == HT.status401
+       then [toHeader CTApplicationJSON, ("WWW-Authenticate", "Bearer") :: Header]
+       else [toHeader CTApplicationJSON]
+
+instance JSON.ToJSON PgError where
+  toJSON (PgError _ usageError) = JSON.toJSON usageError
+
 instance JSON.ToJSON P.UsageError where
  toJSON (P.ConnectionError e) = JSON.object [
-    "code" .= ("" :: Text),
+    "code"    .= ("" :: Text),
    "message" .= ("Database connection error" :: Text),
    "details" .= (toS $ fromMaybe "" e :: Text)]
  toJSON (P.SessionError e) = JSON.toJSON e -- H.Error
@@ -127,69 +108,143 @@ instance JSON.ToJSON H.QueryError where

 instance JSON.ToJSON H.CommandError where
  toJSON (H.ResultError (H.ServerError c m d h)) = case toS c of
-    'P':'T':_ ->
-      JSON.object [
-        "details" .= (fmap toS d::Maybe Text),
-        "hint" .= (fmap toS h::Maybe Text)]
-    _ ->
-      JSON.object [
-        "code" .= (toS c::Text),
-        "message" .= (toS m::Text),
-        "details" .= (fmap toS d::Maybe Text),
-        "hint" .= (fmap toS h::Maybe Text)]
+    'P':'T':_ -> JSON.object [
+        "details" .= (fmap toS d :: Maybe Text),
+        "hint"    .= (fmap toS h :: Maybe Text)]
+
+    _         -> JSON.object [
+        "code"    .= (toS c      :: Text),
+        "message" .= (toS m      :: Text),
+        "details" .= (fmap toS d :: Maybe Text),
+        "hint"    .= (fmap toS h :: Maybe Text)]
+
  toJSON (H.ResultError (H.UnexpectedResult m)) = JSON.object [
-    "message" .= (m::Text)]
+    "message" .= (m :: Text)]
  toJSON (H.ResultError (H.RowError i H.EndOfInput)) = JSON.object [
-    "message" .= ("Row error: end of input"::Text),
-    "details" .=
-      ("Attempt to parse more columns than there are in the result"::Text),
-    "details" .= (("Row number " <> show i)::Text)]
+    "message" .= ("Row error: end of input" :: Text),
+    "details" .= ("Attempt to parse more columns than there are in the result" :: Text),
+    "hint"    .= (("Row number " <> show i) :: Text)]
  toJSON (H.ResultError (H.RowError i H.UnexpectedNull)) = JSON.object [
-    "message" .= ("Row error: unexpected null"::Text),
-    "details" .= ("Attempt to parse a NULL as some value."::Text),
-    "details" .= (("Row number " <> show i)::Text)]
+    "message" .= ("Row error: unexpected null" :: Text),
+    "details" .= ("Attempt to parse a NULL as some value." :: Text),
+    "hint"    .= (("Row number " <> show i) :: Text)]
  toJSON (H.ResultError (H.RowError i (H.ValueError d))) = JSON.object [
-    "message" .= ("Row error: Wrong value parser used"::Text),
+    "message" .= ("Row error: Wrong value parser used" :: Text),
    "details" .= d,
-    "details" .= (("Row number " <> show i)::Text)]
+    "hint"    .= (("Row number " <> show i) :: Text)]
  toJSON (H.ResultError (H.UnexpectedAmountOfRows i)) = JSON.object [
-    "message" .= ("Unexpected amount of rows"::Text),
+    "message" .= ("Unexpected amount of rows" :: Text),
    "details" .= i]
  toJSON (H.ClientError d) = JSON.object [
-    "message" .= ("Database client error"::Text),
-    "details" .= (fmap toS d::Maybe Text)]
+    "message" .= ("Database client error" :: Text),
+    "details" .= (fmap toS d :: Maybe Text)]

-httpStatus :: Bool -> P.UsageError -> HT.Status
-httpStatus _ (P.ConnectionError _) = HT.status503
-httpStatus authed (P.SessionError (H.QueryError _ _ (H.ResultError (H.ServerError c m _ _)))) =
-  case toS c of
-    '0':'8':_ -> HT.status503 -- pg connection err
-    '0':'9':_ -> HT.status500 -- triggered action exception
-    '0':'L':_ -> HT.status403 -- invalid grantor
-    '0':'P':_ -> HT.status403 -- invalid role specification
-    "23503"   -> HT.status409 -- foreign_key_violation
-    "23505"   -> HT.status409 -- unique_violation
-    '2':'5':_ -> HT.status500 -- invalid tx state
-    '2':'8':_ -> HT.status403 -- invalid auth specification
-    '2':'D':_ -> HT.status500 -- invalid tx termination
-    '3':'8':_ -> HT.status500 -- external routine exception
-    '3':'9':_ -> HT.status500 -- external routine invocation
-    '3':'B':_ -> HT.status500 -- savepoint exception
-    '4':'0':_ -> HT.status500 -- tx rollback
-    '5':'3':_ -> HT.status503 -- insufficient resources
-    '5':'4':_ -> HT.status413 -- too complex
-    '5':'5':_ -> HT.status500 -- obj not on prereq state
-    '5':'7':_ -> HT.status500 -- operator intervention
-    '5':'8':_ -> HT.status500 -- system error
-    'F':'0':_ -> HT.status500 -- conf file error
-    'H':'V':_ -> HT.status500 -- foreign data wrapper error
-    "P0001"   -> HT.status400 -- default code for "raise"
-    'P':'0':_ -> HT.status500 -- PL/pgSQL Error
-    'X':'X':_ -> HT.status500 -- internal Error
-    "42883"   -> HT.status404 -- undefined function
-    "42P01"   -> HT.status404 -- undefined table
-    "42501"   -> if authed then HT.status403 else HT.status401 -- insufficient privilege
-    'P':'T':n -> fromMaybe HT.status500 (HT.mkStatus <$> readMaybe n <*> pure m)
-    _         -> HT.status400
-httpStatus _ (P.SessionError (H.QueryError _ _ (H.ResultError _))) = HT.status500
-httpStatus _ (P.SessionError (H.QueryError _ _ (H.ClientError _))) = HT.status503
+pgErrorStatus :: Bool -> P.UsageError -> HT.Status
+pgErrorStatus _      (P.ConnectionError _)                                      = HT.status503
+pgErrorStatus _      (P.SessionError (H.QueryError _ _ (H.ClientError _)))      = HT.status503
+pgErrorStatus authed (P.SessionError (H.QueryError _ _ (H.ResultError rError))) =
+  case rError of
+    (H.ServerError c m _ _) ->
+      case toS c of
+        '0':'8':_ -> HT.status503 -- pg connection err
+        '0':'9':_ -> HT.status500 -- triggered action exception
+        '0':'L':_ -> HT.status403 -- invalid grantor
+        '0':'P':_ -> HT.status403 -- invalid role specification
+        "23503"   -> HT.status409 -- foreign_key_violation
+        "23505"   -> HT.status409 -- unique_violation
+        '2':'5':_ -> HT.status500 -- invalid tx state
+        '2':'8':_ -> HT.status403 -- invalid auth specification
+        '2':'D':_ -> HT.status500 -- invalid tx termination
+        '3':'8':_ -> HT.status500 -- external routine exception
+        '3':'9':_ -> HT.status500 -- external routine invocation
+        '3':'B':_ -> HT.status500 -- savepoint exception
+        '4':'0':_ -> HT.status500 -- tx rollback
+        '5':'3':_ -> HT.status503 -- insufficient resources
+        '5':'4':_ -> HT.status413 -- too complex
+        '5':'5':_ -> HT.status500 -- obj not on prereq state
+        '5':'7':_ -> HT.status500 -- operator intervention
+        '5':'8':_ -> HT.status500 -- system error
+        'F':'0':_ -> HT.status500 -- conf file error
+        'H':'V':_ -> HT.status500 -- foreign data wrapper error
+        "P0001"   -> HT.status400 -- default code for "raise"
+        'P':'0':_ -> HT.status500 -- PL/pgSQL Error
+        'X':'X':_ -> HT.status500 -- internal Error
+        "42883"   -> HT.status404 -- undefined function
+        "42P01"   -> HT.status404 -- undefined table
+        "42501"   -> if authed then HT.status403 else HT.status401 -- insufficient privilege
+        'P':'T':n -> fromMaybe HT.status500 (HT.mkStatus <$> readMaybe n <*> pure m)
+        _         -> HT.status400
+
+    _                       -> HT.status500
+
+checkIsFatal :: PgError -> Maybe Text
+checkIsFatal (PgError _ (P.ConnectionError e))
+  | isAuthFailureMessage = Just $ toS failureMessage
+  | otherwise = Nothing
+  where isAuthFailureMessage = "FATAL:  password authentication failed" `isPrefixOf` toS failureMessage
+        failureMessage = fromMaybe "" e
+checkIsFatal _ = Nothing
+
+
+data SimpleError
+  = GucHeadersError
+  | BinaryFieldError
+  | ConnectionLostError
+  | PutSingletonError
+  | PutMatchingPkError
+  | PutRangeNotAllowedError
+  | PutPayloadIncompleteError
+  | JwtTokenMissing
+  | JwtTokenInvalid Text
+  | SingularityError Integer
+  | ContentTypeError [ByteString]
+  deriving (Show, Eq)
+
+instance PgrstError SimpleError where
+  status GucHeadersError           = HT.status500
+  status BinaryFieldError          = HT.status406
+  status ConnectionLostError       = HT.status503
+  status PutSingletonError         = HT.status400
+  status PutMatchingPkError        = HT.status400
+  status PutRangeNotAllowedError   = HT.status400
+  status PutPayloadIncompleteError = HT.status400
+  status JwtTokenMissing           = HT.status500
+  status (JwtTokenInvalid _)       = HT.unauthorized401
+  status (SingularityError _)      = HT.status406
+  status (ContentTypeError _)      = HT.status415
+
+  headers (SingularityError _)     = [toHeader CTSingularJSON]
+  headers (JwtTokenInvalid m)      = [toHeader CTApplicationJSON, invalidTokenHeader m]
+  headers _                        = [toHeader CTApplicationJSON]
+
+instance JSON.ToJSON SimpleError where
+  toJSON GucHeadersError           = JSON.object [
+    "message" .= ("response.headers guc must be a JSON array composed of objects with a single key and a string value" :: Text)]
+  toJSON BinaryFieldError          = JSON.object [
+    "message" .= ((toS (toMime CTOctetStream) <> " requested but a single column was not selected") :: Text)]
+  toJSON ConnectionLostError       = JSON.object [
+    "message" .= ("Database connection lost, retrying the connection." :: Text)]
+
+  toJSON PutSingletonError         = JSON.object [
+    "message" .= ("PUT payload must contain a single row" :: Text)]
+  toJSON PutRangeNotAllowedError   = JSON.object [
+    "message" .= ("Range header and limit/offset querystring parameters are not allowed for PUT" :: Text)]
+  toJSON PutPayloadIncompleteError = JSON.object [
+    "message" .= ("You must specify all columns in the payload when using PUT" :: Text)]
+  toJSON PutMatchingPkError        = JSON.object [
+    "message" .= ("Payload values do not match URL in primary key column(s)" :: Text)]
+
+  toJSON (ContentTypeError cts)    = JSON.object [
+    "message" .= ("None of these Content-Types are available: " <> (toS . intercalate ", " . map toS) cts :: Text)]
+  toJSON (SingularityError n)      = JSON.object [
+    "message" .= ("JSON object requested, multiple (or no) rows returned" :: Text),
+    "details" .= unwords ["Results contain", show n, "rows,", toS (toMime CTSingularJSON), "requires 1 row"]]
+
+  toJSON JwtTokenMissing           = JSON.object [
+    "message" .= ("Server lacks JWT secret" :: Text)]
+  toJSON (JwtTokenInvalid message) = JSON.object [
+    "message" .= (message :: Text)]
+
+invalidTokenHeader :: Text -> Header
+invalidTokenHeader m =
+  ("WWW-Authenticate", "Bearer error=\"invalid_token\", " <> "error_description=" <> show m)
@@ -13,7 +13,6 @@ import qualified Data.Aeson                    as JSON
 import qualified Data.HashMap.Strict           as M
 import qualified Hasql.Transaction             as H

-import           Network.HTTP.Types.Status     (unauthorized401, status500)
 import           Network.Wai                   (Application, Response)
 import           Network.Wai.Middleware.Cors   (cors)
 import           Network.Wai.Middleware.Gzip   (def, gzip)
@@ -22,7 +21,7 @@ import           Network.Wai.Middleware.Static (only, staticPolicy)
 import           PostgREST.ApiRequest          (ApiRequest(..))
 import           PostgREST.Auth                (JWTAttempt(..))
 import           PostgREST.Config              (AppConfig (..), corsPolicy)
-import           PostgREST.Error               (simpleError)
+import           PostgREST.Error               (errorResponseFor, SimpleError(JwtTokenMissing, JwtTokenInvalid))
 import           PostgREST.QueryBuilder        (unquoted, pgFmtSetLocal, pgFmtSetLocalSearchPath)

 import           Protolude
@@ -32,10 +31,10 @@ runWithClaims :: AppConfig -> JWTAttempt ->
                 ApiRequest -> H.Transaction Response
 runWithClaims conf eClaims app req =
  case eClaims of
-    JWTInvalid JWTExpired -> return $ unauthed "JWT expired"
-    JWTInvalid e -> return $ unauthed $ show e
-    JWTMissingSecret -> return $ simpleError status500 [] "Server lacks JWT secret"
-    JWTClaims claims -> do
+    JWTMissingSecret      -> return . errorResponseFor $ JwtTokenMissing
+    JWTInvalid JWTExpired -> return . errorResponseFor . JwtTokenInvalid $ "JWT expired"
+    JWTInvalid e          -> return . errorResponseFor . JwtTokenInvalid . show $ e
+    JWTClaims claims      -> do
      H.sql $ toS . mconcat $ setSearchPathSql : setRoleSql ++ claimsSql ++ headersSql ++ cookiesSql ++ appSettingsSql
      mapM_ H.sql customReqCheck
      app req
@@ -51,14 +50,6 @@ runWithClaims conf eClaims app req =
        claimsWithRole = M.union claims (M.singleton "role" anon)
        anon = JSON.String . toS $ configAnonRole conf
        customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf
-  where
-    unauthed message = simpleError
-      unauthorized401
-      [( "WWW-Authenticate"
-        , "Bearer error=\"invalid_token\", " <>
-          "error_description=" <> show message
-      )]
-      message

 defaultMiddle :: Application -> Application
 defaultMiddle =
@@ -17,6 +17,7 @@ import qualified Data.Set                      as S
 import           Data.Tree
 import           Data.Either.Combinators       (mapLeft)
 import           PostgREST.RangeQuery          (NonnegRange)
+import           PostgREST.Error               (ApiRequestError(ParseRequestError))
 import           PostgREST.Types
 import           Text.ParserCombinators.Parsec hiding (many, (<|>))
 import           Text.Parsec.Error
@@ -3,7 +3,9 @@ Module      : PostgREST.Types
 Description : PostgREST common types and functions used by the rest of the modules
 -}
 {-# LANGUAGE DuplicateRecordFields    #-}
+
 module PostgREST.Types where
+
 import           Protolude
 import qualified GHC.Show
 import qualified Data.Aeson           as JSON
@@ -34,16 +36,6 @@ toMime CTOctetStream     = "application/octet-stream"
 toMime CTAny             = "*/*"
 toMime (CTOther ct)      = ct

-data ApiRequestError = ActionInappropriate
-                     | InvalidBody ByteString
-                     | InvalidRange
-                     | ParseRequestError Text Text
-                     | UnknownRelation
-                     | NoRelationBetween Text Text
-                     | UnsupportedVerb
-                     | InvalidFilters
-                     deriving (Show, Eq)
-
 data PreferResolution = MergeDuplicates | IgnoreDuplicates deriving Eq
 instance Show PreferResolution where
  show MergeDuplicates  = "resolution=merge-duplicates"
@@ -413,3 +405,12 @@ sourceCTEName = "pg_source"
 type JSPath = [JSPathExp]
 -- | jspath expression, e.g. .property, .property[0] or ."property-dash"
 data JSPathExp = JSPKey Text | JSPIdx Int deriving (Eq, Show)
+
+
+
+-- | Current database connection status data ConnectionStatus
+data ConnectionStatus 
+  = NotConnected
+  | Connected PgVersion
+  | FatalConnectionError Text
+  deriving (Eq, Show)