diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/relational-query-HDBC.cabal b/relational-query-HDBC.cabal new file mode 100644 --- /dev/null +++ b/relational-query-HDBC.cabal @@ -0,0 +1,68 @@ +name: relational-query-HDBC +version: 0.0.1.0 +synopsis: HDBC instance of relational join and typed query for HDBC +description: This package contains HDBC instance of relational-query and + typed query for HDBC. + Generating Database table definitions and functions for + relational-query by reading table and index definitions + from Database system catalogs. +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.HDBC.Record.Persistable + Database.HDBC.Record.TH + Database.HDBC.Record.Statement + Database.HDBC.Record.Query + Database.HDBC.Record.Update + Database.HDBC.Record.Insert + Database.HDBC.Record.InsertQuery + Database.HDBC.Record.Delete + Database.HDBC.Record.KeyUpdate + Database.HDBC.Record + Database.HDBC.Query.TH + Database.HDBC.SqlValueExtra + Database.HDBC.Schema.Driver + Database.HDBC.Schema.IBMDB2 + Database.HDBC.Schema.PostgreSQL + Database.HDBC.Schema.SQLServer + Database.HDBC.Schema.SQLite3 + Database.HDBC.Schema.Oracle + Database.HDBC.Schema.MySQL + + other-modules: + Database.HDBC.Record.InternalTH + + build-depends: base <5 + , containers + , convertible + , template-haskell + + , names-th + , persistable-record + , relational-query + , relational-schemas + , HDBC >=2 + , HDBC-session + + 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 diff --git a/src/Database/HDBC/Query/TH.hs b/src/Database/HDBC/Query/TH.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Query/TH.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.HDBC.Query.TH +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module contains templates to generate Haskell record types +-- and HDBC instances correspond to RDB table schema. +module Database.HDBC.Query.TH ( + makeRecordPersistableDefault, + + defineTableDefault', + defineTableDefault, + + defineTableFromDB', + defineTableFromDB, + + inlineVerifiedQuery + ) where + +import Data.Maybe (listToMaybe, fromMaybe) +import qualified Data.Map as Map +import Control.Monad (when) + +import Database.HDBC (IConnection, SqlValue, prepare) + +import Language.Haskell.TH (Q, runIO, Name, TypeQ, Dec) +import Language.Haskell.TH.Name.CamelCase (ConName, varCamelcaseName) +import Language.Haskell.TH.Lib.Extra (reportWarning, reportMessage) + +import Database.Record.TH (makeRecordPersistableWithSqlTypeDefault) +import qualified Database.Record.TH as Record +import Database.Relational.Query (Relation, Config, defaultConfig, relationalQuerySQL) +import Database.Relational.Query.SQL (QuerySuffix) +import qualified Database.Relational.Query.TH as Relational + +import Database.HDBC.Session (withConnectionIO) +import Database.HDBC.Record.Persistable () + +import Database.HDBC.Schema.Driver (Driver, getFields, getPrimaryKey) + + +-- | Generate all persistable templates against defined record like type constructor. +makeRecordPersistableDefault :: Name -- ^ Type constructor name + -> Q [Dec] -- ^ Resutl declaration +makeRecordPersistableDefault recTypeName = do + rr <- Relational.makeRelationalRecordDefault recTypeName + (pair, (_mayNs, cts)) <- Record.reifyRecordType recTypeName + let width = length cts + ps <- Record.makeRecordPersistableWithSqlType [t| SqlValue |] + (Record.persistableFunctionNamesDefault recTypeName) pair width + return $ rr ++ ps + +-- | Generate all HDBC templates about table except for constraint keys using default naming rule. +defineTableDefault' :: Config -- ^ Configuration to generate query with + -> String -- ^ Schema name + -> String -- ^ Table name + -> [(String, TypeQ)] -- ^ List of column name and type + -> [ConName] -- ^ Derivings + -> Q [Dec] -- ^ Result declaration +defineTableDefault' config schema table columns derives = do + modelD <- Relational.defineTableTypesAndRecordDefault config schema table columns derives + sqlvD <- makeRecordPersistableWithSqlTypeDefault [t| SqlValue |] table $ length columns + return $ modelD ++ sqlvD + +-- | Generate all HDBC templates about table using default naming rule. +defineTableDefault :: Config -- ^ Configuration to generate query with + -> String -- ^ Schema name + -> String -- ^ Table name + -> [(String, TypeQ)] -- ^ List of column name and type + -> [ConName] -- ^ Derivings + -> [Int] -- ^ Indexes to represent primary key + -> Maybe Int -- ^ Index of not-null key + -> Q [Dec] -- ^ Result declaration +defineTableDefault config schema table columns derives primary notNull = do + modelD <- Relational.defineTableDefault config schema table columns derives primary notNull + sqlvD <- makeRecordPersistableWithSqlTypeDefault [t| SqlValue |] table $ length columns + return $ modelD ++ sqlvD + +-- | Generate all HDBC templates using system catalog informations with specified config. +defineTableFromDB' :: IConnection conn + => IO conn -- ^ Connect action to system catalog database + -> Config -- ^ Configuration to generate query with + -> Driver conn -- ^ Driver definition + -> String -- ^ Schema name + -> String -- ^ Table name + -> [ConName] -- ^ Derivings + -> Q [Dec] -- ^ Result declaration +defineTableFromDB' connect config drv scm tbl derives = do + let getDBinfo = + withConnectionIO connect + (\conn -> do + (cols, notNullIdxs) <- getFields drv conn scm tbl + primCols <- getPrimaryKey drv conn scm tbl + + return (cols, notNullIdxs, primCols) ) + + (cols, notNullIdxs, primaryCols) <- runIO getDBinfo + when (null primaryCols) . reportWarning + $ "getPrimaryKey: Primary key not found for table: " ++ scm ++ "." ++ tbl + + let colIxMap = Map.fromList $ zip [c | (c, _) <- cols] [(0 :: Int) .. ] + ixLookups = [ (k, Map.lookup k colIxMap) | k <- primaryCols ] + warnLk k = maybe + (reportWarning $ "defineTableFromDB: fail to find index of pkey - " ++ k ++ ". Something wrong!!") + (const $ return ()) + primaryIxs = fromMaybe [] . sequence $ map snd ixLookups + mapM_ (uncurry warnLk) ixLookups + + defineTableDefault config scm tbl cols derives primaryIxs (listToMaybe notNullIdxs) + +-- | Generate all HDBC templates using system catalog informations. +defineTableFromDB :: IConnection conn + => IO conn -- ^ Connect action to system catalog database + -> Driver conn -- ^ Driver definition + -> String -- ^ Schema name + -> String -- ^ Table name + -> [ConName] -- ^ Derivings + -> Q [Dec] -- ^ Result declaration +defineTableFromDB connect = defineTableFromDB' connect defaultConfig + +-- | Verify composed 'Query' and inline it in compile type. +inlineVerifiedQuery :: IConnection conn + => IO conn -- ^ Connect action to system catalog database + -> Name -- ^ Top-level variable name which has 'Relation' type + -> Relation p r -- ^ Object which has 'Relation' type + -> Config -- ^ Configuration to generate SQL + -> QuerySuffix -- ^ suffix SQL words + -> String -- ^ Variable name to define as inlined query + -> Q [Dec] -- ^ Result declarations +inlineVerifiedQuery connect relVar rel config sufs qns = do + (p, r) <- Relational.reifyRelation relVar + let sql = relationalQuerySQL config rel sufs + _ <- runIO $ withConnectionIO connect + (\conn -> do + reportMessage $ "Verify with prepare: " ++ sql + prepare conn sql) + Relational.unsafeInlineQuery (return p) (return r) sql (varCamelcaseName qns) diff --git a/src/Database/HDBC/Record.hs b/src/Database/HDBC/Record.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Record.hs @@ -0,0 +1,31 @@ +-- | +-- Module : Database.HDBC.Record +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides merged namespace of +-- typed 'Query', 'Insert', 'InsertQuery', 'Update', 'KeyUpdate' and 'Delete' +-- running sequences. +module Database.HDBC.Record ( + module Database.HDBC.Record.Query, + module Database.HDBC.Record.Insert, + module Database.HDBC.Record.InsertQuery, + module Database.HDBC.Record.Update, + module Database.HDBC.Record.KeyUpdate, + module Database.HDBC.Record.Delete, + module Database.HDBC.Record.Statement + ) where + +import Database.HDBC.Record.Query hiding (prepare) +import Database.HDBC.Record.Insert hiding (prepare) +import Database.HDBC.Record.InsertQuery hiding (prepare) +import Database.HDBC.Record.Update hiding (prepare) +import Database.HDBC.Record.KeyUpdate hiding (prepare) +import Database.HDBC.Record.Delete hiding (prepare) +import Database.HDBC.Record.Statement + +{-# ANN module "HLint: ignore Use import/export shortcut" #-} diff --git a/src/Database/HDBC/Record/Delete.hs b/src/Database/HDBC/Record/Delete.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Record/Delete.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Database.HDBC.Record.Delete +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides typed 'Delete' running sequence +-- which intermediate structres are typed. +module Database.HDBC.Record.Delete ( + PreparedDelete, prepare, prepareDelete, + + runPreparedDelete, runDelete + ) where + +import Database.HDBC (IConnection, SqlValue) + +import Database.Relational.Query (Delete) +import Database.Record (ToSql) + +import Database.HDBC.Record.Statement + (prepareNoFetch, PreparedStatement, runPreparedNoFetch, runNoFetch) + + +-- | Typed prepared delete type. +type PreparedDelete p = PreparedStatement p () + +-- | Typed prepare delete operation. +prepare :: IConnection conn + => conn + -> Delete p + -> IO (PreparedDelete p) +prepare = prepareNoFetch + +-- | Same as 'prepare'. +prepareDelete :: IConnection conn + => conn + -> Delete p + -> IO (PreparedDelete p) +prepareDelete = prepare + +-- | Bind parameters, execute statement and get execution result. +runPreparedDelete :: ToSql SqlValue p + => PreparedDelete p + -> p + -> IO Integer +runPreparedDelete = runPreparedNoFetch + +-- | Prepare delete statement, bind parameters, +-- execute statement and get execution result. +runDelete :: (IConnection conn, ToSql SqlValue p) + => conn + -> Delete p + -> p + -> IO Integer +runDelete = runNoFetch diff --git a/src/Database/HDBC/Record/Insert.hs b/src/Database/HDBC/Record/Insert.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Record/Insert.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Database.HDBC.Record.Insert +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides typed 'Insert' running sequence +-- which intermediate structres are typed. +module Database.HDBC.Record.Insert ( + PreparedInsert, prepare, prepareInsert, + + runPreparedInsert, runInsert, mapInsert, + + chunksInsertActions, chunksInsert, + ) where + +import Database.HDBC (IConnection, SqlValue) + +import Database.Relational.Query (Insert (..)) +import Database.Record (ToSql, fromRecord) + +import Database.HDBC.Record.Statement + (prepareNoFetch, unsafePrepare, PreparedStatement, untypePrepared, BoundStatement (..), + runPreparedNoFetch, runNoFetch, mapNoFetch, executeNoFetch) + + +-- | Typed prepared insert type. +type PreparedInsert a = PreparedStatement a () + +-- | Typed prepare insert operation. +prepare :: IConnection conn + => conn + -> Insert a + -> IO (PreparedInsert a) +prepare = prepareNoFetch + +-- | Same as 'prepare'. +prepareInsert :: IConnection conn + => conn + -> Insert a + -> IO (PreparedInsert a) +prepareInsert = prepare + +-- | Bind parameters, execute statement and get execution result. +runPreparedInsert :: ToSql SqlValue a + => PreparedInsert a + -> a + -> IO Integer +runPreparedInsert = runPreparedNoFetch + +-- | Prepare insert statement, bind parameters, +-- execute statement and get execution result. +runInsert :: (IConnection conn, ToSql SqlValue a) + => conn + -> Insert a + -> a + -> IO Integer +runInsert = runNoFetch + +-- | Prepare and insert each record. +mapInsert :: (IConnection conn, ToSql SqlValue a) + => conn + -> Insert a + -> [a] + -> IO [Integer] +mapInsert = mapNoFetch + + +-- | Unsafely bind chunk of records. +chunkBind :: ToSql SqlValue p => PreparedStatement [p] () -> [p] -> BoundStatement () +chunkBind q ps = BoundStatement { bound = untypePrepared q, params = ps >>= fromRecord } + +chunks :: Int -> [a] -> [Either [a] [a]] +chunks n = rec' where + rec' xs + | null tl = [ if length c == n + then Right c + else Left c ] + | otherwise = Right c : rec' tl where + (c, tl) = splitAt n xs + +-- | Prepare and insert with chunk insert statement. Result is insert action list. +chunksInsertActions :: (IConnection conn, ToSql SqlValue a) + => conn + -> Insert a + -> [a] + -> IO [ IO [Integer] ] +chunksInsertActions conn i0 rs = do + ins <- unsafePrepare conn $ untypeInsert i0 + iChunk <- unsafePrepare conn $ untypeChunkInsert i0 + let insert (Right c) = do + rv <- executeNoFetch $ chunkBind iChunk c + return [rv] + insert (Left c) = + mapM (runPreparedInsert ins) c + return . map insert $ chunks (chunkSizeOfInsert i0) rs + +-- | Prepare and insert with chunk insert statement. +chunksInsert :: (IConnection conn, ToSql SqlValue a) => conn -> Insert a -> [a] -> IO [[Integer]] +chunksInsert conn ins rs = do + as <- chunksInsertActions conn ins rs + sequence as diff --git a/src/Database/HDBC/Record/InsertQuery.hs b/src/Database/HDBC/Record/InsertQuery.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Record/InsertQuery.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Database.HDBC.Record.InsertQuery +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides typed 'InsertQuery' running sequence +-- which intermediate structres are typed. +module Database.HDBC.Record.InsertQuery ( + PreparedInsertQuery, prepare, prepareInsertQuery, + + runPreparedInsertQuery, runInsertQuery + ) where + +import Database.HDBC (IConnection, SqlValue) + +import Database.Relational.Query (InsertQuery, untypeInsertQuery) +import Database.Record (ToSql) + +import Database.HDBC.Record.Statement + (unsafePrepare, PreparedStatement, runPreparedNoFetch) + +-- | Typed prepared insert query type. +type PreparedInsertQuery p = PreparedStatement p () + +-- | Typed prepare insert-query operation. +prepare :: IConnection conn + => conn + -> InsertQuery p + -> IO (PreparedInsertQuery p) +prepare conn = unsafePrepare conn . untypeInsertQuery + +-- | Same as 'prepare'. +prepareInsertQuery :: IConnection conn + => conn + -> InsertQuery p + -> IO (PreparedInsertQuery p) +prepareInsertQuery = prepare + +-- | Bind parameters, execute statement and get execution result. +runPreparedInsertQuery :: ToSql SqlValue p + => PreparedInsertQuery p + -> p + -> IO Integer +runPreparedInsertQuery = runPreparedNoFetch + +-- | Prepare insert statement, bind parameters, +-- execute statement and get execution result. +runInsertQuery :: (IConnection conn, ToSql SqlValue p) + => conn + -> InsertQuery p + -> p + -> IO Integer +runInsertQuery conn q p = prepareInsertQuery conn q >>= (`runPreparedInsertQuery` p) diff --git a/src/Database/HDBC/Record/InternalTH.hs b/src/Database/HDBC/Record/InternalTH.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Record/InternalTH.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +-- | +-- Module : Database.HDBC.Record.InternalTH +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides internal definitions used from DB-record templates. +module Database.HDBC.Record.InternalTH ( + -- * Persistable instances along with 'Convertible' instances + derivePersistableInstancesFromConvertibleSqlValues + ) where + +import Data.Maybe (catMaybes) +import Data.Set (Set) +import qualified Data.Set as Set + +import Language.Haskell.TH + (Q, Dec (InstanceD), Type(AppT, ConT), + Info (ClassI), reify) +import Data.Convertible (Convertible) +import Database.HDBC (SqlValue) +import Database.HDBC.SqlValueExtra () +import Database.Record (PersistableWidth) +import Database.Record.TH (deriveNotNullType) +import Database.Record.Instances () +import Database.Relational.Query.TH (defineScalarDegree) + +import Database.HDBC.Record.TH (derivePersistableInstanceFromValue) + + +-- | Wrapper type which represents type constructor. +newtype TypeCon = TypeCon { unTypeCon :: Type } deriving Eq + +-- | Ord instance for type constructor. +instance Ord TypeCon where + TypeCon (ConT an) `compare` TypeCon (ConT bn) = an `compare` bn + TypeCon (ConT _) `compare` TypeCon _ = LT + TypeCon _ `compare` TypeCon (ConT _) = GT + a `compare` b | a == b = EQ + | otherwise = EQ + +-- | Set of 'TypeCon'. +type TConSet = Set TypeCon + +-- | From 'Type' list into 'TConSet'. +fromList :: [Type] -> TConSet +fromList = Set.fromList . map TypeCon + +-- | From 'TConSet' into 'Type' list. +toList :: TConSet -> [Type] +toList = map unTypeCon . Set.toList + + +-- | 'SqlValue' type 'Q'. +sqlValueType :: Q Type +sqlValueType = [t| SqlValue |] + +-- | 'Convertble' pairs with 'SqlValue'. +convertibleSqlValues' :: Q [(Type, Type)] +convertibleSqlValues' = cvInfo >>= d0 where + cvInfo = reify ''Convertible + unknownDeclaration = + fail . ("convertibleSqlValues: Unknown declaration pattern: " ++) + d0 (ClassI _ is) = fmap catMaybes . mapM d1 $ is where + d1 (InstanceD _cxt (AppT (AppT (ConT _n) a) b) _ds) + = do qvt <- sqlValueType + return + $ if qvt == a || qvt == b + then case (a, b) of + (ConT _, ConT _) -> Just (a, b) + _ -> Nothing + else Nothing + d1 decl + = unknownDeclaration $ show decl + d0 cls = unknownDeclaration $ show cls + +-- | Get types which are 'Convertible' with. +convertibleSqlValues :: Q TConSet +convertibleSqlValues = do + qvt <- sqlValueType + vs <- convertibleSqlValues' + let from = fromList . map snd . filter ((== qvt) . fst) $ vs + to = fromList . map fst . filter ((== qvt) . snd) $ vs + return $ Set.intersection from to + +-- | Get types which are instance of 'PersistableWith'. +persistableWidthTypes :: Q TConSet +persistableWidthTypes = cvInfo >>= d0 where + cvInfo = reify ''PersistableWidth + unknownDeclaration = + fail . ("persistableWidthTypes: Unknown declaration pattern: " ++) + d0 (ClassI _ is) = fmap fromList . mapM d1 $ is where + d1 (InstanceD _cxt (AppT (ConT _n) a) _ds) = return a + d1 decl = unknownDeclaration $ show decl + d0 cls = unknownDeclaration $ show cls + +-- | Map instance declarations. +mapInstanceD :: (Q Type -> Q [Dec]) -- ^ Template to declare instances from a type + -> [Type] -- ^ Types + -> Q [Dec] -- ^ Result declaration template. +mapInstanceD fD = fmap concat . mapM (fD . return) + +-- | Template to declare HDBC instances of DB-record along with 'Convertible' instances. +derivePersistableInstancesFromConvertibleSqlValues :: Q [Dec] +derivePersistableInstancesFromConvertibleSqlValues = do + wds <- persistableWidthTypes + svs <- convertibleSqlValues + ws <- mapInstanceD deriveNotNullType (toList $ Set.difference svs wds) + let svl = toList svs + ps <- mapInstanceD derivePersistableInstanceFromValue svl + ss <- mapInstanceD defineScalarDegree svl + return $ ws ++ ps ++ ss diff --git a/src/Database/HDBC/Record/KeyUpdate.hs b/src/Database/HDBC/Record/KeyUpdate.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Record/KeyUpdate.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Database.HDBC.Record.KeyUpdate +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides typed 'KeyUpdate' running sequence +-- which intermediate structres are typed. +module Database.HDBC.Record.KeyUpdate ( + PreparedKeyUpdate, + + prepare, prepareKeyUpdate, + + bindKeyUpdate, + + runPreparedKeyUpdate, runKeyUpdate + ) where + +import Database.HDBC (IConnection, SqlValue, Statement) +import qualified Database.HDBC as HDBC + +import Database.Relational.Query + (KeyUpdate, untypeKeyUpdate, updateValuesWithKey, Pi) +import qualified Database.Relational.Query as Query +import Database.Record (ToSql) + +import Database.HDBC.Record.Statement + (BoundStatement (BoundStatement, bound, params), executeNoFetch) + + +-- | Typed prepared key-update type. +data PreparedKeyUpdate p a = + PreparedKeyUpdate + { + -- | Key to specify update target records. + updateKey :: Pi a p + -- | Untyped prepared statement before executed. + , preparedKeyUpdate :: Statement + } + +-- | Typed prepare key-update operation. +prepare :: IConnection conn + => conn + -> KeyUpdate p a + -> IO (PreparedKeyUpdate p a) +prepare conn ku = fmap (PreparedKeyUpdate key) . HDBC.prepare conn $ sql where + sql = untypeKeyUpdate ku + key = Query.updateKey ku + +-- | Same as 'prepare'. +prepareKeyUpdate :: IConnection conn + => conn + -> KeyUpdate p a + -> IO (PreparedKeyUpdate p a) +prepareKeyUpdate = prepare + +-- | Typed operation to bind parameters for 'PreparedKeyUpdate' type. +bindKeyUpdate :: ToSql SqlValue a + => PreparedKeyUpdate p a + -> a + -> BoundStatement () +bindKeyUpdate pre a = + BoundStatement { bound = preparedKeyUpdate pre, params = updateValuesWithKey key a } + where key = updateKey pre + +-- | Bind parameters, execute statement and get execution result. +runPreparedKeyUpdate :: ToSql SqlValue a + => PreparedKeyUpdate p a + -> a + -> IO Integer +runPreparedKeyUpdate pre = executeNoFetch . bindKeyUpdate pre + +-- | Prepare insert statement, bind parameters, +-- execute statement and get execution result. +runKeyUpdate :: (IConnection conn, ToSql SqlValue a) + => conn + -> KeyUpdate p a + -> a + -> IO Integer +runKeyUpdate conn q a = prepareKeyUpdate conn q >>= (`runPreparedKeyUpdate` a) diff --git a/src/Database/HDBC/Record/Persistable.hs b/src/Database/HDBC/Record/Persistable.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Record/Persistable.hs @@ -0,0 +1,43 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Database.HDBC.Record.Persistable +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides HDBC instance definitions of DB-record. +module Database.HDBC.Record.Persistable ( + persistableSqlValue + ) where + +import Database.Record (PersistableSqlValue, PersistableType (..), PersistableValue (..)) +import Database.Record.Persistable (unsafePersistableSqlTypeFromNull) +import qualified Database.Record.Persistable as Record +import Database.HDBC.Record.InternalTH (derivePersistableInstancesFromConvertibleSqlValues) + +import Data.Convertible (Convertible) +import Database.HDBC (SqlValue(SqlNull), fromSql, toSql) + +instance PersistableType SqlValue where + persistableType = unsafePersistableSqlTypeFromNull SqlNull + +-- | Derived 'PersistableSqlValue' from 'Convertible'. +persistableSqlValue :: (Convertible SqlValue a, Convertible a SqlValue) + => PersistableSqlValue SqlValue a +persistableSqlValue = Record.persistableSqlValue persistableType fromSql toSql + +-- | Infered 'PersistableSqlValue' from 'Convertible'. +instance (Convertible SqlValue a, Convertible a SqlValue) + => PersistableValue SqlValue a where + persistableValue = persistableSqlValue + +$(derivePersistableInstancesFromConvertibleSqlValues) diff --git a/src/Database/HDBC/Record/Query.hs b/src/Database/HDBC/Record/Query.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Record/Query.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Database.HDBC.Record.Query +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides typed 'Query' running sequence +-- which intermediate structres are typed. +module Database.HDBC.Record.Query ( + PreparedQuery, prepare, prepareQuery, + + fetch, fetchAll, fetchAll', + listToUnique, fetchUnique, fetchUnique', + + runStatement, runStatement', + runPreparedQuery, runPreparedQuery', + runQuery, runQuery' + ) where + +import Data.Maybe (listToMaybe) +import Database.HDBC (IConnection, Statement, SqlValue) +import qualified Database.HDBC as HDBC + +import Database.Relational.Query (Query, untypeQuery) +import Database.Record + (ToSql, RecordFromSql, FromSql(recordFromSql), runToRecord) + +import Database.HDBC.Record.Statement + (unsafePrepare, PreparedStatement, + bind, BoundStatement, + execute, ExecutedStatement, executed) + + +-- | Typed prepared query type. +type PreparedQuery p a = PreparedStatement p a + +-- | Typed prepare query operation. +prepare :: IConnection conn + => conn -- ^ Database connection + -> Query p a -- ^ Typed query + -> IO (PreparedQuery p a) -- ^ Result typed prepared query with parameter type 'p' and result type 'a' +prepare conn = unsafePrepare conn . untypeQuery + +-- | Same as 'prepare'. +prepareQuery :: IConnection conn + => conn -- ^ Database connection + -> Query p a -- ^ Typed query + -> IO (PreparedQuery p a) -- ^ Result typed prepared query with parameter type 'p' and result type 'a' +prepareQuery = prepare + +-- | Polymorphic fetch operation. +fetchRecordsExplicit :: Functor f + => (Statement -> IO (f [SqlValue]) ) + -> RecordFromSql SqlValue a + -> ExecutedStatement a + -> IO (f a) +fetchRecordsExplicit fetchs fromSql es = do + rows <- fetchs (executed es) + return $ fmap (runToRecord fromSql) rows + +-- | Fetch a record. +fetch :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a) +fetch = fetchRecordsExplicit HDBC.fetchRow recordFromSql + +-- | Lazily Fetch all records. +fetchAll :: FromSql SqlValue a => ExecutedStatement a -> IO [a] +fetchAll = fetchRecordsExplicit HDBC.fetchAllRows recordFromSql + +-- | Strict version of 'fetchAll'. +fetchAll' :: FromSql SqlValue a => ExecutedStatement a -> IO [a] +fetchAll' = fetchRecordsExplicit HDBC.fetchAllRows' recordFromSql + +-- | Fetch all records but get only first record. +-- Expecting result records is unique. +fetchUnique :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a) +fetchUnique es = do + recs <- fetchAll es + let z' = listToMaybe recs + z <- z' `seq` return z' + HDBC.finish $ executed es + return z + +-- | Fetch expecting result records is unique. +listToUnique :: [a] -> IO (Maybe a) +listToUnique = d where + d [] = return Nothing + d [r] = return $ Just r + d (_:_:_) = fail "fetchUnique': more than one record found." + +-- | Fetch all records but get only first record. +-- Expecting result records is unique. +-- Error when records count is more than one. +fetchUnique' :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a) +fetchUnique' es = do + recs <- fetchAll es + z <- listToUnique recs + HDBC.finish $ executed es + return z + +-- | Execute statement and lazily fetch all records. +runStatement :: FromSql SqlValue a => BoundStatement a -> IO [a] +runStatement = (>>= fetchAll) . execute + +-- | Strict version of 'runStatement'. +runStatement' :: FromSql SqlValue a => BoundStatement a -> IO [a] +runStatement' = (>>= fetchAll') . execute + +-- | Bind parameters, execute statement and lazily fetch all records. +runPreparedQuery :: (ToSql SqlValue p, FromSql SqlValue a) + => PreparedQuery p a -- ^ Statement to bind to + -> p -- ^ Parameter type + -> IO [a] -- ^ Action to get records +runPreparedQuery ps = runStatement . bind ps + +-- | Strict version of 'runPreparedQuery'. +runPreparedQuery' :: (ToSql SqlValue p, FromSql SqlValue a) + => PreparedQuery p a -- ^ Statement to bind to + -> p -- ^ Parameter type + -> IO [a] -- ^ Action to get records +runPreparedQuery' ps = runStatement' . bind ps + +-- | Prepare SQL, bind parameters, execute statement and lazily fetch all records. +runQuery :: (IConnection conn, ToSql SqlValue p, FromSql SqlValue a) + => conn -- ^ Database connection + -> Query p a -- ^ Query to get record type 'a' requires parameter 'p' + -> p -- ^ Parameter type + -> IO [a] -- ^ Action to get records +runQuery conn q p = prepare conn q >>= (`runPreparedQuery` p) + +-- | Strict version of 'runQuery'. +runQuery' :: (IConnection conn, ToSql SqlValue p, FromSql SqlValue a) + => conn -- ^ Database connection + -> Query p a -- ^ Query to get record type 'a' requires parameter 'p' + -> p -- ^ Parameter type + -> IO [a] -- ^ Action to get records +runQuery' conn q p = prepare conn q >>= (`runPreparedQuery'` p) diff --git a/src/Database/HDBC/Record/Statement.hs b/src/Database/HDBC/Record/Statement.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Record/Statement.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Database.HDBC.Record.Statement +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides typed statement running sequence +-- which intermediate structres are typed. +module Database.HDBC.Record.Statement ( + PreparedStatement, untypePrepared, unsafePrepare, + + BoundStatement (..), bind', bind, bindTo, + + ExecutedStatement, executed, result, execute, + + prepareNoFetch, executeNoFetch, runPreparedNoFetch, runNoFetch, mapNoFetch + ) where + +import Database.Relational.Query (UntypeableNoFetch (untypeNoFetch)) +import Database.HDBC (IConnection, Statement, SqlValue) +import qualified Database.HDBC as HDBC + +import Database.Record + (RecordToSql, ToSql(recordToSql), runFromRecord) + +-- | Typed prepared statement type. +newtype PreparedStatement p a = + PreparedStatement { + -- | Untyped prepared statement before executed. + prepared :: Statement + } + +-- | Typed prepared statement which has bound placeholder parameters. +data BoundStatement a = + BoundStatement + { + -- | Untyped prepared statement before executed. + bound :: Statement + -- | Bound parameters. + , params :: [SqlValue] + } + +-- | Typed executed statement. +data ExecutedStatement a = + ExecutedStatement + { -- | Untyped executed statement. + executed :: Statement + -- | Result of HDBC execute. + , result :: Integer + } + +-- | Unsafely untype prepared statement. +untypePrepared :: PreparedStatement p a -> Statement +untypePrepared = prepared + +-- | Run prepare and unsafely make Typed prepared statement. +unsafePrepare :: IConnection conn + => conn -- ^ Database connection + -> String -- ^ Raw SQL String + -> IO (PreparedStatement p a) -- ^ Result typed prepared query with parameter type 'p' and result type 'a' +unsafePrepare conn = fmap PreparedStatement . HDBC.prepare conn + +-- | Generalized prepare inferred from 'UntypeableNoFetch' instance. +prepareNoFetch :: (UntypeableNoFetch s, IConnection conn) + => conn + -> s p + -> IO (PreparedStatement p ()) +prepareNoFetch conn = unsafePrepare conn . untypeNoFetch + +-- | Typed operation to bind parameters. +bind' :: RecordToSql SqlValue p -- ^ Proof object to convert from parameter type 'p' into 'SqlValue' list. + -> PreparedStatement p a -- ^ Prepared query to bind to + -> p -- ^ Parameter to bind + -> BoundStatement a -- ^ Result parameter bound statement +bind' toSql q p = BoundStatement { bound = prepared q, params = runFromRecord toSql p } + +-- | Typed operation to bind parameters. Infered 'RecordToSql' is used. +bind :: ToSql SqlValue p => PreparedStatement p a -> p -> BoundStatement a +bind = bind' recordToSql + +-- | Same as 'bind' except for argument is flipped. +bindTo :: ToSql SqlValue p => p -> PreparedStatement p a -> BoundStatement a +bindTo = flip bind + +-- | Typed execute operation. +execute :: BoundStatement a -> IO (ExecutedStatement a) +execute bs = do + let stmt = bound bs + n <- HDBC.execute stmt (params bs) + return $ ExecutedStatement stmt n + +-- | Typed execute operation. Only get result. +executeNoFetch :: BoundStatement () -> IO Integer +executeNoFetch = fmap result . execute + +-- | Bind parameters, execute statement and get execution result. +runPreparedNoFetch :: ToSql SqlValue a + => PreparedStatement a () + -> a + -> IO Integer +runPreparedNoFetch p = executeNoFetch . (p `bind`) + +-- | Prepare and run sequence for polymorphic no-fetch statement. +runNoFetch :: (UntypeableNoFetch s, IConnection conn, ToSql SqlValue a) + => conn + -> s a + -> a + -> IO Integer +runNoFetch conn s p = prepareNoFetch conn s >>= (`runPreparedNoFetch` p) + +-- | Prepare and run it against each parameter list. +mapNoFetch :: (UntypeableNoFetch s, IConnection conn, ToSql SqlValue a) + => conn + -> s a + -> [a] + -> IO [Integer] +mapNoFetch conn s rs = do + ps <- prepareNoFetch conn s + mapM (runPreparedNoFetch ps) rs diff --git a/src/Database/HDBC/Record/TH.hs b/src/Database/HDBC/Record/TH.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Record/TH.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} + +-- | +-- Module : Database.HDBC.Record.TH +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides DB-record templates depends on HDBC. +module Database.HDBC.Record.TH ( + derivePersistableInstanceFromValue, + ) where + +import Language.Haskell.TH (Q, Dec, Type) +import Database.HDBC (SqlValue) +import Database.HDBC.SqlValueExtra () +import Database.Record (FromSql(..), valueFromSql, ToSql(..), valueToSql) + + +-- | Template to declare HDBC instances of DB-record against single value type. +derivePersistableInstanceFromValue :: Q Type -- ^ Type to implement instances + -> Q [Dec] -- ^ Result declarations +derivePersistableInstanceFromValue typ = + [d| instance FromSql SqlValue $(typ) where + recordFromSql = valueFromSql + + instance ToSql SqlValue $(typ) where + recordToSql = valueToSql + |] diff --git a/src/Database/HDBC/Record/Update.hs b/src/Database/HDBC/Record/Update.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Record/Update.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Database.HDBC.Record.Update +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides typed 'Update' running sequence +-- which intermediate structres are typed. +module Database.HDBC.Record.Update ( + PreparedUpdate, prepare, prepareUpdate, + + runPreparedUpdate, runUpdate, mapUpdate + ) where + +import Database.HDBC (IConnection, SqlValue) + +import Database.Relational.Query (Update) +import Database.Record (ToSql) + +import Database.HDBC.Record.Statement + (prepareNoFetch, PreparedStatement, runPreparedNoFetch, runNoFetch, mapNoFetch) + + +-- | Typed prepared update type. +type PreparedUpdate p = PreparedStatement p () + +-- | Typed prepare update operation. +prepare :: IConnection conn + => conn + -> Update p + -> IO (PreparedUpdate p) +prepare = prepareNoFetch + +-- | Same as 'prepare'. +prepareUpdate :: IConnection conn + => conn + -> Update p + -> IO (PreparedUpdate p) +prepareUpdate = prepare + +-- | Bind parameters, execute statement and get execution result. +runPreparedUpdate :: ToSql SqlValue p + => PreparedUpdate p + -> p + -> IO Integer +runPreparedUpdate = runPreparedNoFetch + +-- | Prepare update statement, bind parameters, +-- execute statement and get execution result. +runUpdate :: (IConnection conn, ToSql SqlValue p) + => conn + -> Update p + -> p + -> IO Integer +runUpdate = runNoFetch + +-- | Prepare and update with each parameter list. +mapUpdate :: (IConnection conn, ToSql SqlValue a) + => conn + -> Update a + -> [a] + -> IO [Integer] +mapUpdate = mapNoFetch diff --git a/src/Database/HDBC/Schema/Driver.hs b/src/Database/HDBC/Schema/Driver.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Schema/Driver.hs @@ -0,0 +1,53 @@ +-- | +-- Module : Database.HDBC.Schema.Driver +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides driver interface +-- to load database system catalog via HDBC. +module Database.HDBC.Schema.Driver ( + TypeMap, + Driver(Driver, typeMap, getFieldsWithMap, getPrimaryKey), + emptyDriver, + getFields + ) where + +import Database.HDBC (IConnection) +import Language.Haskell.TH (TypeQ) + + +-- | Mapping between type name string of DBMS and type in Haskell. +-- Type name string depends on specification of DBMS system catalogs. +type TypeMap = [(String, TypeQ)] + +-- | Interface type to load database system catalog via HDBC. +data Driver conn = + Driver + { -- | Custom type mapping of this driver + typeMap :: TypeMap + + -- | Get column name and Haskell type pairs and not-null columns index. + , getFieldsWithMap :: TypeMap -- Custom type mapping + -> conn -- Connection to query system catalog + -> String -- Schema name string + -> String -- Table name string + -> IO ([(String, TypeQ)], [Int]) -- Action to get column name and Haskell type pairs and not-null columns index. + + -- | Get primary key column name. + , getPrimaryKey :: conn -- Connection to query system catalog + -> String -- Schema name string + -> String -- Table name string + -> IO [String] -- Action to get column names of primary key + } + +-- | Empty definition of 'Driver' +emptyDriver :: IConnection conn => Driver conn +emptyDriver = Driver [] (\_ _ _ _ -> return ([],[])) (\_ _ _ -> return []) + +-- | Helper function to call 'getFieldsWithMap' using 'typeMap' of 'Driver'. +getFields :: IConnection conn => Driver conn -> conn -> String -> String -> IO ([(String, TypeQ)], [Int]) +getFields drv = getFieldsWithMap drv (typeMap drv) diff --git a/src/Database/HDBC/Schema/IBMDB2.hs b/src/Database/HDBC/Schema/IBMDB2.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Schema/IBMDB2.hs @@ -0,0 +1,104 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.HDBC.Schema.IBMDB2 +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides driver implementation +-- to load IBM-DB2 system catalog via HDBC. +module Database.HDBC.Schema.IBMDB2 ( + driverIBMDB2 + ) where + +import Prelude hiding (length) + +import Language.Haskell.TH (TypeQ) + +import qualified Data.List as List +import Data.Char (toUpper) +import Data.Map (fromList) +import Control.Monad (when) + +import Database.HDBC (IConnection, SqlValue) + +import Language.Haskell.TH.Lib.Extra (reportMessage) + +import Database.HDBC.Record.Query (runQuery') +import Database.HDBC.Record.Persistable () + +import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) + +import Database.Relational.Schema.IBMDB2 + (normalizeColumn, notNull, getType, columnsQuerySQL, primaryKeyQuerySQL) +import Database.Relational.Schema.DB2Syscat.Columns (Columns) +import qualified Database.Relational.Schema.DB2Syscat.Columns as Columns + +import Database.HDBC.Schema.Driver + (TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver) + + +-- Specify type constructor and data constructor from same table name. +$(makeRecordPersistableWithSqlTypeDefaultFromDefined + [t| SqlValue |] ''Columns) + +logPrefix :: String -> String +logPrefix = ("IBMDB2: " ++) + +putLog :: String -> IO () +putLog = reportMessage . logPrefix + +compileErrorIO :: String -> IO a +compileErrorIO = fail . logPrefix + +getPrimaryKey' :: IConnection conn + => conn + -> String + -> String + -> IO [String] +getPrimaryKey' conn scm' tbl' = do + let tbl = map toUpper tbl' + scm = map toUpper scm' + primCols <- runQuery' conn primaryKeyQuerySQL (scm, tbl) + let primaryKeyCols = normalizeColumn `fmap` primCols + putLog $ "getPrimaryKey: primary key = " ++ show primaryKeyCols + + return primaryKeyCols + +getColumns' :: IConnection conn + => TypeMap + -> conn + -> String + -> String + -> IO ([(String, TypeQ)], [Int]) +getColumns' tmap conn scm' tbl' = do + let tbl = map toUpper tbl' + scm = map toUpper scm' + + cols <- runQuery' conn columnsQuerySQL (scm, tbl) + when (null cols) . compileErrorIO + $ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl + + let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols + putLog + $ "getFields: num of columns = " ++ show (List.length cols) + ++ ", not null columns = " ++ show notNullIdxs + let getType' col = case getType (fromList tmap) col of + Nothing -> compileErrorIO + $ "Type mapping is not defined against DB2 type: " ++ Columns.typename col + Just p -> return p + + types <- mapM getType' cols + return (types, notNullIdxs) + +-- | Driver implementation +driverIBMDB2 :: IConnection conn => Driver conn +driverIBMDB2 = + emptyDriver { getFieldsWithMap = getColumns' } + { getPrimaryKey = getPrimaryKey' } diff --git a/src/Database/HDBC/Schema/MySQL.hs b/src/Database/HDBC/Schema/MySQL.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Schema/MySQL.hs @@ -0,0 +1,88 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Database.HDBC.Schema.MySQL + ( + driverMySQL + ) + where + +import Prelude hiding (length) +import Language.Haskell.TH (TypeQ) +import qualified Data.List as List +import Data.Map (fromList) + +import Database.HDBC (IConnection, SqlValue) +import Database.HDBC.Record.Query (runQuery') +import Database.HDBC.Record.Persistable () +import Database.HDBC.Schema.Driver ( TypeMap + , Driver + , getFieldsWithMap + , getPrimaryKey + , emptyDriver + ) +import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) +import Database.Relational.Schema.MySQL ( normalizeColumn + , notNull + , getType + , columnsQuerySQL + , primaryKeyQuerySQL + ) + +import Database.Relational.Schema.MySQLInfo.Columns (Columns) +import qualified Database.Relational.Schema.MySQLInfo.Columns as Columns + +$(makeRecordPersistableWithSqlTypeDefaultFromDefined [t| SqlValue |] ''Columns) + +logPrefix :: String -> String +logPrefix = ("MySQL: " ++) + +putLog :: String -> IO () +putLog = putStrLn . logPrefix + +compileErrorIO :: String -> IO a +compileErrorIO = fail . logPrefix + +getPrimaryKey' :: IConnection conn + => conn + -> String + -> String + -> IO [String] +getPrimaryKey' conn scm tbl = do + primCols <- runQuery' conn primaryKeyQuerySQL (scm, tbl) + let primaryKeyCols = normalizeColumn `fmap` primCols + putLog $ "getPrimaryKey: primary key = " ++ show primaryKeyCols + return primaryKeyCols + +getFields' :: IConnection conn + => TypeMap + -> conn + -> String + -> String + -> IO ([(String, TypeQ)], [Int]) +getFields' tmap conn scm tbl = do + cols <- runQuery' conn columnsQuerySQL (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 (List.length cols) + ++ ", not null columns = " ++ show notNullIdxs + types <- mapM getType' cols + return (types, notNullIdxs) + where + getType' col = + case getType (fromList tmap) col of + Nothing -> compileErrorIO + $ "Type mapping is not defined against MySQL type: " + ++ Columns.dataType col + Just p -> return p + +-- | Driver implementation +driverMySQL :: IConnection conn => Driver conn +driverMySQL = + emptyDriver { getFieldsWithMap = getFields' } + { getPrimaryKey = getPrimaryKey' } diff --git a/src/Database/HDBC/Schema/Oracle.hs b/src/Database/HDBC/Schema/Oracle.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Schema/Oracle.hs @@ -0,0 +1,85 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-} + +module Database.HDBC.Schema.Oracle + ( driverOracle + ) where + +import Control.Applicative ((<$>)) +import Data.Char (toUpper) +import Data.Map (fromList) +import Data.Maybe (catMaybes) +import Language.Haskell.TH (TypeQ) + +import Database.HDBC (IConnection, SqlValue) +import Database.HDBC.Record.Query (runQuery') +import Database.HDBC.Record.Persistable () +import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) +import Database.HDBC.Schema.Driver + ( TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver + ) + +import Database.Relational.Schema.Oracle + ( normalizeColumn, notNull, getType + , columnsQuerySQL, primaryKeyQuerySQL + ) +import Database.Relational.Schema.OracleDataDictionary.TabColumns (DbaTabColumns) +import qualified Database.Relational.Schema.OracleDataDictionary.TabColumns as Cols + +$(makeRecordPersistableWithSqlTypeDefaultFromDefined + [t|SqlValue|] + ''DbaTabColumns) + +logPrefix :: String -> String +logPrefix = ("Oracle: " ++) + +putLog :: String -> IO () +putLog = putStrLn . logPrefix + +compileErrorIO :: String -> IO a +compileErrorIO = fail . logPrefix + +getPrimaryKey' :: IConnection conn + => conn + -> String -- ^ owner name + -> String -- ^ table name + -> IO [String] -- ^ primary key names +getPrimaryKey' conn owner' tbl' = do + let owner = map toUpper owner' + tbl = map toUpper tbl' + prims <- map normalizeColumn . catMaybes <$> + runQuery' conn primaryKeyQuerySQL (owner, tbl) + putLog $ "getPrimaryKey: keys = " ++ show prims + return prims + +getFields' :: IConnection conn + => TypeMap + -> conn + -> String + -> String + -> IO ([(String, TypeQ)], [Int]) +getFields' tmap conn owner' tbl' = do + let owner = map toUpper owner' + tbl = map toUpper tbl' + cols <- runQuery' conn columnsQuerySQL (owner, tbl) + case cols of + [] -> compileErrorIO $ + "getFields: No columns found: owner = " ++ owner ++ ", 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 Oracle DB type: " ++ + show (Cols.dataType col) + Just p -> return p + types <- mapM getType' cols + return (types, notNullIdxs) + +-- | Driver for Oracle DB +driverOracle :: IConnection conn => Driver conn +driverOracle = + emptyDriver { getFieldsWithMap = getFields' } + { getPrimaryKey = getPrimaryKey' } diff --git a/src/Database/HDBC/Schema/PostgreSQL.hs b/src/Database/HDBC/Schema/PostgreSQL.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Schema/PostgreSQL.hs @@ -0,0 +1,112 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.HDBC.Schema.PostgreSQL +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides driver implementation +-- to load PostgreSQL system catalog via HDBC. +module Database.HDBC.Schema.PostgreSQL ( + driverPostgreSQL + ) where + +import Language.Haskell.TH (TypeQ) + +import Data.Char (toLower) +import Data.Map (fromList) +import Control.Monad (when) + +import Database.HDBC (IConnection, SqlValue) + +import Language.Haskell.TH.Lib.Extra (reportMessage) + +import Database.HDBC.Record.Query (runQuery') +import Database.HDBC.Record.Persistable () + +import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) + +import Database.Relational.Schema.PostgreSQL + (normalizeColumn, notNull, getType, columnQuerySQL, + primaryKeyLengthQuerySQL, primaryKeyQuerySQL) +import Database.Relational.Schema.PgCatalog.PgAttribute (PgAttribute) +import Database.Relational.Schema.PgCatalog.PgType (PgType) +import qualified Database.Relational.Schema.PgCatalog.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 = 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 [] + +getColumns' :: IConnection conn + => TypeMap + -> conn + -> String + -> String + -> IO ([(String, TypeQ)], [Int]) +getColumns' tmap conn scm' tbl' = do + let scm = map toLower scm' + tbl = map toLower tbl' + cols <- runQuery' conn columnQuerySQL (scm, tbl) + when (null cols) . compileErrorIO + $ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl + + 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 = getColumns' } + { getPrimaryKey = getPrimaryKey' } diff --git a/src/Database/HDBC/Schema/SQLServer.hs b/src/Database/HDBC/Schema/SQLServer.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Schema/SQLServer.hs @@ -0,0 +1,87 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.HDBC.Schema.SQLServer +-- Copyright : 2013 Shohei Murayama +-- License : BSD3 +-- +-- Maintainer : shohei.murayama@gmail.com +-- Stability : experimental +-- Portability : unknown +module Database.HDBC.Schema.SQLServer ( + driverSQLServer, + ) where + +import qualified Database.Relational.Schema.SQLServerSyscat.Columns as Columns +import qualified Database.Relational.Schema.SQLServerSyscat.Types as Types + +import Data.Map (fromList) +import Data.Maybe (catMaybes) +import Database.HDBC (IConnection, SqlValue) +import Database.HDBC.Record.Query (runQuery') +import Database.HDBC.Record.Persistable () +import Database.HDBC.Schema.Driver (TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver) +import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) +import Database.Relational.Schema.SQLServer (columnTypeQuerySQL, getType, normalizeColumn, + notNull, primaryKeyQuerySQL) +import Database.Relational.Schema.SQLServerSyscat.Columns (Columns) +import Database.Relational.Schema.SQLServerSyscat.Types (Types) +import Language.Haskell.TH (TypeQ) + +$(makeRecordPersistableWithSqlTypeDefaultFromDefined + [t| SqlValue |] ''Columns) + +$(makeRecordPersistableWithSqlTypeDefaultFromDefined + [t| SqlValue |] ''Types) + +logPrefix :: String -> String +logPrefix = ("SQLServer: " ++) + +putLog :: String -> IO () +putLog = putStrLn . logPrefix + +compileErrorIO :: String -> IO a +compileErrorIO = fail . logPrefix + +getPrimaryKey' :: IConnection conn + => conn + -> String + -> String + -> IO [String] +getPrimaryKey' conn scm tbl = do + prims <- catMaybes `fmap` runQuery' conn primaryKeyQuerySQL (scm,tbl) + let primColumns = map normalizeColumn prims + putLog $ "getPrimaryKey: keys=" ++ show primColumns + return primColumns + +getFields' :: IConnection conn + => TypeMap + -> conn + -> String + -> String + -> IO ([(String, TypeQ)], [Int]) +getFields' tmap conn scm tbl = do + rows <- runQuery' conn columnTypeQuerySQL (scm, tbl) + case rows of + [] -> compileErrorIO + $ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl + _ -> return () + let columnId ((cols,_),_) = Columns.columnId cols - 1 + let notNullIdxs = map (fromIntegral . columnId) . filter notNull $ rows + putLog + $ "getFields: num of columns = " ++ show (length rows) + ++ ", not null columns = " ++ show notNullIdxs + let getType' rec@((_,typs),typScms) = case getType (fromList tmap) rec of + Nothing -> compileErrorIO + $ "Type mapping is not defined against SQLServer type: " + ++ typScms ++ "." ++ Types.name typs + Just p -> return p + types <- mapM getType' rows + return (types, notNullIdxs) + +driverSQLServer :: IConnection conn => Driver conn +driverSQLServer = + emptyDriver { getFieldsWithMap = getFields' } + { getPrimaryKey = getPrimaryKey' } diff --git a/src/Database/HDBC/Schema/SQLite3.hs b/src/Database/HDBC/Schema/SQLite3.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Schema/SQLite3.hs @@ -0,0 +1,106 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | +-- Module : Database.HDBC.Schema.SQLite3 +-- Copyright : 2013 Shohei Murayama +-- License : BSD3 +-- +-- Maintainer : shohei.murayama@gmail.com +-- Stability : experimental +-- Portability : unknown +module Database.HDBC.Schema.SQLite3 ( + driverSQLite3 + ) where + +import qualified Database.Relational.Schema.SQLite3Syscat.IndexInfo as IndexInfo +import qualified Database.Relational.Schema.SQLite3Syscat.IndexList as IndexList +import qualified Database.Relational.Schema.SQLite3Syscat.TableInfo as TableInfo + +import Data.List (isPrefixOf, sort, sortBy) +import Data.Map (fromList) +import Database.HDBC (IConnection, SqlValue) +import Database.HDBC.Record.Query (runQuery') +import Database.HDBC.Record.Persistable () +import Database.HDBC.Schema.Driver (TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver) +import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) +import Database.Relational.Schema.SQLite3 (getType, indexInfoQuerySQL, indexListQuerySQL, normalizeColumn, + normalizeType, notNull, tableInfoQuerySQL) +import Database.Relational.Schema.SQLite3Syscat.IndexInfo (IndexInfo) +import Database.Relational.Schema.SQLite3Syscat.IndexList (IndexList) +import Database.Relational.Schema.SQLite3Syscat.TableInfo (TableInfo) +import Language.Haskell.TH (TypeQ) + +$(makeRecordPersistableWithSqlTypeDefaultFromDefined + [t| SqlValue |] ''TableInfo) + +$(makeRecordPersistableWithSqlTypeDefaultFromDefined + [t| SqlValue |] ''IndexList) + +$(makeRecordPersistableWithSqlTypeDefaultFromDefined + [t| SqlValue |] ''IndexInfo) + +logPrefix :: String -> String +logPrefix = ("SQLite3: " ++) + +putLog :: String -> IO () +putLog = putStrLn . logPrefix + +compileErrorIO :: String -> IO a +compileErrorIO = fail . logPrefix + +getPrimaryKey' :: IConnection conn + => conn + -> String + -> String + -> IO [String] +getPrimaryKey' conn scm tbl = do + tblinfo <- runQuery' conn (tableInfoQuerySQL scm tbl) () + let primColumns = map (normalizeColumn . TableInfo.name) + . filter ((1 ==) . TableInfo.pk) $ tblinfo + if length primColumns <= 1 then do + putLog $ "getPrimaryKey: key=" ++ show primColumns + return primColumns + else do + idxlist <- runQuery' conn (indexListQuerySQL scm tbl) () + let idxNames = filter (isPrefixOf "sqlite_autoindex_") + . map IndexList.name + . filter ((1 ==) . IndexList.unique) $ idxlist + idxInfos <- mapM (\ixn -> runQuery' conn (indexInfoQuerySQL scm ixn) ()) idxNames + let isPrimaryKey = (sort primColumns ==) . sort . map (normalizeColumn . IndexInfo.name) + let idxInfo = concat . take 1 . filter isPrimaryKey $ idxInfos + let comp x y = compare (IndexInfo.seqno x) (IndexInfo.seqno y) + let primColumns' = map IndexInfo.name . sortBy comp $ idxInfo + putLog $ "getPrimaryKey: keys=" ++ show primColumns' + return primColumns' + +getFields' :: IConnection conn + => TypeMap + -> conn + -> String + -> String + -> IO ([(String, TypeQ)], [Int]) +getFields' tmap conn scm tbl = do + rows <- runQuery' conn (tableInfoQuerySQL scm tbl) () + case rows of + [] -> compileErrorIO + $ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl + _ -> return () + let columnId = TableInfo.cid + let notNullIdxs = map (fromIntegral . columnId) . filter notNull $ rows + putLog + $ "getFields: num of columns = " ++ show (length rows) + ++ ", not null columns = " ++ show notNullIdxs + let getType' ti = case getType (fromList tmap) ti of + Nothing -> compileErrorIO + $ "Type mapping is not defined against SQLite3 type: " + ++ normalizeType (TableInfo.ctype ti) + Just p -> return p + types <- mapM getType' rows + return (types, notNullIdxs) + +driverSQLite3 :: IConnection conn => Driver conn +driverSQLite3 = + emptyDriver { getFieldsWithMap = getFields' } + { getPrimaryKey = getPrimaryKey' } diff --git a/src/Database/HDBC/SqlValueExtra.hs b/src/Database/HDBC/SqlValueExtra.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/SqlValueExtra.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS -fno-warn-orphans #-} + +-- | +-- Module : Database.HDBC.SqlValueExtra +-- Copyright : 2013 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +module Database.HDBC.SqlValueExtra () where + +import Data.Convertible (Convertible(safeConvert), ConvertResult) +import Data.Int (Int16, Int32) +import Database.HDBC (SqlValue) + +safeConvertFromIntegral32 :: Integral a => a -> ConvertResult SqlValue +safeConvertFromIntegral32 i = + safeConvert (fromIntegral i :: Int32) + +safeConvertToIntegral32 :: Integral a => SqlValue -> ConvertResult a +safeConvertToIntegral32 v = + fmap fromIntegral (safeConvert v :: ConvertResult Int32) + +instance Convertible Int16 SqlValue where + safeConvert = safeConvertFromIntegral32 + +instance Convertible SqlValue Int16 where + safeConvert = safeConvertToIntegral32