integrated skin code gor generating Sql Query (only left to execute it)
This commit is contained in:
@@ -52,6 +52,8 @@ executable postgrest
|
|||||||
, mtl
|
, mtl
|
||||||
, cassava
|
, cassava
|
||||||
, jwt
|
, jwt
|
||||||
|
, parsec
|
||||||
|
, errors
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
|
|
||||||
library
|
library
|
||||||
@@ -88,8 +90,12 @@ library
|
|||||||
, mtl
|
, mtl
|
||||||
, cassava
|
, cassava
|
||||||
, jwt
|
, jwt
|
||||||
|
, parsec
|
||||||
|
, errors
|
||||||
Exposed-Modules: PostgREST.App
|
Exposed-Modules: PostgREST.App
|
||||||
, PostgREST.Types
|
, PostgREST.Types
|
||||||
|
, PostgREST.Parsers
|
||||||
|
, PostgREST.Functions
|
||||||
, PostgREST.Auth
|
, PostgREST.Auth
|
||||||
, PostgREST.Config
|
, PostgREST.Config
|
||||||
, PostgREST.Error
|
, PostgREST.Error
|
||||||
@@ -111,6 +117,8 @@ Test-Suite spec
|
|||||||
Main-Is: Main.hs
|
Main-Is: Main.hs
|
||||||
Other-Modules: PostgREST.App
|
Other-Modules: PostgREST.App
|
||||||
, PostgREST.Types
|
, PostgREST.Types
|
||||||
|
, PostgREST.Parsers
|
||||||
|
, PostgREST.Functions
|
||||||
, PostgREST.Auth
|
, PostgREST.Auth
|
||||||
, PostgREST.Config
|
, PostgREST.Config
|
||||||
, PostgREST.Error
|
, PostgREST.Error
|
||||||
@@ -150,3 +158,5 @@ Test-Suite spec
|
|||||||
, process
|
, process
|
||||||
, heredoc
|
, heredoc
|
||||||
, jwt
|
, jwt
|
||||||
|
, parsec
|
||||||
|
, errors
|
||||||
|
|||||||
+17
-3
@@ -9,7 +9,7 @@ module PostgREST.App (app, sqlError, isSqlError, contentTypeForAccept
|
|||||||
import Control.Monad (join)
|
import Control.Monad (join)
|
||||||
import Control.Arrow ((***), second)
|
import Control.Arrow ((***), second)
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
|
import Data.Bifunctor (first)
|
||||||
import Data.Text hiding (map, find, filter)
|
import Data.Text hiding (map, find, filter)
|
||||||
import Data.Maybe (fromMaybe, mapMaybe, isJust, isNothing)
|
import Data.Maybe (fromMaybe, mapMaybe, isJust, isNothing)
|
||||||
import Text.Regex.TDFA ((=~))
|
import Text.Regex.TDFA ((=~))
|
||||||
@@ -47,6 +47,8 @@ import PostgREST.Auth
|
|||||||
import PostgREST.PgQuery
|
import PostgREST.PgQuery
|
||||||
import PostgREST.RangeQuery
|
import PostgREST.RangeQuery
|
||||||
import PostgREST.PgStructure
|
import PostgREST.PgStructure
|
||||||
|
import PostgREST.Parsers
|
||||||
|
import PostgREST.Functions
|
||||||
|
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
@@ -66,20 +68,31 @@ app dbstructure conf reqBody role req =
|
|||||||
|
|
||||||
([], _) -> do
|
([], _) -> do
|
||||||
let body = encode $ filter (filterTableAcl role) $ filter (((cs schema)==).tableSchema) allTables
|
let body = encode $ filter (filterTableAcl role) $ filter (((cs schema)==).tableSchema) allTables
|
||||||
return $ responseLBS status200 [jsonH, ("Custom", "header")] $ cs body
|
return $ responseLBS status200 [jsonH] $ cs body
|
||||||
|
|
||||||
([table], "OPTIONS") -> do
|
([table], "OPTIONS") -> do
|
||||||
let qt = Table schema table
|
let qt = Table schema table
|
||||||
let cols = filter (filterCol schema table) allColumns
|
let cols = filter (filterCol schema table) allColumns
|
||||||
let pkey = map pkName $ filter (filterPk schema table) allPrimaryKeys
|
let pkey = map pkName $ filter (filterPk schema table) allPrimaryKeys
|
||||||
let body = encode (TableOptions cols pkey)
|
let body = encode (TableOptions cols pkey)
|
||||||
return $ responseLBS status200 [jsonH, allOrigins, ("Custom", "header2")] $ cs body
|
return $ responseLBS status200 [jsonH, allOrigins] $ cs body
|
||||||
|
|
||||||
|
|
||||||
([table], "GET") ->
|
([table], "GET") ->
|
||||||
if range == Just emptyRange
|
if range == Just emptyRange
|
||||||
then return $ responseLBS status416 [] "HTTP Range error"
|
then return $ responseLBS status416 [] "HTTP Range error"
|
||||||
else do
|
else do
|
||||||
|
let apiRequest = parseGetRequest req
|
||||||
|
dbRequest = first formatParserError apiRequest
|
||||||
|
>>= traverse (requestNodeToQuery schema allTables allColumns)
|
||||||
|
>>= addRelations allRelations Nothing
|
||||||
|
>>= addJoinConditions allColumns
|
||||||
|
where formatParserError = pack.show
|
||||||
|
query = dbRequestToQuery <$> dbRequest
|
||||||
|
body = show query
|
||||||
|
return $ responseLBS status200 [] $ cs body
|
||||||
|
|
||||||
|
{--
|
||||||
let qt = qualify table
|
let qt = qualify table
|
||||||
from = fromMaybe 0 $ rangeOffset <$> range
|
from = fromMaybe 0 $ rangeOffset <$> range
|
||||||
query = B.Stmt "select " V.empty True <>
|
query = B.Stmt "select " V.empty True <>
|
||||||
@@ -110,6 +123,7 @@ app dbstructure conf reqBody role req =
|
|||||||
if Prelude.null canonical then "" else "?" <> cs canonical
|
if Prelude.null canonical then "" else "?" <> cs canonical
|
||||||
)
|
)
|
||||||
] (cs $ fromMaybe "[]" body)
|
] (cs $ fromMaybe "[]" body)
|
||||||
|
--}
|
||||||
|
|
||||||
(["postgrest", "users"], "POST") -> do
|
(["postgrest", "users"], "POST") -> do
|
||||||
let user = decode reqBody :: Maybe AuthUser
|
let user = decode reqBody :: Maybe AuthUser
|
||||||
|
|||||||
@@ -0,0 +1,168 @@
|
|||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
module PostgREST.Functions
|
||||||
|
where
|
||||||
|
|
||||||
|
import PostgREST.Types
|
||||||
|
import Control.Error
|
||||||
|
import Data.List (find)
|
||||||
|
import Data.Tree
|
||||||
|
import Data.Text hiding (find, foldr, map, null, last)
|
||||||
|
import Data.Monoid
|
||||||
|
import PostgREST.PgQuery (pgFmtOperator, pgFmtValue, pgFmtIdent, pgFmtLit, fromQi, QualifiedIdentifier(..))
|
||||||
|
|
||||||
|
|
||||||
|
findColumn :: [Column] -> Text -> Text -> Text -> Either Text Column
|
||||||
|
findColumn allColumns s t c = note ("no such column: "<>t<>"."<>c) $
|
||||||
|
find (\ col -> colSchema col == s && colTable col == t && colName col == c ) allColumns
|
||||||
|
|
||||||
|
findTable :: [Table] -> Text -> Text -> Either Text Table
|
||||||
|
findTable allTables s t = note ("no such table: "<>t) $
|
||||||
|
find (\tb-> s == tableSchema tb && t == tableName tb ) allTables
|
||||||
|
|
||||||
|
findRelation :: [Relation] -> Text -> Text -> Text -> Maybe Relation
|
||||||
|
findRelation allRelations s t1 t2 =
|
||||||
|
find (\r -> s == relSchema r && t1 == relTable r && t2 == relFTable r) allRelations
|
||||||
|
|
||||||
|
|
||||||
|
filterToCondition :: Text -> [Column] -> Text -> Filter -> Either Text Condition
|
||||||
|
filterToCondition schema allColumns table (Filter fld op val) =
|
||||||
|
Condition <$> c <*> pure op <*> pure (VText (pack val))
|
||||||
|
where
|
||||||
|
c = (,) <$> column <*> pure (snd fld)
|
||||||
|
column = findColumn allColumns schema table $ pack $ fst fld
|
||||||
|
|
||||||
|
|
||||||
|
requestNodeToQuery ::Text -> [Table] -> [Column] -> RequestNode -> Either Text Query
|
||||||
|
requestNodeToQuery schema allTables allColumns (RequestNode tblNameS flds fltrs) =
|
||||||
|
Select <$> mainTable <*> select <*> joinTables <*> qwhere <*> rel
|
||||||
|
where
|
||||||
|
tblName = pack tblNameS
|
||||||
|
mainTable = findTable allTables schema tblName
|
||||||
|
select = mapM toDbSelectItem flds --besides specific columns, we allow * here also
|
||||||
|
where
|
||||||
|
-- it's ok not to check that the table exists here, mainTable will do the checking
|
||||||
|
toDbSelectItem :: SelectItem -> Either Text DbSelectItem
|
||||||
|
toDbSelectItem (("*", Nothing), Nothing) = Right $ ((Star{colSchema = schema, colTable = tblName}, Nothing), Nothing)
|
||||||
|
toDbSelectItem ((c,jp), cast) = (,) <$> dbFld <*> pure cast
|
||||||
|
where
|
||||||
|
col = findColumn allColumns schema tblName $ pack c
|
||||||
|
dbFld = (,) <$> col <*> pure jp
|
||||||
|
|
||||||
|
qwhere = mapM (filterToCondition schema allColumns tblName) fltrs
|
||||||
|
joinTables = pure []
|
||||||
|
rel = pure Nothing
|
||||||
|
|
||||||
|
addRelations :: [Relation] -> Maybe DbRequest -> DbRequest -> Either Text DbRequest
|
||||||
|
addRelations allRelations parentNode node@(Node query@(Select {qMainTable=table}) forest) =
|
||||||
|
case parentNode of
|
||||||
|
Nothing -> Node query{qRelation=Nothing} <$> updatedForest
|
||||||
|
(Just (Node (Select{qMainTable=parentTable}) _)) -> Node <$> (addRel query <$> rel) <*> updatedForest
|
||||||
|
where
|
||||||
|
rel = note ("no relation between " <> (tableName table) <> " and " <> (tableName parentTable)) $
|
||||||
|
findRelation allRelations (tableSchema table) (tableName table) (tableName parentTable)
|
||||||
|
addRel :: Query -> Relation -> Query
|
||||||
|
addRel q r = q{qRelation = Just r}
|
||||||
|
where
|
||||||
|
updatedForest = mapM (addRelations allRelations (Just node)) forest
|
||||||
|
|
||||||
|
|
||||||
|
addJoinConditions :: [Column] -> Tree Query -> Either Text DbRequest
|
||||||
|
addJoinConditions allColumns (Node query@(Select{qRelation=relation}) forest) =
|
||||||
|
case relation of
|
||||||
|
Nothing -> Node <$> updatedQuery <*> updatedForest -- this is the root node
|
||||||
|
Just rel@(Relation{relType="child"}) -> Node <$> (addCond <$> updatedQuery <*> getJoinCondition rel) <*> updatedForest
|
||||||
|
Just (Relation{relType="parent"}) -> Node <$> updatedQuery <*> updatedForest
|
||||||
|
-- Just (Many relationColumn1 relationColumn2) -> Node <$> pure updatedQuery{qJoinTables=linkTable:qJoinTables updatedQuery, qWhere=cond1:cond2:qWhere updatedQuery} <*> updatedForest
|
||||||
|
-- where
|
||||||
|
-- cond1 = getJoinCondition relationColumn1
|
||||||
|
-- cond2 = getJoinCondition relationColumn2
|
||||||
|
-- linkTable = Table "public" (colTable relationColumn1) True
|
||||||
|
_ -> Left "unknow relation"
|
||||||
|
where
|
||||||
|
-- add parentTable and parentJoinConditions to the query
|
||||||
|
updatedQuery = foldr (flip addCond) (query{qJoinTables = parentTables ++ (qJoinTables query)}) <$> parentJoinConditions
|
||||||
|
where
|
||||||
|
parentJoinConditions = mapM (getJoinCondition.snd) parents
|
||||||
|
parentTables = map fst parents
|
||||||
|
parents = mapMaybe (getParents.rootLabel) forest
|
||||||
|
getParents qq@(Select{qRelation=(Just rel@(Relation{relType="parent"}))}) = Just (qMainTable qq, rel)
|
||||||
|
getParents _ = Nothing
|
||||||
|
updatedForest = mapM (addJoinConditions allColumns) forest
|
||||||
|
getJoinCondition rel@(Relation s t c _ _ _) = Condition <$> cc <*> pure "=" <*> pure (VForeignKey rel)
|
||||||
|
where
|
||||||
|
col = findColumn allColumns s t c
|
||||||
|
cc = (,) <$> col <*> pure Nothing
|
||||||
|
addCond q con = q{qWhere=con:qWhere q}
|
||||||
|
|
||||||
|
|
||||||
|
dbRequestToQuery :: DbRequest -> Text
|
||||||
|
dbRequestToQuery (Node (Select mainTable columns tables conditions relation) forest) =
|
||||||
|
case relation of
|
||||||
|
Nothing -> "SELECT "
|
||||||
|
<> "pg_catalog.count(t),"
|
||||||
|
<> "array_to_json(array_agg(row_to_json(t)))::CHARACTER VARYING AS json "
|
||||||
|
<> "FROM ("
|
||||||
|
<> query
|
||||||
|
<> ") t;"
|
||||||
|
|
||||||
|
_ -> query
|
||||||
|
where
|
||||||
|
query = Data.Text.unwords [
|
||||||
|
("WITH " <> intercalate ", " withs) `emptyOnNull` withs,
|
||||||
|
"SELECT ", intercalate ", " (map selectItemToStr columns ++ selects),
|
||||||
|
"FROM ", intercalate ", " (map pgFmtTable (mainTable:tables)),
|
||||||
|
("WHERE " <> intercalate " AND " ( map pgFmtCondition conditions )) `emptyOnNull` conditions
|
||||||
|
]
|
||||||
|
emptyOnNull val x = if null x then "" else val
|
||||||
|
(withs, selects) = foldr getQueryParts ([],[]) forest
|
||||||
|
--getQueryParts is not total but dbRequestToQuery is called only after addJoinConditions which ensures the only
|
||||||
|
--posible relations are Child Parent Many
|
||||||
|
getQueryParts :: Tree Query -> ([Text], [Text]) -> ([Text], [Text])
|
||||||
|
getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Relation {relType="child"}))}) forst) (w,s) = (w,sel:s)
|
||||||
|
where name = tableName table
|
||||||
|
sel = "("
|
||||||
|
<> "SELECT array_to_json(array_agg(row_to_json("<>name<>"))) "
|
||||||
|
<> "FROM (" <> dbRequestToQuery (Node q forst) <> ") " <> name
|
||||||
|
<> ") AS " <> name
|
||||||
|
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) <> " )"
|
||||||
|
-- getQueryParts (Node q@(Select{qMainTable=table, qRelation=(Just (Many _ _))}) forst) (w,s) = (w,sel:s)
|
||||||
|
-- where name = tableName table
|
||||||
|
-- sel = "("
|
||||||
|
-- <> "SELECT array_to_json(array_agg(row_to_json("<>name<>"))) "
|
||||||
|
-- <> "FROM (" <> dbRequestToQuery (Node q forst) <> ") " <> name
|
||||||
|
-- <> ") AS " <> name
|
||||||
|
-- the following is just to remove the warning, maybe relType should not be String?
|
||||||
|
getQueryParts (Node (Select{qRelation=Nothing}) _) _ = undefined
|
||||||
|
getQueryParts (Node (Select{qRelation=(Just (Relation {relType=_}))}) _) _ = undefined
|
||||||
|
|
||||||
|
pgFmtCondition :: Condition -> Text
|
||||||
|
pgFmtCondition (Condition (col,jp) ops val) = pgFmtColumn col <> pgFmtJsonPath jp <> opToStr op <> valToStr val
|
||||||
|
where
|
||||||
|
op = pack ops
|
||||||
|
opToStr o = pgFmtOperator o
|
||||||
|
valToStr v = case v of
|
||||||
|
VText s -> pgFmtValue op s
|
||||||
|
VForeignKey (Relation{relFTable=table, relFColumn=column}) -> table <> "." <> column
|
||||||
|
|
||||||
|
pgFmtColumn :: Column -> Text
|
||||||
|
pgFmtColumn Column {colSchema=s, colTable=t, colName=c} = pgFmtIdent s <> "." <> pgFmtIdent t <> "." <> pgFmtIdent c
|
||||||
|
pgFmtColumn Star {colSchema=s, colTable=t} = pgFmtIdent s <> "." <> pgFmtIdent t <> ".*"
|
||||||
|
|
||||||
|
pgFmtJsonPath :: Maybe JsonPath -> Text
|
||||||
|
pgFmtJsonPath (Just [x]) = "->>" <> (pgFmtLit $ pack x)
|
||||||
|
pgFmtJsonPath (Just (x:xs)) = "->" <> pgFmtLit (pack x) <> pgFmtJsonPath ( Just xs )
|
||||||
|
pgFmtJsonPath _ = ""
|
||||||
|
|
||||||
|
pgFmtTable :: Table -> Text
|
||||||
|
pgFmtTable Table{tableSchema=s, tableName=n} = fromQi $ QualifiedIdentifier s n
|
||||||
|
|
||||||
|
selectItemToStr :: DbSelectItem -> Text
|
||||||
|
selectItemToStr ((c, jp), Nothing) = pgFmtColumn c <> pgFmtJsonPath jp <> asJsonPath jp
|
||||||
|
selectItemToStr ((c, jp), Just cast ) = "CAST (" <> pgFmtColumn c <> pgFmtJsonPath jp <> " AS " <> pack cast <> " )" <> asJsonPath jp
|
||||||
|
|
||||||
|
asJsonPath :: Maybe JsonPath -> Text
|
||||||
|
asJsonPath Nothing = ""
|
||||||
|
asJsonPath (Just xx) = " AS " <> (pack $ last xx)
|
||||||
@@ -0,0 +1,154 @@
|
|||||||
|
--{-# LANGUAGE QuasiQuotes, ScopedTypeVariables, OverloadedStrings, FlexibleContexts #-}
|
||||||
|
module PostgREST.Parsers
|
||||||
|
-- ( parseGetRequest
|
||||||
|
-- , pSelect
|
||||||
|
-- , pField
|
||||||
|
-- , pRequestSelect
|
||||||
|
-- )
|
||||||
|
|
||||||
|
where
|
||||||
|
import Text.ParserCombinators.Parsec hiding (many, (<|>))
|
||||||
|
--import Text.Parsec.Text
|
||||||
|
--import Text.Parsec hiding (many, (<|>))
|
||||||
|
--import Text.Parsec.Prim hiding (many, (<|>))
|
||||||
|
import Control.Applicative
|
||||||
|
--import Control.Monad
|
||||||
|
--import qualified Data.Text as T
|
||||||
|
import Data.Tree
|
||||||
|
import Network.Wai (Request, pathInfo, queryString)
|
||||||
|
import PostgREST.Types
|
||||||
|
--import qualified Data.ByteString.Char8 as C
|
||||||
|
--import Control.Monad
|
||||||
|
--import Data.Foldable (foldrM)
|
||||||
|
import Data.List (delete, find)
|
||||||
|
import Data.Maybe
|
||||||
|
import Data.String.Conversions (cs)
|
||||||
|
--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
|
||||||
|
where
|
||||||
|
apiRequest = parse (pRequestSelect rootTableName) ("failed to parse select ("++selectStr++")") $ cs selectStr
|
||||||
|
flts = mapM pRequestFilter whereFilters
|
||||||
|
rootTableName = cs $ head $ pathInfo httpRequest -- TODO unsafe head
|
||||||
|
qString = [(cs k, cs <$> v)|(k,v) <- queryString httpRequest]
|
||||||
|
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"], isJust v ]
|
||||||
|
|
||||||
|
pRequestSelect :: String -> Parser ApiRequest
|
||||||
|
pRequestSelect rootNodeName = do
|
||||||
|
fieldTree <- pFieldForest
|
||||||
|
return $ foldr treeEntry (Node (RequestNode rootNodeName [] []) []) 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)
|
||||||
|
|
||||||
|
pRequestFilter :: (String, String) -> Either ParseError (Path, Filter)
|
||||||
|
pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
|
||||||
|
where
|
||||||
|
treePath = parse pTreePath ("failed to parser tree path ("++k++")") k
|
||||||
|
opVal = parse pOpValueExp ("failed to parse filter ("++v++")") v
|
||||||
|
path = fst <$> treePath
|
||||||
|
fld = snd <$> treePath
|
||||||
|
op = fst <$> opVal
|
||||||
|
val = snd <$> opVal
|
||||||
|
|
||||||
|
addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest
|
||||||
|
addFilter ([], flt) (Node rn@(RequestNode {filters=flts}) forest) = Node (rn {filters=flt:flts}) forest
|
||||||
|
addFilter (path, flt) (Node rn forest) =
|
||||||
|
case targetNode of
|
||||||
|
Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path
|
||||||
|
Just tn -> Node rn (addFilter (remainingPath, flt) tn:restForest)
|
||||||
|
where
|
||||||
|
targetNodeName:remainingPath = path
|
||||||
|
(targetNode,restForest) = splitForest targetNodeName forest
|
||||||
|
splitForest name forst =
|
||||||
|
case maybeNode of
|
||||||
|
Nothing -> (Nothing,forest)
|
||||||
|
Just node -> (Just node, delete node forest)
|
||||||
|
where maybeNode = find ((name==).nodeName.rootLabel) forst
|
||||||
|
|
||||||
|
ws :: Parser String
|
||||||
|
ws = many (oneOf " \t")
|
||||||
|
|
||||||
|
--lexeme :: Parser String -> Parser String
|
||||||
|
--lexeme :: Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity a -> Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity a
|
||||||
|
--lexeme :: Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity Char -> Text.Parsec.Prim.ParsecT String () Data.Functor.Identity.Identity Char
|
||||||
|
lexeme p = ws *> p <* ws
|
||||||
|
|
||||||
|
pTreePath :: Parser (Path,Field)
|
||||||
|
pTreePath = do
|
||||||
|
p <- (pFieldName `sepBy1` pDelimiter)
|
||||||
|
--f <- pField
|
||||||
|
jp <- optionMaybe ( string "->" >> pJsonPath)
|
||||||
|
return (init p, (last p, jp))
|
||||||
|
|
||||||
|
|
||||||
|
pFieldForest :: Parser [Tree SelectItem]
|
||||||
|
pFieldForest = pFieldTree `sepBy1` lexeme (char ',')
|
||||||
|
|
||||||
|
pFieldTree :: Parser (Tree SelectItem)
|
||||||
|
pFieldTree =
|
||||||
|
try ( do
|
||||||
|
fld <- pSelect
|
||||||
|
char '('
|
||||||
|
subforest <- pFieldForest
|
||||||
|
char ')'
|
||||||
|
return (Node fld subforest)
|
||||||
|
)
|
||||||
|
<|> do
|
||||||
|
fld <- pSelect
|
||||||
|
return (Node fld [])
|
||||||
|
|
||||||
|
pStar :: Parser String
|
||||||
|
pStar = string "*" *> pure "*"
|
||||||
|
|
||||||
|
pFieldName :: Parser String
|
||||||
|
pFieldName = many1 (letter <|> digit <|> oneOf "_")
|
||||||
|
<?> "field name (* or [a..z0..9_])"
|
||||||
|
|
||||||
|
pJsonPath :: Parser [String]
|
||||||
|
pJsonPath = pFieldName `sepBy1` (try (string "->>") <|> string "->")
|
||||||
|
|
||||||
|
pField :: Parser Field
|
||||||
|
pField = lexeme $ do
|
||||||
|
f <- pFieldName
|
||||||
|
jp <- optionMaybe ( (try (string "->>") <|> string "->") >> pJsonPath)
|
||||||
|
return (f, jp)
|
||||||
|
|
||||||
|
pSelect :: Parser SelectItem
|
||||||
|
pSelect = lexeme $
|
||||||
|
try (do
|
||||||
|
n <- pField
|
||||||
|
v <- optionMaybe (string "::" >> many letter)
|
||||||
|
return (n, v)
|
||||||
|
)
|
||||||
|
<|> do
|
||||||
|
s <- pStar
|
||||||
|
return ((s, Nothing), Nothing)
|
||||||
|
|
||||||
|
pOperator :: Parser Operator
|
||||||
|
pOperator = try (string "eq")
|
||||||
|
<|> try (string "gt")
|
||||||
|
<|> try (string "lt")
|
||||||
|
<?> "operator (eq, gt, ...)"
|
||||||
|
|
||||||
|
pInt :: Parser Int
|
||||||
|
pInt = try (liftA read (many1 digit)) <?> "integer"
|
||||||
|
|
||||||
|
--pValue :: Parser Value
|
||||||
|
--pValue = (VInt <$> try (pInt <* eof))
|
||||||
|
-- <|>(VString <$> many anyChar)
|
||||||
|
pValue :: Parser FValue
|
||||||
|
pValue = many anyChar
|
||||||
|
|
||||||
|
pDelimiter :: Parser Char
|
||||||
|
pDelimiter = char '.' <?> "delimiter (.)"
|
||||||
|
|
||||||
|
pOpValueExp :: Parser (Operator, FValue)
|
||||||
|
pOpValueExp = liftA2 (,) pOperator (pDelimiter *> pValue)
|
||||||
+36
-25
@@ -222,35 +222,46 @@ wherePred table (col, predicate) =
|
|||||||
opCode = hasNot (head rest) headPredicate
|
opCode = hasNot (head rest) headPredicate
|
||||||
notOp = hasNot headPredicate ""
|
notOp = hasNot headPredicate ""
|
||||||
value = hasNot (T.intercalate "." $ tail rest) (T.intercalate "." rest)
|
value = hasNot (T.intercalate "." $ tail rest) (T.intercalate "." rest)
|
||||||
whiteList val = fromMaybe
|
sqlValue = pgFmtValue opCode value
|
||||||
(cs (pgFmtLit val) <> "::unknown ")
|
op = pgFmtOperator opCode
|
||||||
(L.find ((==) . T.toLower $ val) ["null","true","false"])
|
|
||||||
|
|
||||||
|
whiteList :: T.Text -> T.Text
|
||||||
|
whiteList val = fromMaybe
|
||||||
|
(cs (pgFmtLit val) <> "::unknown ")
|
||||||
|
(L.find ((==) . T.toLower $ val) ["null","true","false"])
|
||||||
|
|
||||||
|
pgFmtValue :: T.Text -> T.Text -> T.Text
|
||||||
|
pgFmtValue opCode value =
|
||||||
|
case opCode of
|
||||||
|
"like" -> unknownLiteral $ T.map star value
|
||||||
|
"ilike" -> unknownLiteral $ T.map star value
|
||||||
|
"in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") "
|
||||||
|
"notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") "
|
||||||
|
"@@" -> "to_tsquery(" <> unknownLiteral value <> ") "
|
||||||
|
_ -> unknownLiteral value
|
||||||
|
where
|
||||||
star c = if c == '*' then '%' else c
|
star c = if c == '*' then '%' else c
|
||||||
unknownLiteral = (<> "::unknown ") . pgFmtLit
|
unknownLiteral = (<> "::unknown ") . pgFmtLit
|
||||||
|
|
||||||
sqlValue = case opCode of
|
pgFmtOperator :: T.Text -> T.Text
|
||||||
"like" -> unknownLiteral $ T.map star value
|
pgFmtOperator opCode =
|
||||||
"ilike" -> unknownLiteral $ T.map star value
|
case opCode of
|
||||||
"in" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") "
|
"eq" -> "="
|
||||||
"notin" -> "(" <> T.intercalate ", " (map unknownLiteral $ T.split (==',') value) <> ") "
|
"gt" -> ">"
|
||||||
"@@" -> "to_tsquery(" <> unknownLiteral value <> ") "
|
"lt" -> "<"
|
||||||
_ -> unknownLiteral value
|
"gte" -> ">="
|
||||||
|
"lte" -> "<="
|
||||||
|
"neq" -> "<>"
|
||||||
|
"like"-> "like"
|
||||||
|
"ilike"-> "ilike"
|
||||||
|
"in" -> "in"
|
||||||
|
"notin" -> "not in"
|
||||||
|
"is" -> "is"
|
||||||
|
"isnot" -> "is not"
|
||||||
|
"@@" -> "@@"
|
||||||
|
_ -> "="
|
||||||
|
|
||||||
op = case opCode of
|
|
||||||
"eq" -> "="
|
|
||||||
"gt" -> ">"
|
|
||||||
"lt" -> "<"
|
|
||||||
"gte" -> ">="
|
|
||||||
"lte" -> "<="
|
|
||||||
"neq" -> "<>"
|
|
||||||
"like"-> "like"
|
|
||||||
"ilike"-> "ilike"
|
|
||||||
"in" -> "in"
|
|
||||||
"notin" -> "not in"
|
|
||||||
"is" -> "is"
|
|
||||||
"isnot" -> "is not"
|
|
||||||
"@@" -> "@@"
|
|
||||||
_ -> "="
|
|
||||||
|
|
||||||
orderParse :: Net.Query -> [OrderTerm]
|
orderParse :: Net.Query -> [OrderTerm]
|
||||||
orderParse q =
|
orderParse q =
|
||||||
|
|||||||
+25
-1
@@ -1,5 +1,6 @@
|
|||||||
module PostgREST.Types where
|
module PostgREST.Types where
|
||||||
import Data.Text
|
import Data.Text
|
||||||
|
import Data.Tree
|
||||||
|
|
||||||
data DbStructure = DbStructure {
|
data DbStructure = DbStructure {
|
||||||
tables :: [Table]
|
tables :: [Table]
|
||||||
@@ -34,7 +35,7 @@ data Column = Column {
|
|||||||
, colDefault :: Maybe Text
|
, colDefault :: Maybe Text
|
||||||
, colEnum :: [Text]
|
, colEnum :: [Text]
|
||||||
, colFK :: Maybe ForeignKey
|
, colFK :: Maybe ForeignKey
|
||||||
} deriving (Show)
|
} | Star {colSchema :: Text, colTable :: Text } deriving (Show)
|
||||||
|
|
||||||
data PrimaryKey = PrimaryKey {
|
data PrimaryKey = PrimaryKey {
|
||||||
pkSchema::Text, pkTable::Text, pkName::Text
|
pkSchema::Text, pkTable::Text, pkName::Text
|
||||||
@@ -48,3 +49,26 @@ data Relation = Relation {
|
|||||||
, relFColumn :: Text
|
, relFColumn :: Text
|
||||||
, relType :: Text
|
, relType :: Text
|
||||||
} deriving (Show, Eq)
|
} deriving (Show, Eq)
|
||||||
|
|
||||||
|
|
||||||
|
--------
|
||||||
|
-- Request Types
|
||||||
|
type Operator = String
|
||||||
|
type FValue = String
|
||||||
|
type ApiRequest = Tree RequestNode
|
||||||
|
type FieldName = String
|
||||||
|
type JsonPath = [String]
|
||||||
|
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 Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq)
|
||||||
|
|
||||||
|
-- Db Request Types
|
||||||
|
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)
|
||||||
|
type DbRequest = Tree Query
|
||||||
|
|||||||
Reference in New Issue
Block a user