relational-postgresql8 (empty) → 0.1.0.0
raw patch · 11 files changed
+725/−0 lines, 11 filesdep +HDBCdep +basedep +containerssetup-changed
Dependencies added: HDBC, base, containers, names-th, persistable-record, relational-query, relational-query-HDBC, template-haskell, time
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- relational-postgresql8.cabal +42/−0
- src/Database/HDBC/Schema/PostgreSQL8.hs +112/−0
- src/Database/Relational/Schema/PgCatalog8/Config.hs +17/−0
- src/Database/Relational/Schema/PgCatalog8/PgAttribute.hs +71/−0
- src/Database/Relational/Schema/PgCatalog8/PgClass.hs +58/−0
- src/Database/Relational/Schema/PgCatalog8/PgConstraint.hs +52/−0
- src/Database/Relational/Schema/PgCatalog8/PgNamespace.hs +29/−0
- src/Database/Relational/Schema/PgCatalog8/PgType.hs +90/−0
- src/Database/Relational/Schema/PostgreSQL8.hs +222/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Shohei Murayama++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 Shohei Murayama 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-postgresql8.cabal view
@@ -0,0 +1,42 @@+name: relational-postgresql8+version: 0.1.0.0+synopsis: PostgreSQL v8.x driver for haskell-relational-record+description: This package contains a driver of old PostgreSQL for haskell-relational-record.+homepage: https://github.com/yuga/haskell-relational-record-driver-postgresql8+license: BSD3+license-file: LICENSE+author: Shohei Murayama+maintainer: shohei.murayama@gmail.com+copyright: Copyright (c) 2014 Shohei Murayama+category: Database+build-type: Simple+cabal-version: >=1.8++source-repository head+ type: git+ location: https://github.com/yuga/haskell-relational-record-driver-postgresql8++library+ exposed-modules:+ Database.HDBC.Schema.PostgreSQL8+ Database.Relational.Schema.PostgreSQL8+ Database.Relational.Schema.PgCatalog8.Config+ Database.Relational.Schema.PgCatalog8.PgAttribute+ Database.Relational.Schema.PgCatalog8.PgClass+ Database.Relational.Schema.PgCatalog8.PgConstraint+ Database.Relational.Schema.PgCatalog8.PgNamespace+ Database.Relational.Schema.PgCatalog8.PgType++ build-depends: base <5+ , containers+ , time+ , persistable-record+ , HDBC >=2+ , names-th+ , relational-query+ , relational-query-HDBC+ , template-haskell++ hs-source-dirs: src+ + ghc-options: -Wall
+ src/Database/HDBC/Schema/PostgreSQL8.hs view
@@ -0,0 +1,112 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module : Database.HDBC.Schema.PostgreSQL8+-- Copyright : 2013 Kei Hibino, 2014 Shohei Murayama+-- License : BSD3+--+-- Maintainer : shohei.murayama@gmail.com+-- Stability : experimental+-- Portability : unknown+--+-- This module provides driver implementation+-- to load PostgreSQL system catalog via HDBC.+module Database.HDBC.Schema.PostgreSQL8 (+ driverPostgreSQL+ ) where++import Language.Haskell.TH (TypeQ)+import qualified Language.Haskell.TH.Lib.Extra as TH++import Data.Char (toLower)+import Data.Map (fromList)++import Database.HDBC (IConnection, SqlValue)++import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined)++import Database.HDBC.Record.Query (runQuery')+import Database.HDBC.Record.Persistable ()++import Database.Relational.Schema.PostgreSQL8+ (normalizeColumn, notNull, getType, columnQuerySQL,+ primaryKeyLengthQuerySQL, primaryKeyQuerySQL)+import Database.Relational.Schema.PgCatalog8.PgAttribute (PgAttribute)+import Database.Relational.Schema.PgCatalog8.PgType (PgType)+import qualified Database.Relational.Schema.PgCatalog8.PgType as Type++import Database.HDBC.Schema.Driver+ (TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver)+++$(makeRecordPersistableWithSqlTypeDefaultFromDefined+ [t| SqlValue |] ''PgAttribute)++$(makeRecordPersistableWithSqlTypeDefaultFromDefined+ [t| SqlValue |] ''PgType)++logPrefix :: String -> String+logPrefix = ("PostgreSQL: " ++)++putLog :: String -> IO ()+putLog = TH.reportMessage . logPrefix++compileErrorIO :: String -> IO a+compileErrorIO = fail . logPrefix++getPrimaryKey' :: IConnection conn+ => conn+ -> String+ -> String+ -> IO [String]+getPrimaryKey' conn scm' tbl' = do+ let scm = map toLower scm'+ tbl = map toLower tbl'+ mayKeyLen <- runQuery' conn primaryKeyLengthQuerySQL (scm, tbl)+ case mayKeyLen of+ [] -> do+ putLog "getPrimaryKey: Primary key not found."+ return []+ [keyLen] -> do+ primCols <- runQuery' conn (primaryKeyQuerySQL keyLen) (scm, tbl)+ let primaryKeyCols = normalizeColumn `fmap` primCols+ putLog $ "getPrimaryKey: primary key = " ++ show primaryKeyCols+ return primaryKeyCols+ _:_:_ -> do+ putLog "getPrimaryKey: Fail to detect primary key. Something wrong."+ return []++getFields' :: IConnection conn+ => TypeMap+ -> conn+ -> String+ -> String+ -> IO ([(String, TypeQ)], [Int])+getFields' tmap conn scm' tbl' = do+ let scm = map toLower scm'+ tbl = map toLower tbl'+ cols <- runQuery' conn columnQuerySQL (scm, tbl)+ case cols of+ [] -> compileErrorIO+ $ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl+ _ -> return ()++ let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols+ putLog+ $ "getFields: num of columns = " ++ show (length cols)+ ++ ", not null columns = " ++ show notNullIdxs+ 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++ types <- mapM getType' cols+ return (types, notNullIdxs)++-- | Driver implementation+driverPostgreSQL :: IConnection conn => Driver conn+driverPostgreSQL =+ emptyDriver { getFieldsWithMap = getFields' }+ { getPrimaryKey = getPrimaryKey' }
+ src/Database/Relational/Schema/PgCatalog8/Config.hs view
@@ -0,0 +1,17 @@+-- |+-- Module : Database.Relational.Schema.PgCatalog8.Config+-- Copyright : 2013 Kei Hibino, 2014 Shohei Murayama+-- License : BSD3+--+-- Maintainer : shohei.murayama@gmail.com+-- Stability : experimental+-- Portability : unknown+module Database.Relational.Schema.PgCatalog8.Config (config) where++import Database.Relational.Query (Config, defaultConfig)+++-- | Configuration parameter against PostgreSQL v8.x+config :: Config+config = defaultConfig+
+ src/Database/Relational/Schema/PgCatalog8/PgAttribute.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module : Database.HDBC.Schema.PgCatalog8.PgAttribute+-- Copyright : 2013 Kei Hibino, 2014 Shohei Murayama+-- License : BSD3+--+-- Maintainer : shohei.murayama@gmail.com+-- Stability : experimental+-- Portability : unknown+module Database.Relational.Schema.PgCatalog8.PgAttribute where++import Data.Int (Int16, Int32)++import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.PgCatalog8.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 <= since 9.1+ -- ("attcollation", [t|Int32|]),+-- attacl | aclitem[] | <= since 8.4+ -- ("attacl" , [t|String|]),+-- attoptions | text[] | <= since 9.0+ -- ("attoptions" , [t|String|]),+-- attfdwoptions | text[] | <- since 9.2+ -- ("attfdwoptions", [t|String|])+ ]+ [derivingShow])
+ src/Database/Relational/Schema/PgCatalog8/PgClass.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module : Database.Relational.Schema.PgCatalog8.PgClass+-- Copyright : 2013 Kei Hibino, 2014 Sohei Murayama+-- License : BSD3+--+-- Maintainer : shohei.murayama@gmail.com+-- Stability : experimental+-- Portability : unknown+module Database.Relational.Schema.PgCatalog8.PgClass where++import Data.Int (Int32)++import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.PgCatalog8.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 <= since 9.0+ -- 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 <= since 9.1+ -- relkind | "char" | not null+ -- relnatts | smallint | not null+ -- relchecks | smallint | not null+ -- reltriggers | smallint | not null <= until 8.3+ -- relukeys | smallint | not null <= until 8.3+ -- relfkeys | smallint | not null <= until 8.3+ -- relrefs | smallint | not null <= until 8.3+ -- relhasoids | boolean | not null+ -- relhaspkey | boolean | not null+ -- relhasrules | boolean | not null+ -- relhastriggers | boolean | not null <= since 8.4+ -- relhassubclass | boolean | not null+ -- relfrozenxid | xid | not null <= since 8.2+ -- relminmxid | xid | not null <= since 9.3+ -- relacl | aclitem[] |+ -- reloptions | text[] | <= since 8.2+ ]+ [derivingShow])
+ src/Database/Relational/Schema/PgCatalog8/PgConstraint.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module : Database.Relational.Schema.PgCatalog8.PgConstraint+-- Copyright : 2013 Kei Hibino, 2014 Shohei Murayama+-- License : BSD3+--+-- Maintainer : shohei.murayama@gmail.com+-- Stability : experimental+-- Portability : unknown+module Database.Relational.Schema.PgCatalog8.PgConstraint where++import Data.Int (Int32)++import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.PgCatalog8.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 <= since 9.1+ -- conrelid | oid | not null+ ("conrelid", [t| Int32 |])+ -- contypid | oid | not null+ -- conindid | oid | not null <= since 9.0+ -- confrelid | oid | not null+ -- confupdtype | "char" | not null+ -- confdeltype | "char" | not null+ -- confmatchtype | "char" | not null+ -- conislocal | boolean | not null <= since 8.4+ -- coninhcount | integer | not null <= since 8.4+ -- connoinherit | bool | not null <= since 9.3+ -- conkey | smallint[] |+ -- ("conkey", ???),+ -- confkey | smallint[] |+ -- conpfeqop | oid[] | <= since 8.3+ -- conppeqop | oid[] | <= since 8.3+ -- conffeqop | oid[] | <= since 8.3+ -- conexclop | oid[] | <= since 9.0+ -- conbin | pg_node_tree |+ -- consrc | text |+ ]+ [derivingShow])
+ src/Database/Relational/Schema/PgCatalog8/PgNamespace.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module : Database.Relational.Schema.PgCatalog8.PgNamespace+-- Copyright : 2013 Kei Hibino, 2014 Shohei Murayama+-- License : BSD3+--+-- Maintainer : shohei.murayama@gmail.com+-- Stability : experimental+-- Portability : unknown+module Database.Relational.Schema.PgCatalog8.PgNamespace where++import Data.Int (Int32)++import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.PgCatalog8.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/PgCatalog8/PgType.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module : Database.Relational.Schema.PgCatalog8.PgType+-- Copyright : 2013 Kei Hibino, 2014 Shohei Murayama+-- License : BSD3+--+-- Maintainer : shohei.murayama@gmail.com+-- Stability : experimental+-- Portability : unknown+module Database.Relational.Schema.PgCatalog8.PgType where++import Data.Int (Int16, Int32)++import Database.Record.TH (derivingShow)+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)++import Database.Relational.Schema.PgCatalog8.Config (config)++$(defineTableTypesAndRecordDefault config+ "PG_CATALOG" "pg_type"++ [+ ("oid", [t|Int32|]),+-- Table "pg_catalog.pg_type"+-- Column | Type | Modifiers+-- ----------------+--------------+-----------+-- oid | oid | not null <= since 9.3+-- 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 <= since 8.4+ --("typcategory", [t|Char|]),+-- typispreferred | boolean | not null <= since 8.4+ --("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 <= since 8.3+ --("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 <= since 8.3+ -- ("typmodin", [t||]),+-- typmodout | regproc | not null <= since 8.3+ -- ("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 <= since 9.1+ --("typcollation", [t|Int32|]),+-- typdefaultbin | pg_node_tree |+ -- ("typdefaultbin", [t||]),+-- typdefault | text |+ ("typdefault", [t|Maybe String|])+-- typacl | aclitem[] | <= since 9.2+ ]+ [derivingShow])
+ src/Database/Relational/Schema/PostgreSQL8.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module : Database.Relational.Schema.PostgreSQL8+-- Copyright : 2013 Kei Hibino, 2014 Shohei Murayama+-- License : BSD3+--+-- Maintainer : shohei.murayama@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.PostgreSQL8 (+ 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.PgCatalog8.PgNamespace (pgNamespace)+import qualified Database.Relational.Schema.PgCatalog8.PgNamespace as Namespace+import Database.Relational.Schema.PgCatalog8.PgClass (pgClass)+import qualified Database.Relational.Schema.PgCatalog8.PgClass as Class+import Database.Relational.Schema.PgCatalog8.PgConstraint (PgConstraint, pgConstraint)+import qualified Database.Relational.Schema.PgCatalog8.PgConstraint as Constraint++import Database.Relational.Schema.PgCatalog8.PgAttribute (PgAttribute, pgAttribute)+import qualified Database.Relational.Schema.PgCatalog8.PgAttribute as Attr+import Database.Relational.Schema.PgCatalog8.PgType (PgType(..), pgType)+import qualified Database.Relational.Schema.PgCatalog8.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+-- ]++ wheres $ typ ! Type.typname' `in'` values+ [ "bool", "char", "name", "int8", "int2", "int4" , "regproc" , "text"+ , "oid" , "pg_node_tree" , "float4" , "float8" , "abstime" , "reltime"+ , "tinterval" , "money" , "bpchar" , "varchar" , "date" , "time"+ , "timestamp" , "timestamptz" , "interval" , "timetz" , "numeric"+ , "regprocedure" , "regoper" , "regoperator" , "regclass" , "regtype"+ , "regconfig" , "regdictionary"+ ]++ 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)")+ return (ph, unsafeProjectSql "array_upper (conkey, 1) - array_lower (conkey, 1) + 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