WIP: Insertion memory leak fixed

But a whole lot of other things broken, including updates

src/PostgREST/App.hs

@@ -20,7 +20,6 @@ import           Data.Ranged.Ranges        (emptyRange, singletonRange)
 import           Data.String.Conversions   (cs)
 import           Data.Text                 (Text, replace, strip)
 import           Data.Tree
-import qualified Data.Map                  as M
 import qualified Data.Aeson                as JSON
 
 import           Text.Parsec.Error
@@ -46,7 +45,7 @@ import           PostgREST.DbStructure
 import           PostgREST.RangeQuery
 import           PostgREST.RequestIntent   (Intent(..), ContentType(..)
                                             , Action(..), Target(..)
-                                            , Payload(..), userIntent)
+                                            , userIntent)
 import           PostgREST.Types
 import           PostgREST.Auth            (tokenJWT)
 import           PostgREST.Error           (errResponse)
@@ -114,13 +113,13 @@ app dbStructure conf reqBody req =
                   )
                 ] (fromMaybe "[]" body)
 
-    (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just (PayloadJSON payload)) ->
+    (ActionCreate, TargetIdent (QualifiedIdentifier _ table), Just payload@(PayloadJSON rows)) ->
       case queries of
         Left e -> return $ responseLBS status400 [jsonH] $ cs e
         Right (sq,mq) -> do
-          let isSingle = (==1) $ V.length payload
+          let isSingle = (==1) $ V.length rows
           let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
-          let stm = createWriteStatement sq mq isSingle (iPreferRepresentation intent) pKeys (contentType == TextCSV)
+          let stm = createWriteStatement sq mq isSingle (iPreferRepresentation intent) pKeys (contentType == TextCSV) payload
           row <- H.maybeEx stm
           let (_, _, location, body) = extractQueryResult row
           return $ responseLBS status201
@@ -130,11 +129,11 @@ app dbStructure conf reqBody req =
             ]
             $ if iPreferRepresentation intent then fromMaybe "[]" body else ""
 
-    (ActionUpdate, TargetIdent _, Just (PayloadJSON _)) ->
+    (ActionUpdate, TargetIdent _, Just payload@(PayloadJSON _)) ->
       case queries of
         Left e -> return $ responseLBS status400 [jsonH] $ cs e
         Right (sq,mq) -> do
-          let stm = createWriteStatement sq mq False (iPreferRepresentation intent) [] (contentType == TextCSV)
+          let stm = createWriteStatement sq mq False (iPreferRepresentation intent) [] (contentType == TextCSV) payload
           row <- H.maybeEx stm
           let (_, queryTotal, _, body) = extractQueryResult row
               r = contentRangeH 0 (queryTotal-1) (Just queryTotal)
@@ -148,7 +147,8 @@ app dbStructure conf reqBody req =
       case queries of
         Left e -> return $ responseLBS status400 [jsonH] $ cs e
         Right (sq,mq) -> do
-          let stm = createWriteStatement sq mq False False [] (contentType == TextCSV)
+          let fakeload = PayloadJSON V.empty
+          let stm = createWriteStatement sq mq False False [] (contentType == TextCSV) fakeload
           row <- H.maybeEx stm
           let (_, queryTotal, _, _) = extractQueryResult row
           return $ if queryTotal == 0
@@ -326,28 +326,18 @@ buildMutateApiRequest intent =
   where
     action = iAction intent
     target = iTarget intent
-    rootTableName = fromJust $ -- Make it safe
+    payload = fromJust $ iPayload intent
+    rootTableName = -- TODO: Make it safe
       case target of
-        (TargetIdent (QualifiedIdentifier _ t) ) -> Just t
+        (TargetIdent (QualifiedIdentifier _ t) ) -> t
-        _ -> Nothing
+        _ -> undefined
     mutateApiRequest = case action of
-      ActionCreate -> Node <$> ((,) <$> (Insert rootTableName <$> flds <*> vals)    <*> pure (rootTableName, Nothing)) <*> pure []
+      ActionCreate -> Node <$> ((,) <$> (Insert rootTableName <$> pure payload) <*> pure (rootTableName, Nothing)) <*> pure []
-      ActionUpdate -> Node <$> ((,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)) <*> pure []
+      --ActionUpdate -> Node <$> ((,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)) <*> pure []
       ActionDelete -> Node <$> ((,) <$> (Delete [rootTableName] <$> cond) <*> pure (rootTableName, Nothing)) <*> pure []
       _        -> Left "Unsupported HTTP verb"
-    parseField f = parse pField ("failed to parse field <<"++f++">>") f
-    payload = case iPayload intent of
-      Just (PayloadJSON v) -> JSON.Array v
-      _ -> undefined --TODO! fix
-    parsedBody = checkStructure =<< convertJson payload
-    isSingleRecord = either (const False) ((==1) . length . snd ) parsedBody
-    flds =  join $ first formatParserError . mapM (parseField . cs) <$> (fst <$> parsedBody)
-    vals = snd <$> parsedBody
     mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters intent -- update/delete filters can be only on the root table
     cond = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters
-    setWith = if isSingleRecord
-          then M.fromList <$> (zip <$> flds <*> (head <$> vals))
-          else Left "Expecting a sigle CSV line with header or a JSON object"
 
 addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest
 addFilter ([], flt) (Node (q@(Select {where_=flts}), i) forest) = Node (q {where_=flt:flts}, i) forest
@@ -399,8 +389,9 @@ createReadStatement selectQuery range isSingle countTable asCsv =
     ] selectStarF (if isNothing range && isSingle then Just $ singletonRange 0 else range)
   ) V.empty True
 
-createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> [Text] -> Bool -> B.Stmt P.Postgres
+createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool ->
-createWriteStatement selectQuery mutateQuery isSingle echoRequested pKeys asCsv =
+                        [Text] -> Bool -> Payload -> B.Stmt P.Postgres
+createWriteStatement selectQuery mutateQuery isSingle echoRequested pKeys asCsv (PayloadJSON rows) =
   B.Stmt (
     wrapQuery mutateQuery [
       countNoneF, -- when updateing it does not make sense
@@ -414,7 +405,7 @@ createWriteStatement selectQuery mutateQuery isSingle echoRequested pKeys asCsv
       else "null"
 
     ] selectQuery Nothing
-  ) V.empty True
+  ) (V.singleton . B.encodeValue . JSON.Array $ rows) True
 
 extractQueryResult :: Maybe (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString)
                          -> (Maybe Int, Int, Maybe BL.ByteString, Maybe BL.ByteString)

src/PostgREST/QueryBuilder.hs

@@ -229,33 +229,24 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)
     --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only
     --posible relations are Child Parent Many
     getQueryParts (Node (_,(_,Nothing)) _) _ = undefined
-requestToQuery schema (Node (Insert _ flds vals, (mainTbl, _)) _) =
+requestToQuery schema (Node (Insert _ payload, (mainTbl, _)) _) =
-  query
+  let qi = QualifiedIdentifier schema mainTbl in
-  where
+  unwords [
-    qi = QualifiedIdentifier schema mainTbl
-    query = unwords [
     "INSERT INTO ", fromQi qi,
-      " (" <> intercalate ", " (map (pgFmtIdent . fst) flds) <> ") ",
+    "select * from json_populate_recordset(null::" , fromQi qi, ", ?)",
-      "VALUES " <> intercalate ", "
-        ( map (\v ->
-            "(" <>
-            intercalate ", " ( map insertableValue v ) <>
-            ")"
-          ) vals
-        ),
     "RETURNING " <> fromQi qi <> ".*"
     ]
-requestToQuery schema (Node (Update _ setWith conditions, (mainTbl, _)) _) =
+-- requestToQuery schema (Node (Update _ setWith conditions, (mainTbl, _)) _) =
-  query
+--   query
-  where
+--   where
-    qi = QualifiedIdentifier schema mainTbl
+--     qi = QualifiedIdentifier schema mainTbl
-    query = unwords [
+--     query = unwords [
-      "UPDATE ", fromQi qi,
+--       "UPDATE ", fromQi qi,
-      " SET " <> intercalate ", " (map formatSet (M.toList setWith)) <> " ",
+--       " SET " <> intercalate ", " (map formatSet (M.toList setWith)) <> " ",
-      ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
+--       ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
-      "RETURNING " <> fromQi qi <> ".*"
+--       "RETURNING " <> fromQi qi <> ".*"
-      ]
+--       ]
-    formatSet ((c, jp), v) = pgFmtIdent c <> pgFmtJsonPath jp <> " = " <> insertableValue v
+--     formatSet ((c, jp), v) = pgFmtIdent c <> pgFmtJsonPath jp <> " = " <> insertableValue v
 requestToQuery schema (Node (Delete _ conditions, (mainTbl, _)) _) =
   query
   where

src/PostgREST/RequestIntent.hs

@@ -16,7 +16,8 @@ import qualified Data.Vector             as V
 import           Network.Wai             (Request (..))
 import           Network.Wai.Parse       (parseHttpAccept)
 import           PostgREST.RangeQuery    (NonnegRange, rangeRequested)
-import           PostgREST.Types         (QualifiedIdentifier (..), Schema)
+import           PostgREST.Types         (QualifiedIdentifier (..),
+                                          Schema, Payload(..))
 
 type RequestBody = BL.ByteString
 
@@ -36,12 +37,6 @@ instance Show ContentType where
   show ApplicationJSON = "application/json"
   show TextCSV         = "text/csv"
 
--- | When Hasql supports the COPY command then we can
--- have a special payload just for CSV, but until
--- then CSV is converted to a JSON array.
-data Payload = PayloadJSON JSON.Array
-             | PayloadParseError BS.ByteString
-
 {-|
   Describes what the user wants to do. This data type is a
   translation of the raw elements of an HTTP request into domain

src/PostgREST/Types.hs

@@ -2,8 +2,8 @@ module PostgREST.Types where
 import Data.Text
 import Data.Tree
 import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString      as BS
 import Data.Aeson
-import Data.Map
 
 data DbStructure = DbStructure {
   dbTables :: [Table]
@@ -84,6 +84,12 @@ data Relation = Relation {
 , relLCols2   :: Maybe [Column]
 } deriving (Show, Eq)
 
+-- | When Hasql supports the COPY command then we can
+-- have a special payload just for CSV, but until
+-- then CSV is converted to a JSON array.
+data Payload = PayloadJSON Array
+             | PayloadParseError BS.ByteString
+             deriving (Show, Eq)
 
 type Operator = Text
 data FValue = VText Text | VForeignKey QualifiedIdentifier ForeignKey deriving (Show, Eq)
@@ -95,9 +101,9 @@ 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]] }
+           | Insert { into::Text, qPayload::Payload }
            | Delete { from::[Text], where_::[Filter] }
-           | Update { into::Text, set::Map Field Value, where_::[Filter] } deriving (Show, Eq)
+           | Update { into::Text, qPayload::Payload, 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