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

Cleanup / Refactoring

Browse Source
This commit is contained in:
Ruslan Talpa
2015-10-29 16:04:16 +02:00
parent 915ce0fa9d
commit 9458ee3292
2 changed files with 91 additions and 215 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/PostgREST/App.hs
+90 -176
View File
@@ -1,18 +1,11 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module PostgREST.App where
-- module PostgREST.App (
-- app
-- , sqlError
-- , isSqlError
-- , contentTypeForAccept
-- , jsonH
-- , TableOptions(..)
-- , parsePostRequest
-- , rr
-- , bb
-- ) where
--module PostgREST.App where
module PostgREST.App (
app
, contentTypeForAccept
) where
import Control.Applicative
import Control.Arrow ((***))
@@ -72,26 +65,16 @@ app dbstructure conf reqBody req =
if range == Just emptyRange
then return $ responseLBS status416 [] "HTTP Range error"
else
case query of
Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
Right qs -> do
let q = B.Stmt
(
wrapQuery qs [
if hasPrefer "count=none" then countNoneF else countAllF,
countF,
case contentType of
"text/csv" -> asCsvF -- TODO check when in csv mode if the header is correct when requesting nested data
_ -> asJsonF
] selectStarF range
)
V.empty True
case request of
Left e -> return $ responseLBS status400 [jsonH] $ cs e
Right (selectQuery, _, _) -> do
let q = B.Stmt (createStatement selectQuery Nothing True range [] (not $ hasPrefer "count=none") isCsv) V.empty True
row <- H.maybeEx q
let (tableTotal, queryTotal, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe BL.ByteString) row
let (tableTotal, queryTotal, _ , body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe BL.ByteString, Just "" :: Maybe BL.ByteString) row
to = frm+queryTotal-1
contentRange = contentRangeH frm to tableTotal
status = rangeStatus frm to tableTotal
canonical = urlEncodeVars
canonical = urlEncodeVars -- should this be moved to the db (location)?
. sortBy (comparing fst)
. map (join (***) cs)
. parseSimpleQuery
@@ -106,59 +89,26 @@ app dbstructure conf reqBody req =
where
frm = fromMaybe 0 $ rangeOffset <$> range
-- apiRequest = parseGetRequest table req
-- >>= first formatRelationError . addRelations schema allRels Nothing
-- >>= addJoinConditions schema allCols
apiRequest = parseGetRequest table req >>= augumentRequestWithJoin schema allRels
query = requestToQuery schema <$> apiRequest
request = parseRequest schema allRels table req reqBody
([table], "POST") -> do
let echoRequested = hasPrefer "return=representation"
case queries of
Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
Right (qi, qs) -> do
let isSingle = either (const False) id returnSingle
pKeys = map pkName $ filter (filterPk schema table) allPrKeys
q = B.Stmt
(
wrapQuery qi [
if isSingle then locationF pKeys else "null",
"null", -- countF,
if echoRequested
then
case contentType of
"text/csv" -> asCsvF
_ -> if isSingle then asJsonSingleF else asJsonF
else "null"
] qs Nothing
)
V.empty True
case request of
Left e -> return $ responseLBS status400 [jsonH] $ cs e
Right (selectQuery, mutateQuery, isSingle) -> do
let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
q = B.Stmt (createStatement selectQuery (Just (mutateQuery, isSingle)) echoRequested Nothing pKeys False isCsv) V.empty True
row <- H.maybeEx q
let (locationRaw, _ {-- queryTotal --}, bodyRaw) = fromMaybe (Just "" :: Maybe BL.ByteString, Just (0::Int), Just "" :: Maybe BL.ByteString) row
body = fromMaybe "[]" bodyRaw
locationH = fromMaybe "" locationRaw
let (_, _, location, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe BL.ByteString, Just "" :: Maybe BL.ByteString) row
return $ responseLBS status201
[
contentTypeH,
(hLocation, "/" <> cs table <> "?" <> cs locationH)
(hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location))
]
$ if echoRequested then body else ""
$ if echoRequested then (fromMaybe "[]" body) else ""
where
res = parsePostRequest table req reqBody
ins = fst <$> res
insertApiRequest = snd <$> ins
returnSingle = fst <$> ins
insertQuery = requestToQuery schema <$> insertApiRequest
selectApiRequest = (snd <$> res) >>= augumentRequestWithJoin schema (fakeSourceRelations ++ allRels)
selectQuery = requestToQuery schema <$> selectApiRequest
queries = (,) <$> insertQuery <*> selectQuery
request = parseRequest schema (fakeSourceRelations ++ allRels) table req reqBody
fakeSourceRelations = mapMaybe (toSourceRelation table) allRels
--changeRootNodeToSource :: Text -> ApiRequest -> ApiRequest
--changeRootNodeToSource rootTableName (q, (rootTableName, r)) =
--returnSelect = selectStarF
([table], "PUT") ->
handleJsonObj reqBody $ \obj -> do
@@ -186,46 +136,21 @@ app dbstructure conf reqBody req =
([table], "PATCH") -> do
let echoRequested = hasPrefer "return=representation"
case queries of
Left e -> return $ responseLBS status400 [("Content-Type", "application/json")] $ cs e
Right (qu, qs) -> do
let q = B.Stmt
(
wrapQuery qu [
countF,
if echoRequested
then
case contentType of
"text/csv" -> asCsvF
_ -> asJsonF
else "null"
] qs Nothing
)
V.empty True
case request of
Left e -> return $ responseLBS status400 [jsonH] $ cs e
Right (selectQuery, mutateQuery, _) -> do
let q = B.Stmt (createStatement selectQuery (Just (mutateQuery, False)) echoRequested Nothing [] False isCsv) V.empty True
row <- H.maybeEx q
let (queryTotal, bodyRaw) = fromMaybe (0::Int, Just "" :: Maybe BL.ByteString) row
body = fromMaybe "[]" bodyRaw
let (_, queryTotal, _, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe BL.ByteString, Just "" :: Maybe BL.ByteString) row
r = contentRangeH 0 (queryTotal-1) (Just queryTotal)
s = case () of _ | queryTotal == 0 -> status404
| echoRequested -> status200
| otherwise -> status204
--return $ responseLBS s [ jsonH, r ] $ if echoRequested then cs $ fromMaybe "[]" body else ""
return $ responseLBS s
[
contentTypeH,
r
]
$ if echoRequested then body else ""
return $ responseLBS s [contentTypeH, r]
$ if echoRequested then (fromMaybe "[]" body) else ""
where
res = parsePatchRequest table req reqBody
updateApiRequest = fst <$> res
updateQuery = requestToQuery schema <$> updateApiRequest
selectApiRequest = (snd <$> res) >>= augumentRequestWithJoin schema (fakeSourceRelations ++ allRels)
selectQuery = requestToQuery schema <$> selectApiRequest
queries = (,) <$> updateQuery <*> selectQuery
request = parseRequest schema (fakeSourceRelations ++ allRels) table req reqBody
fakeSourceRelations = mapMaybe (toSourceRelation table) allRels
([table], "DELETE") -> do
@@ -298,14 +223,9 @@ app dbstructure conf reqBody req =
range = rangeRequested hdrs
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
contentType = fromMaybe "application/json" $ contentTypeForAccept accept
isCsv = contentType == csvMT
contentTypeH = (hContentType, contentType)
sqlError :: t
sqlError = undefined
isSqlError :: t
isSqlError = undefined
rangeStatus :: Int -> Int -> Maybe Int -> Status
rangeStatus _ _ Nothing = status200
rangeStatus frm to (Just total)
@@ -347,11 +267,6 @@ contentTypeForAccept accept
findInAccept = flip find $ parseHttpAccept acceptH
has = isJust . findInAccept . BS.isPrefixOf
bodyForAccept :: BS.ByteString -> QualifiedIdentifier -> StatementT
bodyForAccept contentType table
| contentType == csvMT = asCsvWithCount table
| otherwise = asJsonWithCount -- defaults to JSON
handleJsonObj :: BL.ByteString -> (Object -> H.Tx P.Postgres s Response)
-> H.Tx P.Postgres s Response
handleJsonObj reqBody handler = do
@@ -376,6 +291,7 @@ formatRelationError :: Text -> Text
formatRelationError e = cs $ encode $ object [
"mesage" .= ("could not find foreign keys between these entities"::String),
"details" .= e]
formatParserError :: ParseError -> Text
formatParserError e = cs $ encode $ object [
"message" .= message,
@@ -385,54 +301,6 @@ formatParserError e = cs $ encode $ object [
details = strip $ replace "\n" " " $ cs
$ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
parsePatchRequest :: NodeName -> Request -> BL.ByteString -> Either Text (ApiRequest, ApiRequest)
parsePatchRequest rootTableName httpRequest reqBody =
(,) <$> updateApiRequest <*> returnApiRequest
where
updateApiRequest = Node <$> apiNode <*> pure []
apiNode = (,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)
flds = join $ first formatParserError . mapM (parseField . cs) <$> (fst <$> parsed)
vals = head.snd <$> parsed -- TODO! cheack if head is safe here
parseField f = parse pField ("failed to parse field <<"++f++">>") f
parsed :: Either Text ([Text],[[Value]])
parsed = parseRequestBody isCsv reqBody
returnSingle = (==1) . length . snd <$> parsed
isSingle = either (const False) id returnSingle
setWith = if isSingle
then M.fromList <$> (zip <$> flds <*> vals)
else Left "Expecting a sigle CSV line with header or a JSON object"
hdrs = requestHeaders httpRequest
lookupHeader = flip lookup hdrs
--rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
isCsv = lookupHeader "Content-Type" == Just csvMT
qParams = queryParams httpRequest
selectFilters = filter (( '.' `elem` ) . fst) $ whereFilters qParams -- there can be no filters on the root table whre we are doing insert
updateFilters = filter (not . ( '.' `elem` ) . fst) $ whereFilters qParams -- update filters can be only on the root table
returnApiRequest = buildSelectApiRequest sourceSubqueryName (selectStr qParams) selectFilters (orderStr qParams)
cond = first formatParserError $ map snd <$> mapM pRequestFilter updateFilters
-- quite ugly return type
parsePostRequest :: NodeName -> Request -> BL.ByteString -> Either Text ((Bool, ApiRequest), ApiRequest)
parsePostRequest rootTableName httpRequest reqBody =
(,) <$> ((,) <$> returnSingle <*> insertApiRequest) <*> returnApiRequest
where
insertApiRequest = Node <$> apiNode <*> pure []
apiNode = (,) <$> (Insert rootTableName <$> flds <*> vals) <*> pure (rootTableName, Nothing)
flds = join $ first formatParserError . mapM (parseField . cs) <$> (fst <$> parsed)
vals = snd <$> parsed
parseField f = parse pField ("failed to parse field <<"++f++">>") f
parsed :: Either Text ([Text],[[Value]])
parsed = parseRequestBody isCsv reqBody
returnSingle = (==1) . length . snd <$> parsed -- not quite correct qhen the user send single row but in an array
hdrs = requestHeaders httpRequest
lookupHeader = flip lookup hdrs
--rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
isCsv = lookupHeader "Content-Type" == Just csvMT
qParams = queryParams httpRequest
filters = filter (( '.' `elem` ) . fst) $ whereFilters qParams -- there can be no filters on the root table whre we are doing insert
returnApiRequest = buildSelectApiRequest sourceSubqueryName (selectStr qParams) filters (orderStr qParams)
parseRequestBody :: Bool -> BL.ByteString -> Either Text ([Text],[[Value]])
parseRequestBody isCsv reqBody = first cs $
checkStructure =<<
@@ -448,13 +316,6 @@ parseRequestBody isCsv reqBody = first cs $
| headerMatchesContent v = Right v
| isCsv = Left "CSV header does not match rows length"
| otherwise = Left "The number of keys in objects do not match"
-- checkStructure v =
-- if headerMatchesContent v
-- then Right v
-- else
-- if isCsv
-- then Left "CSV header does not match rows length"
-- else Left "The number of keys in objects do not match"
headerMatchesContent :: ([Text], [[Value]]) -> Bool
headerMatchesContent (header, vals) = all ( (headerLength ==) . length) vals
@@ -489,12 +350,6 @@ convertJson v = (,) <$> (header <$> normalized) <*> (vals <$> normalized)
a@(Array _) -> Right a
_ -> Left invalidMsg
parseGetRequest :: NodeName -> Request -> Either Text ApiRequest
parseGetRequest rootTableName httpRequest =
buildSelectApiRequest rootTableName (selectStr qParams) (whereFilters qParams) (orderStr qParams)
where
qParams = queryParams httpRequest
augumentRequestWithJoin :: Text -> [Relation] -> ApiRequest -> Either Text ApiRequest
augumentRequestWithJoin schema allRels request =
(first formatRelationError . addRelations schema allRels Nothing) request
@@ -553,3 +408,62 @@ instance ToJSON TableOptions where
toJSON t = object [
"columns" .= tblOptcolumns t
, "pkey" .= tblOptpkey t ]
parseRequest :: Text -> [Relation] -> NodeName -> Request -> BL.ByteString -> Either Text (Text, Text, Bool)
parseRequest schema allRels rootTableName httpRequest reqBody =
(,,) <$> selectQuery
<*> (if method == "GET" then pure "" else mutateQuery)
<*> (if method == "GET" then pure False else pure isSingleRecord)
where
hdrs = requestHeaders httpRequest
lookupHeader = flip lookup hdrs
isCsv = lookupHeader "Content-Type" == Just csvMT
method = requestMethod httpRequest
qParams = queryParams httpRequest
parsedBody = parseRequestBody isCsv reqBody
isSingleRecord = either (const False) ((==1) . length . snd ) parsedBody
parseField f = parse pField ("failed to parse field <<"++f++">>") f
flds = join $ first formatParserError . mapM (parseField . cs) <$> (fst <$> parsedBody)
vals = snd <$> parsedBody
setWith = if isSingleRecord
then M.fromList <$> (zip <$> flds <*> (head <$> vals))
else Left "Expecting a sigle CSV line with header or a JSON object"
allFilters = whereFilters qParams
updateFilters = filter (not . ( '.' `elem` ) . fst) $ allFilters -- update filters can be only on the root table
cond = first formatParserError $ map snd <$> mapM pRequestFilter updateFilters
selectApiRequest = augumentRequestWithJoin schema allRels
=<< buildSelectApiRequest rootName (selectStr qParams) filters (orderStr qParams)
where
rootName = if method == "GET"
then rootTableName
else sourceSubqueryName
filters = if method == "GET"
then allFilters
else filter (( '.' `elem` ) . fst) allFilters -- there can be no filters on the root table whre we are doing insert/update
selectQuery = requestToQuery schema <$> selectApiRequest
mutateQuery = requestToQuery schema <$> case method of
"POST" -> (Node <$> ((,) <$> (Insert rootTableName <$> flds <*> vals) <*> pure (rootTableName, Nothing)) <*> pure [])
"PATCH" -> (Node <$> ((,) <$> (Update rootTableName <$> setWith <*> cond) <*> pure (rootTableName, Nothing)) <*> pure [])
_ -> undefined
createStatement :: Text -> Maybe (Text, Bool) -> Bool -> Maybe NonnegRange -> [Text] -> Bool -> Bool -> Text
createStatement selectQuery Nothing _ range _ countTable asCsv =
wrapQuery selectQuery [
if countTable then countAllF else countNoneF,
countF,
"null", -- location header can not be calucalted
if asCsv then asCsvF else asJsonF
] selectStarF range
createStatement selectQuery (Just (changeQuery, isSingle)) echoRequested _ pKeys _ asCsv =
wrapQuery changeQuery [
countNoneF, -- when updateing it does not make sense
countF,
if isSingle then locationF pKeys else "null",
if echoRequested
then
if asCsv
then asCsvF
else if isSingle then asJsonSingleF else asJsonF
else "null"
] selectQuery Nothing
src/PostgREST/QueryBuilder.hs
+1 -39
View File
@@ -15,15 +15,11 @@ import PostgREST.PgQuery (fromQi, pgFmtCondition, pgFmtSelectItem,
insertableValue, orderF, sourceSubqueryName, pgFmtJsonPath)
import PostgREST.Types
import qualified Data.Map as M
--import qualified Data.Vector as V (empty)
--import qualified Hasql.Backend as B
findRelation :: [Relation] -> Text -> Text -> Text -> Maybe Relation
findRelation allRelations s t1 t2 =
find (\r -> s == relSchema r && t1 == relTable r && t2 == relFTable r) allRelations
addRelations :: Text -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest
addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) forest) =
case parentNode of
@@ -72,45 +68,18 @@ addJoinConditions schema (Node (query, (t, r)) forest) =
updatedForest = mapM (addJoinConditions schema) forest
addCond q con = q{where_=con ++ where_ q}
-- requestToCountQuery :: Text -> ApiRequest -> PStmt
-- requestToCountQuery schema (Node (Select _ _ conditions _, (mainTbl, _)) _) =
-- B.Stmt query V.empty True
-- where
-- query = Data.Text.unwords [
-- "SELECT pg_catalog.count(1)",
-- "FROM ", fromQi $ QualifiedIdentifier schema mainTbl,
-- ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl)) localConditions )) `emptyOnNull` localConditions
-- ]
-- emptyOnNull val x = if null x then "" else val
-- localConditions = filter fn conditions
-- where
-- fn (Filter{value=VText _}) = True
-- fn (Filter{value=VForeignKey _ _}) = False
--requestToQuery :: Text -> ApiRequest -> PStmt
emptyOnNull :: Text -> [a] -> Text
emptyOnNull val x = if null x then "" else val
requestToQuery :: Text -> ApiRequest -> Text
requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)) forest) =
--orderT (fromMaybe [] ord) query
query
where
--query = B.Stmt qStr V.empty True
--qStr = Data.Text.unwords [
-- query = Data.Text.unwords [
-- ("WITH " <> intercalate ", " withs) `emptyOnNull` withs,
-- "SELECT ", intercalate ", " (map (pgFmtSelectItem (QualifiedIdentifier schema mainTbl)) colSelects ++ selects),
-- "FROM ", intercalate ", " (map (fromQi . QualifiedIdentifier schema) tbls),
-- ("WHERE " <> intercalate " AND " ( map (pgFmtCondition (QualifiedIdentifier schema mainTbl) ) conditions )) `emptyOnNull` conditions,
-- orderF (fromMaybe [] ord)
-- ]
-- TODO! the folloing helper functions are just to remove the "schema" part when the table is "source" which is the name
-- of our WITH query part
tblSchema tbl = if tbl == sourceSubqueryName then "" else schema
qi = QualifiedIdentifier (tblSchema mainTbl) mainTbl
toQi t = QualifiedIdentifier (tblSchema t) t
query = Data.Text.unwords [
("WITH " <> intercalate ", " withs) `emptyOnNull` withs,
"SELECT ", intercalate ", " (map (pgFmtSelectItem qi) colSelects ++ selects),
@@ -118,7 +87,6 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)
("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
orderF (fromMaybe [] ord)
]
(withs, selects) = foldr getQueryParts ([],[]) forest
getQueryParts :: Tree ApiNode -> ([Text], [Text]) -> ([Text], [Text])
getQueryParts (Node n@(_, (table, Just (Relation {relType=Child}))) forst) (w,s) = (w,sel:s)
@@ -127,26 +95,20 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)
<> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
<> "FROM (" <> subquery <> ") " <> table
<> ") AS " <> table
--where (B.Stmt subquery _ _) = requestToQuery schema (Node n forst)
where subquery = requestToQuery schema (Node n forst)
getQueryParts (Node n@(_, (table, Just (Relation {relType=Parent}))) forst) (w,s) = (wit:w,sel:s)
where
sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular
wit = table <> " AS ( " <> subquery <> " )"
--where (B.Stmt subquery _ _) = requestToQuery schema (Node n forst)
where subquery = requestToQuery schema (Node n forst)
getQueryParts (Node n@(_, (table, Just (Relation {relType=Many}))) forst) (w,s) = (w,sel:s)
where
sel = "("
<> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
<> "FROM (" <> subquery <> ") " <> table
<> ") AS " <> table
--where (B.Stmt subquery _ _) = requestToQuery schema (Node n forst)
where subquery = requestToQuery schema (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
--posible relations are Child Parent Many
getQueryParts (Node (_,(_,Nothing)) _) _ = undefined