diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 3009a4d8b..24963e4e2 100644 --- a/src/PostgREST/App.hs +++ b/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 - _ -> 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) diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 72ba5b8b1..0f3d3b93d 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/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, _)) _) = - 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 diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/RequestIntent.hs index d00404b8e..b3199caee 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/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 diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 0bea9245a..9e1346f94 100644 --- a/src/PostgREST/Types.hs +++ b/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