khibino/haskell-relational-record
1
1
Fork 0
mirror of https://github.com/khibino/haskell-relational-record.git synced 2024-12-27 14:02:35 +03:00
Code Issues Projects Releases Wiki Activity

relational-query-HDBC: prepare to switch module namespace.

Browse Source
This commit is contained in:
Kei Hibino 2019-06-11 02:37:41 +09:00
parent 06aa81b317
commit f5b5f0dec6
34 changed files with 1416 additions and 1321 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
relational-query-HDBC/relational-query-HDBC.cabal
View File

@ -28,6 +28,19 @@ extra-source-files: ChangeLog.md
library
exposed-modules:
Database.Relational.HDBC.SqlValueExtra
Database.Relational.HDBC.Persistable
Database.Relational.HDBC.Sequence
Database.Relational.HDBC.Statement
Database.Relational.HDBC.Query
Database.Relational.HDBC.Update
Database.Relational.HDBC.Insert
Database.Relational.HDBC.InsertQuery
Database.Relational.HDBC.Delete
Database.Relational.HDBC.KeyUpdate
Database.Relational.HDBC
Database.Relational.HDBC.TH
Database.HDBC.Record.Persistable
Database.HDBC.Record.TH
Database.HDBC.Record.Sequence
@ -50,7 +63,7 @@ library
Database.HDBC.Schema.MySQL
other-modules:
Database.HDBC.Record.InternalTH
Database.Relational.HDBC.InternalTH
build-depends: base <5
, containers

189
relational-query-HDBC/src/Database/HDBC/Query/TH.hs
View File

@ -1,187 +1,6 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-- |
-- Module : Database.HDBC.Query.TH
-- Copyright : 2013-2019 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
module Database.HDBC.Query.TH
{-# DEPRECATED "import Database.Relational.HDBC.TH" #-} (
module Database.Relational.HDBC.TH,
) 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.Lib.Extra (reportWarning, reportError)
import Language.SQL.Keyword (Keyword)
import Database.Record (ToSql, FromSql)
import Database.Record.TH (recordTemplate, defineSqlPersistableInstances)
import Database.Relational
(Config, nameConfig, recordConfig, enableWarning, verboseAsCompilerWarning,
defaultConfig, Relation)
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
-> [Keyword] -- ^ suffix SQL words. for example, `[FOR, UPDATE]`, `[FETCH, FIRST, "3", ROWS, ONLY]` ...
-> String -- ^ Variable name to define as inlined query
-> Q [Dec] -- ^ Result declarations
inlineVerifiedQuery connect relVar rel config sufs declName =
Relational.inlineQuery_ check relVar rel config sufs declName
where
check sql = do
when (verboseAsCompilerWarning config) . reportWarning $ "Verify with prepare: " ++ sql
void . runIO $ withConnectionIO connect (\conn -> prepare conn sql)
import Database.Relational.HDBC.TH

31
relational-query-HDBC/src/Database/HDBC/Record.hs
View File

@ -1,31 +1,8 @@
-- |
-- 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
module Database.HDBC.Record
{-# DEPRECATED "import Database.Relational.HDBC" #-} (
module Database.Relational.HDBC,
) 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
import Database.Relational.HDBC
{-# ANN module "HLint: ignore Use import/export shortcut" #-}

70
relational-query-HDBC/src/Database/HDBC/Record/Delete.hs
View File

@ -1,68 +1,6 @@
{-# 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
module Database.HDBC.Record.Delete
{-# DEPRECATED "import Database.Relational.HDBC.Delete" #-} (
module Database.Relational.HDBC.Delete
) 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
import Database.Relational.HDBC.Delete

176
relational-query-HDBC/src/Database/HDBC/Record/Insert.hs
View File

@ -1,174 +1,6 @@
{-# 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,
module Database.HDBC.Record.Insert
{-# DEPRECATED "import Database.Relational.HDBC.Insert" #-} (
module Database.Relational.HDBC.Insert
) 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]
import Database.Relational.HDBC.Insert

69
relational-query-HDBC/src/Database/HDBC/Record/InsertQuery.hs
View File

@ -1,67 +1,6 @@
{-# 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
module Database.HDBC.Record.InsertQuery
{-# DEPRECATED "import Database.Relational.HDBC.InsertQuery" #-} (
module Database.Relational.HDBC.InsertQuery
) 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
import Database.Relational.HDBC.InsertQuery

101
relational-query-HDBC/src/Database/HDBC/Record/KeyUpdate.hs
View File

@ -1,99 +1,6 @@
{-# 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
module Database.HDBC.Record.KeyUpdate
{-# DEPRECATED "import Database.Relational.HDBC.KeyUpdate" #-} (
module Database.Relational.HDBC.KeyUpdate
) 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)
import Database.Relational.HDBC.KeyUpdate

31
relational-query-HDBC/src/Database/HDBC/Record/Persistable.hs
View File

@ -1,28 +1,5 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
module Database.HDBC.Record.Persistable
{-# DEPRECATED "import Database.Relational.HDBC.Persistable" #-} (
) where
-- |
-- 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)
import Database.Relational.HDBC.Persistable ()

199
relational-query-HDBC/src/Database/HDBC/Record/Query.hs
View File

@ -1,197 +1,6 @@
{-# 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,
module Database.HDBC.Record.Query
{-# DEPRECATED "import Database.Relational.HDBC.Query" #-} (
module Database.Relational.HDBC.Query
) 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)
import Database.Relational.HDBC.Query

186
relational-query-HDBC/src/Database/HDBC/Record/Sequence.hs
View File

@ -1,184 +1,6 @@
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
{-# LANGUAGE FlexibleContexts #-}
-- |
-- Module : Database.HDBC.Record.Sequence
-- Copyright : 2017-2019 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 (
-- * Get pool of sequence numbers
getPool, getSeq, getAutoPool,
poolFromSeq, autoPoolFromSeq,
-- * Deprecated
pool, autoPool,
unsafePool, unsafeAutoPool,
module Database.HDBC.Record.Sequence
{-# DEPRECATED "import Database.Relational.HDBC.Sequence" #-} (
module Database.Relational.HDBC.Sequence
) where
import Control.Applicative ((<$>))
import Control.Monad (when, void)
import Data.Maybe (listToMaybe)
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, relationFromTable,
seqFromRelation, seqTable, tableName, updateNumber)
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, unsafeSpecifyNumber)
-- | Get a sized pool of sequence number from sequence table corresponding proper Table 'r'
getPool :: (FromSql SqlValue s, ToSql SqlValue i,
PersistableWidth i, LiteralSQL i,
Bounded i, Integral i, Show i, IConnection conn,
Binding r s i)
=> IO conn -- ^ action to connect to DBMS
-> i -- ^ pool size
-> Relation () r -- ^ table relation corresponding sequence table
-> IO [i] -- ^ action to get pool
getPool connAct sz = seqPool connAct sz . seqFromRelation
getSeq :: (FromSql SqlValue s, ToSql SqlValue i,
PersistableWidth i, LiteralSQL i,
Bounded i, Integral i, Show i, IConnection conn,
Binding r s i)
=> IO conn -- ^ action to connect to DBMS
-> Relation () r -- ^ table relation corresponding sequence table
-> IO i -- ^ action to get pool
getSeq connAct rel =
maybe (fail $ "Sequence.getSeq: fail to get seq from seq-table: " ++ n) return . listToMaybe =<<
getPool connAct 1 rel
where
n = tableName . seqTable $ seqFromRelation rel
-- | Get a lazy-IO pool of sequence number from sequence table corresponding proper Table 'r'
getAutoPool :: (FromSql SqlValue s,
ToSql SqlValue i, LiteralSQL i,
Bounded i, Integral i, Show i, IConnection conn,
Binding r s i)
=> IO conn -- ^ action to connect to DBMS
-> i -- ^ buffer size
-> Relation () r -- ^ table relation corresponding sequence table
-> IO [i] -- ^ action to get lazy-IO pool
getAutoPool connAct sz = unsafeAutoPool connAct sz . seqFromRelation
-- | 'Number' result version of 'getPool'.
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 unsafeSpecifyNumber <$>)
. seqPool connAct sz
. seqFromRelation
{-# WARNING pool "Number will be dropped in the future. use getPool instead of this." #-}
-- | 'Number' result version of 'getAutoPool'.
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 unsafeSpecifyNumber <$>)
. unsafeAutoPool connAct sz
. seqFromRelation
{-# WARNING autoPool "Number will be dropped in the future. use getAutoPool instead of this." #-}
-----
-- | Get a sized pool of sequence number from sequence table directly.
poolFromSeq :: (FromSql SqlValue s, PersistableWidth s,
ToSql SqlValue i, LiteralSQL i,
Bounded i, Integral i, Show i, IConnection conn)
=> IO conn -- ^ action to connect to DBMS
-> i -- ^ pool size
-> Sequence s i -- ^ sequence table to get pool from
-> IO [i] -- ^ action to get pool
poolFromSeq = seqPool
-- | Get a lazy-IO pool of sequence number from sequence table directly.
autoPoolFromSeq :: (FromSql SqlValue s, PersistableWidth s,
ToSql SqlValue i, LiteralSQL i,
Bounded i, Integral i, Show i, IConnection conn)
=> IO conn -- ^ action to connect to DBMS
-> i -- ^ buffer size
-> Sequence s i -- ^ sequence table to get pool from
-> IO [i] -- ^ action to get lazy-IO pool
autoPoolFromSeq connAct sz seqt = loop where
loop = unsafeInterleaveIO $ do
hd <- seqPool connAct sz seqt
(hd ++) <$> loop
-- | Depredated. use poolFromSeq instead of this.
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 = seqPool
{-# DEPRECATED unsafePool "use poolFromSeq instead of this." #-}
-- | Deprecated. use autoPoolFromSeq instead of this.
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 = autoPoolFromSeq
{-# DEPRECATED unsafeAutoPool "use autoPoolFromSeq instead of this." #-}
seqPool :: (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]
seqPool connAct sz seqt = withConnectionIO connAct $ \conn -> do
let t = seqTable seqt
name = tableName t
pq <- prepareQuery conn $ relationalQuery' (relationFromTable 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 (updateNumber seq1 seqt) ()
maybe (return ()) (const . fail $ "More than two record found in seq table: " ++ name) =<< fetch es
commit conn
return [seq0 + 1 .. seq1]
import Database.Relational.HDBC.Sequence

176
relational-query-HDBC/src/Database/HDBC/Record/Statement.hs
View File

@ -1,174 +1,6 @@
{-# 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,
module Database.HDBC.Record.Statement
{-# DEPRECATED "import Database.Relational.HDBC.Statement" #-} (
module Database.Relational.HDBC.Statement
) 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)
import Database.Relational.HDBC.Statement

2
relational-query-HDBC/src/Database/HDBC/Record/TH.hs
View File

@ -18,7 +18,7 @@ module Database.HDBC.Record.TH
import Language.Haskell.TH (Q, Dec, Type, )
import qualified Database.HDBC.Record.InternalTH as Internal
import qualified Database.Relational.HDBC.InternalTH as Internal
(derivePersistableInstanceFromConvertible)

78
relational-query-HDBC/src/Database/HDBC/Record/Update.hs
View File

@ -1,76 +1,6 @@
{-# 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
module Database.HDBC.Record.Update
{-# DEPRECATED "import Database.Relational.HDBC.Update" #-} (
module Database.Relational.HDBC.Update
) 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
import Database.Relational.HDBC.Update

4
relational-query-HDBC/src/Database/HDBC/Schema/IBMDB2.hs
View File

@ -31,8 +31,8 @@ import Control.Monad.Trans.Maybe (MaybeT)
import Database.HDBC (IConnection, SqlValue)
import Database.HDBC.Record.Query (runQuery')
import Database.HDBC.Record.Persistable ()
import Database.Relational.HDBC.Query (runQuery')
import Database.Relational.HDBC.Persistable ()
import Database.Record (FromSql, ToSql)

4
relational-query-HDBC/src/Database/HDBC/Schema/MySQL.hs
View File

@ -27,8 +27,8 @@ 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.Relational.HDBC.Query (runQuery')
import Database.Relational.HDBC.Persistable ()
import Database.HDBC.Schema.Driver ( TypeMap
, LogChan
, putVerbose

4
relational-query-HDBC/src/Database/HDBC/Schema/Oracle.hs
View File

@ -25,8 +25,8 @@ 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.Relational.HDBC.Query (runQuery')
import Database.Relational.HDBC.Persistable ()
import Database.HDBC.Schema.Driver
( TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe,
Driver, driverConfig, getFieldsWithMap, getPrimaryKey, emptyDriver

4
relational-query-HDBC/src/Database/HDBC/Schema/PostgreSQL.hs
View File

@ -28,8 +28,8 @@ import Control.Monad.Trans.Maybe (MaybeT)
import Database.HDBC (IConnection, SqlValue)
import Database.HDBC.Record.Query (runQuery')
import Database.HDBC.Record.Persistable ()
import Database.Relational.HDBC.Query (runQuery')
import Database.Relational.HDBC.Persistable ()
import Database.Record (FromSql, ToSql)

4
relational-query-HDBC/src/Database/HDBC/Schema/SQLServer.hs
View File

@ -24,8 +24,8 @@ 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.Relational.HDBC.Query (runQuery')
import Database.Relational.HDBC.Persistable ()
import Database.HDBC.Schema.Driver
(TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe,
Driver, driverConfig, getFieldsWithMap, getPrimaryKey, emptyDriver)

4
relational-query-HDBC/src/Database/HDBC/Schema/SQLite3.hs
View File

@ -25,8 +25,8 @@ 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.Relational.HDBC.Query (runQuery')
import Database.Relational.HDBC.Persistable ()
import Database.HDBC.Schema.Driver
(TypeMap, LogChan, putVerbose, failWith, maybeIO, hoistMaybe,
Driver, driverConfig, getFieldsWithMap, getPrimaryKey, emptyDriver)

46
relational-query-HDBC/src/Database/HDBC/SqlValueExtra.hs
View File

@ -1,51 +1,15 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS -fno-warn-orphans #-}
-- |
-- Module : Database.HDBC.SqlValueExtra
-- Copyright : 2013-2018 Kei Hibino
-- Copyright : 2019 Kei Hibino
-- License : BSD3
--
-- Maintainer : ex8k.hibino@gmail.com
-- Stability : experimental
-- Portability : unknown
module Database.HDBC.SqlValueExtra () where
module Database.HDBC.SqlValueExtra
{-# DEPRECATED "import Database.Relational.HDBC.SqlValueExtra instead of this." #-}
() 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
import Database.Relational.HDBC.SqlValueExtra ()

31
relational-query-HDBC/src/Database/Relational/HDBC.hs Normal file
View File

@ -0,0 +1,31 @@
-- |
-- Module : Database.Relational.HDBC
-- Copyright : 2019 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.Relational.HDBC (
module Database.Relational.HDBC.Query,
module Database.Relational.HDBC.Insert,
module Database.Relational.HDBC.InsertQuery,
module Database.Relational.HDBC.Update,
module Database.Relational.HDBC.KeyUpdate,
module Database.Relational.HDBC.Delete,
module Database.Relational.HDBC.Statement
) where
import Database.Relational.HDBC.Query hiding (prepare)
import Database.Relational.HDBC.Insert hiding (prepare)
import Database.Relational.HDBC.InsertQuery hiding (prepare)
import Database.Relational.HDBC.Update hiding (prepare)
import Database.Relational.HDBC.KeyUpdate hiding (prepare)
import Database.Relational.HDBC.Delete hiding (prepare)
import Database.Relational.HDBC.Statement
{-# ANN module "HLint: ignore Use import/export shortcut" #-}

68
relational-query-HDBC/src/Database/Relational/HDBC/Delete.hs Normal file
View File

@ -0,0 +1,68 @@
{-# LANGUAGE FlexibleContexts #-}
-- |
-- Module : Database.Relational.HDBC.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.Relational.HDBC.Delete (
PreparedDelete, prepare, prepareDelete, withPrepareDelete,
runPreparedDelete, runDelete
) where
import Database.HDBC (IConnection, SqlValue)
import Database.Relational (Delete)
import Database.Record (ToSql)
import Database.Relational.HDBC.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

174
relational-query-HDBC/src/Database/Relational/HDBC/Insert.hs Normal file
View File

@ -0,0 +1,174 @@
{-# LANGUAGE FlexibleContexts #-}
-- |
-- Module : Database.Relational.HDBC.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.Relational.HDBC.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.Relational.HDBC.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]

67
relational-query-HDBC/src/Database/Relational/HDBC/InsertQuery.hs Normal file
View File

@ -0,0 +1,67 @@
{-# LANGUAGE FlexibleContexts #-}
-- |
-- Module : Database.Relational.HDBC.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.Relational.HDBC.InsertQuery (
PreparedInsertQuery, prepare, prepareInsertQuery, withPrepareInsertQuery,
runPreparedInsertQuery, runInsertQuery
) where
import Database.HDBC (IConnection, SqlValue)
import Database.Relational (InsertQuery)
import Database.Record (ToSql)
import Database.Relational.HDBC.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

6
relational-query-HDBC/src/Database/HDBC/Record/InternalTH.hs → relational-query-HDBC/src/Database/Relational/HDBC/InternalTH.hs
View File

@ -2,7 +2,7 @@
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
-- |
-- Module : Database.HDBC.Record.InternalTH
-- Module : Database.Relational.HDBC.InternalTH
-- Copyright : 2013-2019 Kei Hibino
-- License : BSD3
--
@ -11,7 +11,7 @@
-- Portability : unknown
--
-- This module provides internal definitions used from DB-record templates.
module Database.HDBC.Record.InternalTH (
module Database.Relational.HDBC.InternalTH (
-- * Persistable instances along with 'Convertible' instances
derivePersistableInstanceFromConvertible,
derivePersistableInstancesFromConvertibleSqlValues,
@ -27,7 +27,7 @@ import Language.Haskell.TH
import Language.Haskell.TH.Compat.Data (unInstanceD)
import Data.Convertible (Convertible, convert)
import Database.HDBC (SqlValue)
import Database.HDBC.SqlValueExtra ()
import Database.Relational.HDBC.SqlValueExtra ()
import Database.Record
(PersistableWidth, FromSql (..), ToSql (..),
valueRecordFromSql, valueRecordToSql)

99
relational-query-HDBC/src/Database/Relational/HDBC/KeyUpdate.hs Normal file
View File

@ -0,0 +1,99 @@
{-# LANGUAGE FlexibleContexts #-}
-- |
-- Module : Database.Relational.HDBC.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.Relational.HDBC.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.Relational.HDBC.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)

28
relational-query-HDBC/src/Database/Relational/HDBC/Persistable.hs Normal file
View File

@ -0,0 +1,28 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
-- |
-- Module : Database.Relational.HDBC.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.Relational.HDBC.Persistable () where
import Database.Record (PersistableType (..))
import Database.Record.Persistable (unsafePersistableSqlTypeFromNull)
import Database.Relational.HDBC.InternalTH (derivePersistableInstancesFromConvertibleSqlValues)
import Database.HDBC (SqlValue(SqlNull))
instance PersistableType SqlValue where
persistableType = unsafePersistableSqlTypeFromNull SqlNull
$(derivePersistableInstancesFromConvertibleSqlValues)

197
relational-query-HDBC/src/Database/Relational/HDBC/Query.hs Normal file
View File

@ -0,0 +1,197 @@
{-# LANGUAGE FlexibleContexts #-}
-- |
-- Module : Database.Relational.HDBC.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.Relational.HDBC.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.Relational.HDBC.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)

184
relational-query-HDBC/src/Database/Relational/HDBC/Sequence.hs Normal file
View File

@ -0,0 +1,184 @@
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
{-# LANGUAGE FlexibleContexts #-}
-- |
-- Module : Database.Relational.HDBC.Sequence
-- Copyright : 2017-2019 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.Relational.HDBC.Sequence (
-- * Get pool of sequence numbers
getPool, getSeq, getAutoPool,
poolFromSeq, autoPoolFromSeq,
-- * Deprecated
pool, autoPool,
unsafePool, unsafeAutoPool,
) where
import Control.Applicative ((<$>))
import Control.Monad (when, void)
import Data.Maybe (listToMaybe)
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, relationFromTable,
seqFromRelation, seqTable, tableName, updateNumber)
import Database.Relational.HDBC.Persistable ()
import Database.Relational.HDBC.Statement (bind, executeBound)
import Database.Relational.HDBC.Query (prepareQuery, fetch)
import Database.Relational.HDBC.Update (runUpdate)
import Database.Relational (Sequence (..), Binding, Number, unsafeSpecifyNumber)
-- | Get a sized pool of sequence number from sequence table corresponding proper Table 'r'
getPool :: (FromSql SqlValue s, ToSql SqlValue i,
PersistableWidth i, LiteralSQL i,
Bounded i, Integral i, Show i, IConnection conn,
Binding r s i)
=> IO conn -- ^ action to connect to DBMS
-> i -- ^ pool size
-> Relation () r -- ^ table relation corresponding sequence table
-> IO [i] -- ^ action to get pool
getPool connAct sz = seqPool connAct sz . seqFromRelation
getSeq :: (FromSql SqlValue s, ToSql SqlValue i,
PersistableWidth i, LiteralSQL i,
Bounded i, Integral i, Show i, IConnection conn,
Binding r s i)
=> IO conn -- ^ action to connect to DBMS
-> Relation () r -- ^ table relation corresponding sequence table
-> IO i -- ^ action to get pool
getSeq connAct rel =
maybe (fail $ "Sequence.getSeq: fail to get seq from seq-table: " ++ n) return . listToMaybe =<<
getPool connAct 1 rel
where
n = tableName . seqTable $ seqFromRelation rel
-- | Get a lazy-IO pool of sequence number from sequence table corresponding proper Table 'r'
getAutoPool :: (FromSql SqlValue s,
ToSql SqlValue i, LiteralSQL i,
Bounded i, Integral i, Show i, IConnection conn,
Binding r s i)
=> IO conn -- ^ action to connect to DBMS
-> i -- ^ buffer size
-> Relation () r -- ^ table relation corresponding sequence table
-> IO [i] -- ^ action to get lazy-IO pool
getAutoPool connAct sz = unsafeAutoPool connAct sz . seqFromRelation
-- | 'Number' result version of 'getPool'.
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 unsafeSpecifyNumber <$>)
. seqPool connAct sz
. seqFromRelation
{-# WARNING pool "Number will be dropped in the future. use getPool instead of this." #-}
-- | 'Number' result version of 'getAutoPool'.
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 unsafeSpecifyNumber <$>)
. unsafeAutoPool connAct sz
. seqFromRelation
{-# WARNING autoPool "Number will be dropped in the future. use getAutoPool instead of this." #-}
-----
-- | Get a sized pool of sequence number from sequence table directly.
poolFromSeq :: (FromSql SqlValue s, PersistableWidth s,
ToSql SqlValue i, LiteralSQL i,
Bounded i, Integral i, Show i, IConnection conn)
=> IO conn -- ^ action to connect to DBMS
-> i -- ^ pool size
-> Sequence s i -- ^ sequence table to get pool from
-> IO [i] -- ^ action to get pool
poolFromSeq = seqPool
-- | Get a lazy-IO pool of sequence number from sequence table directly.
autoPoolFromSeq :: (FromSql SqlValue s, PersistableWidth s,
ToSql SqlValue i, LiteralSQL i,
Bounded i, Integral i, Show i, IConnection conn)
=> IO conn -- ^ action to connect to DBMS
-> i -- ^ buffer size
-> Sequence s i -- ^ sequence table to get pool from
-> IO [i] -- ^ action to get lazy-IO pool
autoPoolFromSeq connAct sz seqt = loop where
loop = unsafeInterleaveIO $ do
hd <- seqPool connAct sz seqt
(hd ++) <$> loop
-- | Depredated. use poolFromSeq instead of this.
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 = seqPool
{-# DEPRECATED unsafePool "use poolFromSeq instead of this." #-}
-- | Deprecated. use autoPoolFromSeq instead of this.
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 = autoPoolFromSeq
{-# DEPRECATED unsafeAutoPool "use autoPoolFromSeq instead of this." #-}
seqPool :: (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]
seqPool connAct sz seqt = withConnectionIO connAct $ \conn -> do
let t = seqTable seqt
name = tableName t
pq <- prepareQuery conn $ relationalQuery' (relationFromTable 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 (updateNumber seq1 seqt) ()
maybe (return ()) (const . fail $ "More than two record found in seq table: " ++ name) =<< fetch es
commit conn
return [seq0 + 1 .. seq1]

51
relational-query-HDBC/src/Database/Relational/HDBC/SqlValueExtra.hs Normal file
View File

@ -0,0 +1,51 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS -fno-warn-orphans #-}
-- |
-- Module : Database.Relational.HDBC.SqlValueExtra
-- Copyright : 2013-2018 Kei Hibino
-- License : BSD3
--
-- Maintainer : ex8k.hibino@gmail.com
-- Stability : experimental
-- Portability : unknown
module Database.Relational.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

174
relational-query-HDBC/src/Database/Relational/HDBC/Statement.hs Normal file
View File

@ -0,0 +1,174 @@
{-# LANGUAGE FlexibleContexts #-}
-- |
-- Module : Database.Relational.HDBC.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.Relational.HDBC.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)

187
relational-query-HDBC/src/Database/Relational/HDBC/TH.hs Normal file
View File

@ -0,0 +1,187 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-- |
-- Module : Database.Relational.HDBC.TH
-- Copyright : 2013-2019 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.Relational.HDBC.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.Lib.Extra (reportWarning, reportError)
import Language.SQL.Keyword (Keyword)
import Database.Record (ToSql, FromSql)
import Database.Record.TH (recordTemplate, defineSqlPersistableInstances)
import Database.Relational
(Config, nameConfig, recordConfig, enableWarning, verboseAsCompilerWarning,
defaultConfig, Relation)
import qualified Database.Relational.TH as Relational
import Database.HDBC.Session (withConnectionIO)
import Database.Relational.HDBC.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
-> [Keyword] -- ^ suffix SQL words. for example, `[FOR, UPDATE]`, `[FETCH, FIRST, "3", ROWS, ONLY]` ...
-> String -- ^ Variable name to define as inlined query
-> Q [Dec] -- ^ Result declarations
inlineVerifiedQuery connect relVar rel config sufs declName =
Relational.inlineQuery_ check relVar rel config sufs declName
where
check sql = do
when (verboseAsCompilerWarning config) . reportWarning $ "Verify with prepare: " ++ sql
void . runIO $ withConnectionIO connect (\conn -> prepare conn sql)

76
relational-query-HDBC/src/Database/Relational/HDBC/Update.hs Normal file
View File

@ -0,0 +1,76 @@
{-# LANGUAGE FlexibleContexts #-}
-- |
-- Module : Database.Relational.HDBC.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.Relational.HDBC.Update (
PreparedUpdate, prepare, prepareUpdate, withPrepareUpdate,
runPreparedUpdate, runUpdate, mapUpdate
) where
import Database.HDBC (IConnection, SqlValue)
import Database.Relational (Update)
import Database.Record (ToSql)
import Database.Relational.HDBC.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

2
relational-query-HDBC/test/convertibleIso.hs
View File

@ -9,7 +9,7 @@ import Database.HDBC (SqlValue (SqlInteger))
import Test.QuickCheck (Arbitrary (..), resize)
import Test.QuickCheck.Simple (qcTest, defaultMain)
import Database.HDBC.Record.Persistable ()
import Database.Relational.HDBC.Persistable ()