cleanup suggested by @begriffs
This commit is contained in:
Ruslan Talpa
+19
-29
@@ -29,7 +29,7 @@ import Data.Ord (comparing)
|
||||
import Data.Ranged.Ranges (emptyRange)
|
||||
import qualified Data.Set as S
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Text (Text, pack)
|
||||
import Data.Text (Text)
|
||||
import Text.Regex.TDFA ((=~))
|
||||
|
||||
import Network.HTTP.Base (urlEncodeVars)
|
||||
@@ -63,22 +63,19 @@ app dbstructure conf reqBody dbrole req =
|
||||
case (path, verb) of
|
||||
|
||||
([], _) -> do
|
||||
let body = encode $ filter (filterTableAcl dbrole) $ filter ((cs schema==).tableSchema) allTables
|
||||
let body = encode $ filter (filterTableAcl dbrole) $ filter ((cs schema==).tableSchema) allTabs
|
||||
return $ responseLBS status200 [jsonH] $ cs body
|
||||
|
||||
([table], "OPTIONS") -> do
|
||||
--let qt = Table schema table
|
||||
let cols = filter (filterCol schema table) allColumns
|
||||
let pkeys = map pkName $ filter (filterPk schema table) allPrimaryKeys
|
||||
let body = encode (TableOptions cols pkeys)
|
||||
let cols = filter (filterCol schema table) allCols
|
||||
pkeys = map pkName $ filter (filterPk schema table) allPrKeys
|
||||
body = encode (TableOptions cols pkeys)
|
||||
return $ responseLBS status200 [jsonH, allOrigins] $ cs body
|
||||
|
||||
|
||||
([table], "GET") ->
|
||||
if range == Just emptyRange
|
||||
then return $ responseLBS status416 [] "HTTP Range error"
|
||||
else
|
||||
-- return $ responseLBS status416 [] $ cs $ show queries
|
||||
case queries of
|
||||
Left e -> return $ responseLBS status400 [("Content-Type", "text/plain")] $ cs e
|
||||
Right (qs, cqs) -> do
|
||||
@@ -94,7 +91,6 @@ app dbstructure conf reqBody dbrole req =
|
||||
. limitT range
|
||||
$ qs
|
||||
)
|
||||
-- return $ responseLBS status200 [contentTypeH] (cs $ show $ B.stmtTemplate q)
|
||||
row <- H.maybeEx q
|
||||
let (tableTotal, queryTotal, body) = fromMaybe (Just (0::Int), 0::Int, Just "" :: Maybe Text) row
|
||||
to = from+queryTotal-1
|
||||
@@ -105,8 +101,6 @@ app dbstructure conf reqBody dbrole req =
|
||||
. map (join (***) cs)
|
||||
. parseSimpleQuery
|
||||
$ rawQueryString req
|
||||
|
||||
|
||||
return $ responseLBS status
|
||||
[contentTypeH, contentRange,
|
||||
("Content-Location",
|
||||
@@ -118,9 +112,9 @@ app dbstructure conf reqBody dbrole req =
|
||||
where
|
||||
from = fromMaybe 0 $ rangeOffset <$> range
|
||||
apiRequest = first formatParserError (parseGetRequest req)
|
||||
>>= addRelations schema allRelations Nothing
|
||||
>>= addJoinConditions schema allColumns
|
||||
where formatParserError = pack.show
|
||||
>>= addRelations schema allRels Nothing
|
||||
>>= addJoinConditions schema allCols
|
||||
where formatParserError = cs.show
|
||||
query = requestToQuery schema <$> apiRequest
|
||||
countQuery = requestToCountQuery schema <$> apiRequest
|
||||
queries = (,) <$> query <*> countQuery
|
||||
@@ -180,9 +174,8 @@ app dbstructure conf reqBody dbrole req =
|
||||
Right toBeInserted -> do
|
||||
rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted
|
||||
let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows
|
||||
pKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys
|
||||
--pKeys <- primaryKeyColumns qt
|
||||
let responses = flip map inserted $ \obj -> do
|
||||
pKeys = map pkName $ filter (filterPk schema table) allPrKeys
|
||||
responses = flip map inserted $ \obj -> do
|
||||
let primaries =
|
||||
if Prelude.null pKeys
|
||||
then obj
|
||||
@@ -215,16 +208,14 @@ app dbstructure conf reqBody dbrole req =
|
||||
([table], "PUT") ->
|
||||
handleJsonObj reqBody $ \obj -> do
|
||||
let qt = qualify table
|
||||
pKeys = map pkName $ filter (filterPk schema table) allPrimaryKeys
|
||||
--pKeys <- primaryKeyColumns qt
|
||||
let specifiedKeys = map (cs . fst) qq
|
||||
pKeys = map pkName $ filter (filterPk schema table) allPrKeys
|
||||
specifiedKeys = map (cs . fst) qq
|
||||
if S.fromList pKeys /= S.fromList specifiedKeys
|
||||
then return $ responseLBS status405 []
|
||||
"You must speficy all and only primary keys as params"
|
||||
else do
|
||||
--tableCols <- map (cs . colName) <$> columns qt
|
||||
let tableCols = map (cs . colName) $ filter (filterCol schema table) allColumns
|
||||
let cols = map cs $ M.keys obj
|
||||
let tableCols = map (cs . colName) $ filter (filterCol schema table) allCols
|
||||
cols = map cs $ M.keys obj
|
||||
if S.fromList tableCols == S.fromList cols
|
||||
then do
|
||||
let vals = M.elems obj
|
||||
@@ -274,14 +265,13 @@ app dbstructure conf reqBody dbrole req =
|
||||
return $ responseLBS status404 [] ""
|
||||
|
||||
where
|
||||
allTables = tables dbstructure
|
||||
allRelations = relations dbstructure
|
||||
allColumns = columns dbstructure
|
||||
allPrimaryKeys = primaryKeys dbstructure
|
||||
--allTablesAcl = tablesAcl dbstructure
|
||||
allTabs = tables dbstructure
|
||||
allRels = relations dbstructure
|
||||
allCols = columns dbstructure
|
||||
allPrKeys = primaryKeys dbstructure
|
||||
filterCol sc table (Column{colSchema=s, colTable=t}) = s==sc && table==t
|
||||
filterCol _ _ _ = False
|
||||
filterPk sc table (PrimaryKey{pkSchema=s, pkTable=t}) = s==sc && table==t
|
||||
filterPk sc table pk = sc == pkSchema pk && table == pkTable pk
|
||||
|
||||
filterTableAcl :: Text -> Table -> Bool
|
||||
filterTableAcl r (Table{tableAcl=a}) = r `elem` a
|
||||
|
||||
@@ -29,10 +29,10 @@ data AppConfig = AppConfig {
|
||||
|
||||
argParser :: Parser AppConfig
|
||||
argParser = AppConfig
|
||||
<$> strOption (long "db-name" <> short 'd' <> metavar "NAME" <> value "skin_test" <> help "name of database")
|
||||
<$> strOption (long "db-name" <> short 'd' <> metavar "NAME" <> help "name of database")
|
||||
<*> option auto (long "db-port" <> short 'P' <> metavar "PORT" <> value 5432 <> help "postgres server port" <> showDefault)
|
||||
<*> strOption (long "db-user" <> short 'U' <> metavar "ROLE" <> value "skin_test" <> help "postgres authenticator role")
|
||||
<*> strOption (long "db-pass" <> metavar "PASS" <> value "skin_pass" <> help "password for authenticator role")
|
||||
<*> strOption (long "db-user" <> short 'U' <> metavar "ROLE" <> help "postgres authenticator role")
|
||||
<*> strOption (long "db-pass" <> metavar "PASS" <> help "password for authenticator role")
|
||||
<*> strOption (long "db-host" <> metavar "HOST" <> value "localhost" <> help "postgres server hostname" <> showDefault)
|
||||
|
||||
<*> option auto (long "port" <> short 'p' <> metavar "PORT" <> value 3000 <> help "port number on which to run HTTP server" <> showDefault)
|
||||
|
||||
+17
-33
@@ -2,17 +2,10 @@ module Main where
|
||||
|
||||
|
||||
import Paths_postgrest (version)
|
||||
-- added
|
||||
import PostgREST.PgStructure
|
||||
--import Data.Aeson
|
||||
--import Data.List (find)
|
||||
--import Data.Maybe (isJust)
|
||||
import PostgREST.Types
|
||||
--import Network.HTTP.Types.Status
|
||||
--import Network.HTTP.Types.Header
|
||||
import Network.Wai
|
||||
|
||||
|
||||
import PostgREST.App
|
||||
import PostgREST.Error (errResponse)
|
||||
import PostgREST.Middleware
|
||||
@@ -87,37 +80,28 @@ main = do
|
||||
fail "Cannot run in this PostgreSQL version, PostgREST needs at least 9.2.0"
|
||||
) supportedOrError
|
||||
|
||||
-- read the structure of the database
|
||||
-- read the structure of the database
|
||||
let txParam = Just (H.ReadCommitted, Just True)
|
||||
let txSettings = Just (H.ReadCommitted, Just True)
|
||||
metadata <- H.session pool $ H.tx txSettings $ do
|
||||
tabs <- allTables
|
||||
rels <- allRelations
|
||||
cols <- allColumns rels
|
||||
keys <- allPrimaryKeys
|
||||
return (tabs, rels, cols, keys)
|
||||
|
||||
tblsRes <- H.session pool $ H.tx txParam alltables
|
||||
let allTables = either (fail . show) id tblsRes
|
||||
dbstructure <- case metadata of
|
||||
Left e -> fail $ show e
|
||||
Right (tabs, rels, cols, keys) ->
|
||||
return $ DbStructure {
|
||||
tables=tabs
|
||||
, columns=cols
|
||||
, relations=rels
|
||||
, primaryKeys=keys
|
||||
}
|
||||
|
||||
relsRes <- H.session pool $ H.tx txParam allrelations
|
||||
let allRelations = either (fail . show) id relsRes
|
||||
|
||||
colsRes <- H.session pool $ H.tx txParam $ allcolumns allRelations
|
||||
let allColumns = either (fail . show) id colsRes
|
||||
|
||||
pkRes <- H.session pool $ H.tx txParam allprimaryKeys
|
||||
let allPrimaryKeys = either (fail . show) id pkRes
|
||||
|
||||
-- tableAclRes <- H.session pool $ H.tx txParam $ alltablesAcl
|
||||
-- let allTablesAcl = either (fail . show) id tableAclRes
|
||||
|
||||
|
||||
let dbstructure = DbStructure {
|
||||
tables=allTables
|
||||
, columns=allColumns
|
||||
, relations=allRelations
|
||||
, primaryKeys=allPrimaryKeys
|
||||
--, tablesAcl=allTablesAcl
|
||||
}
|
||||
|
||||
runSettings appSettings $ middle $ \ req respond -> do
|
||||
body <- strictRequestBody req
|
||||
resOrError <- liftIO $ H.session pool $ H.tx (Just (H.ReadCommitted, Just True)) $
|
||||
resOrError <- liftIO $ H.session pool $ H.tx txSettings $
|
||||
authenticated conf (app dbstructure conf body) req
|
||||
either (respond . errResponse) respond resOrError
|
||||
|
||||
|
||||
@@ -6,8 +6,6 @@ module PostgREST.Middleware where
|
||||
import Data.Maybe (fromMaybe, isNothing)
|
||||
import Data.Monoid
|
||||
import Data.Text
|
||||
-- import Data.Pool(withResource, Pool)
|
||||
|
||||
import Data.String.Conversions (cs)
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Postgres as P
|
||||
|
||||
@@ -4,6 +4,7 @@ module PostgREST.Parsers
|
||||
where
|
||||
|
||||
import Control.Applicative hiding ((<$>))
|
||||
--lines needed for ghc 7.8
|
||||
import Data.Functor ((<$>))
|
||||
import Data.Traversable (traverse)
|
||||
|
||||
@@ -31,17 +32,6 @@ parseGetRequest 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", "order"], isJust v ]
|
||||
|
||||
{--
|
||||
data Query = Select {
|
||||
mainTable::Text
|
||||
, fields::[SelectItem]
|
||||
, joinTables::[Text]
|
||||
, filters::[Filter]
|
||||
, order::Maybe [OrderTerm]
|
||||
, relation::Maybe Relation
|
||||
} deriving (Show)
|
||||
|
||||
--}
|
||||
pRequestSelect :: Text -> Parser ApiRequest
|
||||
pRequestSelect rootNodeName = do
|
||||
fieldTree <- pFieldForest
|
||||
@@ -142,12 +132,6 @@ pOperator = cs <$> ( try (string "lte") -- has to be before 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 = VText <$> (cs <$> many anyChar)
|
||||
|
||||
|
||||
@@ -1,25 +1,23 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
module PostgREST.PgStructure where
|
||||
|
||||
import Data.List (find)
|
||||
import Data.Text (Text, split)
|
||||
import PostgREST.PgQuery ()
|
||||
import PostgREST.Types
|
||||
import Data.Functor.Identity
|
||||
import Control.Applicative
|
||||
import Data.Functor.Identity
|
||||
import Data.List (find)
|
||||
import Data.Maybe (fromMaybe, isJust, mapMaybe)
|
||||
import Data.Monoid
|
||||
|
||||
--import qualified Data.Map as Map
|
||||
|
||||
import Data.Monoid
|
||||
import Data.Text (Text, split)
|
||||
import qualified Hasql as H
|
||||
import qualified Hasql.Postgres as P
|
||||
import PostgREST.PgQuery ()
|
||||
import PostgREST.Types
|
||||
|
||||
import GHC.Exts (groupWith)
|
||||
import Prelude
|
||||
import GHC.Exts (groupWith)
|
||||
|
||||
|
||||
doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool
|
||||
@@ -54,21 +52,18 @@ columnFromRow (s, t, n, pos, nul, typ, u, l, p, d, e) =
|
||||
parseEnum str = fromMaybe [] $ split (==',') <$> str
|
||||
|
||||
|
||||
------------
|
||||
|
||||
|
||||
relationFromRow :: (Text, Text, Text, Text, Text) -> Relation
|
||||
relationFromRow (s, t, c, ft, fc) = Relation s t c ft fc "child" Nothing Nothing Nothing
|
||||
relationFromRow (s, t, c, ft, fc) = Relation s t c ft fc Child Nothing Nothing Nothing
|
||||
|
||||
pkFromRow :: (Text, Text, Text) -> PrimaryKey
|
||||
pkFromRow (s, t, n) = PrimaryKey s t n
|
||||
|
||||
|
||||
addParentRelation :: Relation -> [Relation] -> [Relation]
|
||||
addParentRelation rel@(Relation s t c ft fc _ _ _ _) rels = Relation s ft fc t c "parent" Nothing Nothing Nothing:rel:rels
|
||||
addParentRelation rel@(Relation s t c ft fc _ _ _ _) rels = Relation s ft fc t c Parent Nothing Nothing Nothing:rel:rels
|
||||
|
||||
alltables :: H.Tx P.Postgres s [Table]
|
||||
alltables = do
|
||||
allTables :: H.Tx P.Postgres s [Table]
|
||||
allTables = do
|
||||
rows <- H.listEx $ [H.stmt|
|
||||
SELECT
|
||||
n.nspname AS table_schema,
|
||||
@@ -96,8 +91,8 @@ alltables = do
|
||||
|]
|
||||
return $ map tableFromRow rows
|
||||
|
||||
allrelations :: H.Tx P.Postgres s [Relation]
|
||||
allrelations = do
|
||||
allRelations :: H.Tx P.Postgres s [Relation]
|
||||
allRelations = do
|
||||
rels <- H.listEx $ [H.stmt|
|
||||
WITH table_fk AS (
|
||||
SELECT DISTINCT
|
||||
@@ -129,7 +124,7 @@ allrelations = do
|
||||
|
||||
|]
|
||||
let simpleRelations = foldr (addParentRelation.relationFromRow) [] rels
|
||||
let links = filter ((==2).length) $ groupWith groupFn $ filter ( (=="child"). relType) simpleRelations
|
||||
let links = filter ((==2).length) $ groupWith groupFn $ filter ( (==Child). relType) simpleRelations
|
||||
return $ simpleRelations ++ mapMaybe link2Relation links
|
||||
where
|
||||
groupFn :: Relation -> Text
|
||||
@@ -137,11 +132,11 @@ allrelations = do
|
||||
link2Relation [
|
||||
Relation{relSchema=sc, relTable=lt, relColumn=lc1, relFTable=t, relFColumn=c},
|
||||
Relation{ relColumn=lc2, relFTable=ft, relFColumn=fc}
|
||||
] = Just $ Relation sc t c ft fc "many" (Just lt) (Just lc1) (Just lc2)
|
||||
] = Just $ Relation sc t c ft fc Many (Just lt) (Just lc1) (Just lc2)
|
||||
link2Relation _ = Nothing
|
||||
|
||||
allcolumns :: [Relation] -> H.Tx P.Postgres s [Column]
|
||||
allcolumns rels = do
|
||||
allColumns :: [Relation] -> H.Tx P.Postgres s [Column]
|
||||
allColumns rels = do
|
||||
cols <- H.listEx $ [H.stmt|
|
||||
SELECT
|
||||
info.table_schema AS schema,
|
||||
@@ -189,34 +184,43 @@ allcolumns rels = do
|
||||
addFK col = col { colFK = relToFk <$> find (lookupFn col) rels }
|
||||
lookupFn :: Column -> Relation -> Bool
|
||||
lookupFn (Column{colSchema=cs, colTable=ct, colName=cn}) (Relation{relSchema=rs, relTable=rt, relColumn=rc, relType=rty}) =
|
||||
cs==rs && ct==rt && cn==rc && rty=="child"
|
||||
cs==rs && ct==rt && cn==rc && rty==Child
|
||||
lookupFn _ _ = False
|
||||
relToFk (Relation{relFTable=t, relFColumn=c}) = ForeignKey t c
|
||||
|
||||
allprimaryKeys :: H.Tx P.Postgres s [PrimaryKey]
|
||||
allprimaryKeys = do
|
||||
allPrimaryKeys :: H.Tx P.Postgres s [PrimaryKey]
|
||||
allPrimaryKeys = do
|
||||
pks <- H.listEx $ [H.stmt|
|
||||
WITH table_pk AS
|
||||
(
|
||||
SELECT kc.table_schema, kc.table_name, kc.column_name
|
||||
FROM information_schema.table_constraints tc,
|
||||
information_schema.key_column_usage kc
|
||||
WHERE tc.constraint_type = 'PRIMARY KEY'
|
||||
AND kc.table_name = tc.table_name
|
||||
AND kc.table_schema = tc.table_schema
|
||||
AND kc.constraint_name = tc.constraint_name
|
||||
AND kc.table_schema NOT IN ('pg_catalog', 'information_schema')
|
||||
)
|
||||
SELECT table_schema, table_name, column_name
|
||||
FROM table_pk
|
||||
UNION
|
||||
(
|
||||
SELECT vcu.view_schema, vcu.view_name, vcu.column_name
|
||||
FROM information_schema.view_column_usage AS vcu
|
||||
JOIN table_pk ON table_pk.table_schema = vcu.view_schema
|
||||
AND table_pk.table_name = vcu.table_name
|
||||
AND table_pk.column_name = vcu.column_name
|
||||
WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema')
|
||||
)
|
||||
|]
|
||||
WITH table_pk AS (
|
||||
SELECT
|
||||
kc.table_schema,
|
||||
kc.table_name,
|
||||
kc.column_name
|
||||
FROM
|
||||
information_schema.table_constraints tc,
|
||||
information_schema.key_column_usage kc
|
||||
WHERE
|
||||
tc.constraint_type = 'PRIMARY KEY' AND
|
||||
kc.table_name = tc.table_name AND
|
||||
kc.table_schema = tc.table_schema AND
|
||||
kc.constraint_name = tc.constraint_name AND
|
||||
kc.table_schema NOT IN ('pg_catalog', 'information_schema')
|
||||
)
|
||||
SELECT table_schema,
|
||||
table_name,
|
||||
column_name
|
||||
FROM table_pk
|
||||
UNION (
|
||||
SELECT
|
||||
vcu.view_schema,
|
||||
vcu.view_name,
|
||||
vcu.column_name
|
||||
FROM information_schema.view_column_usage AS vcu
|
||||
JOIN
|
||||
table_pk ON table_pk.table_schema = vcu.view_schema AND
|
||||
table_pk.table_name = vcu.table_name AND
|
||||
table_pk.column_name = vcu.column_name
|
||||
WHERE vcu.view_schema NOT IN ('pg_catalog','information_schema')
|
||||
)
|
||||
|]
|
||||
return $ map pkFromRow pks
|
||||
|
||||
@@ -13,25 +13,13 @@ import PostgREST.PgQuery (PStmt, QualifiedIdentifier (..), fromQi,
|
||||
orderT, pgFmtIdent, pgFmtLit, pgFmtOperator,
|
||||
pgFmtValue, whiteList)
|
||||
import PostgREST.Types
|
||||
--import qualified Hasql as H
|
||||
--import qualified Hasql.Postgres as P
|
||||
--import Control.Applicative ((<|>))
|
||||
import qualified Data.Vector as V (empty)
|
||||
import qualified Hasql.Backend as B
|
||||
|
||||
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
|
||||
|
||||
|
||||
addRelations :: Text -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest
|
||||
addRelations schema allRelations parentNode node@(Node query@(Select {mainTable=table}) forest) =
|
||||
case parentNode of
|
||||
@@ -46,14 +34,13 @@ addRelations schema allRelations parentNode node@(Node query@(Select {mainTable=
|
||||
where
|
||||
updatedForest = mapM (addRelations schema allRelations (Just node)) forest
|
||||
|
||||
|
||||
addJoinConditions :: Text -> [Column] -> ApiRequest -> Either Text ApiRequest
|
||||
addJoinConditions schema allColumns (Node query@(Select{relation=r}) forest) =
|
||||
case r of
|
||||
Nothing -> Node updatedQuery <$> updatedForest -- this is the root node
|
||||
Just rel@(Relation{relType="child"}) -> Node (addCond updatedQuery (getJoinConditions rel)) <$> updatedForest
|
||||
Just (Relation{relType="parent"}) -> Node updatedQuery <$> updatedForest
|
||||
Just rel@(Relation{relType="many", relLTable=(Just linkTable)}) ->
|
||||
Just rel@(Relation{relType=Child}) -> Node (addCond updatedQuery (getJoinConditions rel)) <$> updatedForest
|
||||
Just (Relation{relType=Parent}) -> Node updatedQuery <$> updatedForest
|
||||
Just rel@(Relation{relType=Many, relLTable=(Just linkTable)}) ->
|
||||
Node <$> pure qq <*> updatedForest
|
||||
where
|
||||
q = addCond updatedQuery (getJoinConditions rel)
|
||||
@@ -66,21 +53,20 @@ addJoinConditions schema allColumns (Node query@(Select{relation=r}) forest) =
|
||||
parentJoinConditions = map (getJoinConditions.snd) parents
|
||||
parentTables = map fst parents
|
||||
parents = mapMaybe (getParents.rootLabel) forest
|
||||
getParents qq@(Select{relation=(Just rel@(Relation{relType="parent"}))}) = Just (mainTable qq, rel)
|
||||
getParents qq@(Select{relation=(Just rel@(Relation{relType=Parent}))}) = Just (mainTable qq, rel)
|
||||
getParents _ = Nothing
|
||||
updatedForest = mapM (addJoinConditions schema allColumns) forest
|
||||
getJoinConditions :: Relation -> [Filter]
|
||||
getJoinConditions rel@(Relation _ _ c _ _ "child" _ _ _) = [Filter (c, Nothing) "=" (VForeignKey rel)]
|
||||
getJoinConditions rel@(Relation _ _ c _ _ "parent" _ _ _) = [Filter (c, Nothing) "=" (VForeignKey rel)]
|
||||
getJoinConditions (Relation s t c ft fc "many" (Just lt) (Just lc1) (Just lc2)) =
|
||||
getJoinConditions rel@(Relation _ _ c _ _ Child _ _ _) = [Filter (c, Nothing) "=" (VForeignKey rel)]
|
||||
getJoinConditions rel@(Relation _ _ c _ _ Parent _ _ _) = [Filter (c, Nothing) "=" (VForeignKey rel)]
|
||||
getJoinConditions (Relation s t c ft fc Many (Just lt) (Just lc1) (Just lc2)) =
|
||||
[
|
||||
Filter (c, Nothing) "=" (VForeignKey (Relation s t c lt lc1 "child" Nothing Nothing Nothing)),
|
||||
Filter (fc, Nothing) "=" (VForeignKey (Relation s ft fc lt lc2 "child" Nothing Nothing Nothing))
|
||||
Filter (c, Nothing) "=" (VForeignKey (Relation s t c lt lc1 Child Nothing Nothing Nothing)),
|
||||
Filter (fc, Nothing) "=" (VForeignKey (Relation s ft fc lt lc2 Child Nothing Nothing Nothing))
|
||||
]
|
||||
getJoinConditions _ = []
|
||||
addCond q con = q{filters=con ++ filters q}
|
||||
|
||||
|
||||
requestToCountQuery :: Text -> ApiRequest -> PStmt
|
||||
requestToCountQuery schema (Node (Select mainTbl _ _ conditions _ _) _) =
|
||||
B.Stmt query V.empty True
|
||||
@@ -96,8 +82,6 @@ requestToCountQuery schema (Node (Select mainTbl _ _ conditions _ _) _) =
|
||||
fn (Filter{value=VText _}) = True
|
||||
fn (Filter{value=VForeignKey _}) = False
|
||||
|
||||
|
||||
-- main field join filters order rela
|
||||
requestToQuery :: Text -> ApiRequest -> PStmt
|
||||
requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) forest) =
|
||||
orderT (fromMaybe [] ord) query
|
||||
@@ -111,10 +95,8 @@ requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) fo
|
||||
]
|
||||
emptyOnNull val x = if null x then "" else val
|
||||
(withs, selects) = foldr getQueryParts ([],[]) forest
|
||||
--getQueryParts is not total but requestToQuery 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{mainTable=table, relation=(Just (Relation {relType="child"}))}) forst) (w,s) = (w,sel:s)
|
||||
getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Child}))}) forst) (w,s) = (w,sel:s)
|
||||
where
|
||||
sel = "("
|
||||
<> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
|
||||
@@ -122,13 +104,13 @@ requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) fo
|
||||
<> ") AS " <> table
|
||||
where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
|
||||
|
||||
getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation{relType="parent"}))}) forst) (w,s) = (wit:w,sel:s)
|
||||
getQueryParts (Node q@(Select{mainTable=table, relation=(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 q forst)
|
||||
|
||||
getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType="many"}))}) forst) (w,s) = (w,sel:s)
|
||||
getQueryParts (Node q@(Select{mainTable=table, relation=(Just (Relation {relType=Many}))}) forst) (w,s) = (w,sel:s)
|
||||
where
|
||||
sel = "("
|
||||
<> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
|
||||
@@ -136,9 +118,10 @@ requestToQuery schema (Node (Select mainTbl colSelects tbls conditions ord _) fo
|
||||
<> ") AS " <> table
|
||||
where (B.Stmt subquery _ _) = requestToQuery schema (Node q forst)
|
||||
|
||||
-- the following is just to remove the warning, maybe relType should not be String?
|
||||
-- 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 (Select{relation=Nothing}) _) _ = undefined
|
||||
getQueryParts (Node (Select{relation=(Just (Relation {relType=_}))}) _) _ = undefined
|
||||
|
||||
pgFmtCondition :: QualifiedIdentifier -> Filter -> Text
|
||||
pgFmtCondition table (Filter (col,jp) ops val) =
|
||||
@@ -163,7 +146,6 @@ pgFmtCondition table (Filter (col,jp) ops val) =
|
||||
pgFmtColumn :: QualifiedIdentifier -> Text -> Text
|
||||
pgFmtColumn table "*" = fromQi table <> ".*"
|
||||
pgFmtColumn table c = fromQi table <> "." <> pgFmtIdent c
|
||||
--pgFmtColumn Star {colSchema=s, colTable=t} = pgFmtIdent s <> "." <> pgFmtIdent t <> ".*"
|
||||
|
||||
pgFmtJsonPath :: Maybe JsonPath -> Text
|
||||
pgFmtJsonPath (Just [x]) = "->>" <> pgFmtLit x
|
||||
|
||||
@@ -9,7 +9,6 @@ data DbStructure = DbStructure {
|
||||
, columns :: [Column]
|
||||
, relations :: [Relation]
|
||||
, primaryKeys :: [PrimaryKey]
|
||||
--, tablesAcl :: [(Text, Text, Text)]
|
||||
}
|
||||
|
||||
|
||||
@@ -50,22 +49,20 @@ data OrderTerm = OrderTerm {
|
||||
, otNullOrder :: Maybe BS.ByteString
|
||||
} deriving (Show, Eq)
|
||||
|
||||
|
||||
data RelationType = Child | Parent | Many deriving (Show, Eq)
|
||||
data Relation = Relation {
|
||||
relSchema :: Text
|
||||
, relTable :: Text
|
||||
, relColumn :: Text
|
||||
, relFTable :: Text
|
||||
, relFColumn :: Text
|
||||
, relType :: Text
|
||||
, relType :: RelationType
|
||||
, relLTable :: Maybe Text
|
||||
, relLCol1 :: Maybe Text
|
||||
, relLCol2 :: Maybe Text
|
||||
} deriving (Show, Eq)
|
||||
|
||||
|
||||
--------
|
||||
-- Request Types
|
||||
type Operator = Text
|
||||
data FValue = VText Text | VForeignKey Relation deriving (Show, Eq)
|
||||
type FieldName = Text
|
||||
|
||||
+17
-26
@@ -55,36 +55,27 @@ withApp perform = do
|
||||
pool :: H.Pool P.Postgres
|
||||
<- H.acquirePool pgSettings testPoolOpts
|
||||
|
||||
let txParam = (Just (H.ReadCommitted, Just True))
|
||||
|
||||
tblsRes <- H.session pool $ H.tx txParam alltables
|
||||
let allTables = either (fail . show) id tblsRes
|
||||
|
||||
relsRes <- H.session pool $ H.tx txParam allrelations
|
||||
let allRelations = either (fail . show) id relsRes
|
||||
|
||||
colsRes <- H.session pool $ H.tx txParam $ allcolumns allRelations
|
||||
let allColumns = either (fail . show) id colsRes
|
||||
|
||||
pkRes <- H.session pool $ H.tx txParam $ allprimaryKeys
|
||||
let allPrimaryKeys = either (fail . show) id pkRes
|
||||
|
||||
-- tableAclRes <- H.session pool $ H.tx txParam $ alltablesAcl
|
||||
-- let allTablesAcl = either (fail . show) id tableAclRes
|
||||
|
||||
|
||||
let dbstructure = DbStructure {
|
||||
tables=allTables
|
||||
, columns=allColumns
|
||||
, relations=allRelations
|
||||
, primaryKeys=allPrimaryKeys
|
||||
--, tablesAcl=allTablesAcl
|
||||
}
|
||||
let txSettings = Just (H.ReadCommitted, Just True)
|
||||
metadata <- H.session pool $ H.tx txSettings $ do
|
||||
tabs <- allTables
|
||||
rels <- allRelations
|
||||
cols <- allColumns rels
|
||||
keys <- allPrimaryKeys
|
||||
return (tabs, rels, cols, keys)
|
||||
|
||||
dbstructure <- case metadata of
|
||||
Left e -> fail $ show e
|
||||
Right (tabs, rels, cols, keys) ->
|
||||
return $ DbStructure {
|
||||
tables=tabs
|
||||
, columns=cols
|
||||
, relations=rels
|
||||
, primaryKeys=keys
|
||||
}
|
||||
|
||||
perform $ middle $ \req resp -> do
|
||||
body <- strictRequestBody req
|
||||
result <- liftIO $ H.session pool $ H.tx (Just (H.ReadCommitted, Just True))
|
||||
result <- liftIO $ H.session pool $ H.tx txSettings
|
||||
$ authenticated cfg (app dbstructure cfg body) req
|
||||
either (resp . errResponse) resp result
|
||||
|
||||
|
||||
Reference in New Issue
Block a user