Refactor DbStructure

- Rename `dbstructure` to `db` in App.hs - Rename PgStructure* to DbStructure* - Move `DbStructure` creation to DbStructure.hs
2015-11-11 09:03:06 -05:00
parent 3f1d2d8ed9
commit 7560fafbab
11 changed files with 81 additions and 99 deletions
@@ -70,7 +70,7 @@ executable postgrest
                     , PostgREST.Middleware
                     , PostgREST.Parsers
                     , PostgREST.PgQuery
-                     , PostgREST.PgStructure
+                     , PostgREST.DbStructure
                     , PostgREST.QueryBuilder
                     , PostgREST.RangeQuery
                     , PostgREST.Types
@@ -134,7 +134,7 @@ library
                     , PostgREST.Middleware
                     , PostgREST.Parsers
                     , PostgREST.PgQuery
-                     , PostgREST.PgStructure
+                     , PostgREST.DbStructure
                     , PostgREST.QueryBuilder
                     , PostgREST.RangeQuery
                     , PostgREST.Types
@@ -165,7 +165,7 @@ Test-Suite spec
                     , PostgREST.Middleware
                     , PostgREST.Parsers
                     , PostgREST.PgQuery
-                     , PostgREST.PgStructure
+                     , PostgREST.DbStructure
                     , PostgREST.QueryBuilder
                     , PostgREST.RangeQuery
                     , PostgREST.Types
@@ -46,7 +46,7 @@ import qualified Hasql.Postgres            as P
 import           PostgREST.Config          (AppConfig (..))
 import           PostgREST.Parsers
 import           PostgREST.PgQuery
-import           PostgREST.PgStructure
+import           PostgREST.DbStructure
 import           PostgREST.QueryBuilder
 import           PostgREST.RangeQuery
 import           PostgREST.Types
@@ -55,7 +55,7 @@ import           PostgREST.Auth (tokenJWT)
 import           Prelude

 app :: DbStructure -> AppConfig -> BL.ByteString -> Request -> H.Tx P.Postgres s Response
-app dbstructure conf reqBody req =
+app db conf reqBody req =
  case (path, verb) of

    ([table], "GET") ->
@@ -160,9 +160,9 @@ app dbstructure conf reqBody req =
      return $ responseLBS status404 [] ""

  where
-    allRels = relations dbstructure
-    allCols = columns dbstructure
-    allPrKeys = primaryKeys dbstructure
+    allRels = relations db
+    allCols = columns db
+    allPrKeys = primaryKeys db
    filterCol sc table (Column{colSchema=s, colTable=t}) =  s==sc && table==t
    filterCol _ _ _ =  False
    filterPk sc table pk = sc == pkSchema pk && table == pkTable pk
@@ -332,7 +332,7 @@ addFilter (path, flt) (Node rn forest) =
      where maybeNode = find ((name==).fst.snd.rootLabel) forst

 toSourceRelation :: Text -> Relation -> Maybe Relation
-toSourceRelation mt r@(Relation _ t _ ft _ _ rt _ _)
+toSourceRelation mt r@(Relation _ t _ _ ft _ _ _ rt _ _)
  | mt == t = Just $ r {relTable=sourceSubqueryName}
  | mt == ft = Just $ r {relFTable=sourceSubqueryName}
  | Just mt == rt = Just $ r {relLTable=Just sourceSubqueryName}
@@ -3,7 +3,7 @@
 {-# LANGUAGE QuasiQuotes           #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TypeSynonymInstances  #-}
-module PostgREST.PgStructure where
+module PostgREST.DbStructure where

 import           Control.Applicative
 import           Control.Monad         (join)
@@ -21,6 +21,20 @@ import           PostgREST.Types
 import           GHC.Exts              (groupWith)
 import           Prelude

+createDbStructure :: H.Tx P.Postgres s DbStructure
+createDbStructure = do
+  tabs <- allTables
+  rels <- allRelations
+  cols <- allColumns rels
+  keys <- allPrimaryKeys
+
+  return DbStructure {
+      tables = tabs
+    , columns = cols
+    , relations = rels
+    , primaryKeys = keys
+    }
+
 doesProc :: forall c s. B.CxValue c Int =>
            (Text -> Text -> B.Stmt c) -> Text -> Text -> H.Tx c s Bool
 doesProc stmt schema proc = do
@@ -64,15 +78,15 @@ 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, cs, ft, fcs) = Relation s t cs ft fcs Child Nothing Nothing Nothing
+relationFromRow :: (Text, Text, [Text], Text, Text, [Text]) -> Relation
+relationFromRow (s, t, cs, fs, ft, fcs) = Relation s t cs fs ft fcs Child Nothing 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 fs ft fc _ _ _ _ _) rels = Relation fs ft fc s t c Parent Nothing Nothing Nothing Nothing:rel:rels

 -- allTables :: H.Tx P.Postgres s [Table]
 -- allTables = do
@@ -135,9 +149,10 @@ allRelations :: H.Tx P.Postgres s [Relation]
 allRelations = do
  rels <- H.listEx $ [H.stmt|
    WITH table_fk AS (
-        SELECT ns.nspname AS table_schema,
+        SELECT ns1.nspname AS table_schema,
               tab.relname AS table_name,
               column_info.cols AS columns,
+               ns2.nspname AS foreign_table_schema,
               other.relname AS foreign_table_name,
               column_info.refs AS foreign_columns
        FROM pg_constraint,
@@ -152,10 +167,10 @@ allRelations = do
                                     WHERE attrelid = confrelid AND attnum = ref)
                                AS refs)
                AS column_info,
-           LATERAL (SELECT * FROM pg_namespace
-                            WHERE pg_namespace.oid = connamespace) AS ns,
+           LATERAL (SELECT * FROM pg_namespace WHERE pg_namespace.oid = connamespace) AS ns1,
           LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = conrelid) AS tab,
-           LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = confrelid) AS other
+           LATERAL (SELECT * FROM pg_class WHERE pg_class.oid = confrelid) AS other,
+           LATERAL (SELECT * FROM pg_namespace WHERE pg_namespace.oid = other.relnamespace) AS ns2
        WHERE confrelid != 0
        ORDER BY (conrelid, column_info.nums)
    )
@@ -167,33 +182,35 @@ allRelations = do
            vcu.table_schema,
            vcu.view_name AS table_name,
            array_agg(vcu.column_name::text) AS columns,
+            table_fk.foreign_table_schema,
            table_fk.foreign_table_name,
            table_fk.foreign_columns
-        FROM information_schema.view_column_usage as vcu
+        FROM information_schema.view_column_usage AS vcu
        JOIN table_fk ON
            table_fk.table_schema = vcu.view_schema AND
            table_fk.table_name = vcu.table_name AND
            vcu.column_name = ANY (table_fk.columns)
        WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema')
        AND columns = table_fk.columns
-        GROUP BY vcu.table_schema, vcu.view_name, table_fk.foreign_table_name, table_fk.foreign_columns
+        GROUP BY vcu.table_schema, vcu.view_name, table_fk.foreign_table_schema, table_fk.foreign_table_name, table_fk.foreign_columns
    )
    UNION
    (
        SELECT
-            vcu.view_schema as table_schema,
+            table_fk.table_schema,
            table_fk.table_name,
            table_fk.columns,
-            vcu.view_name as foreign_table_name,
-            array_agg(vcu.column_name::text) as foreign_columns
-        FROM information_schema.view_column_usage as vcu
+            vcu.view_schema AS foreign_table_schema,
+            vcu.view_name AS foreign_table_name,
+            array_agg(vcu.column_name::text) AS foreign_columns
+        FROM information_schema.view_column_usage AS vcu
        JOIN table_fk ON
            table_fk.table_schema = vcu.view_schema AND
            table_fk.foreign_table_name = vcu.table_name AND
            vcu.column_name = ANY (table_fk.foreign_columns)
        WHERE vcu.view_schema NOT IN ('pg_catalog', 'information_schema')
            AND foreign_columns = table_fk.foreign_columns
-        GROUP BY vcu.view_schema, table_fk.table_name, vcu.view_name, table_fk.columns
+        GROUP BY table_fk.table_schema, table_fk.table_name, vcu.view_schema, vcu.view_name, table_fk.columns
    )
  |]
  let simpleRelations = foldr (addParentRelation.relationFromRow) [] rels
@@ -204,10 +221,10 @@ allRelations = do
    groupFn (Relation{relSchema=s, relTable=t}) = s<>"_"<>t
    combinations k ns = filter ((k==).length) (subsequences ns)
    link2Relation [
-      Relation{relSchema=sc, relTable=lt, relColumns=lc1, relFTable=t, relFColumns=c},
-      Relation{                           relColumns=lc2, relFTable=ft, relFColumns=fc}
+      Relation{relSchema=ls, relTable=lt, relColumns=lc1, relFSchema=s,  relFTable=t,  relFColumns=c},
+      Relation{                           relColumns=lc2, relFSchema=fs, relFTable=ft, relFColumns=fc}
      ]
-      | lc1 /= lc2 && length lc1 == 1 && length lc2 == 1 = Just $ Relation sc t c ft fc Many (Just lt) (Just lc1) (Just lc2)
+      | lc1 /= lc2 && length lc1 == 1 && length lc2 == 1 = Just $ Relation s t c fs ft fc Many (Just ls) (Just lt) (Just lc1) (Just lc2)
      | otherwise = Nothing
    link2Relation _ = Nothing

@@ -264,7 +281,7 @@ allColumns rels = do
    lookupFn (Column{colSchema=cs, colTable=ct, colName=cn})  (Relation{relSchema=rs, relTable=rt, relColumns=rc, relType=rty}) =
      cs==rs && ct==rt && cn `elem` rc && rty==Child
    lookupFn _ _ = False
-    relToFk cName (Relation{relFTable=t, relColumns=cs, relFColumns=fcs}) = ForeignKey t <$> c
+    relToFk cName (Relation{relSchema=s, relFTable=t, relColumns=cs, relFColumns=fcs}) = ForeignKey s t <$> c
      where
        pos = elemIndex cName cs
        c = (fcs !!) <$> pos
@@ -2,14 +2,13 @@ module Main where


 import           PostgREST.App
-- import PostgREST.QueryBuilder
 import           PostgREST.Config                     (AppConfig (..),
                                                       minimumPgVersion,
                                                       prettyVersion,
                                                       readOptions)
 import           PostgREST.Error                      (errResponse, PgError)
 import           PostgREST.Middleware
-import           PostgREST.PgStructure
+import           PostgREST.DbStructure
 import           PostgREST.Types

 import           Control.Monad                        (unless)
@@ -27,7 +26,6 @@ import           Network.Wai.Middleware.RequestLogger (logStdout)
 import           System.IO                            (BufferMode (..),
                                                       hSetBuffering, stderr,
                                                       stdin, stdout)
-- import Data.Maybe (mapMaybe)

 isServerVersionSupported :: H.Session P.Postgres IO Bool
 isServerVersionSupported = do
@@ -70,38 +68,12 @@ main = do
          <> show minimumPgVersion)
    ) supportedOrError

-  -- what was this code for?
-  -- roleOrError <- H.session pool $ do
-  --   Identity (role :: Text) <- H.tx Nothing $ H.singleEx
-  --     [H.stmt|SELECT SESSION_USER|]
-  --   return role
-  -- authenticator <- either hasqlError return roleOrError
-
  let txSettings = Just (H.ReadCommitted, Just True)
-  metadata <- H.session pool $ H.tx txSettings $ do
-    rels <- allRelations
-    cols <- allColumns rels
-    keys <- allPrimaryKeys
-    return (rels, cols, keys)
-
-
-  dbstructure <- either hasqlError
-    (\(rels, cols, keys) ->
-
-      return DbStructure {
-          columns=cols
-        , relations=rels
-        , primaryKeys=keys
-        }
-    ) metadata
-
-  -- let allRels = relations dbstructure
-  --     fakeRels = mapMaybe (toSourceRelation "projects") allRels
-  --
-  -- print $ findRelation (fakeRels ++ allRels) "test" "pg_source" "clients"
+  dbOrError <- H.session pool $ H.tx txSettings createDbStructure
+  db <- either hasqlError return dbOrError

  runSettings appSettings $ middle $ \ req respond -> do
    body <- strictRequestBody req
    resOrError <- liftIO $ H.session pool $ H.tx txSettings $
-      runWithClaims conf (app dbstructure conf body) req
+      runWithClaims conf (app db conf body) req
    either (respond . errResponse) respond resOrError
@@ -8,7 +8,7 @@ import           PostgREST.Config                     (AppConfig (..),
                                                       readOptions)
 import           PostgREST.Error                      (errResponse, PgError)
 import           PostgREST.Middleware
-import           PostgREST.PgStructure
+import           PostgREST.DbStructure
 import           PostgREST.Types

 import           Control.Monad                        (unless)
@@ -94,7 +94,7 @@ main = do
    return (tabs, rels, cols, keys)


-  dbstructure <- either hasqlError
+  db <- either hasqlError
    (\(tabs, rels, cols, keys) ->

      return DbStructure {
@@ -107,10 +107,10 @@ main = do
  runSettings appSettings $ middle $ \ req respond -> do
    body <- strictRequestBody req
    resOrError <- liftIO $ H.session pool $ H.tx txSettings $
-      runWithClaims conf (app dbstructure conf body) req
+      runWithClaims conf (app db conf body) req
    either (respond . errResponse) respond resOrError

-  --let allRels = relations dbstructure
+  --let allRels = relations db
      -- links = join $ map (combinations 2) $ filter ((>=1).length) $ groupWith groupFn $ filter ( (==Child). relType) allRels
      -- combinations k ns = filter ((k==).length) (subsequences ns)

@@ -281,7 +281,7 @@ pgFmtCondition table (Filter (col,jp) ops val) =
      _      -> ""
    valToStr v = case v of
      VText s -> pgFmtValue opCode s
-      VForeignKey (QualifiedIdentifier s _) (ForeignKey ft fc) -> pgFmtColumn qi fc
+      VForeignKey (QualifiedIdentifier s _) (ForeignKey _ ft fc) -> pgFmtColumn qi fc
        where qi = QualifiedIdentifier (if ft == sourceSubqueryName then "" else s) ft

 pgFmtColumn :: QualifiedIdentifier -> T.Text -> T.Text
@@ -35,14 +35,14 @@ addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) for
    updatedForest = mapM (addRelations schema allRelations (Just node)) forest

 getJoinConditions :: Relation -> [Filter]
-getJoinConditions (Relation s t cs ft fcs typ lt lc1 lc2) =
+getJoinConditions (Relation s t cs fs ft fcs typ ls lt lc1 lc2) =
  case typ of
-    Child  -> zipWith (toFilter t ft) cs fcs
-    Parent -> zipWith (toFilter t ft) cs fcs
-    Many   -> zipWith (toFilter t (fromMaybe "" lt)) cs (fromMaybe [] lc1) ++ zipWith (toFilter ft (fromMaybe "" lt)) fcs (fromMaybe [] lc2)
+    Child  -> zipWith (toFilter t fs ft) cs fcs
+    Parent -> zipWith (toFilter t fs ft) cs fcs
+    Many   -> zipWith (toFilter t (fromMaybe "" ls) (fromMaybe "" lt)) cs (fromMaybe [] lc1) ++ zipWith (toFilter ft (fromMaybe "" ls) (fromMaybe "" lt)) fcs (fromMaybe [] lc2)
  where
-    toFilter :: Text -> Text -> FieldName -> FieldName -> Filter
-    toFilter tb ftb c fc = Filter (c, Nothing) "=" (VForeignKey (QualifiedIdentifier s tb) (ForeignKey ftb fc))
+    toFilter :: Text -> Text -> Text -> FieldName -> FieldName -> Filter
+    toFilter tb fsc ftb c fc = Filter (c, Nothing) "=" (VForeignKey (QualifiedIdentifier s tb) (ForeignKey fsc ftb fc))

 addJoinConditions :: Text -> ApiRequest -> Either Text ApiRequest
 addJoinConditions schema (Node (query, (t, r)) forest) =
@@ -55,7 +55,7 @@ addJoinConditions schema (Node (query, (t, r)) forest) =
      where
         q = addCond updatedQuery (getJoinConditions rel)
         qq = q{from=linkTable:from q}
-    _ -> Left "unknow relation"
+    _ -> Left "unknown relation"
  where
    -- add parentTable and parentJoinConditions to the query
    updatedQuery = foldr (flip addCond) (query{from = parentTables ++ from query}) parentJoinConditions
@@ -19,7 +19,9 @@ data Table = Table {
 } deriving (Show)

 data ForeignKey = ForeignKey {
-  fkTable::Text, fkCol::Text
+  fkSchema :: Text,
+  fkTable :: Text,
+  fkCol :: Text
 } deriving (Show, Eq)


@@ -36,7 +38,7 @@ data Column = Column {
 , colDefault :: Maybe Text
 , colEnum :: [Text]
 , colFK :: Maybe ForeignKey
-} | Star {colSchema :: Text, colTable :: Text } deriving (Show)
+} | Star { colSchema :: Text, colTable :: Text } deriving (Show)

 data PrimaryKey = PrimaryKey {
  pkSchema::Text, pkTable::Text, pkName::Text
@@ -56,13 +58,15 @@ data QualifiedIdentifier = QualifiedIdentifier {

 data RelationType = Child | Parent | Many deriving (Show, Eq)
 data Relation = Relation {
-  relSchema  :: Text
-, relTable   :: Text
+  relSchema   :: Text
+, relTable    :: Text
 , relColumns  :: [Text]
-, relFTable  :: Text
+, relFSchema  :: Text
+, relFTable   :: Text
 , relFColumns :: [Text]
-, relType    :: RelationType
-, relLTable  :: Maybe Text
+, relType     :: RelationType
+, relLSchema  :: Maybe Text
+, relLTable   :: Maybe Text
 , relLCols1   :: Maybe [Text]
 , relLCols2   :: Maybe [Text]
 } deriving (Show, Eq)
@@ -101,7 +105,7 @@ instance ToJSON Column where
    , "enum"      .= colEnum c ]

 instance ToJSON ForeignKey where
-  toJSON fk = object ["table".=fkTable fk, "column".=fkCol fk]
+  toJSON fk = object ["schema".=fkSchema fk, "table".=fkTable fk, "column".=fkCol fk]

 instance ToJSON Table where
  toJSON v = object [
@@ -175,6 +175,7 @@ spec = around withApp $ do
            },
            {
               "references":{
+                  "schema":"test",
                  "column":"id",
                  "table":"auto_incrementing_pk"
               },
@@ -191,6 +192,7 @@ spec = around withApp $ do
            },
            {
               "references":{
+                  "schema":"test",
                  "column":"k",
                  "table":"simple_pk"
               },
@@ -30,8 +30,7 @@ import PostgREST.App (app)
 import PostgREST.Config (AppConfig(..))
 import PostgREST.Middleware
 import PostgREST.Error(errResponse)
-import PostgREST.PgStructure
-import PostgREST.Types
+import PostgREST.DbStructure

 dbString :: String
 dbString = "postgres://postgrest_test@localhost:5432/postgrest_test"
@@ -55,25 +54,13 @@ withApp perform = do
    <- H.acquirePool pgSettings testPoolOpts

  let txSettings = Just (H.ReadCommitted, Just True)
-  metadata <- H.session pool $ H.tx txSettings $ do
-    rels <- allRelations
-    cols <- allColumns rels
-    keys <- allPrimaryKeys
-    return (rels, cols, keys)
-
-  dbstructure <- case metadata of
-    Left e -> fail $ show e
-    Right (rels, cols, keys) ->
-      return DbStructure {
-          columns=cols
-        , relations=rels
-        , primaryKeys=keys
-        }
+  dbOrError <- H.session pool $ H.tx txSettings createDbStructure
+  db <- either (fail . show) return dbOrError

  perform $ middle $ \req resp -> do
    body <- strictRequestBody req
    result <- liftIO $ H.session pool $ H.tx txSettings
-      $ runWithClaims cfg (app dbstructure cfg body) req
+      $ runWithClaims cfg (app db cfg body) req
    either (resp . errResponse) resp result

  where middle = defaultMiddle
@@ -1,7 +1,7 @@
-module Unit.PgStructureSpec where
+module Unit.DbStructureSpec where

 import Test.Hspec
-import PgStructure (Table(..), tables, Column(..), columns, ForeignKey(..),
+import DbStructure (Table(..), tables, Column(..), columns, ForeignKey(..),
  foreignKeys)

 import Database.HDBC (quickQuery)