add: partial document update using Pgrst Patch

Signed-off-by: Taimoor Zaeem <taimoorzaeem@gmail.com>

Author: taimoorzaeem

CHANGELOG.md

@@ -12,6 +12,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
   + The exposed schemas are now listed in the `hint` instead of the `message` field.
 - Improve error details of `PGRST301` error by @taimoorzaeem in #4051
 - Bounded JWT cache using the SIEVE algorithm by @mkleczek in #4084
+- Add partial document update using PGRST Patch by @taimoorzaeem in #3166
 
 ### Fixed
 

postgrest.cabal

@@ -239,6 +239,7 @@ test-suite spec
                       Feature.Query.JsonOperatorSpec
                       Feature.Query.MultipleSchemaSpec
                       Feature.Query.NullsStripSpec
+                      Feature.Query.PgrstPatchSpec
                       Feature.Query.PgSafeUpdateSpec
                       Feature.Query.PlanSpec
                       Feature.Query.PostGISSpec

src/PostgREST/ApiRequest.hs

@@ -80,7 +80,7 @@ userApiRequest :: AppConfig -> Preferences.Preferences -> Request -> RequestBody
 userApiRequest conf prefs req reqBody = do
   resource <- getResource conf $ pathInfo req
   (schema, negotiatedByProfile) <- getSchema conf hdrs method
-  act <- getAction resource schema method
+  act <- getAction resource schema method contentMediaType
   qPrms <- first QueryParamError $ QueryParams.parse (actIsInvokeSafe act) $ rawQueryString req
   (topLevelRange, ranges) <- getRanges method qPrms hdrs
   (payload, columns) <- getPayload reqBody contentMediaType qPrms act
@@ -126,8 +126,8 @@ getResource AppConfig{configOpenApiMode, configDbRootSpec} = \case
   ["rpc", pName] -> Right $ ResourceRoutine pName
   _              -> Left InvalidResourcePath
 
-getAction :: Resource -> Schema -> ByteString -> Either ApiRequestError Action
-getAction resource schema method =
+getAction :: Resource -> Schema -> ByteString -> MediaType -> Either ApiRequestError Action
+getAction resource schema method mediaType =
   case (resource, method) of
     (ResourceRoutine rout, "HEAD")    -> Right . ActDb $ ActRoutine (qi rout) $ InvRead True
     (ResourceRoutine rout, "GET")     -> Right . ActDb $ ActRoutine (qi rout) $ InvRead False
@@ -139,9 +139,11 @@ getAction resource schema method =
     (ResourceRelation rel, "GET")     -> Right . ActDb $ ActRelationRead (qi rel) False
     (ResourceRelation rel, "POST")    -> Right . ActDb $ ActRelationMut  (qi rel) MutationCreate
     (ResourceRelation rel, "PUT")     -> Right . ActDb $ ActRelationMut  (qi rel) MutationSingleUpsert
-    (ResourceRelation rel, "PATCH")   -> Right . ActDb $ ActRelationMut  (qi rel) MutationUpdate
     (ResourceRelation rel, "DELETE")  -> Right . ActDb $ ActRelationMut  (qi rel) MutationDelete
     (ResourceRelation rel, "OPTIONS") -> Right $ ActRelationInfo (qi rel)
+    (ResourceRelation rel, "PATCH")   -> case mediaType of -- do pgrst patch with vendored pgrst patch content-type
+        MTVndPgrstPatch -> Right . ActDb $ ActRelationMut (qi rel) MutationPgrstPatch
+        _               -> Right . ActDb $ ActRelationMut (qi rel) MutationUpdate
 
     (ResourceSchema, "HEAD")          -> Right . ActDb $ ActSchemaRead schema True
     (ResourceSchema, "GET")           -> Right . ActDb $ ActSchemaRead schema False

src/PostgREST/ApiRequest/Payload.hs

@@ -6,6 +6,7 @@
 --
 {-# LANGUAGE LambdaCase     #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module PostgREST.ApiRequest.Payload
   ( getPayload
   ) where
@@ -18,13 +19,16 @@ import qualified Data.ByteString.Lazy  as LBS
 import qualified Data.Csv              as CSV
 import qualified Data.HashMap.Strict   as HM
 import qualified Data.Map.Strict       as M
+import qualified Data.Scientific       as Sci
 import qualified Data.Set              as S
 import qualified Data.Text.Encoding    as T
 import qualified Data.Vector           as V
 
 import Control.Arrow           ((***))
+import Control.Monad           (fail)
+import Data.Aeson              ((.:))
 import Data.Aeson.Types        (emptyArray, emptyObject)
-import Data.Either.Combinators (mapBoth)
+import Data.Either.Combinators (mapBoth, mapLeft)
 import Network.HTTP.Types.URI  (parseSimpleQuery)
 
 import PostgREST.ApiRequest.QueryParams  (QueryParams (..))
@@ -44,6 +48,7 @@ getPayload reqBody contentMediaType QueryParams{qsColumns} action = do
         (Just ProcessedJSON{payKeys}, _)       -> payKeys
         (Just ProcessedUrlEncoded{payKeys}, _) -> payKeys
         (Just RawJSON{}, Just cls)             -> cls
+        (Just PgrstPatchPay{}, Just cls)       -> cls
         _                                      -> S.empty
   return (checkedPayload, cols)
   where
@@ -69,8 +74,12 @@ getPayload reqBody contentMediaType QueryParams{qsColumns} action = do
       (MTTextPlain, True) -> Right $ RawPay reqBody
       (MTTextXML, True) -> Right $ RawPay reqBody
       (MTOctetStream, True) -> Right $ RawPay reqBody
+      (MTVndPgrstPatch, False) -> PgrstPatchPay <$> parsePgrstPatch reqBody
       (ct, _) -> Left $ "Content-Type not acceptable: " <> MediaType.toMime ct
 
+    parsePgrstPatch :: LBS.ByteString -> Either ByteString [PgrstPatchOp]
+    parsePgrstPatch = mapLeft BS.pack . JSON.eitherDecode
+
     shouldParsePayload = case action of
       ActDb (ActRelationMut _ MutationDelete) -> False
       ActDb (ActRelationMut _ _)              -> True
@@ -88,6 +97,7 @@ getPayload reqBody contentMediaType QueryParams{qsColumns} action = do
       _                      -> False
     params = (T.decodeUtf8 *** T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody)
 
+
 type CsvData = V.Vector (M.Map Text LBS.ByteString)
 
 {-|
@@ -136,3 +146,32 @@ payloadAttributes raw json =
     _ -> Just emptyPJArray
   where
     emptyPJArray = ProcessedJSON (JSON.encode emptyArray) S.empty
+
+
+instance JSON.FromJSON PgrstPatchOp where
+  parseJSON (JSON.Object o) = do
+    op    <- parseString o "op"
+    path  <- parseString o "path"
+    -- TODO: We need to decide what JSON "value"s are allowed in our
+    --       our Pgrst Patch implementation.
+    --       For now, we only have incr operator, so it's number only
+    case op of
+      "incr" -> Incr path <$> parseNumber o "value"
+      _      -> fail $ "Unknown Pgrst Patch operation " ++ show op
+    where
+      parseString obj key = do
+        val <- obj .: key
+        case val of
+          JSON.String txt -> pure txt
+          _               -> fail $ "Expected JSON string for " ++ show key
+
+      parseNumber obj key = do
+        val <- obj .: key
+        case val of
+          JSON.Number num -> pure $ sciToInt num
+          _               -> fail $ "Expected JSON number for " ++ show key
+        where
+          sciToInt :: Sci.Scientific -> Int
+          sciToInt = fromMaybe 0 . Sci.toBoundedInteger
+
+  parseJSON _ = mzero

src/PostgREST/ApiRequest/Types.hs

@@ -1,14 +1,19 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 module PostgREST.ApiRequest.Types
   ( AggregateFunction(..)
+  , Action (..)
   , Alias
   , Cast
+  , DbAction (..)
   , Depth
   , EmbedParam(..)
   , EmbedPath
   , Field
   , Filter(..)
+  , FtsOperator(..)
   , Hint
+  , InvokeMethod (..)
+  , IsVal(..)
   , JoinType(..)
   , JsonOperand(..)
   , JsonOperation(..)
@@ -17,26 +22,22 @@ module PostgREST.ApiRequest.Types
   , ListVal
   , LogicOperator(..)
   , LogicTree(..)
+  , Mutation (..)
   , NodeName
   , OpExpr(..)
-  , Operation (..)
   , OpQuantifier(..)
+  , Operation (..)
   , OrderDirection(..)
   , OrderNulls(..)
   , OrderTerm(..)
-  , SingleVal
-  , IsVal(..)
-  , SimpleOperator(..)
-  , QuantOperator(..)
-  , FtsOperator(..)
-  , SelectItem(..)
   , Payload (..)
-  , InvokeMethod (..)
-  , Mutation (..)
-  , Resource (..)
-  , DbAction (..)
-  , Action (..)
+  , PgrstPatchOp (..)
+  , QuantOperator(..)
   , RequestBody
+  , Resource (..)
+  , SelectItem(..)
+  , SimpleOperator(..)
+  , SingleVal
   ) where
 
 import qualified Data.ByteString.Lazy as LBS
@@ -56,6 +57,7 @@ data Mutation
   | MutationDelete
   | MutationSingleUpsert
   | MutationUpdate
+  | MutationPgrstPatch
   deriving Eq
 
 data Resource
@@ -88,10 +90,15 @@ data Payload
       -- ^ Keys of the object or if it's an array these keys are guaranteed to
       -- be the same across all its objects
       }
-  | ProcessedUrlEncoded { payArray  :: [(Text, Text)], payKeys :: S.Set Text }
-  | RawJSON { payRaw  :: LBS.ByteString }
-  | RawPay  { payRaw  :: LBS.ByteString }
+  | ProcessedUrlEncoded { payArray :: [(Text, Text)], payKeys :: S.Set Text }
+  | RawJSON      { payRaw   :: LBS.ByteString }
+  | RawPay       { payRaw   :: LBS.ByteString }
+  | PgrstPatchPay { payPgrstPatch :: [PgrstPatchOp] } -- ^ PgrstPatchPay is a list of patch updates
+
 
+data PgrstPatchOp
+  = Incr FieldName Int
+  -- We can add more operations in the future
 
 -- | The value in `/tbl?select=alias:field.aggregateFunction()::cast`
 data SelectItem

src/PostgREST/MediaType.hs

@@ -37,6 +37,7 @@ data MediaType
   -- vendored media types
   | MTVndArrayJSONStrip
   | MTVndSingularJSON Bool
+  | MTVndPgrstPatch
   -- TODO MTVndPlan should only have its options as [Text]. Its ResultAggregate should have the typed attributes.
   | MTVndPlan MediaType MTVndPlanFormat [MTVndPlanOption]
   deriving (Eq, Show, Generic, JSON.ToJSON)
@@ -72,6 +73,7 @@ toMime MTTextXML              = "text/xml"
 toMime MTOpenAPI              = "application/openapi+json"
 toMime (MTVndSingularJSON True)  = "application/vnd.pgrst.object+json;nulls=stripped"
 toMime (MTVndSingularJSON False) = "application/vnd.pgrst.object+json"
+toMime MTVndPgrstPatch        = "application/vnd.pgrst.patch+json"
 toMime MTUrlEncoded           = "application/x-www-form-urlencoded"
 toMime MTOctetStream          = "application/octet-stream"
 toMime MTAny                  = "*/*"
@@ -121,6 +123,9 @@ toMimePlanFormat PlanText = "text"
 -- >>> decodeMediaType "application/vnd.pgrst.object+json"
 -- MTVndSingularJSON False
 --
+-- >>> decodeMediaType "application/vnd.pgrst.patch+json"
+-- MTVndPgrstPatch
+--
 -- Test uppercase is parsed correctly (per issue #3478)
 -- >>> decodeMediaType "ApplicatIon/vnd.PgRsT.object+json"
 -- MTVndSingularJSON False
@@ -147,6 +152,7 @@ decodeMediaType mt = decodeMediaType' $ decodeLatin1 mt
         ("application", "vnd.pgrst.plan+json", _)   -> getPlan PlanJSON
         ("application", "vnd.pgrst.object+json", _) -> MTVndSingularJSON strippedNulls
         ("application", "vnd.pgrst.object", _)      -> MTVndSingularJSON strippedNulls
+        ("application", "vnd.pgrst.patch+json", _)  -> MTVndPgrstPatch
         ("application", "vnd.pgrst.array+json", _)  -> checkArrayNullStrip
         ("application", "vnd.pgrst.array", _)       -> checkArrayNullStrip
         ("*","*",_)                                 -> MTAny

src/PostgREST/Plan.hs

@@ -988,6 +988,7 @@ mutatePlan mutation qi ApiRequest{iPreferences=Preferences{..}, ..} SchemaCache{
         else
           Left $ ApiRequestError InvalidFilters
     MutationDelete -> Right $ Delete qi combinedLogic returnings
+    MutationPgrstPatch -> Right $ PgrstPatch qi pgrstPatchBody combinedLogic returnings
   where
     ctx = ResolverContext dbTables dbRepresentations qi "json"
     confCols = fromMaybe pkCols qsOnConflict
@@ -1003,6 +1004,7 @@ mutatePlan mutation qi ApiRequest{iPreferences=Preferences{..}, ..} SchemaCache{
     logic = map (resolveLogicTree ctx . snd) qsLogic
     combinedLogic = foldr (addFilterToLogicForest . resolveFilter ctx) logic qsFiltersRoot
     body = payRaw <$> iPayload -- the body is assumed to be json at this stage(ApiRequest validates)
+    pgrstPatchBody = payPgrstPatch <$> iPayload
     applyDefaults = preferMissing == Just ApplyDefaults
     typedColumnsOrError = resolveOrError ctx tbl `traverse` S.toList iColumns
 

src/PostgREST/Plan/MutatePlan.hs

@@ -6,12 +6,12 @@ where
 import qualified Data.ByteString.Lazy as LBS
 
 import PostgREST.ApiRequest.Preferences  (PreferResolution)
+import PostgREST.ApiRequest.Types        (PgrstPatchOp (..))
 import PostgREST.Plan.Types              (CoercibleField,
                                           CoercibleLogicTree)
 import PostgREST.SchemaCache.Identifiers (FieldName,
                                           QualifiedIdentifier)
 
-
 import Protolude
 
 data MutatePlan
@@ -38,3 +38,9 @@ data MutatePlan
       , where_    :: [CoercibleLogicTree]
       , returning :: [FieldName]
       }
+  | PgrstPatch -- A modified version of JSON Patch
+      { in_       :: QualifiedIdentifier
+      , patchBody :: Maybe [PgrstPatchOp]
+      , where_    :: [CoercibleLogicTree]
+      , returning :: [FieldName]
+      }

src/PostgREST/Query.hs

@@ -150,6 +150,8 @@ actionQuery (DbCrud plan@MutateReadPlan{..}) conf@AppConfig{..} apiReq@ApiReques
       MutationDelete -> do
         failNotSingular mrMedia resultSet
         failExceedsMaxAffectedPref (preferMaxAffected,preferHandling) resultSet
+      MutationPgrstPatch -> do
+        failExceedsMaxAffectedPref (preferMaxAffected,preferHandling) resultSet
     mainActionQuery = do
       resultSet <- lift $ SQL.statement mempty result
       failMutation resultSet

src/PostgREST/Query/QueryBuilder.hs

@@ -119,6 +119,7 @@ getJoin fld node@(Node ReadPlan{relJoinType, relSpread} _) =
         correlatedSubquery (selectSubqAgg <> fromSubqAgg) aggAlias joinCondition
 
 mutatePlanToQuery :: MutatePlan -> SQL.Snippet
+-- INSERT: Corresponds to HTTP POST and PUT methods
 mutatePlanToQuery (Insert mainQi iCols body onConflict putConditions returnings _ applyDefaults) =
   "INSERT INTO " <> fromQi mainQi <> (if null iCols then " " else "(" <> cols <> ") ") <>
   fromJsonBodyF body iCols True False applyDefaults <>
@@ -142,6 +143,7 @@ mutatePlanToQuery (Insert mainQi iCols body onConflict putConditions returnings
     cols = intercalateSnippet ", " $ pgFmtIdent . cfName <$> iCols
     mergeDups = case onConflict of {Just (MergeDuplicates,_) -> True; _ -> False;}
 
+-- UPDATE: Corresponds to HTTP PATCH method
 mutatePlanToQuery (Update mainQi uCols body logicForest returnings applyDefaults)
   | null uCols =
     -- if there are no columns we cannot do UPDATE table SET {empty}, it'd be invalid syntax
@@ -161,13 +163,45 @@ mutatePlanToQuery (Update mainQi uCols body logicForest returnings applyDefaults
     emptyBodyReturnedColumns = if null returnings then "NULL" else intercalateSnippet ", " (pgFmtColumn (QualifiedIdentifier mempty $ qiName mainQi) <$> returnings)
     cols = intercalateSnippet ", " (pgFmtIdent . cfName <> const " = " <> pgFmtColumn (QualifiedIdentifier mempty "pgrst_body") . cfName <$> uCols)
 
+-- DELETE: Corresponds to HTTP DELETE method
 mutatePlanToQuery (Delete mainQi logicForest returnings) =
   "DELETE FROM " <> fromQi mainQi <> " " <>
   whereLogic <> " " <>
   returningF mainQi returnings
   where
     whereLogic = if null logicForest then mempty else " WHERE " <> intercalateSnippet " AND " (pgFmtLogicTree mainQi <$> logicForest)
 
+-- PGRST PATCH: HTTP PATCH method with "vnd.pgrst.patch+json" Content-Type
+mutatePlanToQuery (PgrstPatch mainQi body logicForest returnings) =
+  "UPDATE " <> fromQi mainQi <> " SET "
+  <> "(" <> intercalateSnippet "," cols <> ")"
+  <> " = "
+  <> "ROW(" <> intercalateSnippet "," vals <> ") "
+  <> whereLogic <> " "
+  <> returningF mainQi returnings
+  where
+    -- TODO: At this stage, there must be a body. The Maybe comes from
+    --       ApiRequest which should be refactored later to avoid 'fromJust'
+    patchBody = fromJust body
+
+    cols :: [SQL.Snippet]
+    cols = map getFieldName patchBody
+      where
+        getFieldName :: PgrstPatchOp -> SQL.Snippet
+        getFieldName (Incr field _) = pgFmtIdent field
+
+    vals :: [SQL.Snippet]
+    vals = map getValAndApplyOp patchBody
+      where
+        intToSnip = SQL.sql . BS.pack . show
+
+        getValAndApplyOp :: PgrstPatchOp -> SQL.Snippet
+        getValAndApplyOp (Incr field val) =
+          pgFmtIdent field <> " + CAST(" <> intToSnip val <> " AS INTEGER)"
+
+    whereLogic = if null logicForest then mempty else " WHERE " <> intercalateSnippet " AND " (pgFmtLogicTree mainQi <$> logicForest)
+
+
 callPlanToQuery :: CallPlan -> SQL.Snippet
 callPlanToQuery (FunctionCall qi params arguments returnsScalar returnsSetOfScalar filterFields returnings) =
   "SELECT " <> (if returnsScalar || returnsSetOfScalar then "pgrst_call.pgrst_scalar" else returnedColumns) <> " " <>