Use a mime type to request singular JSON responses (#763)

CHANGELOG.md

@@ -7,7 +7,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 
 ### Added
 - Allow test database to be on another host - @dsimunic
-- New `Prefer` header value: `params=single-object` to pass all form values as a single json object to a stored procedure - @dsimunic
+- `Prefer: params=single-object` to treat payload as single json argument in RPC - @dsimunic
 - Ability to generate an OpenAPI spec - @mainx07, @hudayou, @ruslantalpa, @begriffs
 - Ability to generate an OpenAPI spec behind a proxy - @hudayou
 - Ability to set addresses to listen on - @hudayou
@@ -30,6 +30,9 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 - Use specific columns in the RETURNING section - @ruslantalpa
 
 ### Changed
+- Replace `Prefer: plurality=singular` with `Accept: application/vnd.pgrst.object` - @begriffs
+- Standardize arrays in responses for `Prefer: return=representation` - @begriffs
+- Calling unknown RPC gives 404, not 400 - @begriffs
 - Use HTTP 400 for raise\_exception - @begriffs
 - Remove non-OpenAPI schema description - @begriffs
 - Use comma rather than semicolon to separate Prefer header values - @begriffs

postgrest.cabal

@@ -60,7 +60,7 @@ library
                      , either
                      , hasql
                      , hasql-pool == 0.4.1
-                     , hasql-transaction == 0.4.5.1
+                     , hasql-transaction == 0.5
                      , heredoc
                      , HTTP
                      , http-types
@@ -120,6 +120,7 @@ Test-Suite spec
                      , Feature.QueryLimitedSpec
                      , Feature.QuerySpec
                      , Feature.RangeSpec
+                     , Feature.SingularSpec
                      , Feature.StructureSpec
                      , Feature.UnicodeSpec
                      , SpecHelper
@@ -133,6 +134,7 @@ Test-Suite spec
                      , base64-bytestring
                      , case-insensitive
                      , cassava
+                     , containers
                      , contravariant
                      , hasql
                      , hasql-pool

src/PostgREST/ApiRequest.hs

@@ -38,7 +38,7 @@ import           Data.Ranged.Boundaries
 import           PostgREST.Types           (QualifiedIdentifier (..),
                                             Schema,
                                             PayloadJSON(..))
-import           Data.Ranged.Ranges        (Range(..), singletonRange, rangeIntersection, emptyRange)
+import           Data.Ranged.Ranges        (Range(..), rangeIntersection, emptyRange)
 
 type RequestBody = BL.ByteString
 
@@ -59,6 +59,7 @@ data PreferRepresentation = Full | HeadersOnly | None deriving Eq
                           --
 -- | Enumeration of currently supported response content types
 data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI
+                 | CTSingularJSON
                  | CTAny | CTOther BS.ByteString deriving Eq
 
 data ApiRequestError = ErrorActionInappropriate
@@ -75,6 +76,7 @@ toMime :: ContentType -> ByteString
 toMime CTApplicationJSON = "application/json"
 toMime CTTextCSV         = "text/csv"
 toMime CTOpenAPI         = "application/openapi+json"
+toMime CTSingularJSON    = "application/vnd.pgrst.object+json"
 toMime CTAny             = "*/*"
 toMime (CTOther ct)      = ct
 
@@ -98,8 +100,6 @@ data ApiRequest = ApiRequest {
   , iPayload :: Maybe PayloadJSON
   -- | If client wants created items echoed back
   , iPreferRepresentation :: PreferRepresentation
-  -- | If client wants first row as raw object
-  , iPreferSingular :: Bool
   -- | Pass all parameters as a single json object to a stored procedure
   , iPreferSingleObjectParameter :: Bool
   -- | Whether the client wants a result count (slower)
@@ -130,9 +130,8 @@ userApiRequest schema req reqBody
         map decodeContentType . parseHttpAccept <$> lookupHeader "accept"
       , iPayload = relevantPayload
       , iPreferRepresentation = representation
-      , iPreferSingular = singular
       , iPreferSingleObjectParameter = singleObject
-      , iPreferCount = not singular && hasPrefer "count=exact"
+      , iPreferCount = hasPrefer "count=exact"
       , iFilters = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset"] k) ]
       , iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
       , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
@@ -194,7 +193,6 @@ userApiRequest schema req reqBody
     where
         split :: BS.ByteString -> [Text]
         split = map T.strip . T.split (==',') . toS
-  singular        = hasPrefer "plurality=singular"
   singleObject    = hasPrefer "params=single-object"
   representation
     | hasPrefer "return=representation" = Full
@@ -208,7 +206,7 @@ userApiRequest schema req reqBody
   endingIn xx key = lastWord `elem` xx
     where lastWord = last $ T.split (=='.') key
 
-  headerRange = if singular && method == "GET" then singletonRange 0 else rangeRequested hdrs
+  headerRange = rangeRequested hdrs
   replaceLast x s = T.intercalate "." $ L.init (T.split (=='.') s) ++ [x]
   limitParams :: M.HashMap ByteString NonnegRange
   limitParams  = M.fromList [(toS (replaceLast "limit" k), restrictRange (readMaybe =<< (toS <$> v)) allRange) | (k,v) <- qParams, isJust v, endingIn ["limit"] k]
@@ -244,11 +242,13 @@ mutuallyAgreeable sProduces cAccepts =
 decodeContentType :: BS.ByteString -> ContentType
 decodeContentType ct =
   case BS.takeWhile (/= BS.c2w ';') ct of
-    "application/json"         -> CTApplicationJSON
+    "application/json"                  -> CTApplicationJSON
-    "text/csv"                 -> CTTextCSV
+    "text/csv"                          -> CTTextCSV
-    "application/openapi+json" -> CTOpenAPI
+    "application/openapi+json"          -> CTOpenAPI
-    "*/*"                      -> CTAny
+    "application/vnd.pgrst.object+json" -> CTSingularJSON
-    ct'                        -> CTOther ct'
+    "application/vnd.pgrst.object"      -> CTSingularJSON
+    "*/*"                               -> CTAny
+    ct'                                 -> CTOther ct'
 
 type CsvData = V.Vector (M.HashMap Text BL.ByteString)
 

src/PostgREST/App.hs

@@ -11,19 +11,18 @@ import qualified Data.ByteString.Char8     as BS
 import           Data.IORef                (IORef, readIORef)
 import           Data.List                 (delete, lookup)
 import           Data.Maybe                (fromJust)
-import           Data.Text                 (replace, strip, isInfixOf, dropWhile, drop, intercalate)
+import           Data.Text                 (isInfixOf, dropWhile, drop, intercalate)
 import           Data.Time.Clock.POSIX     (POSIXTime)
 import           Data.Tree
 import           Data.Either.Combinators   (mapLeft)
 
-import qualified Hasql.Pool                as P
+import qualified Hasql.Pool                 as P
-import qualified Hasql.Transaction         as HT
+import qualified Hasql.Transaction          as HT
+import qualified Hasql.Transaction.Sessions as HT
 
 import           Text.Parsec.Error
 import           Text.ParserCombinators.Parsec (parse)
 
-import qualified Text.InterpolatedString.Perl6 as P6 (q)
-
 import           Network.HTTP.Types.Header
 import           Network.HTTP.Types.Status
 import           Network.HTTP.Types.URI    (renderSimpleQuery)
@@ -31,8 +30,6 @@ import           Network.Wai
 import           Network.Wai.Middleware.RequestLogger (logStdout)
 import           Web.JWT                   (binarySecret)
 
-import           Data.Aeson
-import           Data.Aeson.Types          (emptyArray)
 import qualified Data.Vector               as V
 import qualified Hasql.Transaction         as H
 
@@ -49,7 +46,7 @@ import           PostgREST.ApiRequest   ( ApiRequest(..), ContentType(..)
 import           PostgREST.Auth            (jwtClaims, containsRole)
 import           PostgREST.Config          (AppConfig (..))
 import           PostgREST.DbStructure
-import           PostgREST.Error           (errResponse, pgErrResponse, apiRequestErrResponse)
+import           PostgREST.Error           (errResponse, pgErrResponse, apiRequestErrResponse, singularityError, formatParserError)
 import           PostgREST.Parsers
 import           PostgREST.RangeQuery      (NonnegRange, allRange, rangeOffset, restrictRange)
 import           PostgREST.Middleware
@@ -89,7 +86,7 @@ postgrest conf refDbStructure pool getTime =
             authed = containsRole eClaims
             handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest
             txMode = transactionMode $ iAction apiRequest
-        response <- P.use pool $ HT.run handleReq HT.ReadCommitted txMode
+        response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq
         return $ either (pgErrResponse authed) identity response
     respond response
 
@@ -109,96 +106,102 @@ app dbStructure conf apiRequest =
           case readSqlParts of
             Left errorResponse -> return errorResponse
             Right (q, cq) -> do
-              let singular = iPreferSingular apiRequest
+              let stm = createReadStatement q cq (contentType == CTSingularJSON) shouldCount (contentType == CTTextCSV)
-                  stm = createReadStatement q cq singular shouldCount (contentType == CTTextCSV)
               row <- H.query () stm
               let (tableTotal, queryTotal, _ , body) = row
-              if singular
+                  (status, contentRange) = rangeHeader queryTotal tableTotal
-              then return $ if queryTotal <= 0
+                  canonical = iCanonicalQS apiRequest
-                then notFound
+              return $
-                else responseLBS status200 [toHeader contentType] (toS body)
+                if contentType == CTSingularJSON && queryTotal /= 1
-              else do
+                  then singularityError (toInteger queryTotal)
-                let (status, contentRange) = rangeHeader queryTotal tableTotal
+                  else responseLBS status
-                    canonical = iCanonicalQS apiRequest
+                    [toHeader contentType, contentRange,
-                    --TargetIdent qi = iTarget apiRequest
+                      ("Content-Location",
-                return $ responseLBS status
+                        "/" <> toS (qiName qi) <>
-                  [toHeader contentType, contentRange,
+                          if BS.null canonical then "" else "?" <> toS canonical
-                    ("Content-Location",
+                      )
-                      "/" <> toS (qiName qi) <>
+                    ] (toS body)
-                        if BS.null canonical then "" else "?" <> toS canonical
-                    )
-                  ] (toS body)
 
-        (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), Just payload@(PayloadJSON rows)) ->
+        (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just payload@(PayloadJSON rows)) ->
           case mutateSqlParts of
             Left errorResponse -> return errorResponse
             Right (sq, mq) -> do
               let isSingle = (==1) $ V.length rows
-              when (not isSingle && iPreferSingular apiRequest) $
+              if contentType == CTSingularJSON
-                HT.sql [P6.q| DO $$
+                 && not isSingle
-                          BEGIN RAISE EXCEPTION cardinality_violation
+                 && iPreferRepresentation apiRequest == Full
-                          USING MESSAGE =
+                then return $ singularityError (toInteger $ V.length rows)
-                            'plurality=singular specified, but more than one object would be inserted';
+                else do
-                          END $$;
+                  let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
-                        |]
+                      stm = createWriteStatement sq mq
-              let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
+                        (contentType == CTSingularJSON) isSingle
-              let stm = createWriteStatement qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == CTTextCSV) payload
+                        (contentType == CTTextCSV) (iPreferRepresentation apiRequest)
-              row <- H.query payload stm
+                        pKeys
-              let (_, _, fs, body) = extractQueryResult row
+                  row <- H.query payload stm
-                  headers = catMaybes [
+                  let (_, _, fs, body) = extractQueryResult row
-                      if null fs
+                      headers = catMaybes [
-                        then Nothing
+                          if null fs
-                        else Just (hLocation, "/" <> toS table <> renderLocationFields fs)
+                            then Nothing
-                    , if iPreferRepresentation apiRequest == Full
+                            else Just (hLocation, "/" <> toS table <> renderLocationFields fs)
-                        then Just $ toHeader contentType
+                        , if iPreferRepresentation apiRequest == Full
-                        else Nothing
+                            then Just $ toHeader contentType
-                    , Just . contentRangeH 1 0 $
+                            else Nothing
-                        toInteger <$> if shouldCount then Just (V.length rows) else Nothing
+                        , Just . contentRangeH 1 0 $
-                    ]
+                            toInteger <$> if shouldCount then Just (V.length rows) else Nothing
+                        ]
 
-              return . responseLBS status201 headers $
+                  return . responseLBS status201 headers $
-                if iPreferRepresentation apiRequest == Full
+                    if iPreferRepresentation apiRequest == Full
-                  then toS body else ""
+                      then toS body else ""
 
-        (ActionUpdate, TargetIdent qi, Just payload) ->
+        (ActionUpdate, TargetIdent _, Just payload) ->
           case mutateSqlParts of
             Left errorResponse -> return errorResponse
             Right (sq, mq) -> do
-              let singular = iPreferSingular apiRequest
+              let stm = createWriteStatement sq mq
-                  stm = createWriteStatement qi sq mq singular (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) payload
+                    (contentType == CTSingularJSON) False (contentType == CTTextCSV)
+                    (iPreferRepresentation apiRequest) []
               row <- H.query payload stm
               let (_, queryTotal, _, body) = extractQueryResult row
-              when (singular && queryTotal > 1) $
+              if contentType == CTSingularJSON
-                HT.sql [P6.q| DO $$
+                 && queryTotal /= 1
-                          BEGIN RAISE EXCEPTION cardinality_violation
+                 && iPreferRepresentation apiRequest == Full
-                          USING MESSAGE =
+                then do
-                            'plurality=singular specified, but more than one object would be updated';
+                  HT.condemn
-                          END $$;
+                  return $ singularityError (toInteger queryTotal)
-                        |]
+                else do
-              let r = contentRangeH 0 (toInteger $ queryTotal-1)
+                  let r = contentRangeH 0 (toInteger $ queryTotal-1)
-                        (toInteger <$> if shouldCount then Just queryTotal else Nothing)
+                            (toInteger <$> if shouldCount then Just queryTotal else Nothing)
-                  s = case () of _ | queryTotal == 0 -> status404
+                      s = if iPreferRepresentation apiRequest == Full
-                                  | iPreferRepresentation apiRequest == Full -> status200
+                            then status200
-                                  | otherwise -> status204
+                            else status204
-              return $ if iPreferRepresentation apiRequest == Full
+                  return $ if iPreferRepresentation apiRequest == Full
-                then responseLBS s [toHeader contentType, r] (toS body)
+                    then responseLBS s [toHeader contentType, r] (toS body)
-                else responseLBS s [r] ""
+                    else responseLBS s [r] ""
 
-        (ActionDelete, TargetIdent qi, Nothing) ->
+        (ActionDelete, TargetIdent _, Nothing) ->
           case mutateSqlParts of
             Left errorResponse -> return errorResponse
             Right (sq, mq) -> do
               let emptyPayload = PayloadJSON V.empty
-                  stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) emptyPayload
+                  stm = createWriteStatement sq mq
+                    (contentType == CTSingularJSON) False
+                    (contentType == CTTextCSV)
+                    (iPreferRepresentation apiRequest) []
               row <- H.query emptyPayload stm
               let (_, queryTotal, _, body) = extractQueryResult row
                   r = contentRangeH 1 0 $
                         toInteger <$> if shouldCount then Just queryTotal else Nothing
-              return $ if queryTotal == 0
+              if contentType == CTSingularJSON
-                then notFound
+                 && queryTotal /= 1
-                else if iPreferRepresentation apiRequest == Full
+                 && iPreferRepresentation apiRequest == Full
-                  then responseLBS status200 [toHeader contentType, r] (toS body)
+                then do
-                  else responseLBS status204 [r] ""
+                  HT.condemn
+                  return $ singularityError (toInteger queryTotal)
+                else
+                  return $ if iPreferRepresentation apiRequest == Full
+                    then responseLBS status200 [toHeader contentType, r] (toS body)
+                    else responseLBS status204 [r] ""
 
         (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->
           let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in
@@ -213,13 +216,17 @@ app dbStructure conf apiRequest =
             Left errorResponse -> return errorResponse
             Right (q, cq) -> do
               let p = V.head payload
-                  singular = iPreferSingular apiRequest
+                  singular = contentType == CTSingularJSON
                   paramsAsSingleObject = iPreferSingleObjectParameter apiRequest
               row <- H.query () (callProc qi p q cq topLevelRange shouldCount singular paramsAsSingleObject)
               let (tableTotal, queryTotal, body) =
-                    fromMaybe (Just 0, 0, emptyArray) row
+                    fromMaybe (Just 0, 0, "[]") row
                   (status, contentRange) = rangeHeader queryTotal tableTotal
-              return $ responseLBS status [jsonH, contentRange] (toS . encode $ body)
+              if singular && queryTotal /= 1
+                then do
+                  HT.condemn
+                  return $ singularityError (toInteger queryTotal)
+                else return $ responseLBS status [jsonH, contentRange] (toS body)
 
         (ActionInspect, TargetRoot, Nothing) -> do
           let host = configHost conf
@@ -275,13 +282,13 @@ responseContentTypeOrError accepts action = serves contentTypesForRequest accept
   where
     contentTypesForRequest =
       case action of
-        ActionRead -> [CTApplicationJSON, CTTextCSV]
+        ActionRead ->    [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-        ActionCreate -> [CTApplicationJSON, CTTextCSV]
+        ActionCreate ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-        ActionUpdate -> [CTApplicationJSON, CTTextCSV]
+        ActionUpdate ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-        ActionDelete -> [CTApplicationJSON, CTTextCSV]
+        ActionDelete ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-        ActionInvoke -> [CTApplicationJSON]
+        ActionInvoke ->  [CTApplicationJSON, CTSingularJSON]
         ActionInspect -> [CTOpenAPI]
-        ActionInfo -> [CTTextCSV]
+        ActionInfo ->    [CTTextCSV]
     serves sProduces cAccepts =
       case mutuallyAgreeable sProduces cAccepts of
         Nothing -> do
@@ -318,23 +325,12 @@ contentRangeH lower upper total =
       totalNotZero  = fromMaybe True ((/=) 0 <$> total)
       fromInRange   = lower <= upper
 
-formatParserError :: ParseError -> Text
-formatParserError e = formatGeneralError message details
-  where
-     message = show $ errorPos e
-     details = strip $ replace "\n" " " $ toS
-       $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
-
-formatGeneralError :: Text -> Text -> Text
-formatGeneralError message details = message <> ", " <> details
-
 augumentRequestWithJoin :: Schema ->  [Relation] ->  ReadRequest -> Either Text ReadRequest
 augumentRequestWithJoin schema allRels request =
   (first formatRelationError . addRelations schema allRels Nothing) request
   >>= addJoinConditions schema
   where
-    formatRelationError = formatGeneralError
+    formatRelationError = ("could not find foreign keys between these entities, " <>)
-      "could not find foreign keys between these entities"
 
 addFiltersOrdersRanges :: ApiRequest -> Either ParseError (ReadRequest -> ReadRequest)
 addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [

src/PostgREST/Error.hs

@@ -2,16 +2,18 @@
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 
-module PostgREST.Error (apiRequestErrResponse, pgErrResponse, errResponse, prettyUsageError) where
+module PostgREST.Error (apiRequestErrResponse, pgErrResponse, errResponse, prettyUsageError, singularityError, formatGeneralError, formatParserError) where
 
 import           Protolude
 import           Data.Aeson                ((.=))
 import qualified Data.Aeson                as JSON
+import           Data.Text                 (replace, strip, unwords)
 import qualified Hasql.Pool                as P
 import qualified Hasql.Session             as H
 import qualified Network.HTTP.Types.Status as HT
 import           Network.Wai               (Response, responseLBS)
-import           PostgREST.ApiRequest      (toHeader, ContentType(..), ApiRequestError(..))
+import           PostgREST.ApiRequest      (toHeader, toMime, ContentType(..), ApiRequestError(..))
+import           Text.Parsec.Error
 
 apiRequestErrResponse :: ApiRequestError -> Response
 apiRequestErrResponse err =
@@ -41,6 +43,28 @@ prettyUsageError (P.ConnectionError e) =
   "Database connection error:\n" <> toS (fromMaybe "" e)
 prettyUsageError e = show $ JSON.encode e
 
+singularityError :: Integer -> 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"
+        ]
+
+formatParserError :: ParseError -> Text
+formatParserError e = formatGeneralError message details
+  where
+     message = show $ errorPos e
+     details = strip $ replace "\n" " " $ toS
+       $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
+
+formatGeneralError :: Text -> Text -> Text
+formatGeneralError message details = toS . JSON.encode $
+  JSON.object ["message" .= message, "details" .= details]
+
 instance JSON.ToJSON P.UsageError where
   toJSON (P.ConnectionError e) = JSON.object [
     "code" .= ("" :: Text),
@@ -103,6 +127,7 @@ httpStatus authed (P.SessionError (H.ResultError (H.ServerError c _ _ _))) =
     "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
     _         -> HT.status400

src/PostgREST/OpenAPI.hs

@@ -155,7 +155,7 @@ makeGetParams :: [Column] -> [Param]
 makeGetParams [] =
   makeRangeParams ++
   [ makeSelectParam
-  , makePreferParam ["plurality=singular", "count=none"]
+  , makePreferParam ["count=none"]
   ]
 makeGetParams cs =
   makeRangeParams ++
@@ -168,12 +168,12 @@ makeGetParams cs =
       & in_ .~ ParamQuery
       & type_ .~ SwaggerString
       & enum_ .~ decode (encode $ makeOrderItems cs))
-  , makePreferParam ["plurality=singular", "count=none"]
+  , makePreferParam ["count=none"]
   ]
 
 makePostParams :: Text -> [Param]
 makePostParams tn =
-  [ makePreferParam ["return=representation", "return=representation,plurality=singular",
+  [ makePreferParam ["return=representation",
                      "return=minimal", "return=none"]
   , (mempty :: Param)
     & name        .~ "body"
@@ -200,17 +200,17 @@ makePathItem (t, cs, _) = ("/" ++ unpack tn, p $ tableInsertable t)
   where
     tOp = (mempty :: Operation)
       & tags .~ Set.fromList [tn]
-      & produces ?~ makeMimeList [CTApplicationJSON, CTTextCSV]
+      & produces ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
       & at 200 ?~ "OK"
     getOp = tOp
       & parameters .~ map Inline (makeGetParams cs ++ rs)
       & at 206 ?~ "Partial Content"
     postOp = tOp
-      & consumes ?~ makeMimeList [CTApplicationJSON, CTTextCSV]
+      & consumes ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
       & parameters .~ map Inline (makePostParams tn)
       & at 201 ?~ "Created"
     patchOp = tOp
-      & consumes ?~ makeMimeList [CTApplicationJSON, CTTextCSV]
+      & consumes ?~ makeMimeList [CTApplicationJSON, CTSingularJSON, CTTextCSV]
       & parameters .~ map Inline (makePostParams tn ++ rs)
       & at 204 ?~ "No Content"
     deletOp = tOp
@@ -228,7 +228,7 @@ makeProcPathItem pd = ("/rpc/" ++ toS (pdName pd), pe)
     postOp = (mempty :: Operation)
       & parameters .~ map Inline (makeProcParam $ "(rpc) " <> pdName pd)
       & tags .~ Set.fromList ["(rpc) " <> pdName pd]
-      & produces ?~ makeMimeList [CTApplicationJSON]
+      & produces ?~ makeMimeList [CTApplicationJSON, CTSingularJSON]
       & at 200 ?~ "OK"
     pe = (mempty :: PathItem) & post ?~ postOp
 

src/PostgREST/QueryBuilder.hs

@@ -111,49 +111,40 @@ createReadStatement selectQuery countQuery isSingle countTotal asCsv =
     | isSingle = asJsonSingleF
     | otherwise = asJsonF
 
-createWriteStatement :: QualifiedIdentifier -> SqlQuery -> SqlQuery -> Bool ->
+createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->
-                        PreferRepresentation -> [Text] -> Bool -> PayloadJSON ->
+                        PreferRepresentation -> [Text] ->
                         H.Query PayloadJSON (Maybe ResultsWithCount)
-createWriteStatement _ _ mutateQuery _ None
+createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys =
-                     _ _ (PayloadJSON _) =
   unicodeStatement sql encodeUniformObjs decodeStandardMay True
+
  where
-  sql = [qc|
+  sql = case rep of
+    None -> [qc|
       WITH {sourceCTEName} AS ({mutateQuery})
       SELECT '', 0, {noLocationF}, '' |]
-
+    HeadersOnly -> [qc|
-createWriteStatement _ _ mutateQuery isSingle HeadersOnly
-                     pKeys _ (PayloadJSON _) =
-  unicodeStatement sql encodeUniformObjs decodeStandardMay True
- where
-  sql = [qc|
       WITH {sourceCTEName} AS ({mutateQuery})
       SELECT {cols}
       FROM (SELECT 1 FROM {sourceCTEName}) _postgrest_t |]
-  cols = intercalate ", " [
+    Full -> [qc|
-      "'' AS total_result_set",
-      "pg_catalog.count(_postgrest_t) AS page_total",
-      if isSingle then locationF pKeys else noLocationF,
-      "''"
-    ]
-
-createWriteStatement _ selectQuery mutateQuery isSingle Full
-                     pKeys asCsv (PayloadJSON _) =
-  unicodeStatement sql encodeUniformObjs decodeStandardMay True
- where
-  sql = [qc|
       WITH {sourceCTEName} AS ({mutateQuery})
       SELECT {cols}
       FROM ({selectQuery}) _postgrest_t |]
+
   cols = intercalate ", " [
       "'' AS total_result_set", -- when updateing it does not make sense
       "pg_catalog.count(_postgrest_t) AS page_total",
-      if isSingle then locationF pKeys else noLocationF <> " AS header",
+      if wantHdrs
-      bodyF <> " AS body"
+         then locationF pKeys
+         else noLocationF <> " AS header",
+      if rep == Full
+         then bodyF <> " AS body"
+         else "''"
     ]
+
   bodyF
     | asCsv = asCsvF
-    | isSingle = asJsonSingleF
+    | wantSingle = asJsonSingleF
     | otherwise = asJsonF
 
 addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest
@@ -237,7 +228,7 @@ addJoinConditions schema (Node nn@(query, (n, r, a)) forest) =
     updatedForest = mapM (addJoinConditions schema) forest
     addCond query' con = query'{flt_=con ++ flt_ query'}
 
-type ProcResults = (Maybe Int64, Int64, JSON.Value)
+type ProcResults = (Maybe Int64, Int64, ByteString)
 callProc :: QualifiedIdentifier -> JSON.Object -> SqlQuery -> SqlQuery -> NonnegRange -> Bool -> Bool -> Bool -> H.Query () (Maybe ProcResults)
 callProc qi params selectQuery countQuery _ countTotal isSingle paramsAsJson =
   unicodeStatement sql HE.unit decodeProc True
@@ -269,7 +260,7 @@ callProc qi params selectQuery countQuery _ countTotal isSingle paramsAsJson =
                    else "null::bigint" :: Text
     decodeProc = HD.maybeRow procRow
     procRow = (,,) <$> HD.nullableValue HD.int8 <*> HD.value HD.int8
-                   <*> HD.value HD.json
+                   <*> HD.value HD.bytea
     bodyF
      | isSingle = asJsonSingleF
      | otherwise = asJsonF
@@ -389,9 +380,10 @@ requestToQuery schema _ returningSql (DbMutate (Insert mainTbl (PayloadJSON rows
         insInto = unwords [ "INSERT INTO" , fromQi qi,
             if T.null colsString then "" else "(" <> colsString <> ")"
           ]
-        vals = unwords $ if T.null colsString
+        vals = unwords $
-                  then ["DEFAULT VALUES"]
+          if T.null colsString
-                  else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"]
+            then if V.null rows then ["SELECT null WHERE false"] else ["DEFAULT VALUES"]
+            else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"]
 requestToQuery schema _ returningSql (DbMutate (Update mainTbl (PayloadJSON rows) conditions)) =
   case rows V.!? 0 of
     Just obj ->

stack.yaml

@@ -2,7 +2,7 @@ resolver: lts-7.4
 extra-deps:
   - Ranged-sets-0.3.0
   - hasql-pool-0.4.1
-  - hasql-transaction-0.4.5.1
+  - hasql-transaction-0.5
 ghc-options:
   postgrest: -O2 -Werror -Wall -fwarn-identities
 nix:

test/Feature/AuthSpec.hs

@@ -15,7 +15,7 @@ import Protolude hiding (get)
 
 spec :: SpecWith Application
 spec = describe "authorization" $ do
-  let single = ("Prefer","plurality=singular")
+  let single = ("Accept","application/vnd.pgrst.object+json")
 
   it "denies access to tables that anonymous does not own" $
     get "/authors_only" `shouldRespondWith` ResponseMatcher {
@@ -61,10 +61,7 @@ spec = describe "authorization" $ do
   it "sql functions can read custom and standard claims variables" $ do
     let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJzdWIiOiJmdW4iLCJqdGkiOiJmb28iLCJuYmYiOjEzMDA4MTkzODAsImV4cCI6OTk5OTk5OTk5OSwiaHR0cDovL3Bvc3RncmVzdC5jb20vZm9vIjp0cnVlLCJpc3MiOiJqb2UiLCJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWF0IjoxMzAwODE5MzgwLCJhdWQiOiJldmVyeW9uZSJ9.AQmCA7CMScvfaDRMqRPeUY6eNf--69gpW-kxaWfq9X0"
     request methodPost "/rpc/reveal_big_jwt" [auth] "{}"
-      `shouldRespondWith` [json| [
+      `shouldRespondWith` [str|[{"iss":"joe","sub":"fun","aud":"everyone","exp":9999999999,"nbf":1300819380,"iat":1300819380,"jti":"foo","http://postgrest.com/foo":true}]|]
-          {"sub":"fun", "jti":"foo", "nbf":1300819380, "exp":9999999999,
-          "http://postgrest.com/foo":true, "iss":"joe", "iat":1300819380,
-          "aud":"everyone"}] |]
 
   it "allows users with permissions to see their tables" $ do
     let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.y4vZuu1dDdwAl0-S00MCRWRYMlJ5YAMSir6Es6WtWx0"

test/Feature/DeleteSpec.hs

@@ -52,9 +52,15 @@ spec =
           , matchHeaders = ["Content-Range" <:> "0-0/*"]
           }
 
-    context "known route, unknown record" $
+    context "known route, no records matched" $
-      it "fails with 404" $
+      it "includes [] body if return=rep" $
-        request methodDelete "/items?id=eq.101" [] "" `shouldRespondWith` 404
+        request methodDelete "/items?id=eq.101"
+          [("Prefer", "return=representation")] ""
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just "[]"
+          , matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "*/*"]
+          }
 
     context "totally unknown route" $
       it "fails with 404" $

test/Feature/InsertSpec.hs

@@ -39,12 +39,12 @@ spec = do
 
       it "filters columns in result using &select" $
         request methodPost "/menagerie?select=integer,varchar" [("Prefer", "return=representation")]
-          [json| {
+          [json| [{
             "integer": 14, "double": 3.14159, "varchar": "testing!"
           , "boolean": false, "date": "1900-01-01", "money": "$3.99"
           , "enum": "foo"
-          } |] `shouldRespondWith` ResponseMatcher {
+          }] |] `shouldRespondWith` ResponseMatcher {
-            matchBody    = Just [str|{"integer":14,"varchar":"testing!"}|]
+            matchBody    = Just [str|[{"integer":14,"varchar":"testing!"}]|]
           , matchStatus  = 201
           , matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]
           }
@@ -53,7 +53,7 @@ spec = do
         request methodPost "/projects?select=id,name,clients{id,name}"
                 [("Prefer", "return=representation"), ("Prefer", "count=exact")]
           [str|{"id":6,"name":"New Project","client_id":2}|] `shouldRespondWith` ResponseMatcher {
-            matchBody    = Just [str|{"id":6,"name":"New Project","clients":{"id":2,"name":"Apple"}}|]
+            matchBody    = Just [str|[{"id":6,"name":"New Project","clients":{"id":2,"name":"Apple"}}]|]
           , matchStatus  = 201
           , matchHeaders = [ "Content-Type" <:> "application/json; charset=utf-8"
                            , "Location" <:> "/projects?id=eq.6"
@@ -86,9 +86,11 @@ spec = do
             incNullableStr record `shouldBe` Nothing
 
       context "into a table with simple pk" $
-        it "fails with 400 and error" $
+        it "fails with 400 and error" $ do
-          post "/simple_pk" [json| { "extra":"foo"} |]
+          p <- post "/simple_pk" [json| { "extra":"foo"} |]
-            `shouldRespondWith` 400
+          liftIO $ do
+            simpleStatus p `shouldBe` badRequest400
+            isErrorFormat (simpleBody p) `shouldBe` True
 
       context "into a table with no pk" $ do
         it "succeeds with 201 and a link including all fields" $ do
@@ -103,10 +105,18 @@ spec = do
                        [("Prefer", "return=representation")]
                        [json| { "a":"bar", "b":"baz" } |]
           liftIO $ do
-            simpleBody p `shouldBe` [json| { "a":"bar", "b":"baz" } |]
+            simpleBody p `shouldBe` [json| [{ "a":"bar", "b":"baz" }] |]
             simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=eq.bar&b=eq.baz"
             simpleStatus p `shouldBe` created201
 
+        it "returns empty array when no items inserted, and return=rep" $ do
+          p <- request methodPost "/no_pk"
+                       [("Prefer", "return=representation")]
+                       [json| [] |]
+          liftIO $ do
+            simpleBody p `shouldBe` [json| [] |]
+            simpleStatus p `shouldBe` created201
+
         it "can insert in tables with no select privileges" $ do
           p <- request methodPost "/insertonly"
                        [("Prefer", "return=minimal")]
@@ -121,7 +131,7 @@ spec = do
                        [("Prefer", "return=representation")]
                        [json| { "a":null, "b":"foo" } |]
           liftIO $ do
-            simpleBody p `shouldBe` [json| { "a":null, "b":"foo" } |]
+            simpleBody p `shouldBe` [json| [{ "a":null, "b":"foo" }] |]
             simpleHeaders p `shouldSatisfy` matchHeader hLocation "/no_pk\\?a=is.null&b=eq.foo"
             simpleStatus p `shouldBe` created201
 
@@ -134,7 +144,7 @@ spec = do
                      [("Prefer", "return=representation")]
                      inserted
         liftIO $ do
-          JSON.decode (simpleBody p) `shouldBe` Just expectedObj
+          JSON.decode (simpleBody p) `shouldBe` Just [expectedObj]
           simpleStatus p `shouldBe` created201
           lookup hLocation (simpleHeaders p) `shouldBe` Just expectedLoc
 
@@ -154,8 +164,11 @@ spec = do
           lookup hLocation (simpleHeaders p) `shouldBe` Nothing
 
     context "with invalid json payload" $
-      it "fails with 400 and error" $
+      it "fails with 400 and error" $ do
-        post "/simple_pk" "}{ x = 2" `shouldRespondWith` 400
+        p <- post "/simple_pk" "}{ x = 2"
+        liftIO $ do
+          simpleStatus p `shouldBe` badRequest400
+          isErrorFormat (simpleBody p) `shouldBe` True
 
     context "with valid json payload" $
       it "succeeds and returns 201 created" $
@@ -177,7 +190,7 @@ spec = do
                      [("Prefer", "return=representation")]
                      inserted
           `shouldRespondWith` ResponseMatcher {
-            matchBody    = Just inserted
+            matchBody    = Just [str|[{"data":{"foo":"bar"}}]|]
           , matchStatus  = 201
           , matchHeaders = ["Location" <:> location]
           }
@@ -189,7 +202,7 @@ spec = do
                      [("Prefer", "return=representation")]
                      inserted
           `shouldRespondWith` ResponseMatcher {
-            matchBody    = Just inserted
+            matchBody    = Just [str|[{"data":[1,2,3]}]|]
           , matchStatus  = 201
           , matchHeaders = ["Location" <:> location]
           }
@@ -205,7 +218,7 @@ spec = do
       it "succeeds if correct select is applied" $
         request methodPost "/limited_article_stars?select=article_id,user_id" [("Prefer", "return=representation")]
           [json| {"article_id": 2, "user_id": 1} |] `shouldRespondWith` ResponseMatcher {
-            matchBody    = Just [str|{"article_id":2,"user_id":1}|]
+            matchBody    = Just [str|[{"article_id":2,"user_id":1}]|]
           , matchStatus  = 201
           , matchHeaders = []
           }
@@ -264,11 +277,12 @@ spec = do
                             "Location" <:> "/no_pk?a=is.null&b=eq.foo"]
           }
 
-
     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 $ simpleStatus p `shouldBe` badRequest400
+        liftIO $ do
+          simpleStatus p `shouldBe` badRequest400
+          isErrorFormat (simpleBody p) `shouldBe` True
 
     context "with unicode values" $
       it "succeeds and returns usable location header" $ do
@@ -277,7 +291,7 @@ spec = do
                      [("Prefer", "return=representation")]
                      payload
         liftIO $ do
-          simpleBody p `shouldBe` payload
+          simpleBody p `shouldBe` "["<>payload<>"]"
           simpleStatus p `shouldBe` created201
 
         let Just location = lookup hLocation $ simpleHeaders p
@@ -297,7 +311,11 @@ spec = do
       it "indicates no records found to update" $
         request methodPatch "/empty_table" []
           [json| { "extra":20 } |]
-            `shouldRespondWith` 404
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just "",
+            matchStatus  = 204,
+            matchHeaders = ["Content-Range" <:> "*/*"]
+          }
 
     context "in a nonempty table" $ do
       it "can update a single item" $ do
@@ -310,12 +328,32 @@ spec = do
             matchStatus  = 204,
             matchHeaders = ["Content-Range" <:> "0-0/*"]
           }
-        liftIO $
+        liftIO $ lookup hContentType (simpleHeaders p) `shouldBe` Nothing
-          lookup hContentType (simpleHeaders p) `shouldBe` Nothing
 
+        -- check it really got updated
         g' <- get "/items?id=eq.42"
         liftIO $ simpleHeaders g'
           `shouldSatisfy` matchHeader "Content-Range" "0-0/\\*"
+        -- put value back for other tests
+        void $ request methodPatch "/items?id=eq.42" [] [json| { "id":2 } |]
+
+      it "returns empty array when no rows updated and return=rep" $
+        request methodPatch "/items?id=eq.999999"
+          [("Prefer", "return=representation")] [json| { "id":999999 } |]
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just "[]",
+            matchStatus  = 200,
+            matchHeaders = ["Content-Range" <:> "*/*"]
+          }
+
+      it "returns updated object as array when return=rep" $
+        request methodPatch "/items?id=eq.2"
+          [("Prefer", "return=representation")] [json| { "id":2 } |]
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just [str|[{"id":2}]|],
+            matchStatus  = 200,
+            matchHeaders = ["Content-Range" <:> "0-0/*"]
+          }
 
       it "can update multiple items" $ do
         replicateM_ 10 $ post "/auto_incrementing_pk"
@@ -335,50 +373,6 @@ spec = do
         get "/no_pk?a=eq.keepme" `shouldRespondWith`
           [json| [{ a: "keepme", b: null }] |]
 
-      it "can update based on a computed column" $
-        request methodPatch
-          "/items?always_true=eq.false"
-          [("Prefer", "return=representation")]
-          [json| { id: 100 } |]
-          `shouldRespondWith` 404
-      it "can provide a representation" $ do
-        _ <- post "/items"
-          [json| { id: 1 } |]
-        request methodPatch
-          "/items?id=eq.1"
-          [("Prefer", "return=representation")]
-          [json| { id: 99 } |]
-          `shouldRespondWith` [json| [{id:99}] |]
-
-    context "in a table" $ do
-      it "can provide a singular representation when updating one entity" $ do
-        _ <- post "/addresses" [json| { id: 97, address: "A Street" } |]
-        p <- request methodPatch
-          "/addresses?id=eq.97"
-          [("Prefer", "return=representation,plurality=singular")]
-          [json| { address: "B Street" } |]
-        liftIO $ simpleBody p `shouldBe` [str|{"id":97,"address":"B Street"}|]
-      it "raises an error when attempting to update multiple entities with plurality=singular" $ do
-        _ <- post "/addresses" [json| { id: 98, address: "xxx" } |]
-        _ <- post "/addresses" [json| { id: 99, address: "yyy" } |]
-        p <- request methodPatch
-          "/addresses?id=gt.0"
-          [("Prefer", "return=representation,plurality=singular")]
-          [json| { address: "zzz" } |]
-        liftIO $ simpleStatus p `shouldBe` status400
-      it "can provide a singular representation when creating one entity" $ do
-        p <- request methodPost
-          "/addresses"
-          [("Prefer", "return=representation,plurality=singular")]
-          [json| [ { id: 100, address: "xxx" } ] |]
-        liftIO $ simpleBody p `shouldBe` [str|{"id":100,"address":"xxx"}|]
-      it "raises an error when attempting to create multiple entities with plurality=singular" $ do
-        p <- request methodPost
-          "/addresses"
-          [("Prefer", "return=representation,plurality=singular")]
-          [json| [ { id: 100, address: "xxx" }, { id: 101, address: "xxx" } ] |]
-        liftIO $ simpleStatus p `shouldBe` status400
-
       it "can set a json column to escaped value" $ do
         _ <- post "/json" [json| { data: {"escaped":"bar"} } |]
         request methodPatch "/json?data->>escaped=eq.bar"
@@ -390,6 +384,26 @@ spec = do
           , matchHeaders = []
           }
 
+      it "can update based on a computed column" $
+        request methodPatch
+          "/items?always_true=eq.false"
+          [("Prefer", "return=representation")]
+          [json| { id: 100 } |]
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just "[]",
+            matchStatus  = 200,
+            matchHeaders = ["Content-Range" <:> "*/*"]
+          }
+
+      it "can provide a representation" $ do
+        _ <- post "/items"
+          [json| { id: 1 } |]
+        request methodPatch
+          "/items?id=eq.1"
+          [("Prefer", "return=representation")]
+          [json| { id: 99 } |]
+          `shouldRespondWith` [json| [{id:99}] |]
+
     context "with unicode values" $
       it "succeeds and returns values intact" $ do
         void $ request methodPost "/no_pk" []
@@ -411,13 +425,13 @@ spec = do
         [ auth, ("Prefer", "return=representation") ]
         [json| { "secret": "nyancat" } |]
       liftIO $ do
-          simpleBody p1 `shouldBe` [str|{"owner":"jdoe","secret":"nyancat"}|]
+        simpleBody p1 `shouldBe` [str|[{"owner":"jdoe","secret":"nyancat"}]|]
-          simpleStatus p1 `shouldBe` created201
+        simpleStatus p1 `shouldBe` created201
 
       p2 <- request methodPost "/authors_only"
         -- jwt token for jroe
         [ authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqcm9lIn0.YuF_VfmyIxWyuceT7crnNKEprIYXsJAyXid3rjPjIow", ("Prefer", "return=representation") ]
         [json| { "secret": "lolcat", "owner": "hacker" } |]
       liftIO $ do
-          simpleBody p2 `shouldBe` [str|{"owner":"jroe","secret":"lolcat"}|]
+        simpleBody p2 `shouldBe` [str|[{"owner":"jroe","secret":"lolcat"}]|]
-          simpleStatus p2 `shouldBe` created201
+        simpleStatus p2 `shouldBe` created201

test/Feature/QuerySpec.hs

@@ -4,7 +4,7 @@ import Test.Hspec hiding (pendingWith)
 import Test.Hspec.Wai
 import Test.Hspec.Wai.JSON
 import Network.HTTP.Types
-import Network.Wai.Test (SResponse(simpleHeaders))
+import Network.Wai.Test (SResponse(simpleHeaders,simpleStatus,simpleBody))
 
 import SpecHelper
 import Text.Heredoc
@@ -302,44 +302,6 @@ spec = do
       get "/projects?id=in.1,3&select=id,name,client_id,client{id,name}" `shouldRespondWith`
         [str|[{"id":1,"name":"Windows 7","client_id":1,"client":{"id":1,"name":"Microsoft"}},{"id":3,"name":"IOS","client_id":2,"client":{"id":2,"name":"Apple"}}]|]
 
-
-  describe "Plurality singular" $ do
-    it "will select an existing object" $
-      request methodGet "/items?id=eq.5" [("Prefer","plurality=singular")] ""
-        `shouldRespondWith` ResponseMatcher {
-          matchBody    = Just [json| {"id":5} |]
-        , matchStatus  = 200
-        , matchHeaders = []
-        }
-
-    it "can combine multiple prefer values" $
-      request methodGet "/items?id=eq.5" [("Prefer","plurality=singular , future=new, count=none")] ""
-        `shouldRespondWith` ResponseMatcher {
-          matchBody    = Just [json| {"id":5} |]
-        , matchStatus  = 200
-        , matchHeaders = []
-        }
-
-    it "works in the presence of a range header" $
-      let headers = ("Prefer","plurality=singular") :
-            rangeHdrs (ByteRangeFromTo 0 9) in
-      request methodGet "/items" headers ""
-        `shouldRespondWith` ResponseMatcher {
-          matchBody    = Just [json| {"id":1} |]
-        , matchStatus  = 200
-        , matchHeaders = []
-        }
-
-    it "will respond with 404 when not found" $
-      request methodGet "/items?id=eq.9999" [("Prefer","plurality=singular")] ""
-        `shouldRespondWith` 404
-
-    it "can shape plurality singular object routes" $
-      request methodGet "/projects_view?id=eq.1&select=id,name,clients{*},tasks{id,name}" [("Prefer","plurality=singular")] ""
-        `shouldRespondWith`
-          [str|{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}|]
-
-
   describe "ordering response" $ do
     it "by a column asc" $
       get "/items?id=lte.2&order=id.asc"
@@ -531,10 +493,14 @@ spec = do
         post "/rpc/getitemrange" [json| { "min": 2, "max": 4 } |] `shouldRespondWith`
           [json| [ {"id": 3}, {"id":4} ] |]
 
+    context "unknown function" $
+      it "returns 404" $
+        post "/rpc/fakefunc" [json| {} |] `shouldRespondWith` 404
+
     context "shaping the response returned by a proc" $ do
       it "returns a project" $
         post "/rpc/getproject" [json| { "id": 1} |] `shouldRespondWith`
-          [json|[{"id":1,"name":"Windows 7","client_id":1}]|]
+          [str|[{"id":1,"name":"Windows 7","client_id":1}]|]
 
       it "can filter proc results" $
         post "/rpc/getallprojects?id=gt.1&id=lt.5&select=id" [json| {} |] `shouldRespondWith`
@@ -548,20 +514,13 @@ spec = do
              , matchHeaders = ["Content-Range" <:> "1-2/*"]
              }
 
-
-
-      it "prefer singular" $
-        request methodPost "/rpc/getproject"
-          [("Prefer","plurality=singular")] [json| { "id": 1} |] `shouldRespondWith`
-          [json|{"id":1,"name":"Windows 7","client_id":1}|]
-
       it "select works on the first level" $
         post "/rpc/getproject?select=id,name" [json| { "id": 1} |] `shouldRespondWith`
-          [json|[{"id":1,"name":"Windows 7"}]|]
+          [str|[{"id":1,"name":"Windows 7"}]|]
 
       it "can embed foreign entities to the items returned by a proc" $
         post "/rpc/getproject?select=id,name,client{id},tasks{id}" [json| { "id": 1} |] `shouldRespondWith`
-          [json|[{"id":1,"name":"Windows 7","client":{"id":1},"tasks":[{"id":1},{"id":2}]}]|]
+          [str|[{"id":1,"name":"Windows 7","client":{"id":1},"tasks":[{"id":1},{"id":2}]}]|]
 
     context "a proc that returns an empty rowset" $
       it "returns empty json array" $
@@ -582,17 +541,17 @@ spec = do
         request methodPost "/rpc/sayhello"
           (acceptHdrs "audio/mpeg3") [json| { "name": "world" } |]
             `shouldRespondWith` 415
-      it "rejects malformed json payload" $
+      it "rejects malformed json payload" $ do
-        request methodPost "/rpc/sayhello"
+        p <- request methodPost "/rpc/sayhello"
           (acceptHdrs "application/json") "sdfsdf"
-            `shouldRespondWith` 400
+        liftIO $ do
-      -- it used to be 404 and it makes sense but in another part we decided that it's good to return
+          simpleStatus p `shouldBe` badRequest400
-      -- PostgreSQL errors (and have the proxy handle them) and this saves us an aditional query on each rpc request
+          isErrorFormat (simpleBody p) `shouldBe` True
-      it "responds with 400 on an unexisting proc" $
+      it "treats simple plpgsql raise as invalid input" $ do
-        post "/rpc/fake" "{}" `shouldRespondWith` 400
+        p <- post "/rpc/problem" "{}"
-      it "treats simple plpgsql raise as invalid input" $
+        liftIO $ do
-        post "/rpc/problem" "{}" `shouldRespondWith` 400
+          simpleStatus p `shouldBe` badRequest400
-
+          isErrorFormat (simpleBody p) `shouldBe` True
 
     context "unsupported verbs" $ do
       it "DELETE fails" $
@@ -623,7 +582,7 @@ spec = do
           [("Prefer","params=single-object")] [json| { "p1": 1, "p2": "text", "p3" : {"obj":"text"} } |] `shouldRespondWith`
           [json| { "p1": 1, "p2": "text", "p3" : {"obj":"text"} } |]
 
-      it "accepts parameters from an html form" $ 
+      it "accepts parameters from an html form" $
         request methodPost "/rpc/singlejsonparam"
           [("Prefer","params=single-object"),("Content-Type", "application/x-www-form-urlencoded")]
           ("integer=7&double=2.71828&varchar=forms+are+fun&" <>

test/Feature/SingularSpec.hs

@@ -0,0 +1,198 @@
+module Feature.SingularSpec where
+
+import Text.Heredoc
+import Test.Hspec
+import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
+import Network.HTTP.Types
+import Network.Wai.Test (SResponse(..))
+
+import Network.Wai (Application)
+
+import SpecHelper
+import Protolude hiding (get)
+
+
+spec :: SpecWith Application
+spec =
+  describe "Requesting singular json object" $ do
+    let pgrstObj = "application/vnd.pgrst.object+json"
+        singular = ("Accept", pgrstObj)
+
+    context "with GET request" $ do
+      it "fails for zero rows" $
+        request methodGet  "/items?id=gt.0&id=lt.0" [singular] ""
+          `shouldRespondWith` 406
+
+      it "will select an existing object" $ do
+        request methodGet "/items?id=eq.5" [singular] ""
+          `shouldRespondWith` [str|{"id":5}|]
+        -- also test without the +json suffix
+        request methodGet "/items?id=eq.5"
+          [("Accept", "application/vnd.pgrst.object")] ""
+          `shouldRespondWith` [str|{"id":5}|]
+
+      it "can combine multiple prefer values" $
+        request methodGet "/items?id=eq.5" [singular, ("Prefer","count=none")] ""
+          `shouldRespondWith` [str|{"id":5}|]
+
+      it "can shape plurality singular object routes" $
+        request methodGet "/projects_view?id=eq.1&select=id,name,clients{*},tasks{id,name}" [singular] ""
+          `shouldRespondWith`
+            [str|{"id":1,"name":"Windows 7","clients":{"id":1,"name":"Microsoft"},"tasks":[{"id":1,"name":"Design w7"},{"id":2,"name":"Code w7"}]}|]
+
+    context "when updating rows" $ do
+
+      it "works for one row" $ do
+        _ <- post "/addresses" [json| { id: 97, address: "A Street" } |]
+        request methodPatch
+          "/addresses?id=eq.97"
+          [("Prefer", "return=representation"), singular]
+          [json| { address: "B Street" } |]
+          `shouldRespondWith`
+            [str|{"id":97,"address":"B Street"}|]
+
+      it "raises an error for multiple rows" $ do
+        _ <- post "/addresses" [json| { id: 98, address: "xxx" } |]
+        _ <- post "/addresses" [json| { id: 99, address: "yyy" } |]
+        p <- request methodPatch
+          "/addresses?id=gt.0"
+          [("Prefer", "return=representation"), singular]
+          [json| { address: "zzz" } |]
+        liftIO $ do
+          simpleStatus p `shouldBe` notAcceptable406
+          isErrorFormat (simpleBody p) `shouldBe` True
+
+        -- the rows should not be updated, either
+        get "/addresses?id=eq.98" `shouldRespondWith` [str|[{"id":98,"address":"xxx"}]|]
+
+      it "raises an error for zero rows" $ do
+        p <- request methodPatch  "/items?id=gt.0&id=lt.0"
+          [("Prefer", "return=representation"), singular] [json|{"id":1}|]
+        liftIO $ do
+          simpleStatus p `shouldBe` notAcceptable406
+          isErrorFormat (simpleBody p) `shouldBe` True
+
+    context "when creating rows" $ do
+
+      it "works for one row" $ do
+        p <- request methodPost
+          "/addresses"
+          [("Prefer", "return=representation"), singular]
+          [json| [ { id: 100, address: "xxx" } ] |]
+        liftIO $ simpleBody p `shouldBe` [str|{"id":100,"address":"xxx"}|]
+
+      it "works for one row even with return=minimal" $ do
+        request methodPost "/addresses"
+          [("Prefer", "return=minimal"), singular]
+          [json| [ { id: 101, address: "xxx" } ] |]
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just ""
+          , matchStatus  = 201
+          , matchHeaders = ["Content-Range" <:> "*/*"]
+          }
+        -- and the element should exist
+        get "/addresses?id=eq.101"
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just [str|[{"id":101,"address":"xxx"}]|]
+          , matchStatus  = 200
+          , matchHeaders = []
+          }
+
+      it "raises an error when attempting to create multiple entities" $ do
+        p <- request methodPost
+          "/addresses"
+          [("Prefer", "return=representation"), singular]
+          [json| [ { id: 200, address: "xxx" }, { id: 201, address: "yyy" } ] |]
+        liftIO $ simpleStatus p `shouldBe` notAcceptable406
+
+        -- the rows should not exist, either
+        get "/addresses?id=eq.200" `shouldRespondWith` "[]"
+
+      it "return=minimal allows request to create multiple elements" $
+        request methodPost "/addresses"
+          [("Prefer", "return=minimal"), singular]
+          [json| [ { id: 200, address: "xxx" }, { id: 201, address: "yyy" } ] |]
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Just ""
+          , matchStatus  = 201
+          , matchHeaders = ["Content-Range" <:> "*/*"]
+          }
+
+      it "raises an error when creating zero entities" $ do
+        p <- request methodPost
+          "/addresses"
+          [("Prefer", "return=representation"), singular]
+          [json| [ ] |]
+        liftIO $ do
+          simpleStatus p `shouldBe` notAcceptable406
+          isErrorFormat (simpleBody p) `shouldBe` True
+
+    context "when deleting rows" $ do
+
+      it "works for one row" $ do
+        p <- request methodDelete
+          "/items?id=eq.11"
+          [("Prefer", "return=representation"), singular] ""
+        liftIO $ simpleBody p `shouldBe` [str|{"id":11}|]
+
+      it "raises an error when attempting to delete multiple entities" $ do
+        let firstItems = "/items?id=gt.0&id=lt.11"
+        request methodDelete firstItems
+          [("Prefer", "return=representation"), singular] ""
+          `shouldRespondWith` 406
+
+        -- the rows should not exist, either
+        get firstItems
+          `shouldRespondWith` ResponseMatcher {
+            matchBody    = Nothing
+          , matchStatus  = 200
+          , matchHeaders = ["Content-Range" <:> "0-9/*"]
+          }
+
+      it "raises an error when deleting zero entities" $ do
+        p <- request methodDelete "/items?id=lt.0"
+          [("Prefer", "return=representation"), singular] ""
+        liftIO $ do
+          simpleStatus p `shouldBe` notAcceptable406
+          isErrorFormat (simpleBody p) `shouldBe` True
+
+    context "when calling a stored proc" $ do
+
+      it "fails for zero rows" $ do
+        p <- request methodPost "/rpc/getproject"
+          [singular] [json|{ "id": 9999999}|]
+        liftIO $ do
+          simpleStatus p `shouldBe` notAcceptable406
+          isErrorFormat (simpleBody p) `shouldBe` True
+
+      -- this one may be controversial, should vnd.pgrst.object include
+      -- the likes of 2 and "hello?"
+      it "succeeds for scalar result" $
+        request methodPost "/rpc/sayhello"
+          [singular] [json|{ "name": "world"}|]
+          `shouldRespondWith` 200
+
+      it "returns a single object for json proc" $
+        request methodPost "/rpc/getproject"
+          [singular] [json|{ "id": 1}|] `shouldRespondWith`
+          [str|{"id":1,"name":"Windows 7","client_id":1}|]
+
+      it "fails for multiple rows" $ do
+        p <- request methodPost "/rpc/getallprojects" [singular] "{}"
+        liftIO $ do
+          simpleStatus p `shouldBe` notAcceptable406
+          isErrorFormat (simpleBody p) `shouldBe` True
+
+      it "executes the proc exactly once per request" $ do
+        request methodPost "/rpc/getproject?select=id,name" [] [json| {"id": 1} |]
+          `shouldRespondWith` [str|[{"id":1,"name":"Windows 7"}]|]
+        p <- request methodPost "/rpc/setprojects" [singular]
+          [json| {"id_l": 1, "id_h": 2, "name": "changed"} |]
+        liftIO $ do
+          simpleStatus p `shouldBe` notAcceptable406
+          isErrorFormat (simpleBody p) `shouldBe` True
+
+        -- should not actually have executed the function
+        request methodPost "/rpc/getproject?select=id,name" [] [json| {"id": 1} |]
+          `shouldRespondWith` [str|[{"id":1,"name":"Windows 7"}]|]

test/Main.hs

@@ -23,6 +23,7 @@ import qualified Feature.QueryLimitedSpec
 import qualified Feature.QuerySpec
 import qualified Feature.RangeSpec
 import qualified Feature.StructureSpec
+import qualified Feature.SingularSpec
 import qualified Feature.UnicodeSpec
 import qualified Feature.ProxySpec
 
@@ -81,5 +82,6 @@ main = do
     , ("Feature.InsertSpec"       , Feature.InsertSpec.spec)
     , ("Feature.QuerySpec"        , Feature.QuerySpec.spec)
     , ("Feature.RangeSpec"        , Feature.RangeSpec.spec)
+    , ("Feature.SingularSpec"     , Feature.SingularSpec.spec)
     , ("Feature.StructureSpec"    , Feature.StructureSpec.spec)
     ]

test/SpecHelper.hs

@@ -7,9 +7,12 @@ import System.Environment (getEnv)
 
 import qualified Data.ByteString.Base64 as B64 (encode, decodeLenient)
 import Data.CaseInsensitive (CI(..))
+import qualified Data.Set as S
+import qualified Data.Map.Strict as M
 import Data.List (lookup)
 import Text.Regex.TDFA ((=~))
 import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy as BL
 import System.Process (readProcess)
 
 import PostgREST.Config (AppConfig(..))
@@ -21,7 +24,7 @@ import Network.HTTP.Types
 import Network.Wai.Test (SResponse(simpleStatus, simpleHeaders, simpleBody))
 
 import Data.Maybe (fromJust)
-import Data.Aeson (decode)
+import Data.Aeson (decode, Value(..))
 import qualified Data.JsonSchema.Draft4 as D4
 
 import Protolude
@@ -123,3 +126,15 @@ authHeaderBasic u p =
 authHeaderJWT :: BS.ByteString -> Header
 authHeaderJWT token =
   (hAuthorization, "Bearer " <> token)
+
+-- | Tests whether the text can be parsed as a json object comtaining
+-- the key "message", and optional keys "details", "hint", "code",
+-- and no extraneous keys
+isErrorFormat :: BL.ByteString -> Bool
+isErrorFormat s =
+  "message" `S.member` keys &&
+    S.null (S.difference keys validKeys)
+ where
+  obj = decode s :: Maybe (M.Map Text Value)
+  keys = fromMaybe S.empty (M.keysSet <$> obj)
+  validKeys = S.fromList ["message", "details", "hint", "code"]

test/fixtures/schema.sql

@@ -1091,6 +1091,12 @@ CREATE FUNCTION getallprojects() RETURNS SETOF projects
     SELECT * FROM test.projects;
 $_$;
 
+CREATE FUNCTION setprojects(id_l int, id_h int, name text) RETURNS SETOF projects
+    LANGUAGE sql
+    AS $_$
+    update test.projects set name = $3 WHERE id >= $1 AND id <= $2 returning *;
+$_$;
+
 --
 -- PostgreSQL database dump complete
 --