relational-schemas (empty) → 0.0.1.0
raw patch · 36 files changed
+1941/−0 lines, 36 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, persistable-record, relational-query, template-haskell, time
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- relational-schemas.cabal +91/−0
- src/Database/Relational/Schema/DB2Syscat/Columns.hs +103/−0
- src/Database/Relational/Schema/DB2Syscat/Config.hs +16/−0
- src/Database/Relational/Schema/DB2Syscat/Keycoluse.hs +31/−0
- src/Database/Relational/Schema/DB2Syscat/Tabconst.hs +33/−0
- src/Database/Relational/Schema/IBMDB2.hs +119/−0
- src/Database/Relational/Schema/MySQL.hs +111/−0
- src/Database/Relational/Schema/MySQLInfo/Columns.hs +23/−0
- src/Database/Relational/Schema/MySQLInfo/Config.hs +16/−0
- src/Database/Relational/Schema/MySQLInfo/KeyColumnUsage.hs +21/−0
- src/Database/Relational/Schema/MySQLInfo/TableConstraints.hs +19/−0
- src/Database/Relational/Schema/Oracle.hs +117/−0
- src/Database/Relational/Schema/OracleDataDictionary/Config.hs +16/−0
- src/Database/Relational/Schema/OracleDataDictionary/ConsColumns.hs +28/−0
- src/Database/Relational/Schema/OracleDataDictionary/Constraints.hs +40/−0
- src/Database/Relational/Schema/OracleDataDictionary/TabColumns.hs +82/−0
- src/Database/Relational/Schema/PgCatalog/Config.hs +16/−0
- src/Database/Relational/Schema/PgCatalog/PgAttribute.hs +70/−0
- src/Database/Relational/Schema/PgCatalog/PgClass.hs +54/−0
- src/Database/Relational/Schema/PgCatalog/PgConstraint.hs +52/−0
- src/Database/Relational/Schema/PgCatalog/PgNamespace.hs +30/−0
- src/Database/Relational/Schema/PgCatalog/PgType.hs +89/−0
- src/Database/Relational/Schema/PostgreSQL.hs +212/−0
- src/Database/Relational/Schema/SQLServer.hs +130/−0
- src/Database/Relational/Schema/SQLServerSyscat/Columns.hs +69/−0
- src/Database/Relational/Schema/SQLServerSyscat/Config.hs +16/−0
- src/Database/Relational/Schema/SQLServerSyscat/IndexColumns.hs +33/−0
- src/Database/Relational/Schema/SQLServerSyscat/Indexes.hs +57/−0
- src/Database/Relational/Schema/SQLServerSyscat/Types.hs +50/−0
- src/Database/Relational/Schema/SQLite3.hs +65/−0
- src/Database/Relational/Schema/SQLite3Syscat/Config.hs +16/−0
- src/Database/Relational/Schema/SQLite3Syscat/IndexInfo.hs +26/−0
- src/Database/Relational/Schema/SQLite3Syscat/IndexList.hs +26/−0
- src/Database/Relational/Schema/SQLite3Syscat/TableInfo.hs +32/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Kei Hibino++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Kei Hibino nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ relational-schemas.cabal view
@@ -0,0 +1,91 @@+name: relational-schemas+version: 0.0.1.0+synopsis: RDBMSs' schema templates for relational-query+description: This package contains some RDBMSs' schema structure definitions.+ Supported RDBMS schemas are below:+ - IBM DB2+ - PostgreSQL+ - Microsoft SQLServer+ - SQLite3+ - Oracle+ - MySQL+homepage: http://twitter.com/khibino+license: BSD3+license-file: LICENSE+author: Kei Hibino, Shohei Murayama, Shohei Yasutake, Sho KURODA+maintainer: ex8k.hibino@gmail.com, shohei.murayama@gmail.com, amutake.s@gmail.com, krdlab@gmail.com+copyright: Copyright (c) 2013 2014 Kei Hibino, Shohei Murayama, Shohei Yasutake, Sho KURODA+category: Database+build-type: Simple+cabal-version: >=1.10++library+ exposed-modules:+ Database.Relational.Schema.DB2Syscat.Columns+ Database.Relational.Schema.IBMDB2++ Database.Relational.Schema.PgCatalog.PgAttribute+ Database.Relational.Schema.PgCatalog.PgType+ Database.Relational.Schema.PostgreSQL++ Database.Relational.Schema.SQLServerSyscat.Columns+ Database.Relational.Schema.SQLServerSyscat.Types+ Database.Relational.Schema.SQLServer++ Database.Relational.Schema.SQLite3Syscat.IndexInfo+ Database.Relational.Schema.SQLite3Syscat.IndexList+ Database.Relational.Schema.SQLite3Syscat.TableInfo+ Database.Relational.Schema.SQLite3++ Database.Relational.Schema.OracleDataDictionary.TabColumns+ Database.Relational.Schema.Oracle++ Database.Relational.Schema.MySQLInfo.Columns+ Database.Relational.Schema.MySQL++ Database.Relational.Schema.DB2Syscat.Config+ Database.Relational.Schema.PgCatalog.Config+ Database.Relational.Schema.SQLServerSyscat.Config+ Database.Relational.Schema.SQLite3Syscat.Config+ Database.Relational.Schema.OracleDataDictionary.Config+ Database.Relational.Schema.MySQLInfo.Config++ other-modules:+ Database.Relational.Schema.DB2Syscat.Tabconst+ Database.Relational.Schema.DB2Syscat.Keycoluse++ Database.Relational.Schema.PgCatalog.PgConstraint+ Database.Relational.Schema.PgCatalog.PgNamespace+ Database.Relational.Schema.PgCatalog.PgClass++ Database.Relational.Schema.SQLServerSyscat.IndexColumns+ Database.Relational.Schema.SQLServerSyscat.Indexes++ Database.Relational.Schema.OracleDataDictionary.ConsColumns+ Database.Relational.Schema.OracleDataDictionary.Constraints++ Database.Relational.Schema.MySQLInfo.KeyColumnUsage+ Database.Relational.Schema.MySQLInfo.TableConstraints++ build-depends: base <5+ , template-haskell+ , containers+ , time+ , bytestring++ , persistable-record+ , relational-query++ hs-source-dirs: src+ ghc-options: -Wall++ default-language: Haskell2010+++source-repository head+ type: git+ location: https://github.com/khibino/haskell-relational-record++source-repository head+ type: mercurial+ location: https://bitbucket.org/khibino/haskell-relational-record
+ src/Database/Relational/Schema/DB2Syscat/Columns.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module : Database.Relational.Schema.DB2Syscat.Columns+-- Copyright : 2013 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+--+-- Generate template of SYSCAT.columns system catalog table.+module Database.Relational.Schema.DB2Syscat.Columns where++import Data.Int (Int16, Int32, Int64)++import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.DB2Syscat.Config (config)+++$(defineTableTypesAndRecordDefault config+ "SYSCAT" "columns"+ [+ -- column schema type length NULL+ -- ------------------------------ --------- ------------------ -------- ----- ------+ -- TABSCHEMA SYSIBM VARCHAR 128 0 No+ ("tabschema", [t|String|]),+ -- TABNAME SYSIBM VARCHAR 128 0 No+ ("tabname", [t|String|]),+ -- COLNAME SYSIBM VARCHAR 128 0 No+ ("colname", [t|String|]),+ -- COLNO SYSIBM SMALLINT 2 0 No+ ("colno", [t|Int16|]),+ -- TYPESCHEMA SYSIBM VARCHAR 128 0 No+ ("typeschema", [t|String|]),+ -- TYPENAME SYSIBM VARCHAR 18 0 No+ ("typename", [t|String|]),+ -- LENGTH SYSIBM INTEGER 4 0 No+ ("length", [t|Int32|]),+ -- SCALE SYSIBM SMALLINT 2 0 No+ ("scale", [t|Int16|]),+ -- DEFAULT SYSIBM VARCHAR 254 0 Yes+ ("default", [t|Maybe String|]),+ -- NULLS SYSIBM CHARACTER 1 0 No+ ("nulls", [t|String|]),+ -- CODEPAGE SYSIBM SMALLINT 2 0 No+ ("codepage", [t|Int16|]),+ -- LOGGED SYSIBM CHARACTER 1 0 No+ ("logged", [t|String|]),+ -- COMPACT SYSIBM CHARACTER 1 0 No+ ("compact", [t|String|]),+ -- COLCARD SYSIBM BIGINT 8 0 No+ ("colcard", [t|Int64|]),+ -- HIGH2KEY SYSIBM VARCHAR 254 0 Yes+ ("high2key", [t|Maybe String|]),+ -- LOW2KEY SYSIBM VARCHAR 254 0 Yes+ ("low2key", [t|Maybe String|]),+ -- AVGCOLLEN SYSIBM INTEGER 4 0 No+ ("avgcollen", [t|Int32|]),+ -- KEYSEQ SYSIBM SMALLINT 2 0 Yes+ ("keyseq", [t|Maybe Int16|]),+ -- PARTKEYSEQ SYSIBM SMALLINT 2 0 Yes+ ("partkeyseq", [t|Maybe Int16|]),+ -- NQUANTILES SYSIBM SMALLINT 2 0 No+ ("nquantiles", [t|Int16|]),+ -- NMOSTFREQ SYSIBM SMALLINT 2 0 No+ ("nmostfreq", [t|Int16|]),+ -- NUMNULLS SYSIBM BIGINT 8 0 No+ ("numnulls", [t|Int64|]),+ -- TARGET_TYPESCHEMA SYSIBM VARCHAR 128 0 Yes+ ("target_typeschema", [t|Maybe String|]),+ -- TARGET_TYPENAME SYSIBM VARCHAR 18 0 Yes+ ("target_typename", [t|Maybe String|]),+ -- SCOPE_TABSCHEMA SYSIBM VARCHAR 128 0 Yes+ ("scope_tabschema", [t|Maybe String|]),+ -- SCOPE_TABNAME SYSIBM VARCHAR 128 0 Yes+ ("scope_tabname", [t|Maybe String|]),+ -- SOURCE_TABSCHEMA SYSIBM VARCHAR 128 0 Yes+ ("source_tabschema", [t|Maybe String|]),+ -- SOURCE_TABNAME SYSIBM VARCHAR 128 0 Yes+ ("source_tabname", [t|Maybe String|]),+ -- DL_FEATURES SYSIBM CHARACTER 10 0 Yes+ ("dl_features", [t|Maybe String|]),+ -- SPECIAL_PROPS SYSIBM CHARACTER 8 0 Yes+ ("special_props", [t|Maybe String|]),+ -- HIDDEN SYSIBM CHARACTER 1 0 No+ ("hidden", [t|String|]),+ -- INLINE_LENGTH SYSIBM INTEGER 4 0 No+ ("inline_length", [t|Int32|]),+ -- IDENTITY SYSIBM CHARACTER 1 0 No+ ("identity", [t|String|]),+ -- GENERATED SYSIBM CHARACTER 1 0 No+ ("generated", [t|String|]),+ -- TEXT SYSIBM CLOB 65538 0 Yes+ ("text", [t|Maybe String|]),+ -- REMARKS SYSIBM VARCHAR 254 0 Yes+ ("remarks", [t|Maybe String|])++ ]+ [derivingShow])
+ src/Database/Relational/Schema/DB2Syscat/Config.hs view
@@ -0,0 +1,16 @@+-- |+-- Module : Database.Relational.Schema.DB2Syscat.Config+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+module Database.Relational.Schema.DB2Syscat.Config (config) where++import Database.Relational.Query (Config (..), ProductUnitSupport (..), defaultConfig)+++-- | Configuration parameter against IBM DB2.+config :: Config+config = defaultConfig { productUnitSupport = PUNotSupported }
+ src/Database/Relational/Schema/DB2Syscat/Keycoluse.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module : Database.Relational.Schema.DB2Syscat.Keycoluse+-- Copyright : 2013 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+--+-- Generate template of SYSCAT.keycoluse system catalog table.+-- Not all columns are mapped to Haskell record.+-- Minimum implementation required to generate table constraints.+module Database.Relational.Schema.DB2Syscat.Keycoluse where++import Data.Int (Int16)+import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.DB2Syscat.Config (config)+++-- Not all column is mapped. Minimum implementation.+$(defineTableTypesAndRecordDefault config+ "SYSCAT" "keycoluse"+ [("constname", [t| String |]),+ ("colname" , [t| String |]),+ ("colseq" , [t| Int16 |])]+ [derivingShow])
+ src/Database/Relational/Schema/DB2Syscat/Tabconst.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module : Database.Relational.Schema.DB2Syscat.Tabconst+-- Copyright : 2013 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+--+-- Generate template of SYSCAT.tabconst system catalog table.+-- Not all columns are mapped to Haskell record.+-- Minimum implementation required to generate table constraints.+module Database.Relational.Schema.DB2Syscat.Tabconst where++import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.DB2Syscat.Config (config)+++-- Not all column is mapped. Minimum implementation.+$(defineTableTypesAndRecordDefault config+ "SYSCAT" "tabconst"+ [("constname", [t| String |]),+ ("tabschema", [t| String |]),+ ("tabname" , [t| String |]),+ --+ ("type" , [t| String |]),+ ("enforced" , [t| String |])]+ [derivingShow])
+ src/Database/Relational/Schema/IBMDB2.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module : Database.Relational.Schema.IBMDB2+-- Copyright : 2013 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+--+-- This module implements queries to get+-- table schema and table constraint informations+-- from system catalog of IBM DB2.+module Database.Relational.Schema.IBMDB2 (+ normalizeColumn, notNull, getType,++ columnsQuerySQL, primaryKeyQuerySQL+ ) where+++import Data.Int (Int16, Int32, Int64)+import Data.Char (toLower)+import Data.Map (Map, fromList)+import qualified Data.Map as Map+import Data.Time (LocalTime, Day)+import Language.Haskell.TH (TypeQ)++import Database.Relational.Query.Type (relationalQuery)+import Database.Relational.Query+ (Query, Relation, query, relation',+ wheres, (.=.), (!), (><), placeholder, asc, value)++import Control.Applicative ((<|>))++import Database.Relational.Schema.DB2Syscat.Columns (Columns, columns)+import qualified Database.Relational.Schema.DB2Syscat.Columns as Columns+import Database.Relational.Schema.DB2Syscat.Tabconst (tabconst)+import qualified Database.Relational.Schema.DB2Syscat.Tabconst as Tabconst+import Database.Relational.Schema.DB2Syscat.Keycoluse (keycoluse)+import qualified Database.Relational.Schema.DB2Syscat.Keycoluse as Keycoluse+++-- | Mapping between type in DB2 and Haskell type.+mapFromSqlDefault :: Map String TypeQ+mapFromSqlDefault =+ fromList [("VARCHAR", [t|String|]),+ ("CHAR", [t|String|]),+ ("CHARACTER", [t|String|]),+ ("TIMESTAMP", [t|LocalTime|]),+ ("DATE", [t|Day|]),+ ("SMALLINT", [t|Int16|]),+ ("INTEGER", [t|Int32|]),+ ("BIGINT", [t|Int64|]),+ ("BLOB", [t|String|]),+ ("CLOB", [t|String|])]++-- | Normalize column name string to query DB2 system catalog+normalizeColumn :: String -> String+normalizeColumn = map toLower++-- | Not-null attribute information of column.+notNull :: Columns -> Bool+notNull = (== "N") . Columns.nulls++-- | Get column normalized name and column Haskell type.+getType :: Map String TypeQ -- ^ Type mapping specified by user+ -> Columns -- ^ Column info in system catalog+ -> Maybe (String, TypeQ) -- ^ Result normalized name and mapped Haskell type+getType mapFromSql rec = do+ typ <- (Map.lookup key mapFromSql+ <|>+ Map.lookup key mapFromSqlDefault)+ return (normalizeColumn $ Columns.colname rec, mayNull typ)+ where key = Columns.typename rec+ mayNull typ = if notNull rec+ then typ+ else [t| Maybe $(typ) |]++-- | 'Relation' to query 'Columns' from schema name and table name.+columnsRelationFromTable :: Relation (String, String) Columns+columnsRelationFromTable = relation' $ do+ c <- query columns+ (schemaP, ()) <- placeholder (\ph -> wheres $ c ! Columns.tabschema' .=. ph)+ (nameP , ()) <- placeholder (\ph -> wheres $ c ! Columns.tabname' .=. ph)+ asc $ c ! Columns.colno'+ return (schemaP >< nameP, c)++-- | Phantom typed 'Query' to get 'Columns' from schema name and table name.+columnsQuerySQL :: Query (String, String) Columns+columnsQuerySQL = relationalQuery columnsRelationFromTable+++-- | 'Relation' to query primary key name from schema name and table name.+primaryKeyRelation :: Relation (String, String) String+primaryKeyRelation = relation' $ do+ cons <- query tabconst+ key <- query keycoluse+ col <- query columns++ wheres $ cons ! Tabconst.tabschema' .=. col ! Columns.tabschema'+ wheres $ cons ! Tabconst.tabname' .=. col ! Columns.tabname'+ wheres $ key ! Keycoluse.colname' .=. col ! Columns.colname'+ wheres $ cons ! Tabconst.constname' .=. key ! Keycoluse.constname'++ wheres $ col ! Columns.nulls' .=. value "N"+ wheres $ cons ! Tabconst.type' .=. value "P"+ wheres $ cons ! Tabconst.enforced' .=. value "Y"++ (schemaP, ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tabschema' .=. ph)+ (nameP , ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tabname' .=. ph)++ asc $ key ! Keycoluse.colseq'++ return (schemaP >< nameP, key ! Keycoluse.colname')++-- | Phantom typed 'Query' to get primary key name from schema name and table name.+primaryKeyQuerySQL :: Query (String, String) String+primaryKeyQuerySQL = relationalQuery primaryKeyRelation
+ src/Database/Relational/Schema/MySQL.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE TemplateHaskell #-}+module Database.Relational.Schema.MySQL+ ( normalizeColumn+ , notNull+ , getType+ , columnsQuerySQL+ , primaryKeyQuerySQL+ )+ where++import Data.Int (Int32, Int64)+import Data.Char (toLower, toUpper)+import Data.Map (Map, fromList)+import qualified Data.Map as Map+import Data.Time (Day, LocalTime, TimeOfDay)+import Data.Time.Clock.POSIX (POSIXTime)+import Data.ByteString (ByteString)+import Control.Applicative ((<|>))+import Language.Haskell.TH (TypeQ)++import Database.Relational.Query ( Query+ , query+ , relation'+ , wheres+ , (.=.)+ , (!)+ , (><)+ , placeholder+ , asc+ , value+ )+import Database.Relational.Query.Type (relationalQuery)++import Database.Relational.Schema.MySQLInfo.Columns (Columns, columns)+import qualified Database.Relational.Schema.MySQLInfo.Columns as Columns+import Database.Relational.Schema.MySQLInfo.TableConstraints (tableConstraints)+import qualified Database.Relational.Schema.MySQLInfo.TableConstraints as Tabconst+import Database.Relational.Schema.MySQLInfo.KeyColumnUsage (keyColumnUsage)+import qualified Database.Relational.Schema.MySQLInfo.KeyColumnUsage as Keycoluse++mapFromSqlDefault :: Map String TypeQ+mapFromSqlDefault = fromList+ [ ("CHAR", [t| String |])+ , ("VARCHAR", [t| String |])+ , ("TINYTEXT", [t| String |])+ , ("TEXT", [t| String |])+ , ("MEDIUMTEXT", [t| String |])+ , ("LONGTEXT", [t| String |])+ , ("TINYBLOB", [t| ByteString |])+ , ("BLOB", [t| ByteString |])+ , ("MEDIUMBLOB", [t| ByteString |])+ , ("LONGBLOB", [t| ByteString |])+ , ("DATE", [t| Day |])+ , ("DATETIME", [t| LocalTime |])+ , ("TIME", [t| TimeOfDay |])+ , ("TIMESTAMP", [t| POSIXTime |])+ , ("TINYINT", [t| Int32 |])+ , ("SMALLINT", [t| Int32 |])+ , ("INT", [t| Int32 |])+ , ("INTEGER", [t| Int32 |])+ , ("BIGINT", [t| Int64 |])+ ]++normalizeColumn :: String -> String+normalizeColumn = map toLower++notNull :: Columns -> Bool+notNull = (== "NO") . Columns.isNullable++getType :: Map String TypeQ+ -> Columns+ -> Maybe (String, TypeQ)+getType mapFromSql rec = do+ typ <- Map.lookup key mapFromSql+ <|>+ Map.lookup key mapFromSqlDefault+ return (normalizeColumn $ Columns.columnName rec, mayNull typ)+ where+ key = map toUpper $ Columns.dataType rec+ mayNull typ = if notNull rec+ then typ+ else [t|Maybe $(typ)|]++columnsQuerySQL :: Query (String, String) Columns+columnsQuerySQL = relationalQuery columnsRelationFromTable+ where+ columnsRelationFromTable = relation' $ do+ c <- query columns+ (schemaP, ()) <- placeholder (\ph -> wheres $ c ! Columns.tableSchema' .=. ph)+ (nameP , ()) <- placeholder (\ph -> wheres $ c ! Columns.tableName' .=. ph)+ asc $ c ! Columns.ordinalPosition'+ return (schemaP >< nameP, c)++primaryKeyQuerySQL :: Query (String, String) String+primaryKeyQuerySQL = relationalQuery primaryKeyRelation+ where+ primaryKeyRelation = relation' $ do+ cons <- query tableConstraints+ key <- query keyColumnUsage++ wheres $ cons ! Tabconst.tableSchema' .=. key ! Keycoluse.tableSchema'+ wheres $ cons ! Tabconst.tableName' .=. key ! Keycoluse.tableName'+ wheres $ cons ! Tabconst.constraintName' .=. key ! Keycoluse.constraintName'++ (schemaP, ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tableSchema' .=. ph)+ (nameP , ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tableName' .=. ph)+ wheres $ cons ! Tabconst.constraintType' .=. value "PRIMARY KEY"++ asc $ key ! Keycoluse.ordinalPosition'++ return (schemaP >< nameP, key ! Keycoluse.columnName')
+ src/Database/Relational/Schema/MySQLInfo/Columns.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++module Database.Relational.Schema.MySQLInfo.Columns where++import Data.Int (Int16)+import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.MySQLInfo.Config (config)+++$(defineTableTypesAndRecordDefault config+ "INFORMATION_SCHEMA" "columns"+ [ ("table_schema", [t|String|])+ , ("table_name", [t|String|])+ , ("column_name", [t|String|])+ , ("ordinal_position", [t|Int16|])+ , ("column_default", [t|Maybe String|])+ , ("is_nullable", [t|String|])+ , ("data_type", [t|String|])+ ]+ [derivingShow])
+ src/Database/Relational/Schema/MySQLInfo/Config.hs view
@@ -0,0 +1,16 @@+-- |+-- Module : Database.Relational.Schema.MySQLInfo.Config+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+module Database.Relational.Schema.MySQLInfo.Config (config) where++import Database.Relational.Query (Config (..), defaultConfig)+++-- | Configuration parameter against MySQL.+config :: Config+config = defaultConfig { normalizedTableName = False }
+ src/Database/Relational/Schema/MySQLInfo/KeyColumnUsage.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++module Database.Relational.Schema.MySQLInfo.KeyColumnUsage where++import Data.Int (Int16)+import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.MySQLInfo.Config (config)+++$(defineTableTypesAndRecordDefault config+ "INFORMATION_SCHEMA" "key_column_usage"+ [ ("constraint_name" , [t| String |])+ , ("table_schema" , [t| String |])+ , ("table_name" , [t| String |])+ , ("column_name" , [t| String |])+ , ("ordinal_position" , [t| Int16 |])+ ]+ [derivingShow])
+ src/Database/Relational/Schema/MySQLInfo/TableConstraints.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++module Database.Relational.Schema.MySQLInfo.TableConstraints where++import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.MySQLInfo.Config (config)+++$(defineTableTypesAndRecordDefault config+ "INFORMATION_SCHEMA" "table_constraints"+ [ ("table_schema" , [t| String |])+ , ("table_name" , [t| String |])+ , ("constraint_name" , [t| String |])+ , ("constraint_type" , [t| String |])+ ]+ [derivingShow])
+ src/Database/Relational/Schema/Oracle.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.Relational.Schema.Oracle+ ( normalizeColumn, notNull, getType+ , columnsQuerySQL, primaryKeyQuerySQL+ ) where++import Control.Applicative ((<|>))+import Data.ByteString (ByteString)+import Data.Char (toLower)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Time (LocalTime)++import Language.Haskell.TH (TypeQ)++import Database.Relational.Query++import Database.Relational.Schema.OracleDataDictionary.ConsColumns (dbaConsColumns)+import qualified Database.Relational.Schema.OracleDataDictionary.ConsColumns as ConsCols+import Database.Relational.Schema.OracleDataDictionary.Constraints (dbaConstraints)+import qualified Database.Relational.Schema.OracleDataDictionary.Constraints as Cons+import Database.Relational.Schema.OracleDataDictionary.TabColumns (DbaTabColumns, dbaTabColumns)+import qualified Database.Relational.Schema.OracleDataDictionary.TabColumns as Cols++-- NOT COMPLETED+-- (ref: http://docs.oracle.com/cd/B28359_01/server.111/b28318/datatype.htm)+-- | Mapping between type in Oracle DB and Haskell type.+mapFromSqlDefault :: Map String TypeQ+mapFromSqlDefault = Map.fromList+ [ ("CHAR", [t|String|])+ , ("VARCHAR", [t|String|]) -- deprecated+ , ("VARCHAR2", [t|String|])+ , ("NCHAR", [t|String|])+ , ("NVARCHAR2", [t|String|])+ -- , ("NUMBER", [t|Integer or Double|]) see 'getType'+ , ("BINARY_FLOAT", [t|Double|]) -- Float don't work+ , ("BINARY_DOUBLE", [t|Double|])+ , ("DATE", [t|LocalTime|])+ , ("BLOB", [t|ByteString|])+ , ("CLOB", [t|String|])+ , ("NCLOB", [t|String|])+ , ("LONG RAW", [t|ByteString|]) -- deprecated+ , ("RAW", [t|ByteString|])+ , ("ROWID", [t|String|])+ , ("UROWID", [t|String|])+ ]++-- | Normalize column name string to query Oracle DB data dictionary.+normalizeColumn :: String -> String+normalizeColumn = map toLower++-- | Not-null attribute information of column.+notNull :: DbaTabColumns -> Bool+notNull = (== Just "N") . Cols.nullable++-- | Get column normalized name and column Haskell type.+getType :: Map String TypeQ -- ^ Type mapping specified by user+ -> DbaTabColumns -- ^ Column info in data dictionary+ -> Maybe (String, TypeQ) -- ^ Result normalized name and mapped Haskell type+getType mapFromSql cols = do+ ky <- Cols.dataType cols+ typ <- if ky == "NUMBER"+ then return $ numberType $ Cols.dataScale cols+ else Map.lookup ky mapFromSql <|> Map.lookup ky mapFromSqlDefault+ return (normalizeColumn $ Cols.columnName cols, mayNull typ)+ where+ mayNull typ+ | notNull cols = typ+ | otherwise = [t|Maybe $(typ)|]+ numberType Nothing = [t|Integer|]+ numberType (Just n)+ | n <= 0 = [t|Integer|]+ | otherwise = [t|Double|]++-- | 'Relation' to query 'DbaTabColumns' from owner name and table name.+columnsRelationFromTable :: Relation (String, String) DbaTabColumns+columnsRelationFromTable = relation' $ do+ cols <- query dbaTabColumns+ (owner, ()) <- placeholder $ \owner ->+ wheres $ cols ! Cols.owner' .=. owner+ (name, ()) <- placeholder $ \name ->+ wheres $ cols ! Cols.tableName' .=. name+ asc $ cols ! Cols.columnId'+ return (owner >< name, cols)++-- | Phantom typed 'Query' to get 'DbaTabColumns' from owner name and table name.+columnsQuerySQL :: Query (String, String) DbaTabColumns+columnsQuerySQL = relationalQuery columnsRelationFromTable++-- | 'Relation' to query primary key name from owner name and table name.+primaryKeyRelation :: Relation (String, String) (Maybe String)+primaryKeyRelation = relation' $ do+ cons <- query dbaConstraints+ cols <- query dbaTabColumns+ consCols <- query dbaConsColumns++ wheres $ cons ! Cons.owner' .=. just (cols ! Cols.owner')+ wheres $ cons ! Cons.tableName' .=. cols ! Cols.tableName'+ wheres $ consCols ! ConsCols.columnName' .=. just (cols ! Cols.columnName')+ wheres $ cons ! Cons.constraintName' .=. consCols ! ConsCols.constraintName'++ wheres $ cols ! Cols.nullable' .=. just (value "N")+ wheres $ cons ! Cons.constraintType' .=. just (value "P")++ (owner, ()) <- placeholder $ \owner ->+ wheres $ cons ! Cons.owner' .=. just owner+ (name, ()) <- placeholder $ \name ->+ wheres $ cons ! Cons.tableName' .=. name++ asc $ consCols ! ConsCols.position'++ return (owner >< name, consCols ! ConsCols.columnName')++-- | Phantom typed 'Query' to get primary key name from owner name and table name.+primaryKeyQuerySQL :: Query (String, String) (Maybe String)+primaryKeyQuerySQL = relationalQuery primaryKeyRelation
+ src/Database/Relational/Schema/OracleDataDictionary/Config.hs view
@@ -0,0 +1,16 @@+-- |+-- Module : Database.Relational.Schema.OracleDataDictionary.Config+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+module Database.Relational.Schema.OracleDataDictionary.Config (config) where++import Database.Relational.Query (Config, defaultConfig)+++-- | Configuration parameter against Oracle.+config :: Config+config = defaultConfig
+ src/Database/Relational/Schema/OracleDataDictionary/ConsColumns.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++module Database.Relational.Schema.OracleDataDictionary.ConsColumns where++import Data.Int (Int32)++import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.OracleDataDictionary.Config (config)+++$(defineTableTypesAndRecordDefault config+ "SYS" "dba_cons_columns"+ -- Column NULL? Datatype+ -- ----------------------------------------- -------- ----------------------------+ -- OWNER NOT NULL VARCHAR2(30)+ [ ("owner", [t|String|])+ -- CONSTRAINT_NAME NOT NULL VARCHAR2(30)+ , ("constraint_name", [t|String|])+ -- TABLE_NAME NOT NULL VARCHAR2(30)+ , ("table_name", [t|String|])+ -- COLUMN_NAME VARCHAR2(4000)+ , ("column_name", [t|Maybe String|])+ -- POSITION NUMBER+ , ("position", [t|Maybe Int32|])+ ] [derivingShow])
+ src/Database/Relational/Schema/OracleDataDictionary/Constraints.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++module Database.Relational.Schema.OracleDataDictionary.Constraints where++import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.OracleDataDictionary.Config (config)+++$(defineTableTypesAndRecordDefault config+ "SYS" "dba_constraints"+ -- Column NULL? Datatype+ -- ----------------------------------------- -------- ----------------------------+ -- OWNER VARCHAR2(30)+ [ ("owner", [t|Maybe String|])+ -- CONSTRAINT_NAME NOT NULL VARCHAR2(30)+ , ("constraint_name", [t|String|])+ -- CONSTRAINT_TYPE VARCHAR2(1)+ , ("constraint_type", [t|Maybe String|])+ -- TABLE_NAME NOT NULL VARCHAR2(30)+ , ("table_name", [t|String|])+ -- SEARCH_CONDITION LONG+ -- R_OWNER VARCHAR2(30)+ -- R_CONSTRAINT_NAME VARCHAR2(30)+ -- DELETE_RULE VARCHAR2(9)+ -- STATUS VARCHAR2(8)+ -- DEFERRABLE VARCHAR2(14)+ -- DEFERRED VARCHAR2(9)+ -- VALIDATED VARCHAR2(13)+ -- GENERATED VARCHAR2(14)+ -- BAD VARCHAR2(3)+ -- RELY VARCHAR2(4)+ -- LAST_CHANGE DATE+ -- INDEX_OWNER VARCHAR2(30)+ -- INDEX_NAME VARCHAR2(30)+ -- INVALID VARCHAR2(7)+ -- VIEW_RELATED VARCHAR2(14)+ ] [derivingShow])
+ src/Database/Relational/Schema/OracleDataDictionary/TabColumns.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++module Database.Relational.Schema.OracleDataDictionary.TabColumns where++import Data.Int (Int32)+-- import Data.ByteString (ByteString)+-- import Data.Time.Calendar (Day)++import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.OracleDataDictionary.Config (config)+++$(defineTableTypesAndRecordDefault config+ "SYS" "dba_tab_columns"+ -- Column NULL? Datatype+ -- ----------------------------------------- -------- ----------------------------+ -- OWNER NOT NULL VARCHAR2(30)+ [ ("owner", [t|String|])+ -- TABLE_NAME NOT NULL VARCHAR2(30)+ , ("table_name", [t|String|])+ -- COLUMN_NAME NOT NULL VARCHAR2(30)+ , ("column_name", [t|String|])+ -- DATA_TYPE VARCHAR2(106)+ , ("data_type", [t|Maybe String|])+ -- DATA_TYPE_MOD VARCHAR2(3)+ , ("data_type_mod", [t|Maybe String|])+ -- DATA_TYPE_OWNER VARCHAR2(30)+ , ("data_type_owner", [t|Maybe String|])+ -- DATA_LENGTH NOT NULL NUMBER+ , ("data_length", [t|Int32|])+ -- DATA_PRECISION NUMBER+ , ("data_precision", [t|Maybe Int32|])+ -- DATA_SCALE NUMBER+ , ("data_scale", [t|Maybe Int32|])+ -- NULLABLE VARCHAR2(1)+ , ("nullable", [t|Maybe String|])+ -- COLUMN_ID NUMBER+ , ("column_id", [t|Maybe Int32|])+ -- DEFAULT_LENGTH NUMBER+ , ("default_length", [t|Maybe Int32|])+ -- DATA_DEFAULT LONG+ , ("data_default", [t|Maybe String|])+ -- NUM_DISTINCT NUMBER+ , ("num_distinct", [t|Maybe Int32|])+ -- LOW_VALUE RAW(32)+ -- , ("low_value", [t|Maybe ByteString|])+ -- HIGH_VALUE RAW(32)+ -- , ("high_value", [t|Maybe ByteString|])+ -- DENSITY NUMBER+ , ("density", [t|Maybe Int32|])+ -- NUM_NULLS NUMBER+ , ("num_nulls", [t|Maybe Int32|])+ -- NUM_BUCKETS NUMBER+ , ("num_buckets", [t|Maybe Int32|])+ -- LAST_ANALYZED DATE+ -- , ("last_analyzed", [t|Maybe Day|])+ -- SAMPLE_SIZE NUMBER+ , ("sample_size", [t|Maybe Int32|])+ -- CHARACTER_SET_NAME VARCHAR2(44)+ , ("character_set_name", [t|Maybe String|])+ -- CHAR_COL_DECL_LENGTH NUMBER+ , ("char_col_decl_length", [t|Maybe Int32|])+ -- GLOBAL_STATS VARCHAR2(3)+ , ("global_stats", [t|Maybe String|])+ -- USER_STATS VARCHAR2(3)+ , ("user_stats", [t|Maybe String|])+ -- AVG_COL_LEN NUMBER+ , ("avg_col_len", [t|Maybe Int32|])+ -- CHAR_LENGTH NUMBER+ , ("char_length", [t|Maybe Int32|])+ -- CHAR_USED VARCHAR2(1)+ , ("char_used", [t|Maybe String|])+ -- V80_FMT_IMAGE VARCHAR2(3)+ , ("v80_fmt_image", [t|Maybe String|])+ -- DATA_UPGRADED VARCHAR2(3)+ , ("data_upgraded", [t|Maybe String|])+ -- HISTOGRAM VARCHAR2(15)+ , ("histogram", [t|Maybe String|])+ ] [derivingShow])
+ src/Database/Relational/Schema/PgCatalog/Config.hs view
@@ -0,0 +1,16 @@+-- |+-- Module : Database.Relational.Schema.PgCatalog.Config+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+module Database.Relational.Schema.PgCatalog.Config (config) where++import Database.Relational.Query (Config, defaultConfig)+++-- | Configuration parameter against PostgreSQL.+config :: Config+config = defaultConfig
+ src/Database/Relational/Schema/PgCatalog/PgAttribute.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module : Database.HDBC.Schema.PgCatalog.PgAttribute+-- Copyright : 2013 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+module Database.Relational.Schema.PgCatalog.PgAttribute where++import Data.Int (Int16, Int32)++import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.PgCatalog.Config (config)+++$(defineTableTypesAndRecordDefault config+ "PG_CATALOG" "pg_attribute"++ [+-- Table "pg_catalog.pg_attribute"+-- Column | Type | Modifiers+-- ---------------+-----------+-----------+-- attrelid | oid | not null+ ("attrelid" , [t|Int32|]),+-- attname | name | not null+ ("attname" , [t|String|]),+-- atttypid | oid | not null+ ("atttypid" , [t|Int32|]),+-- attstattarget | integer | not null+ ("attstattarget", [t|Int32|]),+-- attlen | smallint | not null+ ("attlen" , [t|Int16|]),+-- attnum | smallint | not null+ ("attnum" , [t|Int16|]),+-- attndims | integer | not null+ ("attndims" , [t|Int32|]),+-- attcacheoff | integer | not null+ ("attcacheoff" , [t|Int32|]),+-- atttypmod | integer | not null+ ("atttypmod" , [t|Int32|]),+-- attbyval | boolean | not null+ ("attbyval" , [t|Bool|]),+-- attstorage | "char" | not null+ ("attstorage" , [t|Char|]),+-- attalign | "char" | not null+ ("attalign" , [t|Char|]),+-- attnotnull | boolean | not null+ ("attnotnull" , [t|Bool|]),+-- atthasdef | boolean | not null+ ("atthasdef" , [t|Bool|]),+-- attisdropped | boolean | not null+ ("attisdropped", [t|Bool|]),+-- attislocal | boolean | not null+ ("attislocal" , [t|Bool|]),+-- attinhcount | integer | not null+ ("attinhcount" , [t|Int32|]),+-- attcollation | oid | not null+ ("attcollation", [t|Int32|])+-- attacl | aclitem[] |+ -- ("attacl" , [t|String|]),+-- attoptions | text[] |+ -- ("attoptions" , [t|String|])+ ]+ [derivingShow])
+ src/Database/Relational/Schema/PgCatalog/PgClass.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module : Database.Relational.Schema.PgCatalog.PgClass+-- Copyright : 2013 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+module Database.Relational.Schema.PgCatalog.PgClass where++import Data.Int (Int32)++import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.PgCatalog.Config (config)+++$(defineTableTypesAndRecordDefault config+ "PG_CATALOG" "pg_class"+ [("oid" , [t| Int32 |]),+ -- relname | name | not null+ ("relname" , [t| String |]),+ -- relnamespace | oid | not null+ ("relnamespace", [t| Int32 |])+ -- reltype | oid | not null+ -- reloftype | oid | not null+ -- relowner | oid | not null+ -- relam | oid | not null+ -- relfilenode | oid | not null+ -- reltablespace | oid | not null+ -- relpages | integer | not null+ -- reltuples | real | not null+ -- reltoastrelid | oid | not null+ -- reltoastidxid | oid | not null+ -- relhasindex | boolean | not null+ -- relisshared | boolean | not null+ -- relpersistence | "char" | not null+ -- relkind | "char" | not null+ -- relnatts | smallint | not null+ -- relchecks | smallint | not null+ -- relhasoids | boolean | not null+ -- relhaspkey | boolean | not null+ -- relhasrules | boolean | not null+ -- relhastriggers | boolean | not null+ -- relhassubclass | boolean | not null+ -- relfrozenxid | xid | not null+ -- relacl | aclitem[] |+ -- reloptions | text[] |+ ]+ [derivingShow])
+ src/Database/Relational/Schema/PgCatalog/PgConstraint.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module : Database.Relational.Schema.PgCatalog.PgConstraint+-- Copyright : 2013 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+module Database.Relational.Schema.PgCatalog.PgConstraint where++import Data.Int (Int32)++import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.PgCatalog.Config (config)+++$(defineTableTypesAndRecordDefault config+ "PG_CATALOG" "pg_constraint"+ [ -- ("oid" , [t| Int32 |]),+ -- conname | name | not null+ -- connamespace | oid | not null+ -- contype | "char" | not null+ ("contype", [t| Char |]),+ -- condeferrable | boolean | not null+ -- condeferred | boolean | not null+ -- convalidated | boolean | not null+ -- conrelid | oid | not null+ ("conrelid", [t| Int32 |])+ -- contypid | oid | not null+ -- conindid | oid | not null+ -- confrelid | oid | not null+ -- confupdtype | "char" | not null+ -- confdeltype | "char" | not null+ -- confmatchtype | "char" | not null+ -- conislocal | boolean | not null+ -- coninhcount | integer | not null+ -- conkey | smallint[] |+ -- ("conkey", ???),+ -- confkey | smallint[] |+ -- conpfeqop | oid[] |+ -- conppeqop | oid[] |+ -- conffeqop | oid[] |+ -- conexclop | oid[] |+ -- conbin | pg_node_tree |+ -- consrc | text |+ ]+ [derivingShow])
+ src/Database/Relational/Schema/PgCatalog/PgNamespace.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module : Database.Relational.Schema.PgCatalog.PgNamespace+-- Copyright : 2013 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+module Database.Relational.Schema.PgCatalog.PgNamespace where++import Data.Int (Int32)++import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.PgCatalog.Config (config)+++$(defineTableTypesAndRecordDefault config+ "PG_CATALOG" "pg_namespace"+ [("oid" , [t| Int32 |]),+ -- nspname | name | not null+ ("nspname", [t| String |])+ -- nspowner | oid | not null+ -- nspacl | aclitem[] |+ ]+ [derivingShow])
+ src/Database/Relational/Schema/PgCatalog/PgType.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module : Database.Relational.Schema.PgCatalog.PgType+-- Copyright : 2013 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+module Database.Relational.Schema.PgCatalog.PgType where++import Data.Int (Int16, Int32)++import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.PgCatalog.Config (config)+++$(defineTableTypesAndRecordDefault config+ "PG_CATALOG" "pg_type"++ [+ ("oid", [t|Int32|]),+-- Table "pg_catalog.pg_type"+-- Column | Type | Modifiers+-- ----------------+--------------+-----------+-- typname | name | not null+ ("typname", [t|String|]),+-- typnamespace | oid | not null+ ("typnamespace", [t|Int32|]),+-- typowner | oid | not null+ ("typowner", [t|Int32|]),+-- typlen | smallint | not null+ ("typlen", [t|Int16|]),+-- typbyval | boolean | not null+ ("typbyval", [t|Bool|]),+-- typtype | "char" | not null+ ("typtype", [t|Char|]),+-- typcategory | "char" | not null+ ("typcategory", [t|Char|]),+-- typispreferred | boolean | not null+ ("typispreferred", [t|Bool|]),+-- typisdefined | boolean | not null+ ("typisdefined", [t|Bool|]),+-- typdelim | "char" | not null+ ("typdelim", [t|Char|]),+-- typrelid | oid | not null+ ("typrelid", [t|Int32|]),+-- typelem | oid | not null+ ("typelem", [t|Int32|]),+-- typarray | oid | not null+ ("typarray", [t|Int32|]),+-- typinput | regproc | not null+ -- ("typinput", [t||]),+-- typoutput | regproc | not null+ -- ("typoutput", [t||]),+-- typreceive | regproc | not null+ -- ("typreceive", [t||]),+-- typsend | regproc | not null+ -- ("typsend", [t||]),+-- typmodin | regproc | not null+ -- ("typmodin", [t||]),+-- typmodout | regproc | not null+ -- ("typmodout", [t||]),+-- typanalyze | regproc | not null+ -- ("typanalyze", [t||]),+-- typalign | "char" | not null+ ("typalign", [t|Char|]),+-- typstorage | "char" | not null+ ("typstorage", [t|Char|]),+-- typnotnull | boolean | not null+ ("typnotnull", [t|Bool|]),+-- typbasetype | oid | not null+ ("typbasetype", [t|Int32|]),+-- typtypmod | integer | not null+ ("typtypmod", [t|Int32|]),+-- typndims | integer | not null+ ("typndims", [t|Int32|]),+-- typcollation | oid | not null+ ("typcollation", [t|Int32|]),+-- typdefaultbin | pg_node_tree |+ -- ("typdefaultbin", [t||]),+-- typdefault | text |+ ("typdefault", [t|Maybe String|])+ ]+ [derivingShow])
+ src/Database/Relational/Schema/PostgreSQL.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module : Database.Relational.Schema.PostgreSQL+-- Copyright : 2013 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+--+-- This module implements queries to get+-- table schema and table constraint informations+-- from system catalog of PostgreSQL.+module Database.Relational.Schema.PostgreSQL (+ Column,++ normalizeColumn, notNull, getType,++ columnQuerySQL,+ primaryKeyLengthQuerySQL, primaryKeyQuerySQL+ ) where++import Prelude hiding (or)++import Language.Haskell.TH (TypeQ)++import Data.Int (Int16, Int32, Int64)+import Data.Char (toLower)+import Data.List (foldl1')+import Data.Map (Map, fromList)+import qualified Data.Map as Map+import Data.Time+ (DiffTime, NominalDiffTime,+ LocalTime, ZonedTime, Day, TimeOfDay)++import Database.Relational.Query.Type (relationalQuery)+import Database.Relational.Query+ (Query, Relation, query, query', relation', relation, union,+ wheres, (.=.), (.>.), in', values, (!), fst', snd',+ placeholder, asc, value, unsafeProjectSql, (><))++import Database.Relational.Schema.PgCatalog.PgNamespace (pgNamespace)+import qualified Database.Relational.Schema.PgCatalog.PgNamespace as Namespace+import Database.Relational.Schema.PgCatalog.PgClass (pgClass)+import qualified Database.Relational.Schema.PgCatalog.PgClass as Class+import Database.Relational.Schema.PgCatalog.PgConstraint (PgConstraint, pgConstraint)+import qualified Database.Relational.Schema.PgCatalog.PgConstraint as Constraint++import Database.Relational.Schema.PgCatalog.PgAttribute (PgAttribute, pgAttribute)+import qualified Database.Relational.Schema.PgCatalog.PgAttribute as Attr+import Database.Relational.Schema.PgCatalog.PgType (PgType(..), pgType)+import qualified Database.Relational.Schema.PgCatalog.PgType as Type++import Control.Applicative ((<|>))+++-- | Mapping between type in PostgreSQL and Haskell type.+mapFromSqlDefault :: Map String TypeQ+mapFromSqlDefault =+ fromList [("bool", [t| Bool |]),+ ("char", [t| Char |]),+ ("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 |])+ ]++-- | Normalize column name string to query PostgreSQL system catalog.+normalizeColumn :: String -> String+normalizeColumn = map toLower++-- | Type to represent Column information.+type Column = (PgAttribute, PgType)++-- | Not-null attribute information of column.+notNull :: Column -> Bool+notNull = Attr.attnotnull . fst++-- | Get column normalized name and column Haskell type.+getType :: Map String TypeQ -- ^ Type mapping specified by user+ -> Column -- ^ Column info in system catalog+ -> Maybe (String, TypeQ) -- ^ Result normalized name and mapped Haskell type+getType mapFromSql column@(pgAttr, pgTyp) = do+ typ <- (Map.lookup key mapFromSql+ <|>+ Map.lookup key mapFromSqlDefault)+ return (normalizeColumn $ Attr.attname pgAttr,+ mayNull typ)+ where key = Type.typname pgTyp+ mayNull typ = if notNull column+ then typ+ else [t| Maybe $typ |]++-- | 'Relation' to query PostgreSQL relation oid from schema name and table name.+relOidRelation :: Relation (String, String) Int32+relOidRelation = relation' $ do+ nsp <- query pgNamespace+ cls <- query pgClass++ wheres $ cls ! Class.relnamespace' .=. nsp ! Namespace.oid'+ (nspP, ()) <- placeholder (\ph -> wheres $ nsp ! Namespace.nspname' .=. ph)+ (relP, ()) <- placeholder (\ph -> wheres $ cls ! Class.relname' .=. ph)++ return (nspP >< relP, cls ! Class.oid')++-- | 'Relation' to query column attribute from schema name and table name.+attributeRelation :: Relation (String, String) PgAttribute+attributeRelation = relation' $ do+ (ph, reloid) <- query' relOidRelation+ att <- query pgAttribute++ wheres $ att ! Attr.attrelid' .=. reloid+ wheres $ att ! Attr.attnum' .>. value 0++ return (ph, att)++-- | 'Relation' to query 'Column' from schema name and table name.+columnRelation :: Relation (String, String) Column+columnRelation = relation' $ do+ (ph, att) <- query' attributeRelation+ typ <- query pgType++ wheres $ att ! Attr.atttypid' .=. typ ! Type.oid'+ wheres $ typ ! Type.typtype' .=. value 'b' -- 'b': base type only++ wheres $ typ ! Type.typcategory' `in'` values [ 'B' -- Boolean types+ , 'D' -- Date/time types+ , 'N' -- Numeric types+ , 'S' -- String types+ , 'T' -- typespan types+ ]++ asc $ att ! Attr.attnum'++ return (ph, att >< typ)++-- | Phantom typed 'Query' to get 'Column' from schema name and table name.+columnQuerySQL :: Query (String, String) Column+columnQuerySQL = relationalQuery columnRelation++-- | 'Relation' to query primary key length from schema name and table name.+primaryKeyLengthRelation :: Relation (String, String) Int32+primaryKeyLengthRelation = relation' $ do+ (ph, reloid) <- query' relOidRelation+ con <- query pgConstraint++ wheres $ con ! Constraint.conrelid' .=. reloid+ wheres $ con ! Constraint.contype' .=. value 'p' -- 'p': primary key constraint type++ return (ph, unsafeProjectSql "array_length (conkey, 1)")++-- | Phantom typed 'Query' to get primary key length from schema name and table name.+primaryKeyLengthQuerySQL :: Query (String, String) Int32+primaryKeyLengthQuerySQL = relationalQuery primaryKeyLengthRelation++-- | One column which is nth column of composite primary key.+constraintColRelation :: Int32 -> Relation () (PgConstraint, (Int16, Int32))+constraintColRelation i = relation $ do+ con <- query pgConstraint++ return $ con >< (unsafeProjectSql ("conkey[" ++ show i ++ "]") >< value i)++-- | Make composite primary key relation from primary key length.+constraintColExpandRelation :: Int32 -> Relation () (PgConstraint, (Int16, Int32))+constraintColExpandRelation n =+ foldl1' union [constraintColRelation i | i <- [1..n] ]++-- | 'Relation' to query primary key name from schema name and table name.+primaryKeyRelation :: Int32 -> Relation (String, String) String+primaryKeyRelation n = relation' $ do+ (ph, att) <- query' attributeRelation+ conEx <- query (constraintColExpandRelation n)++ let con = conEx ! fst'+ col' = conEx ! snd'+ keyIx = col' ! fst'+ keyN = col' ! snd'++ wheres $ con ! Constraint.conrelid' .=. att ! Attr.attrelid'+ wheres $ keyIx .=. att ! Attr.attnum'+ wheres $ con ! Constraint.contype' .=. value 'p' -- 'p': primary key constraint type++ asc $ keyN++ return (ph, att ! Attr.attname')++-- | Phantom typed 'Query' to get primary key name from schema name and table name.+primaryKeyQuerySQL :: Int32 -> Query (String, String) String+primaryKeyQuerySQL = relationalQuery . primaryKeyRelation
+ src/Database/Relational/Schema/SQLServer.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.Relational.Schema.SQLServer (+ getType, normalizeColumn, notNull,+ columnTypeQuerySQL, primaryKeyQuerySQL+ ) where++import qualified Data.Map as Map+import qualified Database.Relational.Schema.SQLServerSyscat.Columns as Columns+import qualified Database.Relational.Schema.SQLServerSyscat.Indexes as Indexes+import qualified Database.Relational.Schema.SQLServerSyscat.IndexColumns as IndexColumns+import qualified Database.Relational.Schema.SQLServerSyscat.Types as Types++import Control.Applicative ((<|>))+import Data.ByteString (ByteString)+import Data.Char (toLower)+import Data.Int (Int32, Int64)+import Data.Map (Map)+import Data.Time (LocalTime, Day, TimeOfDay)+import Database.Record.Instances ()+import Database.Relational.Query (Query, Relation, PlaceHolders, Projection, Flat,+ (!), (.=.), (><), asc, relationalQuery, just, placeholder',+ query, relation', unsafeShowSql, unsafeShowSqlProjection,+ unsafeProjectSql, wheres)+import Database.Relational.Schema.SQLServerSyscat.Columns+import Database.Relational.Schema.SQLServerSyscat.Indexes+import Database.Relational.Schema.SQLServerSyscat.IndexColumns+import Database.Relational.Schema.SQLServerSyscat.Types+import Language.Haskell.TH (TypeQ)++--{-# ANN module "HLint: ignore Redundant $" #-}++mapFromSqlDefault :: Map String TypeQ+mapFromSqlDefault =+ Map.fromList [ ("image", [t|ByteString|])+ , ("text", [t|ByteString|])+ , ("date", [t|Day|])+ , ("time", [t|TimeOfDay|])+ , ("tinyint", [t|Int32|])+ , ("smallint", [t|Int32|])+ , ("int", [t|Int32|])+ , ("smalldatetime", [t|LocalTime|])+ , ("real", [t|Double|])+ , ("datetime", [t|LocalTime|])+ , ("float", [t|Double|])+ , ("ntext", [t|String|])+ , ("bit", [t|Char|])+ , ("bigint", [t|Int64|])+ , ("varbinary", [t|String|])+ , ("varchar", [t|String|])+ , ("binary", [t|ByteString|])+ , ("char", [t|String|])+ , ("timestamp", [t|LocalTime|])+ , ("nvarchar", [t|String|])+ , ("nchar", [t|String|])+ ]++normalizeColumn :: String -> String+normalizeColumn = map toLower++notNull :: ((Columns,Types),String) -> Bool+notNull ((cols,_),_) = isTrue . Columns.isNullable $ cols+ where+ isTrue (Just b) = not b+ isTrue _ = True++getType :: Map String TypeQ -> ((Columns,Types),String) -> Maybe (String, TypeQ)+getType mapFromSql rec@((cols,typs),typScms) = do+ colName <- Columns.name cols+ typ <- Map.lookup key mapFromSql+ <|>+ Map.lookup key mapFromSqlDefault+ return (normalizeColumn colName, mayNull typ)+ where+ key = if typScms == "sys"+ then Types.name typs+ else typScms ++ "." ++ Types.name typs+ mayNull typ = if notNull rec+ then typ+ else [t|Maybe $(typ)|]++sqlsrvTrue :: Projection Flat Bool+sqlsrvTrue = unsafeProjectSql "1"++sqlsrvObjectId :: Projection Flat String -> Projection Flat String -> Projection Flat Int32+sqlsrvObjectId s t = unsafeProjectSql $+ "OBJECT_ID(" ++ unsafeShowSql s ++ " + '.' + " ++ unsafeShowSql t ++ ")"++sqlsrvOidPlaceHolder :: (PlaceHolders (String, String), Projection Flat Int32)+sqlsrvOidPlaceHolder = (nsParam >< relParam, oid)+ where+ (nsParam, (relParam, oid)) =+ placeholder' (\nsPh ->+ placeholder' (\relPh ->+ sqlsrvObjectId nsPh relPh))++columnTypeRelation :: Relation (String,String) ((Columns,Types),String)+columnTypeRelation = relation' $ do+ cols <- query columns+ typs <- query types++ wheres $ cols ! Columns.userTypeId' .=. typs ! Types.userTypeId'+ wheres $ cols ! Columns.objectId' .=. oid+ asc $ cols ! Columns.columnId'+ return (params, cols >< typs >< sqlsrvSchemaName (typs ! Types.schemaId'))+ where+ (params, oid) = sqlsrvOidPlaceHolder+ sqlsrvSchemaName i = unsafeProjectSql $+ "SCHEMA_NAME(" ++ unsafeShowSqlProjection i ++ ")"++columnTypeQuerySQL :: Query (String, String) ((Columns, Types), String)+columnTypeQuerySQL = relationalQuery columnTypeRelation++primaryKeyRelation :: Relation (String,String) (Maybe String)+primaryKeyRelation = relation' $ do+ idxes <- query indexes+ idxcol <- query indexColumns+ cols <- query columns+ wheres $ idxes ! Indexes.objectId' .=. idxcol ! IndexColumns.objectId'+ wheres $ idxes ! Indexes.indexId' .=. idxcol ! IndexColumns.indexId'+ wheres $ idxcol ! IndexColumns.objectId' .=. cols ! Columns.objectId'+ wheres $ idxcol ! IndexColumns.columnId' .=. cols ! Columns.columnId'+ wheres $ idxes ! Indexes.isPrimaryKey' .=. just sqlsrvTrue+ let (params, oid) = sqlsrvOidPlaceHolder+ wheres $ idxes ! Indexes.objectId' .=. oid+ asc $ idxcol ! IndexColumns.keyOrdinal'+ return (params, cols ! Columns.name')++primaryKeyQuerySQL :: Query (String,String) (Maybe String)+primaryKeyQuerySQL = relationalQuery primaryKeyRelation
+ src/Database/Relational/Schema/SQLServerSyscat/Columns.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++module Database.Relational.Schema.SQLServerSyscat.Columns where++import Data.Int (Int32)+import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.SQLServerSyscat.Config (config)+++$(defineTableTypesAndRecordDefault config+ "sys" "columns"+ [+ -- column schema type length NULL+ -- --------------------- ------- ------------------- -------- ------+ -- object_id sys int 4 No+ ("object_id", [t|Int32|]),+ -- name sys sysname(nvarchar) 128 Yes+ ("name", [t|Maybe String|]),+ -- column_id sys int 4 No+ ("column_id", [t|Int32|]),+ -- system_type_id sys tinyint 1 No+ --("system_type_id", [t|Int32|]),+ -- user_type_id sys int 4 No+ ("user_type_id", [t|Int32|]),+ -- max_length sys smallint 2 No+ --("max_length", [t|Int32|]),+ -- precision sys tinyint 1 No+ --("precision", [t|Int32|]),+ -- scale sys tinyint 1 No+ --("scale", [t|Int32|]),+ -- collation_name sys sysname(nvarchar) 128 Yes+ --("collation_name", [t|Maybe String|]),+ -- is_nullable sys bit 1 Yes+ ("is_nullable", [t|Maybe Bool|])--,+ -- is_ansi_padded sys bit 1 No+ --("is_ansi_padded", [t|Bool|]),+ -- is_rowguidcol sys bit 1 No+ --("is_rowguidcol", [t|Bool|]),+ -- is_identity sys bit 1 No+ --("is_identity", [t|Bool|]),+ -- is_computed sys bit 1 No+ --("is_computed", [t|Bool|]),+ -- is_filestream sys bit 1 No+ --("is_filestream", [t|Bool|]),+ -- is_replicated sys bit 1 Yes+ --("is_replicated", [t|Maybe Bool|]),+ -- is_non_sql_subscribed sys bit 1 Yes+ --("is_non_sql_subscribed", [t|Maybe Bool|]),+ -- is_merge_published sys bit 1 Yes+ --("is_merge_published", [t|Maybe Bool|]),+ -- is_dts_repllicated sys bit 1 Yes+ --("is_dts_replicated", [t|Maybe Bool|]),+ -- is_xml_document sys bit 1 No+ --("is_xml_document", [t|Bool|]),+ -- xml_collection_id sys int 4 No+ --("xml_collection_id", [t|Int32|]),+ -- default_object_id sys int 4 No+ --("default_object_id", [t|Int32|]),+ -- rule_object_id sys int 4 No+ --("rule_object_id", [t|Int32|]),+ -- is_sparse sys bit 1 Yes+ --("is_sparse", [t|Maybe Bool|]),+ -- is_column_set sys bit 1 Yes+ --("is_column_set", [t|Maybe Bool|])+ ]+ [derivingShow])
+ src/Database/Relational/Schema/SQLServerSyscat/Config.hs view
@@ -0,0 +1,16 @@+-- |+-- Module : Database.Relational.Schema.PgCatalog.Config+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+module Database.Relational.Schema.SQLServerSyscat.Config (config) where++import Database.Relational.Query (Config, defaultConfig)+++-- | Configuration parameter against SQLServer.+config :: Config+config = defaultConfig
+ src/Database/Relational/Schema/SQLServerSyscat/IndexColumns.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++module Database.Relational.Schema.SQLServerSyscat.IndexColumns where++import Data.Int (Int32)+import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.SQLServerSyscat.Config (config)+++$(defineTableTypesAndRecordDefault config+ "sys" "index_columns"+ [+ -- column schema type length NULL+ -- --------------------- ------- ------------------- -------- ------+ -- object_id sys int 4 No+ ("object_id", [t|Int32|]),+ -- index_id sys int 4 No+ ("index_id", [t|Int32|]),+ -- index_column_id sys int 4 No+ ("column_id", [t|Int32|]),+ -- key_ordinal sys tinyint 1 No+ ("key_ordinal", [t|Int32|]),+ -- partition_ordinal sys tinyint 1 No+ --("partition_ordinal", [t|Int32|]),+ -- is_descending_key sys bit 1 No+ --("is_descending_key", [t|Bool|]),+ -- is_included_column sys bit 1 No+ ("is_included_column", [t|Bool|])+ ]+ [derivingShow])
+ src/Database/Relational/Schema/SQLServerSyscat/Indexes.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++module Database.Relational.Schema.SQLServerSyscat.Indexes where++--import Data.ByteString (ByteString)+import Data.Int (Int32)+import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.SQLServerSyscat.Config (config)+++$(defineTableTypesAndRecordDefault config+ "sys" "indexes"+ [+-- View "sys.indexes"+-- column schema type length NULL+-- --------------------- ------- ------------------- -------- ------+-- object_id sys int 4 No+ ("object_id", [t|Int32|]),+-- name sys sysname(nvarchar) 128 Yes+ --("name", [t|Maybe String|]),+-- index_id sys int 4 No+ ("index_id", [t|Int32|]),+-- type sys tinyint 1 No+ --("type", [t|Char|]),+-- type_desc sys nvarchar 60 Yes+ --("type_desc", [t|Maybe String|]),+-- is_unique sys bit 1 Yes+ --("is_unique", [t|Maybe Bool|]),+-- data_space_id sys int 4 No+ --("data_space_id", [t|Int32|]),+-- ignore_dup_key sys bit 1 Yes+ --("ignore_dup_key", [t|Maybe Bool|]),+-- is_primary_key sys bit 1 Yes+ ("is_primary_key", [t|Maybe Bool|])--,+-- is_unique_constraint sys bit 1 Yes+ --("is_unique_constraint", [t|Maybe Bool|]),+-- fill_factor sys tinyint 1 No+ --("fill_factor", [t|Int32|]),+-- is_padded sys bit 1 Yes+ --("is_padded", [t|Maybe Bool|]),+-- is_disabled sys bit 1 Yes+ --("is_disabled", [t|Maybe Bool|]),+-- is_hypothetical sys bit 1 Yes+ --("is_hypothetical", [t|Maybe Bool|]),+-- allow_row_locks sys bit 1 Yes+ --("allow_row_locks", [t|Maybe Bool|]),+-- allow_page_locks sys bit 1 Yes+ --("allow_page_locks", [t|Maybe Bool|]),+-- has_filter sys bit 1 Yes+ --("has_filter", [t|Maybe Bool|]),+-- filter_definition sys nvarchar max Yes+ --("filter_definition", [t|Maybe ByteString|])+ ]+ [derivingShow])
+ src/Database/Relational/Schema/SQLServerSyscat/Types.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++module Database.Relational.Schema.SQLServerSyscat.Types where++import Data.Int (Int32)+import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.SQLServerSyscat.Config (config)+++$(defineTableTypesAndRecordDefault config+ "sys" "types"+ [+-- View "sys.types"+-- column schema type length NULL+-- --------------------- ------- ------------------- -------- ------+-- name sys sysname(nvarchar) 128 No+ ("name", [t|String|]),+-- system_type_id sys tinyint 1 No+ --("system_type_id", [t|Int32|]),+-- user_type_id sys int 4 No+ ("user_type_id", [t|Int32|]),+-- schema_id sys int 4 No+ ("schema_id", [t|Int32|])--,+-- principal_id sys int 4 Yes+ --("principal_id", [t|Maybe Int32|]),+-- max_length sys int 4 No+ --("max_length", [t|Int32|]),+-- precision sys tinyint 1 No+ --("precision", [t|Int32|]),+-- scale sys tinyint 1 No+ --("scale", [t|Int32|]),+-- collation_name sys sysname(nvarchar) 128 Yes+ --("collation_name", [t|Maybe String|]),+-- is_nullable sys bit 1 Yes+ --("is_nullable", [t|Maybe Bool|]),+-- is_user_defined sys bit 1 No+ --("is_user_defined", [t|Bool|]),+-- is_assembly_type sys bit 1 No+ --("is_assembly_type", [t|Bool|]),+-- default_object_id sys int 4 No+ --("default_object_id", [t|Int32|]),+-- rule_object_id sys int 4 No+ --("rule_object_id", [t|Int32|]),+-- is_table_type sys bit 1 No+ --("is_table_type", [t|Bool|])+ ]+ [derivingShow])
+ src/Database/Relational/Schema/SQLite3.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE TemplateHaskell #-}++module Database.Relational.Schema.SQLite3 (+ getType, normalizeColumn, normalizeType, notNull,+ tableInfoQuerySQL, indexListQuerySQL, indexInfoQuerySQL+ ) where++import qualified Data.Map as Map+import qualified Database.Relational.Schema.SQLite3Syscat.TableInfo as TableInfo++import Control.Applicative ((<|>))+import Data.ByteString (ByteString)+import Data.Char (toLower)+import Data.Int (Int64)+import Data.Map (Map)+import Database.Record.Instances ()+import Database.Relational.Query (Query)+import Database.Relational.Query.Type (unsafeTypedQuery)+import Database.Relational.Schema.SQLite3Syscat.IndexInfo+import Database.Relational.Schema.SQLite3Syscat.IndexList+import Database.Relational.Schema.SQLite3Syscat.TableInfo+import Language.Haskell.TH (TypeQ)++--{-# ANN module "HLint: ignore Redundant $" #-}++mapFromSqlDefault :: Map String TypeQ+mapFromSqlDefault =+ Map.fromList [ ("integer", [t|Int64|])+ , ("real", [t|Double|])+ , ("text", [t|String|])+ , ("blob", [t|ByteString|])+ ]++normalizeColumn :: String -> String+normalizeColumn = map toLower++normalizeType :: String -> String+normalizeType = normalizeColumn . takeWhile (not . flip elem " (")++notNull :: TableInfo -> Bool+notNull info = isTrue . TableInfo.notnull $ info+ where+ isTrue 1 = True+ isTrue _ = False++getType :: Map String TypeQ -> TableInfo -> Maybe (String, TypeQ)+getType mapFromSql info = do+ typ <- Map.lookup key mapFromSql+ <|>+ Map.lookup key mapFromSqlDefault+ return (normalizeColumn (TableInfo.name info), mayNull typ)+ where+ key = normalizeType . TableInfo.ctype $ info+ mayNull typ = if notNull info+ then typ+ else [t|Maybe $(typ)|]++tableInfoQuerySQL :: String -> String -> Query () TableInfo+tableInfoQuerySQL db tbl = unsafeTypedQuery $ "pragma " ++ db ++ ".table_info(" ++ tbl ++ ");"++indexListQuerySQL :: String -> String -> Query () IndexList+indexListQuerySQL db tbl = unsafeTypedQuery $ "pragma " ++ db ++ ".index_list(" ++ tbl ++ ");"++indexInfoQuerySQL :: String -> String -> Query () IndexInfo+indexInfoQuerySQL db idx = unsafeTypedQuery $ "pragma " ++ db ++ ".index_info(" ++ idx ++ ");"
+ src/Database/Relational/Schema/SQLite3Syscat/Config.hs view
@@ -0,0 +1,16 @@+-- |+-- Module : Database.Relational.Schema.SQLite3Syscat.Config+-- Copyright : 2014 Kei Hibino+-- License : BSD3+--+-- Maintainer : ex8k.hibino@gmail.com+-- Stability : experimental+-- Portability : unknown+module Database.Relational.Schema.SQLite3Syscat.Config (config) where++import Database.Relational.Query (Config, defaultConfig)+++-- | Configuration parameter against SQLite3.+config :: Config+config = defaultConfig
+ src/Database/Relational/Schema/SQLite3Syscat/IndexInfo.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++module Database.Relational.Schema.SQLite3Syscat.IndexInfo where++import Data.Int (Int64)+import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.SQLite3Syscat.Config (config)+++$(defineTableTypesAndRecordDefault config+ "pragma" "index_info"+ [+-- pragma "index_info"+-- column type NULL+-- --------------------- ------------------- ------+-- seqno integer No+ ("seqno", [t|Int64|]),+-- cid integer No+ ("cid", [t|Int64|]),+-- name text No+ ("name", [t|String|])+ ]+ [derivingShow])
+ src/Database/Relational/Schema/SQLite3Syscat/IndexList.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++module Database.Relational.Schema.SQLite3Syscat.IndexList where++import Data.Int (Int64)+import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.SQLite3Syscat.Config (config)+++$(defineTableTypesAndRecordDefault config+ "pragma" "index_list"+ [+-- pragma "main.index_list"+-- column type NULL+-- --------------------- ------------------- ------+-- seq integer No+ ("seq", [t|Int64|]),+-- name text No+ ("name", [t|String|]),+-- unique integer No+ ("unique", [t|Int64|])+ ]+ [derivingShow])
+ src/Database/Relational/Schema/SQLite3Syscat/TableInfo.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++module Database.Relational.Schema.SQLite3Syscat.TableInfo where++import Data.Int (Int16, Int64)+import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.SQLite3Syscat.Config (config)+++$(defineTableTypesAndRecordDefault config+ "pragma" "table_info"+ [+-- View "main.sqlite_master"+-- column type NULL+-- --------------------- ------------------- ------+-- cid integer No+ ("cid", [t|Int64|]),+-- name text No+ ("name", [t|String|]),+-- type text No+ ("ctype", [t|String|]),+-- notnull integer No+ ("notnull", [t|Int16|]),+-- dflt_value - Yes+ ("dflt_value", [t|Maybe String|]),+-- pk integer No+ ("pk", [t|Int16|])+ ]+ [derivingShow])