Refactor: remove pjKeys from RawJSON

src/PostgREST/ApiRequest.hs

@@ -19,7 +19,6 @@ import qualified Data.ByteString           as BS
 import qualified Data.ByteString.Internal  as BS (c2w)
 import qualified Data.ByteString.Lazy      as BL
 import qualified Data.Csv                  as CSV
-import           Data.Either.Combinators   (mapLeft)
 import qualified Data.List                 as L
 import           Data.List                 (lookup, last, partition)
 import qualified Data.HashMap.Strict       as M
@@ -33,7 +32,6 @@ import           Network.HTTP.Types.Header (hAuthorization, hCookie)
 import           Network.HTTP.Types.URI    (parseSimpleQuery)
 import           Network.Wai               (Request (..))
 import           Network.Wai.Parse         (parseHttpAccept)
-import           PostgREST.Parsers         (pRequestColumns)
 import           PostgREST.RangeQuery      (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset)
 import           Data.Ranged.Boundaries
 import           PostgREST.Types
@@ -90,6 +88,8 @@ data ApiRequest = ApiRequest {
   , iLogic :: [(Text, Text)]
   -- | &select parameter used to shape the response
   , iSelect :: Text
+  -- | &columns parameter used to shape the payload
+  , iColumns :: Maybe Text
   -- | &order parameters for each level
   , iOrder :: [(Text, Text)]
   -- | Alphabetized (canonical) request query string for response URLs
@@ -123,6 +123,7 @@ userApiRequest schema req reqBody
       , iFilters = filters
       , iLogic = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["and", "or"] k ]
       , iSelect = toS $ fromMaybe "*" $ join $ lookup "select" qParams
+      , iColumns = columns
       , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
       , iCanonicalQS = toS $ urlEncodeVars
         . L.sortBy (comparing fst)
@@ -150,19 +151,19 @@ userApiRequest schema req reqBody
   isEmbedPath = T.isInfixOf "."
   isTargetingProc = (== Just "rpc") $ listToMaybe path
   contentType = decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type"
+  columns | action `elem` [ActionCreate, ActionUpdate, ActionInvoke{isReadOnly=False}] = toS <$> join (lookup "columns" qParams)
+          | otherwise = Nothing
   payload =
     case (contentType, action) of
       (_, ActionInvoke{isReadOnly=True}) ->
         Right $ ProcessedJSON (JSON.encode $ M.fromList $ second JSON.toJSON <$> rpcQParams) PJObject (S.fromList $ fst <$> rpcQParams)
       (CTApplicationJSON, _) ->
-        let columns | action `elem` [ActionCreate, ActionUpdate, ActionInvoke{isReadOnly=False}] = toS <$> join (lookup "columns" qParams)
-                    | otherwise = Nothing in
-        case columns of
-          Just cols -> RawJSON reqBody <$> mapLeft show (pRequestColumns cols)
-          Nothing   -> note "All object keys must match" . payloadAttributes reqBody
-                         =<< if BL.null reqBody && isTargetingProc
-                               then Right emptyObject
-                               else JSON.eitherDecode reqBody
+        if isJust columns
+          then Right $ RawJSON reqBody
+          else note "All object keys must match" . payloadAttributes reqBody
+                 =<< if BL.null reqBody && isTargetingProc
+                       then Right emptyObject
+                       else JSON.eitherDecode reqBody
       (CTTextCSV, _) -> do
         json <- csvToJson <$> CSV.decodeByName reqBody
         note "All lines must have same number of fields" $ payloadAttributes (JSON.encode json) json

src/PostgREST/App.hs

@@ -56,6 +56,7 @@ import           PostgREST.QueryBuilder ( callProc
                                         , createWriteStatement
                                         , ResultsWithCount
                                         )
+import           PostgREST.Parsers      (pRequestColumns)
 import           PostgREST.Types
 import           PostgREST.OpenAPI
 
@@ -74,33 +75,29 @@ postgrest conf refDbStructure pool getTime worker =
     case maybeDbStructure of
       Nothing -> respond connectionLostError
       Just dbStructure -> do
-        response <- case userApiRequest (configSchema conf) req body of
-          Left err -> return $ apiRequestError err
-          Right apiRequest -> do
-            eClaims <- jwtClaims jwtSecret (configJwtAudience conf) (toS $ iJWT apiRequest) time (rightToMaybe $ configRoleClaimKey conf)
-            let authed = containsRole eClaims
-                proc = case (iTarget apiRequest, iPayload apiRequest, iPreferSingleObjectParameter apiRequest) of
-                  (TargetProc qi, Just pJson, s) -> findProc qi (pjKeys pJson) s $ dbProcs dbStructure
-                  _ -> Nothing
-                handleReq = runWithClaims conf eClaims (app dbStructure proc conf) apiRequest
-                txMode = transactionMode proc (iAction apiRequest)
-            response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq
-            return $ either (pgError authed) identity response
+        response <- do
+          -- Need to parse ?columns early because findProc needs it to solve overloaded functions
+          let apiReq = userApiRequest (configSchema conf) req body
+              apiReqCols = (,) <$> apiReq <*> (pRequestColumns =<< iColumns <$> apiReq)
+          case apiReqCols of
+            Left err -> return $ apiRequestError err
+            Right (apiRequest, maybeCols) -> do
+              eClaims <- jwtClaims jwtSecret (configJwtAudience conf) (toS $ iJWT apiRequest) time (rightToMaybe $ configRoleClaimKey conf)
+              let authed = containsRole eClaims
+                  cols = case (iPayload apiRequest, maybeCols) of
+                    (Just ProcessedJSON{pjKeys}, _) -> pjKeys
+                    (Just RawJSON{}, Just cls)      -> cls
+                    _                               -> S.empty
+                  proc = case iTarget apiRequest of
+                    TargetProc qi -> findProc qi cols (iPreferSingleObjectParameter apiRequest) $ dbProcs dbStructure
+                    _ -> Nothing
+                  handleReq = runWithClaims conf eClaims (app dbStructure proc cols conf) apiRequest
+                  txMode = transactionMode proc (iAction apiRequest)
+              response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq
+              return $ either (pgError authed) identity response
         when (responseStatus response == status503) worker
         respond response
 
-findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> M.HashMap Text [ProcDescription] -> Maybe ProcDescription
-findProc qi payloadKeys paramsAsSingleObject allProcs =
-  let procs = M.lookup (qiName qi) allProcs in
- -- Handle overloaded functions case
-  join $ (case length <$> procs of
-    Just 1 -> headMay -- if it's not an overloaded function then immediatly get the ProcDescription
-    _ -> find (\x ->
-           if paramsAsSingleObject
-             then length (pdArgs x) == 1 -- if the arg is not of json type let the db give the err
-             else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs x))
-  ) <$> procs
-
 transactionMode :: Maybe ProcDescription -> Action -> HT.Mode
 transactionMode proc action =
   case action of
@@ -115,8 +112,8 @@ transactionMode proc action =
     ActionInvoke{isReadOnly=True} -> HT.Read
     _ -> HT.Write
 
-app :: DbStructure -> Maybe ProcDescription -> AppConfig -> ApiRequest -> H.Transaction Response
-app dbStructure proc conf apiRequest =
+app :: DbStructure -> Maybe ProcDescription -> S.Set FieldName -> AppConfig -> ApiRequest -> H.Transaction Response
+app dbStructure proc cols conf apiRequest =
   case responseContentTypeOrError (iAccepts apiRequest) (iAction apiRequest) of
     Left errorResponse -> return errorResponse
     Right contentType ->
@@ -189,7 +186,7 @@ app dbStructure proc conf apiRequest =
               row <- H.statement (toS $ pjRaw pJson) stm
               let (_, queryTotal, _, body) = extractQueryResult row
 
-                  updateIsNoOp       = S.null $ pjKeys pJson
+                  updateIsNoOp       = S.null cols
                   contentRangeHeader = contentRangeH 0 (queryTotal - 1) $
                                           if shouldCount then Just queryTotal else Nothing
                   minimalHeaders     = [contentRangeHeader]
@@ -285,7 +282,7 @@ app dbStructure proc conf apiRequest =
             Left errorResponse -> return errorResponse
             Right ((q, cq), bField) -> do
               let singular = contentType == CTSingularJSON
-                  specifiedPgArgs = filter ((`S.member` pjKeys pJson) . pgaName) $ maybe [] pdArgs proc
+                  specifiedPgArgs = filter ((`S.member` cols) . pgaName) $ maybe [] pdArgs proc
               row <- H.statement (toS $ pjRaw pJson) $
                 callProc qi specifiedPgArgs returnsScalar q cq shouldCount
                          singular (iPreferSingleObjectParameter apiRequest)
@@ -339,7 +336,7 @@ app dbStructure proc conf apiRequest =
       selectQuery = requestToQuery schema False <$> readDbRequest
       countQuery = requestToCountQuery schema <$> readDbRequest
       readSqlParts = (,) <$> selectQuery <*> countQuery
-      mutationDbRequest s t = mutateRequest apiRequest t (tablePKCols dbStructure s t) =<< fldNames
+      mutationDbRequest s t = mutateRequest apiRequest t cols (tablePKCols dbStructure s t) =<< fldNames
       mutateSqlParts s t =
         (,) <$> selectQuery
             <*> (requestToQuery schema False . DbMutate <$> mutationDbRequest s t)

src/PostgREST/DbRequestBuilder.hs

@@ -318,11 +318,11 @@ addProperty f (targetNodeName:remainingPath, a) (Node rn forest) =
   where
     pathNode = find (\(Node (_,(nodeName,_,alias,_,_)) _) -> nodeName == targetNodeName || alias == Just targetNodeName) forest
 
-mutateRequest :: ApiRequest -> TableName -> [Text] -> [FieldName] -> Either Response MutateRequest
-mutateRequest apiRequest tName pkCols fldNames = mapLeft apiRequestError $
+mutateRequest :: ApiRequest -> TableName -> S.Set FieldName -> [FieldName] -> [FieldName] -> Either Response MutateRequest
+mutateRequest apiRequest tName cols pkCols fldNames = mapLeft apiRequestError $
   case action of
-    ActionCreate -> Right $ Insert tName pjCols ((,) <$> iPreferResolution apiRequest <*> Just pkCols) [] returnings
-    ActionUpdate -> Update tName pjCols <$> combinedLogic <*> pure returnings
+    ActionCreate -> Right $ Insert tName cols ((,) <$> iPreferResolution apiRequest <*> Just pkCols) [] returnings
+    ActionUpdate -> Update tName cols <$> combinedLogic <*> pure returnings
     ActionSingleUpsert ->
       (\flts ->
         if null (iLogic apiRequest) &&
@@ -331,14 +331,13 @@ mutateRequest apiRequest tName pkCols fldNames = mapLeft apiRequestError $
            all (\case
               Filter _ (OpExpr False (Op "eq" _)) -> True
               _ -> False) flts
-          then Insert tName pjCols (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings
+          then Insert tName cols (Just (MergeDuplicates, pkCols)) <$> combinedLogic <*> pure returnings
         else
           Left InvalidFilters) =<< filters
     ActionDelete -> Delete tName <$> combinedLogic <*> pure returnings
     _            -> Left UnsupportedVerb
   where
     action = iAction apiRequest
-    pjCols = pjKeys $ fromJust $ iPayload apiRequest
     returnings = if iPreferRepresentation apiRequest == None then [] else fldNames
     filters = map snd <$> mapM pRequestFilter mutateFilters
     logic = map snd <$> mapM pRequestLogicTree logicFilters

src/PostgREST/Parsers.hs

@@ -56,6 +56,13 @@ pRequestLogicTree (k, v) = mapError $ (,) <$> embedPath <*> logicTree
     -- Concat op and v to make pLogicTree argument regular, in the form of "?and=and(.. , ..)" instead of "?and=(.. , ..)"
     logicTree = join $ parse pLogicTree ("failed to parse logic tree (" ++ toS v ++ ")") . toS <$> ((<>) <$> op <*> pure v)
 
+pRequestColumns :: Maybe Text -> Either ApiRequestError (Maybe (S.Set FieldName))
+pRequestColumns colStr =
+  case colStr of
+    Just str ->
+      mapError $ Just . S.fromList <$> parse pColumns ("failed to parse columns parameter (" <> toS str <> ")") (toS str)
+    _ -> Right Nothing
+
 ws :: Parser Text
 ws = toS <$> many (oneOf " \t")
 
@@ -218,10 +225,6 @@ pLogicPath = do
       notOp = "not." <> op
   return (filter (/= "not") (init path), if "not" `elem` path then notOp else op)
 
-pRequestColumns :: Text -> Either ParseError (S.Set FieldName)
-pRequestColumns colStr =
-  S.fromList <$> parse pColumns ("failed to parse columns parameter (" <> toS colStr <> ")") (toS colStr)
-
 pColumns :: Parser [FieldName]
 pColumns = pFieldName `sepBy1` lexeme (char ',')
 

src/PostgREST/Types.hs

@@ -95,6 +95,22 @@ instance Ord ProcDescription where
     | name1 == name2 && length args1 > length args2  = GT
     | otherwise = (name1, des1, args1, rt1, vol1) `compare` (name2, des2, args2, rt2, vol2)
 
+{-|
+  Search a pg procedure by its parameters, since a function can be overloaded the name is not enough to find it.
+  An overloaded function can have a different volatility or even a different return type.
+-}
+findProc :: QualifiedIdentifier -> S.Set Text -> Bool -> M.HashMap Text [ProcDescription] -> Maybe ProcDescription
+findProc qi payloadKeys paramsAsSingleObject allProcs =
+  let procs = M.lookup (qiName qi) allProcs in
+ -- Handle overloaded functions case
+  join $ (case length <$> procs of
+    Just 1 -> headMay -- if it's not an overloaded function then immediatly get the ProcDescription
+    _ -> find (\x ->
+           if paramsAsSingleObject
+             then length (pdArgs x) == 1 -- if the arg is not of json type let the db give the err
+             else payloadKeys `S.isSubsetOf` S.fromList (pgaName <$> pdArgs x))
+  ) <$> procs
+
 type Schema = Text
 type TableName = Text
 type SqlQuery = Text
@@ -200,7 +216,6 @@ data PayloadJSON =
   }|
   RawJSON {
     pjRaw  :: BL.ByteString
-  , pjKeys :: S.Set Text
   } deriving (Show, Eq)
 
 data PJType = PJArray { pjaLength :: Int } | PJObject deriving (Show, Eq)

test/Feature/InsertSpec.hs

@@ -533,7 +533,7 @@ spec actualPgVersion = do
           simpleBody p `shouldBe` "["<>payload<>"]"
           simpleStatus p `shouldBe` ok200
 
-    context "PATCH with ?columns parameter" $
+    context "PATCH with ?columns parameter" $ do
       it "ignores json keys not included in ?columns" $
         request methodPatch "/articles?id=eq.200&columns=body" [("Prefer", "return=representation")]
           [json| {"body": "Some real content", "smth": "here", "other": "stuff", "fake_id": 13} |] `shouldRespondWith`
@@ -541,6 +541,10 @@ spec actualPgVersion = do
           { matchStatus  = 200
           , matchHeaders = [] }
 
+      it "ignores json keys and gives 404 if no record updated" $
+        request methodPatch "/articles?id=eq.2001&columns=body" [("Prefer", "return=representation")]
+          [json| {"body": "Some real content", "smth": "here", "other": "stuff", "fake_id": 13} |] `shouldRespondWith` 404
+
   describe "Row level permission" $
     it "set user_id when inserting rows" $ do
       let auth = authHeaderJWT "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJyb2xlIjoicG9zdGdyZXN0X3Rlc3RfYXV0aG9yIiwiaWQiOiJqZG9lIn0.B-lReuGNDwAlU1GOC476MlO0vAt9JNoHIlxg2vwMaO0"