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
@@ -11,6 +11,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 - #1239, Add support for resource embedding on materialized views - @vitorbaptista
 - #1264, Add support for bulk RPC call - @steve-chavez
 - #1278, Add db-pool-timeout config option - @qu4tro
+- #1285, Abort on wrong database password - @qu4tro

 ### Fixed

@@ -7,9 +7,9 @@ import           PostgREST.App              (postgrest)
 import           PostgREST.Config           (AppConfig (..), configPoolTimeout',
                                             prettyVersion, readOptions)
 import           PostgREST.DbStructure      (getDbStructure, getPgVersion)
-import           PostgREST.Error            (encodeError)
+import           PostgREST.Error            (errorPayload, checkIsFatal, PgError(PgError))
 import           PostgREST.OpenAPI          (isMalformedProxyUri)
-import           PostgREST.Types            (DbStructure, Schema, PgVersion(..), minimumPgVersion)
+import           PostgREST.Types            (DbStructure, Schema, PgVersion(..), minimumPgVersion, ConnectionStatus(..))
 import           Protolude                  hiding (hPutStrLn, replace)


@@ -28,7 +28,6 @@ import           Data.Text.Encoding         (decodeUtf8, encodeUtf8)
 import           Data.Text.IO               (hPutStrLn, readFile)
 import           Data.Time.Clock            (getCurrentTime)
 import qualified Hasql.Pool                 as P
-import qualified Hasql.Session              as H
 import qualified Hasql.Transaction.Sessions as HT
 import           Network.Wai.Handler.Warp   (defaultSettings,
                                             runSettings, setHost,
@@ -74,25 +73,24 @@ connectionWorker mainTid pool schema refDbStructure refIsWorkerOn = do
    work = do
      atomicWriteIORef refDbStructure Nothing
      putStrLn ("Attempting to connect to the database..." :: Text)
-      connected <- connectingSucceeded pool
-      when connected $ do
-        result <- P.use pool $ do
-          actualPgVersion <- getPgVersion
-          unless (actualPgVersion >= minimumPgVersion) $ liftIO $ do
-            hPutStrLn stderr
-              ("Cannot run in this PostgreSQL version, PostgREST needs at least "
-              <> pgvName minimumPgVersion)
-            killThread mainTid
-          dbStructure <- HT.transaction HT.ReadCommitted HT.Read $ getDbStructure schema actualPgVersion
-          liftIO $ atomicWriteIORef refDbStructure $ Just dbStructure
-        case result of
-          Left e -> do
-            putStrLn ("Failed to query the database. Retrying." :: Text)
-            hPutStrLn stderr (toS $ encodeError e)
-            work
-          Right _ -> do
-            atomicWriteIORef refIsWorkerOn False
-            putStrLn ("Connection successful" :: Text)
+      connected <- connectionStatus pool
+      case connected of
+        FatalConnectionError reason -> hPutStrLn stderr reason 
+                                      >> killThread mainTid    -- Fatal error when connecting
+        NotConnected                -> return ()               -- Unreachable
+        Connected actualPgVersion   -> do                      -- Procede with initialization
+          result <- P.use pool $ do
+            dbStructure <- HT.transaction HT.ReadCommitted HT.Read $ getDbStructure schema actualPgVersion
+            liftIO $ atomicWriteIORef refDbStructure $ Just dbStructure
+          case result of
+            Left e -> do
+              putStrLn ("Failed to query the database. Retrying." :: Text)
+              hPutStrLn stderr . toS . errorPayload $ PgError False e
+              work
+              
+            Right _ -> do
+              atomicWriteIORef refIsWorkerOn False
+              putStrLn ("Connection successful" :: Text)

 {-|
  Used by 'connectionWorker' to check if the provided db-uri lets
@@ -103,26 +101,37 @@ connectionWorker mainTid pool schema refDbStructure refIsWorkerOn = do
  The connection tries are capped, but if the connection times out no error is
  thrown, just 'False' is returned.
 -}
-connectingSucceeded :: P.Pool -> IO Bool
-connectingSucceeded pool =
+connectionStatus :: P.Pool -> IO ConnectionStatus
+connectionStatus pool =
  retrying (capDelay 32000000 $ exponentialBackoff 1000000)
           shouldRetry
-           (const $ P.release pool >> isConnectionSuccessful)
+           (const $ P.release pool >> getConnectionStatus)
  where
-    isConnectionSuccessful :: IO Bool
-    isConnectionSuccessful = do
-      testConn <- P.use pool $ H.sql "SELECT 1"
-      case testConn of
-        Left e -> hPutStrLn stderr (toS $ encodeError e) >> pure False
-        _ -> pure True
-    shouldRetry :: RetryStatus -> Bool -> IO Bool
+    getConnectionStatus :: IO ConnectionStatus
+    getConnectionStatus = do
+      pgVersion <- P.use pool getPgVersion
+      case pgVersion of
+        Left e -> do
+          let err = PgError False e
+          hPutStrLn stderr . toS $ errorPayload err
+          case checkIsFatal err of
+            Just reason -> return $ FatalConnectionError reason
+            Nothing     -> return NotConnected
+
+        Right version ->
+          if version < minimumPgVersion
+             then return . FatalConnectionError $ "Cannot run in this PostgreSQL version, PostgREST needs at least " <> pgvName minimumPgVersion
+             else return . Connected  $ version
+
+    shouldRetry :: RetryStatus -> ConnectionStatus -> IO Bool
    shouldRetry rs isConnSucc = do
      delay <- pure $ fromMaybe 0 (rsPreviousDelay rs) `div` 1000000
-      itShould <- pure $ not isConnSucc
+      itShould <- pure $ NotConnected == isConnSucc
      when itShould $
        putStrLn $ "Attempting to reconnect to the database in " <> (show delay::Text) <> " seconds..."
      return itShould

+
 {-|
  This is where everything starts.
 -}
@@ -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)
@@ -53,9 +53,22 @@ spec actualPgVersion = do

    context "non uniform json array" $ do
      it "rejects json array that isn't exclusivily composed of objects" $
-        post "/articles" [json| [{"id": 100, "body": "xxxxx"}, 123, "xxxx", {"id": 111, "body": "xxxx"}] |] `shouldRespondWith` 400
+        post "/articles"
+             [json| [{"id": 100, "body": "xxxxx"}, 123, "xxxx", {"id": 111, "body": "xxxx"}] |]
+        `shouldRespondWith`
+             [json| {"message":"All object keys must match"} |]
+             { matchStatus  = 400
+             , matchHeaders = [matchContentTypeJson]
+             }
+
      it "rejects json array that has objects with different keys" $
-        post "/articles" [json| [{"id": 100, "body": "xxxxx"}, {"id": 111, "body": "xxxx", "owner": "me"}] |] `shouldRespondWith` 400
+        post "/articles"
+             [json| [{"id": 100, "body": "xxxxx"}, {"id": 111, "body": "xxxx", "owner": "me"}] |]
+        `shouldRespondWith`
+             [json| {"message":"All object keys must match"} |]
+             { matchStatus  = 400
+             , matchHeaders = [matchContentTypeJson]
+             }

    context "requesting full representation" $ do
      it "includes related data after insert" $
@@ -105,11 +118,13 @@ spec actualPgVersion = do
            incNullableStr record `shouldBe` Nothing

      context "into a table with simple pk" $
-        it "fails with 400 and error" $ do
-          p <- post "/simple_pk" [json| { "extra":"foo"} |]
-          liftIO $ do
-            simpleStatus p `shouldBe` badRequest400
-            isErrorFormat (simpleBody p) `shouldBe` True
+        it "fails with 400 and error" $
+          post "/simple_pk" [json| { "extra":"foo"} |]
+          `shouldRespondWith`
+          [json|{"hint":null,"details":"Failing row contains (null, foo).","code":"23502","message":"null value in column \"k\" violates not-null constraint"}|]
+          { matchStatus  = 400
+          , matchHeaders = [matchContentTypeJson]
+          }

      context "into a table with no pk" $ do
        it "succeeds with 201 and a link including all fields" $ do
@@ -183,11 +198,13 @@ spec actualPgVersion = do
          lookup hLocation (simpleHeaders p) `shouldBe` Nothing

    context "with invalid json payload" $
-      it "fails with 400 and error" $ do
-        p <- post "/simple_pk" "}{ x = 2"
-        liftIO $ do
-          simpleStatus p `shouldBe` badRequest400
-          isErrorFormat (simpleBody p) `shouldBe` True
+      it "fails with 400 and error" $
+        post "/simple_pk" "}{ x = 2"
+        `shouldRespondWith`
+        [json|{"message":"Error in $: Failed reading: not a valid json value"}|]
+        { matchStatus  = 400
+        , matchHeaders = [matchContentTypeJson]
+        }

    context "with valid json payload" $
      it "succeeds and returns 201 created" $
@@ -195,7 +212,12 @@ spec actualPgVersion = do

    context "attempting to insert a row with the same primary key" $
      it "fails returning a 409 Conflict" $
-        post "/simple_pk" [json| { "k":"k1", "extra":"e1" } |] `shouldRespondWith` 409
+        post "/simple_pk" [json| { "k":"k1", "extra":"e1" } |]
+          `shouldRespondWith`
+          [json|{"hint":null,"details":"Key (k)=(k1) already exists.","code":"23505","message":"duplicate key value violates unique constraint \"contacts_pkey\""}|]
+          { matchStatus  = 409
+          , matchHeaders = [matchContentTypeJson]
+          }

    context "attempting to insert a row with conflicting unique constraint" $
      it "fails returning a 409 Conflict" $
@@ -295,7 +317,12 @@ spec actualPgVersion = do
        post "/articles?columns="
          [json|[
            {"id": 204, "body": "yyy"},
-            {"id": 205, "body": "zzz"}]|] `shouldRespondWith` 400
+            {"id": 205, "body": "zzz"}]|]
+          `shouldRespondWith`
+          [json|  {"details":"unexpected end of input expecting field name (* or [a..z0..9_])","message":"\"failed to parse columns parameter ()\" (line 1, column 1)"} |]
+          { matchStatus  = 400
+          , matchHeaders = []
+          }

      it "disallows array elements that are not json objects" $
        post "/articles?columns=id,body"
@@ -314,7 +341,6 @@ spec actualPgVersion = do
          }

  describe "CSV insert" $ do
-
    context "disparate csv types" $
      it "succeeds with multipart response" $ do
        pendingWith "Decide on what to do with CSV insert"
@@ -361,11 +387,13 @@ spec actualPgVersion = do
          }

    context "with wrong number of columns" $
-      it "fails for too few" $ do
-        p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz"
-        liftIO $ do
-          simpleStatus p `shouldBe` badRequest400
-          isErrorFormat (simpleBody p) `shouldBe` True
+      it "fails for too few" $
+        request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz"
+        `shouldRespondWith`
+        [json|{"message":"All lines must have same number of fields"}|]
+        { matchStatus  = 400
+        , matchHeaders = [matchContentTypeJson]
+        }

    context "with unicode values" $
      it "succeeds and returns usable location header" $ do
@@ -381,9 +409,7 @@ spec actualPgVersion = do
        r <- get location
        liftIO $ simpleBody r `shouldBe` "["<>payload<>"]"

-
  describe "Patching record" $ do
-
    context "to unknown uri" $
      it "indicates no table found by returning 404" $
        request methodPatch "/fake" []
@@ -3,6 +3,7 @@ module Feature.NoJwtSpec where
 -- {{{ Imports
 import Test.Hspec
 import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
 import Network.HTTP.Types

 import SpecHelper
@@ -18,7 +19,11 @@ spec = describe "server started without JWT secret" $ do
  it "responds with error on attempted auth" $ do
    let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJleHAiOjk5OTk5OTk5OTksInJvbGUiOiJwb3N0Z3Jlc3RfdGVzdF9hdXRob3IiLCJpZCI6Impkb2UifQ.Dpss-QoLYjec5OTsOaAc3FNVsSjA89wACoV-0ra3ClA"
    request methodGet "/authors_only" [auth] ""
-      `shouldRespondWith` 500
+      `shouldRespondWith`
+      [json|{"message":"Server lacks JWT secret"}|]
+      { matchStatus  = 500
+      , matchHeaders = [ matchContentTypeJson ]
+      }

  it "behaves normally when user does not attempt auth" $
    request methodGet "/items" [] ""
@@ -34,10 +34,30 @@ spec =
              "X-Test-2" <:> "key1=val1"]}

      it "fails when setting headers with wrong json structure" $ do
-        get "/rpc/bad_guc_headers_1" `shouldRespondWith` 500
-        get "/rpc/bad_guc_headers_2" `shouldRespondWith` 500
-        get "/rpc/bad_guc_headers_3" `shouldRespondWith` 500
-        post "/rpc/bad_guc_headers_1" [json|{}|] `shouldRespondWith` 500
+        get "/rpc/bad_guc_headers_1"
+          `shouldRespondWith`
+          [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|]
+          { matchStatus  = 500
+          , matchHeaders = [ matchContentTypeJson ]
+          }
+        get "/rpc/bad_guc_headers_2"
+          `shouldRespondWith`
+          [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|]
+          { matchStatus  = 500
+          , matchHeaders = [ matchContentTypeJson ]
+          }
+        get "/rpc/bad_guc_headers_3"
+          `shouldRespondWith`
+          [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|]
+          { matchStatus  = 500
+          , matchHeaders = [ matchContentTypeJson ]
+          }
+        post "/rpc/bad_guc_headers_1" [json|{}|]
+          `shouldRespondWith`
+          [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|]
+          { matchStatus  = 500
+          , matchHeaders = [ matchContentTypeJson ]
+          }

      it "can set the same http header twice" $
        get "/rpc/set_cookie_twice"
@@ -181,7 +181,6 @@ spec = do
        { matchHeaders = [matchContentTypeJson] }

  describe "Shaping response with select parameter" $ do
-
    it "selectStar works in absense of parameter" $
      get "/complex_items?id=eq.3" `shouldRespondWith`
        [str|[{"id":3,"name":"Three","settings":{"foo":{"int":1,"bar":"baz"}},"arr_data":[1,2,3],"field-with_sep":1}]|]
@@ -455,6 +454,12 @@ spec = do
             {"id":3,"body":"How are you doing?","sender":{"name":"John"},"recipient":{"name":"Jane"}}] |]
          { matchHeaders = [matchContentTypeJson] }

+      it "fails with an unknown relation" $
+        get "/message?select=id,sender:person.space(name)&id=lt.4" `shouldRespondWith`
+          [json|{"message":"Could not find foreign keys between these entities, No relation found between message and person"}|]
+          { matchStatus = 400
+          , matchHeaders = [matchContentTypeJson] }
+
      it "works with a parent view relation" $
        get "/message?select=id,body,sender:person_detail%2Bsender(name,sent),recipient:person_detail%2Brecipient(name,received)&id=lt.4" `shouldRespondWith`
          [json|
@@ -790,7 +795,11 @@ spec = do
    it "should respond an unknown accept type with 415" $
      request methodGet "/simple_pk"
              (acceptHdrs "text/unknowntype") ""
-        `shouldRespondWith` 415
+        `shouldRespondWith`
+        [json|{"message":"None of these Content-Types are available: text/unknowntype"}|]
+        { matchStatus  = 415
+        , matchHeaders = [matchContentTypeJson]
+        }

    it "should respond correctly to */* in accept header" $
      request methodGet "/simple_pk"
@@ -846,7 +855,6 @@ spec = do
        respHeaders `shouldSatisfy` matchHeader
          "Content-Location" "/simple_pk"

-
  describe "weird requests" $ do
    it "can query as normal" $ do
      get "/Escap3e;" `shouldRespondWith`
@@ -897,7 +905,11 @@ spec = do

      it "fails if a single column is not selected" $ do
        request methodGet "/images?select=img,name&name=eq.A.png" (acceptHdrs "application/octet-stream") ""
-          `shouldRespondWith` 406
+          `shouldRespondWith`
+          [json| {"message":"application/octet-stream requested but a single column was not selected"} |]
+          { matchStatus = 406
+          , matchHeaders = [matchContentTypeJson]
+          }
        request methodGet "/images?select=*&name=eq.A.png" (acceptHdrs "application/octet-stream") ""
          `shouldRespondWith` 406
        request methodGet "/images?name=eq.A.png" (acceptHdrs "application/octet-stream") ""
@@ -929,7 +941,11 @@ spec = do

        it "fails if a single column is not selected" $
          request methodPost "/rpc/ret_rows_with_base64_bin" (acceptHdrs "application/octet-stream") ""
-            `shouldRespondWith` 406
+            `shouldRespondWith`
+            [json| {"message":"application/octet-stream requested but a single column was not selected"} |]
+            { matchStatus = 406
+            , matchHeaders = [matchContentTypeJson]
+            }

  describe "HTTP request env vars" $ do
    it "custom header is set" $
@@ -1047,7 +1063,12 @@ spec = do
        [json| [] |] { matchHeaders = [matchContentTypeJson] }

    it "only returns an empty result set if the in value is empty" $
-      get "/items_with_different_col_types?int_data=in.( ,3,4)" `shouldRespondWith` 400
+      get "/items_with_different_col_types?int_data=in.( ,3,4)"
+        `shouldRespondWith`
+        [json| {"hint":null,"details":null,"code":"22P02","message":"invalid input syntax for integer: \"\""} |]
+        { matchStatus = 400
+        , matchHeaders = [matchContentTypeJson]
+        }

  describe "Embedding when column name = table name" $ do
    it "works with child embeds" $
@@ -38,7 +38,6 @@ spec = do
            { matchHeaders = ["Content-Range" <:> "0-14/*"] }

    context "with range headers" $ do
-
      context "of acceptable range" $ do
        it "succeeds with partial content" $ do
          r <- request methodPost  "/rpc/getitemrange"
@@ -156,7 +155,6 @@ spec = do
          , matchHeaders = ["Content-Range" <:> "0-0/*"]
          }

-
      it "limit and offset works on first level" $
        get "/items?select=id&order=id.asc&limit=3&offset=2"
          `shouldRespondWith` [json|[{"id":3},{"id":4},{"id":5}]|]
@@ -164,8 +162,37 @@ spec = do
          , matchHeaders = ["Content-Range" <:> "2-4/*"]
          }

-    context "with range headers" $ do
+      it "succeeds if offset equals 0 as a no-op" $
+        get "/items?select=id&offset=0"
+          `shouldRespondWith`
+          [json|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|]
+          { matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "0-14/*"]
+          }

+      it "succeeds if offset is negative as a no-op" $
+        get "/items?select=id&offset=-4"
+          `shouldRespondWith`
+          [json|[{"id":1},{"id":2},{"id":3},{"id":4},{"id":5},{"id":6},{"id":7},{"id":8},{"id":9},{"id":10},{"id":11},{"id":12},{"id":13},{"id":14},{"id":15}]|]
+          { matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "0-14/*"]
+          }
+
+      it "fails if limit equals 0" $
+        get "/items?select=id&limit=0"
+          `shouldRespondWith` [json|{"message":"HTTP Range error"}|]
+          { matchStatus  = 416
+          , matchHeaders = [matchContentTypeJson]
+          }
+
+      it "fails if limit is negative" $
+        get "/items?select=id&limit=-1"
+          `shouldRespondWith` [json|{"message":"HTTP Range error"}|]
+          { matchStatus  = 416
+          , matchHeaders = [matchContentTypeJson]
+          }
+
+    context "with range headers" $ do
      context "of acceptable range" $ do
        it "succeeds with partial content" $ do
          r <- request methodGet  "/items"
@@ -253,7 +253,11 @@ spec actualPgVersion =
    context "unsupported verbs" $ do
      it "DELETE fails" $
        request methodDelete "/rpc/sayhello" [] ""
-          `shouldRespondWith` 405
+          `shouldRespondWith`
+          [json|{"message":"Bad Request"}|]
+          { matchStatus  = 405
+          , matchHeaders = [matchContentTypeJson]
+          }
      it "PATCH fails" $
        request methodPatch "/rpc/sayhello" [] ""
          `shouldRespondWith` 405
@@ -319,7 +323,12 @@ spec actualPgVersion =
        }

    it "defaults to status 500 if RAISE code is PT not followed by a number" $
-      get "/rpc/raise_bad_pt" `shouldRespondWith` 500
+      get "/rpc/raise_bad_pt"
+        `shouldRespondWith`
+        [json|{"hint": null, "details": null}|]
+        { matchStatus  = 500
+        , matchHeaders = [ matchContentTypeJson ]
+        }

    context "expects a single json object" $ do
      it "does not expand posted json into parameters" $
@@ -110,48 +110,96 @@ spec =
      context "Restrictions" $ do
        it "fails if Range is specified" $
          request methodPut "/tiobe_pls?name=eq.Javascript" [("Range", "0-5")]
-            [str| [ { "name": "Javascript", "rank": 1 } ]|] `shouldRespondWith` 400
+            [str| [ { "name": "Javascript", "rank": 1 } ]|]
+            `shouldRespondWith`
+            [json|{"message":"Range header and limit/offset querystring parameters are not allowed for PUT"}|]
+            { matchStatus = 400 , matchHeaders = [matchContentTypeJson] }

        it "fails if limit is specified" $
          put "/tiobe_pls?name=eq.Javascript&limit=1"
-            [str| [ { "name": "Javascript", "rank": 1 } ]|] `shouldRespondWith` 400
+            [str| [ { "name": "Javascript", "rank": 1 } ]|]
+            `shouldRespondWith`
+            [json|{"message":"Range header and limit/offset querystring parameters are not allowed for PUT"}|]
+            { matchStatus = 400 , matchHeaders = [matchContentTypeJson] }

        it "fails if offset is specified" $
          put "/tiobe_pls?name=eq.Javascript&offset=1"
-            [str| [ { "name": "Javascript", "rank": 1 } ]|] `shouldRespondWith` 400
+            [str| [ { "name": "Javascript", "rank": 1 } ]|]
+            `shouldRespondWith`
+            [json|{"message":"Range header and limit/offset querystring parameters are not allowed for PUT"}|]
+            { matchStatus = 400 , matchHeaders = [matchContentTypeJson] }

        it "fails if the payload has more than one row" $
          put "/tiobe_pls?name=eq.Go"
-            [str| [ { "name": "Go", "rank": 19 }, { "name": "Swift", "rank": 12 } ]|] `shouldRespondWith` 400
+            [str| [ { "name": "Go", "rank": 19 }, { "name": "Swift", "rank": 12 } ]|]
+            `shouldRespondWith`
+            [json|{"message":"PUT payload must contain a single row"}|]
+            { matchStatus = 400 , matchHeaders = [matchContentTypeJson] }

        it "fails if not all columns are specified" $ do
          put "/tiobe_pls?name=eq.Go"
-            [str| [ { "name": "Go" } ]|] `shouldRespondWith` 400
+            [str| [ { "name": "Go" } ]|]
+            `shouldRespondWith`
+            [json|{"message":"You must specify all columns in the payload when using PUT"}|]
+            { matchStatus = 400 , matchHeaders = [matchContentTypeJson] }
+
          put "/employees?first_name=eq.Susan&last_name=eq.Heidt"
-            [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000" } ]|] `shouldRespondWith` 400
+            [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000" } ]|]
+            `shouldRespondWith`
+            [json|{"message":"You must specify all columns in the payload when using PUT"}|]
+            { matchStatus = 400 , matchHeaders = [matchContentTypeJson] }

        it "rejects every other filter than pk cols eq's" $ do
-          put "/tiobe_pls?rank=eq.19" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405
-          put "/tiobe_pls?id=not.eq.Java" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405
-          put "/tiobe_pls?id=in.(Go)" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405
-          put "/tiobe_pls?and=(id.eq.Go)" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405
+          put "/tiobe_pls?rank=eq.19"
+            [str| [ { "name": "Go", "rank": 19 } ]|]
+            `shouldRespondWith`
+            [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]
+            { matchStatus = 405 , matchHeaders = [matchContentTypeJson] }
+
+          put "/tiobe_pls?id=not.eq.Java"
+            [str| [ { "name": "Go", "rank": 19 } ]|]
+            `shouldRespondWith`
+            [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]
+            { matchStatus = 405 , matchHeaders = [matchContentTypeJson] }
+          put "/tiobe_pls?id=in.(Go)"
+            [str| [ { "name": "Go", "rank": 19 } ]|]
+            `shouldRespondWith`
+            [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]
+            { matchStatus = 405 , matchHeaders = [matchContentTypeJson] }
+          put "/tiobe_pls?and=(id.eq.Go)"
+            [str| [ { "name": "Go", "rank": 19 } ]|]
+            `shouldRespondWith`
+            [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]
+            { matchStatus = 405 , matchHeaders = [matchContentTypeJson] }

        it "fails if not all composite key cols are specified as eq filters" $ do
          put "/employees?first_name=eq.Susan"
            [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]
-            `shouldRespondWith` 405
+            `shouldRespondWith`
+            [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]
+            { matchStatus = 405 , matchHeaders = [matchContentTypeJson] }
          put "/employees?last_name=eq.Heidt"
            [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]
-            `shouldRespondWith` 405
+            `shouldRespondWith`
+            [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]
+            { matchStatus = 405 , matchHeaders = [matchContentTypeJson] }

      it "fails if the uri primary key doesn't match the payload primary key" $ do
-        put "/tiobe_pls?name=eq.MATLAB"
-          [str| [ { "name": "Perl", "rank": 17 } ]|] `shouldRespondWith` 400
+        put "/tiobe_pls?name=eq.MATLAB" [str| [ { "name": "Perl", "rank": 17 } ]|]
+          `shouldRespondWith`
+          [json|{"message":"Payload values do not match URL in primary key column(s)"}|]
+          { matchStatus = 400 , matchHeaders = [matchContentTypeJson] }
        put "/employees?first_name=eq.Wendy&last_name=eq.Anderson"
-          [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|] `shouldRespondWith` 400
+          [str| [ { "first_name": "Susan", "last_name": "Heidt", "salary": "48000", "company": "GEX", "occupation": "Railroad engineer" } ]|]
+          `shouldRespondWith`
+          [json|{"message":"Payload values do not match URL in primary key column(s)"}|]
+          { matchStatus = 400 , matchHeaders = [matchContentTypeJson] }

      it "fails if the table has no PK" $
-        put "/no_pk?a=eq.one&b=eq.two" [str| [ { "a": "one", "b": "two" } ]|] `shouldRespondWith` 405
+        put "/no_pk?a=eq.one&b=eq.two" [str| [ { "a": "one", "b": "two" } ]|]
+          `shouldRespondWith`
+          [json|{"message":"Filters must include all and only primary key columns with 'eq' operators"}|]
+          { matchStatus = 405 , matchHeaders = [matchContentTypeJson] }

      context "Inserting row" $ do
        it "succeeds on table with single pk col" $ do