diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index 1159c0013..26efe7f34 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -36,8 +36,8 @@ import Network.Wai.Parse (parseHttpAccept) import PostgREST.RangeQuery (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset) import Data.Ranged.Boundaries import PostgREST.Types (QualifiedIdentifier (..), - Schema, Payload(..), - UniformObjects(..)) + Schema, + PayloadJSON(..)) import Data.Ranged.Ranges (Range(..), singletonRange, rangeIntersection, emptyRange) type RequestBody = BL.ByteString @@ -95,7 +95,7 @@ data ApiRequest = ApiRequest { -- | Content types the client will accept, [CTAny] if no Accept header , iAccepts :: [ContentType] -- | Data sent by client and used for mutation actions - , iPayload :: Maybe Payload + , iPayload :: Maybe PayloadJSON -- | If client wants created items echoed back , iPreferRepresentation :: PreferRepresentation -- | If client wants first row as raw object @@ -150,13 +150,13 @@ userApiRequest schema req reqBody CTApplicationJSON -> either Left (\val -> case ensureUniform (pluralize val) of Nothing -> Left "All object keys must match" - Just json -> Right $ PayloadJSON json) (JSON.eitherDecode reqBody) + Just json -> Right json) (JSON.eitherDecode reqBody) CTTextCSV -> either Left (\val -> case ensureUniform (csvToJson val) of Nothing -> Left "All lines must have same number of fields" - Just json -> Right $ PayloadJSON json) (CSV.decodeByName reqBody) + Just json -> Right json) (CSV.decodeByName reqBody) CTOther "application/x-www-form-urlencoded" -> - Right . PayloadJSON . UniformObjects . V.singleton . M.fromList + Right . PayloadJSON . V.singleton . M.fromList . map (toS *** JSON.String . toS) . parseSimpleQuery $ toS reqBody ct -> @@ -283,8 +283,8 @@ pluralize (JSON.Array arr) = arr pluralize _ = V.empty -- | Test that Array contains only Objects having the same keys --- and if so mark it as UniformObjects -ensureUniform :: JSON.Array -> Maybe UniformObjects +-- and if so mark it as PayloadJSON +ensureUniform :: JSON.Array -> Maybe PayloadJSON ensureUniform arr = let objs :: V.Vector JSON.Object objs = foldr -- filter non-objects, map to raw objects @@ -297,5 +297,5 @@ ensureUniform arr = areKeysUniform = all (==canonicalKeys) keysPerObj in if (V.length objs == V.length arr) && areKeysUniform - then Just (UniformObjects objs) + then Just (PayloadJSON objs) else Nothing diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 124155501..db00892cb 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -128,7 +128,7 @@ app dbStructure conf apiRequest = ) ] (toS body) - (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), Just payload@(PayloadJSON uniform@(UniformObjects rows))) -> + (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), Just payload@(PayloadJSON rows)) -> case mutateSqlParts of Left errorResponse -> return errorResponse Right (sq, mq) -> do @@ -142,7 +142,7 @@ app dbStructure conf apiRequest = |] 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 qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == CTTextCSV) payload - row <- H.query uniform stm + row <- H.query payload stm let (_, _, fs, body) = extractQueryResult row headers = catMaybes [ if null fs @@ -159,13 +159,13 @@ app dbStructure conf apiRequest = if iPreferRepresentation apiRequest == Full then toS body else "" - (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) -> + (ActionUpdate, TargetIdent qi, Just payload) -> case mutateSqlParts of Left errorResponse -> return errorResponse Right (sq, mq) -> do let singular = iPreferSingular apiRequest stm = createWriteStatement qi sq mq singular (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) payload - row <- H.query uniform stm + row <- H.query payload stm let (_, queryTotal, _, body) = extractQueryResult row when (singular && queryTotal > 1) $ HT.sql [P6.q| DO $$ @@ -187,10 +187,9 @@ app dbStructure conf apiRequest = case mutateSqlParts of Left errorResponse -> return errorResponse Right (sq, mq) -> do - let emptyUniform = UniformObjects V.empty - fakeload = PayloadJSON emptyUniform - stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) fakeload - row <- H.query emptyUniform stm + let emptyPayload = PayloadJSON V.empty + stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) emptyPayload + row <- H.query emptyPayload stm let (_, queryTotal, _, body) = extractQueryResult row r = contentRangeH 1 0 $ toInteger <$> if shouldCount then Just queryTotal else Nothing @@ -208,7 +207,7 @@ app dbStructure conf apiRequest = let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in return $ responseLBS status200 [allOrigins, acceptH] "" - (ActionInvoke, TargetProc qi, Just (PayloadJSON (UniformObjects payload))) -> + (ActionInvoke, TargetProc qi, Just (PayloadJSON payload)) -> case readSqlParts of Left errorResponse -> return errorResponse Right (q, cq) -> do diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 99957e8b6..03a077c82 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -83,12 +83,12 @@ decodeStandardMay = HD.maybeRow standardRow {-| JSON and CSV payloads from the client are given to us as - UniformObjects (objects who all have the same keys), + PayloadJSON (objects who all have the same keys), and we turn this into an old fasioned JSON array -} -encodeUniformObjs :: HE.Params UniformObjects +encodeUniformObjs :: HE.Params PayloadJSON encodeUniformObjs = - contramap (JSON.Array . V.map JSON.Object . unUniformObjects) (HE.value HE.json) + contramap (JSON.Array . V.map JSON.Object . unPayloadJSON) (HE.value HE.json) createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> H.Query () ResultsWithCount @@ -111,10 +111,10 @@ createReadStatement selectQuery countQuery isSingle countTotal asCsv = | otherwise = asJsonF createWriteStatement :: QualifiedIdentifier -> SqlQuery -> SqlQuery -> Bool -> - PreferRepresentation -> [Text] -> Bool -> Payload -> - H.Query UniformObjects (Maybe ResultsWithCount) + PreferRepresentation -> [Text] -> Bool -> PayloadJSON -> + H.Query PayloadJSON (Maybe ResultsWithCount) createWriteStatement _ _ mutateQuery _ None - _ _ (PayloadJSON (UniformObjects _)) = + _ _ (PayloadJSON _) = unicodeStatement sql encodeUniformObjs decodeStandardMay True where sql = [qc| @@ -122,7 +122,7 @@ createWriteStatement _ _ mutateQuery _ None SELECT '', 0, {noLocationF}, '' |] createWriteStatement qi _ mutateQuery isSingle HeadersOnly - pKeys _ (PayloadJSON (UniformObjects _)) = + pKeys _ (PayloadJSON _) = unicodeStatement sql encodeUniformObjs decodeStandardMay True where sql = [qc| @@ -137,7 +137,7 @@ createWriteStatement qi _ mutateQuery isSingle HeadersOnly ] createWriteStatement qi selectQuery mutateQuery isSingle Full - pKeys asCsv (PayloadJSON (UniformObjects _)) = + pKeys asCsv (PayloadJSON _) = unicodeStatement sql encodeUniformObjs decodeStandardMay True where sql = [qc| @@ -381,7 +381,7 @@ requestToQuery schema isParent (DbRead (Node (Select colSelects tbls conditions --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only --posible relations are Child Parent Many getQueryParts _ _ = undefined --error "undefined getQueryParts" -requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects rows)))) = +requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON rows))) = let qi = QualifiedIdentifier schema mainTbl cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0)) colsString = intercalate ", " cols @@ -393,7 +393,7 @@ requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects r else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"] in insInto <> vals -requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON (UniformObjects rows)) conditions)) = +requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) conditions)) = case rows V.!? 0 of Just obj -> let assignments = map diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 84b28171f..5136ffc04 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -101,16 +101,11 @@ data Relation = Relation { -- | An array of JSON objects that has been verified to have -- the same keys in every object -newtype UniformObjects = UniformObjects (V.Vector Object) +newtype PayloadJSON = PayloadJSON (V.Vector Object) deriving (Show, Eq) -unUniformObjects :: UniformObjects -> V.Vector Object -unUniformObjects (UniformObjects objs) = objs - --- | 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 UniformObjects deriving (Show, Eq) +unPayloadJSON :: PayloadJSON -> V.Vector Object +unPayloadJSON (PayloadJSON objs) = objs data Proxy = Proxy { proxyScheme :: Text @@ -130,9 +125,9 @@ type NodeName = Text type SelectItem = (Field, Maybe Cast, Maybe Alias) type Path = [Text] data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq) -data MutateQuery = Insert { in_::TableName, qPayload::Payload } +data MutateQuery = Insert { in_::TableName, qPayload::PayloadJSON } | Delete { in_::TableName, where_::[Filter] } - | Update { in_::TableName, qPayload::Payload, where_::[Filter] } deriving (Show, Eq) + | Update { in_::TableName, qPayload::PayloadJSON, where_::[Filter] } deriving (Show, Eq) data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq) type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) type ReadRequest = Tree ReadNode