PATCH path rewriten in new style

src/PostgREST/App.hs

@@ -22,7 +22,7 @@ import qualified Data.ByteString.Char8     as BS
 import qualified Data.ByteString.Lazy      as BL
 import qualified Data.Csv                  as CSV
 import           Data.Functor.Identity
-import qualified Data.HashMap.Strict       as M
+import qualified Data.HashMap.Strict       as HM
 import           Data.List                 (find, sortBy, delete, transpose)
 import           Data.Maybe                (fromMaybe, fromJust, isJust, isNothing, mapMaybe)
 import           Data.Ord                  (comparing)
@@ -31,6 +31,7 @@ import qualified Data.Set                  as S
 import           Data.String.Conversions   (cs)
 import           Data.Text                 (Text, replace, strip)
 import           Data.Tree
+import qualified Data.Map as M
 --import           Data.Foldable             (forlrM)
 
 import           Text.Parsec.Error
@@ -169,10 +170,10 @@ app dbstructure conf reqBody req =
             "You must speficy all and only primary keys as params"
           else do
             let tableCols = map (cs . colName) $ filter (filterCol schema table) allCols
-                cols = map cs $ M.keys obj
+                cols = map cs $ HM.keys obj
             if S.fromList tableCols == S.fromList cols
               then do
-                let vals = M.elems obj
+                let vals = HM.elems obj
                 H.unitEx $ iffNotT
                   (whereT qt qq $ update qt cols vals)
                   (insertSelect qt cols vals)
@@ -183,25 +184,49 @@ app dbstructure conf reqBody req =
                 else responseLBS status400 []
                   "You must specify all columns in PUT request"
 
-    ([table], "PATCH") ->
+    ([table], "PATCH") -> do
-      handleJsonObj reqBody $ \obj -> do
+      let echoRequested = hasPrefer "return=representation"
-        let qt = qualify table
+      case queries of
-            up = returningStarT
+        Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
-              . whereT qt qq
+        Right (qu, qs) -> do
-              $ update qt (map cs $ M.keys obj) (M.elems obj)
+          let q = B.Stmt
-            patch = withT up "t" $ B.Stmt
+                    (
-              "select count(t), array_to_json(array_agg(row_to_json(t)))::character varying"
+                      wrapQuery qu [
+                        countF,
+                        if echoRequested
+                        then
+                          case contentType of
+                             "text/csv" -> asCsvF
+                             _     -> asJsonF
+                        else "null"
+
+                      ] qs Nothing
+                    )
                     V.empty True
 
-        row <- H.maybeEx patch
+          row <- H.maybeEx q
-        let (queryTotal, body) =
+          let (queryTotal, bodyRaw) = fromMaybe (0::Int, Just "" :: Maybe BL.ByteString) row
-              fromMaybe (0 :: Int, Just "" :: Maybe Text) row
+              body = fromMaybe "[]" bodyRaw
               r = contentRangeH 0 (queryTotal-1) (Just queryTotal)
-            echoRequested = hasPrefer "return=representation"
               s = case () of _ | queryTotal == 0 -> status404
                                | echoRequested -> status200
                                | otherwise -> status204
-        return $ responseLBS s [ jsonH, r ] $ if echoRequested then cs $ fromMaybe "[]" body else ""
+          --return $ responseLBS s [ jsonH, r ] $ if echoRequested then cs $ fromMaybe "[]" body else ""
+          return $ responseLBS s
+            [
+              contentTypeH,
+              r
+            ]
+            $ if echoRequested then body else ""
+
+      where
+        res = parsePatchRequest table req reqBody
+        updateApiRequest = fst <$> res
+        updateQuery = requestToQuery schema <$> updateApiRequest
+        selectApiRequest = (snd <$> res) >>= augumentRequestWithJoin schema (fakeSourceRelations ++ allRels)
+        selectQuery = requestToQuery schema <$> selectApiRequest
+        queries = (,) <$> updateQuery <*> selectQuery
+        fakeSourceRelations = mapMaybe (toSourceRelation table) allRels
 
     ([table], "DELETE") -> do
       let qt = qualify table
@@ -221,7 +246,7 @@ app dbstructure conf reqBody req =
       if exists
         then do
           let call = B.Stmt "select " V.empty True <>
-                asJson (callProc qi $ fromMaybe M.empty (decode reqBody))
+                asJson (callProc qi $ fromMaybe HM.empty (decode reqBody))
           bodyJson :: Maybe (Identity Value) <- H.maybeEx call
           returnJWT <- doesProcReturnJWT schema proc
           return $ responseLBS status200 [jsonH]
@@ -360,6 +385,32 @@ formatParserError e = cs $ encode $ object [
      details = strip $ replace "\n" " " $ cs
        $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
 
+parsePatchRequest :: NodeName -> Request -> BL.ByteString -> Either Text (ApiRequest, ApiRequest)
+parsePatchRequest rootTableName httpRequest reqBody =
+  (,) <$> updateApiRequest <*> returnApiRequest
+  where
+    updateApiRequest = Node <$> apiNode <*> pure []
+    apiNode = (,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)
+    flds =  join $ first formatParserError . mapM (parseField . cs) <$> (fst <$> parsed)
+    vals = head.snd <$> parsed -- TODO! cheack if head is safe here
+    parseField f = parse pField ("failed to parse field <<"++f++">>") f
+    parsed :: Either Text ([Text],[[Value]])
+    parsed = parseRequestBody isCsv reqBody
+    returnSingle = (==1) . length . snd <$> parsed
+    isSingle = either (const False) id returnSingle
+    setWith = if isSingle
+          then M.fromList <$> (zip <$> flds <*> vals)
+          else Left "Expecting a sigle CSV line with header or a JSON object"
+    hdrs          = requestHeaders httpRequest
+    lookupHeader  = flip lookup hdrs
+    --rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
+    isCsv = lookupHeader "Content-Type" == Just csvMT
+    qParams = queryParams httpRequest
+    selectFilters = filter (( '.' `elem` ) . fst) $ whereFilters qParams -- there can be no filters on the root table whre we are doing insert
+    updateFilters = filter (not . ( '.' `elem` ) . fst) $ whereFilters qParams -- update filters can be only on the root table
+    returnApiRequest = buildSelectApiRequest sourceSubqueryName (selectStr qParams) selectFilters (orderStr qParams)
+    cond = first formatParserError $ map snd <$> mapM pRequestFilter updateFilters
+
 -- quite ugly return type
 parsePostRequest :: NodeName -> Request -> BL.ByteString -> Either Text ((Bool, ApiRequest), ApiRequest)
 parsePostRequest rootTableName httpRequest reqBody =
@@ -378,7 +429,8 @@ parsePostRequest rootTableName httpRequest reqBody =
     --rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
     isCsv = lookupHeader "Content-Type" == Just csvMT
     qParams = queryParams httpRequest
-    returnApiRequest = buildSelectApiRequest sourceSubqueryName (selectStr qParams) (whereFilters qParams) (orderStr qParams)
+    filters = filter (( '.' `elem` ) . fst) $ whereFilters qParams -- there can be no filters on the root table whre we are doing insert
+    returnApiRequest = buildSelectApiRequest sourceSubqueryName (selectStr qParams) filters (orderStr qParams)
 
 
 parseRequestBody :: Bool -> BL.ByteString -> Either Text ([Text],[[Value]])
@@ -422,11 +474,11 @@ convertJson v = (,) <$> (header <$> normalized) <*> (vals <$> normalized)
     header = map fst
 
     groupByKey :: Value -> Either String [(Text,[Value])]
-    groupByKey (Array a) = M.toList . foldr (M.unionWith (++)) (M.fromList []) <$> maps
+    groupByKey (Array a) = HM.toList . foldr (HM.unionWith (++)) (HM.fromList []) <$> maps
       where
-        maps :: Either String [M.HashMap Text [Value]]
+        maps :: Either String [HM.HashMap Text [Value]]
         maps = mapM getElems $ V.toList a
-        getElems (Object o) = Right $ M.map (:[]) o
+        getElems (Object o) = Right $ HM.map (:[]) o
         getElems _ = Left invalidMsg
     groupByKey _ = Left invalidMsg
 

src/PostgREST/QueryBuilder.hs

@@ -12,8 +12,9 @@ import           Control.Applicative
 import           Data.Tree
 import           PostgREST.PgQuery (fromQi, pgFmtCondition, pgFmtSelectItem,
                                     pgFmtIdent, pgFmtCondition,
-                                    insertableValue, orderF, sourceSubqueryName)
+                                    insertableValue, orderF, sourceSubqueryName, pgFmtJsonPath)
 import           PostgREST.Types
+import qualified Data.Map as M
 --import qualified Data.Vector       as V (empty)
 --import qualified Hasql.Backend     as B
 
@@ -87,6 +88,9 @@ addJoinConditions schema (Node (query, (t, r)) forest) =
 --         fn  (Filter{value=VForeignKey _ _}) = False
 
 --requestToQuery :: Text -> ApiRequest -> PStmt
+emptyOnNull :: Text -> [a] -> Text
+emptyOnNull val x = if null x then "" else val
+
 requestToQuery :: Text -> ApiRequest -> Text
 requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)) forest) =
   --orderT (fromMaybe [] ord)  query
@@ -114,7 +118,7 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)
       ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
       orderF (fromMaybe [] ord)
       ]
-    emptyOnNull val x = if null x then "" else val
+
     (withs, selects) = foldr getQueryParts ([],[]) forest
     getQueryParts :: Tree ApiNode -> ([Text], [Text]) -> ([Text], [Text])
     getQueryParts (Node n@(_, (table, Just (Relation {relType=Child}))) forst) (w,s) = (w,sel:s)
@@ -149,9 +153,7 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)
 requestToQuery schema (Node (Insert _ flds vals, (mainTbl, _)) _) =
   query
   where
-    --query = B.Stmt qStr V.empty True
     qi = QualifiedIdentifier schema mainTbl
-    --qStr = Data.Text.unwords [
     query = Data.Text.unwords [
       "INSERT INTO ", fromQi qi,
       " (" <> intercalate ", " (map (pgFmtIdent . fst) flds) <> ") ",
@@ -164,13 +166,14 @@ requestToQuery schema (Node (Insert _ flds vals, (mainTbl, _)) _) =
         ),
       "RETURNING " <> fromQi qi <> ".*"
       ]
-    -- ("insert into " <> fromQi t <> " (" <>
+requestToQuery schema (Node (Update _ setWith conditions, (mainTbl, _)) _) =
-    --   T.intercalate ", " (V.toList $ V.map pgFmtIdent cols) <>
+  query
-    --   ") values "
+  where
-    --   <> T.intercalate ", "
+    qi = QualifiedIdentifier schema mainTbl
-    --     (V.toList $ V.map (\v -> "("
+    query = Data.Text.unwords [
-    --         <> T.intercalate ", " (V.toList $ V.map insertableValue v)
+      "UPDATE ", fromQi qi,
-    --         <> ")"
+      " SET " <> intercalate ", " (map formatSet (M.toList setWith)) <> " ",
-    --       ) vals
+      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
-    --     )
+      "RETURNING " <> fromQi qi <> ".*"
-    --   <> " returning row_to_json(" <> fromQi t <> ".*)")
+      ]
+    formatSet ((c, jp), v) = pgFmtIdent c <> pgFmtJsonPath jp <> " = " <> insertableValue v

src/PostgREST/Types.hs

@@ -3,7 +3,7 @@ import Data.Text
 import Data.Tree
 import qualified Data.ByteString.Char8 as BS
 import Data.Aeson
---import Data.Map
+import Data.Map
 
 data DbStructure = DbStructure {
   tables :: [Table]
@@ -80,8 +80,8 @@ type NodeName = Text
 type SelectItem = (Field, Maybe Cast)
 type Path = [Text]
 data Query = Select { select::[SelectItem], from::[Text], where_::[Filter], order::Maybe [OrderTerm] }
-           | Insert { into::Text, fields::[Field], values::[[Value]] } deriving (Show, Eq)
+           | Insert { into::Text, fields::[Field], values::[[Value]] }
---           | Update { into::Text, set::Map Field Value, where_::[Filter] } deriving (Show, Eq)
+           | Update { into::Text, set::Map Field Value, where_::[Filter] } deriving (Show, Eq)
 data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq)
 type ApiNode = (Query, (NodeName, Maybe Relation))
 type ApiRequest = Tree ApiNode