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

Merge pull request #383 from ruslantalpa/simplify

Browse Source 
Type refactoring (ApiRequest/DbRequest)
This commit is contained in:
Joe Nelson
2015-11-23 09:31:01 -08:00
parent 7f58600dbb 50745ad48b
commit 64da08b220
7 changed files with 75 additions and 71 deletions
Download Patch File Download Diff File Expand all files Collapse all files
postgrest.cabal
+3 -3
View File
@@ -72,7 +72,7 @@ executable postgrest
, PostgREST.DbStructure , PostgREST.DbStructure
, PostgREST.QueryBuilder , PostgREST.QueryBuilder
, PostgREST.RangeQuery , PostgREST.RangeQuery
, PostgREST.RequestIntent , PostgREST.ApiRequest
, PostgREST.Types , PostgREST.Types
library library
@@ -136,7 +136,7 @@ library
, PostgREST.DbStructure , PostgREST.DbStructure
, PostgREST.QueryBuilder , PostgREST.QueryBuilder
, PostgREST.RangeQuery , PostgREST.RangeQuery
, PostgREST.RequestIntent , PostgREST.ApiRequest
, PostgREST.Types , PostgREST.Types
hs-source-dirs: src hs-source-dirs: src
@@ -167,7 +167,7 @@ Test-Suite spec
, PostgREST.DbStructure , PostgREST.DbStructure
, PostgREST.QueryBuilder , PostgREST.QueryBuilder
, PostgREST.RangeQuery , PostgREST.RangeQuery
, PostgREST.RequestIntent , PostgREST.ApiRequest
, PostgREST.Types , PostgREST.Types
, Spec , Spec
, SpecHelper , SpecHelper
src/PostgREST/RequestIntent.hs → src/PostgREST/ApiRequest.hs
+5 -5
View File
@@ -1,4 +1,4 @@
module PostgREST.RequestIntent where module PostgREST.ApiRequest where
import qualified Data.Aeson as JSON import qualified Data.Aeson as JSON
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
@@ -46,7 +46,7 @@ instance Show ContentType where
sensible, it is up to a later stage of processing to determine sensible, it is up to a later stage of processing to determine
if it is an action we are able to perform. if it is an action we are able to perform.
-} -}
data Intent = Intent { data ApiRequest = ApiRequest {
-- | Set to Nothing for unknown HTTP verbs -- | Set to Nothing for unknown HTTP verbs
iAction :: Action iAction :: Action
-- | Set to Nothing for malformed range -- | Set to Nothing for malformed range
@@ -72,8 +72,8 @@ data Intent = Intent {
} }
-- | Examines HTTP request and translates it into user intent. -- | Examines HTTP request and translates it into user intent.
userIntent :: Schema -> Request -> RequestBody -> Intent userApiRequest :: Schema -> Request -> RequestBody -> ApiRequest
userIntent schema req reqBody = userApiRequest schema req reqBody =
let action = case method of let action = case method of
"GET" -> ActionRead "GET" -> ActionRead
"POST" -> if isTargetingProc "POST" -> if isTargetingProc
@@ -112,7 +112,7 @@ userIntent schema req reqBody =
ActionInvoke -> Just payload ActionInvoke -> Just payload
_ -> Nothing in _ -> Nothing in
Intent { ApiRequest {
iAction = action iAction = action
, iRange = if singular then Nothing else rangeRequested hdrs , iRange = if singular then Nothing else rangeRequested hdrs
, iTarget = target , iTarget = target
src/PostgREST/App.hs
+39 -39
View File
@@ -12,8 +12,7 @@ import Control.Monad (join)
import Data.Bifunctor (first) import Data.Bifunctor (first)
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.Functor.Identity import Data.Functor.Identity
import qualified Data.HashMap.Strict as HM import Data.List (find, sortBy, delete)
import Data.List (find, sortBy, delete, transpose)
import Data.Maybe (fromMaybe, fromJust, isNothing, mapMaybe) import Data.Maybe (fromMaybe, fromJust, isNothing, mapMaybe)
import Data.Ord (comparing) import Data.Ord (comparing)
import Data.Ranged.Ranges (emptyRange, singletonRange) import Data.Ranged.Ranges (emptyRange, singletonRange)
@@ -43,9 +42,9 @@ import PostgREST.Config (AppConfig (..))
import PostgREST.Parsers import PostgREST.Parsers
import PostgREST.DbStructure import PostgREST.DbStructure
import PostgREST.RangeQuery import PostgREST.RangeQuery
import PostgREST.RequestIntent (Intent(..), ContentType(..) import PostgREST.ApiRequest (ApiRequest(..), ContentType(..)
, Action(..), Target(..) , Action(..), Target(..)
, userIntent) , userApiRequest)
import PostgREST.Types import PostgREST.Types
import PostgREST.Auth (tokenJWT) import PostgREST.Auth (tokenJWT)
import PostgREST.Error (errResponse) import PostgREST.Error (errResponse)
@@ -73,19 +72,19 @@ app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Tx P.Postgres s R
app dbStructure conf reqBody req = app dbStructure conf reqBody req =
let let
-- TODO: blow up for Left values (there is a middleware that checks the headers) -- TODO: blow up for Left values (there is a middleware that checks the headers)
contentType = either (const ApplicationJSON) id (iAccepts intent) contentType = either (const ApplicationJSON) id (iAccepts apiRequest)
contentTypeH = (hContentType, cs $ show contentType) in contentTypeH = (hContentType, cs $ show contentType) in
case (iAction intent, iTarget intent, iPayload intent) of case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of
(ActionRead, TargetIdent qi, Nothing) -> (ActionRead, TargetIdent qi, Nothing) ->
case selectQuery of case selectQuery of
Left e -> return $ responseLBS status400 [jsonH] $ cs e Left e -> return $ responseLBS status400 [jsonH] $ cs e
Right q -> do Right q -> do
let range = iRange intent let range = iRange apiRequest
singular = iPreferSingular intent singular = iPreferSingular apiRequest
stm = createReadStatement q range singular stm = createReadStatement q range singular
(iPreferCount intent) (contentType == TextCSV) (iPreferCount apiRequest) (contentType == TextCSV)
if range == Just emptyRange if range == Just emptyRange
then return $ errResponse status416 "HTTP Range error" then return $ errResponse status416 "HTTP Range error"
else do else do
@@ -120,7 +119,7 @@ app dbStructure conf reqBody req =
Right (sq,mq) -> do Right (sq,mq) -> do
let isSingle = (==1) $ V.length rows 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 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) payload let stm = createWriteStatement sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == TextCSV) payload
row <- H.maybeEx stm row <- H.maybeEx stm
let (_, _, location, body) = extractQueryResult row let (_, _, location, body) = extractQueryResult row
return $ responseLBS status201 return $ responseLBS status201
@@ -128,21 +127,21 @@ app dbStructure conf reqBody req =
contentTypeH, contentTypeH,
(hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location)) (hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location))
] ]
$ if iPreferRepresentation intent then fromMaybe "[]" body else "" $ if iPreferRepresentation apiRequest then fromMaybe "[]" body else ""
(ActionUpdate, TargetIdent _, Just payload@(PayloadJSON _)) -> (ActionUpdate, TargetIdent _, Just payload@(PayloadJSON _)) ->
case queries of case queries of
Left e -> return $ responseLBS status400 [jsonH] $ cs e Left e -> return $ responseLBS status400 [jsonH] $ cs e
Right (sq,mq) -> do Right (sq,mq) -> do
let stm = createWriteStatement sq mq False (iPreferRepresentation intent) [] (contentType == TextCSV) payload let stm = createWriteStatement sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) payload
row <- H.maybeEx stm row <- H.maybeEx stm
let (_, queryTotal, _, body) = extractQueryResult row let (_, queryTotal, _, body) = extractQueryResult row
r = contentRangeH 0 (queryTotal-1) (Just queryTotal) r = contentRangeH 0 (queryTotal-1) (Just queryTotal)
s = case () of _ | queryTotal == 0 -> status404 s = case () of _ | queryTotal == 0 -> status404
| iPreferRepresentation intent -> status200 | iPreferRepresentation apiRequest -> status200
| otherwise -> status204 | otherwise -> status204
return $ responseLBS s [contentTypeH, r] return $ responseLBS s [contentTypeH, r]
$ if iPreferRepresentation intent then fromMaybe "[]" body else "" $ if iPreferRepresentation apiRequest then fromMaybe "[]" body else ""
(ActionDelete, TargetIdent _, Nothing) -> (ActionDelete, TargetIdent _, Nothing) ->
case queries of case queries of
@@ -204,9 +203,9 @@ app dbStructure conf reqBody req =
allPrKeys = dbPrimaryKeys dbStructure allPrKeys = dbPrimaryKeys dbStructure
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
schema = cs $ configSchema conf schema = cs $ configSchema conf
intent = userIntent schema req reqBody apiRequest = userApiRequest schema req reqBody
selectQuery = requestToQuery schema <$> buildSelectApiRequest (dbRelations dbStructure) intent selectQuery = requestToQuery schema <$> (DbRead <$> buildReadRequest (dbRelations dbStructure) apiRequest)
mutateQuery = requestToQuery schema <$> buildMutateApiRequest intent mutateQuery = requestToQuery schema <$> (DbMutate <$> buildMutateRequest apiRequest)
queries = (,) <$> selectQuery <*> mutateQuery queries = (,) <$> selectQuery <*> mutateQuery
rangeStatus :: Int -> Int -> Maybe Int -> Status rangeStatus :: Int -> Int -> Maybe Int -> Status
@@ -247,19 +246,19 @@ formatGeneralError message details = cs $ encode $ object [
"message" .= message, "message" .= message,
"details" .= details] "details" .= details]
augumentRequestWithJoin :: Schema -> [Relation] -> ApiRequest -> Either Text ApiRequest augumentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either Text ReadRequest
augumentRequestWithJoin schema allRels request = augumentRequestWithJoin schema allRels request =
(first formatRelationError . addRelations schema allRels Nothing) request (first formatRelationError . addRelations schema allRels Nothing) request
>>= addJoinConditions schema >>= addJoinConditions schema
buildSelectApiRequest :: [Relation] -> Intent -> Either Text ApiRequest buildReadRequest :: [Relation] -> ApiRequest -> Either Text ReadRequest
buildSelectApiRequest allRels intent = buildReadRequest allRels apiRequest =
augumentRequestWithJoin schema rels =<< first formatParserError (foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts) augumentRequestWithJoin schema rels =<< first formatParserError (foldr addFilter <$> (addOrder <$> readRequest <*> ord) <*> flts)
where where
selStr = iSelect intent selStr = iSelect apiRequest
orderS = iOrder intent orderS = iOrder apiRequest
action = iAction intent action = iAction apiRequest
target = iTarget intent target = iTarget apiRequest
(schema, rootTableName) = fromJust $ -- Make it safe (schema, rootTableName) = fromJust $ -- Make it safe
case target of case target of
(TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t) (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t)
@@ -269,39 +268,39 @@ buildSelectApiRequest allRels intent =
then rootTableName then rootTableName
else sourceSubqueryName else sourceSubqueryName
filters = if action == ActionRead filters = if action == ActionRead
then iFilters intent then iFilters apiRequest
else filter (( '.' `elem` ) . fst) $ iFilters intent -- there can be no filters on the root table whre we are doing insert/update else filter (( '.' `elem` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update
rels = case action of rels = case action of
ActionCreate -> fakeSourceRelations ++ allRels ActionCreate -> fakeSourceRelations ++ allRels
ActionUpdate -> fakeSourceRelations ++ allRels ActionUpdate -> fakeSourceRelations ++ allRels
_ -> allRels _ -> allRels
where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation
apiRequest = parse (pRequestSelect rootName) ("failed to parse select parameter <<"++selStr++">>") selStr readRequest = parse (pRequestSelect rootName) ("failed to parse select parameter <<"++selStr++">>") selStr
addOrder (Node (q,i) f) o = Node (q{order=o}, i) f addOrder (Node (q,i) f) o = Node (q{order=o}, i) f
flts = mapM pRequestFilter filters flts = mapM pRequestFilter filters
ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderS++">>")) orderS ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderS++">>")) orderS
buildMutateApiRequest :: Intent -> Either Text ApiRequest buildMutateRequest :: ApiRequest -> Either Text MutateRequest
buildMutateApiRequest intent = buildMutateRequest apiRequest =
mutateApiRequest mutateApiRequest
where where
action = iAction intent action = iAction apiRequest
target = iTarget intent target = iTarget apiRequest
payload = fromJust $ iPayload intent payload = fromJust $ iPayload apiRequest
rootTableName = -- TODO: Make it safe rootTableName = -- TODO: Make it safe
case target of case target of
(TargetIdent (QualifiedIdentifier _ t) ) -> t (TargetIdent (QualifiedIdentifier _ t) ) -> t
_ -> undefined _ -> undefined
mutateApiRequest = case action of mutateApiRequest = case action of
ActionCreate -> Node <$> ((,) <$> (Insert rootTableName <$> pure payload) <*> pure (rootTableName, Nothing)) <*> pure [] ActionCreate -> Insert rootTableName <$> pure payload
ActionUpdate -> Node <$> ((,) <$> (Update rootTableName <$> pure payload <*> cond) <*> pure (rootTableName, Nothing)) <*> pure [] ActionUpdate -> Update rootTableName <$> pure payload <*> cond
ActionDelete -> Node <$> ((,) <$> (Delete [rootTableName] <$> cond) <*> pure (rootTableName, Nothing)) <*> pure [] ActionDelete -> Delete rootTableName <$> cond
_ -> Left "Unsupported HTTP verb" _ -> Left "Unsupported HTTP verb"
mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters intent -- update/delete filters can be only on the root table mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table
cond = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters cond = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters
addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest addFilter :: (Path, Filter) -> ReadRequest -> ReadRequest
addFilter ([], flt) (Node (q@(Select {where_=flts}), i) forest) = Node (q {where_=flt:flts}, i) forest addFilter ([], flt) (Node (q@(Select {flt_=flts}), i) forest) = Node (q {flt_=flt:flts}, i) forest
addFilter (path, flt) (Node rn forest) = addFilter (path, flt) (Node rn forest) =
case targetNode of case targetNode of
Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path
@@ -352,6 +351,7 @@ createReadStatement selectQuery range isSingle countTable asCsv =
createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool ->
[Text] -> Bool -> Payload -> B.Stmt P.Postgres [Text] -> Bool -> Payload -> B.Stmt P.Postgres
createWriteStatement _ _ _ _ _ _ (PayloadParseError _) = undefined
createWriteStatement selectQuery mutateQuery isSingle echoRequested createWriteStatement selectQuery mutateQuery isSingle echoRequested
pKeys asCsv (PayloadJSON (UniformObjects rows)) = pKeys asCsv (PayloadJSON (UniformObjects rows)) =
B.Stmt ( B.Stmt (
src/PostgREST/Middleware.hs
+1 -1
View File
@@ -18,7 +18,7 @@ import Network.Wai.Middleware.Cors (cors)
import Network.Wai.Middleware.Gzip (def, gzip) import Network.Wai.Middleware.Gzip (def, gzip)
import Network.Wai.Middleware.Static (only, staticPolicy) import Network.Wai.Middleware.Static (only, staticPolicy)
import PostgREST.RequestIntent (pickContentType) import PostgREST.ApiRequest (pickContentType)
import PostgREST.Auth (setRole, jwtClaims, claimsToSQL) import PostgREST.Auth (setRole, jwtClaims, claimsToSQL)
import PostgREST.Config (AppConfig (..), corsPolicy) import PostgREST.Config (AppConfig (..), corsPolicy)
import PostgREST.Error (errResponse) import PostgREST.Error (errResponse)
src/PostgREST/Parsers.hs
+2 -2
View File
@@ -12,12 +12,12 @@ import PostgREST.Types
import Text.ParserCombinators.Parsec hiding (many, (<|>)) import Text.ParserCombinators.Parsec hiding (many, (<|>))
import PostgREST.QueryBuilder (operators) import PostgREST.QueryBuilder (operators)
pRequestSelect :: Text -> Parser ApiRequest pRequestSelect :: Text -> Parser ReadRequest
pRequestSelect rootNodeName = do pRequestSelect rootNodeName = do
fieldTree <- pFieldForest fieldTree <- pFieldForest
return $ foldr treeEntry (Node (Select [] [rootNodeName] [] Nothing, (rootNodeName, Nothing)) []) fieldTree return $ foldr treeEntry (Node (Select [] [rootNodeName] [] Nothing, (rootNodeName, Nothing)) []) fieldTree
where where
treeEntry :: Tree SelectItem -> ApiRequest -> ApiRequest treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest
treeEntry (Node fld@((fn, _),_) fldForest) (Node (q, i) rForest) = treeEntry (Node fld@((fn, _),_) fldForest) (Node (q, i) rForest) =
case fldForest of case fldForest of
[] -> Node (q {select=fld:select q}, i) rForest [] -> Node (q {select=fld:select q}, i) rForest
src/PostgREST/QueryBuilder.hs
+17 -15
View File
@@ -58,7 +58,7 @@ instance Monoid PStmt where
mempty = B.Stmt "" empty True mempty = B.Stmt "" empty True
type StatementT = PStmt -> PStmt type StatementT = PStmt -> PStmt
addRelations :: Schema -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest
addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) forest) = addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) forest) =
case parentNode of case parentNode of
Nothing -> Node (query, (table, Nothing)) <$> updatedForest Nothing -> Node (query, (table, Nothing)) <$> updatedForest
@@ -67,14 +67,14 @@ addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) for
rel = note ("no relation between " <> table <> " and " <> parentTable) rel = note ("no relation between " <> table <> " and " <> parentTable)
$ findRelation schema table parentTable $ findRelation schema table parentTable
<|> findRelation schema parentTable table <|> findRelation schema parentTable table
addRel :: (Query, (NodeName, Maybe Relation)) -> Relation -> (Query, (NodeName, Maybe Relation)) addRel :: (ReadQuery, (NodeName, Maybe Relation)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation))
addRel (q, (t, _)) r = (q, (t, Just r)) addRel (q, (t, _)) r = (q, (t, Just r))
where where
updatedForest = mapM (addRelations schema allRelations (Just node)) forest updatedForest = mapM (addRelations schema allRelations (Just node)) forest
findRelation s t1 t2 = findRelation s t1 t2 =
find (\r -> s == (tableSchema . relTable) r && t1 == (tableName . relTable) r && t2 == (tableName . relFTable) r) allRelations find (\r -> s == (tableSchema . relTable) r && t1 == (tableName . relTable) r && t2 == (tableName . relFTable) r) allRelations
addJoinConditions :: Schema -> ApiRequest -> Either Text ApiRequest addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest
addJoinConditions schema (Node (query, (n, r)) forest) = addJoinConditions schema (Node (query, (n, r)) forest) =
case r of case r of
Nothing -> Node (updatedQuery, (n,r)) <$> updatedForest -- this is the root node Nothing -> Node (updatedQuery, (n,r)) <$> updatedForest -- this is the root node
@@ -96,7 +96,7 @@ addJoinConditions schema (Node (query, (n, r)) forest) =
getParents (_, (tbl, Just rel@(Relation{relType=Parent}))) = Just (tbl, rel) getParents (_, (tbl, Just rel@(Relation{relType=Parent}))) = Just (tbl, rel)
getParents _ = Nothing getParents _ = Nothing
updatedForest = mapM (addJoinConditions schema) forest updatedForest = mapM (addJoinConditions schema) forest
addCond q con = q{where_=con ++ where_ q} addCond q con = q{flt_=con ++ flt_ q}
asCsvF :: SqlFragment asCsvF :: SqlFragment
asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
@@ -189,8 +189,10 @@ pgFmtLit x =
then "E" <> slashed then "E" <> slashed
else slashed else slashed
requestToQuery :: Schema -> ApiRequest -> SqlQuery requestToQuery :: Schema -> DbRequest -> SqlQuery
requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)) forest) = requestToQuery _ (DbMutate (Insert _ (PayloadParseError _))) = undefined
requestToQuery _ (DbMutate (Update _ (PayloadParseError _) _)) = undefined
requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord, (mainTbl, _)) forest)) =
query query
where where
-- TODO! the folloing helper functions are just to remove the "schema" part when the table is "source" which is the name -- TODO! the folloing helper functions are just to remove the "schema" part when the table is "source" which is the name
@@ -206,31 +208,31 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)
orderF (fromMaybe [] ord) orderF (fromMaybe [] ord)
] ]
(withs, selects) = foldr getQueryParts ([],[]) forest (withs, selects) = foldr getQueryParts ([],[]) forest
getQueryParts :: Tree ApiNode -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment]) getQueryParts :: Tree ReadNode -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment])
getQueryParts (Node n@(_, (table, Just (Relation {relType=Child}))) forst) (w,s) = (w,sel:s) getQueryParts (Node n@(_, (table, Just (Relation {relType=Child}))) forst) (w,s) = (w,sel:s)
where where
sel = "(" sel = "("
<> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) " <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
<> "FROM (" <> subquery <> ") " <> table <> "FROM (" <> subquery <> ") " <> table
<> ") AS " <> table <> ") AS " <> table
where subquery = requestToQuery schema (Node n forst) where subquery = requestToQuery schema (DbRead (Node n forst))
getQueryParts (Node n@(_, (table, Just (Relation {relType=Parent}))) forst) (w,s) = (wit:w,sel:s) getQueryParts (Node n@(_, (table, Just (Relation {relType=Parent}))) forst) (w,s) = (wit:w,sel:s)
where where
sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular
wit = table <> " AS ( " <> subquery <> " )" wit = table <> " AS ( " <> subquery <> " )"
where subquery = requestToQuery schema (Node n forst) where subquery = requestToQuery schema (DbRead (Node n forst))
getQueryParts (Node n@(_, (table, Just (Relation {relType=Many}))) forst) (w,s) = (w,sel:s) getQueryParts (Node n@(_, (table, Just (Relation {relType=Many}))) forst) (w,s) = (w,sel:s)
where where
sel = "(" sel = "("
<> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) " <> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
<> "FROM (" <> subquery <> ") " <> table <> "FROM (" <> subquery <> ") " <> table
<> ") AS " <> table <> ") AS " <> table
where subquery = requestToQuery schema (Node n forst) where subquery = requestToQuery schema (DbRead (Node n forst))
--the following is just to remove the warning --the following is just to remove the warning
--getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only
--posible relations are Child Parent Many --posible relations are Child Parent Many
getQueryParts (Node (_,(_,Nothing)) _) _ = undefined getQueryParts (Node (_,(_,Nothing)) _) _ = undefined
requestToQuery schema (Node (Insert _ (PayloadJSON (UniformObjects rows)), (mainTbl, _)) _) = requestToQuery schema (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects rows)))) =
let qi = QualifiedIdentifier schema mainTbl let qi = QualifiedIdentifier schema mainTbl
cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0)) cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0))
colsString = intercalate ", " cols in colsString = intercalate ", " cols in
@@ -241,22 +243,22 @@ requestToQuery schema (Node (Insert _ (PayloadJSON (UniformObjects rows)), (main
" FROM json_populate_recordset(null::" , fromQi qi, ", ?)", " FROM json_populate_recordset(null::" , fromQi qi, ", ?)",
" RETURNING " <> fromQi qi <> ".*" " RETURNING " <> fromQi qi <> ".*"
] ]
requestToQuery schema (Node (Update _ (PayloadJSON (UniformObjects rows)) conditions, (mainTbl, _)) _) = requestToQuery schema (DbMutate (Update mainTbl (PayloadJSON (UniformObjects rows)) conditions)) =
case rows V.!? 0 of case rows V.!? 0 of
Just obj -> Just obj ->
let assignments = map let assignments = map
(\(k,v) -> pgFmtIdent k <> "=" <> insertableValue v) $ HM.toList obj in (\(k,v) -> pgFmtIdent k <> "=" <> insertableValue v) $ HM.toList obj in
unwords [ unwords [
"UPDATE ", fromQi qi, "UPDATE ", fromQi qi,
" SET " <> (intercalate "," assignments) <> " ", " SET " <> intercalate "," assignments <> " ",
("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions, ("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
"RETURNING " <> fromQi qi <> ".*" "RETURNING " <> fromQi qi <> ".*"
] ]
Nothing -> "" Nothing -> undefined
where where
qi = QualifiedIdentifier schema mainTbl qi = QualifiedIdentifier schema mainTbl
requestToQuery schema (Node (Delete _ conditions, (mainTbl, _)) _) = requestToQuery schema (DbMutate (Delete mainTbl conditions)) =
query query
where where
qi = QualifiedIdentifier schema mainTbl qi = QualifiedIdentifier schema mainTbl
src/PostgREST/Types.hs
+8 -6
View File
@@ -106,13 +106,15 @@ type Cast = Text
type NodeName = Text type NodeName = Text
type SelectItem = (Field, Maybe Cast) type SelectItem = (Field, Maybe Cast)
type Path = [Text] type Path = [Text]
data Query = Select { select::[SelectItem], from::[Text], where_::[Filter], order::Maybe [OrderTerm] } data ReadQuery = Select { select::[SelectItem], from::[Text], flt_::[Filter], order::Maybe [OrderTerm] } deriving (Show, Eq)
| Insert { into::Text, qPayload::Payload } data MutateQuery = Insert { in_::Text, qPayload::Payload }
| Delete { from::[Text], where_::[Filter] } | Delete { in_::Text, where_::[Filter] }
| Update { into::Text, qPayload::Payload, where_::[Filter] } deriving (Show, Eq) | Update { in_::Text, qPayload::Payload, where_::[Filter] } deriving (Show, Eq)
data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq) data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq)
type ApiNode = (Query, (NodeName, Maybe Relation)) type ReadNode = (ReadQuery, (NodeName, Maybe Relation))
type ApiRequest = Tree ApiNode type ReadRequest = Tree ReadNode
type MutateRequest = MutateQuery
data DbRequest = DbRead ReadRequest | DbMutate MutateRequest
instance ToJSON Column where instance ToJSON Column where