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

cleanup suggested by @begriffs

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