diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 32f9e657a..41e6a1622 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -1,6 +1,6 @@ module PgQuery ( CompleteQuery -, QualifiedTable +, QualifiedTable(..) , limitT , whereT , orderT diff --git a/src/PgStructure.hs b/src/PgStructure.hs index e323a1569..544ed833f 100644 --- a/src/PgStructure.hs +++ b/src/PgStructure.hs @@ -1,29 +1,127 @@ +{-# LANGUAGE QuasiQuotes #-} module PgStructure where +import PgQuery (QualifiedTable(..)) import Data.Functor ( (<$>) ) -import Data.Maybe (mapMaybe) import Data.Text hiding (foldl, map, zipWith, concat) -import Data.Monoid ((<>)) -import Data.String.Conversions (cs) import Control.Applicative ( (<*>) ) -import qualified Data.ByteString.Lazy as BL - +import qualified Data.List as L import qualified Data.Aeson as JSON import qualified Data.Map as Map -import Database.HDBC hiding (colType, colNullable) -import Database.HDBC.PostgreSQL - +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.SqlQQ +import Database.PostgreSQL.Simple.FromRow import Data.Aeson ((.=)) +foreignKeys :: Connection -> QualifiedTable -> IO (Map.Map Text ForeignKey) +foreignKeys c table = do + r <- query c [sql| + select kcu.column_name, ccu.table_name AS foreign_table_name, + ccu.column_name AS foreign_column_name + from information_schema.table_constraints AS tc + join information_schema.key_column_usage AS kcu + on tc.constraint_name = kcu.constraint_name + join information_schema.constraint_column_usage AS ccu + on ccu.constraint_name = tc.constraint_name + where constraint_type = 'FOREIGN KEY' + and tc.table_name=? and tc.table_schema = ? + order by kcu.column_name + |] + (qtName table, qtSchema table) + + return $ foldl addKey Map.empty r + where + addKey m [col, ftab, fcol] = Map.insert col (ForeignKey ftab fcol) m + addKey _ _ = error "foreignKeys: should never happen" + + +tables :: Connection -> Text -> IO [Table] +tables c schema = + query c [sql| + select table_schema, table_name, + is_insertable_into + from information_schema.tables + where table_schema = ? + order by table_name + |] $ Only schema + + +columns :: Connection -> QualifiedTable -> IO [Column] +columns c table = do + cols <- query c [sql| + select info.table_schema as schema, info.table_name as table_name, + info.column_name as name, info.ordinal_position as position, + info.is_nullable as nullable, info.data_type as col_type, + info.is_updatable as updatable, + info.character_maximum_length as max_len, + info.numeric_precision as precision, + info.column_default as default_value, + array_to_string(enum_info.vals, ',') as enum + from ( + select table_schema, table_name, column_name, ordinal_position, + is_nullable, data_type, is_updatable, + character_maximum_length, numeric_precision, + column_default, udt_name + from information_schema.columns + where table_schema = ? and table_name = ? + ) as info + left outer join ( + select n.nspname as s, + t.typname as n, + array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals + from pg_type t + join pg_enum e on t.oid = e.enumtypid + join pg_catalog.pg_namespace n ON n.oid = t.typnamespace + group by s, n + ) as enum_info + on (info.udt_name = enum_info.n) + order by position |] (qtSchema table, qtName table) + + fks <- foreignKeys c table + return $ map (\col -> col { colFK = Map.lookup (colName col) fks }) cols + + +primaryKeyColumns :: Connection -> QualifiedTable -> IO [Text] +primaryKeyColumns c table = do + r <- query c [sql| + select 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 = ? + and kc.table_name = ? |] (qtSchema table, qtName table) + return $ concat r + + data Table = Table { tableSchema :: Text , tableName :: Text , tableInsertable :: Bool } deriving (Show) +instance FromRow Table where + fromRow = Table <$> field <*> field <*> (toBool <$> field) + +instance FromRow Column where + fromRow = Column <$> + field <*> field <*> field <*> field + <*> (toBool <$> field) + <*> field + <*> (toBool <$> field) + <*> field <*> field <*> field + <*> (vanishNull . splitOn "," <$> field) + <*> return Nothing + +vanishNull :: [a] -> Maybe [a] +vanishNull xs = if L.null xs then Nothing else Just xs + instance JSON.ToJSON Table where toJSON v = JSON.object [ "schema" .= tableSchema v @@ -40,24 +138,6 @@ data ForeignKey = ForeignKey { instance JSON.ToJSON ForeignKey where toJSON fk = JSON.object ["table".=fkTable fk, "column".=fkCol fk] -foreignKeys :: Text -> Text -> Connection -> IO (Map.Map Text ForeignKey) -foreignKeys schema table conn = do - r <- quickQuery conn - "select kcu.column_name, ccu.table_name AS foreign_table_name,\ - \ ccu.column_name AS foreign_column_name \ - \from information_schema.table_constraints AS tc \ - \ join information_schema.key_column_usage AS kcu \ - \ on tc.constraint_name = kcu.constraint_name \ - \ join information_schema.constraint_column_usage AS ccu \ - \ on ccu.constraint_name = tc.constraint_name \ - \where constraint_type = 'FOREIGN KEY' \ - \ and tc.table_name=? and tc.table_schema = ? \ - \order by kcu.column_name" (map toSql [table, schema]) - return $ foldl addKey Map.empty $ map (map fromSql) r - where - addKey m [col, ftab, fcol] = Map.insert col (ForeignKey ftab fcol) m - addKey m _ = m --should never happen - data Column = Column { colSchema :: Text , colTable :: Text @@ -86,108 +166,3 @@ instance JSON.ToJSON Column where , "references".= colFK c , "default" .= colDefault c , "enum" .= colEnum c ] - -data TableOptions = TableOptions { - tblOptcolumns :: [Column] -, tblOptpkey :: [Text] -} - -instance JSON.ToJSON TableOptions where - toJSON t = JSON.object [ - "columns" .= tblOptcolumns t - , "pkey" .= tblOptpkey t ] - -tables :: Text -> Connection -> IO [Table] -tables s conn = do - r <- quickQuery conn - "select table_schema, table_name,\ - \ is_insertable_into\ - \ from information_schema.tables\ - \ where table_schema = ?\ - \ order by table_name" [toSql s] - return $ mapMaybe mkTable r - - where - mkTable [schema, name, insertable] = - Just $ Table (fromSql schema) - (fromSql name) - (toBool (fromSql insertable)) - mkTable _ = Nothing - -columns :: Text -> Text -> Connection -> IO [Column] -columns s t conn = do - r <- quickQuery conn - "select info.table_schema as schema, info.table_name as table_name, \ - \ info.column_name as name, info.ordinal_position as position, \ - \ info.is_nullable as nullable, info.data_type as col_type, \ - \ info.is_updatable as updatable, \ - \ info.character_maximum_length as max_len, \ - \ info.numeric_precision as precision, \ - \ info.column_default as default_value, \ - \ array_to_string(enum_info.vals, ',') as enum \ - \ from ( \ - \ select table_schema, table_name, column_name, ordinal_position, \ - \ is_nullable, data_type, is_updatable, \ - \ character_maximum_length, numeric_precision, \ - \ column_default, udt_name \ - \ from information_schema.columns \ - \ where table_schema = ? and table_name = ? \ - \ ) as info \ - \ left outer join ( \ - \ select n.nspname as s, \ - \ t.typname as n, \ - \ array_agg(e.enumlabel ORDER BY e.enumsortorder) as vals \ - \ from pg_type t \ - \ join pg_enum e on t.oid = e.enumtypid \ - \ join pg_catalog.pg_namespace n ON n.oid = t.typnamespace \ - \ group by s, n \ - \ ) as enum_info \ - \ on (info.udt_name = enum_info.n) \ - \order by position" [toSql s, toSql t] - fks <- foreignKeys s t conn - let lookupFK (_:_:name:_) = Map.lookup (fromSql name) fks - lookupFK _ = Nothing - let cols = zipWith ($) (map mkColumn r) (map lookupFK r) - return cols - - where - mkColumn [schema, table, name, pos, nullable, colT, updatable, maxlen, precision, defVal, enum] = Column (fromSql schema) - (fromSql table) - (fromSql name) - (fromSql pos) - (toBool (fromSql nullable)) - (fromSql colT) - (toBool (fromSql updatable)) - (fromSql maxlen) - (fromSql precision) - (fromSql defVal) - (Data.Text.splitOn "," <$> fromSql enum) - mkColumn _ = error $ "Incomplete column data received for table " <> - cs t <> " in schema " <> cs s <> "." - -printTables :: Text -> Connection -> IO BL.ByteString -printTables schema conn = JSON.encode <$> tables schema conn - -printColumns :: Text -> Text -> Connection -> IO BL.ByteString -printColumns schema table conn = - JSON.encode <$> (TableOptions <$> cols <*> pkey) - where - cols :: IO [Column] - cols = columns schema table conn - pkey :: IO [Text] - pkey = primaryKeyColumns schema table conn - -primaryKeyColumns :: Text -> Text -> Connection -> IO [Text] -primaryKeyColumns s t conn = do - r <- quickQuery conn - "select 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 = ? \ - \ and kc.table_name = ?" [toSql s, toSql t] - return $ map fromSql (concat r)