diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index a51004cf9..1741b2f6d 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -55,7 +55,7 @@ import PostgREST.Auth (tokenJWT) import Prelude app :: DbStructure -> AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response -app db conf reqBody req = +app dbStructure conf reqBody req = case (path, verb) of ([table], "GET") -> @@ -71,7 +71,7 @@ app db conf reqBody req = to = frm+queryTotal-1 contentRange = contentRangeH frm to tableTotal status = rangeStatus frm to tableTotal - canonical = urlEncodeVars -- should this be moved to the db (location)? + canonical = urlEncodeVars -- should this be moved to the dbStructure (location)? . sortBy (comparing fst) . map (join (***) cs) . parseSimpleQuery @@ -160,10 +160,10 @@ app db conf reqBody req = return $ responseLBS status404 [] "" where - allTabs = tables db - allRels = relations db - allCols = columns db - allPrKeys = primaryKeys db + allTabs = tables dbStructure + allRels = relations dbStructure + allCols = columns dbStructure + allPrKeys = primaryKeys dbStructure filterCol sc table (Column{colTable=Table{tableSchema=s, tableName=t}}) = s==sc && table==t filterCol _ _ _ = False filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk diff --git a/src/PostgREST/DbStructure.hs b/src/PostgREST/DbStructure.hs index 0798b1120..04aca3d97 100644 --- a/src/PostgREST/DbStructure.hs +++ b/src/PostgREST/DbStructure.hs @@ -4,7 +4,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} module PostgREST.DbStructure ( - createDbStructure + getDbStructure , accessibleTables , doesProcExist , doesProcReturnJWT @@ -26,15 +26,15 @@ import PostgREST.Types import GHC.Exts (groupWith) import Prelude -createDbStructure :: Schema -> H.Tx P.Postgres s DbStructure -createDbStructure schema = do +getDbStructure :: Schema -> H.Tx P.Postgres s DbStructure +getDbStructure schema = do tabs <- allTables cols <- allColumns tabs syns <- allSynonyms cols rels <- allRelations tabs cols keys <- allPrimaryKeys tabs - let rels' = (manyToManyRelations . raiseRelations schema syns . parentRelations . synonymousRelations syns) rels + let rels' = (addManyToManyRelations . raiseRelations schema syns . addParentRelations . addSynonymousRelations syns) rels cols' = addForeignKeys rels' cols keys' = synonymousPrimaryKeys syns keys @@ -115,20 +115,20 @@ addForeignKeys rels = map addFk pos = elemIndex col cols colF = (colsF !!) <$> pos -synonymousRelations :: [(Column,Column)] -> [Relation] -> [Relation] -synonymousRelations _ [] = [] -synonymousRelations syns (rel:rels) = rel : synRelsP ++ synRelsF ++ synonymousRelations syns rels +addSynonymousRelations :: [(Column,Column)] -> [Relation] -> [Relation] +addSynonymousRelations _ [] = [] +addSynonymousRelations syns (rel:rels) = rel : synRelsP ++ synRelsF ++ addSynonymousRelations syns rels where synRelsP = synRels (relColumns rel) (\t cs -> rel{relTable=t,relColumns=cs}) synRelsF = synRels (relFColumns rel) (\t cs -> rel{relFTable=t,relFColumns=cs}) synRels cols mapFn = map (\cs -> mapFn (colTable $ head cs) cs) $ synonymousColumns syns cols -parentRelations :: [Relation] -> [Relation] -parentRelations [] = [] -parentRelations (rel@(Relation t c ft fc _ _ _ _):rels) = Relation ft fc t c Parent Nothing Nothing Nothing : rel : parentRelations rels +addParentRelations :: [Relation] -> [Relation] +addParentRelations [] = [] +addParentRelations (rel@(Relation t c ft fc _ _ _ _):rels) = Relation ft fc t c Parent Nothing Nothing Nothing : rel : addParentRelations rels -manyToManyRelations :: [Relation] -> [Relation] -manyToManyRelations rels = rels ++ mapMaybe link2Relation links +addManyToManyRelations :: [Relation] -> [Relation] +addManyToManyRelations rels = rels ++ mapMaybe link2Relation links where links = join $ map (combinations 2) $ filter (not . null) $ groupWith groupFn $ filter ( (==Child). relType) rels groupFn :: Relation -> Text diff --git a/src/PostgREST/Main.hs b/src/PostgREST/Main.hs index 948cb875f..4b12d07b8 100644 --- a/src/PostgREST/Main.hs +++ b/src/PostgREST/Main.hs @@ -68,11 +68,11 @@ main = do ) supportedOrError let txSettings = Just (H.ReadCommitted, Just True) - dbOrError <- H.session pool $ H.tx txSettings $ createDbStructure (cs $ configSchema conf) - db <- either hasqlError return dbOrError + dbOrError <- H.session pool $ H.tx txSettings $ getDbStructure (cs $ configSchema conf) + dbStructure <- either hasqlError return dbOrError runSettings appSettings $ middle $ \ req respond -> do body <- strictRequestBody req resOrError <- liftIO $ H.session pool $ H.tx txSettings $ - runWithClaims conf (app db conf body) req + runWithClaims conf (app dbStructure conf body) req either (respond . errResponse) respond resOrError diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs index 8a6f9dfe6..8971b606f 100644 --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -54,7 +54,7 @@ withApp perform = do <- H.acquirePool pgSettings testPoolOpts let txSettings = Just (H.ReadCommitted, Just True) - dbOrError <- H.session pool $ H.tx txSettings $ createDbStructure (cs $ configSchema cfg) + dbOrError <- H.session pool $ H.tx txSettings $ getDbStructure (cs $ configSchema cfg) db <- either (fail . show) return dbOrError perform $ middle $ \req resp -> do @@ -119,7 +119,7 @@ clearProjectsTable :: IO () clearProjectsTable = do pool <- testPool void . liftIO $ H.session pool $ H.tx Nothing $ - H.unitEx $ B.Stmt ("delete from test.projects where id > 4") V.empty True + H.unitEx $ B.Stmt "delete from test.projects where id > 4" V.empty True createItems :: Int -> IO ()