add: implement Pgrst Patch for partial document update

Signed-off-by: Taimoor Zaeem <[email protected]>

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
+- Implement `PGRST Patch` for partial document update 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

@@ -24,12 +24,12 @@ import Network.Wai               (Request (..))
 import Network.Wai.Parse         (parseHttpAccept)
 import Web.Cookie                (parseCookies)
 
-import PostgREST.ApiRequest.Payload      (getPayload)
+import PostgREST.ApiRequest.Payload      (Payload (..), getPayload)
 import PostgREST.ApiRequest.QueryParams  (QueryParams (..))
 import PostgREST.ApiRequest.Types        (Action (..), DbAction (..),
                                           InvokeMethod (..),
-                                          Mutation (..), Payload (..),
-                                          RequestBody, Resource (..))
+                                          Mutation (..), RequestBody,
+                                          Resource (..))
 import PostgREST.Config                  (AppConfig (..),
                                           OpenAPIMode (..))
 import PostgREST.Config.Database         (TimezoneNames)
@@ -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

@@ -8,6 +8,8 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module PostgREST.ApiRequest.Payload
   ( getPayload
+  , Payload (..)
+  , PgrstPatchOp (..)
   ) where
 
 import qualified Data.Aeson            as JSON
@@ -23,8 +25,10 @@ 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 (..))
@@ -37,13 +41,37 @@ import qualified PostgREST.MediaType as MediaType
 
 import Protolude
 
+data Payload
+  = ProcessedJSON -- ^ Cached attributes of a JSON payload
+      { payRaw  :: LBS.ByteString
+      -- ^ This is the raw ByteString that comes from the request body.  We
+      -- cache this instead of an Aeson Value because it was detected that for
+      -- large payloads the encoding had high memory usage, see
+      -- https://github.com/PostgREST/postgrest/pull/1005 for more details
+      , payKeys :: S.Set Text
+      -- ^ 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 }
+  | PgrstPatchPay { payPgrstPatch :: [PgrstPatchOp] } -- ^ PgrstPatchPay is a list of patch updates
+
+-- This type should be in the Types.hs module, but because we
+-- are defining a JSON.FromJSON instance for this type, we need to have
+-- this type here to avoid "no-orphan-instances" warning.
+data PgrstPatchOp
+  = Set FieldName Text
+  -- We can add more operations in the future
+
 getPayload :: RequestBody -> MediaType -> QueryParams -> Action -> Either ApiRequestError (Maybe Payload, S.Set FieldName)
 getPayload reqBody contentMediaType QueryParams{qsColumns} action = do
   checkedPayload <- if shouldParsePayload then payload else Right Nothing
   let cols = case (checkedPayload, columns) of
         (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 +97,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 +120,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 +169,22 @@ 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.
+    case op of
+      "set" -> Set path <$> parseString 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
+
+  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,30 +22,23 @@ 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 (..)
   , RequestBody
+  , Resource (..)
+  , SelectItem(..)
+  , SimpleOperator(..)
+  , SingleVal
   ) where
 
 import qualified Data.ByteString.Lazy as LBS
-import qualified Data.Set             as S
 
 import PostgREST.SchemaCache.Identifiers (FieldName,
                                           QualifiedIdentifier (..),
@@ -56,6 +54,7 @@ data Mutation
   | MutationDelete
   | MutationSingleUpsert
   | MutationUpdate
+  | MutationPgrstPatch
   deriving Eq
 
 data Resource
@@ -77,22 +76,6 @@ data Action
 
 type RequestBody = LBS.ByteString
 
-data Payload
-  = ProcessedJSON -- ^ Cached attributes of a JSON payload
-      { payRaw  :: LBS.ByteString
-      -- ^ This is the raw ByteString that comes from the request body.  We
-      -- cache this instead of an Aeson Value because it was detected that for
-      -- large payloads the encoding had high memory usage, see
-      -- https://github.com/PostgREST/postgrest/pull/1005 for more details
-      , payKeys :: S.Set Text
-      -- ^ 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 }
-
-
 -- | The value in `/tbl?select=alias:field.aggregateFunction()::cast`
 data SelectItem
   = SelectField

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

@@ -38,6 +38,8 @@ import Data.Maybe              (fromJust)
 import Data.Tree               (Tree (..))
 
 import PostgREST.ApiRequest                  (ApiRequest (..))
+import PostgREST.ApiRequest.Payload          (Payload (..),
+                                              PgrstPatchOp (..))
 import PostgREST.Config                      (AppConfig (..))
 import PostgREST.Error                       (ApiRequestError (..),
                                               Error (..),
@@ -974,21 +976,34 @@ mutatePlan :: Mutation -> QualifiedIdentifier -> ApiRequest -> SchemaCache -> Re
 mutatePlan mutation qi ApiRequest{iPreferences=Preferences{..}, ..} SchemaCache{dbTables, dbRepresentations} readReq =
   case mutation of
     MutationCreate ->
-      mapRight (\typedColumns -> Insert qi typedColumns body ((,) <$> preferResolution <*> Just confCols) [] returnings pkCols applyDefaults) typedColumnsOrError
+      mapRight (\typedColumns -> Insert qi typedColumns body ((,) <$> preferResolution <*> Just confCols) [] returnings pkCols applyDefaults) (typedColumnsOrError iColumnsList)
     MutationUpdate ->
-      mapRight (\typedColumns -> Update qi typedColumns body combinedLogic returnings applyDefaults) typedColumnsOrError
+      mapRight (\typedColumns -> Update qi typedColumns body combinedLogic returnings applyDefaults) (typedColumnsOrError iColumnsList)
     MutationSingleUpsert ->
         if null qsLogic &&
            qsFilterFields == S.fromList pkCols &&
            not (null (S.fromList pkCols)) &&
            all (\case
               Filter _ (OpExpr False (OpQuant OpEqual Nothing _)) -> True
               _                                                   -> False) qsFiltersRoot
-          then mapRight (\typedColumns -> Insert qi typedColumns body (Just (MergeDuplicates, pkCols)) combinedLogic returnings mempty False) typedColumnsOrError
+          then mapRight (\typedColumns -> Insert qi typedColumns body (Just (MergeDuplicates, pkCols)) combinedLogic returnings mempty False) (typedColumnsOrError iColumnsList)
         else
           Left $ ApiRequestError InvalidFilters
     MutationDelete -> Right $ Delete qi combinedLogic returnings
+    MutationPgrstPatch ->
+      case pgrstPatchBody of
+        Just bdy ->
+          -- If we have columns query param, then update only those columns.
+          -- Otherwise, update all the fields given in Pgrst Patch body.
+          mapRight (\typedColumns -> PgrstPatch qi typedColumns pgrstPatchBody combinedLogic returnings) (typedColumnsOrError $ if null iColumnsList then map getPgrstPatchFieldName bdy else iColumnsList)
+        Nothing ->
+          Left $ ApiRequestError $ InvalidBody "PGRST Patch Body is missing"
   where
+    iColumnsList = S.toList iColumns
+
+    getPgrstPatchFieldName :: PgrstPatchOp -> FieldName
+    getPgrstPatchFieldName (Set f _) = f
+
     ctx = ResolverContext dbTables dbRepresentations qi "json"
     confCols = fromMaybe pkCols qsOnConflict
     QueryParams.QueryParams{..} = iQueryParams
@@ -1003,8 +1018,9 @@ 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
+    typedColumnsOrError mutCols = resolveOrError ctx tbl `traverse` mutCols
 
 resolveOrError :: ResolverContext -> Table -> FieldName -> Either Error CoercibleField
 resolveOrError ctx table field = case resolveTableFieldName table field Nothing of

src/PostgREST/Plan/MutatePlan.hs

@@ -5,13 +5,13 @@ where
 
 import qualified Data.ByteString.Lazy as LBS
 
+import PostgREST.ApiRequest.Payload      (PgrstPatchOp (..))
 import PostgREST.ApiRequest.Preferences  (PreferResolution)
 import PostgREST.Plan.Types              (CoercibleField,
                                           CoercibleLogicTree)
 import PostgREST.SchemaCache.Identifiers (FieldName,
                                           QualifiedIdentifier)
 
-
 import Protolude
 
 data MutatePlan
@@ -38,3 +38,10 @@ data MutatePlan
       , where_    :: [CoercibleLogicTree]
       , returning :: [FieldName]
       }
+  | PgrstPatch -- A modified version of JSON Patch
+      { in_       :: QualifiedIdentifier
+      , patchCols :: [CoercibleField]
+      , 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