relational-query-HDBC-0.6.0.2/0000755000000000000000000000000012731442376014047 5ustar0000000000000000relational-query-HDBC-0.6.0.2/relational-query-HDBC.cabal0000644000000000000000000000621612731442376021033 0ustar0000000000000000name: relational-query-HDBC version: 0.6.0.2 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-2016 Kei Hibino, Shohei Murayama, Shohei Yasutake, Sho KURODA category: Database build-type: Simple cabal-version: >=1.10 tested-with: GHC == 8.0.1 , 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 library exposed-modules: Database.HDBC.Record.Persistable Database.HDBC.Record.TH Database.HDBC.Record.Statement Database.HDBC.Record.Query Database.HDBC.Record.Update Database.HDBC.Record.Insert Database.HDBC.Record.InsertQuery Database.HDBC.Record.Delete Database.HDBC.Record.KeyUpdate Database.HDBC.Record Database.HDBC.Query.TH Database.HDBC.SqlValueExtra Database.HDBC.Schema.Driver Database.HDBC.Schema.IBMDB2 Database.HDBC.Schema.PostgreSQL Database.HDBC.Schema.SQLServer Database.HDBC.Schema.SQLite3 Database.HDBC.Schema.Oracle Database.HDBC.Schema.MySQL other-modules: Database.HDBC.Record.InternalTH build-depends: base <5 , containers , transformers , convertible , template-haskell , dlist , th-data-compat , names-th , persistable-record >= 0.4 , relational-query >= 0.8 , relational-schemas , HDBC >=2 , HDBC-session hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010 source-repository head type: git location: https://github.com/khibino/haskell-relational-record source-repository head type: mercurial location: https://bitbucket.org/khibino/haskell-relational-record relational-query-HDBC-0.6.0.2/Setup.hs0000644000000000000000000000005612731442376015504 0ustar0000000000000000import Distribution.Simple main = defaultMain relational-query-HDBC-0.6.0.2/LICENSE0000644000000000000000000000275612731442376015066 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.6.0.2/src/0000755000000000000000000000000012731442376014636 5ustar0000000000000000relational-query-HDBC-0.6.0.2/src/Database/0000755000000000000000000000000012731442376016342 5ustar0000000000000000relational-query-HDBC-0.6.0.2/src/Database/HDBC/0000755000000000000000000000000012731442376017042 5ustar0000000000000000relational-query-HDBC-0.6.0.2/src/Database/HDBC/Record.hs0000644000000000000000000000206612731442376020620 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.6.0.2/src/Database/HDBC/SqlValueExtra.hs0000644000000000000000000000215312731442376022137 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS -fno-warn-orphans #-} -- | -- Module : Database.HDBC.SqlValueExtra -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown module Database.HDBC.SqlValueExtra () where import Data.Convertible (Convertible(safeConvert), ConvertResult) import Data.Int (Int8, Int16, Int32) import Database.HDBC (SqlValue) -- Convert from narrower width than Int32 safeConvertFromIntegral32 :: Integral a => a -> ConvertResult SqlValue safeConvertFromIntegral32 i = safeConvert (fromIntegral i :: Int32) safeConvertToIntegral32 :: Integral a => SqlValue -> ConvertResult a safeConvertToIntegral32 v = fmap fromIntegral (safeConvert v :: ConvertResult Int32) instance Convertible 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 relational-query-HDBC-0.6.0.2/src/Database/HDBC/Schema/0000755000000000000000000000000012731442376020242 5ustar0000000000000000relational-query-HDBC-0.6.0.2/src/Database/HDBC/Schema/Oracle.hs0000644000000000000000000000643212731442376022010 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.MySQL -- Copyright : 2013 Shohei Yasutake -- 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.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) import Database.HDBC.Schema.Driver ( TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver ) import Database.Relational.Schema.Oracle ( normalizeColumn, notNull, getType , columnsQuerySQL, primaryKeyQuerySQL ) import Database.Relational.Schema.OracleDataDictionary.TabColumns (DbaTabColumns) import qualified Database.Relational.Schema.OracleDataDictionary.TabColumns as Cols $(makeRecordPersistableWithSqlTypeDefaultFromDefined [t|SqlValue|] ''DbaTabColumns) logPrefix :: String -> String logPrefix = ("Oracle: " ++) putLog :: 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' } relational-query-HDBC-0.6.0.2/src/Database/HDBC/Schema/SQLServer.hs0000644000000000000000000000666712731442376022443 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.SQLServer -- Copyright : 2013 Shohei Murayama -- License : BSD3 -- -- Maintainer : shohei.murayama@gmail.com -- Stability : experimental -- Portability : unknown module Database.HDBC.Schema.SQLServer ( driverSQLServer, ) where import qualified Database.Relational.Schema.SQLServerSyscat.Columns as Columns import qualified Database.Relational.Schema.SQLServerSyscat.Types as Types import 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, Driver, hoistMaybe, getFieldsWithMap, getPrimaryKey, emptyDriver) import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) import Database.Relational.Schema.SQLServer (columnTypeQuerySQL, getType, normalizeColumn, notNull, primaryKeyQuerySQL) import Database.Relational.Schema.SQLServerSyscat.Columns (Columns) import Database.Relational.Schema.SQLServerSyscat.Types (Types) import Language.Haskell.TH (TypeQ) $(makeRecordPersistableWithSqlTypeDefaultFromDefined [t| SqlValue |] ''Columns) $(makeRecordPersistableWithSqlTypeDefaultFromDefined [t| SqlValue |] ''Types) logPrefix :: String -> String logPrefix = ("SQLServer: " ++) putLog :: 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' } relational-query-HDBC-0.6.0.2/src/Database/HDBC/Schema/Driver.hs0000644000000000000000000001063112731442376022032 0ustar0000000000000000-- | -- Module : Database.HDBC.Schema.Driver -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides driver interface -- to load database system catalog via HDBC. module Database.HDBC.Schema.Driver ( TypeMap, Log, runLog, LogChan, newLogChan, takeLogs, putWarning, putError, putVerbose, failWith, hoistMaybe, maybeIO, Driver(Driver, typeMap, 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 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) -- | 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 = Warning String | Error String -- | Folding operation of 'Log' type. runLog :: (String -> t) -> (String -> t) -> Log -> t runLog wf ef = d where d (Warning m) = wf m d (Error m) = ef m -- | Channel to store compile-time warning messages. data LogChan = LogChan { chan :: IORef (DList Log) , verboseAsWarning :: Bool } -- | Build and return a new instance of 'LogChan'. newLogChan :: Bool -> IO LogChan newLogChan v = LogChan <$> newIORef mempty <*> pure v -- | 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 . Warning -- | 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 -- | Put verbose compile-time message as warning when 'verboseAsWarning'. putVerbose :: LogChan -> String -> IO () putVerbose lchan | verboseAsWarning lchan = putWarning lchan . ("info: " ++) | otherwise = const $ pure () -- | Interface type to load database system catalog via HDBC. data Driver conn = Driver { -- | Custom type mapping of this driver typeMap :: TypeMap -- | Get column name and Haskell type pairs and not-null columns index. , getFieldsWithMap :: TypeMap -- Custom type mapping -> conn -- Connection to query system catalog -> 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 [] (\_ _ _ _ _ -> 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 drv = getFieldsWithMap drv (typeMap drv) relational-query-HDBC-0.6.0.2/src/Database/HDBC/Schema/IBMDB2.hs0000644000000000000000000000652112731442376021501 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.IBMDB2 -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides driver implementation -- to load IBM-DB2 system catalog via HDBC. module Database.HDBC.Schema.IBMDB2 ( driverIBMDB2 ) where import Prelude hiding (length) import Language.Haskell.TH (TypeQ) import qualified Data.List as List import Data.Char (toUpper) import Data.Map (fromList) import Control.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.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) import Database.Relational.Schema.IBMDB2 (normalizeColumn, notNull, getType, columnsQuerySQL, primaryKeyQuerySQL) import Database.Relational.Schema.DB2Syscat.Columns (Columns) import qualified Database.Relational.Schema.DB2Syscat.Columns as Columns import Database.HDBC.Schema.Driver (TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver) -- Specify type constructor and data constructor from same table name. $(makeRecordPersistableWithSqlTypeDefaultFromDefined [t| 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' } relational-query-HDBC-0.6.0.2/src/Database/HDBC/Schema/PostgreSQL.hs0000644000000000000000000000736312731442376022612 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.PostgreSQL -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides driver implementation -- to load PostgreSQL system catalog via HDBC. module Database.HDBC.Schema.PostgreSQL ( driverPostgreSQL ) where import Language.Haskell.TH (TypeQ) import Data.Char (toLower) import Data.Map (fromList) import Control.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.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) import Database.Relational.Schema.PostgreSQL (normalizeColumn, notNull, getType, columnQuerySQL, primaryKeyLengthQuerySQL, primaryKeyQuerySQL) import Database.Relational.Schema.PgCatalog.PgAttribute (PgAttribute) import Database.Relational.Schema.PgCatalog.PgType (PgType) import qualified Database.Relational.Schema.PgCatalog.PgType as Type import Database.HDBC.Schema.Driver (TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver) $(makeRecordPersistableWithSqlTypeDefaultFromDefined [t| SqlValue |] ''PgAttribute) $(makeRecordPersistableWithSqlTypeDefaultFromDefined [t| 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 [] -> do putLog lchan "getPrimaryKey: Primary key not found." 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' } relational-query-HDBC-0.6.0.2/src/Database/HDBC/Schema/SQLite3.hs0000644000000000000000000001077212731442376022031 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.SQLite3 -- Copyright : 2013 Shohei Murayama -- License : BSD3 -- -- Maintainer : shohei.murayama@gmail.com -- Stability : experimental -- Portability : unknown module Database.HDBC.Schema.SQLite3 ( driverSQLite3 ) where import qualified Database.Relational.Schema.SQLite3Syscat.IndexInfo as IndexInfo import qualified Database.Relational.Schema.SQLite3Syscat.IndexList as IndexList import qualified Database.Relational.Schema.SQLite3Syscat.TableInfo as TableInfo import 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, Driver, hoistMaybe, getFieldsWithMap, getPrimaryKey, emptyDriver) import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) import Database.Relational.Schema.SQLite3 (getType, indexInfoQuerySQL, indexListQuerySQL, normalizeColumn, normalizeType, notNull, tableInfoQuerySQL) import Database.Relational.Schema.SQLite3Syscat.IndexInfo (IndexInfo) import Database.Relational.Schema.SQLite3Syscat.IndexList (IndexList) import Database.Relational.Schema.SQLite3Syscat.TableInfo (TableInfo) import Language.Haskell.TH (TypeQ) $(makeRecordPersistableWithSqlTypeDefaultFromDefined [t| SqlValue |] ''TableInfo) $(makeRecordPersistableWithSqlTypeDefaultFromDefined [t| SqlValue |] ''IndexList) $(makeRecordPersistableWithSqlTypeDefaultFromDefined [t| SqlValue |] ''IndexInfo) logPrefix :: String -> String logPrefix = ("SQLite3: " ++) putLog :: 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' } relational-query-HDBC-0.6.0.2/src/Database/HDBC/Schema/MySQL.hs0000644000000000000000000001033412731442376021544 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Schema.MySQL -- Copyright : 2013 Sho KURODA -- 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.HDBC.Record.Query (runQuery') import Database.HDBC.Record.Persistable () import Database.HDBC.Schema.Driver ( TypeMap , LogChan , putVerbose , failWith , maybeIO , hoistMaybe , Driver , getFieldsWithMap , getPrimaryKey , emptyDriver ) import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined) import Database.Relational.Schema.MySQL ( normalizeColumn , notNull , getType , columnsQuerySQL , primaryKeyQuerySQL ) import Database.Relational.Schema.MySQLInfo.Columns (Columns) import qualified Database.Relational.Schema.MySQLInfo.Columns as Columns $(makeRecordPersistableWithSqlTypeDefaultFromDefined [t| SqlValue |] ''Columns) logPrefix :: String -> String logPrefix = ("MySQL: " ++) putLog :: 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' } relational-query-HDBC-0.6.0.2/src/Database/HDBC/Record/0000755000000000000000000000000012731442376020260 5ustar0000000000000000relational-query-HDBC-0.6.0.2/src/Database/HDBC/Record/InternalTH.hs0000644000000000000000000001034412731442376022626 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.Query.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.6.0.2/src/Database/HDBC/Record/Delete.hs0000644000000000000000000000350012731442376022014 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 structres are typed. module Database.HDBC.Record.Delete ( PreparedDelete, prepare, prepareDelete, withPrepareDelete, runPreparedDelete, runDelete ) where import Database.HDBC (IConnection, SqlValue) import Database.Relational.Query (Delete) import Database.Record (ToSql) import Database.HDBC.Record.Statement (prepareNoFetch, withPrepareNoFetch, PreparedStatement, runPreparedNoFetch, runNoFetch) -- | Typed prepared delete type. type PreparedDelete p = PreparedStatement p () -- | Typed prepare delete operation. prepare :: IConnection conn => conn -> Delete p -> IO (PreparedDelete p) prepare = prepareNoFetch -- | Same as 'prepare'. prepareDelete :: IConnection conn => conn -> Delete p -> IO (PreparedDelete p) prepareDelete = prepare -- | 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 = runPreparedNoFetch -- | Prepare delete statement, bind parameters, -- execute statement and get execution result. runDelete :: (IConnection conn, ToSql SqlValue p) => conn -> Delete p -> p -> IO Integer runDelete = runNoFetch relational-query-HDBC-0.6.0.2/src/Database/HDBC/Record/Update.hs0000644000000000000000000000406612731442376022044 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 structres are typed. module Database.HDBC.Record.Update ( PreparedUpdate, prepare, prepareUpdate, withPrepareUpdate, runPreparedUpdate, runUpdate, mapUpdate ) where import Database.HDBC (IConnection, SqlValue) import Database.Relational.Query (Update) import Database.Record (ToSql) import Database.HDBC.Record.Statement (prepareNoFetch, withPrepareNoFetch, PreparedStatement, runPreparedNoFetch, runNoFetch, mapNoFetch) -- | Typed prepared update type. type PreparedUpdate p = PreparedStatement p () -- | Typed prepare update operation. prepare :: IConnection conn => conn -> Update p -> IO (PreparedUpdate p) prepare = prepareNoFetch -- | Same as 'prepare'. prepareUpdate :: IConnection conn => conn -> Update p -> IO (PreparedUpdate p) prepareUpdate = prepare -- | 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 = runPreparedNoFetch -- | Prepare update statement, bind parameters, -- execute statement and get execution result. runUpdate :: (IConnection conn, ToSql SqlValue p) => conn -> Update p -> p -> IO Integer runUpdate = runNoFetch -- | Prepare and update with each parameter list. mapUpdate :: (IConnection conn, ToSql SqlValue a) => conn -> Update a -> [a] -> IO [Integer] mapUpdate = mapNoFetch relational-query-HDBC-0.6.0.2/src/Database/HDBC/Record/KeyUpdate.hs0000644000000000000000000000572312731442376022516 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.HDBC.Record.KeyUpdate -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides typed 'KeyUpdate' running sequence -- which intermediate structres are typed. module Database.HDBC.Record.KeyUpdate ( PreparedKeyUpdate, prepare, prepareKeyUpdate, withPrepareKeyUpdate, bindKeyUpdate, runPreparedKeyUpdate, runKeyUpdate ) where import Control.Exception (bracket) import Database.HDBC (IConnection, SqlValue, Statement) import qualified Database.HDBC as HDBC import Database.Relational.Query (KeyUpdate, untypeKeyUpdate, updateValuesWithKey, Pi) import qualified Database.Relational.Query as Query import Database.Record (ToSql) import Database.HDBC.Record.Statement (BoundStatement (BoundStatement, bound, params), executeNoFetch) -- | Typed prepared key-update type. data PreparedKeyUpdate p a = PreparedKeyUpdate { -- | Key to specify update target records. updateKey :: Pi a p -- | Untyped prepared statement before executed. , preparedKeyUpdate :: Statement } -- | Typed prepare key-update operation. prepare :: IConnection conn => conn -> KeyUpdate p a -> IO (PreparedKeyUpdate p a) prepare conn ku = fmap (PreparedKeyUpdate key) . HDBC.prepare conn $ sql where sql = untypeKeyUpdate ku key = Query.updateKey ku -- | Same as 'prepare'. prepareKeyUpdate :: IConnection conn => conn -> KeyUpdate p a -> IO (PreparedKeyUpdate p a) prepareKeyUpdate = prepare -- | 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 = Query.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 = executeNoFetch . bindKeyUpdate pre -- | Prepare insert statement, bind parameters, -- execute statement and get execution result. runKeyUpdate :: (IConnection conn, ToSql SqlValue a) => conn -> KeyUpdate p a -> a -> IO Integer runKeyUpdate conn q a = withPrepareKeyUpdate conn q (`runPreparedKeyUpdate` a) relational-query-HDBC-0.6.0.2/src/Database/HDBC/Record/Query.hs0000644000000000000000000001315112731442376021722 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 structres are typed. module Database.HDBC.Record.Query ( PreparedQuery, prepare, prepareQuery, withPrepareQuery, fetch, fetchAll, fetchAll', listToUnique, fetchUnique, fetchUnique', runStatement, runStatement', runPreparedQuery, runPreparedQuery', runQuery, runQuery' ) where import Data.Maybe (listToMaybe) import Database.HDBC (IConnection, Statement, SqlValue) import qualified Database.HDBC as HDBC import Database.Relational.Query (Query, untypeQuery) import Database.Record (ToSql, RecordFromSql, FromSql(recordFromSql), runToRecord) import Database.HDBC.Record.Statement (unsafePrepare, withUnsafePrepare, PreparedStatement, bind, BoundStatement, execute, ExecutedStatement, executed) -- | Typed prepared query type. type PreparedQuery p a = PreparedStatement p a -- | Typed prepare query operation. prepare :: IConnection conn => conn -- ^ Database connection -> Query p a -- ^ Typed query -> IO (PreparedQuery p a) -- ^ Result typed prepared query with parameter type 'p' and result type 'a' prepare conn = unsafePrepare conn . untypeQuery -- | Same as 'prepare'. prepareQuery :: IConnection conn => conn -- ^ Database connection -> Query p a -- ^ Typed query -> IO (PreparedQuery p a) -- ^ Result typed prepared query with parameter type 'p' and result type 'a' prepareQuery = prepare -- | Bracketed prepare operation. 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. fetchRecordsExplicit :: Functor f => (Statement -> IO (f [SqlValue]) ) -> RecordFromSql SqlValue a -> ExecutedStatement a -> IO (f a) fetchRecordsExplicit fetchs fromSql es = do rows <- fetchs (executed es) return $ fmap (runToRecord fromSql) rows -- | Fetch a record. fetch :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a) fetch = fetchRecordsExplicit HDBC.fetchRow recordFromSql -- | Lazily Fetch all records. fetchAll :: FromSql SqlValue a => ExecutedStatement a -> IO [a] fetchAll = fetchRecordsExplicit HDBC.fetchAllRows recordFromSql -- | Strict version of 'fetchAll'. fetchAll' :: FromSql SqlValue a => ExecutedStatement a -> IO [a] fetchAll' = fetchRecordsExplicit HDBC.fetchAllRows' recordFromSql -- | Fetch all records but get only first record. -- Expecting result records is unique. fetchUnique :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a) fetchUnique es = do recs <- fetchAll es let z' = listToMaybe recs z <- z' `seq` return z' HDBC.finish $ executed es return z -- | Fetch expecting result records is unique. listToUnique :: [a] -> IO (Maybe a) listToUnique = d where d [] = return Nothing d [r] = return $ Just r d (_:_:_) = fail "fetchUnique': more than one record found." -- | Fetch all records but get only first record. -- Expecting result records is unique. -- Error when records count is more than one. fetchUnique' :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a) fetchUnique' es = do recs <- fetchAll es z <- listToUnique recs HDBC.finish $ executed es return z -- | Execute statement and lazily fetch all records. runStatement :: FromSql SqlValue a => BoundStatement a -> IO [a] runStatement = (>>= fetchAll) . execute -- | Strict version of 'runStatement'. runStatement' :: FromSql SqlValue a => BoundStatement a -> IO [a] runStatement' = (>>= fetchAll') . execute -- | Bind parameters, execute statement and lazily fetch all records. runPreparedQuery :: (ToSql SqlValue p, FromSql SqlValue a) => PreparedQuery p a -- ^ Statement to bind to -> p -- ^ Parameter type -> IO [a] -- ^ Action to get records runPreparedQuery ps = runStatement . bind ps -- | Strict version of 'runPreparedQuery'. runPreparedQuery' :: (ToSql SqlValue p, FromSql SqlValue a) => PreparedQuery p a -- ^ Statement to bind to -> p -- ^ Parameter type -> IO [a] -- ^ Action to get records runPreparedQuery' ps = runStatement' . bind ps -- | Prepare SQL, bind parameters, execute statement and lazily fetch all records. runQuery :: (IConnection conn, ToSql SqlValue p, FromSql SqlValue a) => conn -- ^ Database connection -> Query p a -- ^ Query to get record type 'a' requires parameter 'p' -> p -- ^ Parameter type -> IO [a] -- ^ Action to get records runQuery conn q p = prepare conn q >>= (`runPreparedQuery` p) -- | Strict version of 'runQuery'. runQuery' :: (IConnection conn, ToSql SqlValue p, FromSql SqlValue a) => conn -- ^ Database connection -> Query p a -- ^ Query to get record type 'a' requires parameter 'p' -> p -- ^ Parameter type -> IO [a] -- ^ Action to get records runQuery' conn q p = withPrepareQuery conn q (`runPreparedQuery'` p) relational-query-HDBC-0.6.0.2/src/Database/HDBC/Record/InsertQuery.hs0000644000000000000000000000404212731442376023106 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 structres are typed. module Database.HDBC.Record.InsertQuery ( PreparedInsertQuery, prepare, prepareInsertQuery, withPrepareInsertQuery, runPreparedInsertQuery, runInsertQuery ) where import Database.HDBC (IConnection, SqlValue) import Database.Relational.Query (InsertQuery) import Database.Record (ToSql) import Database.HDBC.Record.Statement (prepareNoFetch, withPrepareNoFetch, PreparedStatement, runPreparedNoFetch, 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 = runPreparedNoFetch -- | Prepare insert statement, bind parameters, -- execute statement and get execution result. runInsertQuery :: (IConnection conn, ToSql SqlValue p) => conn -> InsertQuery p -> p -> IO Integer runInsertQuery = runNoFetch relational-query-HDBC-0.6.0.2/src/Database/HDBC/Record/Statement.hs0000644000000000000000000001210712731442376022561 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.HDBC.Record.Statement -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides typed statement running sequence -- which intermediate structres are typed. module Database.HDBC.Record.Statement ( PreparedStatement, untypePrepared, unsafePrepare, finish, withUnsafePrepare, withPrepareNoFetch, BoundStatement (..), bind', bind, bindTo, ExecutedStatement, executed, result, execute, prepareNoFetch, executeNoFetch, runPreparedNoFetch, runNoFetch, mapNoFetch ) where import Control.Exception (bracket) import Database.Relational.Query (UntypeableNoFetch (untypeNoFetch)) import Database.HDBC (IConnection, Statement, SqlValue) import qualified Database.HDBC as HDBC import Database.Record (RecordToSql, ToSql(recordToSql), runFromRecord) -- | Typed prepared statement type. newtype PreparedStatement p a = PreparedStatement { -- | Untyped prepared statement before executed. prepared :: Statement } -- | Typed prepared statement which has bound placeholder parameters. data BoundStatement a = BoundStatement { -- | Untyped prepared statement before executed. bound :: Statement -- | Bound parameters. , params :: [SqlValue] } -- | Typed executed statement. data ExecutedStatement a = ExecutedStatement { -- | Untyped executed statement. executed :: Statement -- | Result of HDBC execute. , result :: Integer } -- | Unsafely untype prepared statement. untypePrepared :: PreparedStatement p a -> Statement untypePrepared = prepared -- | Run prepare and unsafely make Typed prepared statement. unsafePrepare :: IConnection conn => conn -- ^ Database connection -> String -- ^ Raw SQL String -> IO (PreparedStatement p a) -- ^ Result typed prepared query with parameter type 'p' and result type 'a' unsafePrepare conn = fmap PreparedStatement . HDBC.prepare conn -- | Generalized prepare inferred from 'UntypeableNoFetch' instance. prepareNoFetch :: (UntypeableNoFetch s, IConnection conn) => conn -> s p -> IO (PreparedStatement p ()) prepareNoFetch conn = unsafePrepare conn . untypeNoFetch -- | Close PreparedStatement. Useful for connection pooling cases. finish :: PreparedStatement p a -> IO () finish = HDBC.finish . prepared -- | Bracketed prepare operation. -- Unsafely make Typed prepared statement. 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. bind' :: RecordToSql SqlValue p -- ^ Proof object to convert from parameter type 'p' into 'SqlValue' list. -> PreparedStatement p a -- ^ Prepared query to bind to -> p -- ^ Parameter to bind -> BoundStatement a -- ^ Result parameter bound statement bind' toSql q p = BoundStatement { bound = prepared q, params = runFromRecord toSql p } -- | Typed operation to bind parameters. Infered 'RecordToSql' is used. bind :: ToSql SqlValue p => PreparedStatement p a -> p -> BoundStatement a bind = bind' recordToSql -- | Same as 'bind' except for argument is flipped. bindTo :: ToSql SqlValue p => p -> PreparedStatement p a -> BoundStatement a bindTo = flip bind -- | Typed execute operation. execute :: BoundStatement a -> IO (ExecutedStatement a) execute bs = do let stmt = bound bs n <- HDBC.execute stmt (params bs) return $ ExecutedStatement stmt n -- | Typed execute operation. Only get result. executeNoFetch :: BoundStatement () -> IO Integer executeNoFetch = fmap result . execute -- | Bind parameters, execute statement and get execution result. runPreparedNoFetch :: ToSql SqlValue a => PreparedStatement a () -> a -> IO Integer runPreparedNoFetch p = executeNoFetch . (p `bind`) -- | Prepare and run sequence for polymorphic no-fetch statement. runNoFetch :: (UntypeableNoFetch s, IConnection conn, ToSql SqlValue a) => conn -> s a -> a -> IO Integer runNoFetch conn s p = 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.6.0.2/src/Database/HDBC/Record/TH.hs0000644000000000000000000000231012731442376021123 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.6.0.2/src/Database/HDBC/Record/Persistable.hs0000644000000000000000000000162012731442376023070 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.6.0.2/src/Database/HDBC/Record/Insert.hs0000644000000000000000000000705212731442376022064 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | -- Module : Database.HDBC.Record.Insert -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module provides typed 'Insert' running sequence -- which intermediate structres are typed. module Database.HDBC.Record.Insert ( PreparedInsert, prepare, prepareInsert, runPreparedInsert, runInsert, mapInsert, chunksInsert, ) where import Database.HDBC (IConnection, SqlValue) import Database.Relational.Query (Insert (..), untypeChunkInsert, chunkSizeOfInsert) import Database.Record (ToSql, fromRecord) import Database.HDBC.Record.Statement (prepareNoFetch, withPrepareNoFetch, withUnsafePrepare, PreparedStatement, untypePrepared, BoundStatement (..), runPreparedNoFetch, runNoFetch, mapNoFetch, executeNoFetch) -- | Typed prepared insert type. type PreparedInsert a = PreparedStatement a () -- | Typed prepare insert operation. prepare :: IConnection conn => conn -> Insert a -> IO (PreparedInsert a) prepare = prepareNoFetch -- | Same as 'prepare'. prepareInsert :: IConnection conn => conn -> Insert a -> IO (PreparedInsert a) prepareInsert = prepare -- | Bind parameters, execute statement and get execution result. runPreparedInsert :: ToSql SqlValue a => PreparedInsert a -> a -> IO Integer runPreparedInsert = runPreparedNoFetch -- | Prepare insert statement, bind parameters, -- execute statement and get execution result. runInsert :: (IConnection conn, ToSql SqlValue a) => conn -> Insert a -> a -> IO Integer runInsert = runNoFetch -- | Prepare and insert each record. mapInsert :: (IConnection conn, ToSql SqlValue a) => conn -> Insert a -> [a] -> IO [Integer] mapInsert = mapNoFetch -- | Unsafely bind chunk of records. chunkBind :: ToSql SqlValue p => PreparedStatement [p] () -> [p] -> BoundStatement () chunkBind q ps = BoundStatement { bound = untypePrepared q, params = ps >>= fromRecord } chunks :: Int -> [a] -> [Either [a] [a]] chunks n = rec' where rec' xs | null tl = [ if length c == n then Right c else Left c ] | otherwise = Right c : rec' tl where (c, tl) = splitAt n xs 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) ) -- Prepare and insert with chunk insert statement. chunksInsertActions :: ToSql SqlValue a => [a] -> PreparedInsert a -> PreparedStatement [a] () -> Int -> IO [[Integer]] chunksInsertActions rs ins iChunk size = mapM insert $ chunks size rs where insert (Right c) = do rv <- executeNoFetch $ chunkBind iChunk c return [rv] insert (Left c) = mapM (runPreparedInsert ins) c -- | Prepare and insert with chunk insert statement. chunksInsert :: (IConnection conn, ToSql SqlValue a) => conn -> Insert a -> [a] -> IO [[Integer]] chunksInsert conn ins rs = withPrepareChunksInsert conn ins $ chunksInsertActions rs relational-query-HDBC-0.6.0.2/src/Database/HDBC/Query/0000755000000000000000000000000012731442376020147 5ustar0000000000000000relational-query-HDBC-0.6.0.2/src/Database/HDBC/Query/TH.hs0000644000000000000000000001557612731442376021034 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- | -- Module : Database.HDBC.Query.TH -- Copyright : 2013 Kei Hibino -- License : BSD3 -- -- Maintainer : ex8k.hibino@gmail.com -- Stability : experimental -- Portability : unknown -- -- This module contains templates to generate Haskell record types -- and HDBC instances correspond to RDB table schema. module Database.HDBC.Query.TH ( makeRecordPersistableDefault, defineTableDefault', defineTableDefault, defineTableFromDB', defineTableFromDB, inlineVerifiedQuery ) where import Data.Maybe (listToMaybe, fromMaybe) import qualified Data.Map as Map import Control.Applicative ((<$>), (<*>)) import Control.Monad (when, void) import Database.HDBC (IConnection, SqlValue, prepare) import Language.Haskell.TH (Q, runIO, Name, TypeQ, Dec) import Language.Haskell.TH.Name.CamelCase (varCamelcaseName) import Language.Haskell.TH.Lib.Extra (reportWarning, reportError) import Database.Record.TH (makeRecordPersistableWithSqlTypeDefault) import qualified Database.Record.TH as Record import Database.Relational.Query (Relation, Config, verboseAsCompilerWarning, defaultConfig, relationalQuerySQL) import Database.Relational.Query.SQL (QuerySuffix) import qualified Database.Relational.Query.TH as Relational import Database.HDBC.Session (withConnectionIO) import Database.HDBC.Record.Persistable () import Database.HDBC.Schema.Driver (runLog, newLogChan, takeLogs, Driver, getFields, getPrimaryKey) -- | Generate all persistable templates against defined record like type constructor. makeRecordPersistableDefault :: Name -- ^ Type constructor name -> Q [Dec] -- ^ Result declaration makeRecordPersistableDefault recTypeName = do rr <- Relational.makeRelationalRecordDefault recTypeName (pair, (_mayNs, cts)) <- Record.reifyRecordType recTypeName let width = length cts ps <- Record.makeRecordPersistableWithSqlType [t| SqlValue |] (Record.persistableFunctionNamesDefault recTypeName) pair width return $ rr ++ ps -- | Generate all HDBC templates about table except for constraint keys using default naming rule. defineTableDefault' :: Config -- ^ Configuration to generate query with -> String -- ^ Schema name -> String -- ^ Table name -> [(String, TypeQ)] -- ^ List of column name and type -> [Name] -- ^ Derivings -> Q [Dec] -- ^ Result declaration defineTableDefault' config schema table columns derives = do modelD <- Relational.defineTableTypesAndRecord config schema table columns derives sqlvD <- makeRecordPersistableWithSqlTypeDefault [t| SqlValue |] schema table $ length columns return $ modelD ++ sqlvD -- | Generate all HDBC templates about table using default naming rule. defineTableDefault :: Config -- ^ Configuration to generate query with -> String -- ^ Schema name -> String -- ^ Table name -> [(String, TypeQ)] -- ^ List of column name and type -> [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 <- makeRecordPersistableWithSqlTypeDefault [t| SqlValue |] schema table $ length columns return $ modelD ++ sqlvD -- | Generate all HDBC templates using system catalog informations with specified config. defineTableFromDB' :: IConnection conn => IO conn -- ^ Connect action to system catalog database -> Config -- ^ Configuration to generate query with -> Driver conn -- ^ Driver definition -> String -- ^ Schema name -> String -- ^ Table name -> [Name] -- ^ Derivings -> Q [Dec] -- ^ Result declaration defineTableFromDB' connect config drv scm tbl derives = do let getDBinfo = do logChan <- newLogChan $ verboseAsCompilerWarning config 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 mapM_ (runLog 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 defineTableDefault config scm tbl cols derives primaryIxs (listToMaybe notNullIdxs) -- | Generate all HDBC templates using system catalog informations. defineTableFromDB :: IConnection conn => IO conn -- ^ Connect action to system catalog database -> Driver conn -- ^ Driver definition -> String -- ^ Schema name -> String -- ^ Table name -> [Name] -- ^ Derivings -> Q [Dec] -- ^ Result declaration defineTableFromDB connect = defineTableFromDB' connect defaultConfig -- | Verify composed 'Query' and inline it in compile type. inlineVerifiedQuery :: IConnection conn => IO conn -- ^ Connect action to system catalog database -> Name -- ^ Top-level variable name which has 'Relation' type -> Relation p r -- ^ Object which has 'Relation' type -> Config -- ^ Configuration to generate SQL -> QuerySuffix -- ^ suffix SQL words -> String -- ^ Variable name to define as inlined query -> Q [Dec] -- ^ Result declarations inlineVerifiedQuery connect relVar rel config sufs qns = do (p, r) <- Relational.reifyRelation relVar let sql = relationalQuerySQL config rel sufs 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)