mirror of
https://github.com/khibino/haskell-relational-record.git
synced 2024-12-03 03:52:10 +03:00
Move schema query code for postgreSQL which does not depend on HDBC.
This commit is contained in:
Kei Hibino
parent
cda839431f
commit
c060ea3625
@ -35,8 +35,10 @@ library
|
||||
|
||||
Database.Relational.Schema.DB2Syscat.Columns
|
||||
Database.Relational.Schema.IBMDB2
|
||||
|
||||
Database.Relational.Schema.PgCatalog.PgAttribute
|
||||
Database.Relational.Schema.PgCatalog.PgType
|
||||
Database.Relational.Schema.PostgreSQL
|
||||
|
||||
-- other-modules:
|
||||
build-depends: base <5
|
||||
|
||||
@ -33,12 +33,11 @@ import qualified Database.Relational.Query.Table as Table
|
||||
|
||||
import Database.Relational.Schema.IBMDB2
|
||||
(normalizeColumn, notNull, getType, columnsQuerySQL, primaryKeyQuerySQL)
|
||||
import Database.Relational.Schema.DB2Syscat.Columns (Columns(Columns), tableOfColumns)
|
||||
import qualified Database.Relational.Schema.DB2Syscat.Columns as Columns
|
||||
|
||||
import Database.HDBC.Schema.Driver
|
||||
(TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver)
|
||||
|
||||
import Database.Relational.Schema.DB2Syscat.Columns (Columns(Columns), tableOfColumns)
|
||||
import qualified Database.Relational.Schema.DB2Syscat.Columns as Columns
|
||||
|
||||
|
||||
-- Specify type constructor and data constructor from same table name.
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
-- |
|
||||
@ -15,157 +15,29 @@ module Database.HDBC.Schema.PostgreSQL (
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH (TypeQ)
|
||||
import qualified Language.Haskell.TH.Name.CamelCase as TH
|
||||
import qualified Language.Haskell.TH.Name.Extra as TH
|
||||
|
||||
import Data.Int (Int16, Int32, Int64)
|
||||
import Data.Char (toLower)
|
||||
import Data.Map (Map, fromList, (!))
|
||||
import qualified Data.Map as Map
|
||||
import Data.Time
|
||||
(DiffTime, NominalDiffTime,
|
||||
LocalTime, ZonedTime, Day, TimeOfDay)
|
||||
import Data.Map (fromList)
|
||||
|
||||
import Database.HDBC (IConnection, SqlValue)
|
||||
|
||||
import Database.Record.TH (defineRecordWithSqlTypeDefaultFromDefined)
|
||||
import qualified Database.Relational.Query.Table as Table
|
||||
import Database.Relational.Query.Type (unsafeTypedQuery)
|
||||
import Database.Relational.Query (Query(untypeQuery))
|
||||
import Database.HDBC.Record.Query (runQuery', listToUnique)
|
||||
|
||||
import Database.HDBC.Record.Query (runQuery', listToUnique)
|
||||
import Database.HDBC.Record.Persistable ()
|
||||
|
||||
import Database.Relational.Schema.PostgreSQL
|
||||
(normalizeColumn, notNull, getType, columnQuerySQL, primaryKeyQuerySQL)
|
||||
import Database.Relational.Schema.PgCatalog.PgAttribute (PgAttribute(PgAttribute), tableOfPgAttribute)
|
||||
import qualified Database.Relational.Schema.PgCatalog.PgAttribute as Attr
|
||||
import Database.Relational.Schema.PgCatalog.PgType (PgType(..), tableOfPgType)
|
||||
import qualified Database.Relational.Schema.PgCatalog.PgType as Type
|
||||
|
||||
import Language.SQL.Keyword (Keyword(..), (<.>), (.=.))
|
||||
import qualified Language.SQL.Keyword as SQL
|
||||
|
||||
import Database.HDBC.Record.Persistable ()
|
||||
import Database.HDBC.Schema.Driver
|
||||
(TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver)
|
||||
|
||||
|
||||
mapFromSqlDefault :: Map String TypeQ
|
||||
mapFromSqlDefault =
|
||||
fromList [("bool", [t| Bool |]),
|
||||
("char", [t| String |]),
|
||||
("name", [t| String |]),
|
||||
("int8", [t| Int64 |]),
|
||||
("int2", [t| Int16 |]),
|
||||
("int4", [t| Int32 |]),
|
||||
-- ("regproc", [t| Int32 |]),
|
||||
("text", [t| String |]),
|
||||
("oid", [t| Int32 |]),
|
||||
-- ("pg_node_tree", [t| String |]),
|
||||
("float4", [t| Float |]),
|
||||
("float8", [t| Double |]),
|
||||
("abstime", [t| LocalTime |]),
|
||||
("reltime", [t| NominalDiffTime |]),
|
||||
("tinterval", [t| DiffTime |]),
|
||||
-- ("money", [t| Decimal |]),
|
||||
("bpchar", [t| String |]),
|
||||
("varchar", [t| String |]),
|
||||
("date", [t| Day |]),
|
||||
("time", [t| TimeOfDay |]),
|
||||
("timestamp", [t| LocalTime |]),
|
||||
("timestamptz", [t| ZonedTime |]),
|
||||
("interval", [t| DiffTime |]),
|
||||
("timetz", [t| ZonedTime |])
|
||||
|
||||
-- ("bit", [t| |]),
|
||||
-- ("varbit", [t| |]),
|
||||
-- ("numeric", [t| Decimal |])
|
||||
]
|
||||
|
||||
normalizeField :: String -> String
|
||||
normalizeField = map toLower
|
||||
|
||||
type Column = (PgAttribute, PgType)
|
||||
|
||||
notNull :: Column -> Bool
|
||||
notNull = Attr.attnotnull . fst
|
||||
|
||||
getType :: Map String TypeQ -> Column -> (String, TypeQ)
|
||||
getType mapFromSql column@(pgAttr, pgType) =
|
||||
(normalizeField $ Attr.attname pgAttr,
|
||||
mayNull $ mapFromSql ! Type.typname pgType)
|
||||
where
|
||||
mayNull typ = if notNull column
|
||||
then typ
|
||||
else [t| Maybe $typ |]
|
||||
|
||||
pgCatalog :: SQL.Keyword
|
||||
pgCatalog = "PG_CATALOG"
|
||||
|
||||
relOidQuerySQL :: Query (String, String) (Int32)
|
||||
relOidQuerySQL =
|
||||
unsafeTypedQuery .
|
||||
SQL.unwordsSQL
|
||||
$ [SELECT,
|
||||
"rel" <.> "oid", AS, "rel_object_id",
|
||||
FROM,
|
||||
pgCatalog <.> "pg_namespace", AS, "nsp", ",",
|
||||
pgCatalog <.> "pg_class", AS, "rel",
|
||||
WHERE,
|
||||
"rel" <.> "relnamespace" .=. "nsp" <.> "oid", AND,
|
||||
|
||||
"nspname" .=. "?", AND, "relname" .=. "?"
|
||||
]
|
||||
|
||||
attributeQuerySQL :: Query (String, String) PgAttribute
|
||||
attributeQuerySQL =
|
||||
unsafeTypedQuery .
|
||||
SQL.unwordsSQL
|
||||
$ [SELECT,
|
||||
map (("att" <.>) . SQL.word) (Table.columns tableOfPgAttribute) `SQL.sepBy` ", ",
|
||||
FROM,
|
||||
"(", SQL.word $ untypeQuery relOidQuerySQL, ")", AS, "rel", ",",
|
||||
SQL.word (Table.name tableOfPgAttribute), AS, "att",
|
||||
WHERE,
|
||||
"attrelid" .=. "rel_object_id", AND,
|
||||
"attnum", ">", "0" -- attnum of normal attributes begins from 1
|
||||
]
|
||||
|
||||
columnQuerySQL :: Query (String, String) Column
|
||||
columnQuerySQL =
|
||||
unsafeTypedQuery .
|
||||
SQL.unwordsSQL
|
||||
$ [SELECT,
|
||||
(map (("att" <.>) . SQL.word) (Table.columns tableOfPgAttribute) ++
|
||||
map (("typ" <.>) . SQL.word) (Table.columns tableOfPgType))
|
||||
`SQL.sepBy` ", ",
|
||||
FROM,
|
||||
"(", SQL.word $ untypeQuery attributeQuerySQL, ")", AS, "att", ",",
|
||||
SQL.word (Table.name tableOfPgType), AS, "typ",
|
||||
WHERE,
|
||||
"atttypid" .=. "typ" <.> "oid", AND,
|
||||
"typ" <.> "typtype" .=. "'b'", AND,
|
||||
"(",
|
||||
"typcategory = 'B'", OR,
|
||||
"typcategory = 'D'", OR,
|
||||
"typcategory = 'N'", OR,
|
||||
"typcategory = 'S'", OR,
|
||||
"typcategory = 'T'",
|
||||
")" ]
|
||||
|
||||
primaryKeyQuerySQL :: Query (String, String) String
|
||||
primaryKeyQuerySQL =
|
||||
unsafeTypedQuery .
|
||||
SQL.unwordsSQL
|
||||
$ [SELECT, "attname", FROM,
|
||||
"(", SQL.word $ untypeQuery attributeQuerySQL, ")", AS, "att", ",",
|
||||
pgCatalog <.> "pg_constraint", AS, "con",
|
||||
WHERE,
|
||||
"conrelid" .=. "attrelid", AND,
|
||||
"conkey[1]" .=. "attnum", AND,
|
||||
|
||||
"attnotnull" .=. "TRUE", AND,
|
||||
"contype" .=. "'p'", AND,
|
||||
"array_length (conkey, 1)" .=. "1"]
|
||||
|
||||
|
||||
$(defineRecordWithSqlTypeDefaultFromDefined
|
||||
[t| SqlValue |] (Table.shortName tableOfPgAttribute))
|
||||
|
||||
@ -191,7 +63,7 @@ getPrimaryKey' conn scm' tbl' = do
|
||||
tbl = map toLower tbl'
|
||||
mayPrim <- runQuery' conn (scm, tbl) primaryKeyQuerySQL
|
||||
>>= listToUnique
|
||||
return $ normalizeField `fmap` mayPrim
|
||||
return $ normalizeColumn `fmap` mayPrim
|
||||
|
||||
getFields' :: IConnection conn
|
||||
=> TypeMap
|
||||
@ -212,9 +84,13 @@ getFields' tmap conn scm' tbl' = do
|
||||
putLog
|
||||
$ "getFields: num of columns = " ++ show (length cols)
|
||||
++ ", not null columns = " ++ show notNullIdxs
|
||||
let mapFromSql = fromList tmap `Map.union` mapFromSqlDefault
|
||||
let getType' col = case getType (fromList tmap) col of
|
||||
Nothing -> compileErrorIO
|
||||
$ "Type mapping is not defined against PostgreSQL type: " ++ Type.typname (snd col)
|
||||
Just p -> return p
|
||||
|
||||
return $ (map (getType mapFromSql) cols, notNullIdxs)
|
||||
types <- mapM getType' cols
|
||||
return (types, notNullIdxs)
|
||||
|
||||
driverPostgreSQL :: IConnection conn => Driver conn
|
||||
driverPostgreSQL =
|
||||
|
||||
Loading…
Reference in New Issue
Block a user