diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ +## 0.6.6.0 + +- add a portable sequence number operation. +- defaultly use custom configuration in defineTableFromDB. + ## 0.6.5.0 - apply relational-query-0.10.0 diff --git a/relational-query-HDBC.cabal b/relational-query-HDBC.cabal --- a/relational-query-HDBC.cabal +++ b/relational-query-HDBC.cabal @@ -1,5 +1,5 @@ name: relational-query-HDBC -version: 0.6.5.0 +version: 0.6.6.0 synopsis: HDBC instance of relational-query and typed query interface for HDBC description: This package contains the HDBC instance of relational-query and the typed query interface for HDBC. @@ -27,6 +27,7 @@ exposed-modules: Database.HDBC.Record.Persistable Database.HDBC.Record.TH + Database.HDBC.Record.Sequence Database.HDBC.Record.Statement Database.HDBC.Record.Query Database.HDBC.Record.Update @@ -58,8 +59,9 @@ , product-isomorphic >= 0.0.3 , names-th + , sql-words , persistable-record >= 0.6 - , relational-query >= 0.10 + , relational-query >= 0.10.1 , relational-schemas , HDBC >=2 , HDBC-session diff --git a/src/Database/HDBC/Query/TH.hs b/src/Database/HDBC/Query/TH.hs --- a/src/Database/HDBC/Query/TH.hs +++ b/src/Database/HDBC/Query/TH.hs @@ -16,6 +16,7 @@ -- and HDBC instances correspond to RDB table schema. module Database.HDBC.Query.TH ( makeRelationalRecord, + makeRelationalRecord', defineTableDefault', defineTableDefault, @@ -49,7 +50,7 @@ import Database.HDBC.Record.Persistable () import Database.HDBC.Schema.Driver - (runLog, newLogChan, takeLogs, Driver, getFields, getPrimaryKey) + (runLog, newLogChan, takeLogs, Driver, driverConfig, getFields, getPrimaryKey) defineInstancesForSqlValue :: TypeQ -- ^ Record type constructor. @@ -60,14 +61,20 @@ |] -- | Generate all persistable templates against defined record like type constructor. -makeRelationalRecord :: Name -- ^ Type constructor name - -> Q [Dec] -- ^ Result declaration -makeRelationalRecord recTypeName = do - rr <- Relational.makeRelationalRecordDefault recTypeName +makeRelationalRecord' :: Config + -> Name -- ^ Type constructor name + -> Q [Dec] -- ^ Result declaration +makeRelationalRecord' config recTypeName = do + rr <- Relational.makeRelationalRecordDefault' config recTypeName (((typeCon, avs), _), _) <- reifyRecordType recTypeName ps <- defineSqlPersistableInstances [t| SqlValue |] typeCon avs return $ rr ++ ps +-- | Generate all persistable templates against defined record like type constructor. +makeRelationalRecord :: Name -- ^ Type constructor name + -> Q [Dec] -- ^ Result declaration +makeRelationalRecord = makeRelationalRecord' defaultConfig + -- | Generate all HDBC templates about table except for constraint keys. defineTableDefault' :: Config -- ^ Configuration to generate query with -> String -- ^ Schema name @@ -96,16 +103,15 @@ sqlvD <- defineInstancesForSqlValue . fst $ recordTemplate (recordConfig $ nameConfig config) schema table 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 - -> [Name] -- ^ Derivings - -> Q [Dec] -- ^ Result declaration -defineTableFromDB' connect config drv scm tbl derives = do +tableAlongWithSchema :: 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 + -> [Name] -- ^ Derivings + -> Q [Dec] -- ^ Result declaration +tableAlongWithSchema connect config drv scm tbl derives = do let getDBinfo = do logChan <- newLogChan $ verboseAsCompilerWarning config infoP <- withConnectionIO connect @@ -130,6 +136,18 @@ defineTableDefault config scm tbl cols derives primaryIxs (listToMaybe notNullIdxs) +{-# DEPRECATED defineTableFromDB' "Use defineTableFromDB with updated driverConfig field of Driver argument." #-} +-- | 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 + -> [Name] -- ^ Derivings + -> Q [Dec] -- ^ Result declaration +defineTableFromDB' = tableAlongWithSchema + -- | Generate all HDBC templates using system catalog informations. defineTableFromDB :: IConnection conn => IO conn -- ^ Connect action to system catalog database @@ -138,7 +156,7 @@ -> String -- ^ Table name -> [Name] -- ^ Derivings -> Q [Dec] -- ^ Result declaration -defineTableFromDB connect = defineTableFromDB' connect defaultConfig +defineTableFromDB connect driver = tableAlongWithSchema connect (driverConfig driver) driver -- | Verify composed 'Query' and inline it in compile type. inlineVerifiedQuery :: IConnection conn diff --git a/src/Database/HDBC/Record/Sequence.hs b/src/Database/HDBC/Record/Sequence.hs new file mode 100644 --- /dev/null +++ b/src/Database/HDBC/Record/Sequence.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | +-- Module : Database.HDBC.Record.Sequence +-- Copyright : 2017 Kei Hibino +-- License : BSD3 +-- +-- Maintainer : ex8k.hibino@gmail.com +-- Stability : experimental +-- Portability : unknown +-- +-- This module provides operations for sequence tables of relational-query with HDBC. +module Database.HDBC.Record.Sequence ( + pool, autoPool, + + unsafePool, unsafeAutoPool, + ) where + +import Control.Applicative ((<$>)) +import Control.Monad (when, void) +import System.IO.Unsafe (unsafeInterleaveIO) +import Database.HDBC (IConnection, SqlValue, commit) +import Database.HDBC.Session (withConnectionIO) + +import Language.SQL.Keyword (Keyword (FOR, UPDATE)) +import Database.Record (FromSql, ToSql, PersistableWidth) +import Database.Relational + (relationalQuery', ShowConstantTermsSQL, Relation, ) +import qualified Database.Relational as Relation +import qualified Database.Relational.Table as Table +import Database.HDBC.Record.Persistable () +import Database.HDBC.Record.Statement (bind, executeBound) +import Database.HDBC.Record.Query (prepareQuery, fetch) +import Database.HDBC.Record.Update (runUpdate) + +import Database.Relational (Sequence (..), Binding, Number, ) +import qualified Database.Relational as Relational + + +-- | Unsafely get a raw sequence number pool of specified size +unsafePool :: (FromSql SqlValue s, PersistableWidth s, + ToSql SqlValue i, ShowConstantTermsSQL i, + Bounded i, Integral i, Show i, IConnection conn) + => IO conn + -> i + -> Sequence s i + -> IO [i] +unsafePool connAct sz seqt = withConnectionIO connAct $ \conn -> do + let t = seqTable seqt + name = Table.name t + pq <- prepareQuery conn $ relationalQuery' (Relation.table t) [FOR, UPDATE] + + es <- executeBound $ pq `bind` () + seq0 <- maybe + (fail $ "No record found in sequence table: " ++ name) + (return . seqExtract seqt) + =<< fetch es + when (maxBound - seq0 < sz) . fail + $ "Not enough size in sequence table: " + ++ name ++ ": " ++ show (maxBound - seq0) ++ " < " ++ show sz + + let seq1 = seq0 + sz + void $ runUpdate conn (Relational.updateNumber seq1 seqt) () + maybe (return ()) (const . fail $ "More than two record found in seq table: " ++ name) =<< fetch es + + commit conn + return [seq0 + 1 .. seq1] + +-- | Unsafely get a raw lazy pool of sequence number +unsafeAutoPool :: (FromSql SqlValue s, PersistableWidth s, + ToSql SqlValue i, ShowConstantTermsSQL i, + Bounded i, Integral i, Show i, IConnection conn) + => IO conn + -> i + -> Sequence s i + -> IO [i] +unsafeAutoPool connAct sz seqt = loop where + loop = unsafeInterleaveIO $ do + hd <- unsafePool connAct sz seqt + (hd ++) <$> loop + + +-- | Get a sized sequence number pool corresponding proper table 'r' +pool :: (FromSql SqlValue s, ToSql SqlValue i, + PersistableWidth i, ShowConstantTermsSQL i, + Bounded i, Integral i, Show i, IConnection conn, + Binding r s i) + => IO conn + -> i + -> Relation () r + -> IO [Number r i] +pool connAct sz = + (map Relational.unsafeSpecifyNumber <$>) + . unsafePool connAct sz + . Relational.fromRelation + +-- | Get a lazy pool corresponding proper table 'r' +autoPool :: (FromSql SqlValue s, + ToSql SqlValue i, ShowConstantTermsSQL i, + Bounded i, Integral i, Show i, IConnection conn, + Binding r s i) + => IO conn + -> i + -> Relation () r + -> IO [Number r i] +autoPool connAct sz = + (map Relational.unsafeSpecifyNumber <$>) + . unsafeAutoPool connAct sz + . Relational.fromRelation diff --git a/src/Database/HDBC/Schema/Driver.hs b/src/Database/HDBC/Schema/Driver.hs --- a/src/Database/HDBC/Schema/Driver.hs +++ b/src/Database/HDBC/Schema/Driver.hs @@ -1,6 +1,6 @@ -- | -- Module : Database.HDBC.Schema.Driver --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -16,22 +16,24 @@ LogChan, newLogChan, takeLogs, putWarning, putError, putVerbose, failWith, hoistMaybe, maybeIO, - Driver(Driver, typeMap, getFieldsWithMap, getPrimaryKey), + Driver(Driver, typeMap, driverConfig, getFieldsWithMap, getPrimaryKey), emptyDriver, getFields ) where -import Database.HDBC (IConnection) -import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) -import Data.Monoid (mempty, (<>)) -import Data.DList (DList, toList) +import Language.Haskell.TH (TypeQ) import Control.Applicative ((<$>), pure, (<*>)) import Control.Monad (MonadPlus, mzero) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT (..)) -import Language.Haskell.TH (TypeQ) +import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) +import Data.Monoid (mempty, (<>)) +import Data.DList (DList, toList) +import Database.HDBC (IConnection) +import Database.Relational (Config, defaultConfig) + -- | 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)] @@ -109,6 +111,9 @@ { -- | Custom type mapping of this driver typeMap :: TypeMap + -- | Custom configuration for this driver + , driverConfig :: Config + -- | Get column name and Haskell type pairs and not-null columns index. , getFieldsWithMap :: TypeMap -- Custom type mapping -> conn -- Connection to query system catalog @@ -127,9 +132,16 @@ } -- | Empty definition of 'Driver' -emptyDriver :: IConnection conn => Driver conn -emptyDriver = Driver [] (\_ _ _ _ _ -> return ([],[])) (\_ _ _ _ -> return []) +emptyDriver :: IConnection conn + => Driver conn +emptyDriver = Driver [] defaultConfig (\_ _ _ _ _ -> return ([],[])) (\_ _ _ _ -> return []) -- | Helper function to call 'getFieldsWithMap' using 'typeMap' of 'Driver'. -getFields :: IConnection conn => Driver conn -> conn -> LogChan -> String -> String -> IO ([(String, TypeQ)], [Int]) +getFields :: IConnection conn + => Driver conn -- ^ driver record + -> conn -- ^ connection + -> LogChan -- ^ log channel + -> String -- ^ schema name string + -> String -- ^ table name 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 --- a/src/Database/HDBC/Schema/IBMDB2.hs +++ b/src/Database/HDBC/Schema/IBMDB2.hs @@ -4,7 +4,7 @@ -- | -- Module : Database.HDBC.Schema.IBMDB2 --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -40,10 +40,11 @@ (normalizeColumn, notNull, getType, columnsQuerySQL, primaryKeyQuerySQL) import Database.Relational.Schema.DB2Syscat.Columns (Columns) import qualified Database.Relational.Schema.DB2Syscat.Columns as Columns +import Database.Relational.Schema.DB2Syscat.Config (config) import Database.HDBC.Schema.Driver (TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe, - Driver, getFieldsWithMap, getPrimaryKey, emptyDriver) + Driver, driverConfig, getFieldsWithMap, getPrimaryKey, emptyDriver) instance FromSql SqlValue Columns @@ -104,3 +105,4 @@ driverIBMDB2 = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } + { driverConfig = config } diff --git a/src/Database/HDBC/Schema/MySQL.hs b/src/Database/HDBC/Schema/MySQL.hs --- a/src/Database/HDBC/Schema/MySQL.hs +++ b/src/Database/HDBC/Schema/MySQL.hs @@ -4,7 +4,7 @@ -- | -- Module : Database.HDBC.Schema.MySQL --- Copyright : 2013 Sho KURODA +-- Copyright : 2013 Sho KURODA, 2017 Kei Hibiono -- License : BSD3 -- -- Maintainer : krdlab@gmail.com @@ -36,6 +36,7 @@ , maybeIO , hoistMaybe , Driver + , driverConfig , getFieldsWithMap , getPrimaryKey , emptyDriver @@ -49,6 +50,7 @@ import Database.Relational.Schema.MySQLInfo.Columns (Columns) import qualified Database.Relational.Schema.MySQLInfo.Columns as Columns +import Database.Relational.Schema.MySQLInfo.Config (config) instance FromSql SqlValue Columns @@ -106,3 +108,4 @@ driverMySQL = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } + { driverConfig = config } diff --git a/src/Database/HDBC/Schema/Oracle.hs b/src/Database/HDBC/Schema/Oracle.hs --- a/src/Database/HDBC/Schema/Oracle.hs +++ b/src/Database/HDBC/Schema/Oracle.hs @@ -2,8 +2,8 @@ {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-} -- | --- Module : Database.HDBC.Schema.MySQL --- Copyright : 2013 Shohei Yasutake +-- Module : Database.HDBC.Schema.Oracle +-- Copyright : 2013 Shohei Yasutake, 2017 Kei Hibiono -- License : BSD3 -- -- Maintainer : amutake.s@gmail.com @@ -29,7 +29,7 @@ import Database.HDBC.Record.Persistable () import Database.HDBC.Schema.Driver ( TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe, - Driver, getFieldsWithMap, getPrimaryKey, emptyDriver + Driver, driverConfig, getFieldsWithMap, getPrimaryKey, emptyDriver ) import Database.Relational.Schema.Oracle @@ -38,6 +38,7 @@ ) import Database.Relational.Schema.OracleDataDictionary.TabColumns (DbaTabColumns) import qualified Database.Relational.Schema.OracleDataDictionary.TabColumns as Cols +import Database.Relational.Schema.OracleDataDictionary.Config (config) instance FromSql SqlValue DbaTabColumns @@ -96,3 +97,4 @@ driverOracle = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } + { driverConfig = config } diff --git a/src/Database/HDBC/Schema/PostgreSQL.hs b/src/Database/HDBC/Schema/PostgreSQL.hs --- a/src/Database/HDBC/Schema/PostgreSQL.hs +++ b/src/Database/HDBC/Schema/PostgreSQL.hs @@ -4,7 +4,7 @@ -- | -- Module : Database.HDBC.Schema.PostgreSQL --- Copyright : 2013 Kei Hibino +-- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com @@ -39,10 +39,11 @@ 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.Relational.Schema.PgCatalog.Config (config) import Database.HDBC.Schema.Driver (TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe, - Driver, getFieldsWithMap, getPrimaryKey, emptyDriver) + Driver, driverConfig, getFieldsWithMap, getPrimaryKey, emptyDriver) instance FromSql SqlValue PgAttribute @@ -113,3 +114,4 @@ driverPostgreSQL = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } + { driverConfig = config } diff --git a/src/Database/HDBC/Schema/SQLServer.hs b/src/Database/HDBC/Schema/SQLServer.hs --- a/src/Database/HDBC/Schema/SQLServer.hs +++ b/src/Database/HDBC/Schema/SQLServer.hs @@ -4,7 +4,7 @@ -- | -- Module : Database.HDBC.Schema.SQLServer --- Copyright : 2013 Shohei Murayama +-- Copyright : 2013 Shohei Murayama, 2017 Kei Hibiono -- License : BSD3 -- -- Maintainer : shohei.murayama@gmail.com @@ -27,13 +27,14 @@ import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () import Database.HDBC.Schema.Driver - (TypeMap, LogChan, putVerbose, failWith, maybeIO, - Driver, hoistMaybe, getFieldsWithMap, getPrimaryKey, emptyDriver) + (TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe, + Driver, driverConfig, getFieldsWithMap, getPrimaryKey, emptyDriver) import Database.Record (FromSql, ToSql) 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 Database.Relational.Schema.SQLServerSyscat.Config (config) import Language.Haskell.TH (TypeQ) @@ -94,3 +95,4 @@ driverSQLServer = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } + { driverConfig = config } diff --git a/src/Database/HDBC/Schema/SQLite3.hs b/src/Database/HDBC/Schema/SQLite3.hs --- a/src/Database/HDBC/Schema/SQLite3.hs +++ b/src/Database/HDBC/Schema/SQLite3.hs @@ -4,7 +4,7 @@ -- | -- Module : Database.HDBC.Schema.SQLite3 --- Copyright : 2013 Shohei Murayama +-- Copyright : 2013 Shohei Murayama, 2017 Kei Hibiono -- License : BSD3 -- -- Maintainer : shohei.murayama@gmail.com @@ -28,14 +28,15 @@ import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () import Database.HDBC.Schema.Driver - (TypeMap, LogChan, putVerbose, failWith, maybeIO, - Driver, hoistMaybe, getFieldsWithMap, getPrimaryKey, emptyDriver) + (TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe, + Driver, driverConfig, getFieldsWithMap, getPrimaryKey, emptyDriver) import Database.Record (FromSql, ToSql) 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 Database.Relational.Schema.SQLite3Syscat.Config (config) import Language.Haskell.TH (TypeQ) @@ -113,3 +114,4 @@ driverSQLite3 = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } + { driverConfig = config }