169 lines
8.7 KiB
Haskell
169 lines
8.7 KiB
Haskell
{-# 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)
|