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

CHANGELOG.md

@@ -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
 

main/Main.hs

@@ -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
+      connected <- connectionStatus pool
-      when connected $ do
+      case connected of
-        result <- P.use pool $ do
+        FatalConnectionError reason -> hPutStrLn stderr reason 
-          actualPgVersion <- getPgVersion
+                                      >> killThread mainTid    -- Fatal error when connecting
-          unless (actualPgVersion >= minimumPgVersion) $ liftIO $ do
+        NotConnected                -> return ()               -- Unreachable
-            hPutStrLn stderr
+        Connected actualPgVersion   -> do                      -- Procede with initialization
-              ("Cannot run in this PostgreSQL version, PostgREST needs at least "
+          result <- P.use pool $ do
-              <> pgvName minimumPgVersion)
+            dbStructure <- HT.transaction HT.ReadCommitted HT.Read $ getDbStructure schema actualPgVersion
-            killThread mainTid
+            liftIO $ atomicWriteIORef refDbStructure $ Just dbStructure
-          dbStructure <- HT.transaction HT.ReadCommitted HT.Read $ getDbStructure schema actualPgVersion
+          case result of
-          liftIO $ atomicWriteIORef refDbStructure $ Just dbStructure
+            Left e -> do
-        case result of
+              putStrLn ("Failed to query the database. Retrying." :: Text)
-          Left e -> do
+              hPutStrLn stderr . toS . errorPayload $ PgError False e
-            putStrLn ("Failed to query the database. Retrying." :: Text)
+              work
-            hPutStrLn stderr (toS $ encodeError e)
+              
-            work
+            Right _ -> do
-          Right _ -> do
+              atomicWriteIORef refIsWorkerOn False
-            atomicWriteIORef refIsWorkerOn False
+              putStrLn ("Connection successful" :: Text)
-            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
+connectionStatus :: P.Pool -> IO ConnectionStatus
-connectingSucceeded pool =
+connectionStatus pool =
   retrying (capDelay 32000000 $ exponentialBackoff 1000000)
            shouldRetry
-           (const $ P.release pool >> isConnectionSuccessful)
+           (const $ P.release pool >> getConnectionStatus)
   where
-    isConnectionSuccessful :: IO Bool
+    getConnectionStatus :: IO ConnectionStatus
-    isConnectionSuccessful = do
+    getConnectionStatus = do
-      testConn <- P.use pool $ H.sql "SELECT 1"
+      pgVersion <- P.use pool getPgVersion
-      case testConn of
+      case pgVersion of
-        Left e -> hPutStrLn stderr (toS $ encodeError e) >> pure False
+        Left e -> do
-        _ -> pure True
+          let err = PgError False e
-    shouldRetry :: RetryStatus -> Bool -> IO Bool
+          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.
 -}

src/PostgREST/ApiRequest.hs

@@ -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(..)
+{-# LANGUAGE LambdaCase #-}
-                            , ContentType(..)
+
-                            , Action(..)
+module PostgREST.ApiRequest ( 
-                            , Target(..)
+  ApiRequest(..)
-                            , PreferRepresentation (..)
+, ContentType(..)
-                            , mutuallyAgreeable
+, Action(..)
-                            , userApiRequest
+, Target(..)
-                            ) where
+, 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)

src/PostgREST/App.hs

@@ -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
+import           PostgREST.Error           ( SimpleError(..), PgError(..)
-                                           , apiRequestError
+                                           , errorResponseFor
-                                           , singularityError, binaryFieldError
-                                           , connectionLostError, gucHeadersError
                                            )
 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
+        Nothing -> Left . errorResponseFor . ContentTypeError . map toMime $ cAccepts
-          let failed = intercalate ", " $ map (toS . toMime) cAccepts
-          Left $ simpleError status415 [] $
-            "None of these Content-Types are available: " <> failed
         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

src/PostgREST/Config.hs

@@ -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(..),
+import           PostgREST.Types              (JSPath, JSPathExp(..))
-                                               JSPath, JSPathExp(..))
+import           PostgREST.Error              (ApiRequestError(..))
 import           Protolude                    hiding (hPutStrLn, take,
                                                intercalate, (<>))
 import           System.IO                    (hPrint)

src/PostgREST/DbRequestBuilder.hs

@@ -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(..)
+import           PostgREST.ApiRequest      ( ApiRequest(..)
-                                        , PreferRepresentation(..)
+                                           , PreferRepresentation(..)
-                                        , Action(..), Target(..)
+                                           , Action(..), Target(..)
-                                        , PreferRepresentation (..)
+                                           , PreferRepresentation (..)
-                                        )
+                                           )
-import           PostgREST.Error           (apiRequestError)
+import           PostgREST.Error           (ApiRequestError(..), errorResponseFor)
 import           PostgREST.Parsers
 import           PostgREST.RangeQuery      (NonnegRange, restrictRange, allRange)
 import           PostgREST.Types
 
-import           Protolude                hiding (from)
+import           Protolude                 hiding (from)
-import           Text.Regex.TDFA         ((=~))
+import           Text.Regex.TDFA           ((=~))
-import           Unsafe                  (unsafeHead)
+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

src/PostgREST/Error.hs

@@ -7,14 +7,12 @@ Description : PostgREST error HTTP responses
 {-# LANGUAGE TypeSynonymInstances #-}
 
 module PostgREST.Error (
-  apiRequestError
+  errorResponseFor
-, pgError
+, ApiRequestError(..)
-, simpleError
+, PgError(..)
-, singularityError
+, SimpleError(..)
-, binaryFieldError
+, errorPayload
-, connectionLostError
+, checkIsFatal
-, encodeError
-, gucHeadersError
 ) 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
+class (JSON.ToJSON a) => PgrstError a where
-simpleError status hdrs message =
+  status   :: a -> HT.Status
-  errorResponse status (toHeader CTApplicationJSON : hdrs) $
+  headers  :: a -> [Header]
-    JSON.object ["message" .= message]
 
-errorResponse :: JSON.ToJSON a => HT.Status -> [Header] -> a -> Response
+  errorPayload :: a -> LByteString
-errorResponse status hdrs e =
+  errorPayload = JSON.encode
-  responseLBS status hdrs $ encodeError e
 
-pgError :: Bool -> P.UsageError -> Response
+  errorResponseFor :: a -> Response
-pgError authed e =
+  errorResponseFor err = responseLBS (status err) (headers err) $ errorPayload err
-  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]
 
 
-binaryFieldError :: Response
-binaryFieldError =
-  simpleError HT.status406 [] (toS (toMime CTOctetStream) <>
-  " requested but a single column was not selected")
 
-gucHeadersError :: Response
+data ApiRequestError
-gucHeadersError =
+  = ActionInappropriate
- simpleError HT.status500 []
+  | InvalidRange
- "response.headers guc must be a JSON array composed of objects with a single key and a string value"
+  | InvalidBody ByteString
+  | ParseRequestError Text Text
+  | NoRelationBetween Text Text
+  | InvalidFilters
+  | UnknownRelation                -- Unreachable?
+  | UnsupportedVerb                -- Unreachable?
+  deriving (Show, Eq)
 
-connectionLostError :: Response
+instance PgrstError ApiRequestError where
-connectionLostError =
+  status InvalidRange            = HT.status416
-  simpleError HT.status503 [] "Database connection lost, retrying the connection."
+  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
+  headers _ = [toHeader CTApplicationJSON]
-encodeError = JSON.encode
 
 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':_ ->
+    'P':'T':_ -> JSON.object [
-      JSON.object [
+        "details" .= (fmap toS d :: Maybe Text),
-        "details" .= (fmap toS d::Maybe Text),
+        "hint"    .= (fmap toS h :: Maybe Text)]
-        "hint" .= (fmap toS h::Maybe Text)]
+
-    _ ->
+    _         -> JSON.object [
-      JSON.object [
+        "code"    .= (toS c      :: Text),
-        "code" .= (toS c::Text),
+        "message" .= (toS m      :: Text),
-        "message" .= (toS m::Text),
+        "details" .= (fmap toS d :: Maybe Text),
-        "details" .= (fmap toS d::Maybe Text),
+        "hint"    .= (fmap toS h :: 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),
+    "message" .= ("Row error: end of input" :: Text),
-    "details" .=
+    "details" .= ("Attempt to parse more columns than there are in the result" :: Text),
-      ("Attempt to parse more columns than there are in the result"::Text),
+    "hint"    .= (("Row number " <> show i) :: Text)]
-    "details" .= (("Row number " <> show i)::Text)]
   toJSON (H.ResultError (H.RowError i H.UnexpectedNull)) = JSON.object [
-    "message" .= ("Row error: unexpected null"::Text),
+    "message" .= ("Row error: unexpected null" :: Text),
-    "details" .= ("Attempt to parse a NULL as some value."::Text),
+    "details" .= ("Attempt to parse a NULL as some value." :: Text),
-    "details" .= (("Row number " <> show i)::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),
+    "message" .= ("Database client error" :: Text),
-    "details" .= (fmap toS d::Maybe Text)]
+    "details" .= (fmap toS d :: Maybe Text)]
 
-httpStatus :: Bool -> P.UsageError -> HT.Status
+pgErrorStatus :: Bool -> P.UsageError -> HT.Status
-httpStatus _ (P.ConnectionError _) = HT.status503
+pgErrorStatus _      (P.ConnectionError _)                                      = HT.status503
-httpStatus authed (P.SessionError (H.QueryError _ _ (H.ResultError (H.ServerError c m _ _)))) =
+pgErrorStatus _      (P.SessionError (H.QueryError _ _ (H.ClientError _)))      = HT.status503
-  case toS c of
+pgErrorStatus authed (P.SessionError (H.QueryError _ _ (H.ResultError rError))) =
-    '0':'8':_ -> HT.status503 -- pg connection err
+  case rError of
-    '0':'9':_ -> HT.status500 -- triggered action exception
+    (H.ServerError c m _ _) ->
-    '0':'L':_ -> HT.status403 -- invalid grantor
+      case toS c of
-    '0':'P':_ -> HT.status403 -- invalid role specification
+        '0':'8':_ -> HT.status503 -- pg connection err
-    "23503"   -> HT.status409 -- foreign_key_violation
+        '0':'9':_ -> HT.status500 -- triggered action exception
-    "23505"   -> HT.status409 -- unique_violation
+        '0':'L':_ -> HT.status403 -- invalid grantor
-    '2':'5':_ -> HT.status500 -- invalid tx state
+        '0':'P':_ -> HT.status403 -- invalid role specification
-    '2':'8':_ -> HT.status403 -- invalid auth specification
+        "23503"   -> HT.status409 -- foreign_key_violation
-    '2':'D':_ -> HT.status500 -- invalid tx termination
+        "23505"   -> HT.status409 -- unique_violation
-    '3':'8':_ -> HT.status500 -- external routine exception
+        '2':'5':_ -> HT.status500 -- invalid tx state
-    '3':'9':_ -> HT.status500 -- external routine invocation
+        '2':'8':_ -> HT.status403 -- invalid auth specification
-    '3':'B':_ -> HT.status500 -- savepoint exception
+        '2':'D':_ -> HT.status500 -- invalid tx termination
-    '4':'0':_ -> HT.status500 -- tx rollback
+        '3':'8':_ -> HT.status500 -- external routine exception
-    '5':'3':_ -> HT.status503 -- insufficient resources
+        '3':'9':_ -> HT.status500 -- external routine invocation
-    '5':'4':_ -> HT.status413 -- too complex
+        '3':'B':_ -> HT.status500 -- savepoint exception
-    '5':'5':_ -> HT.status500 -- obj not on prereq state
+        '4':'0':_ -> HT.status500 -- tx rollback
-    '5':'7':_ -> HT.status500 -- operator intervention
+        '5':'3':_ -> HT.status503 -- insufficient resources
-    '5':'8':_ -> HT.status500 -- system error
+        '5':'4':_ -> HT.status413 -- too complex
-    'F':'0':_ -> HT.status500 -- conf file error
+        '5':'5':_ -> HT.status500 -- obj not on prereq state
-    'H':'V':_ -> HT.status500 -- foreign data wrapper error
+        '5':'7':_ -> HT.status500 -- operator intervention
-    "P0001"   -> HT.status400 -- default code for "raise"
+        '5':'8':_ -> HT.status500 -- system error
-    'P':'0':_ -> HT.status500 -- PL/pgSQL Error
+        'F':'0':_ -> HT.status500 -- conf file error
-    'X':'X':_ -> HT.status500 -- internal Error
+        'H':'V':_ -> HT.status500 -- foreign data wrapper error
-    "42883"   -> HT.status404 -- undefined function
+        "P0001"   -> HT.status400 -- default code for "raise"
-    "42P01"   -> HT.status404 -- undefined table
+        'P':'0':_ -> HT.status500 -- PL/pgSQL Error
-    "42501"   -> if authed then HT.status403 else HT.status401 -- insufficient privilege
+        'X':'X':_ -> HT.status500 -- internal Error
-    'P':'T':n -> fromMaybe HT.status500 (HT.mkStatus <$> readMaybe n <*> pure m)
+        "42883"   -> HT.status404 -- undefined function
-    _         -> HT.status400
+        "42P01"   -> HT.status404 -- undefined table
-httpStatus _ (P.SessionError (H.QueryError _ _ (H.ResultError _))) = HT.status500
+        "42501"   -> if authed then HT.status403 else HT.status401 -- insufficient privilege
-httpStatus _ (P.SessionError (H.QueryError _ _ (H.ClientError _))) = HT.status503
+        '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)

src/PostgREST/Middleware.hs

@@ -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"
+    JWTMissingSecret      -> return . errorResponseFor $ JwtTokenMissing
-    JWTInvalid e -> return $ unauthed $ show e
+    JWTInvalid JWTExpired -> return . errorResponseFor . JwtTokenInvalid $ "JWT expired"
-    JWTMissingSecret -> return $ simpleError status500 [] "Server lacks JWT secret"
+    JWTInvalid e          -> return . errorResponseFor . JwtTokenInvalid . show $ e
-    JWTClaims claims -> do
+    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 =

src/PostgREST/Parsers.hs

@@ -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

src/PostgREST/Types.hs

@@ -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)

test/Feature/InsertSpec.hs

@@ -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
+        it "fails with 400 and error" $
-          p <- post "/simple_pk" [json| { "extra":"foo"} |]
+          post "/simple_pk" [json| { "extra":"foo"} |]
-          liftIO $ do
+          `shouldRespondWith`
-            simpleStatus p `shouldBe` badRequest400
+          [json|{"hint":null,"details":"Failing row contains (null, foo).","code":"23502","message":"null value in column \"k\" violates not-null constraint"}|]
-            isErrorFormat (simpleBody p) `shouldBe` True
+          { 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
+      it "fails with 400 and error" $
-        p <- post "/simple_pk" "}{ x = 2"
+        post "/simple_pk" "}{ x = 2"
-        liftIO $ do
+        `shouldRespondWith`
-          simpleStatus p `shouldBe` badRequest400
+        [json|{"message":"Error in $: Failed reading: not a valid json value"}|]
-          isErrorFormat (simpleBody p) `shouldBe` True
+        { 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
+      it "fails for too few" $
-        p <- request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz"
+        request methodPost "/no_pk" [("Content-Type", "text/csv")] "a,b\nfoo,bar\nbaz"
-        liftIO $ do
+        `shouldRespondWith`
-          simpleStatus p `shouldBe` badRequest400
+        [json|{"message":"All lines must have same number of fields"}|]
-          isErrorFormat (simpleBody p) `shouldBe` True
+        { 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" []

test/Feature/NoJwtSpec.hs

@@ -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" [] ""

test/Feature/PgVersion96Spec.hs

@@ -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_1"
-        get "/rpc/bad_guc_headers_2" `shouldRespondWith` 500
+          `shouldRespondWith`
-        get "/rpc/bad_guc_headers_3" `shouldRespondWith` 500
+          [json|{"message":"response.headers guc must be a JSON array composed of objects with a single key and a string value"}|]
-        post "/rpc/bad_guc_headers_1" [json|{}|] `shouldRespondWith` 500
+          { 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"

test/Feature/QuerySpec.hs

@@ -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" $

test/Feature/RangeSpec.hs

@@ -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"

test/Feature/RpcSpec.hs

@@ -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" $

test/Feature/UpsertSpec.hs

@@ -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?rank=eq.19"
-          put "/tiobe_pls?id=not.eq.Java" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405
+            [str| [ { "name": "Go", "rank": 19 } ]|]
-          put "/tiobe_pls?id=in.(Go)" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405
+            `shouldRespondWith`
-          put "/tiobe_pls?and=(id.eq.Go)" [str| [ { "name": "Go", "rank": 19 } ]|] `shouldRespondWith` 405
+            [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"
+        put "/tiobe_pls?name=eq.MATLAB" [str| [ { "name": "Perl", "rank": 17 } ]|]
-          [str| [ { "name": "Perl", "rank": 17 } ]|] `shouldRespondWith` 400
+          `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