relational-query-HDBC-0.7.2.0/0000755000000000000000000000000013466567526014063 5ustar0000000000000000relational-query-HDBC-0.7.2.0/Setup.hs0000644000000000000000000000005613466567526015520 0ustar0000000000000000import Distribution.Simple main = defaultMain relational-query-HDBC-0.7.2.0/ChangeLog.md0000644000000000000000000000331213466567526016233 0ustar0000000000000000 ## 0.7.2.0 - apply new module names of relational-schema. ## 0.7.1.1 - fix build for old GHCs. ## 0.7.1.0 - add convertible instances of Word8 type and Word16 type. - add foldlFetch and forFetch. ## 0.7.0.1 - update haddock about bracketed-prepare operations. ## 0.7.0.0 - support overwriting of type-map along with column-name. - replace `execute` and `executeNoFetch`. ## 0.6.8.1 - apply renamed LiteralSQL class. ## 0.6.8.0 - apply enableWarning flag in Config type. ## 0.6.7.1 - fix. do safe convert for integral conversion from SQL value. - add test suite of conversion from and to SQL value. ## 0.6.7.0 - add bulkInsert definitions, and deprecate chunksInsert. - enable the mis-disabled warning message of executeNoFetch. - make statement operations strict. ## 0.6.6.1 - update version constraint. ( along with re-versioned relational-query. ) ## 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 ## 0.6.4.1 - apply integrated namespace with new exported symbols. ## 0.6.4.0 - add new function name definitions to execute bounded statement. ## 0.6.2.1 - add tested-with 8.2.1. ## 0.6.2.0 - Apply generic instances. ## 0.6.0.2 - Add tested-with. ## 0.6.0.1 - Update compatibility for GHC 8. - Drop old tests of Oracle. ## 0.6.0.0 - Use updated template of persistable-record. - Drop persistableSqlValue. ## 0.5.0.0 - Use updated template of relational-query. - Drop old examples of Oracle. ## 0.4.0.0 - TH quotation of derive class names. ## 0.3.0.0 - Hide chunksInsertActions. - Add withPrepareDelete. ## 0.2.0.0 - Add logging interface for schema driver. relational-query-HDBC-0.7.2.0/LICENSE0000644000000000000000000000275613466567526015102 0ustar0000000000000000Copyright (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. relational-query-HDBC-0.7.2.0/relational-query-HDBC.cabal0000644000000000000000000001027013466567526021042 0ustar0000000000000000name: relational-query-HDBC version: 0.7.2.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. . Generating Database table definitions and functions for relational-query by reading table and index definitions from Database system catalogs. homepage: http://khibino.github.io/haskell-relational-record/ 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-2019 Kei Hibino, 2013 Shohei Murayama, 2013 Shohei Yasutake, 2013 Sho KURODA category: Database build-type: Simple cabal-version: >=1.10 tested-with: GHC == 8.6.1, GHC == 8.6.2, GHC == 8.6.3, GHC == 8.6.4, GHC == 8.6.5 , GHC == 8.4.1, GHC == 8.4.2, GHC == 8.4.3, GHC == 8.4.4 , GHC == 8.2.1, GHC == 8.2.2 , GHC == 8.0.1, GHC == 8.0.2 , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3 , GHC == 7.8.1, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4 , GHC == 7.6.1, GHC == 7.6.2, GHC == 7.6.3 , GHC == 7.4.1, GHC == 7.4.2 extra-source-files: ChangeLog.md library 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 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 , transformers , convertible , template-haskell , dlist , th-data-compat , product-isomorphic >= 0.0.3 , names-th , sql-words , persistable-record >= 0.6 , relational-query >= 0.12.2 , relational-schemas >= 0.1.7 , HDBC >=2 , HDBC-session hs-source-dirs: src ghc-options: -Wall if impl(ghc >= 8) ghc-options: -Wcompat -Wnoncanonical-monadfail-instances default-language: Haskell2010 test-suite convertible-iso build-depends: base <5 , QuickCheck , quickcheck-simple , convertible , HDBC , relational-query-HDBC type: exitcode-stdio-1.0 main-is: convertibleIso.hs hs-source-dirs: test ghc-options: -Wall if impl(ghc >= 8) ghc-options: -Wcompat -Wnoncanonical-monadfail-instances 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 relational-query-HDBC-0.7.2.0/test/0000755000000000000000000000000013466567526015042 5ustar0000000000000000relational-query-HDBC-0.7.2.0/test/convertibleIso.hs0000644000000000000000000000345413466567526020373 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} import Control.Applicative ((<$>)) import Data.Int (Int8, Int16) import Data.Convertible (Convertible, safeConvert, ConvertResult) import Database.HDBC (SqlValue (SqlInteger)) import Test.QuickCheck (Arbitrary (..), resize) import Test.QuickCheck.Simple (qcTest, defaultMain) import Database.HDBC.Record.Persistable () prop_toFromQvInt8 :: Int8 -> Bool prop_toFromQvInt8 i8 = Right i8 == (safeConvert =<< sv) where sv :: ConvertResult SqlValue sv = safeConvert i8 prop_toFromQvInt16 :: Int16 -> Bool prop_toFromQvInt16 i16 = Right i16 == (safeConvert =<< sv) where sv :: ConvertResult SqlValue sv = safeConvert i16 newtype IntegerR i = IntegerR Integer deriving (Eq, Show) instance Arbitrary (IntegerR Int8) where arbitrary = IntegerR <$> resize 1000 arbitrary instance Arbitrary (IntegerR Int16) where arbitrary = IntegerR <$> resize 100000 arbitrary prop_fromToQvBounded :: (Integral a, Convertible SqlValue a, Convertible a SqlValue) => a -> a -> IntegerR a -> Bool prop_fromToQvBounded mn' mx' (IntegerR i) | i < mn || mx < i = True | otherwise = Right sv == (safeConvert =<< ix) where sv = SqlInteger i ix = safeConvert sv `asTypeOf` Right mn' mn = fromIntegral mn' mx = fromIntegral mx' prop_fromToQvInt8 :: IntegerR Int8 -> Bool prop_fromToQvInt8 = prop_fromToQvBounded minBound maxBound prop_fromToQvInt16 :: IntegerR Int16 -> Bool prop_fromToQvInt16 = prop_fromToQvBounded minBound maxBound main :: IO () main = defaultMain [ qcTest "int8 - to SqlV from SqlV" prop_toFromQvInt8 , qcTest "int16 - to SqlV from SqlV" prop_toFromQvInt16 , qcTest "int8 - from SqlV to SqlV" prop_fromToQvInt8 , qcTest "int16 - from SqlV to SqlV" prop_fromToQvInt16 ] relational-query-HDBC-0.7.2.0/src/0000755000000000000000000000000013466567526014652 5ustar0000000000000000relational-query-HDBC-0.7.2.0/src/Database/0000755000000000000000000000000013466567526016356 5ustar0000000000000000relational-query-HDBC-0.7.2.0/src/Database/HDBC/0000755000000000000000000000000013466567526017056 5ustar0000000000000000relational-query-HDBC-0.7.2.0/src/Database/HDBC/SqlValueExtra.hs0000644000000000000000000000301413466567526022150 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -fno-warn-orphans #-} -- | -- Module : Database.HDBC.SqlValueExtra -- Copyright : 2013-2018 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 (Int8, Int16, Int32) import Data.Word (Word8, Word16) import Database.HDBC (SqlValue) -- Convert from narrower width than Int32 safeConvertFromIntegral32 :: Integral a => a -> ConvertResult SqlValue safeConvertFromIntegral32 i = safeConvert (fromIntegral i :: Int32) safeConvertToIntegral32 :: Convertible Int32 a => SqlValue -> ConvertResult a safeConvertToIntegral32 v = safeConvert =<< (safeConvert v :: ConvertResult Int32) instance Convertible Int8 SqlValue where safeConvert = safeConvertFromIntegral32 instance Convertible SqlValue Int8 where safeConvert = safeConvertToIntegral32 instance Convertible Int16 SqlValue where safeConvert = safeConvertFromIntegral32 instance Convertible SqlValue Int16 where safeConvert = safeConvertToIntegral32 instance Convertible Word8 SqlValue where safeConvert = safeConvertFromIntegral32 instance Convertible SqlValue Word8 where safeConvert = safeConvertToIntegral32 instance Convertible Word16 SqlValue where safeConvert = safeConvertFromIntegral32 instance Convertible SqlValue Word16 where safeConvert = safeConvertToIntegral32 relational-query-HDBC-0.7.2.0/src/Database/HDBC/Record.hs0000644000000000000000000000206613466567526020634 0ustar0000000000000000-- | -- 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" #-} relational-query-HDBC-0.7.2.0/src/Database/HDBC/Schema/0000755000000000000000000000000013466567526020256 5ustar0000000000000000relational-query-HDBC-0.7.2.0/src/Database/HDBC/Schema/Driver.hs0000644000000000000000000001126313466567526022050 0ustar0000000000000000-- | -- Module : Database.HDBC.Schema.Driver -- Copyright : 2013-2017 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, Log, foldLog, LogChan, emptyLogChan, takeLogs, putWarning, putError, putVerbose, failWith, hoistMaybe, maybeIO, Driver(Driver, typeMap, driverConfig, getFieldsWithMap, getPrimaryKey), emptyDriver, getFields, ) where 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 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)] -- | Log string type for compile time. data Log = Verbose String | Warning String | Error String -- | Folding operation of 'Log' type. foldLog :: (String -> t) -> (String -> t) -> (String -> t) -> Log -> t foldLog vf wf ef = d where d (Verbose m) = vf m d (Warning m) = wf m d (Error m) = ef m -- | Channel to store compile-time warning messages. newtype LogChan = LogChan { chan :: IORef (DList Log) } -- | Build and return a new instance of 'LogChan'. emptyLogChan :: IO LogChan emptyLogChan = LogChan <$> newIORef mempty -- | Take all logs list from channel. takeLogs :: LogChan -> IO [Log] takeLogs lchan = do xs <- readIORef $ chan lchan writeIORef (chan lchan) mempty return $ toList xs putLog :: LogChan -> Log -> IO () putLog lchan m = chan lchan `modifyIORef` (<> pure m) -- | Push a warning string into 'LogChan'. putWarning :: LogChan -> String -> IO () putWarning lchan = putLog lchan . Warning -- | Push an error string into 'LogChan'. putError :: LogChan -> String -> IO () putError lchan = putLog lchan . Error -- | Put verbose compile-time message as warning when 'verboseAsWarning'. putVerbose :: LogChan -> String -> IO () putVerbose lchan = putLog lchan . Verbose -- | Push an error string into 'LogChan' and return failed context. failWith :: LogChan -> String -> MaybeT IO a failWith lchan m = do lift $ putError lchan m mzero hoistM :: MonadPlus m => Maybe a -> m a hoistM = maybe mzero return -- | Hoist from 'Maybe' context into 'MaybeT'. hoistMaybe :: Monad m => Maybe a -> MaybeT m a hoistMaybe = hoistM maybeT :: Functor f => b -> (a -> b) -> MaybeT f a -> f b maybeT zero f = (maybe zero f <$>) . runMaybeT -- | Run 'MaybeT' with default value. maybeIO :: b -> (a -> b) -> MaybeT IO a -> IO b maybeIO = maybeT -- | Interface type to load database system catalog via HDBC. data Driver conn = Driver { -- | 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 -> LogChan -> 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 -> LogChan -> 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 [] defaultConfig (\_ _ _ _ _ -> return ([],[])) (\_ _ _ _ -> return []) -- | Helper function to call 'getFieldsWithMap' using 'typeMap' of 'Driver'. 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) relational-query-HDBC-0.7.2.0/src/Database/HDBC/Schema/MySQL.hs0000644000000000000000000001054613466567526021565 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.MySQL -- Copyright : 2013 Sho KURODA, 2017-2019 Kei Hibiono -- License : BSD3 -- -- Maintainer : krdlab@gmail.com -- Stability : experimental -- Portability : unknown module Database.HDBC.Schema.MySQL ( driverMySQL ) where import Prelude hiding (length) import Language.Haskell.TH (TypeQ) import Control.Applicative ((<$>), (<|>)) import Control.Monad (guard) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT) import qualified Data.List as List import Data.Map (fromList) import Database.HDBC (IConnection, SqlValue) import Database.Record (FromSql, ToSql) import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () import Database.HDBC.Schema.Driver ( TypeMap , LogChan , putVerbose , failWith , maybeIO , hoistMaybe , Driver , driverConfig , getFieldsWithMap , getPrimaryKey , emptyDriver ) import Database.Relational.Schema.MySQL ( normalizeColumn , notNull , getType , columnsQuerySQL , primaryKeyQuerySQL ) import Database.Relational.Schema.MySQL.Columns (Columns) import qualified Database.Relational.Schema.MySQL.Columns as Columns import Database.Relational.Schema.MySQL (config) instance FromSql SqlValue Columns instance ToSql SqlValue Columns logPrefix :: String -> String logPrefix = ("MySQL: " ++) putLog :: LogChan -> String -> IO () putLog lchan = putVerbose lchan . logPrefix compileError :: LogChan -> String -> MaybeT IO a compileError lchan = failWith lchan . logPrefix getPrimaryKey' :: IConnection conn => conn -> LogChan -> String -> String -> IO [String] getPrimaryKey' conn lchan scm tbl = do primCols <- runQuery' conn primaryKeyQuerySQL (scm, tbl) let primaryKeyCols = normalizeColumn <$> primCols putLog lchan $ "getPrimaryKey: primary key = " ++ show primaryKeyCols return primaryKeyCols getColumns' :: IConnection conn => TypeMap -> conn -> LogChan -> String -> String -> IO ([(String, TypeQ)], [Int]) getColumns' tmap conn lchan scm tbl = maybeIO ([], []) id $ do cols <- lift $ runQuery' conn columnsQuerySQL (scm, tbl) guard (not $ null cols) <|> compileError lchan ("getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl) let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols lift . putLog lchan $ "getFields: num of columns = " ++ show (List.length cols) ++ ", not null columns = " ++ show notNullIdxs types <- mapM getType' cols return (types, notNullIdxs) where getType' col = hoistMaybe (getType (fromList tmap) col) <|> compileError lchan ("Type mapping is not defined against MySQL type: " ++ Columns.dataType col) -- | Driver implementation driverMySQL :: IConnection conn => Driver conn driverMySQL = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } { driverConfig = config } relational-query-HDBC-0.7.2.0/src/Database/HDBC/Schema/SQLite3.hs0000644000000000000000000001101413466567526022033 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.SQLite3 -- Copyright : 2013 Shohei Murayama, 2017-2019 Kei Hibiono -- License : BSD3 -- -- Maintainer : shohei.murayama@gmail.com -- Stability : experimental -- Portability : unknown module Database.HDBC.Schema.SQLite3 ( driverSQLite3 ) where import qualified Database.Relational.Schema.SQLite3.IndexInfo as IndexInfo import qualified Database.Relational.Schema.SQLite3.IndexList as IndexList import qualified Database.Relational.Schema.SQLite3.TableInfo as TableInfo import Control.Applicative ((<|>)) import Control.Monad (guard) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT) 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, 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.SQLite3.IndexInfo (IndexInfo) import Database.Relational.Schema.SQLite3.IndexList (IndexList) import Database.Relational.Schema.SQLite3.TableInfo (TableInfo) import Database.Relational.Schema.SQLite3 (config) import Language.Haskell.TH (TypeQ) instance FromSql SqlValue TableInfo instance ToSql SqlValue TableInfo instance FromSql SqlValue IndexList instance ToSql SqlValue IndexList instance FromSql SqlValue IndexInfo instance ToSql SqlValue IndexInfo logPrefix :: String -> String logPrefix = ("SQLite3: " ++) putLog :: LogChan -> String -> IO () putLog lchan = putVerbose lchan . logPrefix compileError :: LogChan -> String -> MaybeT IO a compileError lchan = failWith lchan . logPrefix getPrimaryKey' :: IConnection conn => conn -> LogChan -> String -> String -> IO [String] getPrimaryKey' conn lchan scm tbl = do tblinfo <- runQuery' conn (tableInfoQuerySQL scm tbl) () let primColumns = [ normalizeColumn $ TableInfo.name ti | ti <- tblinfo, TableInfo.pk ti == 1 ] if length primColumns <= 1 then do putLog lchan $ "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 lchan $ "getPrimaryKey: keys=" ++ show primColumns' return primColumns' getColumns' :: IConnection conn => TypeMap -> conn -> LogChan -> String -> String -> IO ([(String, TypeQ)], [Int]) getColumns' tmap conn lchan scm tbl = maybeIO ([], []) id $ do rows <- lift $ runQuery' conn (tableInfoQuerySQL scm tbl) () guard (not $ null rows) <|> compileError lchan ("getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl) let columnId = TableInfo.cid let notNullIdxs = map (fromIntegral . columnId) . filter notNull $ rows lift . putLog lchan $ "getFields: num of columns = " ++ show (length rows) ++ ", not null columns = " ++ show notNullIdxs let getType' ti = hoistMaybe (getType (fromList tmap) ti) <|> compileError lchan ("Type mapping is not defined against SQLite3 type: " ++ normalizeType (TableInfo.ctype ti)) types <- mapM getType' rows return (types, notNullIdxs) -- | Driver implementation driverSQLite3 :: IConnection conn => Driver conn driverSQLite3 = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } { driverConfig = config } relational-query-HDBC-0.7.2.0/src/Database/HDBC/Schema/SQLServer.hs0000644000000000000000000000673613466567526022454 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.SQLServer -- Copyright : 2013 Shohei Murayama, 2017-2019 Kei Hibiono -- License : BSD3 -- -- Maintainer : shohei.murayama@gmail.com -- Stability : experimental -- Portability : unknown module Database.HDBC.Schema.SQLServer ( driverSQLServer, ) where import qualified Database.Relational.Schema.SQLServer.Columns as Columns import qualified Database.Relational.Schema.SQLServer.Types as Types import Control.Applicative ((<$>), (<|>)) import Control.Monad (guard) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT) 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, 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.SQLServer.Columns (Columns) import Database.Relational.Schema.SQLServer.Types (Types) import Database.Relational.Schema.SQLServer (config) import Language.Haskell.TH (TypeQ) instance FromSql SqlValue Columns instance ToSql SqlValue Columns instance FromSql SqlValue Types instance ToSql SqlValue Types logPrefix :: String -> String logPrefix = ("SQLServer: " ++) putLog :: LogChan -> String -> IO () putLog lchan = putVerbose lchan . logPrefix compileError :: LogChan -> String -> MaybeT IO a compileError lchan = failWith lchan . logPrefix getPrimaryKey' :: IConnection conn => conn -> LogChan -> String -> String -> IO [String] getPrimaryKey' conn lchan scm tbl = do prims <- catMaybes <$> runQuery' conn primaryKeyQuerySQL (scm,tbl) let primColumns = map normalizeColumn prims putLog lchan $ "getPrimaryKey: keys=" ++ show primColumns return primColumns getColumns' :: IConnection conn => TypeMap -> conn -> LogChan -> String -> String -> IO ([(String, TypeQ)], [Int]) getColumns' tmap conn lchan scm tbl = maybeIO ([], []) id $ do rows <- lift $ runQuery' conn columnTypeQuerySQL (scm, tbl) guard (not $ null rows) <|> compileError lchan ("getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl) let columnId ((cols,_),_) = Columns.columnId cols - 1 let notNullIdxs = map (fromIntegral . columnId) . filter notNull $ rows lift . putLog lchan $ "getFields: num of columns = " ++ show (length rows) ++ ", not null columns = " ++ show notNullIdxs let getType' rec'@((_,typs),typScms) = hoistMaybe (getType (fromList tmap) rec') <|> compileError lchan ("Type mapping is not defined against SQLServer type: " ++ typScms ++ "." ++ Types.name typs) types <- mapM getType' rows return (types, notNullIdxs) -- | Driver implementation driverSQLServer :: IConnection conn => Driver conn driverSQLServer = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } { driverConfig = config } relational-query-HDBC-0.7.2.0/src/Database/HDBC/Schema/Oracle.hs0000644000000000000000000000651613466567526022027 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.Oracle -- Copyright : 2013 Shohei Yasutake, 2017-2019 Kei Hibiono -- License : BSD3 -- -- Maintainer : amutake.s@gmail.com -- Stability : experimental -- Portability : unknown module Database.HDBC.Schema.Oracle ( driverOracle ) where import Control.Applicative ((<$>), (<|>)) import Control.Monad (guard) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT) import Data.Char (toUpper) import Data.Map (fromList) import Data.Maybe (catMaybes) import Language.Haskell.TH (TypeQ) import Database.HDBC (IConnection, SqlValue) import Database.Record (FromSql, ToSql) import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () import Database.HDBC.Schema.Driver ( TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe, Driver, driverConfig, getFieldsWithMap, getPrimaryKey, emptyDriver ) import Database.Relational.Schema.Oracle ( normalizeColumn, notNull, getType , columnsQuerySQL, primaryKeyQuerySQL ) import Database.Relational.Schema.Oracle.TabColumns (DbaTabColumns) import qualified Database.Relational.Schema.Oracle.TabColumns as Cols import Database.Relational.Schema.Oracle (config) instance FromSql SqlValue DbaTabColumns instance ToSql SqlValue DbaTabColumns logPrefix :: String -> String logPrefix = ("Oracle: " ++) putLog :: LogChan -> String -> IO () putLog lchan = putVerbose lchan . logPrefix compileError :: LogChan -> String -> MaybeT IO a compileError lchan = failWith lchan . logPrefix getPrimaryKey' :: IConnection conn => conn -> LogChan -> String -- ^ owner name -> String -- ^ table name -> IO [String] -- ^ primary key names getPrimaryKey' conn lchan owner' tbl' = do let owner = map toUpper owner' tbl = map toUpper tbl' prims <- map normalizeColumn . catMaybes <$> runQuery' conn primaryKeyQuerySQL (owner, tbl) putLog lchan $ "getPrimaryKey: keys = " ++ show prims return prims getColumns' :: IConnection conn => TypeMap -> conn -> LogChan -> String -> String -> IO ([(String, TypeQ)], [Int]) getColumns' tmap conn lchan owner' tbl' = maybeIO ([], []) id $ do let owner = map toUpper owner' tbl = map toUpper tbl' cols <- lift $ runQuery' conn columnsQuerySQL (owner, tbl) guard (not $ null cols) <|> compileError lchan ("getFields: No columns found: owner = " ++ owner ++ ", table = " ++ tbl) let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols lift . putLog lchan $ "getFields: num of columns = " ++ show (length cols) ++ ", not null columns = " ++ show notNullIdxs let getType' col = hoistMaybe (getType (fromList tmap) col) <|> compileError lchan ("Type mapping is not defined against Oracle DB type: " ++ show (Cols.dataType col)) types <- mapM getType' cols return (types, notNullIdxs) -- | Driver for Oracle DB driverOracle :: IConnection conn => Driver conn driverOracle = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } { driverConfig = config } relational-query-HDBC-0.7.2.0/src/Database/HDBC/Schema/IBMDB2.hs0000644000000000000000000000647613466567526021526 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.IBMDB2 -- Copyright : 2013-2019 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.Applicative ((<$>), (<|>)) import Control.Monad (guard) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT) import Database.HDBC (IConnection, SqlValue) import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () import Database.Record (FromSql, ToSql) import Database.Relational.Schema.IBMDB2 (normalizeColumn, notNull, getType, columnsQuerySQL, primaryKeyQuerySQL) import Database.Relational.Schema.IBMDB2.Columns (Columns) import qualified Database.Relational.Schema.IBMDB2.Columns as Columns import Database.Relational.Schema.IBMDB2 (config) import Database.HDBC.Schema.Driver (TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe, Driver, driverConfig, getFieldsWithMap, getPrimaryKey, emptyDriver) instance FromSql SqlValue Columns instance ToSql SqlValue Columns logPrefix :: String -> String logPrefix = ("IBMDB2: " ++) putLog :: LogChan -> String -> IO () putLog lchan = putVerbose lchan . logPrefix compileError :: LogChan -> String -> MaybeT IO a compileError lchan = failWith lchan . logPrefix getPrimaryKey' :: IConnection conn => conn -> LogChan -> String -> String -> IO [String] getPrimaryKey' conn lchan scm' tbl' = do let tbl = map toUpper tbl' scm = map toUpper scm' primCols <- runQuery' conn primaryKeyQuerySQL (scm, tbl) let primaryKeyCols = normalizeColumn <$> primCols putLog lchan $ "getPrimaryKey: primary key = " ++ show primaryKeyCols return primaryKeyCols getColumns' :: IConnection conn => TypeMap -> conn -> LogChan -> String -> String -> IO ([(String, TypeQ)], [Int]) getColumns' tmap conn lchan scm' tbl' = maybeIO ([], []) id $ do let tbl = map toUpper tbl' scm = map toUpper scm' cols <- lift $ runQuery' conn columnsQuerySQL (scm, tbl) guard (not $ null cols) <|> compileError lchan ("getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl) let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols lift . putLog lchan $ "getFields: num of columns = " ++ show (List.length cols) ++ ", not null columns = " ++ show notNullIdxs let getType' col = hoistMaybe (getType (fromList tmap) col) <|> compileError lchan ("Type mapping is not defined against DB2 type: " ++ Columns.typename col) types <- mapM getType' cols return (types, notNullIdxs) -- | Driver implementation driverIBMDB2 :: IConnection conn => Driver conn driverIBMDB2 = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } { driverConfig = config } relational-query-HDBC-0.7.2.0/src/Database/HDBC/Schema/PostgreSQL.hs0000644000000000000000000000734713466567526022630 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.PostgreSQL -- Copyright : 2013-2019 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.Applicative ((<$>), (<|>)) import Control.Monad (guard) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe (MaybeT) import Database.HDBC (IConnection, SqlValue) import Database.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () import Database.Record (FromSql, ToSql) import Database.Relational.Schema.PostgreSQL (normalizeColumn, notNull, getType, columnQuerySQL, primaryKeyLengthQuerySQL, primaryKeyQuerySQL) import Database.Relational.Schema.PostgreSQL.PgAttribute (PgAttribute) import Database.Relational.Schema.PostgreSQL.PgType (PgType) import qualified Database.Relational.Schema.PostgreSQL.PgType as Type import Database.Relational.Schema.PostgreSQL (config) import Database.HDBC.Schema.Driver (TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe, Driver, driverConfig, getFieldsWithMap, getPrimaryKey, emptyDriver) instance FromSql SqlValue PgAttribute instance ToSql SqlValue PgAttribute instance FromSql SqlValue PgType instance ToSql SqlValue PgType logPrefix :: String -> String logPrefix = ("PostgreSQL: " ++) putLog :: LogChan -> String -> IO () putLog lchan = putVerbose lchan . logPrefix compileError :: LogChan -> String -> MaybeT IO a compileError lchan = failWith lchan . logPrefix getPrimaryKey' :: IConnection conn => conn -> LogChan -> String -> String -> IO [String] getPrimaryKey' conn lchan scm' tbl' = do let scm = map toLower scm' tbl = map toLower tbl' mayKeyLen <- runQuery' conn primaryKeyLengthQuerySQL (scm, tbl) case mayKeyLen of [] -> return [] [keyLen] -> do primCols <- runQuery' conn (primaryKeyQuerySQL keyLen) (scm, tbl) let primaryKeyCols = normalizeColumn <$> primCols putLog lchan $ "getPrimaryKey: primary key = " ++ show primaryKeyCols return primaryKeyCols _:_:_ -> do putLog lchan "getPrimaryKey: Fail to detect primary key. Something wrong." return [] getColumns' :: IConnection conn => TypeMap -> conn -> LogChan -> String -> String -> IO ([(String, TypeQ)], [Int]) getColumns' tmap conn lchan scm' tbl' = maybeIO ([], []) id $ do let scm = map toLower scm' tbl = map toLower tbl' cols <- lift $ runQuery' conn columnQuerySQL (scm, tbl) guard (not $ null cols) <|> compileError lchan ("getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl) let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols lift . putLog lchan $ "getFields: num of columns = " ++ show (length cols) ++ ", not null columns = " ++ show notNullIdxs let getType' col = hoistMaybe (getType (fromList tmap) col) <|> compileError lchan ("Type mapping is not defined against PostgreSQL type: " ++ Type.typname (snd col)) types <- mapM getType' cols return (types, notNullIdxs) -- | Driver implementation driverPostgreSQL :: IConnection conn => Driver conn driverPostgreSQL = emptyDriver { getFieldsWithMap = getColumns' } { getPrimaryKey = getPrimaryKey' } { driverConfig = config } relational-query-HDBC-0.7.2.0/src/Database/HDBC/Record/0000755000000000000000000000000013466567526020274 5ustar0000000000000000relational-query-HDBC-0.7.2.0/src/Database/HDBC/Record/Query.hs0000644000000000000000000001561513466567526021745 0ustar0000000000000000{-# 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 structures are typed. module Database.HDBC.Record.Query ( -- * Prepare PreparedQuery, prepare, prepareQuery, withPrepareQuery, -- * Fetch strictly fetch, fetchAll', listToUnique, fetchUnique, fetchUnique', runStatement', runPreparedQuery', runQuery', -- * Fetch loop foldlFetch, forFetch, -- * Fetch with Lazy-IO -- $fetchWithLazyIO fetchAll, runStatement, runPreparedQuery, runQuery, ) where import Control.Applicative ((<$>), pure) import Data.Monoid (mempty, (<>)) import Data.Maybe (listToMaybe) import Data.DList (toList) import Database.HDBC (IConnection, Statement, SqlValue) import qualified Database.HDBC as HDBC import Database.Relational (Query, untypeQuery) import Database.Record (ToSql, FromSql, toRecord) import Database.HDBC.Record.Statement (unsafePrepare, withUnsafePrepare, PreparedStatement, bind, BoundStatement, executeBound, 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 -- | Bracketed prepare operation. -- PreparedStatement is released on closing connection, -- so connection pooling cases often cause resource leaks. withPrepareQuery :: IConnection conn => conn -- ^ Database connection -> Query p a -- ^ Typed query -> (PreparedQuery p a -> IO b) -- ^ Body action to use prepared statement -> IO b -- ^ Result action withPrepareQuery conn = withUnsafePrepare conn . untypeQuery -- | Polymorphic fetch operation. fetchRecords :: (Functor f, FromSql SqlValue a) => (Statement -> IO (f [SqlValue]) ) -> ExecutedStatement a -> IO (f a) fetchRecords fetchs es = do rows <- fetchs (executed es) return $ fmap toRecord rows {- $fetchWithLazyIO __CAUTION!!__ /Lazy-IO/ APIs may be harmful in complex transaction with RDBMs interfaces which require sequential ordered calls of low-level APIs. -} -- | Fetch a record. fetch :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a) fetch = fetchRecords HDBC.fetchRow -- | /Lazy-IO/ version of 'fetchAll''. fetchAll :: FromSql SqlValue a => ExecutedStatement a -> IO [a] fetchAll = fetchRecords HDBC.fetchAllRows -- | Strictly fetch all records. fetchAll' :: FromSql SqlValue a => ExecutedStatement a -> IO [a] fetchAll' = fetchRecords HDBC.fetchAllRows' -- | 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 -- | Fetch fold-left loop convenient for -- the sequence of cursor-solid lock actions. -- Each action is executed after each fetch. foldlFetch :: FromSql SqlValue a => (b -> a -> IO b) -- ^ action executed after each fetch -> b -- ^ zero element of result -> ExecutedStatement a -- ^ statement to fetch from -> IO b foldlFetch f z st = go z where go ac = do let step = (go =<<) . f ac maybe (return ac) step =<< fetch st -- | Fetch loop convenient for -- the sequence of cursor-solid lock actions. -- Each action is executed after each fetch. forFetch :: FromSql SqlValue a => ExecutedStatement a -- ^ statement to fetch from -> (a -> IO b) -- ^ action executed after each fetch -> IO [b] forFetch st action = toList <$> foldlFetch (\ac x -> ((ac <>) . pure) <$> action x) mempty st -- | /Lazy-IO/ version of 'runStatement''. runStatement :: FromSql SqlValue a => BoundStatement a -> IO [a] runStatement = (>>= fetchAll) . executeBound -- | Execute a parameter-bounded statement and strictly fetch all records. runStatement' :: FromSql SqlValue a => BoundStatement a -> IO [a] runStatement' = (>>= fetchAll') . executeBound -- | /Lazy-IO/ 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 -- | Bind parameters, execute statement and strictly 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 -- | /Lazy-IO/ 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) -- | Prepare SQL, bind parameters, execute statement and strictly 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 = withPrepareQuery conn q (`runPreparedQuery'` p) relational-query-HDBC-0.7.2.0/src/Database/HDBC/Record/Update.hs0000644000000000000000000000405113466567526022052 0ustar0000000000000000{-# 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 structures are typed. module Database.HDBC.Record.Update ( PreparedUpdate, prepare, prepareUpdate, withPrepareUpdate, runPreparedUpdate, runUpdate, mapUpdate ) where import Database.HDBC (IConnection, SqlValue) import Database.Relational (Update) import Database.Record (ToSql) import Database.HDBC.Record.Statement (prepareNoFetch, withPrepareNoFetch, PreparedStatement, executeNoFetch, 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 -- | Bracketed prepare operation. withPrepareUpdate :: IConnection conn => conn -> Update p -> (PreparedUpdate p -> IO a) -> IO a withPrepareUpdate = withPrepareNoFetch -- | Bind parameters, execute statement and get execution result. runPreparedUpdate :: ToSql SqlValue p => PreparedUpdate p -> p -> IO Integer runPreparedUpdate = executeNoFetch -- | 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 relational-query-HDBC-0.7.2.0/src/Database/HDBC/Record/Sequence.hs0000644000000000000000000000712013466567526022400 0ustar0000000000000000{-# 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', LiteralSQL, 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, LiteralSQL 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, LiteralSQL 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, LiteralSQL 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, LiteralSQL 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 relational-query-HDBC-0.7.2.0/src/Database/HDBC/Record/InsertQuery.hs0000644000000000000000000000402513466567526023123 0ustar0000000000000000{-# 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 structures are typed. module Database.HDBC.Record.InsertQuery ( PreparedInsertQuery, prepare, prepareInsertQuery, withPrepareInsertQuery, runPreparedInsertQuery, runInsertQuery ) where import Database.HDBC (IConnection, SqlValue) import Database.Relational (InsertQuery) import Database.Record (ToSql) import Database.HDBC.Record.Statement (prepareNoFetch, withPrepareNoFetch, PreparedStatement, executeNoFetch, runNoFetch) -- | 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 = prepareNoFetch -- | Same as 'prepare'. prepareInsertQuery :: IConnection conn => conn -> InsertQuery p -> IO (PreparedInsertQuery p) prepareInsertQuery = prepare -- | Bracketed prepare operation. withPrepareInsertQuery :: IConnection conn => conn -> InsertQuery p -> (PreparedInsertQuery p -> IO a) -> IO a withPrepareInsertQuery = withPrepareNoFetch -- | Bind parameters, execute statement and get execution result. runPreparedInsertQuery :: ToSql SqlValue p => PreparedInsertQuery p -> p -> IO Integer runPreparedInsertQuery = executeNoFetch -- | Prepare insert statement, bind parameters, -- execute statement and get execution result. runInsertQuery :: (IConnection conn, ToSql SqlValue p) => conn -> InsertQuery p -> p -> IO Integer runInsertQuery = runNoFetch relational-query-HDBC-0.7.2.0/src/Database/HDBC/Record/Delete.hs0000644000000000000000000000346313466567526022040 0ustar0000000000000000{-# 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 structures are typed. module Database.HDBC.Record.Delete ( PreparedDelete, prepare, prepareDelete, withPrepareDelete, runPreparedDelete, runDelete ) where import Database.HDBC (IConnection, SqlValue) import Database.Relational (Delete) import Database.Record (ToSql) import Database.HDBC.Record.Statement (prepareNoFetch, withPrepareNoFetch, PreparedStatement, executeNoFetch, 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 -- | Bracketed prepare operation. withPrepareDelete :: IConnection conn => conn -> Delete p -> (PreparedDelete p -> IO a) -> IO a withPrepareDelete = withPrepareNoFetch -- | Bind parameters, execute statement and get execution result. runPreparedDelete :: ToSql SqlValue p => PreparedDelete p -> p -> IO Integer runPreparedDelete = executeNoFetch -- | 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 relational-query-HDBC-0.7.2.0/src/Database/HDBC/Record/KeyUpdate.hs0000644000000000000000000000572113466567526022530 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.HDBC.Record.KeyUpdate -- Copyright : 2013-2017 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides typed 'KeyUpdate' running sequence -- which intermediate structures are typed. module Database.HDBC.Record.KeyUpdate ( PreparedKeyUpdate, prepare, prepareKeyUpdate, withPrepareKeyUpdate, bindKeyUpdate, runPreparedKeyUpdate, runKeyUpdate ) where import Control.Exception (bracket) import Database.HDBC (IConnection, SqlValue, Statement) import qualified Database.HDBC as HDBC import Database.Relational (KeyUpdate, untypeKeyUpdate, updateValuesWithKey, Pi) import qualified Database.Relational as DSL import Database.Record (ToSql) import Database.HDBC.Record.Statement (BoundStatement (BoundStatement, bound, params), executeBoundNoFetch) -- | 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 = DSL.updateKey ku -- | Same as 'prepare'. prepareKeyUpdate :: IConnection conn => conn -> KeyUpdate p a -> IO (PreparedKeyUpdate p a) prepareKeyUpdate = prepare -- | Bracketed prepare operation. withPrepareKeyUpdate :: IConnection conn => conn -> KeyUpdate p a -> (PreparedKeyUpdate p a -> IO b) -> IO b withPrepareKeyUpdate conn ku body = bracket (HDBC.prepare conn sql) HDBC.finish $ body . PreparedKeyUpdate key where sql = untypeKeyUpdate ku key = DSL.updateKey ku -- | 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 = executeBoundNoFetch . 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 = withPrepareKeyUpdate conn q (`runPreparedKeyUpdate` a) relational-query-HDBC-0.7.2.0/src/Database/HDBC/Record/InternalTH.hs0000644000000000000000000001033613466567526022643 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} -- | -- Module : Database.HDBC.Record.InternalTH -- Copyright : 2013,2014,2016 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, Type(AppT, ConT), Info (ClassI), reify) import Language.Haskell.TH.Compat.Data (unInstanceD) 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.TH (defineScalarDegree) import Database.HDBC.Record.TH (derivePersistableInstanceFromConvertible) -- | 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 . unInstanceD) is where d1 (Just (_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 _ = unknownDeclaration $ show is 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 . unInstanceD) is where d1 (Just (_cxt, (AppT (ConT _n) a), _ds)) = return a d1 _ = unknownDeclaration $ show is 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 derivePersistableInstanceFromConvertible svl ss <- mapInstanceD defineScalarDegree svl return $ ws ++ ps ++ ss relational-query-HDBC-0.7.2.0/src/Database/HDBC/Record/Persistable.hs0000644000000000000000000000162013466567526023104 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# 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 () where import Database.Record (PersistableType (..)) import Database.Record.Persistable (unsafePersistableSqlTypeFromNull) import Database.HDBC.Record.InternalTH (derivePersistableInstancesFromConvertibleSqlValues) import Database.HDBC (SqlValue(SqlNull)) instance PersistableType SqlValue where persistableType = unsafePersistableSqlTypeFromNull SqlNull $(derivePersistableInstancesFromConvertibleSqlValues) relational-query-HDBC-0.7.2.0/src/Database/HDBC/Record/Insert.hs0000644000000000000000000001272713466567526022105 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.HDBC.Record.Insert -- Copyright : 2013-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides typed 'Insert' running sequence -- which intermediate structures are typed. module Database.HDBC.Record.Insert ( PreparedInsert, prepare, prepareInsert, runPreparedInsert, runInsert, mapInsert, bulkInsert, bulkInsert', bulkInsertInterleave, chunksInsert, ) where import Control.Applicative ((<$>), (<*>)) import Control.Monad (unless) import System.IO.Unsafe (unsafeInterleaveIO) import Database.HDBC (IConnection, SqlValue) import Database.Relational (Insert (..), untypeChunkInsert, chunkSizeOfInsert) import Database.Record (ToSql, fromRecord) import Database.HDBC.Record.Statement (prepareNoFetch, withPrepareNoFetch, withUnsafePrepare, PreparedStatement, untypePrepared, BoundStatement (..), executeNoFetch, runNoFetch, mapNoFetch, executeBoundNoFetch) -- | 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 = executeNoFetch -- | 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 } withPrepareChunksInsert :: (IConnection conn, ToSql SqlValue a) => conn -> Insert a -> (PreparedInsert a -> PreparedStatement [p] () -> Int -> IO b) -> IO b withPrepareChunksInsert conn i0 body = withPrepareNoFetch conn i0 (\ins -> withUnsafePrepare conn (untypeChunkInsert i0) (\iChunk -> body ins iChunk $ chunkSizeOfInsert i0) ) chunks :: Int -> [a] -> ([[a]], [a]) chunks n = rec' where rec' xs | null tl = if length c == n then ([c], []) else ( [], c) | otherwise = (c : cs, ys) where (c, tl) = splitAt n xs (cs, ys) = rec' tl lazyMapIO :: (a -> IO b) -> [a] -> IO [b] lazyMapIO _ [] = return [] lazyMapIO f (x:xs) = unsafeInterleaveIO $ (:) <$> f x <*> lazyMapIO f xs chunksLazyAction :: ToSql SqlValue a => [a] -> PreparedInsert a -> PreparedStatement [a] () -> Int -> IO ([Integer], [Integer]) chunksLazyAction rs ins iChunk size = (,) <$> lazyMapIO (executeBoundNoFetch . chunkBind iChunk) cs <*> (unsafeInterleaveIO $ mapM (runPreparedInsert ins) xs) where (cs, xs) = chunks size rs -- | Prepare and insert using chunk insert statement, with the Lazy-IO results of insert statements. bulkInsertInterleave :: (IConnection conn, ToSql SqlValue a) => conn -> Insert a -> [a] -> IO ([Integer], [Integer]) bulkInsertInterleave conn ins = withPrepareChunksInsert conn ins . chunksLazyAction chunksAction :: ToSql SqlValue a => [a] -> PreparedInsert a -> PreparedStatement [a] () -> Int -> IO () chunksAction rs ins iChunk size = do (zs, os) <- chunksLazyAction rs ins iChunk size unless (all (== fromIntegral size) zs) $ fail "chunksAction: chunks: unexpected result size!" unless (all (== 1) os) $ fail "chunksAction: tails: unexpected result size!" -- | Prepare and insert using chunk insert statement. bulkInsert :: (IConnection conn, ToSql SqlValue a) => conn -> Insert a -> [a] -> IO () bulkInsert conn ins = withPrepareChunksInsert conn ins . chunksAction -- | Prepare and insert using chunk insert statement, with the results of insert statements. bulkInsert' :: (IConnection conn, ToSql SqlValue a) => conn -> Insert a -> [a] -> IO ([Integer], [Integer]) bulkInsert' conn ins rs = do p@(zs, os) <- withPrepareChunksInsert conn ins $ chunksLazyAction rs let zl = length zs ol = length os zl `seq` ol `seq` return p {-# DEPRECATED chunksInsert "use bulkInsert' instead of this." #-} -- | Deprecated. Use bulkInsert' instead of this. Prepare and insert using chunk insert statement. chunksInsert :: (IConnection conn, ToSql SqlValue a) => conn -> Insert a -> [a] -> IO [[Integer]] chunksInsert conn ins rs = do (zs, os) <- bulkInsert' conn ins rs return $ map (: []) zs ++ [os] relational-query-HDBC-0.7.2.0/src/Database/HDBC/Record/TH.hs0000644000000000000000000000231013466567526021137 0ustar0000000000000000{-# 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 ( derivePersistableInstanceFromConvertible, ) where import Data.Convertible (convert) import Language.Haskell.TH (Q, Dec, Type) import Database.HDBC (SqlValue) import Database.HDBC.SqlValueExtra () import Database.Record (FromSql (..), ToSql(..)) import Database.Record.FromSql (valueRecordFromSql) import Database.Record.ToSql (valueRecordToSql) -- | Template to declare HDBC instances of DB-record against single value type. derivePersistableInstanceFromConvertible :: Q Type -- ^ Type to implement instances -> Q [Dec] -- ^ Result declarations derivePersistableInstanceFromConvertible typ = [d| instance FromSql SqlValue $(typ) where recordFromSql = valueRecordFromSql convert instance ToSql SqlValue $(typ) where recordToSql = valueRecordToSql convert |] relational-query-HDBC-0.7.2.0/src/Database/HDBC/Record/Statement.hs0000644000000000000000000001345713466567526022606 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.HDBC.Record.Statement -- Copyright : 2013-2018 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides typed statement running sequence -- which intermediate structures are typed. module Database.HDBC.Record.Statement ( PreparedStatement, untypePrepared, unsafePrepare, finish, withUnsafePrepare, withPrepareNoFetch, BoundStatement (..), bind, bindTo, ExecutedStatement, executed, result, executeBound, execute, prepareNoFetch, executeBoundNoFetch, executeNoFetch, runNoFetch, mapNoFetch, -- * Deprecated. executePrepared, runPreparedNoFetch, ) where import Control.Exception (bracket) import Database.Relational (UntypeableNoFetch (untypeNoFetch)) import Database.HDBC (IConnection, Statement, SqlValue) import qualified Database.HDBC as HDBC import Database.Record (ToSql, fromRecord) -- | 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 -- | Close PreparedStatement. Useful for connection pooling cases. -- PreparedStatement is released on closing connection, -- so connection pooling cases often cause resource leaks. finish :: PreparedStatement p a -> IO () finish = HDBC.finish . prepared -- | Bracketed prepare operation. -- Unsafely make Typed prepared statement. -- PreparedStatement is released on closing connection, -- so connection pooling cases often cause resource leaks. withUnsafePrepare :: IConnection conn => conn -- ^ Database connection -> String -- ^ Raw SQL String -> (PreparedStatement p a -> IO b) -> IO b withUnsafePrepare conn qs = bracket (unsafePrepare conn qs) finish -- | Bracketed prepare operation. -- Generalized prepare inferred from 'UntypeableNoFetch' instance. withPrepareNoFetch :: (UntypeableNoFetch s, IConnection conn) => conn -> s p -> (PreparedStatement p () -> IO a) -> IO a withPrepareNoFetch conn s = bracket (prepareNoFetch conn s) finish -- | Typed operation to bind parameters. Inferred 'ToSql' is used. bind :: ToSql SqlValue p => PreparedStatement p a -- ^ Prepared query to bind to -> p -- ^ Parameter to bind -> BoundStatement a -- ^ Result parameter bound statement bind q p = BoundStatement { bound = prepared q, params = fromRecord p } -- | Same as 'bind' except for argument is flipped. bindTo :: ToSql SqlValue p => p -> PreparedStatement p a -> BoundStatement a bindTo = flip bind -- | Typed execute operation. executeBound :: BoundStatement a -> IO (ExecutedStatement a) executeBound bs = do let stmt = bound bs n <- HDBC.execute stmt (params bs) n `seq` return (ExecutedStatement stmt n) -- | Bind parameters, execute prepared statement and get executed statement. execute :: ToSql SqlValue p => PreparedStatement p a -> p -> IO (ExecutedStatement a) execute st = executeBound . bind st {-# DEPRECATED executePrepared "use `execute` instead of this." #-} -- | Deprecated. executePrepared :: ToSql SqlValue p => PreparedStatement p a -> p -> IO (ExecutedStatement a) executePrepared = execute -- | Typed execute operation. Only get result. executeBoundNoFetch :: BoundStatement () -> IO Integer executeBoundNoFetch = fmap result . executeBound -- | Bind parameters, execute prepared statement and get execution result. executeNoFetch :: ToSql SqlValue a => PreparedStatement a () -> a -> IO Integer executeNoFetch p = executeBoundNoFetch . (p `bind`) {-# DEPRECATED runPreparedNoFetch "use `executeNoFetch` instead of this." #-} -- | Deprecated. runPreparedNoFetch :: ToSql SqlValue a => PreparedStatement a () -> a -> IO Integer runPreparedNoFetch = executeNoFetch -- | 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 = withPrepareNoFetch 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 = withPrepareNoFetch conn s (\ps -> mapM (runPreparedNoFetch ps) rs) relational-query-HDBC-0.7.2.0/src/Database/HDBC/Query/0000755000000000000000000000000013466567526020163 5ustar0000000000000000relational-query-HDBC-0.7.2.0/src/Database/HDBC/Query/TH.hs0000644000000000000000000002133313466567526021034 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Query.TH -- Copyright : 2013-2018 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 ( makeRelationalRecord, makeRelationalRecord', defineTableDefault', defineTableDefault, defineTableFromDB', defineTableFromDB, inlineVerifiedQuery ) where import Control.Applicative ((<$>), pure, (<*>)) import Control.Monad (when, void) import Data.Maybe (listToMaybe, fromMaybe) import qualified Data.Map as Map import Data.Functor.ProductIsomorphic.TH (reifyRecordType) import Database.HDBC (IConnection, SqlValue, prepare) import Language.Haskell.TH (Q, runIO, Name, TypeQ, Type (AppT, ConT), Dec) import Language.Haskell.TH.Name.CamelCase (varCamelcaseName) import Language.Haskell.TH.Lib.Extra (reportWarning, reportError) import Database.Record (ToSql, FromSql) import Database.Record.TH (recordTemplate, defineSqlPersistableInstances) import Database.Relational (Config, nameConfig, recordConfig, enableWarning, verboseAsCompilerWarning, defaultConfig, Relation, untypeQuery, relationalQuery_, QuerySuffix) import qualified Database.Relational.TH as Relational import Database.HDBC.Session (withConnectionIO) import Database.HDBC.Record.Persistable () import Database.HDBC.Schema.Driver (foldLog, emptyLogChan, takeLogs, Driver, driverConfig, getFields, getPrimaryKey) defineInstancesForSqlValue :: TypeQ -- ^ Record type constructor. -> Q [Dec] -- ^ Instance declarations. defineInstancesForSqlValue typeCon = do [d| instance FromSql SqlValue $typeCon instance ToSql SqlValue $typeCon |] -- | Generate all persistable templates against defined record like type constructor. 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 -> String -- ^ Table name -> [(String, TypeQ)] -- ^ List of column name and type -> [Name] -- ^ Derivings -> Q [Dec] -- ^ Result declaration defineTableDefault' config schema table columns derives = do modelD <- Relational.defineTableTypesAndRecord config schema table columns derives sqlvD <- defineSqlPersistableInstances [t| SqlValue |] (fst $ recordTemplate (recordConfig $ nameConfig config) schema table) [] return $ modelD ++ sqlvD -- | Generate all HDBC templates about table. defineTableDefault :: Config -- ^ Configuration to generate query with -> String -- ^ Schema name -> String -- ^ Table name -> [(String, TypeQ)] -- ^ List of column name and type -> [Name] -- ^ 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.defineTable config schema table columns derives primary notNull sqlvD <- defineInstancesForSqlValue . fst $ recordTemplate (recordConfig $ nameConfig config) schema table return $ modelD ++ sqlvD tableAlongWithSchema :: IConnection conn => IO conn -- ^ Connect action to system catalog database -> Driver conn -- ^ Driver definition -> String -- ^ Schema name -> String -- ^ Table name -> [(String, TypeQ)] -- ^ Additional column-name and column-type mapping to overwrite default -> [Name] -- ^ Derivings -> Q [Dec] -- ^ Result declaration tableAlongWithSchema connect drv scm tbl cmap derives = do let config = driverConfig drv getDBinfo = do logChan <- emptyLogChan infoP <- withConnectionIO connect (\conn -> (,) <$> getFields drv conn logChan scm tbl <*> getPrimaryKey drv conn logChan scm tbl) (,) infoP <$> takeLogs logChan (((cols, notNullIdxs), primaryCols), logs) <- runIO getDBinfo let reportWarning' | enableWarning config = reportWarning | otherwise = const $ pure () reportVerbose | verboseAsCompilerWarning config = reportWarning | otherwise = const $ pure () mapM_ (foldLog reportVerbose reportWarning' reportError) logs 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 let liftMaybe tyQ sty = do ty <- tyQ case ty of (AppT (ConT n) _) | n == ''Maybe -> [t| Maybe $(sty) |] _ -> sty cols1 = [ (,) cn . maybe ty (liftMaybe ty) . Map.lookup cn $ Map.fromList cmap | (cn, ty) <- cols ] defineTableDefault config scm tbl cols1 derives primaryIxs (listToMaybe notNullIdxs) -- | Generate all HDBC templates using system catalog informations with specified config. defineTableFromDB' :: IConnection conn => IO conn -- ^ Connect action to system catalog database -> Driver conn -- ^ Driver definition -> String -- ^ Schema name -> String -- ^ Table name -> [(String, TypeQ)] -- ^ Additional column-name and column-type mapping to overwrite default -> [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 -> Driver conn -- ^ Driver definition -> String -- ^ Schema name -> String -- ^ Table name -> [Name] -- ^ Derivings -> Q [Dec] -- ^ Result declaration defineTableFromDB connect driver tbl scm = tableAlongWithSchema connect driver tbl scm [] -- | 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 = untypeQuery $ relationalQuery_ config rel sufs when (verboseAsCompilerWarning config) . reportWarning $ "Verify with prepare: " ++ sql void . runIO $ withConnectionIO connect (\conn -> prepare conn sql) Relational.unsafeInlineQuery (return p) (return r) sql (varCamelcaseName qns)