packages feed

relational-query-HDBC 0.6.5.0 → 0.6.6.0

raw patch · 11 files changed

+201/−42 lines, 11 filesdep +sql-wordsdep ~relational-queryPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: sql-words

Dependency ranges changed: relational-query

API changes (from Hackage documentation)

+ Database.HDBC.Query.TH: makeRelationalRecord' :: Config -> Name -> Q [Dec]
+ Database.HDBC.Record.Sequence: 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]
+ Database.HDBC.Record.Sequence: 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]
+ Database.HDBC.Record.Sequence: 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]
+ Database.HDBC.Record.Sequence: 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]
+ Database.HDBC.Schema.Driver: [driverConfig] :: Driver conn -> Config
- Database.HDBC.Schema.Driver: Driver :: TypeMap -> (TypeMap -> conn -> LogChan -> String -> String -> IO ([(String, TypeQ)], [Int])) -> (conn -> LogChan -> String -> String -> IO [String]) -> Driver conn
+ Database.HDBC.Schema.Driver: Driver :: TypeMap -> Config -> (TypeMap -> conn -> LogChan -> String -> String -> IO ([(String, TypeQ)], [Int])) -> (conn -> LogChan -> String -> String -> IO [String]) -> Driver conn

Files

ChangeLog.md view
@@ -1,5 +1,10 @@ <!-- -*- Markdown -*- --> +## 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
relational-query-HDBC.cabal view
@@ -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
src/Database/HDBC/Query/TH.hs view
@@ -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
+ src/Database/HDBC/Record/Sequence.hs view
@@ -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
src/Database/HDBC/Schema/Driver.hs view
@@ -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)
src/Database/HDBC/Schema/IBMDB2.hs view
@@ -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 }
src/Database/HDBC/Schema/MySQL.hs view
@@ -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 }
src/Database/HDBC/Schema/Oracle.hs view
@@ -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 }
src/Database/HDBC/Schema/PostgreSQL.hs view
@@ -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 }
src/Database/HDBC/Schema/SQLServer.hs view
@@ -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 }
src/Database/HDBC/Schema/SQLite3.hs view
@@ -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 }