Rename functions
This commit is contained in:
@@ -55,7 +55,7 @@ import PostgREST.Auth (tokenJWT)
|
|||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
app :: DbStructure -> AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response
|
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
|
case (path, verb) of
|
||||||
|
|
||||||
([table], "GET") ->
|
([table], "GET") ->
|
||||||
@@ -71,7 +71,7 @@ app db conf reqBody req =
|
|||||||
to = frm+queryTotal-1
|
to = frm+queryTotal-1
|
||||||
contentRange = contentRangeH frm to tableTotal
|
contentRange = contentRangeH frm to tableTotal
|
||||||
status = rangeStatus 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)
|
. sortBy (comparing fst)
|
||||||
. map (join (***) cs)
|
. map (join (***) cs)
|
||||||
. parseSimpleQuery
|
. parseSimpleQuery
|
||||||
@@ -160,10 +160,10 @@ app db conf reqBody req =
|
|||||||
return $ responseLBS status404 [] ""
|
return $ responseLBS status404 [] ""
|
||||||
|
|
||||||
where
|
where
|
||||||
allTabs = tables db
|
allTabs = tables dbStructure
|
||||||
allRels = relations db
|
allRels = relations dbStructure
|
||||||
allCols = columns db
|
allCols = columns dbStructure
|
||||||
allPrKeys = primaryKeys db
|
allPrKeys = primaryKeys dbStructure
|
||||||
filterCol sc table (Column{colTable=Table{tableSchema=s, tableName=t}}) = s==sc && table==t
|
filterCol sc table (Column{colTable=Table{tableSchema=s, tableName=t}}) = s==sc && table==t
|
||||||
filterCol _ _ _ = False
|
filterCol _ _ _ = False
|
||||||
filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
|
filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
|
||||||
|
|||||||
@@ -4,7 +4,7 @@
|
|||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TypeSynonymInstances #-}
|
{-# LANGUAGE TypeSynonymInstances #-}
|
||||||
module PostgREST.DbStructure (
|
module PostgREST.DbStructure (
|
||||||
createDbStructure
|
getDbStructure
|
||||||
, accessibleTables
|
, accessibleTables
|
||||||
, doesProcExist
|
, doesProcExist
|
||||||
, doesProcReturnJWT
|
, doesProcReturnJWT
|
||||||
@@ -26,15 +26,15 @@ import PostgREST.Types
|
|||||||
import GHC.Exts (groupWith)
|
import GHC.Exts (groupWith)
|
||||||
import Prelude
|
import Prelude
|
||||||
|
|
||||||
createDbStructure :: Schema -> H.Tx P.Postgres s DbStructure
|
getDbStructure :: Schema -> H.Tx P.Postgres s DbStructure
|
||||||
createDbStructure schema = do
|
getDbStructure schema = do
|
||||||
tabs <- allTables
|
tabs <- allTables
|
||||||
cols <- allColumns tabs
|
cols <- allColumns tabs
|
||||||
syns <- allSynonyms cols
|
syns <- allSynonyms cols
|
||||||
rels <- allRelations tabs cols
|
rels <- allRelations tabs cols
|
||||||
keys <- allPrimaryKeys tabs
|
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
|
cols' = addForeignKeys rels' cols
|
||||||
keys' = synonymousPrimaryKeys syns keys
|
keys' = synonymousPrimaryKeys syns keys
|
||||||
|
|
||||||
@@ -115,20 +115,20 @@ addForeignKeys rels = map addFk
|
|||||||
pos = elemIndex col cols
|
pos = elemIndex col cols
|
||||||
colF = (colsF !!) <$> pos
|
colF = (colsF !!) <$> pos
|
||||||
|
|
||||||
synonymousRelations :: [(Column,Column)] -> [Relation] -> [Relation]
|
addSynonymousRelations :: [(Column,Column)] -> [Relation] -> [Relation]
|
||||||
synonymousRelations _ [] = []
|
addSynonymousRelations _ [] = []
|
||||||
synonymousRelations syns (rel:rels) = rel : synRelsP ++ synRelsF ++ synonymousRelations syns rels
|
addSynonymousRelations syns (rel:rels) = rel : synRelsP ++ synRelsF ++ addSynonymousRelations syns rels
|
||||||
where
|
where
|
||||||
synRelsP = synRels (relColumns rel) (\t cs -> rel{relTable=t,relColumns=cs})
|
synRelsP = synRels (relColumns rel) (\t cs -> rel{relTable=t,relColumns=cs})
|
||||||
synRelsF = synRels (relFColumns rel) (\t cs -> rel{relFTable=t,relFColumns=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
|
synRels cols mapFn = map (\cs -> mapFn (colTable $ head cs) cs) $ synonymousColumns syns cols
|
||||||
|
|
||||||
parentRelations :: [Relation] -> [Relation]
|
addParentRelations :: [Relation] -> [Relation]
|
||||||
parentRelations [] = []
|
addParentRelations [] = []
|
||||||
parentRelations (rel@(Relation t c ft fc _ _ _ _):rels) = Relation ft fc t c Parent Nothing Nothing Nothing : rel : parentRelations rels
|
addParentRelations (rel@(Relation t c ft fc _ _ _ _):rels) = Relation ft fc t c Parent Nothing Nothing Nothing : rel : addParentRelations rels
|
||||||
|
|
||||||
manyToManyRelations :: [Relation] -> [Relation]
|
addManyToManyRelations :: [Relation] -> [Relation]
|
||||||
manyToManyRelations rels = rels ++ mapMaybe link2Relation links
|
addManyToManyRelations rels = rels ++ mapMaybe link2Relation links
|
||||||
where
|
where
|
||||||
links = join $ map (combinations 2) $ filter (not . null) $ groupWith groupFn $ filter ( (==Child). relType) rels
|
links = join $ map (combinations 2) $ filter (not . null) $ groupWith groupFn $ filter ( (==Child). relType) rels
|
||||||
groupFn :: Relation -> Text
|
groupFn :: Relation -> Text
|
||||||
|
|||||||
@@ -68,11 +68,11 @@ main = do
|
|||||||
) supportedOrError
|
) supportedOrError
|
||||||
|
|
||||||
let txSettings = Just (H.ReadCommitted, Just True)
|
let txSettings = Just (H.ReadCommitted, Just True)
|
||||||
dbOrError <- H.session pool $ H.tx txSettings $ createDbStructure (cs $ configSchema conf)
|
dbOrError <- H.session pool $ H.tx txSettings $ getDbStructure (cs $ configSchema conf)
|
||||||
db <- either hasqlError return dbOrError
|
dbStructure <- either hasqlError return dbOrError
|
||||||
|
|
||||||
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 txSettings $
|
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
|
either (respond . errResponse) respond resOrError
|
||||||
|
|||||||
+2
-2
@@ -54,7 +54,7 @@ withApp perform = do
|
|||||||
<- H.acquirePool pgSettings testPoolOpts
|
<- H.acquirePool pgSettings testPoolOpts
|
||||||
|
|
||||||
let txSettings = Just (H.ReadCommitted, Just True)
|
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
|
db <- either (fail . show) return dbOrError
|
||||||
|
|
||||||
perform $ middle $ \req resp -> do
|
perform $ middle $ \req resp -> do
|
||||||
@@ -119,7 +119,7 @@ clearProjectsTable :: IO ()
|
|||||||
clearProjectsTable = do
|
clearProjectsTable = do
|
||||||
pool <- testPool
|
pool <- testPool
|
||||||
void . liftIO $ H.session pool $ H.tx Nothing $
|
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 ()
|
createItems :: Int -> IO ()
|
||||||
|
|||||||
Reference in New Issue
Block a user