diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index c6c5ef970..b881ec7f8 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -82,10 +82,22 @@ app dbstructure conf reqBody role req = if range == Just emptyRange then return $ responseLBS status416 [] "HTTP Range error" else - case query of + case queries of Left e -> return $ responseLBS status200 [("Content-Type", "text/plain")] $ cs e - Right qs -> do - let q = B.Stmt qs V.empty True + Right (qs, cqs) -> do + let qt = qualify table + q = B.Stmt "select " V.empty True <> + parentheticT ( + cqs + ) <> commaq <> ( + bodyForAccept contentType qt + . limitT range + -- . orderT (orderParse qq) + -- . whereT qt qq + -- $ select qt qq + $ qs + ) + -- return $ responseLBS status200 [contentTypeH] (cs $ show $ B.stmtTemplate q) row <- H.maybeEx q let (tableTotal, queryTotal, body) = fromMaybe (0::Int, 0::Int, Just "" :: Maybe Text) row to = from+queryTotal-1 @@ -115,6 +127,8 @@ app dbstructure conf reqBody role req = >>= addJoinConditions allColumns where formatParserError = pack.show query = dbRequestToQuery <$> dbRequest + countQuery = dbRequestToCountQuery <$> dbRequest + queries = (,) <$> query <*> countQuery -- diff --git a/src/PostgREST/Functions.hs b/src/PostgREST/Functions.hs index 56dd52df4..ee5320242 100644 --- a/src/PostgREST/Functions.hs +++ b/src/PostgREST/Functions.hs @@ -8,7 +8,12 @@ import Data.List (find) import Data.Tree import Data.Text hiding (find, foldr, map, null, last, head) import Data.Monoid -import PostgREST.PgQuery (pgFmtOperator, pgFmtValue, pgFmtIdent, pgFmtLit, fromQi, whiteList, QualifiedIdentifier(..)) +import PostgREST.PgQuery (orderT, pgFmtOperator, pgFmtValue, pgFmtIdent, pgFmtLit, fromQi, whiteList, QualifiedIdentifier(..), StatementT, PStmt) +import qualified Hasql as H +import qualified Hasql.Postgres as P +import qualified Hasql.Backend as B +import qualified Data.Vector as V (empty) + findColumn :: [Column] -> Text -> Text -> Text -> Either Text Column @@ -33,8 +38,8 @@ filterToCondition schema allColumns table (Filter fld op val) = requestNodeToQuery ::Text -> [Table] -> [Column] -> RequestNode -> Either Text Query -requestNodeToQuery schema allTables allColumns (RequestNode tblNameS flds fltrs) = - Select <$> mainTable <*> select <*> joinTables <*> qwhere <*> rel +requestNodeToQuery schema allTables allColumns (RequestNode tblNameS flds fltrs ord) = + Select <$> mainTable <*> select <*> joinTables <*> qwhere <*> rel <*> pure ord where tblName = pack tblNameS mainTable = findTable allTables schema tblName @@ -95,31 +100,37 @@ addJoinConditions allColumns (Node query@(Select{qRelation=relation}) forest) = addCond q con = q{qWhere=con:qWhere q} -dbRequestToCountQuery :: DbRequest -> Text -dbRequestToCountQuery (Node (Select mainTable columns tables conditions relation) forest) = - Data.Text.unwords [ - "SELECT pg_catalog.count(1)", - "FROM ", pgFmtTable mainTable, - ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions - ] - where emptyOnNull val x = if null x then "" else val - -dbRequestToQuery :: DbRequest -> Text -dbRequestToQuery r@(Node (Select mainTable columns tables conditions relation) forest) = - case relation of - Nothing -> "SELECT " - <> "(" - <> dbRequestToCountQuery r - <> ")," - <> "pg_catalog.count(t)," - <> "array_to_json(array_agg(row_to_json(t)))::CHARACTER VARYING AS json " - <> "FROM (" - <> query - <> ") t;" - - _ -> query +dbRequestToCountQuery :: DbRequest -> PStmt +dbRequestToCountQuery (Node (Select mainTable _ _ conditions _ _) forest) = + B.Stmt query V.empty True where - query = Data.Text.unwords [ + query = Data.Text.unwords [ + "SELECT pg_catalog.count(1)", + "FROM ", pgFmtTable mainTable, + ("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions + ] + emptyOnNull val x = if null x then "" else val + +dbRequestToQuery :: DbRequest -> PStmt +dbRequestToQuery r@(Node (Select mainTable columns tables conditions relation ord) forest) = + orderT (fromMaybe [] ord) $ query + -- case relation of + -- Nothing ->B.Stmt ("SELECT " + -- <> "(" + -- <> dbRequestToCountQuery r + -- <> ")," + -- <> "pg_catalog.count(t)," + -- <> "array_to_json(array_agg(row_to_json(t)))::CHARACTER VARYING AS json " + -- <> "FROM (" + -- <> query + -- <> ") t;" + -- ) V.empty True + -- + -- _ -> B.Stmt query V.empty True + where + + query = B.Stmt q V.empty True + q = Data.Text.unwords [ ("WITH " <> intercalate ", " withs) `emptyOnNull` withs, "SELECT ", intercalate ", " (map selectItemToStr columns ++ selects), "FROM ", intercalate ", " (map pgFmtTable (mainTable:tables)), @@ -134,12 +145,15 @@ dbRequestToQuery r@(Node (Select mainTable columns tables conditions relation) f where name = tableName table sel = "(" <> "SELECT array_to_json(array_agg(row_to_json("<>name<>"))) " - <> "FROM (" <> dbRequestToQuery (Node q forst) <> ") " <> name + <> "FROM (" <> subquery <> ") " <> name <> ") AS " <> name + where (B.Stmt subquery _ _) = dbRequestToQuery (Node q forst) + getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Relation{relType="parent"}))}) forst) (w,s) = (wit:w,sel:s) where name = tableName table sel = "row_to_json(" <> name <> ".*) AS "<>name --TODO must be singular - wit = name <> " AS ( " <> dbRequestToQuery (Node q forst) <> " )" + wit = name <> " AS ( " <> subquery <> " )" + where (B.Stmt subquery _ _) = dbRequestToQuery (Node q forst) -- getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Many _ _))}) forst) (w,s) = (w,sel:s) -- where name = tableName table -- sel = "(" diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index d66e28562..03b476222 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -23,30 +23,35 @@ import PostgREST.Types import Data.List (delete, find) import Data.Maybe import Data.String.Conversions (cs) +import Control.Monad (join) + --import qualified Data.ByteString.Char8 as C --buildRequest :: String -> String -> [(String, String)] -> Either P.ParseError Request parseGetRequest :: Request -> Either ParseError ApiRequest parseGetRequest httpRequest = - foldr addFilter <$> apiRequest <*> flts + foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts where apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select ("++selectStr++")") $ cs selectStr + addOrder (Node r f) o = Node r{order=o} f flts = mapM pRequestFilter whereFilters rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest] + orderStr = join $ lookup "order" qString + ord = traverse (parse pOrder ("failed to parse order ()")) orderStr selectStr = fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qString --in case the parametre is missing or empty we default to * whereFilters = [ (k, fromJust v) | (k,v) <- qString, k `notElem` ["select", "order"], isJust v ] pRequestSelect :: String -> Parser ApiRequest pRequestSelect rootNodeName = do fieldTree <- pFieldForest - return $ foldr treeEntry (Node (RequestNode rootNodeName [] []) []) fieldTree + return $ foldr treeEntry (Node (RequestNode rootNodeName [] [] Nothing) []) fieldTree where treeEntry :: Tree SelectItem -> Tree RequestNode -> Tree RequestNode treeEntry (Node fld@((fn, _),_) fldForest) (Node rNode rForest) = case fldForest of [] -> Node (rNode {fields=fld:fields rNode}) rForest - _ -> Node rNode (foldr treeEntry (Node (RequestNode fn [] []) []) fldForest:rForest) + _ -> Node rNode (foldr treeEntry (Node (RequestNode fn [] [] Nothing) []) fldForest:rForest) pRequestFilter :: (String, String) -> Either ParseError (Path, Filter) pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val) @@ -133,14 +138,12 @@ pSelect = lexeme $ return ((s, Nothing), Nothing) pOperator :: Parser Operator -pOperator = try (string "eq") - <|> try (string "gt") +pOperator = try (string "lte") -- has to be before lt <|> try (string "lt") <|> try (string "eq") + <|> try (string "gte") -- has to be before gh <|> try (string "gt") <|> try (string "lt") - <|> try (string "gte") - <|> try (string "lte") <|> try (string "neq") <|> try (string "like") <|> try (string "ilike") @@ -169,3 +172,14 @@ pOpValueExp = do pDelimiter v <- pValue return (o, v) + +pOrder :: Parser ([OrderTerm]) +pOrder = lexeme pOrderTerm `sepBy` char ',' + +pOrderTerm :: Parser OrderTerm +pOrderTerm = do + c <- pFieldName + pDelimiter + d <- string "asc" <|> string "desc" + nls <- optionMaybe (pDelimiter *> ( try(string "nullslast" *> pure ("nulls last"::String)) <|> try(string "nullsfirst" *> pure ("nulls first"::String)))) + return $ OrderTerm (cs c) (cs d) (cs <$> nls) diff --git a/src/PostgREST/PgQuery.hs b/src/PostgREST/PgQuery.hs index 9e7955780..dcbccf626 100644 --- a/src/PostgREST/PgQuery.hs +++ b/src/PostgREST/PgQuery.hs @@ -4,7 +4,7 @@ module PostgREST.PgQuery where import PostgREST.RangeQuery - +import PostgREST.Types (OrderTerm(..)) import qualified Hasql as H import qualified Hasql.Postgres as P import qualified Hasql.Backend as B @@ -39,11 +39,6 @@ data QualifiedIdentifier = QualifiedIdentifier { , qiName :: T.Text } deriving (Show) -data OrderTerm = OrderTerm { - otTerm :: T.Text -, otDirection :: BS.ByteString -, otNullOrder :: Maybe BS.ByteString -} limitT :: Maybe NonnegRange -> StatementT limitT r q = diff --git a/src/PostgREST/RangeQuery.hs b/src/PostgREST/RangeQuery.hs index a138d9559..d28e2574c 100644 --- a/src/PostgREST/RangeQuery.hs +++ b/src/PostgREST/RangeQuery.hs @@ -6,6 +6,7 @@ module PostgREST.RangeQuery ( , NonnegRange ) where +import PostgREST.Types (OrderTerm(..)) import Control.Applicative import Network.HTTP.Types.Header diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 2568e3439..2144a0689 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -1,6 +1,7 @@ module PostgREST.Types where import Data.Text import Data.Tree +import qualified Data.ByteString.Char8 as BS data DbStructure = DbStructure { tables :: [Table] @@ -41,6 +42,13 @@ data PrimaryKey = PrimaryKey { pkSchema::Text, pkTable::Text, pkName::Text } +data OrderTerm = OrderTerm { + otTerm :: Text +, otDirection :: BS.ByteString +, otNullOrder :: Maybe BS.ByteString +} deriving (Show, Eq) + + data Relation = Relation { relSchema :: Text , relTable :: Text @@ -62,7 +70,12 @@ type Field = (FieldName, Maybe JsonPath) type Cast = String type SelectItem = (Field, Maybe Cast) type Path = [String] -data RequestNode = RequestNode {nodeName::String, fields::[SelectItem], filters::[Filter]} deriving (Show, Eq) +data RequestNode = RequestNode { + nodeName::String +, fields::[SelectItem] +, filters::[Filter] +, order::Maybe [OrderTerm] +} deriving (Show, Eq) data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq) -- Db Request Types @@ -70,5 +83,12 @@ type DbField = (Column, Maybe JsonPath) type DbSelectItem = (DbField, Maybe Cast) data DbValue = VText Text | VForeignKey Relation deriving (Show) data Condition = Condition {conColumn::DbField, conOperator::Operator, conValue::DbValue} deriving (Show) -data Query = Select {qMainTable::Table, qSelect::[DbSelectItem], qJoinTables::[Table], qWhere::[Condition], qRelation::Maybe Relation} deriving (Show) +data Query = Select { + qMainTable::Table +, qSelect::[DbSelectItem] +, qJoinTables::[Table] +, qWhere::[Condition] +, qRelation::Maybe Relation +, qOrder::Maybe [OrderTerm] +} deriving (Show) type DbRequest = Tree Query