diff --git a/src/Postmap/Introspect.hs b/src/Postmap/Introspect.hs index d04d758..3b9e2bf 100644 --- a/src/Postmap/Introspect.hs +++ b/src/Postmap/Introspect.hs @@ -36,6 +36,7 @@ data Table = Table , tableColumns :: ![Column] , tableUniques :: ![[ColumnName]] , tablePrimaryKey :: !(Maybe ColumnName) + , tableIsView :: !Bool } deriving stock (Eq, Generic, Show) deriving (Aeson.FromJSON, Aeson.ToJSON) via (ADC.Autodocodec Table) @@ -50,6 +51,7 @@ instance ADC.HasCodec Table where <*> ADC.requiredField "columns" "Columns of the table." ADC..= tableColumns <*> ADC.requiredField "uniques" "List of list of column names forming unique constraints." ADC..= tableUniques <*> ADC.requiredField "primary_key" "Name of the primary key column, if any." ADC..= tablePrimaryKey + <*> ADC.requiredField "is_view" "Whether the table is a view." ADC..= tableIsView newtype TableSchemaName = MkTableSchemaName @@ -172,6 +174,7 @@ instance ADC.HasCodec ColumnReference where -- given schema name. fetchSchema :: Hasql.Connection.Connection -> T.Text -> IO [Table] fetchSchema conn schema = do + tables <- fetchTables conn schema columns <- fetchColumns conn schema primaryKeys <- fetchPrimaryKeys conn schema foreignKeys <- fetchForeignKeys conn schema @@ -180,10 +183,11 @@ fetchSchema conn schema = do let dbFks = compileForeignKeys foreignKeys let dbUcs = compileUniqueConstraints uniqueConstraints let dbRef = (dbPks, dbFks, dbUcs) :: References - pure . List.sortOn ((<>) <$> unTableSchemaName . tableSchema <*> unTableName . tableName) . fmap snd . HM.toList $ foldl' (go dbRef) mempty columns + pure . List.sortOn ((<>) <$> unTableSchemaName . tableSchema <*> unTableName . tableName) . fmap snd . HM.toList $ foldl' (go tables dbRef) mempty columns where - go refs db c@(schemaName, tableName, _, _, _) = - addColumn refs c (addTable refs schemaName tableName db) + go tables refs db c@(schemaName, tableName, _, _, _) = + let isView = Just (schemaName, tableName, "VIEW") == List.find (\(s, t, _) -> s == schemaName && t == tableName) tables + in addColumn refs c (addTable refs schemaName tableName isView db) type DbTables = HM.HashMap (TableSchemaName, TableName) Table @@ -201,8 +205,8 @@ type DbUniqueConstraints = HM.HashMap (TableSchemaName, TableName) [[ColumnName] type References = (DbPrimaryKeys, DbForeignKeys, DbUniqueConstraints) -addTable :: References -> TableSchemaName -> TableName -> DbTables -> DbTables -addTable (pks, _fks, ucs) tableSchema tableName db = +addTable :: References -> TableSchemaName -> TableName -> Bool -> DbTables -> DbTables +addTable (pks, _fks, ucs) tableSchema tableName isView db = maybe (HM.insert key newTable db) (const db) (HM.lookup key db) where key = (tableSchema, tableName) @@ -213,6 +217,7 @@ addTable (pks, _fks, ucs) tableSchema tableName db = , tableColumns = [] , tableUniques = fromMaybe [] (HM.lookup key ucs) , tablePrimaryKey = HM.lookup key pks + , tableIsView = isView } @@ -255,6 +260,46 @@ compileUniqueConstraints = Just xs -> HM.insert (schema, table) (V.toList columns : xs) acc +-- ** Fetching Tables + + +type StmtTypeTables = + ( TableSchemaName -- Table schema. + , TableName -- Table name. + , T.Text -- Table type. + ) + + +type StmtTypeTables' = + ( T.Text -- Table schema. + , T.Text -- Table name. + , T.Text -- Table name. + ) + + +toStmtTypeTables :: StmtTypeTables' -> StmtTypeTables +toStmtTypeTables (schema, table, typ) = + (MkTableSchemaName schema, MkTableName table, typ) + + +fetchTables :: Hasql.Connection.Connection -> T.Text -> IO [StmtTypeTables] +fetchTables conn schema = do + result <- Hasql.Session.run (Hasql.Session.statement schema stmtTables) conn + either (_die . show) (pure . fmap toStmtTypeTables . V.toList) result + + +stmtTables :: Hasql.Statement.Statement T.Text (V.Vector StmtTypeTables') +stmtTables = + [Hasql.TH.vectorStatement| + SELECT "t"."table_schema" :: text + , "t"."table_name" :: text + , "t"."table_type" :: text + FROM "information_schema"."tables" as "t" + WHERE "t"."table_schema" = $1 :: text + AND "t"."table_type" IN ('BASE TABLE', 'VIEW') + |] + + -- ** Fetching Columns diff --git a/src/Postmap/Spec/FromSchema.hs b/src/Postmap/Spec/FromSchema.hs index 061f69d..5a789a1 100644 --- a/src/Postmap/Spec/FromSchema.hs +++ b/src/Postmap/Spec/FromSchema.hs @@ -35,6 +35,7 @@ fromTable ordering Table {..} = , recordTableName = tableName , recordFields = orderFields ordering (fmap fromColumn tableColumns) , recordUniques = fmap (fmap mkFieldNameFromColumnName) tableUniques + , recordIsView = tableIsView } diff --git a/src/Postmap/Spec/Types.hs b/src/Postmap/Spec/Types.hs index 0dff9ed..0c19e03 100644 --- a/src/Postmap/Spec/Types.hs +++ b/src/Postmap/Spec/Types.hs @@ -58,6 +58,7 @@ data Record = Record , recordTableName :: !TableName , recordFields :: ![Field] , recordUniques :: ![[FieldName]] + , recordIsView :: !Bool } deriving stock (Eq, Generic, Show) deriving (Aeson.FromJSON, Aeson.ToJSON) via (ADC.Autodocodec Record) @@ -74,6 +75,7 @@ instance ADC.HasCodec Record where <*> ADC.requiredField "tableName" "Name of the table." ADC..= recordTableName <*> ADC.requiredField "fields" "Fields in the record." ADC..= recordFields <*> ADC.requiredField "uniques" "Unique constraints in the record." ADC..= recordUniques + <*> ADC.requiredField "isView" "Whether the record is coming from a view." ADC..= recordIsView newtype RecordName = MkRecordName