add: partial document update using JSON Patch

Author: taimoorzaeem

postgrest.cabal

@@ -231,6 +231,7 @@ test-suite spec
                       Feature.Query.ErrorSpec
                       Feature.Query.InsertSpec
                       Feature.Query.JsonOperatorSpec
+                      Feature.Query.JsonPatchSpec
                       Feature.Query.MultipleSchemaSpec
                       Feature.Query.NullsStripSpec
                       Feature.Query.PgSafeUpdateSpec

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,7 +139,9 @@ 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, "PATCH")   -> case mediaType of -- we support JSON Patch on json-patch content-type
+        MTVndJSONPatch -> Right . ActDb $ ActRelationMut  (qi rel) MutationJsonPatch
+        _              -> Right . ActDb $ ActRelationMut  (qi rel) MutationUpdate
     (ResourceRelation rel, "DELETE")  -> Right . ActDb $ ActRelationMut  (qi rel) MutationDelete
     (ResourceRelation rel, "OPTIONS") -> Right $ ActRelationInfo (qi rel)
 

src/PostgREST/ApiRequest/Payload.hs

@@ -6,6 +6,7 @@
 --
 {-# LANGUAGE LambdaCase     #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module PostgREST.ApiRequest.Payload
   ( getPayload
   ) where
@@ -23,6 +24,8 @@ 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 Network.HTTP.Types.URI  (parseSimpleQuery)
@@ -44,6 +47,7 @@ getPayload reqBody contentMediaType QueryParams{qsColumns} action = do
         (Just ProcessedJSON{payKeys}, _)       -> payKeys
         (Just ProcessedUrlEncoded{payKeys}, _) -> payKeys
         (Just RawJSON{}, Just cls)             -> cls
+        (Just JSONPatchPay{}, Just cls)        -> cls
         _                                      -> S.empty
   return (checkedPayload, cols)
   where
@@ -69,6 +73,11 @@ getPayload reqBody contentMediaType QueryParams{qsColumns} action = do
       (MTTextPlain, True) -> Right $ RawPay reqBody
       (MTTextXML, True) -> Right $ RawPay reqBody
       (MTOctetStream, True) -> Right $ RawPay reqBody
+      (MTVndJSONPatch, False) ->
+        case parseJSONPatch reqBody of
+          Just jsonPatchBody -> Right $ JSONPatchPay jsonPatchBody
+          Nothing            -> Left "Couldn't parse JSON Patch body"
+
       (ct, _) -> Left $ "Content-Type not acceptable: " <> MediaType.toMime ct
 
     shouldParsePayload = case action of
@@ -88,6 +97,10 @@ getPayload reqBody contentMediaType QueryParams{qsColumns} action = do
       _                      -> False
     params = (T.decodeUtf8 *** T.decodeUtf8) <$> parseSimpleQuery (LBS.toStrict reqBody)
 
+    parseJSONPatch :: LBS.ByteString -> Maybe [JSONPatchOp]
+    parseJSONPatch = JSON.decode
+
+
 type CsvData = V.Vector (M.Map Text LBS.ByteString)
 
 {-|
@@ -136,3 +149,21 @@ payloadAttributes raw json =
     _ -> Just emptyPJArray
   where
     emptyPJArray = ProcessedJSON (JSON.encode emptyArray) S.empty
+
+
+instance JSON.FromJSON JSONPatchOp where
+  parseJSON (JSON.Object o) = do
+    op    <- parseString o "op"
+    path  <- parseString o "path"
+    case op of
+      "incr"    -> Incr    path <$> parseString o "value"
+      "replace" -> Replace path <$> parseString o "value"
+      _         -> fail $ "Unknown JSON Patch operation" ++ show op
+    where
+      parseString obj key = do
+        val <- obj .: key
+        case val of
+          JSON.String txt -> pure txt
+          _               -> fail $ "Expected string for " ++ show key
+
+  parseJSON _ = fail "Expected JSON Object for JSONPatch"

src/PostgREST/ApiRequest/Types.hs

@@ -1,14 +1,20 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 module PostgREST.ApiRequest.Types
   ( AggregateFunction(..)
+  , Action (..)
   , Alias
   , Cast
+  , DbAction (..)
   , Depth
   , EmbedParam(..)
   , EmbedPath
   , Field
   , Filter(..)
+  , FtsOperator(..)
   , Hint
+  , InvokeMethod (..)
+  , IsVal(..)
+  , JSONPatchOp (..)
   , JoinType(..)
   , JsonOperand(..)
   , JsonOperation(..)
@@ -17,26 +23,21 @@ 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 (..)
+  , QuantOperator(..)
   , RequestBody
+  , Resource (..)
+  , SelectItem(..)
+  , SimpleOperator(..)
+  , SingleVal
   ) where
 
 import qualified Data.ByteString.Lazy as LBS
@@ -56,6 +57,7 @@ data Mutation
   | MutationDelete
   | MutationSingleUpsert
   | MutationUpdate
+  | MutationJsonPatch
   deriving Eq
 
 data Resource
@@ -88,10 +90,18 @@ 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 }
+  | JSONPatchPay { payJSONPatch :: [JSONPatchOp] } -- ^ JSONPatchPay is a list of JSON Patch updates
+
+
+data JSONPatchOp
+  = Incr    FieldName PatchValue
+  | Replace FieldName PatchValue
+  -- Add more operations
 
+type PatchValue = Text
 
 -- | 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
+  | MTVndJSONPatch
   -- 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 MTVndJSONPatch         = "application/vnd.pgrst.json-patch"
 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.json-patch"
+-- MTVndJSONPatch
+--
 -- 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.json-patch", _)  -> MTVndJSONPatch
         ("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
+    MutationJsonPatch -> Right $ JSONPatch qi jsonPatchBody combinedLogic returnings
   where
     ctx = ResolverContext dbTables dbRepresentations qi "json"
     confCols = fromMaybe pkCols qsOnConflict
@@ -1003,6 +1004,8 @@ 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)
+    jsonPatchBody = payJSONPatch <$> iPayload
+
     applyDefaults = preferMissing == Just ApplyDefaults
     typedColumnsOrError = resolveOrError ctx tbl `traverse` S.toList iColumns
 

src/PostgREST/Plan/MutatePlan.hs

@@ -6,6 +6,7 @@ where
 import qualified Data.ByteString.Lazy as LBS
 
 import PostgREST.ApiRequest.Preferences  (PreferResolution)
+import PostgREST.ApiRequest.Types        (JSONPatchOp (..))
 import PostgREST.Plan.Types              (CoercibleField,
                                           CoercibleLogicTree)
 import PostgREST.SchemaCache.Identifiers (FieldName,
@@ -38,3 +39,9 @@ data MutatePlan
       , where_    :: [CoercibleLogicTree]
       , returning :: [FieldName]
       }
+  | JSONPatch -- JSON Patch for partial document update (not fully RFC compliant for now)
+      { in_       :: QualifiedIdentifier
+      , patchBody :: Maybe [JSONPatchOp]
+      , 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
+      MutationJsonPatch -> do
+        failExceedsMaxAffectedPref (preferMaxAffected,preferHandling) resultSet
     mainActionQuery = do
       resultSet <- lift $ SQL.statement mempty result
       failMutation resultSet

src/PostgREST/Query/QueryBuilder.hs

@@ -21,6 +21,7 @@ import qualified Data.Aeson                      as JSON
 import qualified Data.ByteString.Char8           as BS
 import qualified Data.HashMap.Strict             as HM
 import qualified Data.Set                        as S
+import qualified Data.Text.Encoding              as T
 import qualified Hasql.DynamicStatements.Snippet as SQL
 import qualified Hasql.Encoders                  as HE
 
@@ -119,6 +120,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 +144,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 +164,48 @@ 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)
 
+-- JSON PATCH: HTTP PATCH method with custom json-patch Content-Type
+mutatePlanToQuery (JSONPatch 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 :: JSONPatchOp -> SQL.Snippet
+        getFieldName jspOp = SQL.sql $ T.encodeUtf8 $
+          case jspOp of
+            Incr    field _ -> field
+            Replace field _ -> field
+
+    vals :: [SQL.Snippet]
+    vals = map getValAndApplyOp patchBody
+      where
+        getValAndApplyOp :: JSONPatchOp -> SQL.Snippet
+        getValAndApplyOp jspOp = SQL.sql $ T.encodeUtf8 $
+          case jspOp of
+            Incr    field val -> field <> " + CAST(" <> val <> " AS INTEGER)"
+            Replace _     val -> val
+
+    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) <> " " <>