jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

WIP: Insertion memory leak fixed

Browse Source 
But a whole lot of other things broken, including updates
This commit is contained in:
Joe Nelson
2015-11-20 13:08:23 -08:00
parent f54742186b
commit 60007b5f10
4 changed files with 47 additions and 64 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/PostgREST/App.hs
+18 -27
View File
@@ -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
_ -> Nothing
(TargetIdent (QualifiedIdentifier _ t) ) -> t
_ -> undefined
mutateApiRequest = case action of
ActionCreate -> Node <$> ((,) <$> (Insert rootTableName <$> flds <*> vals) <*> pure (rootTableName, Nothing)) <*> pure []
ActionUpdate -> Node <$> ((,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)) <*> pure []
ActionCreate -> Node <$> ((,) <$> (Insert rootTableName <$> pure payload) <*> 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 selectQuery mutateQuery isSingle echoRequested pKeys asCsv =
createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool ->
[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
+18 -27
View File
@@ -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, _)) _) =
query
where
qi = QualifiedIdentifier schema mainTbl
query = unwords [
"INSERT INTO ", fromQi qi,
" (" <> intercalate ", " (map (pgFmtIdent . fst) flds) <> ") ",
"VALUES " <> intercalate ", "
( map (\v ->
"(" <>
intercalate ", " ( map insertableValue v ) <>
")"
) vals
),
"RETURNING " <> fromQi qi <> ".*"
]
requestToQuery schema (Node (Update _ setWith conditions, (mainTbl, _)) _) =
query
where
qi = QualifiedIdentifier schema mainTbl
query = unwords [
"UPDATE ", fromQi qi,
" SET " <> intercalate ", " (map formatSet (M.toList setWith)) <> " ",
("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
"RETURNING " <> fromQi qi <> ".*"
]
formatSet ((c, jp), v) = pgFmtIdent c <> pgFmtJsonPath jp <> " = " <> insertableValue v
requestToQuery schema (Node (Insert _ payload, (mainTbl, _)) _) =
let qi = QualifiedIdentifier schema mainTbl in
unwords [
"INSERT INTO ", fromQi qi,
"select * from json_populate_recordset(null::" , fromQi qi, ", ?)",
"RETURNING " <> fromQi qi <> ".*"
]
-- requestToQuery schema (Node (Update _ setWith conditions, (mainTbl, _)) _) =
-- query
-- where
-- qi = QualifiedIdentifier schema mainTbl
-- query = unwords [
-- "UPDATE ", fromQi qi,
-- " SET " <> intercalate ", " (map formatSet (M.toList setWith)) <> " ",
-- ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
-- "RETURNING " <> fromQi qi <> ".*"
-- ]
-- formatSet ((c, jp), v) = pgFmtIdent c <> pgFmtJsonPath jp <> " = " <> insertableValue v
requestToQuery schema (Node (Delete _ conditions, (mainTbl, _)) _) =
query
where
src/PostgREST/RequestIntent.hs
+2 -7
View File
@@ -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
+9 -3
View File
@@ -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