feat: max-changes prefer header to limit mutations

src/PostgREST/App.hs

@@ -360,11 +360,12 @@ handleUpdate identifier context@(RequestContext _ _ ApiRequest{..} _) = do
       RangeQuery.contentRangeH 0 (resQueryTotal - 1) $
         if shouldCount iPreferCount then Just resQueryTotal else Nothing
 
-  failNotSingular iAcceptContentType resQueryTotal $
-    if fullRepr then
-      response status (contentTypeHeaders context ++ [contentRangeHeader]) (LBS.fromStrict resBody)
-    else
-      response status [contentRangeHeader] mempty
+  failChangesOffLimits iPreferMaxChanges resQueryTotal =<<
+    failNotSingular iAcceptContentType resQueryTotal
+      (if fullRepr then
+        response status (contentTypeHeaders context ++ [contentRangeHeader]) (LBS.fromStrict resBody)
+      else
+        response status [contentRangeHeader] mempty)
 
 handleSingleUpsert :: QualifiedIdentifier -> RequestContext-> DbHandler Wai.Response
 handleSingleUpsert identifier context@(RequestContext _ _ ApiRequest{..} _) = do
@@ -563,6 +564,16 @@ gucResponse gucStatus gucHeaders status headers =
   Wai.responseLBS (fromMaybe status gucStatus) $
     addHeadersIfNotIncluded headers (map unwrapGucHeader gucHeaders)
 
+failChangesOffLimits :: Maybe Int -> Int64 -> Wai.Response -> DbHandler Wai.Response
+failChangesOffLimits (Just maxChanges) queryTotal response =
+  if queryTotal > fromIntegral maxChanges then
+    do
+      lift SQL.condemn
+      throwError $ Error.OffLimitsChangesError queryTotal maxChanges
+  else
+    return response
+failChangesOffLimits _ _ response = return response
+
 -- |
 -- Fail a response if a single JSON object was requested and not exactly one
 -- was found.

src/PostgREST/Error.hs

@@ -280,6 +280,7 @@ data Error
   | PutMatchingPkError
   | PutRangeNotAllowedError
   | SingularityError Integer
+  | OffLimitsChangesError Int64 Int
   | UnsupportedVerb Text
 
 instance PgrstError Error where
@@ -296,6 +297,7 @@ instance PgrstError Error where
   status PutMatchingPkError      = HTTP.status400
   status PutRangeNotAllowedError = HTTP.status400
   status SingularityError{}      = HTTP.status406
+  status OffLimitsChangesError{} = HTTP.status400
   status UnsupportedVerb{}       = HTTP.status405
 
   headers (ApiRequestError err)  = headers err
@@ -324,6 +326,10 @@ instance JSON.ToJSON Error where
     "message" .= ("JSON object requested, multiple (or no) rows returned" :: Text),
     "details" .= T.unwords ["Results contain", show n, "rows,", T.decodeUtf8 (ContentType.toMime CTSingularJSON), "requires 1 row"]]
 
+  toJSON (OffLimitsChangesError n maxs) = JSON.object [
+    "message" .= ("The maximum number of rows changed per operation was surpassed" :: Text),
+    "details" .= T.unwords ["Results contain", show n, "rows changed but the maximum number allowed is", show maxs]]
+
   toJSON JwtTokenMissing           = JSON.object [
     "message" .= ("Server lacks JWT secret" :: Text)]
   toJSON (JwtTokenInvalid message) = JSON.object [

src/PostgREST/Request/ApiRequest.hs

@@ -160,6 +160,7 @@ data ApiRequest = ApiRequest {
   , iPreferCount          :: Maybe PreferCount                -- ^ Whether the client wants a result count
   , iPreferResolution     :: Maybe PreferResolution           -- ^ Whether the client wants to UPSERT or ignore records on PK conflict
   , iPreferTransaction    :: Maybe PreferTransaction          -- ^ Whether the clients wants to commit or rollback the transaction
+  , iPreferMaxChanges     :: Maybe Int
   , iQueryParams          :: QueryParams.QueryParams
   , iColumns              :: S.Set FieldName                  -- ^ parsed colums from &columns parameter and payload
   , iHeaders              :: [(ByteString, ByteString)]       -- ^ HTTP request headers
@@ -197,6 +198,7 @@ apiRequest conf@AppConfig{..} dbStructure req reqBody queryparams@QueryParams{..
       , iPreferCount = preferCount
       , iPreferResolution = preferResolution
       , iPreferTransaction = preferTransaction
+      , iPreferMaxChanges  = preferMaxChanges
       , iQueryParams = queryparams
       , iColumns = payloadColumns
       , iHeaders = [ (CI.foldedCase k, v) | (k,v) <- hdrs, k /= hCookie]

src/PostgREST/Request/Preferences.hs

@@ -42,6 +42,7 @@ data Preferences
     , preferParameters     :: Maybe PreferParameters
     , preferCount          :: Maybe PreferCount
     , preferTransaction    :: Maybe PreferTransaction
+    , preferMaxChanges     :: Maybe Int
     }
 
 -- |
@@ -91,13 +92,14 @@ data Preferences
 --
 -- Preferences can be separated by arbitrary amounts of space, lower-case header is also recognized:
 --
--- >>> pPrint $ fromHeaders [("prefer", "count=exact,    tx=commit   ,return=minimal")]
+-- >>> pPrint $ fromHeaders [("prefer", "count=exact,    tx=commit   ,return=minimal,  max-changes=20")]
 -- Preferences
 --     { preferResolution = Nothing
 --     , preferRepresentation = Just None
 --     , preferParameters = Nothing
 --     , preferCount = Just ExactCount
 --     , preferTransaction = Just Commit
+--     , preferMaxChanges  = Just 20
 --     }
 --
 fromHeaders :: [HTTP.Header] -> Preferences
@@ -108,14 +110,19 @@ fromHeaders headers =
     , preferParameters = parsePrefs [SingleObject, MultipleObjects]
     , preferCount = parsePrefs [ExactCount, PlannedCount, EstimatedCount]
     , preferTransaction = parsePrefs [Commit, Rollback]
+    , preferMaxChanges =  parseMaxChanges
     }
   where
     prefHeaders = filter ((==) HTTP.hPrefer . fst) headers
     prefs = fmap BS.strip . concatMap (BS.split ',' . snd) $ prefHeaders
 
+    parseMaxChanges =
+      fmap fst . BS.readInt =<<
+      head (mapMaybe (BS.stripPrefix "max-changes=") prefs)
+
     parsePrefs :: ToHeaderValue a => [a] -> Maybe a
     parsePrefs vals =
-      head $ mapMaybe (flip Map.lookup $ prefMap vals) prefs
+      head $ mapMaybe (`Map.lookup` prefMap vals) prefs
 
     prefMap :: ToHeaderValue a => [a] -> Map.Map ByteString a
     prefMap = Map.fromList . fmap (\pref -> (toHeaderValue pref, pref))

test/spec/Feature/Query/QueryLimitedSpec.hs

@@ -77,3 +77,17 @@ spec =
             , matchHeaders = [ matchContentTypeJson
                              , "Content-Range" <:> "0-1/3" ]
             }
+
+changesSpec :: SpecWith ((), Application)
+changesSpec =
+  describe "Requests with Prefer: max-changes" $
+    it "fails if the PATCHed rows surpass the maximum allowed" $
+      request methodPatch "/projects"
+          [("Prefer", "max-changes=1")]
+          [json| { name: "PopOS" } |]
+        `shouldRespondWith`
+          [json| {
+            "details": "Results contain 5 rows changed but the maximum number allowed is 1",
+            "message": "The maximum number of rows changed per operation was surpassed"
+          }|]
+          { matchStatus = 400 }

test/spec/Main.hs

@@ -120,23 +120,24 @@ main = do
         analyzeTable "child_entities"
 
       specs = uncurry describe <$> [
-          ("Feature.Query.AndOrParamsSpec"         , Feature.Query.AndOrParamsSpec.spec actualPgVersion)
-        , ("Feature.Auth.AuthSpec"                 , Feature.Auth.AuthSpec.spec actualPgVersion)
-        , ("Feature.ConcurrentSpec"                , Feature.ConcurrentSpec.spec)
-        , ("Feature.CorsSpec"                      , Feature.CorsSpec.spec)
-        , ("Feature.Query.DeleteSpec"              , Feature.Query.DeleteSpec.spec)
-        , ("Feature.Query.EmbedDisambiguationSpec" , Feature.Query.EmbedDisambiguationSpec.spec)
-        , ("Feature.Query.EmbedInnerJoinSpec"      , Feature.Query.EmbedInnerJoinSpec.spec)
-        , ("Feature.Query.InsertSpec"              , Feature.Query.InsertSpec.spec actualPgVersion)
-        , ("Feature.Query.JsonOperatorSpec"        , Feature.Query.JsonOperatorSpec.spec actualPgVersion)
-        , ("Feature.OpenApi.OpenApiSpec"           , Feature.OpenApi.OpenApiSpec.spec actualPgVersion)
-        , ("Feature.OptionsSpec"                   , Feature.OptionsSpec.spec actualPgVersion)
-        , ("Feature.Query.QuerySpec"               , Feature.Query.QuerySpec.spec actualPgVersion)
-        , ("Feature.Query.RawOutputTypesSpec"      , Feature.Query.RawOutputTypesSpec.spec)
-        , ("Feature.Query.RpcSpec"                 , Feature.Query.RpcSpec.spec actualPgVersion)
-        , ("Feature.Query.SingularSpec"            , Feature.Query.SingularSpec.spec)
-        , ("Feature.Query.UpdateSpec"              , Feature.Query.UpdateSpec.spec)
-        , ("Feature.Query.UpsertSpec"              , Feature.Query.UpsertSpec.spec actualPgVersion)
+          ("Feature.Query.AndOrParamsSpec"              , Feature.Query.AndOrParamsSpec.spec actualPgVersion)
+        , ("Feature.Auth.AuthSpec"                      , Feature.Auth.AuthSpec.spec actualPgVersion)
+        , ("Feature.ConcurrentSpec"                     , Feature.ConcurrentSpec.spec)
+        , ("Feature.CorsSpec"                           , Feature.CorsSpec.spec)
+        , ("Feature.Query.DeleteSpec"                   , Feature.Query.DeleteSpec.spec)
+        , ("Feature.Query.EmbedDisambiguationSpec"      , Feature.Query.EmbedDisambiguationSpec.spec)
+        , ("Feature.Query.EmbedInnerJoinSpec"           , Feature.Query.EmbedInnerJoinSpec.spec)
+        , ("Feature.Query.InsertSpec"                   , Feature.Query.InsertSpec.spec actualPgVersion)
+        , ("Feature.Query.JsonOperatorSpec"             , Feature.Query.JsonOperatorSpec.spec actualPgVersion)
+        , ("Feature.OpenApi.OpenApiSpec"                , Feature.OpenApi.OpenApiSpec.spec actualPgVersion)
+        , ("Feature.OptionsSpec"                        , Feature.OptionsSpec.spec actualPgVersion)
+        , ("Feature.Query.QuerySpec"                    , Feature.Query.QuerySpec.spec actualPgVersion)
+        , ("Feature.Query.RawOutputTypesSpec"           , Feature.Query.RawOutputTypesSpec.spec)
+        , ("Feature.Query.RpcSpec"                      , Feature.Query.RpcSpec.spec actualPgVersion)
+        , ("Feature.Query.SingularSpec"                 , Feature.Query.SingularSpec.spec)
+        , ("Feature.Query.UpdateSpec"                   , Feature.Query.UpdateSpec.spec)
+        , ("Feature.Query.UpsertSpec"                   , Feature.Query.UpsertSpec.spec actualPgVersion)
+        , ("Feature.Query.QueryLimitedSpec.changesSpec" , Feature.Query.QueryLimitedSpec.changesSpec)
         ]
 
   hspec $ do