WIP: use postgresql-simple in pgstructure
This commit is contained in:
Joe Nelson
+1
-1
@@ -1,6 +1,6 @@
|
||||
module PgQuery (
|
||||
CompleteQuery
|
||||
, QualifiedTable
|
||||
, QualifiedTable(..)
|
||||
, limitT
|
||||
, whereT
|
||||
, orderT
|
||||
|
||||
+106
-131
@@ -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)
|
||||
|
||||
Reference in New Issue
Block a user