From 812135d1e5c9f1b1037e283f90e2c58b3a2d7cfa Mon Sep 17 00:00:00 2001 From: Ruslan Talpa Date: Thu, 1 Oct 2015 10:30:41 +0300 Subject: [PATCH] cleanup suggested by @begriffs --- src/PostgREST/App.hs | 48 +++++++--------- src/PostgREST/Config.hs | 6 +- src/PostgREST/Main.hs | 50 ++++++----------- src/PostgREST/Middleware.hs | 2 - src/PostgREST/Parsers.hs | 18 +----- src/PostgREST/PgStructure.hs | 102 ++++++++++++++++++---------------- src/PostgREST/QueryBuilder.hs | 48 +++++----------- src/PostgREST/Types.hs | 7 +-- test/SpecHelper.hs | 43 ++++++-------- 9 files changed, 127 insertions(+), 197 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index b93e4bc7b..b1f6b3f25 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -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 diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index 30d6d2a5d..4e2448149 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -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) diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index b4ba1bc1b..07460423b 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -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 diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 47ae96389..b2dfee16a 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -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 diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 1e74cdd46..4cebf0d8f 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -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) diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs index cbe784472..3d4f7f0c1 100644 --- a/src/PostgREST/PgStructure.hs +++ b/src/PostgREST/PgStructure.hs @@ -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 diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 0f7d5fd50..95243800a 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -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 diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 8c333d7b2..164f2d7a4 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -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 diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index cd17e41e6..f47f23b6d 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -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