HDBC-odbc 2.5.0.1 → 2.5.1.1
raw patch · 29 files changed
+2998/−2969 lines, 29 filessetup-changed
Files
- Database/HDBC/ODBC.hs +23/−23
- Database/HDBC/ODBC/Api/Errors.hs +57/−57
- Database/HDBC/ODBC/Api/Imports.hsc +157/−157
- Database/HDBC/ODBC/Api/Types.hsc +37/−37
- Database/HDBC/ODBC/Connection.hsc +208/−208
- Database/HDBC/ODBC/ConnectionImpl.hs +46/−42
- Database/HDBC/ODBC/Log.hs +15/−15
- Database/HDBC/ODBC/Statement.hsc +1053/−1039
- Database/HDBC/ODBC/TypeConv.hsc +102/−102
- Database/HDBC/ODBC/Utils.hs +18/−18
- Database/HDBC/ODBC/Wrappers.hs +188/−179
- HDBC-odbc.cabal +117/−117
- LICENSE +27/−27
- Makefile +36/−36
- README.md +109/−107
- Setup.hs +5/−5
- cbits/hdbc-odbc-helper.c +23/−23
- cbits/hdbc-odbc-helper.h +20/−20
- changelog.txt +15/−15
- stresstest/stresstest.hs +55/−55
- testsrc/SpecificDB.hs +24/−24
- testsrc/SpecificDBTests.hs +5/−5
- testsrc/TestMisc.hs +181/−181
- testsrc/TestSbasics.hs +156/−156
- testsrc/TestTime.hs +99/−99
- testsrc/TestUtils.hs +25/−25
- testsrc/Testbasics.hs +168/−168
- testsrc/Tests.hs +17/−17
- testsrc/runtests.hs +12/−12
Database/HDBC/ODBC.hs view
@@ -1,23 +1,23 @@-{- | - Module : Database.HDBC.ODBC - Copyright : Copyright (C) 2005 John Goerzen - License : BSD3 - - Maintainer : John Goerzen <jgoerzen@complete.org> - Stability : provisional - Portability: portable - -HDBC driver interface for ODBC 3.x - -Written by John Goerzen, jgoerzen\@complete.org --} - -module Database.HDBC.ODBC - ( - connectODBC, Connection(), getQueryInfo, setAutoCommit - ) - -where - -import Database.HDBC.ODBC.Connection(connectODBC, Connection()) -import Database.HDBC.ODBC.ConnectionImpl(getQueryInfo, setAutoCommit) +{- |+ Module : Database.HDBC.ODBC+ Copyright : Copyright (C) 2005 John Goerzen+ License : BSD3++ Maintainer : John Goerzen <jgoerzen@complete.org>+ Stability : provisional+ Portability: portable++HDBC driver interface for ODBC 3.x++Written by John Goerzen, jgoerzen\@complete.org+-}++module Database.HDBC.ODBC+ (+ connectODBC, Connection(), getQueryInfo, setAutoCommit+ )++where++import Database.HDBC.ODBC.Connection(connectODBC, Connection())+import Database.HDBC.ODBC.ConnectionImpl(getQueryInfo, setAutoCommit)
Database/HDBC/ODBC/Api/Errors.hs view
@@ -1,57 +1,57 @@-{-# LANGUAGE CPP, DoAndIfThenElse #-} -module Database.HDBC.ODBC.Api.Errors - ( checkError - , raiseError - , sqlSucceeded - ) where - -import Control.Monad (unless) -import Database.HDBC (SqlError (..), throwSqlError) -import Database.HDBC.ODBC.Api.Imports -import Database.HDBC.ODBC.Api.Types -import Foreign.C -import Foreign.Marshal.Alloc -import Foreign.Ptr -import Foreign.Storable - -checkError :: String -> AnyHandle -> SQLRETURN -> IO () -checkError msg o res = - unless (sqlSucceeded res) $ raiseError msg res o - -raiseError :: String -> SQLRETURN -> AnyHandle -> IO a -raiseError msg code cconn = do - info <- getDiag ht hp 1 - throwSqlError SqlError - { seState = show (map fst info) - , seNativeError = fromIntegral code - , seErrorMsg = msg ++ ": " ++ show (map snd info) - } - where - (ht, hp) = case cconn of - EnvHandle c -> (sQL_HANDLE_ENV, castPtr c) - DbcHandle c -> (sQL_HANDLE_DBC, castPtr c) - StmtHandle c -> (sQL_HANDLE_STMT, castPtr c) - -foreign import ccall safe "sqlSucceeded" - c_sqlSucceeded :: SQLRETURN -> CInt - -sqlSucceeded :: SQLRETURN -> Bool -sqlSucceeded x = c_sqlSucceeded x /= 0 - -getDiag :: SQLSMALLINT -> SQLHANDLE -> SQLSMALLINT -> IO [(String, String)] -getDiag ht hp irow = - allocaBytes 6 $ \csstate -> - alloca $ \pnaterr -> - allocaBytes 1025 $ \csmsg -> - alloca $ \pmsglen -> do - ret <- c_sqlGetDiagRecW ht hp irow csstate pnaterr csmsg 1024 pmsglen - if sqlSucceeded ret - then do - state <- peekCWStringLen (csstate, 5) - nat <- peek pnaterr - msglen <- peek pmsglen - msgstr <- peekCWStringLen (csmsg, fromIntegral msglen) - next <- getDiag ht hp (irow + 1) - return $ (state, show nat ++ ": " ++ msgstr) : next - else - return [] +{-# LANGUAGE CPP, DoAndIfThenElse #-}+module Database.HDBC.ODBC.Api.Errors+ ( checkError+ , raiseError+ , sqlSucceeded+ ) where++import Control.Monad (unless)+import Database.HDBC (SqlError (..), throwSqlError)+import Database.HDBC.ODBC.Api.Imports+import Database.HDBC.ODBC.Api.Types+import Foreign.C+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable++checkError :: String -> AnyHandle -> SQLRETURN -> IO ()+checkError msg o res =+ unless (sqlSucceeded res) $ raiseError msg res o++raiseError :: String -> SQLRETURN -> AnyHandle -> IO a+raiseError msg code cconn = do+ info <- getDiag ht hp 1+ throwSqlError SqlError+ { seState = show (map fst info)+ , seNativeError = fromIntegral code+ , seErrorMsg = msg ++ ": " ++ show (map snd info)+ }+ where+ (ht, hp) = case cconn of+ EnvHandle c -> (sQL_HANDLE_ENV, castPtr c)+ DbcHandle c -> (sQL_HANDLE_DBC, castPtr c)+ StmtHandle c -> (sQL_HANDLE_STMT, castPtr c)++foreign import ccall safe "sqlSucceeded"+ c_sqlSucceeded :: SQLRETURN -> CInt++sqlSucceeded :: SQLRETURN -> Bool+sqlSucceeded x = c_sqlSucceeded x /= 0++getDiag :: SQLSMALLINT -> SQLHANDLE -> SQLSMALLINT -> IO [(String, String)]+getDiag ht hp irow =+ allocaBytes 6 $ \csstate ->+ alloca $ \pnaterr ->+ allocaBytes 1025 $ \csmsg ->+ alloca $ \pmsglen -> do+ ret <- c_sqlGetDiagRecW ht hp irow csstate pnaterr csmsg 1024 pmsglen+ if sqlSucceeded ret+ then do+ state <- peekCWStringLen (csstate, 5)+ nat <- peek pnaterr+ msglen <- peek pmsglen+ msgstr <- peekCWStringLen (csmsg, fromIntegral msglen)+ next <- getDiag ht hp (irow + 1)+ return $ (state, show nat ++ ": " ++ msgstr) : next+ else+ return []
Database/HDBC/ODBC/Api/Imports.hsc view
@@ -1,157 +1,157 @@-{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-} -module Database.HDBC.ODBC.Api.Imports - ( sQL_HANDLE_ENV - , sQL_HANDLE_DBC - , sQL_HANDLE_STMT - , sQL_CLOSE - , sQL_UNBIND - , sQL_RESET_PARAMS - , c_sqlAllocHandle - , c_sqlCancel - , c_sqlCloseCursor - , c_sqlDisconnect - , c_sqlFreeHandle - , c_sqlFreeStmt - , c_sqlGetDiagRecW - , c_sqlSetConnectAttr - , c_sqlGetConnectAttr - , sQL_ATTR_AUTOCOMMIT - , sQL_AUTOCOMMIT_ON - , sQL_AUTOCOMMIT_OFF - , sQL_IS_UINTEGER - ) where - -import Database.HDBC.ODBC.Api.Types -import Database.HDBC.ODBC.Log -import Foreign.C.String -import Foreign.Ptr -import Text.Printf - -#ifdef mingw32_HOST_OS -#include <windows.h> -#endif - -#include <sql.h> -#include <sqlext.h> -#include <sqlucode.h> - -#ifdef mingw32_HOST_OS -#let CALLCONV = "stdcall" -#else -#let CALLCONV = "ccall" -#endif - -sQL_HANDLE_ENV :: SQLSMALLINT -sQL_HANDLE_ENV = #{const SQL_HANDLE_ENV} - -sQL_HANDLE_STMT :: SQLSMALLINT -sQL_HANDLE_STMT = #{const SQL_HANDLE_STMT} - -sQL_HANDLE_DBC :: SQLSMALLINT -sQL_HANDLE_DBC = #{const SQL_HANDLE_DBC} - -foreign import #{CALLCONV} safe "sql.h SQLAllocHandle" - imp_sqlAllocHandle :: SQLSMALLINT -> SQLHANDLE -> Ptr SQLHANDLE -> IO SQLRETURN - -c_sqlAllocHandle :: SQLSMALLINT -> SQLHANDLE -> Ptr SQLHANDLE -> IO SQLRETURN -c_sqlAllocHandle handleType inputHandle outputHandlePtr = do - result <- imp_sqlAllocHandle handleType inputHandle outputHandlePtr - hdbcTrace $ printf "SQLAllocHandle(%d, %s, %s) returned %d" handleType (show inputHandle) (show outputHandlePtr) result - return result - -foreign import #{CALLCONV} safe "sql.h SQLFreeHandle" - imp_sqlFreeHandle :: SQLSMALLINT -> SQLHANDLE -> IO SQLRETURN - -c_sqlFreeHandle :: SQLSMALLINT -> SQLHANDLE -> IO SQLRETURN -c_sqlFreeHandle handleType handle = do - result <- imp_sqlFreeHandle handleType handle - hdbcTrace $ printf "SQLFreeHandle(%d, %s) returned %d" handleType (show handle) result - return result - -foreign import #{CALLCONV} safe "sql.h SQLCancel" - imp_sqlCancel :: SQLHSTMT -> IO SQLRETURN - -c_sqlCancel :: SQLHSTMT -> IO SQLRETURN -c_sqlCancel hStmt = do - result <- imp_sqlCancel hStmt - hdbcTrace $ printf "SQLCancel(%s) returned %d" (show hStmt) result - return result - -foreign import #{CALLCONV} safe "sql.h SQLCloseCursor" - imp_sqlCloseCursor :: SQLHSTMT -> IO SQLRETURN - -c_sqlCloseCursor :: SQLHSTMT -> IO SQLRETURN -c_sqlCloseCursor hStmt = do - result <- imp_sqlCloseCursor hStmt - hdbcTrace $ printf "SQLCloseCursor(%s) returned %d" (show hStmt) result - return result - -foreign import #{CALLCONV} safe "sql.h SQLDisconnect" - imp_sqlDisconnect :: SQLHDBC -> IO SQLRETURN - -c_sqlDisconnect hDbc = do - result <- imp_sqlDisconnect hDbc - hdbcTrace $ printf "SQLDisconnect(%s) returned %d" (show hDbc) result - return result - -foreign import #{CALLCONV} safe "sql.h SQLGetDiagRecW" - imp_sqlGetDiagRecW :: SQLSMALLINT -> Ptr () -> SQLSMALLINT -> CWString - -> Ptr SQLINTEGER -> CWString -> SQLSMALLINT - -> Ptr SQLSMALLINT -> IO SQLRETURN - -c_sqlGetDiagRecW :: SQLSMALLINT -> Ptr () -> SQLSMALLINT -> CWString -> Ptr SQLINTEGER - -> CWString -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN -c_sqlGetDiagRecW handleType handle recNumber sqlState nativeErrorPtr messageText bufferLength textLengthPtr = do - result <- imp_sqlGetDiagRecW handleType handle recNumber sqlState nativeErrorPtr messageText bufferLength textLengthPtr - hdbcTrace $ printf "SqlGetDiagRec(%d, %s, %d, %s, %s, %s, %d, %s) returned %d" - handleType (show handle) recNumber (show sqlState) (show nativeErrorPtr) (show messageText) bufferLength (show textLengthPtr) result - return result - -sQL_CLOSE :: SQLUSMALLINT -sQL_CLOSE = #{const SQL_CLOSE} - -sQL_UNBIND :: SQLUSMALLINT -sQL_UNBIND = #{const SQL_UNBIND} - -sQL_RESET_PARAMS :: SQLUSMALLINT -sQL_RESET_PARAMS = #{const SQL_RESET_PARAMS} - -foreign import #{CALLCONV} safe "sql.h SQLFreeStmt" - imp_sqlFreeStmt :: SQLHSTMT -> SQLUSMALLINT -> IO SQLRETURN - -c_sqlFreeStmt :: SQLHSTMT -> SQLUSMALLINT -> IO SQLRETURN -c_sqlFreeStmt stmt option = do - result <- imp_sqlFreeStmt stmt option - hdbcTrace $ printf "SqlFreeStmt(%s, %d) returned %d" (show stmt) option result - return result - -foreign import #{CALLCONV} safe "sql.h SQLSetConnectAttr" - imp_sqlSetConnectAttr :: SQLHDBC -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> IO SQLRETURN - -c_sqlSetConnectAttr :: SQLHDBC -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> IO SQLRETURN -c_sqlSetConnectAttr conn attr valuePtr stringLength = do - result <- imp_sqlSetConnectAttr conn attr valuePtr stringLength - hdbcTrace $ printf "SQLSetConnectAttr (%s, %d, %s, %d) returned %d" (show conn) attr (show valuePtr) stringLength result - return result - -foreign import #{CALLCONV} safe "sql.h SQLGetConnectAttr" - imp_sqlGetConnectAttr :: SQLHDBC -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN - -c_sqlGetConnectAttr :: SQLHDBC -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN -c_sqlGetConnectAttr conn attr valuePtr bufferLength stringLengthPtr = do - result <- imp_sqlGetConnectAttr conn attr valuePtr bufferLength stringLengthPtr - hdbcTrace $ printf "SQLGetConnectAttr (%s, %d, %s, %d, %s) return %d" - (show conn) attr (show valuePtr) bufferLength (show stringLengthPtr) result - return result - -sQL_ATTR_AUTOCOMMIT :: SQLINTEGER -sQL_ATTR_AUTOCOMMIT = #{const SQL_ATTR_AUTOCOMMIT} - -sQL_AUTOCOMMIT_ON :: SQLUINTEGER -sQL_AUTOCOMMIT_ON = #{const SQL_AUTOCOMMIT_ON} - -sQL_AUTOCOMMIT_OFF :: SQLUINTEGER -sQL_AUTOCOMMIT_OFF = #{const SQL_AUTOCOMMIT_OFF} - -sQL_IS_UINTEGER :: SQLINTEGER -sQL_IS_UINTEGER = #{const SQL_IS_UINTEGER} +{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}+module Database.HDBC.ODBC.Api.Imports+ ( sQL_HANDLE_ENV+ , sQL_HANDLE_DBC+ , sQL_HANDLE_STMT+ , sQL_CLOSE+ , sQL_UNBIND+ , sQL_RESET_PARAMS+ , c_sqlAllocHandle+ , c_sqlCancel+ , c_sqlCloseCursor+ , c_sqlDisconnect+ , c_sqlFreeHandle+ , c_sqlFreeStmt+ , c_sqlGetDiagRecW+ , c_sqlSetConnectAttr+ , c_sqlGetConnectAttr+ , sQL_ATTR_AUTOCOMMIT+ , sQL_AUTOCOMMIT_ON+ , sQL_AUTOCOMMIT_OFF+ , sQL_IS_UINTEGER+ ) where++import Database.HDBC.ODBC.Api.Types+import Database.HDBC.ODBC.Log+import Foreign.C.String+import Foreign.Ptr+import Text.Printf++#ifdef mingw32_HOST_OS+#include <windows.h>+#endif++#include <sql.h>+#include <sqlext.h>+#include <sqlucode.h>++#ifdef mingw32_HOST_OS+#let CALLCONV = "stdcall"+#else+#let CALLCONV = "ccall"+#endif++sQL_HANDLE_ENV :: SQLSMALLINT+sQL_HANDLE_ENV = #{const SQL_HANDLE_ENV}++sQL_HANDLE_STMT :: SQLSMALLINT+sQL_HANDLE_STMT = #{const SQL_HANDLE_STMT}++sQL_HANDLE_DBC :: SQLSMALLINT+sQL_HANDLE_DBC = #{const SQL_HANDLE_DBC}++foreign import #{CALLCONV} safe "sql.h SQLAllocHandle"+ imp_sqlAllocHandle :: SQLSMALLINT -> SQLHANDLE -> Ptr SQLHANDLE -> IO SQLRETURN++c_sqlAllocHandle :: SQLSMALLINT -> SQLHANDLE -> Ptr SQLHANDLE -> IO SQLRETURN+c_sqlAllocHandle handleType inputHandle outputHandlePtr = do+ result <- imp_sqlAllocHandle handleType inputHandle outputHandlePtr+ hdbcTrace $ printf "SQLAllocHandle(%d, %s, %s) returned %d" handleType (show inputHandle) (show outputHandlePtr) result+ return result++foreign import #{CALLCONV} safe "sql.h SQLFreeHandle"+ imp_sqlFreeHandle :: SQLSMALLINT -> SQLHANDLE -> IO SQLRETURN++c_sqlFreeHandle :: SQLSMALLINT -> SQLHANDLE -> IO SQLRETURN+c_sqlFreeHandle handleType handle = do+ result <- imp_sqlFreeHandle handleType handle+ hdbcTrace $ printf "SQLFreeHandle(%d, %s) returned %d" handleType (show handle) result+ return result++foreign import #{CALLCONV} safe "sql.h SQLCancel"+ imp_sqlCancel :: SQLHSTMT -> IO SQLRETURN++c_sqlCancel :: SQLHSTMT -> IO SQLRETURN+c_sqlCancel hStmt = do+ result <- imp_sqlCancel hStmt+ hdbcTrace $ printf "SQLCancel(%s) returned %d" (show hStmt) result+ return result++foreign import #{CALLCONV} safe "sql.h SQLCloseCursor"+ imp_sqlCloseCursor :: SQLHSTMT -> IO SQLRETURN++c_sqlCloseCursor :: SQLHSTMT -> IO SQLRETURN+c_sqlCloseCursor hStmt = do+ result <- imp_sqlCloseCursor hStmt+ hdbcTrace $ printf "SQLCloseCursor(%s) returned %d" (show hStmt) result+ return result++foreign import #{CALLCONV} safe "sql.h SQLDisconnect"+ imp_sqlDisconnect :: SQLHDBC -> IO SQLRETURN++c_sqlDisconnect hDbc = do+ result <- imp_sqlDisconnect hDbc+ hdbcTrace $ printf "SQLDisconnect(%s) returned %d" (show hDbc) result+ return result++foreign import #{CALLCONV} safe "sql.h SQLGetDiagRecW"+ imp_sqlGetDiagRecW :: SQLSMALLINT -> Ptr () -> SQLSMALLINT -> CWString+ -> Ptr SQLINTEGER -> CWString -> SQLSMALLINT+ -> Ptr SQLSMALLINT -> IO SQLRETURN++c_sqlGetDiagRecW :: SQLSMALLINT -> Ptr () -> SQLSMALLINT -> CWString -> Ptr SQLINTEGER+ -> CWString -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN+c_sqlGetDiagRecW handleType handle recNumber sqlState nativeErrorPtr messageText bufferLength textLengthPtr = do+ result <- imp_sqlGetDiagRecW handleType handle recNumber sqlState nativeErrorPtr messageText bufferLength textLengthPtr+ hdbcTrace $ printf "SqlGetDiagRec(%d, %s, %d, %s, %s, %s, %d, %s) returned %d"+ handleType (show handle) recNumber (show sqlState) (show nativeErrorPtr) (show messageText) bufferLength (show textLengthPtr) result+ return result++sQL_CLOSE :: SQLUSMALLINT+sQL_CLOSE = #{const SQL_CLOSE}++sQL_UNBIND :: SQLUSMALLINT+sQL_UNBIND = #{const SQL_UNBIND}++sQL_RESET_PARAMS :: SQLUSMALLINT+sQL_RESET_PARAMS = #{const SQL_RESET_PARAMS}++foreign import #{CALLCONV} safe "sql.h SQLFreeStmt"+ imp_sqlFreeStmt :: SQLHSTMT -> SQLUSMALLINT -> IO SQLRETURN++c_sqlFreeStmt :: SQLHSTMT -> SQLUSMALLINT -> IO SQLRETURN+c_sqlFreeStmt stmt option = do+ result <- imp_sqlFreeStmt stmt option+ hdbcTrace $ printf "SqlFreeStmt(%s, %d) returned %d" (show stmt) option result+ return result++foreign import #{CALLCONV} safe "sql.h SQLSetConnectAttr"+ imp_sqlSetConnectAttr :: SQLHDBC -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> IO SQLRETURN++c_sqlSetConnectAttr :: SQLHDBC -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> IO SQLRETURN+c_sqlSetConnectAttr conn attr valuePtr stringLength = do+ result <- imp_sqlSetConnectAttr conn attr valuePtr stringLength+ hdbcTrace $ printf "SQLSetConnectAttr (%s, %d, %s, %d) returned %d" (show conn) attr (show valuePtr) stringLength result+ return result++foreign import #{CALLCONV} safe "sql.h SQLGetConnectAttr"+ imp_sqlGetConnectAttr :: SQLHDBC -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN++c_sqlGetConnectAttr :: SQLHDBC -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN+c_sqlGetConnectAttr conn attr valuePtr bufferLength stringLengthPtr = do+ result <- imp_sqlGetConnectAttr conn attr valuePtr bufferLength stringLengthPtr+ hdbcTrace $ printf "SQLGetConnectAttr (%s, %d, %s, %d, %s) return %d"+ (show conn) attr (show valuePtr) bufferLength (show stringLengthPtr) result+ return result++sQL_ATTR_AUTOCOMMIT :: SQLINTEGER+sQL_ATTR_AUTOCOMMIT = #{const SQL_ATTR_AUTOCOMMIT}++sQL_AUTOCOMMIT_ON :: SQLUINTEGER+sQL_AUTOCOMMIT_ON = #{const SQL_AUTOCOMMIT_ON}++sQL_AUTOCOMMIT_OFF :: SQLUINTEGER+sQL_AUTOCOMMIT_OFF = #{const SQL_AUTOCOMMIT_OFF}++sQL_IS_UINTEGER :: SQLINTEGER+sQL_IS_UINTEGER = #{const SQL_IS_UINTEGER}
Database/HDBC/ODBC/Api/Types.hsc view
@@ -1,37 +1,37 @@-{-# LANGUAGE EmptyDataDecls #-} -module Database.HDBC.ODBC.Api.Types - ( SQLENV, SQLDBC, SQLSTMT - , SQLHENV, SQLHDBC, SQLHSTMT, SQLHANDLE - , AnyHandle (..) - , SQLRETURN, SQLSMALLINT, SQLINTEGER - , SQLUSMALLINT, SQLUINTEGER, SQLPOINTER - ) where - -import Data.Int (Int16, Int32) -import Data.Word (Word16, Word32) -import Foreign.Ptr - -#ifdef mingw32_HOST_OS -#include <windows.h> -#endif -#include <sql.h> - -data SQLENV -data SQLDBC -data SQLSTMT - -type SQLHENV = Ptr SQLENV -type SQLHDBC = Ptr SQLDBC -type SQLHSTMT = Ptr SQLSTMT -type SQLHANDLE = Ptr () - -data AnyHandle = EnvHandle SQLHENV - | DbcHandle SQLHDBC - | StmtHandle SQLHSTMT - -type SQLRETURN = #{type SQLRETURN} -type SQLSMALLINT = #{type SQLSMALLINT} -type SQLINTEGER = #{type SQLINTEGER} -type SQLUSMALLINT = #{type SQLUSMALLINT} -type SQLUINTEGER = #{type SQLUINTEGER} -type SQLPOINTER = Ptr () +{-# LANGUAGE EmptyDataDecls #-}+module Database.HDBC.ODBC.Api.Types+ ( SQLENV, SQLDBC, SQLSTMT+ , SQLHENV, SQLHDBC, SQLHSTMT, SQLHANDLE+ , AnyHandle (..)+ , SQLRETURN, SQLSMALLINT, SQLINTEGER+ , SQLUSMALLINT, SQLUINTEGER, SQLPOINTER+ ) where++import Data.Int (Int16, Int32)+import Data.Word (Word16, Word32)+import Foreign.Ptr++#ifdef mingw32_HOST_OS+#include <windows.h>+#endif+#include <sql.h>++data SQLENV+data SQLDBC+data SQLSTMT++type SQLHENV = Ptr SQLENV+type SQLHDBC = Ptr SQLDBC+type SQLHSTMT = Ptr SQLSTMT+type SQLHANDLE = Ptr ()++data AnyHandle = EnvHandle SQLHENV+ | DbcHandle SQLHDBC+ | StmtHandle SQLHSTMT++type SQLRETURN = #{type SQLRETURN}+type SQLSMALLINT = #{type SQLSMALLINT}+type SQLINTEGER = #{type SQLINTEGER}+type SQLUSMALLINT = #{type SQLUSMALLINT}+type SQLUINTEGER = #{type SQLUINTEGER}+type SQLPOINTER = Ptr ()
Database/HDBC/ODBC/Connection.hsc view
@@ -1,208 +1,208 @@--- -*- mode: haskell; -*- -{-# CFILES hdbc-odbc-helper.c #-} --- Above line for hugs - -module Database.HDBC.ODBC.Connection (connectODBC, Impl.Connection) where - -import Database.HDBC.Types -import Database.HDBC -import Database.HDBC.DriverUtils -import qualified Database.HDBC.ODBC.ConnectionImpl as Impl -import Database.HDBC.ODBC.Api.Imports -import Database.HDBC.ODBC.Api.Errors -import Database.HDBC.ODBC.Api.Types -import Database.HDBC.ODBC.Statement -import Database.HDBC.ODBC.Wrappers -import Foreign.C.Types -import Foreign.C.String -import Foreign.Marshal hiding (void) -import Foreign.Storable -import Database.HDBC.ODBC.Utils -import Foreign.ForeignPtr -import Foreign.Ptr -import Data.Word -import Data.Int -import Control.Concurrent.MVar -import Control.Monad (when, void) -import qualified Data.ByteString as B -import qualified Data.ByteString.UTF8 as BUTF8 - -#ifdef mingw32_HOST_OS -#include <windows.h> -#endif -#include <sql.h> -#include <sqlext.h> - -#ifdef mingw32_HOST_OS -#let CALLCONV = "stdcall" -#else -#let CALLCONV = "ccall" -#endif - -{- | Connect to an ODBC server. - -For information on the meaning of the passed string, please see: - -<http://msdn2.microsoft.com/en-us/library/ms715433(VS.85).aspx> - -An example string is: - ->"DSN=hdbctest1" - -This, and all other functions that use ODBC directly or indirectly, can raise -SqlErrors just like other HDBC backends. The seErrorMsg field is specified -as a String in HDBC. ODBC specifies this data as a list of strings. -Therefore, this driver uses show on the data from ODBC. For friendly display, -or handling of individual component messages in your code, you can use -read on the seErrorMsg field in a context that expects @[String]@. - -Important note for MySQL users: - -Unless you are going to use InnoDB tables, you are strongly encouraged to set - ->Option = 262144 - -in your odbc.ini (for Unix users), or to disable transaction support in your -DSN setup for Windows users. - -If you fail to do this, the MySQL ODBC driver will incorrectly state that it -supports transactions. dbTransactionSupport will incorrectly return True. -commit and rollback will then silently fail. This is certainly /NOT/ what you -want. It is a bug (or misfeature) in the MySQL driver, not in HDBC. - -You should ignore this advice if you are using InnoDB tables. - --} -connectODBC :: String -> IO Impl.Connection -connectODBC args = - B.useAsCStringLen (BUTF8.fromString args) $ \(cs, cslen) -> do - -- Create the Environment Handle - env <- sqlAllocEnv - withEnvOrDie env $ \hEnv -> - sqlSetEnvAttr hEnv #{const SQL_ATTR_ODBC_VERSION} (getSqlOvOdbc3) 0 - - -- Create the DBC handle. - dbc <- sqlAllocDbc env - -- Now connect. - withDbcOrDie dbc $ \hDbc -> - sqlDriverConnect hDbc nullPtr cs (fromIntegral cslen) - nullPtr 0 nullPtr #{const SQL_DRIVER_NOPROMPT} - >>= checkError "connectODBC/sqlDriverConnect" (DbcHandle hDbc) - - mkConn args dbc - --- FIXME: environment vars may have changed, should use pgsql enquiries --- for clone. -mkConn :: String -> DbcWrapper -> IO Impl.Connection -mkConn args iconn = withDbcOrDie iconn $ \cconn -> - alloca $ \plen -> - alloca $ \psqlusmallint -> - allocaBytes 128 $ \pbuf -> - do - children <- newMVar [] - sqlGetInfo cconn #{const SQL_DBMS_VER} (castPtr pbuf) 127 plen - >>= checkError "sqlGetInfo SQL_DBMS_VER" (DbcHandle cconn) - len <- peek plen - serverver <- peekCStringLen (pbuf, fromIntegral len) - - sqlGetInfo cconn #{const SQL_DRIVER_VER} (castPtr pbuf) 127 plen - >>= checkError "sqlGetInfo SQL_DRIVER_VER" (DbcHandle cconn) - len <- peek plen - proxiedclientver <- peekCStringLen (pbuf, fromIntegral len) - - sqlGetInfo cconn #{const SQL_ODBC_VER} (castPtr pbuf) 127 plen - >>= checkError "sqlGetInfo SQL_ODBC_VER" (DbcHandle cconn) - len <- peek plen - clientver <- peekCStringLen (pbuf, fromIntegral len) - - sqlGetInfo cconn #{const SQL_DBMS_NAME} (castPtr pbuf) 127 plen - >>= checkError "sqlGetInfo SQL_DBMS_NAME" (DbcHandle cconn) - len <- peek plen - clientname <- peekCStringLen (pbuf, fromIntegral len) - - sqlGetInfo cconn #{const SQL_TXN_CAPABLE} (castPtr psqlusmallint) - 0 nullPtr - >>= checkError "sqlGetInfo SQL_TXN_CAPABLE" (DbcHandle cconn) - txninfo <- ((peek psqlusmallint)::IO (#{type SQLUSMALLINT})) - let txnsupport = txninfo /= #{const SQL_TC_NONE} - - when txnsupport . void $ fSetAutoCommit cconn False - return $ Impl.Connection { - Impl.getQueryInfo = fGetQueryInfo iconn children, - Impl.disconnect = fdisconnect iconn children, - Impl.commit = fcommit iconn, - Impl.rollback = frollback iconn, - Impl.run = frun iconn children, - Impl.prepare = newSth iconn children, - Impl.clone = connectODBC args, - -- FIXME: add clone - Impl.hdbcDriverName = "odbc", - Impl.hdbcClientVer = clientver, - Impl.proxiedClientName = clientname, - Impl.proxiedClientVer = proxiedclientver, - Impl.dbServerVer = serverver, - Impl.dbTransactionSupport = txnsupport, - Impl.getTables = fgettables iconn, - Impl.describeTable = fdescribetable iconn, - Impl.setAutoCommit = \x -> withDbcOrDie iconn $ \conn -> fSetAutoCommit conn x - } - --------------------------------------------------- --- Guts here --------------------------------------------------- - -frun conn children query args = - do sth <- newSth conn children query - res <- execute sth args - finish sth - return res - -fcommit iconn = withDbcOrDie iconn $ \cconn -> - sqlEndTran #{const SQL_HANDLE_DBC} cconn #{const SQL_COMMIT} - >>= checkError "sqlEndTran commit" (DbcHandle cconn) - -frollback iconn = withDbcOrDie iconn $ \cconn -> - sqlEndTran #{const SQL_HANDLE_DBC} cconn #{const SQL_ROLLBACK} - >>= checkError "sqlEndTran rollback" (DbcHandle cconn) - -fdisconnect iconn mchildren = do - closeAllChildren mchildren - freeDbcIfNotAlready True iconn - -fGetAutoCommit :: SQLHDBC -> IO Bool -fGetAutoCommit hdbc = do - value <- with (0 :: SQLUINTEGER) $ \acBuf -> do - c_sqlGetConnectAttr hdbc sQL_ATTR_AUTOCOMMIT (castPtr acBuf) sQL_IS_UINTEGER nullPtr - >>= checkError "sqlGetConnectAttr" (DbcHandle hdbc) - peek acBuf - return $ value /= sQL_AUTOCOMMIT_OFF - -fSetAutoCommit :: SQLHDBC -> Bool -> IO Bool -fSetAutoCommit hdbc newValue = do - oldValue <- fGetAutoCommit hdbc - let newValueRaw = if newValue then sQL_AUTOCOMMIT_ON else sQL_AUTOCOMMIT_OFF - c_sqlSetConnectAttr hdbc sQL_ATTR_AUTOCOMMIT (wordPtrToPtr $ fromIntegral newValueRaw) sQL_IS_UINTEGER - >>= checkError "sqlSetConnectAttr" (DbcHandle hdbc) - return oldValue - -foreign import #{CALLCONV} safe "sql.h SQLSetEnvAttr" - sqlSetEnvAttr :: SQLHENV -> #{type SQLINTEGER} -> - Ptr () -> #{type SQLINTEGER} -> IO #{type SQLRETURN} - -foreign import #{CALLCONV} safe "sql.h SQLDriverConnect" - sqlDriverConnect :: SQLHDBC -> Ptr () -> CString -> #{type SQLSMALLINT} - -> CString -> #{type SQLSMALLINT} - -> Ptr #{type SQLSMALLINT} -> #{type SQLUSMALLINT} - -> IO #{type SQLRETURN} - -foreign import ccall safe "hdbc-odbc-helper.h getSqlOvOdbc3" - getSqlOvOdbc3 :: Ptr () - -foreign import #{CALLCONV} safe "sql.h SQLEndTran" - sqlEndTran :: #{type SQLSMALLINT} -> SQLHDBC -> #{type SQLSMALLINT} - -> IO #{type SQLRETURN} - -foreign import #{CALLCONV} safe "sql.h SQLGetInfo" - sqlGetInfo :: SQLHDBC -> #{type SQLUSMALLINT} -> Ptr () -> - #{type SQLSMALLINT} -> Ptr #{type SQLSMALLINT} -> - IO #{type SQLRETURN} +-- -*- mode: haskell; -*-+{-# CFILES hdbc-odbc-helper.c #-}+-- Above line for hugs++module Database.HDBC.ODBC.Connection (connectODBC, Impl.Connection) where++import Database.HDBC.Types+import Database.HDBC+import Database.HDBC.DriverUtils+import qualified Database.HDBC.ODBC.ConnectionImpl as Impl+import Database.HDBC.ODBC.Api.Imports+import Database.HDBC.ODBC.Api.Errors+import Database.HDBC.ODBC.Api.Types+import Database.HDBC.ODBC.Statement+import Database.HDBC.ODBC.Wrappers+import Foreign.C.Types+import Foreign.C.String+import Foreign.Marshal hiding (void)+import Foreign.Storable+import Database.HDBC.ODBC.Utils+import Foreign.ForeignPtr+import Foreign.Ptr+import Data.Word+import Data.Int+import Control.Concurrent.MVar+import Control.Monad (when, void)+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as BUTF8++#ifdef mingw32_HOST_OS+#include <windows.h>+#endif+#include <sql.h>+#include <sqlext.h>++#ifdef mingw32_HOST_OS+#let CALLCONV = "stdcall"+#else+#let CALLCONV = "ccall"+#endif++{- | Connect to an ODBC server.++For information on the meaning of the passed string, please see:++<http://msdn2.microsoft.com/en-us/library/ms715433(VS.85).aspx>++An example string is:++>"DSN=hdbctest1"++This, and all other functions that use ODBC directly or indirectly, can raise+SqlErrors just like other HDBC backends. The seErrorMsg field is specified+as a String in HDBC. ODBC specifies this data as a list of strings.+Therefore, this driver uses show on the data from ODBC. For friendly display,+or handling of individual component messages in your code, you can use+read on the seErrorMsg field in a context that expects @[String]@.++Important note for MySQL users:++Unless you are going to use InnoDB tables, you are strongly encouraged to set++>Option = 262144++in your odbc.ini (for Unix users), or to disable transaction support in your+DSN setup for Windows users.++If you fail to do this, the MySQL ODBC driver will incorrectly state that it+supports transactions. dbTransactionSupport will incorrectly return True.+commit and rollback will then silently fail. This is certainly /NOT/ what you+want. It is a bug (or misfeature) in the MySQL driver, not in HDBC.++You should ignore this advice if you are using InnoDB tables.++-}+connectODBC :: String -> IO Impl.Connection+connectODBC args =+ B.useAsCStringLen (BUTF8.fromString args) $ \(cs, cslen) -> do+ -- Create the Environment Handle+ env <- sqlAllocEnv+ withEnvOrDie env $ \hEnv ->+ sqlSetEnvAttr hEnv #{const SQL_ATTR_ODBC_VERSION} (getSqlOvOdbc3) 0++ -- Create the DBC handle.+ dbc <- sqlAllocDbc env+ -- Now connect.+ withDbcOrDie dbc $ \hDbc ->+ sqlDriverConnect hDbc nullPtr cs (fromIntegral cslen)+ nullPtr 0 nullPtr #{const SQL_DRIVER_NOPROMPT}+ >>= checkError "connectODBC/sqlDriverConnect" (DbcHandle hDbc)++ mkConn args dbc++-- FIXME: environment vars may have changed, should use pgsql enquiries+-- for clone.+mkConn :: String -> DbcWrapper -> IO Impl.Connection+mkConn args iconn = withDbcOrDie iconn $ \cconn ->+ alloca $ \plen ->+ alloca $ \psqlusmallint ->+ allocaBytes 128 $ \pbuf ->+ do+ children <- newMVar []+ sqlGetInfo cconn #{const SQL_DBMS_VER} (castPtr pbuf) 127 plen+ >>= checkError "sqlGetInfo SQL_DBMS_VER" (DbcHandle cconn)+ len <- peek plen+ serverver <- peekCStringLen (pbuf, fromIntegral len)++ sqlGetInfo cconn #{const SQL_DRIVER_VER} (castPtr pbuf) 127 plen+ >>= checkError "sqlGetInfo SQL_DRIVER_VER" (DbcHandle cconn)+ len <- peek plen+ proxiedclientver <- peekCStringLen (pbuf, fromIntegral len)++ sqlGetInfo cconn #{const SQL_ODBC_VER} (castPtr pbuf) 127 plen+ >>= checkError "sqlGetInfo SQL_ODBC_VER" (DbcHandle cconn)+ len <- peek plen+ clientver <- peekCStringLen (pbuf, fromIntegral len)++ sqlGetInfo cconn #{const SQL_DBMS_NAME} (castPtr pbuf) 127 plen+ >>= checkError "sqlGetInfo SQL_DBMS_NAME" (DbcHandle cconn)+ len <- peek plen+ clientname <- peekCStringLen (pbuf, fromIntegral len)++ sqlGetInfo cconn #{const SQL_TXN_CAPABLE} (castPtr psqlusmallint)+ 0 nullPtr+ >>= checkError "sqlGetInfo SQL_TXN_CAPABLE" (DbcHandle cconn)+ txninfo <- ((peek psqlusmallint)::IO (#{type SQLUSMALLINT}))+ let txnsupport = txninfo /= #{const SQL_TC_NONE}++ when txnsupport . void $ fSetAutoCommit cconn False+ return $ Impl.Connection {+ Impl.getQueryInfo = fGetQueryInfo iconn children,+ Impl.disconnect = fdisconnect iconn children,+ Impl.commit = fcommit iconn,+ Impl.rollback = frollback iconn,+ Impl.run = frun iconn children,+ Impl.prepare = newSth iconn children,+ Impl.clone = connectODBC args,+ -- FIXME: add clone+ Impl.hdbcDriverName = "odbc",+ Impl.hdbcClientVer = clientver,+ Impl.proxiedClientName = clientname,+ Impl.proxiedClientVer = proxiedclientver,+ Impl.dbServerVer = serverver,+ Impl.dbTransactionSupport = txnsupport,+ Impl.getTables = fgettables iconn,+ Impl.describeTable = fdescribetable iconn,+ Impl.setAutoCommit = \x -> withDbcOrDie iconn $ \conn -> fSetAutoCommit conn x+ }++--------------------------------------------------+-- Guts here+--------------------------------------------------++frun conn children query args =+ do sth <- newSth conn children query+ res <- execute sth args+ finish sth+ return res++fcommit iconn = withDbcOrDie iconn $ \cconn ->+ sqlEndTran #{const SQL_HANDLE_DBC} cconn #{const SQL_COMMIT}+ >>= checkError "sqlEndTran commit" (DbcHandle cconn)++frollback iconn = withDbcOrDie iconn $ \cconn ->+ sqlEndTran #{const SQL_HANDLE_DBC} cconn #{const SQL_ROLLBACK}+ >>= checkError "sqlEndTran rollback" (DbcHandle cconn)++fdisconnect iconn mchildren = do+ closeAllChildren mchildren+ freeDbcIfNotAlready True iconn++fGetAutoCommit :: SQLHDBC -> IO Bool+fGetAutoCommit hdbc = do+ value <- with (0 :: SQLUINTEGER) $ \acBuf -> do+ c_sqlGetConnectAttr hdbc sQL_ATTR_AUTOCOMMIT (castPtr acBuf) sQL_IS_UINTEGER nullPtr+ >>= checkError "sqlGetConnectAttr" (DbcHandle hdbc)+ peek acBuf+ return $ value /= sQL_AUTOCOMMIT_OFF++fSetAutoCommit :: SQLHDBC -> Bool -> IO Bool+fSetAutoCommit hdbc newValue = do+ oldValue <- fGetAutoCommit hdbc+ let newValueRaw = if newValue then sQL_AUTOCOMMIT_ON else sQL_AUTOCOMMIT_OFF+ c_sqlSetConnectAttr hdbc sQL_ATTR_AUTOCOMMIT (wordPtrToPtr $ fromIntegral newValueRaw) sQL_IS_UINTEGER+ >>= checkError "sqlSetConnectAttr" (DbcHandle hdbc)+ return oldValue++foreign import #{CALLCONV} safe "sql.h SQLSetEnvAttr"+ sqlSetEnvAttr :: SQLHENV -> #{type SQLINTEGER} ->+ Ptr () -> #{type SQLINTEGER} -> IO #{type SQLRETURN}++foreign import #{CALLCONV} safe "sql.h SQLDriverConnect"+ sqlDriverConnect :: SQLHDBC -> Ptr () -> CString -> #{type SQLSMALLINT}+ -> CString -> #{type SQLSMALLINT}+ -> Ptr #{type SQLSMALLINT} -> #{type SQLUSMALLINT}+ -> IO #{type SQLRETURN}++foreign import ccall safe "hdbc-odbc-helper.h getSqlOvOdbc3"+ getSqlOvOdbc3 :: Ptr ()++foreign import #{CALLCONV} safe "sql.h SQLEndTran"+ sqlEndTran :: #{type SQLSMALLINT} -> SQLHDBC -> #{type SQLSMALLINT}+ -> IO #{type SQLRETURN}++foreign import #{CALLCONV} safe "sql.h SQLGetInfo"+ sqlGetInfo :: SQLHDBC -> #{type SQLUSMALLINT} -> Ptr () ->+ #{type SQLSMALLINT} -> Ptr #{type SQLSMALLINT} ->+ IO #{type SQLRETURN}
Database/HDBC/ODBC/ConnectionImpl.hs view
@@ -1,42 +1,46 @@-module Database.HDBC.ODBC.ConnectionImpl where - -import qualified Database.HDBC.Statement as Types -import qualified Database.HDBC.Types as Types -import Database.HDBC.ColTypes as ColTypes - -data Connection = - Connection { - getQueryInfo :: String -> IO ([SqlColDesc], [(String, SqlColDesc)]), - disconnect :: IO (), - commit :: IO (), - rollback :: IO (), - run :: String -> [Types.SqlValue] -> IO Integer, - prepare :: String -> IO Types.Statement, - clone :: IO Connection, - hdbcDriverName :: String, - hdbcClientVer :: String, - proxiedClientName :: String, - proxiedClientVer :: String, - dbServerVer :: String, - dbTransactionSupport :: Bool, - getTables :: IO [String], - describeTable :: String -> IO [(String, ColTypes.SqlColDesc)], - -- | Changes AutoCommit mode of the given connection. Returns previous value. - setAutoCommit :: Bool -> IO Bool - } - -instance Types.IConnection Connection where - disconnect = disconnect - commit = commit - rollback = rollback - run = run - prepare = prepare - clone = clone - hdbcDriverName = hdbcDriverName - hdbcClientVer = hdbcClientVer - proxiedClientName = proxiedClientName - proxiedClientVer = proxiedClientVer - dbServerVer = dbServerVer - dbTransactionSupport = dbTransactionSupport - getTables = getTables - describeTable = describeTable +module Database.HDBC.ODBC.ConnectionImpl where++import qualified Database.HDBC.Statement as Types+import qualified Database.HDBC.Types as Types+import Database.HDBC.ColTypes as ColTypes+import Control.Exception (finally)++data Connection =+ Connection {+ getQueryInfo :: String -> IO ([SqlColDesc], [(String, SqlColDesc)]),+ disconnect :: IO (),+ commit :: IO (),+ rollback :: IO (),+ run :: String -> [Types.SqlValue] -> IO Integer,+ prepare :: String -> IO Types.Statement,+ clone :: IO Connection,+ hdbcDriverName :: String,+ hdbcClientVer :: String,+ proxiedClientName :: String,+ proxiedClientVer :: String,+ dbServerVer :: String,+ dbTransactionSupport :: Bool,+ getTables :: IO [String],+ describeTable :: String -> IO [(String, ColTypes.SqlColDesc)],+ -- | Changes AutoCommit mode of the given connection. Returns previous value.+ setAutoCommit :: Bool -> IO Bool+ }++instance Types.IConnection Connection where+ disconnect = disconnect+ commit = commit+ rollback = rollback+ run = run+ runRaw conn sql = do+ sth <- prepare conn sql+ Types.executeRaw sth `finally` Types.finish sth+ prepare = prepare+ clone = clone+ hdbcDriverName = hdbcDriverName+ hdbcClientVer = hdbcClientVer+ proxiedClientName = proxiedClientName+ proxiedClientVer = proxiedClientVer+ dbServerVer = dbServerVer+ dbTransactionSupport = dbTransactionSupport+ getTables = getTables+ describeTable = describeTable
Database/HDBC/ODBC/Log.hs view
@@ -1,15 +1,15 @@-{-# LANGUAGE OverloadedStrings #-} -module Database.HDBC.ODBC.Log - ( hdbcLog - , hdbcTrace - ) where - -import System.IO - -hdbcLog :: String -> IO () -hdbcLog _ = return () --- hdbcLog m = hPutStrLn stderr ("\n" ++ m) - -hdbcTrace :: String -> IO () -hdbcTrace _ = return () --- hdbcTrace m = hPutStrLn stderr ("\n" ++ m) +{-# LANGUAGE OverloadedStrings #-}+module Database.HDBC.ODBC.Log+ ( hdbcLog+ , hdbcTrace+ ) where++import System.IO++hdbcLog :: String -> IO ()+hdbcLog _ = return ()+-- hdbcLog m = hPutStrLn stderr ("\n" ++ m)++hdbcTrace :: String -> IO ()+hdbcTrace _ = return ()+-- hdbcTrace m = hPutStrLn stderr ("\n" ++ m)
Database/HDBC/ODBC/Statement.hsc view
@@ -1,1039 +1,1053 @@--- -*- mode: haskell; -*- -{-# CFILES hdbc-odbc-helper.c #-} --- Above line for hugs -{-# LANGUAGE EmptyDataDecls #-} - -module Database.HDBC.ODBC.Statement ( - fGetQueryInfo, - newSth, - fgettables, - fdescribetable - ) where - -import Database.HDBC.Types -import Database.HDBC -import Database.HDBC.DriverUtils -import Database.HDBC.ODBC.Api.Errors -import Database.HDBC.ODBC.Api.Imports -import Database.HDBC.ODBC.Api.Types -import Database.HDBC.ODBC.Utils -import Database.HDBC.ODBC.Log -import Database.HDBC.ODBC.TypeConv -import Database.HDBC.ODBC.Wrappers - -import Foreign.C.String (castCUCharToChar) -import Foreign.C.Types -import Foreign.ForeignPtr -import Foreign.Ptr -import Control.Applicative -import Control.Concurrent.MVar -import Foreign.C.String -import Foreign.Marshal -import Foreign.Storable -import Control.Monad -import Data.Word -import Data.Time.Calendar (fromGregorian) -import Data.Time.LocalTime (TimeOfDay(TimeOfDay), LocalTime(LocalTime)) -import Data.Int -import Data.Maybe (catMaybes, fromMaybe) -import qualified Data.ByteString as B -import qualified Data.ByteString.UTF8 as BUTF8 -import qualified Data.ByteString.Unsafe as B -import Unsafe.Coerce (unsafeCoerce) - -import System.IO (hPutStrLn, stderr) -import Debug.Trace - -import qualified Data.Foldable as F - -#ifdef mingw32_HOST_OS -#include <windows.h> -#endif -#include <sql.h> -#include <sqlext.h> - -#ifdef mingw32_HOST_OS -#let CALLCONV = "stdcall" -#else -#let CALLCONV = "ccall" -#endif - -fGetQueryInfo :: DbcWrapper -> ChildList -> String - -> IO ([SqlColDesc], [(String, SqlColDesc)]) -fGetQueryInfo iconn children query = - do hdbcTrace "in fGetQueryInfo" - sstate <- newSState iconn query - addChild children (wrapStmt sstate) -- We get error if we forget this one. Not sure why. - fakeExecute' sstate - -fakeExecute' :: SState -> IO ([SqlColDesc], [(String, SqlColDesc)]) -fakeExecute' sstate = do - hdbcTrace "fakeExecute'" - withStmtOrDie (sstmt sstate) $ \hStmt -> - withCStringLen (squery sstate) $ \(cquery, cqlen) -> do - hdbcTrace "fakeExecute' got stmt handle" - sqlPrepare hStmt cquery (fromIntegral cqlen) >>= - checkError "fakeExecute' prepare" (StmtHandle hStmt) - - -- parmCount <- getNumParams sthptr - parmInfo <- fgetparminfo hStmt - - -- rc <- getNumResultCols sthptr - colInfo <- fgetcolinfo hStmt - return (parmInfo, colInfo) - --- | The Stament State -data SState = SState - { sstmt :: StmtWrapper - , squery :: String - , stmtPrepared :: MVar Bool - , colinfomv :: MVar [(String, SqlColDesc)] - , bindColsMV :: MVar (Maybe [(BindCol, Ptr #{type SQLLEN})]) - } - --- FIXME: we currently do no prepare optimization whatsoever. - -newSState :: DbcWrapper -> String -> IO SState -newSState indbo query = SState - <$> sqlAllocStmt indbo - <*> pure query - <*> newMVar False - <*> newMVar [] - <*> newMVar Nothing - -wrapStmt :: SState -> Statement -wrapStmt sstate = Statement - { execute = fexecute sstate - , executeRaw = return () - , executeMany = fexecutemany sstate - , finish = ffinish sstate - , fetchRow = ffetchrow sstate - , originalQuery = (squery sstate) - , getColumnNames = readMVar (colinfomv sstate) >>= (return . map fst) - , describeResult = readMVar (colinfomv sstate) - } - -newSth :: DbcWrapper -> ChildList -> String -> IO Statement -newSth indbo mchildren query = - do hdbcTrace "in newSth" - sstate <- newSState indbo query - let retval = wrapStmt sstate - addChild mchildren retval - return retval - -fgettables :: DbcWrapper -> IO [String] -fgettables iconn = do - hdbcTrace "fgettables" - sstate <- newSState iconn "" - withStmtOrDie (sstmt sstate) $ \hStmt -> do - hdbcTrace "fgettables got stmt handle" - simpleSqlTables hStmt >>= checkError "gettables simpleSqlTables" (StmtHandle hStmt) - fgetcolinfo hStmt >>= swapMVar (colinfomv sstate) - results <- fetchAllRows' $ wrapStmt sstate - return $ map (\x -> fromSql (x !! 2)) results - -fdescribetable :: DbcWrapper -> String -> IO [(String, SqlColDesc)] -fdescribetable iconn tablename = do - hdbcTrace "fdescribetable" - B.useAsCStringLen (BUTF8.fromString tablename) $ \(cs, csl) -> do - sstate <- newSState iconn tablename - withStmtOrDie (sstmt sstate) $ \hStmt -> do - hdbcTrace "fdescribetable got stmt handle" - simpleSqlColumns hStmt cs (fromIntegral csl) >>= checkError "fdescribetable simpleSqlColumns" (StmtHandle hStmt) - fgetcolinfo hStmt >>= swapMVar (colinfomv sstate) - results <- fetchAllRows' $ wrapStmt sstate - hdbcTrace $ show results - return $ map fromOTypeCol results - -{- For now, we try to just handle things as simply as possible. -FIXME lots of room for improvement here (types, etc). -} -fexecute :: SState -> [SqlValue] -> IO Integer -fexecute sstate args = do - hdbcTrace $ "fexecute: " ++ show (squery sstate) ++ show args - (finish, result) <- withStmtOrDie (sstmt sstate) $ \hStmt -> do - hdbcTrace "fexecute got stmt handle" - -- Realloc the statement - modifyMVar_ (stmtPrepared sstate) $ \prep -> do - unless prep $ - B.useAsCStringLen (BUTF8.fromString (squery sstate)) $ \(cquery, cqlen) -> do - sqlPrepare hStmt cquery (fromIntegral cqlen) >>= checkError "execute prepare" (StmtHandle hStmt) - return True -- Statement is always prepared after this block completes. - - bindArgs <- zipWithM (bindParam hStmt) args [1..] - hdbcTrace $ "Ready for sqlExecute: " ++ show (squery sstate) ++ show args - r <- sqlExecute hStmt - mapM_ (\(x, y) -> free x >> free y) (catMaybes bindArgs) - - case r of - #{const SQL_NO_DATA} -> return () -- Update that did nothing - x -> checkError "execute execute" (StmtHandle hStmt) x - - rc <- getNumResultCols hStmt - - case rc of - 0 -> do rowcount <- getSqlRowCount hStmt - return (True, fromIntegral rowcount) - colcount -> do fgetcolinfo hStmt >>= swapMVar (colinfomv sstate) - return (False, 0) - when finish $ ffinish sstate - return result - -getNumResultCols :: SQLHSTMT -> IO #{type SQLSMALLINT} -getNumResultCols sthptr = alloca $ \pcount -> - do sqlNumResultCols sthptr pcount >>= checkError "SQLNumResultCols" - (StmtHandle sthptr) - peek pcount - --- Bind a parameter column before execution. -bindParam :: SQLHSTMT -> SqlValue -> Word16 - -> IO (Maybe (Ptr #{type SQLLEN}, Ptr CChar)) -bindParam sthptr arg icol = alloca $ \pdtype -> - alloca $ \pcolsize -> - alloca $ \pdecdigits -> - alloca $ \pnullable -> -{- We have to start by getting the SQL type of the column so we can - send the correct type back to the server. Sigh. If the ODBC - backend won't tell us the type, we fake it. - - We've got an annoying situation with error handling. Must make - sure that all data is freed, but if there's an error, we have to raise - it and the caller never gets to freed the allocated data to-date. - So, make sure we either free of have foreignized everything before - control passes out of this function. -} - - do hdbcTrace $ "Binding col " ++ show icol ++ ": " ++ show arg - rc1 <- sqlDescribeParam sthptr icol pdtype pcolsize pdecdigits pnullable - hdbcTrace $ "rc1 is " ++ show (sqlSucceeded rc1) - coltype <- if sqlSucceeded rc1 then Just <$> peek pdtype else return Nothing - colsize <- if sqlSucceeded rc1 then Just <$> peek pcolsize else return Nothing - decdigits <- if sqlSucceeded rc1 then Just <$> peek pdecdigits else return Nothing - hdbcTrace $ "Results: " ++ show (coltype, colsize, decdigits) - case arg of - SqlNull -> -- NULL parameter, bind it as such. - do hdbcTrace "Binding null" - rc2 <- sqlBindParameter sthptr (fromIntegral icol) - #{const SQL_PARAM_INPUT} - #{const SQL_C_CHAR} - (fromMaybe #{const SQL_CHAR} coltype) - (fromMaybe 0 colsize) - (fromMaybe 0 decdigits) - nullPtr 0 nullDataHDBC - checkError ("bindparameter NULL " ++ show icol) - (StmtHandle sthptr) rc2 - return Nothing - x -> do -- Otherwise, we have to allocate RAM, make sure it's - -- not freed now, and pass it along... - boundValue <- bindSqlValue x - do pcslen <- malloc - poke pcslen . fromIntegral $ bvBufferSize boundValue - rc2 <- sqlBindParameter sthptr (fromIntegral icol) - #{const SQL_PARAM_INPUT} - (bvValueType boundValue) - (fromMaybe (bvDefaultColumnType boundValue) coltype) - (fromMaybe (bvDefaultColumnSize boundValue) colsize) - (fromMaybe (bvDefaultDecDigits boundValue) decdigits) - (castPtr $ bvBuffer boundValue) - (bvBufferSize boundValue) - pcslen - if sqlSucceeded rc2 - then do -- We bound it. Make foreignPtrs and return. - return $ Just (pcslen, castPtr $ bvBuffer boundValue) - else do -- Binding failed. Free the data and raise - -- error. - free pcslen - free (bvBuffer boundValue) - checkError ("bindparameter " ++ show icol) - (StmtHandle sthptr) rc2 - return Nothing -- will never get hit - -getSqlRowCount :: SQLHSTMT -> IO Int32 -getSqlRowCount cstmt = alloca $ \prows -> - do sqlRowCount cstmt prows >>= checkError "SQLRowCount" (StmtHandle cstmt) - peek prows - --note: As of ODBC-3.52, the row count is only a C int, ie 32bit. - -data BoundValue = BoundValue { - -- | Type of the value in the buffer - bvValueType :: !(#{type SQLSMALLINT}) - -- | Type of the SQL value to use if ODBC driver doesn't report one - , bvDefaultColumnType :: !(#{type SQLSMALLINT}) - , bvDefaultColumnSize :: !(#{type SQLULEN}) - , bvDefaultDecDigits :: !(#{type SQLSMALLINT}) - , bvBuffer :: !(Ptr ()) - , bvBufferSize :: !(#{type SQLLEN}) - } deriving (Show) - --- | Marshals given SqlValue returning intended ValueType, default ColumnType, --- and a CStringLen with a buffer containing bound value. Pointer in the CStringLen --- structure must be freed by caller -bindSqlValue :: SqlValue -> IO BoundValue -bindSqlValue sqlValue = case sqlValue of - SqlString s -> do --- GHC for Windows strings are implemented with wchar_t symbols, which are 16-bit UCS-2 and ODBC --- driver expects exactly that type. On Linux machines things get harder because wchar_t is 32-bit --- (UTF-32) while ODBC WCHAR might be either 16 or 32 bit. So on Linux we convert our string to --- UTF-8 and pass it to the driver telling it that we are passing SQL_C_CHAR data for a SQL_WCHAR --- column and hoping that the driver will convert back from UTF-8 to appropriate representation. -#ifdef mingw32_HOST_OS - (wstrPtr, wstrLen) <- newCWStringLen s - let result = BoundValue - { bvValueType = #{const SQL_C_WCHAR} - , bvDefaultColumnType = #{const SQL_WCHAR} - , bvDefaultColumnSize = fromIntegral wstrLen - , bvDefaultDecDigits = 0 - , bvBuffer = castPtr wstrPtr - , bvBufferSize = fromIntegral $ wstrLen * #{size wchar_t} - } - hdbcTrace $ "bind SqlString " ++ s ++ ": " ++ show result - return $! result -#else - let utf8ByteString = BUTF8.fromString s - B.unsafeUseAsCStringLen utf8ByteString $ \(unsafeStrPtr, strLen) -> do - safeStrPtr <- mallocBytes strLen - copyBytes safeStrPtr unsafeStrPtr strLen - let result = BoundValue - { bvValueType = #{const SQL_C_CHAR} - , bvDefaultColumnType = #{const SQL_WCHAR} - , bvDefaultColumnSize = fromIntegral strLen - , bvDefaultDecDigits = 0 - , bvBuffer = castPtr safeStrPtr - , bvBufferSize = fromIntegral strLen - } - hdbcTrace $ "bind SqlString " ++ s ++ ": " ++ show result - return result -#endif - SqlByteString bs -> B.unsafeUseAsCStringLen bs $ \(s,len) -> do - res <- mallocBytes len - copyBytes res s len - let result = BoundValue - { bvValueType = #{const SQL_C_BINARY} - , bvDefaultColumnType = #{const SQL_BINARY} - , bvDefaultColumnSize = fromIntegral len - , bvDefaultDecDigits = 0 - , bvBuffer = castPtr res - , bvBufferSize = fromIntegral len - } - hdbcTrace $ "bind SqlByteString " ++ show bs ++ ": " ++ show result - return $! result - -- This is rather hacky, I just replicate the behaviour of a previous version - x -> do - hdbcTrace $ "bind other " ++ show x - bsResult <- bindSqlValue $ SqlByteString (fromSql x) - let result = bsResult - { bvValueType = #{const SQL_C_CHAR} - , bvDefaultColumnType = #{const SQL_CHAR} - } - hdbcTrace $ "bound other " ++ show x ++ ": " ++ show result - return $! result - -ffetchrow :: SState -> IO (Maybe [SqlValue]) -ffetchrow sstate = do - result <- withMaybeStmt (sstmt sstate) $ \maybeStmt -> - case maybeStmt of - Nothing -> do - hdbcTrace "ffetchrow: no statement" - return Nothing - Just hStmt -> do - hdbcTrace "ffetchrow" - bindCols <- getBindCols sstate hStmt - hdbcTrace "ffetchrow: fetching" - rc <- sqlFetch hStmt - if rc == #{const SQL_NO_DATA} - then do - hdbcTrace "ffetchrow: no more rows" - return Nothing - else do - hdbcTrace "ffetchrow: fetching data" - checkError "sqlFetch" (StmtHandle hStmt) rc - sqlValues <- if rc == #{const SQL_SUCCESS} || rc == #{const SQL_SUCCESS_WITH_INFO} - then mapM (bindColToSqlValue hStmt) bindCols - else raiseError "sqlGetData" rc (StmtHandle hStmt) - return $ Just sqlValues - case result of - Just x -> return $ Just x - Nothing -> do - ffinish sstate - return Nothing - -getBindCols :: SState -> SQLHSTMT -> IO [(BindCol, Ptr #{type SQLLEN})] -getBindCols sstate cstmt = do - hdbcTrace "getBindCols" - modifyMVar (bindColsMV sstate) $ \mBindCols -> - case mBindCols of - Nothing -> do - cols <- getNumResultCols cstmt - pBindCols <- mapM (mkBindCol sstate cstmt) [1 .. cols] - return (Just pBindCols, pBindCols) - Just bindCols -> do - return (mBindCols, bindCols) - --- This is only for String data. For binary fix should be very easy. Just check the column type and use buflen instead of buflen - 1 -getLongColData cstmt bindCol = do - let (BindColString buf bufLen col) = bindCol - hdbcTrace $ "buflen: " ++ show bufLen - bs <- B.packCStringLen (buf, fromIntegral (bufLen - 1)) - hdbcTrace $ "sql_no_total col " ++ show (BUTF8.toString bs) - bs2 <- getRestLongColData cstmt #{const SQL_CHAR} col bs - return $ SqlByteString bs2 - - -getRestLongColData cstmt cBinding icol acc = do - hdbcTrace "getLongColData" - alloca $ \plen -> - allocaBytes colBufSizeMaximum $ \buf -> - do res <- sqlGetData cstmt (fromIntegral icol) cBinding - buf (fromIntegral colBufSizeMaximum) plen - if res == #{const SQL_SUCCESS} || res == #{const SQL_SUCCESS_WITH_INFO} - then do - len <- peek plen - if len == #{const SQL_NO_DATA} - then return acc - else do - let bufmax = fromIntegral $ colBufSizeMaximum - 1 - bs <- B.packCStringLen (buf, fromIntegral (if len == #{const SQL_NO_TOTAL} || len > bufmax then bufmax else len)) - hdbcTrace $ "sql_no_total col is: " ++ show (BUTF8.toString bs) - let newacc = B.append acc bs - if len /= #{const SQL_NO_TOTAL} && len <= bufmax - then return newacc - else getRestLongColData cstmt cBinding icol newacc - else raiseError "sqlGetData" res (StmtHandle cstmt) - --- TODO: This code does not deal well with data that is extremely large, --- where multiple fetches are required. -getColData cstmt cBinding icol = do - alloca $ \plen -> - allocaBytes colBufSizeDefault $ \buf -> - do res <- sqlGetData cstmt (fromIntegral icol) cBinding - buf (fromIntegral colBufSizeDefault) plen - case res of - #{const SQL_SUCCESS} -> - do len <- peek plen - case len of - #{const SQL_NULL_DATA} -> return SqlNull - #{const SQL_NO_TOTAL} -> fail $ "Unexpected SQL_NO_TOTAL" - _ -> do bs <- B.packCStringLen (buf, fromIntegral len) - hdbcTrace $ "col is: " ++ show (BUTF8.toString bs) - return (SqlByteString bs) - #{const SQL_SUCCESS_WITH_INFO} -> - do len <- peek plen - allocaBytes (fromIntegral len + 1) $ \buf2 -> - do sqlGetData cstmt (fromIntegral icol) cBinding - buf2 (fromIntegral len + 1) plen - >>= checkError "sqlGetData" (StmtHandle cstmt) - len2 <- peek plen - let firstbuf = case cBinding of - #{const SQL_C_BINARY} -> colBufSizeDefault - _ -> colBufSizeDefault - 1 -- strip off NUL - bs <- liftM2 (B.append) (B.packCStringLen (buf, firstbuf)) - (B.packCStringLen (buf2, fromIntegral len2)) - hdbcTrace $ "col is: " ++ (BUTF8.toString bs) - return (SqlByteString bs) - _ -> raiseError "sqlGetData" res (StmtHandle cstmt) - --- | ffetchrowBaseline is used for benchmarking fetches without the --- overhead of marshalling values. -ffetchrowBaseline sstate = do - hdbcTrace "ffetchrowBaseline" - result <- withStmtOrDie (sstmt sstate) $ \hStmt -> do - hdbcTrace "ffetchrowBaseline got stmt handle" - rc <- sqlFetch hStmt - if rc == #{const SQL_NO_DATA} - then return Nothing - else return (Just []) - case result of - Just x -> return $ Just x - Nothing -> do - ffinish sstate - return Nothing - -data ColBuf - --- These correspond to the C type identifiers found here: --- http://msdn.microsoft.com/en-us/library/ms714556(v=VS.85).aspx --- The Ptr values point to the appropriate C types -data BindCol - = BindColString (Ptr CChar) #{type SQLLEN} #{type SQLUSMALLINT} - | BindColWString (Ptr CWchar) #{type SQLLEN} #{type SQLUSMALLINT} - | BindColBit (Ptr CUChar) - | BindColTinyInt (Ptr CChar) - | BindColShort (Ptr CShort) - | BindColLong (Ptr CLong) - | BindColBigInt (Ptr #{type SQLBIGINT}) - | BindColFloat (Ptr CFloat) - | BindColDouble (Ptr CDouble) - | BindColBinary (Ptr CUChar) #{type SQLLEN} #{type SQLUSMALLINT} - | BindColDate (Ptr StructDate) - | BindColTime (Ptr StructTime) - | BindColTimestamp (Ptr StructTimestamp) - | BindColGetData #{type SQLUSMALLINT} - - --- Intervals and GUIDs have not been implemented, since there is no --- equivalent SqlValue for these. --- --- | BindColInterval --- typedef struct tagSQL_INTERVAL_STRUCT --- { --- SQLINTERVAL interval_type; --- SQLSMALLINT interval_sign; --- union { --- SQL_YEAR_MONTH_STRUCT year_month; --- SQL_DAY_SECOND_STRUCT day_second; --- } intval; --- } SQL_INTERVAL_STRUCT; --- typedef enum --- { --- SQL_IS_YEAR = 1, --- SQL_IS_MONTH = 2, --- SQL_IS_DAY = 3, --- SQL_IS_HOUR = 4, --- SQL_IS_MINUTE = 5, --- SQL_IS_SECOND = 6, --- SQL_IS_YEAR_TO_MONTH = 7, --- SQL_IS_DAY_TO_HOUR = 8, --- SQL_IS_DAY_TO_MINUTE = 9, --- SQL_IS_DAY_TO_SECOND = 10, --- SQL_IS_HOUR_TO_MINUTE = 11, --- SQL_IS_HOUR_TO_SECOND = 12, --- SQL_IS_MINUTE_TO_SECOND = 13 --- } SQLINTERVAL; --- --- typedef struct tagSQL_YEAR_MONTH --- { --- SQLUINTEGER year; --- SQLUINTEGER month; --- } SQL_YEAR_MONTH_STRUCT; --- --- typedef struct tagSQL_DAY_SECOND --- { --- SQLUINTEGER day; --- SQLUINTEGER hour; --- SQLUINTEGER minute; --- SQLUINTEGER second; --- SQLUINTEGER fraction; --- } SQL_DAY_SECOND_STRUCT; --- | BindColGUID (Ptr StructGUID) - - --- | StructDate is used to marshal the DATE_STRUCT --- This struct, and the ones which follow, are described here: --- http://msdn.microsoft.com/en-us/library/ms714556(v=VS.85).aspx -data StructDate = StructDate - #{type SQLSMALLINT} -- year - #{type SQLUSMALLINT} -- month - #{type SQLUSMALLINT} -- day - deriving Show - -instance Storable StructDate where - sizeOf _ = #{size DATE_STRUCT} - alignment _ = alignment (undefined :: CLong) - poke p (StructDate year month day) = do - #{poke DATE_STRUCT, year} p year - #{poke DATE_STRUCT, month} p month - #{poke DATE_STRUCT, day} p day - peek p = return StructDate - `ap` (#{peek DATE_STRUCT, year} p) - `ap` (#{peek DATE_STRUCT, month} p) - `ap` (#{peek DATE_STRUCT, day} p) - - --- | StructTime is used to marshals the TIME_STRUCT: -data StructTime = StructTime - #{type SQLUSMALLINT} -- hour - #{type SQLUSMALLINT} -- minute - #{type SQLUSMALLINT} -- second - -instance Storable StructTime where - sizeOf _ = #{size TIME_STRUCT} - alignment _ = alignment (undefined :: CLong) - poke p (StructTime hour minute second) = do - #{poke TIME_STRUCT, hour} p hour - #{poke TIME_STRUCT, minute} p minute - #{poke TIME_STRUCT, second} p second - peek p = return StructTime - `ap` (#{peek TIME_STRUCT, hour} p) - `ap` (#{peek TIME_STRUCT, minute} p) - `ap` (#{peek TIME_STRUCT, second} p) - --- | StructTimestamp is used to marshal the TIMESTAMP_STRUCT; -data StructTimestamp = StructTimestamp - #{type SQLSMALLINT} -- year - #{type SQLUSMALLINT} -- month - #{type SQLUSMALLINT} -- day - #{type SQLUSMALLINT} -- hour - #{type SQLUSMALLINT} -- minute - #{type SQLUSMALLINT} -- second - #{type SQLUINTEGER} -- fraction - -instance Storable StructTimestamp where - sizeOf _ = #{size TIMESTAMP_STRUCT} - alignment _ = alignment (undefined :: CLong) - poke p (StructTimestamp year month day hour minute second fraction) = do - #{poke TIMESTAMP_STRUCT, year} p year - #{poke TIMESTAMP_STRUCT, month} p month - #{poke TIMESTAMP_STRUCT, day} p day - #{poke TIMESTAMP_STRUCT, hour} p hour - #{poke TIMESTAMP_STRUCT, minute} p minute - #{poke TIMESTAMP_STRUCT, second} p second - #{poke TIMESTAMP_STRUCT, fraction} p fraction - peek p = return StructTimestamp - `ap` (#{peek TIMESTAMP_STRUCT, year} p) - `ap` (#{peek TIMESTAMP_STRUCT, month} p) - `ap` (#{peek TIMESTAMP_STRUCT, day} p) - `ap` (#{peek TIMESTAMP_STRUCT, hour} p) - `ap` (#{peek TIMESTAMP_STRUCT, minute} p) - `ap` (#{peek TIMESTAMP_STRUCT, second} p) - `ap` (#{peek TIMESTAMP_STRUCT, fraction} p) - --- | StructGUID --- data StructGUID = StructGUID --- #{type DWORD} -- ^ Data1 --- #{type WORD} -- ^ Data2 --- #{type WORD} -- ^ Data3 --- [#{type BYTE}] -- ^ Data4[8] --- --- instance Storable StructGUID where --- sizeOf _ = #{size SQLGUID} --- alignment _ = alignment (undefined :: CLong) --- poke p (StructGUID data1 data2 data3 data4) = do --- #{poke SQLGUID, Data1} p data1 --- #{poke SQLGUID, Data2} p data2 --- #{poke SQLGUID, Data3} p data3 --- pokeArray (p `plusPtr` #{offset SQLGUID, Data4}) data4 --- peek p = return StructGUID --- `ap` (#{peek SQLGUID, Data1} p) --- `ap` (#{peek SQLGUID, Data2} p) --- `ap` (#{peek SQLGUID, Data3} p) --- `ap` (peekArray 8 (p `plusPtr` #{offset SQLGUID, Data4})) - - --- | This function binds the data in a column to a value of type --- BindCol, using the default conversion scheme described here: --- http://msdn.microsoft.com/en-us/library/ms716298(v=VS.85).aspx --- The corresponding C types are here: --- http://msdn.microsoft.com/en-us/library/ms714556(v=VS.85).aspx --- These values are then ready for fetching. --- Documentation about SQLBindCol can be found here: --- http://msdn.microsoft.com/en-us/library/ms711010(v=vs.85).aspx --- --- Our implementation follows this code: --- http://publib.boulder.ibm.com/infocenter/iseries/v5r3/index.jsp?topic=%2Fcli%2Frzadpfndecol.htm --- We have to make use of the column type and length information. --- These are given by SQLDescribeCol, which is stored in colinfomv. --- SQLDescribeCol can tell use the data type, and the size of a column (in --- characters, so add 1 for the null terminator), or the number of decimal --- digits that can be held. --- To find out type, and how much memory to allocate, we could also use: --- SQLColAttribute( ..., SQL_DESC_TYPE , ... ) --- SQLColAttribute( ..., SQL_DESC_OCTET_LENGTH , ... ) --- --- Further examples of how to use SQLBindCol are here, though these make use --- of SQLDescribeCol: --- http://msdn.microsoft.com/en-us/library/ms710118(v=vs.85).aspx --- This implementation makes use of Column-Wise binding. Further improvements --- might be had by using Row-Wise binding. -mkBindCol :: SState -> SQLHSTMT -> #{type SQLSMALLINT} -> IO (BindCol, Ptr #{type SQLLEN}) -mkBindCol sstate cstmt col = do - hdbcTrace "mkBindCol" - colInfo <- readMVar (colinfomv sstate) - let colDesc = (snd (colInfo !! ((fromIntegral col) -1))) - case colType colDesc of - SqlCharT -> mkBindColStringEC cstmt col' (colSize colDesc) - SqlVarCharT -> mkBindColStringEC cstmt col' (colSize colDesc) - SqlLongVarCharT -> mkBindColString cstmt col' (colSize colDesc) - SqlWCharT -> mkBindColWStringEC cstmt col' (colSize colDesc) - SqlWVarCharT -> mkBindColWStringEC cstmt col' (colSize colDesc) - SqlWLongVarCharT -> mkBindColWString cstmt col' (colSize colDesc) - SqlDecimalT -> mkBindColString cstmt col' (colSize colDesc) - SqlNumericT -> mkBindColString cstmt col' (colSize colDesc) - SqlBitT -> mkBindColBit cstmt col' (colSize colDesc) - SqlTinyIntT -> mkBindColTinyInt cstmt col' (colSize colDesc) - SqlSmallIntT -> mkBindColShort cstmt col' (colSize colDesc) - SqlIntegerT -> mkBindColLong cstmt col' (colSize colDesc) - SqlBigIntT -> mkBindColBigInt cstmt col' (colSize colDesc) - SqlRealT -> mkBindColFloat cstmt col' (colSize colDesc) - SqlFloatT -> mkBindColDouble cstmt col' (colSize colDesc) - SqlDoubleT -> mkBindColDouble cstmt col' (colSize colDesc) - SqlBinaryT -> mkBindColBinary cstmt col' (colSize colDesc) - SqlVarBinaryT -> mkBindColBinary cstmt col' (colSize colDesc) - SqlLongVarBinaryT -> mkBindColBinary cstmt col' (colSize colDesc) - SqlDateT -> mkBindColDate cstmt col' (colSize colDesc) - SqlTimeT -> mkBindColTime cstmt col' (colSize colDesc) - SqlTimestampT -> mkBindColTimestamp cstmt col' (colSize colDesc) --- SqlIntervalT i -> mkBindColInterval cstmt col' (colSize colDesc) i --- SqlGUIDT -> mkBindColGUID cstmt col' (colSize colDesc) - _ -> mkBindColGetData col' --- The following are not supported by ODBC: --- SqlUTCDateTimeT --- SqlUTCTimeT --- SqlTimeWithZoneT --- SqlTimestampWithZoneT - where - col' = fromIntegral col - -colBufSizeDefault = 1024 -colBufSizeMaximum = 4096 - -utf8EncodingMaximum = 6 -wcSize = 2 - --- The functions that follow do the marshalling from C into a Haskell type -mkBindColString cstmt col mColSize = do - hdbcTrace "mkBindCol: BindColString" - let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize - let bufLen = sizeOf (undefined :: CChar) * (colSize + 1) - buf <- mallocBytes bufLen - pStrLen <- malloc - sqlBindCol cstmt col (#{const SQL_C_CHAR}) (castPtr buf) (fromIntegral bufLen) pStrLen - return (BindColString buf (fromIntegral bufLen) col, pStrLen) -mkBindColStringEC cstmt col = mkBindColString cstmt col . fmap (* utf8EncodingMaximum) -mkBindColWString cstmt col mColSize = do - hdbcTrace "mkBindCol: BindColWString" - let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize - let bufLen = sizeOf (undefined :: CWchar) * (colSize + 1) - buf <- mallocBytes bufLen - pStrLen <- malloc - sqlBindCol cstmt col (#{const SQL_C_CHAR}) (castPtr buf) (fromIntegral bufLen) pStrLen - return (BindColWString buf (fromIntegral bufLen) col, pStrLen) -mkBindColWStringEC cstmt col = mkBindColString cstmt col . fmap extendFactor where - extendFactor sz = sz * ((utf8EncodingMaximum + wcSize - 1) `quot` wcSize) -mkBindColBit cstmt col mColSize = do - hdbcTrace "mkBindCol: BindColBit" - let bufLen = sizeOf (undefined :: CChar) - buf <- malloc - pStrLen <- malloc - sqlBindCol cstmt col (#{const SQL_C_BIT}) (castPtr buf) (fromIntegral bufLen) pStrLen - return (BindColBit buf, pStrLen) -mkBindColTinyInt cstmt col mColSize = do - hdbcTrace "mkBindCol: BindColTinyInt" - let bufLen = sizeOf (undefined :: CUChar) - buf <- malloc - pStrLen <- malloc - sqlBindCol cstmt col (#{const SQL_C_STINYINT}) (castPtr buf) (fromIntegral bufLen) pStrLen - return (BindColTinyInt buf, pStrLen) -mkBindColShort cstmt col mColSize = do - hdbcTrace "mkBindCol: BindColShort" - let bufLen = sizeOf (undefined :: CShort) - buf <- malloc - pStrLen <- malloc - sqlBindCol cstmt col (#{const SQL_C_SSHORT}) (castPtr buf) (fromIntegral bufLen) pStrLen - return (BindColShort buf, pStrLen) -mkBindColLong cstmt col mColSize = do - hdbcTrace "mkBindCol: BindColSize" - let bufLen = sizeOf (undefined :: CLong) - buf <- malloc - pStrLen <- malloc - sqlBindCol cstmt col (#{const SQL_C_SLONG}) (castPtr buf) (fromIntegral bufLen) pStrLen - return (BindColLong buf, pStrLen) -mkBindColBigInt cstmt col mColSize = do - hdbcTrace "mkBindCol: BindColBigInt" - let bufLen = sizeOf (undefined :: CInt) - buf <- malloc - pStrLen <- malloc - sqlBindCol cstmt col (#{const SQL_C_SBIGINT}) (castPtr buf) (fromIntegral bufLen) pStrLen - return (BindColBigInt buf, pStrLen) -mkBindColFloat cstmt col mColSize = do - hdbcTrace "mkBindCol: BindColFloat" - let bufLen = sizeOf (undefined :: CFloat) - buf <- malloc - pStrLen <- malloc - sqlBindCol cstmt col (#{const SQL_C_FLOAT}) (castPtr buf) (fromIntegral bufLen) pStrLen - return (BindColFloat buf, pStrLen) -mkBindColDouble cstmt col mColSize = do - hdbcTrace "mkBindCol: BindColDouble" - let bufLen = sizeOf (undefined :: CDouble) - buf <- malloc - pStrLen <- malloc - sqlBindCol cstmt col (#{const SQL_C_DOUBLE}) (castPtr buf) (fromIntegral bufLen) pStrLen - return (BindColDouble buf, pStrLen) -mkBindColBinary cstmt col mColSize = do - hdbcTrace "mkBindCol: BindColBinary" - let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize - let bufLen = sizeOf (undefined :: CUChar) * (colSize + 1) - buf <- mallocBytes bufLen - pStrLen <- malloc - sqlBindCol cstmt col (#{const SQL_C_BINARY}) (castPtr buf) (fromIntegral bufLen) pStrLen - return (BindColBinary buf (fromIntegral bufLen) col, pStrLen) -mkBindColDate cstmt col mColSize = do - hdbcTrace "mkBindCol: BindColDate" - let bufLen = sizeOf (undefined :: StructDate) - buf <- malloc - pStrLen <- malloc - sqlBindCol cstmt col (#{const SQL_C_TYPE_DATE}) (castPtr buf) (fromIntegral bufLen) pStrLen - return (BindColDate buf, pStrLen) -mkBindColTime cstmt col mColSize = do - hdbcTrace "mkBindCol: BindColTime" - let bufLen = sizeOf (undefined :: StructTime) - buf <- malloc - pStrLen <- malloc - sqlBindCol cstmt col (#{const SQL_C_TYPE_TIME}) (castPtr buf) (fromIntegral bufLen) pStrLen - return (BindColTime buf, pStrLen) -mkBindColTimestamp cstmt col mColSize = do - hdbcTrace "mkBindCol: BindColTimestamp" - let bufLen = sizeOf (undefined :: StructTimestamp) - buf <- malloc - pStrLen <- malloc - sqlBindCol cstmt col (#{const SQL_C_TYPE_TIMESTAMP}) (castPtr buf) (fromIntegral bufLen) pStrLen - return (BindColTimestamp buf, pStrLen) -mkBindColGetData col = do - hdbcTrace "mkBindCol: BindColGetData" - return (BindColGetData col, nullPtr) - -freeBindCol :: BindCol -> IO () -freeBindCol (BindColString buf _ _) = free buf -freeBindCol (BindColWString buf _ _) = free buf -freeBindCol (BindColBit buf) = free buf -freeBindCol (BindColTinyInt buf) = free buf -freeBindCol (BindColShort buf) = free buf -freeBindCol (BindColLong buf) = free buf -freeBindCol (BindColBigInt buf) = free buf -freeBindCol (BindColFloat buf) = free buf -freeBindCol (BindColDouble buf) = free buf -freeBindCol (BindColBinary buf _ _) = free buf -freeBindCol (BindColDate buf) = free buf -freeBindCol (BindColTime buf) = free buf -freeBindCol (BindColTimestamp buf) = free buf -freeBindCol (BindColGetData _ ) = return () - --- | This assumes that SQL_ATTR_MAX_LENGTH is set to zero, otherwise, we --- cannot detect truncated columns. See "returning Data in Bound Columns": --- http://msdn.microsoft.com/en-us/library/ms712424(v=vs.85).aspx --- Also note that the strLen value of SQL_NTS denotes a null terminated string, --- but is only valid as input, so we don't make use of it here: --- http://msdn.microsoft.com/en-us/library/ms713532(v=VS.85).aspx -bindColToSqlValue :: SQLHSTMT -> (BindCol, Ptr #{type SQLLEN}) -> IO SqlValue -bindColToSqlValue pcstmt (BindColGetData col, _) = do - hdbcTrace "bindColToSqlValue: BindColGetData" - getColData pcstmt #{const SQL_CHAR} col -bindColToSqlValue pcstmt (bindCol, pStrLen) = do - hdbcTrace "bindColToSqlValue" - strLen <- peek pStrLen - case strLen of - #{const SQL_NULL_DATA} -> return SqlNull - #{const SQL_NO_TOTAL} -> getLongColData pcstmt bindCol - _ -> bindColToSqlValue' pcstmt bindCol strLen - --- | This is a worker function for `bindcolToSqlValue`. Note that the case --- where the data is null should already be handled by this stage. -bindColToSqlValue' :: SQLHSTMT -> BindCol -> #{type SQLLEN} -> IO SqlValue -bindColToSqlValue' pcstmt (BindColString buf bufLen col) strLen - | bufLen >= strLen = do - bs <- B.packCStringLen (buf, fromIntegral strLen) - hdbcTrace $ "bindColToSqlValue BindColString " ++ show bs ++ " " ++ show strLen - return $ SqlByteString bs - | otherwise = getColData pcstmt #{const SQL_CHAR} col -bindColToSqlValue' pcstmt (BindColWString buf bufLen col) strLen - | bufLen >= strLen = do - bs <- B.packCStringLen (castPtr buf, fromIntegral strLen) - hdbcTrace $ "bindColToSqlValue BindColWString " ++ show bs ++ " " ++ show strLen - return $ SqlByteString bs - | otherwise = getColData pcstmt #{const SQL_CHAR} col -bindColToSqlValue' _ (BindColBit buf) strLen = do - bit <- peek buf - hdbcTrace $ "bindColToSqlValue BindColBit " ++ show bit - return $ SqlChar (castCUCharToChar bit) -bindColToSqlValue' _ (BindColTinyInt buf) strLen = do - tinyInt <- peek buf - hdbcTrace $ "bindColToSqlValue BindColTinyInt " ++ show tinyInt - return $ SqlChar (castCCharToChar tinyInt) -bindColToSqlValue' _ (BindColShort buf) strLen = do - short <- peek buf - hdbcTrace $ "bindColToSqlValue BindColShort" ++ show short - return $ SqlInt32 (fromIntegral short) -bindColToSqlValue' _ (BindColLong buf) strLen = do - long <- peek buf - hdbcTrace $ "bindColToSqlValue BindColLong " ++ show long - return $ SqlInt32 (fromIntegral long) -bindColToSqlValue' _ (BindColBigInt buf) strLen = do - bigInt <- peek buf - hdbcTrace $ "bindColToSqlValue BindColBigInt " ++ show bigInt - return $ SqlInt64 (fromIntegral bigInt) -bindColToSqlValue' _ (BindColFloat buf) strLen = do - float <- peek buf - hdbcTrace $ "bindColToSqlValue BindColFloat " ++ show float - return $ SqlDouble (realToFrac float) -bindColToSqlValue' _ (BindColDouble buf) strLen = do - double <- peek buf - hdbcTrace $ "bindColToSqlValue BindColDouble " ++ show double - return $ SqlDouble (realToFrac double) -bindColToSqlValue' pcstmt (BindColBinary buf bufLen col) strLen - | bufLen >= strLen = do - bs <- B.packCStringLen (castPtr buf, fromIntegral strLen) - hdbcTrace $ "bindColToSqlValue BindColBinary " ++ show bs - return $ SqlByteString bs - | otherwise = getColData pcstmt (#{const SQL_C_BINARY}) col -bindColToSqlValue' _ (BindColDate buf) strLen = do - StructDate year month day <- peek buf - hdbcTrace $ "bindColToSqlValue BindColDate" - return $ SqlLocalDate $ fromGregorian - (fromIntegral year) (fromIntegral month) (fromIntegral day) -bindColToSqlValue' _ (BindColTime buf) strLen = do - StructTime hour minute second <- peek buf - hdbcTrace $ "bindColToSqlValue BindColTime" - return $ SqlLocalTimeOfDay $ TimeOfDay - (fromIntegral hour) (fromIntegral minute) (fromIntegral second) -bindColToSqlValue' _ (BindColTimestamp buf) strLen = do - StructTimestamp year month day hour minute second nanosecond <- peek buf - hdbcTrace $ "bindColToSqlValue BindColTimestamp" - return $ SqlLocalTime $ LocalTime - (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day)) - (TimeOfDay (fromIntegral hour) (fromIntegral minute) - (fromIntegral second + (fromIntegral nanosecond / 1000000000))) -bindColToSqlValue' _ (BindColGetData _) _ = - error "bindColToSqlValue': unexpected BindColGetData!" - -fgetcolinfo :: SQLHSTMT -> IO [(String, SqlColDesc)] -fgetcolinfo cstmt = - do ncols <- getNumResultCols cstmt - mapM getname [1..ncols] - where getname icol = alloca $ \colnamelp -> - allocaBytes 128 $ \cscolname -> - alloca $ \datatypeptr -> - alloca $ \colsizeptr -> - alloca $ \nullableptr -> - do sqlDescribeCol cstmt icol cscolname 127 colnamelp - datatypeptr colsizeptr nullPtr nullableptr - colnamelen <- peek colnamelp - colnamebs <- B.packCStringLen (cscolname, fromIntegral colnamelen) - let colname = BUTF8.toString colnamebs - datatype <- peek datatypeptr - colsize <- peek colsizeptr - nullable <- peek nullableptr - return $ fromOTypeInfo colname datatype colsize nullable - --- FIXME: needs a faster algorithm. -fexecutemany :: SState -> [[SqlValue]] -> IO () -fexecutemany sstate arglist = - mapM_ (fexecute sstate) arglist >> return () - -freeBoundCols :: SState -> IO () -freeBoundCols sstate = modifyMVar_ (bindColsMV sstate) $ \maybeBindCols -> do - F.mapM_ go maybeBindCols - return Nothing - where - go bindCols = do - hdbcTrace "freeBoundCols" - mapM_ (\(bindCol, pSqlLen) -> freeBindCol bindCol >> free pSqlLen) bindCols - -ffinish :: SState -> IO () -ffinish sstate = do - hdbcTrace "ffinish" - withMaybeStmt (sstmt sstate) $ F.mapM_ $ \hStmt -> do - c_sqlFreeStmt hStmt sQL_CLOSE >>= checkError "fexecute c_sqlFreeStmt sQL_CLOSE" (StmtHandle hStmt) - c_sqlFreeStmt hStmt sQL_UNBIND >>= checkError "fexecute c_sqlFreeStmt sQL_UNBIND" (StmtHandle hStmt) - c_sqlFreeStmt hStmt sQL_RESET_PARAMS >>= checkError "fexecute c_sqlFreeStmt sQL_RESET_PARAMS" (StmtHandle hStmt) - freeBoundCols sstate - -ffinalize :: SState -> IO () -ffinalize sstate = do - ffinish sstate - freeStmtIfNotAlready $ sstmt sstate - -foreign import #{CALLCONV} safe "sql.h SQLDescribeCol" - sqlDescribeCol :: SQLHSTMT - -> #{type SQLSMALLINT} -- ^ Column number - -> CString -- ^ Column name - -> #{type SQLSMALLINT} -- ^ Buffer length - -> Ptr (#{type SQLSMALLINT}) -- ^ name length ptr - -> Ptr (#{type SQLSMALLINT}) -- ^ data type ptr - -> Ptr (#{type SQLULEN}) -- ^ column size ptr - -> Ptr (#{type SQLSMALLINT}) -- ^ decimal digits ptr - -> Ptr (#{type SQLSMALLINT}) -- ^ nullable ptr - -> IO #{type SQLRETURN} - -foreign import #{CALLCONV} safe "sql.h SQLGetData" - sqlGetData :: SQLHSTMT -- ^ statement handle - -> #{type SQLUSMALLINT} -- ^ Column number - -> #{type SQLSMALLINT} -- ^ target type - -> CString -- ^ target value pointer (void * in C) - -> #{type SQLLEN} -- ^ buffer len - -> Ptr (#{type SQLLEN}) - -> IO #{type SQLRETURN} - -foreign import #{CALLCONV} safe "sql.h SQLBindCol" - sqlBindCol :: SQLHSTMT -- ^ statement handle - -> #{type SQLUSMALLINT} -- ^ Column number - -> #{type SQLSMALLINT} -- ^ target type - -> Ptr ColBuf -- ^ target value pointer (void * in C) - -> #{type SQLLEN} -- ^ buffer len - -> Ptr (#{type SQLLEN}) -- ^ strlen_or_indptr - -> IO #{type SQLRETURN} - -foreign import #{CALLCONV} safe "sql.h SQLPrepare" - sqlPrepare :: SQLHSTMT -> CString -> #{type SQLINTEGER} - -> IO #{type SQLRETURN} - -foreign import #{CALLCONV} safe "sql.h SQLExecute" - sqlExecute :: SQLHSTMT -> IO #{type SQLRETURN} - -foreign import #{CALLCONV} safe "sql.h SQLNumResultCols" - sqlNumResultCols :: SQLHSTMT -> Ptr #{type SQLSMALLINT} - -> IO #{type SQLRETURN} - -foreign import #{CALLCONV} safe "sql.h SQLRowCount" - sqlRowCount :: SQLHSTMT -> Ptr #{type SQLINTEGER} -> IO #{type SQLRETURN} - -foreign import #{CALLCONV} safe "sql.h SQLBindParameter" - sqlBindParameter :: SQLHSTMT -- ^ Statement handle - -> #{type SQLUSMALLINT} -- ^ Parameter Number - -> #{type SQLSMALLINT} -- ^ Input or output - -> #{type SQLSMALLINT} -- ^ Value type - -> #{type SQLSMALLINT} -- ^ Parameter type - -> #{type SQLULEN} -- ^ column size - -> #{type SQLSMALLINT} -- ^ decimal digits - -> CString -- ^ Parameter value pointer - -> #{type SQLLEN} -- ^ buffer length - -> Ptr #{type SQLLEN} -- ^ strlen_or_indptr - -> IO #{type SQLRETURN} - -foreign import ccall safe "hdbc-odbc-helper.h &nullDataHDBC" - nullDataHDBC :: Ptr #{type SQLLEN} - -foreign import #{CALLCONV} safe "sql.h SQLDescribeParam" - sqlDescribeParam :: SQLHSTMT - -> #{type SQLUSMALLINT} -- ^ parameter number - -> Ptr #{type SQLSMALLINT} -- ^ data type ptr - -> Ptr #{type SQLULEN} -- ^ parameter size ptr - -> Ptr #{type SQLSMALLINT} -- ^ dec digits ptr - -> Ptr #{type SQLSMALLINT} -- ^ nullable ptr - -> IO #{type SQLRETURN} - -foreign import #{CALLCONV} safe "sql.h SQLFetch" - sqlFetch :: SQLHSTMT -> IO #{type SQLRETURN} - -foreign import ccall safe "hdbc-odbc-helper.h simpleSqlTables" - simpleSqlTables :: SQLHSTMT -> IO #{type SQLRETURN} - -foreign import ccall safe "hdbc-odbc-helper.h simpleSqlColumns" - simpleSqlColumns :: SQLHSTMT -> Ptr CChar -> - #{type SQLSMALLINT} -> IO #{type SQLRETURN} - -fgetparminfo :: SQLHSTMT -> IO [SqlColDesc] -fgetparminfo cstmt = - do ncols <- getNumParams cstmt - mapM getname [1..ncols] - where getname icol = -- alloca $ \colnamelp -> - -- allocaBytes 128 $ \cscolname -> - alloca $ \datatypeptr -> - alloca $ \colsizeptr -> - alloca $ \nullableptr -> - do poke datatypeptr 127 -- to test if sqlDescribeParam actually writes something to the area - res <- sqlDescribeParam cstmt (fromInteger $ toInteger icol) -- cscolname 127 colnamelp - datatypeptr colsizeptr nullPtr nullableptr - putStrLn $ show res - -- We need proper error handling here. Not all ODBC drivers supports SQLDescribeParam. - -- Not supporting SQLDescribeParam is quite allright according to the ODBC standard. - datatype <- peek datatypeptr - colsize <- peek colsizeptr - nullable <- peek nullableptr - return $ snd $ fromOTypeInfo "" datatype colsize nullable - -getNumParams :: SQLHSTMT -> IO Int16 -getNumParams sthptr = alloca $ \pcount -> - do sqlNumParams sthptr pcount >>= checkError "SQLNumResultCols" - (StmtHandle sthptr) - peek pcount - -foreign import #{CALLCONV} safe "sql.h SQLNumParams" - sqlNumParams :: SQLHSTMT -> Ptr #{type SQLSMALLINT} - -> IO #{type SQLRETURN} +-- -*- mode: haskell; -*-+{-# CFILES hdbc-odbc-helper.c #-}+-- Above line for hugs+{-# LANGUAGE EmptyDataDecls #-}++module Database.HDBC.ODBC.Statement (+ fGetQueryInfo,+ newSth,+ fgettables,+ fdescribetable+ ) where++import Database.HDBC.Types+import Database.HDBC+import Database.HDBC.DriverUtils+import Database.HDBC.ODBC.Api.Errors+import Database.HDBC.ODBC.Api.Imports+import Database.HDBC.ODBC.Api.Types+import Database.HDBC.ODBC.Utils+import Database.HDBC.ODBC.Log+import Database.HDBC.ODBC.TypeConv+import Database.HDBC.ODBC.Wrappers++import Foreign.C.String (castCUCharToChar)+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Ptr+import Control.Applicative+import Control.Concurrent.MVar+import Foreign.C.String+import Foreign.Marshal+import Foreign.Storable+import Control.Monad+import Data.Word+import Data.Time.Calendar (fromGregorian)+import Data.Time.LocalTime (TimeOfDay(TimeOfDay), LocalTime(LocalTime))+import Data.Int+import Data.Maybe (catMaybes, fromMaybe)+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as BUTF8+import qualified Data.ByteString.Unsafe as B+import Unsafe.Coerce (unsafeCoerce)++import System.IO (hPutStrLn, stderr)+import Debug.Trace++import qualified Data.Foldable as F++#ifdef mingw32_HOST_OS+#include <windows.h>+#endif+#include <sql.h>+#include <sqlext.h>++#ifdef mingw32_HOST_OS+#let CALLCONV = "stdcall"+#else+#let CALLCONV = "ccall"+#endif++fGetQueryInfo :: DbcWrapper -> ChildList -> String+ -> IO ([SqlColDesc], [(String, SqlColDesc)])+fGetQueryInfo iconn children query =+ do hdbcTrace "in fGetQueryInfo"+ sstate <- newSState iconn query+ addChild children (wrapStmt sstate) -- We get error if we forget this one. Not sure why.+ fakeExecute' sstate++fakeExecute' :: SState -> IO ([SqlColDesc], [(String, SqlColDesc)])+fakeExecute' sstate = do+ hdbcTrace "fakeExecute'"+ withStmtOrDie (sstmt sstate) $ \hStmt ->+ withCStringLen (squery sstate) $ \(cquery, cqlen) -> do+ hdbcTrace "fakeExecute' got stmt handle"+ sqlPrepare hStmt cquery (fromIntegral cqlen) >>=+ checkError "fakeExecute' prepare" (StmtHandle hStmt)++ -- parmCount <- getNumParams sthptr+ parmInfo <- fgetparminfo hStmt++ -- rc <- getNumResultCols sthptr+ colInfo <- fgetcolinfo hStmt+ return (parmInfo, colInfo)++-- | The Stament State+data SState = SState+ { sstmt :: StmtWrapper+ , squery :: String+ , stmtPrepared :: MVar Bool+ , colinfomv :: MVar [(String, SqlColDesc)]+ , bindColsMV :: MVar (Maybe [(BindCol, Ptr #{type SQLLEN})])+ }++-- FIXME: we currently do no prepare optimization whatsoever.++newSState :: DbcWrapper -> String -> IO SState+newSState indbo query = SState+ <$> sqlAllocStmt indbo+ <*> pure query+ <*> newMVar False+ <*> newMVar []+ <*> newMVar Nothing++wrapStmt :: SState -> Statement+wrapStmt sstate = Statement+ { execute = fexecute sstate+ , executeRaw = fexecuteraw sstate+ , executeMany = fexecutemany sstate+ , finish = ffinish sstate+ , fetchRow = ffetchrow sstate+ , originalQuery = (squery sstate)+ , getColumnNames = readMVar (colinfomv sstate) >>= (return . map fst)+ , describeResult = readMVar (colinfomv sstate)+ }++newSth :: DbcWrapper -> ChildList -> String -> IO Statement+newSth indbo mchildren query =+ do hdbcTrace "in newSth"+ sstate <- newSState indbo query+ let retval = wrapStmt sstate+ addChild mchildren retval+ return retval++fgettables :: DbcWrapper -> IO [String]+fgettables iconn = do+ hdbcTrace "fgettables"+ sstate <- newSState iconn ""+ withStmtOrDie (sstmt sstate) $ \hStmt -> do+ hdbcTrace "fgettables got stmt handle"+ simpleSqlTables hStmt >>= checkError "gettables simpleSqlTables" (StmtHandle hStmt)+ fgetcolinfo hStmt >>= swapMVar (colinfomv sstate)+ results <- fetchAllRows' $ wrapStmt sstate+ return $ map (\x -> fromSql (x !! 2)) results++fdescribetable :: DbcWrapper -> String -> IO [(String, SqlColDesc)]+fdescribetable iconn tablename = do+ hdbcTrace "fdescribetable"+ B.useAsCStringLen (BUTF8.fromString tablename) $ \(cs, csl) -> do+ sstate <- newSState iconn tablename+ withStmtOrDie (sstmt sstate) $ \hStmt -> do+ hdbcTrace "fdescribetable got stmt handle"+ simpleSqlColumns hStmt cs (fromIntegral csl) >>= checkError "fdescribetable simpleSqlColumns" (StmtHandle hStmt)+ fgetcolinfo hStmt >>= swapMVar (colinfomv sstate)+ results <- fetchAllRows' $ wrapStmt sstate+ hdbcTrace $ show results+ return $ map fromOTypeCol results++{- For now, we try to just handle things as simply as possible.+FIXME lots of room for improvement here (types, etc). -}+fexecute :: SState -> [SqlValue] -> IO Integer+fexecute sstate args = do+ hdbcTrace $ "fexecute: " ++ show (squery sstate) ++ show args+ (finish, result) <- withStmtOrDie (sstmt sstate) $ \hStmt -> do+ hdbcTrace "fexecute got stmt handle"+ -- Realloc the statement+ modifyMVar_ (stmtPrepared sstate) $ \prep -> do+ unless prep $+ B.useAsCStringLen (BUTF8.fromString (squery sstate)) $ \(cquery, cqlen) -> do+ sqlPrepare hStmt cquery (fromIntegral cqlen) >>= checkError "execute prepare" (StmtHandle hStmt)+ return True -- Statement is always prepared after this block completes.++ bindArgs <- zipWithM (bindParam hStmt) args [1..]+ hdbcTrace $ "Ready for sqlExecute: " ++ show (squery sstate) ++ show args+ r <- sqlExecute hStmt+ mapM_ (\(x, y) -> free x >> free y) (catMaybes bindArgs)++ case r of+ #{const SQL_NO_DATA} -> return () -- Update that did nothing+ x -> checkError "execute execute" (StmtHandle hStmt) x++ rc <- getNumResultCols hStmt++ case rc of+ 0 -> do rowcount <- getSqlRowCount hStmt+ return (True, fromIntegral rowcount)+ colcount -> do fgetcolinfo hStmt >>= swapMVar (colinfomv sstate)+ return (False, 0)+ when finish $ ffinish sstate+ return result++fexecuteraw :: SState -> IO ()+fexecuteraw sstate = do+ hdbcTrace $ "fexecuteraw: " ++ show (squery sstate)+ withStmtOrDie (sstmt sstate) $ \hStmt -> do+ hdbcTrace "fexecuteraw got stmt handle"+ -- Realloc the statement+ modifyMVar_ (stmtPrepared sstate) $ \prep -> do+ unless prep $+ B.useAsCStringLen (BUTF8.fromString (squery sstate)) $ \(cquery, cqlen) -> do+ sqlPrepare hStmt cquery (fromIntegral cqlen) >>= checkError "executeraw prepare" (StmtHandle hStmt)+ return True -- Statement is always prepared after this block completes.++ bindArgs <- zipWithM (bindParam hStmt) [] [1..]+ hdbcTrace $ "Ready for sqlExecute: " ++ show (squery sstate)+ r <- sqlExecute hStmt+ mapM_ (\(x, y) -> free x >> free y) (catMaybes bindArgs)++ case r of+ #{const SQL_NO_DATA} -> return () -- Update that did nothing+ x -> checkError "executeraw execute" (StmtHandle hStmt) x++ let getAllResults = do+ r <- sqlMoreResults hStmt+ case r of+ #{const SQL_SUCCESS} -> getAllResults+ #{const SQL_NO_DATA} -> return ()+ x -> checkError "executeraw getAllResults" (StmtHandle hStmt) x+ getAllResults+ ffinish sstate++getNumResultCols :: SQLHSTMT -> IO #{type SQLSMALLINT}+getNumResultCols sthptr = alloca $ \pcount ->+ do sqlNumResultCols sthptr pcount >>= checkError "SQLNumResultCols"+ (StmtHandle sthptr)+ peek pcount++-- Bind a parameter column before execution.+bindParam :: SQLHSTMT -> SqlValue -> Word16+ -> IO (Maybe (Ptr #{type SQLLEN}, Ptr CChar))+bindParam sthptr arg icol = alloca $ \pdtype ->+ alloca $ \pcolsize ->+ alloca $ \pdecdigits ->+ alloca $ \pnullable ->+{- We have to start by getting the SQL type of the column so we can+ send the correct type back to the server. Sigh. If the ODBC+ backend won't tell us the type, we fake it.++ We've got an annoying situation with error handling. Must make+ sure that all data is freed, but if there's an error, we have to raise+ it and the caller never gets to freed the allocated data to-date.+ So, make sure we either free of have foreignized everything before+ control passes out of this function. -}++ do hdbcTrace $ "Binding col " ++ show icol ++ ": " ++ show arg+ rc1 <- sqlDescribeParam sthptr icol pdtype pcolsize pdecdigits pnullable+ hdbcTrace $ "rc1 is " ++ show (sqlSucceeded rc1)+ coltype <- if sqlSucceeded rc1 then Just <$> peek pdtype else return Nothing+ colsize <- if sqlSucceeded rc1 then Just <$> peek pcolsize else return Nothing+ decdigits <- if sqlSucceeded rc1 then Just <$> peek pdecdigits else return Nothing+ hdbcTrace $ "Results: " ++ show (coltype, colsize, decdigits)+ case arg of+ SqlNull -> -- NULL parameter, bind it as such.+ do hdbcTrace "Binding null"+ rc2 <- sqlBindParameter sthptr (fromIntegral icol)+ #{const SQL_PARAM_INPUT}+ #{const SQL_C_CHAR}+ (fromMaybe #{const SQL_CHAR} coltype)+ (fromMaybe 0 colsize)+ (fromMaybe 0 decdigits)+ nullPtr 0 nullDataHDBC+ checkError ("bindparameter NULL " ++ show icol)+ (StmtHandle sthptr) rc2+ return Nothing+ x -> do -- Otherwise, we have to allocate RAM, make sure it's+ -- not freed now, and pass it along...+ boundValue <- bindSqlValue x+ do pcslen <- malloc+ poke pcslen . fromIntegral $ bvBufferSize boundValue+ rc2 <- sqlBindParameter sthptr (fromIntegral icol)+ #{const SQL_PARAM_INPUT}+ (bvValueType boundValue)+ (fromMaybe (bvDefaultColumnType boundValue) coltype)+ (fromMaybe (bvDefaultColumnSize boundValue) colsize)+ (fromMaybe (bvDefaultDecDigits boundValue) decdigits)+ (castPtr $ bvBuffer boundValue)+ (bvBufferSize boundValue)+ pcslen+ if sqlSucceeded rc2+ then do -- We bound it. Make foreignPtrs and return.+ return $ Just (pcslen, castPtr $ bvBuffer boundValue)+ else do -- Binding failed. Free the data and raise+ -- error.+ free pcslen+ free (bvBuffer boundValue)+ checkError ("bindparameter " ++ show icol)+ (StmtHandle sthptr) rc2+ return Nothing -- will never get hit++getSqlRowCount :: SQLHSTMT -> IO Int32+getSqlRowCount cstmt = alloca $ \prows ->+ do sqlRowCount cstmt prows >>= checkError "SQLRowCount" (StmtHandle cstmt)+ peek prows+ --note: As of ODBC-3.52, the row count is only a C int, ie 32bit.++data BoundValue = BoundValue {+ -- | Type of the value in the buffer+ bvValueType :: !(#{type SQLSMALLINT})+ -- | Type of the SQL value to use if ODBC driver doesn't report one+ , bvDefaultColumnType :: !(#{type SQLSMALLINT})+ , bvDefaultColumnSize :: !(#{type SQLULEN})+ , bvDefaultDecDigits :: !(#{type SQLSMALLINT})+ , bvBuffer :: !(Ptr ())+ , bvBufferSize :: !(#{type SQLLEN})+ } deriving (Show)++-- | Marshals given SqlValue returning intended ValueType, default ColumnType,+-- and a CStringLen with a buffer containing bound value. Pointer in the CStringLen+-- structure must be freed by caller+bindSqlValue :: SqlValue -> IO BoundValue+bindSqlValue sqlValue = case sqlValue of+ SqlString s -> do+-- GHC for Windows strings are implemented with wchar_t symbols, which are 16-bit UCS-2 and ODBC+-- driver expects exactly that type. On Linux machines things get harder because wchar_t is 32-bit+-- (UTF-32) while ODBC WCHAR might be either 16 or 32 bit. So on Linux we convert our string to+-- UTF-8 and pass it to the driver telling it that we are passing SQL_C_CHAR data for a SQL_WCHAR+-- column and hoping that the driver will convert back from UTF-8 to appropriate representation.+#ifdef mingw32_HOST_OS+ (wstrPtr, wstrLen) <- newCWStringLen s+ let result = BoundValue+ { bvValueType = #{const SQL_C_WCHAR}+ , bvDefaultColumnType = #{const SQL_WCHAR}+ , bvDefaultColumnSize = fromIntegral wstrLen+ , bvDefaultDecDigits = 0+ , bvBuffer = castPtr wstrPtr+ , bvBufferSize = fromIntegral $ wstrLen * #{size wchar_t}+ }+ hdbcTrace $ "bind SqlString " ++ s ++ ": " ++ show result+ return $! result+#else+ let utf8ByteString = BUTF8.fromString s+ B.unsafeUseAsCStringLen utf8ByteString $ \(unsafeStrPtr, strLen) -> do+ safeStrPtr <- mallocBytes strLen+ copyBytes safeStrPtr unsafeStrPtr strLen+ let result = BoundValue+ { bvValueType = #{const SQL_C_CHAR}+ , bvDefaultColumnType = #{const SQL_WCHAR}+ , bvDefaultColumnSize = fromIntegral strLen+ , bvDefaultDecDigits = 0+ , bvBuffer = castPtr safeStrPtr+ , bvBufferSize = fromIntegral strLen+ }+ hdbcTrace $ "bind SqlString " ++ s ++ ": " ++ show result+ return result+#endif+ SqlByteString bs -> B.unsafeUseAsCStringLen bs $ \(s,len) -> do+ res <- mallocBytes len+ copyBytes res s len+ let result = BoundValue+ { bvValueType = #{const SQL_C_BINARY}+ , bvDefaultColumnType = #{const SQL_BINARY}+ , bvDefaultColumnSize = fromIntegral len+ , bvDefaultDecDigits = 0+ , bvBuffer = castPtr res+ , bvBufferSize = fromIntegral len+ }+ hdbcTrace $ "bind SqlByteString " ++ show bs ++ ": " ++ show result+ return $! result+ -- This is rather hacky, I just replicate the behaviour of a previous version+ x -> do+ hdbcTrace $ "bind other " ++ show x+ bsResult <- bindSqlValue $ SqlByteString (fromSql x)+ let result = bsResult+ { bvValueType = #{const SQL_C_CHAR}+ , bvDefaultColumnType = #{const SQL_CHAR}+ }+ hdbcTrace $ "bound other " ++ show x ++ ": " ++ show result+ return $! result++ffetchrow :: SState -> IO (Maybe [SqlValue])+ffetchrow sstate = do+ result <- withMaybeStmt (sstmt sstate) $ \maybeStmt ->+ case maybeStmt of+ Nothing -> do+ hdbcTrace "ffetchrow: no statement"+ return Nothing+ Just hStmt -> do+ hdbcTrace "ffetchrow"+ bindCols <- getBindCols sstate hStmt+ hdbcTrace "ffetchrow: fetching"+ rc <- sqlFetch hStmt+ if rc == #{const SQL_NO_DATA}+ then do+ hdbcTrace "ffetchrow: no more rows"+ return Nothing+ else do+ hdbcTrace "ffetchrow: fetching data"+ checkError "sqlFetch" (StmtHandle hStmt) rc+ sqlValues <- if rc == #{const SQL_SUCCESS} || rc == #{const SQL_SUCCESS_WITH_INFO}+ then mapM (bindColToSqlValue hStmt) bindCols+ else raiseError "sqlGetData" rc (StmtHandle hStmt)+ return $ Just sqlValues+ case result of+ Just x -> return $ Just x+ Nothing -> do+ ffinish sstate+ return Nothing++getBindCols :: SState -> SQLHSTMT -> IO [(BindCol, Ptr #{type SQLLEN})]+getBindCols sstate cstmt = do+ hdbcTrace "getBindCols"+ modifyMVar (bindColsMV sstate) $ \mBindCols ->+ case mBindCols of+ Nothing -> do+ cols <- getNumResultCols cstmt+ pBindCols <- mapM (mkBindCol sstate cstmt) [1 .. cols]+ return (Just pBindCols, pBindCols)+ Just bindCols -> do+ return (mBindCols, bindCols)++-- This is only for String data. For binary fix should be very easy. Just check the column type and use buflen instead of buflen - 1+getLongColData cstmt bindCol = do+ let (BindColString buf bufLen col) = bindCol+ hdbcTrace $ "buflen: " ++ show bufLen+ bs <- B.packCStringLen (buf, fromIntegral (bufLen - 1))+ hdbcTrace $ "sql_no_total col " ++ show (BUTF8.toString bs)+ bs2 <- getRestLongColData cstmt #{const SQL_CHAR} col bs+ return $ SqlByteString bs2+++getRestLongColData cstmt cBinding icol acc = do+ hdbcTrace "getLongColData"+ alloca $ \plen ->+ allocaBytes colBufSizeMaximum $ \buf ->+ do res <- sqlGetData cstmt (fromIntegral icol) cBinding+ buf (fromIntegral colBufSizeMaximum) plen+ if res == #{const SQL_SUCCESS} || res == #{const SQL_SUCCESS_WITH_INFO}+ then do+ len <- peek plen+ if len == #{const SQL_NO_DATA}+ then return acc+ else do+ let bufmax = fromIntegral $ colBufSizeMaximum - 1+ bs <- B.packCStringLen (buf, fromIntegral (if len == #{const SQL_NO_TOTAL} || len > bufmax then bufmax else len))+ hdbcTrace $ "sql_no_total col is: " ++ show (BUTF8.toString bs)+ let newacc = B.append acc bs+ if len /= #{const SQL_NO_TOTAL} && len <= bufmax+ then return newacc+ else getRestLongColData cstmt cBinding icol newacc+ else raiseError "sqlGetData" res (StmtHandle cstmt)++-- TODO: This code does not deal well with data that is extremely large,+-- where multiple fetches are required.+getColData cstmt cBinding icol = do+ alloca $ \plen ->+ allocaBytes colBufSizeDefault $ \buf ->+ do res <- sqlGetData cstmt (fromIntegral icol) cBinding+ buf (fromIntegral colBufSizeDefault) plen+ case res of+ #{const SQL_SUCCESS} ->+ do len <- peek plen+ case len of+ #{const SQL_NULL_DATA} -> return SqlNull+ #{const SQL_NO_TOTAL} -> fail $ "Unexpected SQL_NO_TOTAL"+ _ -> do bs <- B.packCStringLen (buf, fromIntegral len)+ hdbcTrace $ "col is: " ++ show (BUTF8.toString bs)+ return (SqlByteString bs)+ #{const SQL_SUCCESS_WITH_INFO} ->+ do len <- peek plen+ allocaBytes (fromIntegral len + 1) $ \buf2 ->+ do sqlGetData cstmt (fromIntegral icol) cBinding+ buf2 (fromIntegral len + 1) plen+ >>= checkError "sqlGetData" (StmtHandle cstmt)+ len2 <- peek plen+ let firstbuf = case cBinding of+ #{const SQL_C_BINARY} -> colBufSizeDefault+ _ -> colBufSizeDefault - 1 -- strip off NUL+ bs <- liftM2 (B.append) (B.packCStringLen (buf, firstbuf))+ (B.packCStringLen (buf2, fromIntegral len2))+ hdbcTrace $ "col is: " ++ (BUTF8.toString bs)+ return (SqlByteString bs)+ _ -> raiseError "sqlGetData" res (StmtHandle cstmt)++-- | ffetchrowBaseline is used for benchmarking fetches without the+-- overhead of marshalling values.+ffetchrowBaseline sstate = do+ hdbcTrace "ffetchrowBaseline"+ result <- withStmtOrDie (sstmt sstate) $ \hStmt -> do+ hdbcTrace "ffetchrowBaseline got stmt handle"+ rc <- sqlFetch hStmt+ if rc == #{const SQL_NO_DATA}+ then return Nothing+ else return (Just [])+ case result of+ Just x -> return $ Just x+ Nothing -> do+ ffinish sstate+ return Nothing++data ColBuf++-- These correspond to the C type identifiers found here:+-- http://msdn.microsoft.com/en-us/library/ms714556(v=VS.85).aspx+-- The Ptr values point to the appropriate C types+data BindCol+ = BindColString (Ptr CChar) #{type SQLLEN} #{type SQLUSMALLINT}+ | BindColWString (Ptr CWchar) #{type SQLLEN} #{type SQLUSMALLINT}+ | BindColBit (Ptr CUChar)+ | BindColTinyInt (Ptr CChar)+ | BindColShort (Ptr CShort)+ | BindColLong (Ptr CLong)+ | BindColBigInt (Ptr #{type SQLBIGINT})+ | BindColFloat (Ptr CFloat)+ | BindColDouble (Ptr CDouble)+ | BindColBinary (Ptr CUChar) #{type SQLLEN} #{type SQLUSMALLINT}+ | BindColDate (Ptr StructDate)+ | BindColTime (Ptr StructTime)+ | BindColTimestamp (Ptr StructTimestamp)+ | BindColGetData #{type SQLUSMALLINT}++mallocBuffer :: forall a. Storable a => Int -> IO (Int, Ptr a, Ptr #{type SQLLEN})+mallocBuffer n = do+ let bufLen = sizeOf (undefined :: a) * n+ hdbcTrace $ "mallocBuffer " ++ show n ++ " -> " ++ show bufLen+ buf <- mallocBytes bufLen+ pBufLen <- malloc+ return (bufLen, buf, pBufLen)++-- Intervals and GUIDs have not been implemented, since there is no+-- equivalent SqlValue for these.+--+-- | BindColInterval+-- typedef struct tagSQL_INTERVAL_STRUCT+-- {+-- SQLINTERVAL interval_type;+-- SQLSMALLINT interval_sign;+-- union {+-- SQL_YEAR_MONTH_STRUCT year_month;+-- SQL_DAY_SECOND_STRUCT day_second;+-- } intval;+-- } SQL_INTERVAL_STRUCT;+-- typedef enum+-- {+-- SQL_IS_YEAR = 1,+-- SQL_IS_MONTH = 2,+-- SQL_IS_DAY = 3,+-- SQL_IS_HOUR = 4,+-- SQL_IS_MINUTE = 5,+-- SQL_IS_SECOND = 6,+-- SQL_IS_YEAR_TO_MONTH = 7,+-- SQL_IS_DAY_TO_HOUR = 8,+-- SQL_IS_DAY_TO_MINUTE = 9,+-- SQL_IS_DAY_TO_SECOND = 10,+-- SQL_IS_HOUR_TO_MINUTE = 11,+-- SQL_IS_HOUR_TO_SECOND = 12,+-- SQL_IS_MINUTE_TO_SECOND = 13+-- } SQLINTERVAL;+--+-- typedef struct tagSQL_YEAR_MONTH+-- {+-- SQLUINTEGER year;+-- SQLUINTEGER month;+-- } SQL_YEAR_MONTH_STRUCT;+--+-- typedef struct tagSQL_DAY_SECOND+-- {+-- SQLUINTEGER day;+-- SQLUINTEGER hour;+-- SQLUINTEGER minute;+-- SQLUINTEGER second;+-- SQLUINTEGER fraction;+-- } SQL_DAY_SECOND_STRUCT;+-- | BindColGUID (Ptr StructGUID)+++-- | StructDate is used to marshal the DATE_STRUCT+-- This struct, and the ones which follow, are described here:+-- http://msdn.microsoft.com/en-us/library/ms714556(v=VS.85).aspx+data StructDate = StructDate+ #{type SQLSMALLINT} -- year+ #{type SQLUSMALLINT} -- month+ #{type SQLUSMALLINT} -- day+ deriving Show++instance Storable StructDate where+ sizeOf _ = #{size DATE_STRUCT}+ alignment _ = alignment (undefined :: CLong)+ poke p (StructDate year month day) = do+ #{poke DATE_STRUCT, year} p year+ #{poke DATE_STRUCT, month} p month+ #{poke DATE_STRUCT, day} p day+ peek p = return StructDate+ `ap` (#{peek DATE_STRUCT, year} p)+ `ap` (#{peek DATE_STRUCT, month} p)+ `ap` (#{peek DATE_STRUCT, day} p)+++-- | StructTime is used to marshals the TIME_STRUCT:+data StructTime = StructTime+ #{type SQLUSMALLINT} -- hour+ #{type SQLUSMALLINT} -- minute+ #{type SQLUSMALLINT} -- second++instance Storable StructTime where+ sizeOf _ = #{size TIME_STRUCT}+ alignment _ = alignment (undefined :: CLong)+ poke p (StructTime hour minute second) = do+ #{poke TIME_STRUCT, hour} p hour+ #{poke TIME_STRUCT, minute} p minute+ #{poke TIME_STRUCT, second} p second+ peek p = return StructTime+ `ap` (#{peek TIME_STRUCT, hour} p)+ `ap` (#{peek TIME_STRUCT, minute} p)+ `ap` (#{peek TIME_STRUCT, second} p)++-- | StructTimestamp is used to marshal the TIMESTAMP_STRUCT;+data StructTimestamp = StructTimestamp+ #{type SQLSMALLINT} -- year+ #{type SQLUSMALLINT} -- month+ #{type SQLUSMALLINT} -- day+ #{type SQLUSMALLINT} -- hour+ #{type SQLUSMALLINT} -- minute+ #{type SQLUSMALLINT} -- second+ #{type SQLUINTEGER} -- fraction++instance Storable StructTimestamp where+ sizeOf _ = #{size TIMESTAMP_STRUCT}+ alignment _ = alignment (undefined :: CLong)+ poke p (StructTimestamp year month day hour minute second fraction) = do+ #{poke TIMESTAMP_STRUCT, year} p year+ #{poke TIMESTAMP_STRUCT, month} p month+ #{poke TIMESTAMP_STRUCT, day} p day+ #{poke TIMESTAMP_STRUCT, hour} p hour+ #{poke TIMESTAMP_STRUCT, minute} p minute+ #{poke TIMESTAMP_STRUCT, second} p second+ #{poke TIMESTAMP_STRUCT, fraction} p fraction+ peek p = return StructTimestamp+ `ap` (#{peek TIMESTAMP_STRUCT, year} p)+ `ap` (#{peek TIMESTAMP_STRUCT, month} p)+ `ap` (#{peek TIMESTAMP_STRUCT, day} p)+ `ap` (#{peek TIMESTAMP_STRUCT, hour} p)+ `ap` (#{peek TIMESTAMP_STRUCT, minute} p)+ `ap` (#{peek TIMESTAMP_STRUCT, second} p)+ `ap` (#{peek TIMESTAMP_STRUCT, fraction} p)++-- | StructGUID+-- data StructGUID = StructGUID+-- #{type DWORD} -- ^ Data1+-- #{type WORD} -- ^ Data2+-- #{type WORD} -- ^ Data3+-- [#{type BYTE}] -- ^ Data4[8]+--+-- instance Storable StructGUID where+-- sizeOf _ = #{size SQLGUID}+-- alignment _ = alignment (undefined :: CLong)+-- poke p (StructGUID data1 data2 data3 data4) = do+-- #{poke SQLGUID, Data1} p data1+-- #{poke SQLGUID, Data2} p data2+-- #{poke SQLGUID, Data3} p data3+-- pokeArray (p `plusPtr` #{offset SQLGUID, Data4}) data4+-- peek p = return StructGUID+-- `ap` (#{peek SQLGUID, Data1} p)+-- `ap` (#{peek SQLGUID, Data2} p)+-- `ap` (#{peek SQLGUID, Data3} p)+-- `ap` (peekArray 8 (p `plusPtr` #{offset SQLGUID, Data4}))+++-- | This function binds the data in a column to a value of type+-- BindCol, using the default conversion scheme described here:+-- http://msdn.microsoft.com/en-us/library/ms716298(v=VS.85).aspx+-- The corresponding C types are here:+-- http://msdn.microsoft.com/en-us/library/ms714556(v=VS.85).aspx+-- These values are then ready for fetching.+-- Documentation about SQLBindCol can be found here:+-- http://msdn.microsoft.com/en-us/library/ms711010(v=vs.85).aspx+--+-- Our implementation follows this code:+-- http://publib.boulder.ibm.com/infocenter/iseries/v5r3/index.jsp?topic=%2Fcli%2Frzadpfndecol.htm+-- We have to make use of the column type and length information.+-- These are given by SQLDescribeCol, which is stored in colinfomv.+-- SQLDescribeCol can tell use the data type, and the size of a column (in+-- characters, so add 1 for the null terminator), or the number of decimal+-- digits that can be held.+-- To find out type, and how much memory to allocate, we could also use:+-- SQLColAttribute( ..., SQL_DESC_TYPE , ... )+-- SQLColAttribute( ..., SQL_DESC_OCTET_LENGTH , ... )+--+-- Further examples of how to use SQLBindCol are here, though these make use+-- of SQLDescribeCol:+-- http://msdn.microsoft.com/en-us/library/ms710118(v=vs.85).aspx+-- This implementation makes use of Column-Wise binding. Further improvements+-- might be had by using Row-Wise binding.+mkBindCol :: SState -> SQLHSTMT -> #{type SQLSMALLINT} -> IO (BindCol, Ptr #{type SQLLEN})+mkBindCol sstate cstmt col = do+ hdbcTrace "mkBindCol"+ colInfo <- readMVar (colinfomv sstate)+ let colDesc = (snd (colInfo !! ((fromIntegral col) -1)))+ case colType colDesc of+ SqlCharT -> mkBindColStringEC cstmt col' (colSize colDesc)+ SqlVarCharT -> mkBindColStringEC cstmt col' (colSize colDesc)+ SqlLongVarCharT -> mkBindColString cstmt col' (colSize colDesc)+ SqlWCharT -> mkBindColWStringEC cstmt col' (colSize colDesc)+ SqlWVarCharT -> mkBindColWStringEC cstmt col' (colSize colDesc)+ SqlWLongVarCharT -> mkBindColWString cstmt col' (colSize colDesc)+ SqlDecimalT -> mkBindColString cstmt col' (colSize colDesc)+ SqlNumericT -> mkBindColString cstmt col' (colSize colDesc)+ SqlBitT -> mkBindColBit cstmt col' (colSize colDesc)+ SqlTinyIntT -> mkBindColTinyInt cstmt col' (colSize colDesc)+ SqlSmallIntT -> mkBindColShort cstmt col' (colSize colDesc)+ SqlIntegerT -> mkBindColLong cstmt col' (colSize colDesc)+ SqlBigIntT -> mkBindColBigInt cstmt col' (colSize colDesc)+ SqlRealT -> mkBindColFloat cstmt col' (colSize colDesc)+ SqlFloatT -> mkBindColDouble cstmt col' (colSize colDesc)+ SqlDoubleT -> mkBindColDouble cstmt col' (colSize colDesc)+ SqlBinaryT -> mkBindColBinary cstmt col' (colSize colDesc)+ SqlVarBinaryT -> mkBindColBinary cstmt col' (colSize colDesc)+ SqlLongVarBinaryT -> mkBindColBinary cstmt col' (colSize colDesc)+ SqlDateT -> mkBindColDate cstmt col' (colSize colDesc)+ SqlTimeT -> mkBindColTime cstmt col' (colSize colDesc)+ SqlTimestampT -> mkBindColTimestamp cstmt col' (colSize colDesc)+-- SqlIntervalT i -> mkBindColInterval cstmt col' (colSize colDesc) i+-- SqlGUIDT -> mkBindColGUID cstmt col' (colSize colDesc)+ _ -> mkBindColGetData col'+-- The following are not supported by ODBC:+-- SqlUTCDateTimeT+-- SqlUTCTimeT+-- SqlTimeWithZoneT+-- SqlTimestampWithZoneT+ where+ col' = fromIntegral col++colBufSizeDefault = 1024+colBufSizeMaximum = 4096++utf8EncodingMaximum = 6+wcSize = 2++-- The functions that follow do the marshalling from C into a Haskell type+mkBindColString cstmt col mColSize = do+ hdbcTrace "mkBindCol: BindColString"+ let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize+ (bufLen, buf, pStrLen) <- mallocBuffer (colSize + 1)+ sqlBindCol cstmt col (#{const SQL_C_CHAR}) (castPtr buf) (fromIntegral bufLen) pStrLen+ return (BindColString buf (fromIntegral bufLen) col, pStrLen)+mkBindColStringEC cstmt col = mkBindColString cstmt col . fmap (* utf8EncodingMaximum)+mkBindColWString cstmt col mColSize = do+ hdbcTrace "mkBindCol: BindColWString"+ let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize+ (bufLen, buf, pStrLen) <- mallocBuffer (colSize + 1)+ sqlBindCol cstmt col (#{const SQL_C_WCHAR}) (castPtr buf) (fromIntegral bufLen) pStrLen+ return (BindColWString buf (fromIntegral bufLen) col, pStrLen)+mkBindColWStringEC cstmt col = mkBindColString cstmt col . fmap extendFactor where+ extendFactor sz = sz * ((utf8EncodingMaximum + wcSize - 1) `quot` wcSize)+mkBindColBit cstmt col mColSize = do+ hdbcTrace "mkBindCol: BindColBit"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ sqlBindCol cstmt col (#{const SQL_C_BIT}) (castPtr buf) (fromIntegral bufLen) pStrLen+ return (BindColBit buf, pStrLen)+mkBindColTinyInt cstmt col mColSize = do+ hdbcTrace "mkBindCol: BindColTinyInt"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ sqlBindCol cstmt col (#{const SQL_C_STINYINT}) (castPtr buf) (fromIntegral bufLen) pStrLen+ return (BindColTinyInt buf, pStrLen)+mkBindColShort cstmt col mColSize = do+ hdbcTrace "mkBindCol: BindColShort"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ sqlBindCol cstmt col (#{const SQL_C_SSHORT}) (castPtr buf) (fromIntegral bufLen) pStrLen+ return (BindColShort buf, pStrLen)+mkBindColLong cstmt col mColSize = do+ hdbcTrace "mkBindCol: BindColSize"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ sqlBindCol cstmt col (#{const SQL_C_SLONG}) (castPtr buf) (fromIntegral bufLen) pStrLen+ return (BindColLong buf, pStrLen)+mkBindColBigInt cstmt col mColSize = do+ hdbcTrace "mkBindCol: BindColBigInt"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ sqlBindCol cstmt col (#{const SQL_C_SBIGINT}) (castPtr buf) (fromIntegral bufLen) pStrLen+ return (BindColBigInt buf, pStrLen)+mkBindColFloat cstmt col mColSize = do+ hdbcTrace "mkBindCol: BindColFloat"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ sqlBindCol cstmt col (#{const SQL_C_FLOAT}) (castPtr buf) (fromIntegral bufLen) pStrLen+ return (BindColFloat buf, pStrLen)+mkBindColDouble cstmt col mColSize = do+ hdbcTrace "mkBindCol: BindColDouble"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ sqlBindCol cstmt col (#{const SQL_C_DOUBLE}) (castPtr buf) (fromIntegral bufLen) pStrLen+ return (BindColDouble buf, pStrLen)+mkBindColBinary cstmt col mColSize = do+ hdbcTrace "mkBindCol: BindColBinary"+ let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize+ (bufLen, buf, pStrLen) <- mallocBuffer (colSize + 1)+ sqlBindCol cstmt col (#{const SQL_C_BINARY}) (castPtr buf) (fromIntegral bufLen) pStrLen+ return (BindColBinary buf (fromIntegral bufLen) col, pStrLen)+mkBindColDate cstmt col mColSize = do+ hdbcTrace "mkBindCol: BindColDate"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ sqlBindCol cstmt col (#{const SQL_C_TYPE_DATE}) (castPtr buf) (fromIntegral bufLen) pStrLen+ return (BindColDate buf, pStrLen)+mkBindColTime cstmt col mColSize = do+ hdbcTrace "mkBindCol: BindColTime"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ sqlBindCol cstmt col (#{const SQL_C_TYPE_TIME}) (castPtr buf) (fromIntegral bufLen) pStrLen+ return (BindColTime buf, pStrLen)+mkBindColTimestamp cstmt col mColSize = do+ hdbcTrace "mkBindCol: BindColTimestamp"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ sqlBindCol cstmt col (#{const SQL_C_TYPE_TIMESTAMP}) (castPtr buf) (fromIntegral bufLen) pStrLen+ return (BindColTimestamp buf, pStrLen)+mkBindColGetData col = do+ hdbcTrace "mkBindCol: BindColGetData"+ return (BindColGetData col, nullPtr)++freeBindCol :: BindCol -> IO ()+freeBindCol (BindColString buf _ _) = free buf+freeBindCol (BindColWString buf _ _) = free buf+freeBindCol (BindColBit buf) = free buf+freeBindCol (BindColTinyInt buf) = free buf+freeBindCol (BindColShort buf) = free buf+freeBindCol (BindColLong buf) = free buf+freeBindCol (BindColBigInt buf) = free buf+freeBindCol (BindColFloat buf) = free buf+freeBindCol (BindColDouble buf) = free buf+freeBindCol (BindColBinary buf _ _) = free buf+freeBindCol (BindColDate buf) = free buf+freeBindCol (BindColTime buf) = free buf+freeBindCol (BindColTimestamp buf) = free buf+freeBindCol (BindColGetData _ ) = return ()++-- | This assumes that SQL_ATTR_MAX_LENGTH is set to zero, otherwise, we+-- cannot detect truncated columns. See "returning Data in Bound Columns":+-- http://msdn.microsoft.com/en-us/library/ms712424(v=vs.85).aspx+-- Also note that the strLen value of SQL_NTS denotes a null terminated string,+-- but is only valid as input, so we don't make use of it here:+-- http://msdn.microsoft.com/en-us/library/ms713532(v=VS.85).aspx+bindColToSqlValue :: SQLHSTMT -> (BindCol, Ptr #{type SQLLEN}) -> IO SqlValue+bindColToSqlValue pcstmt (BindColGetData col, _) = do+ hdbcTrace "bindColToSqlValue: BindColGetData"+ getColData pcstmt #{const SQL_CHAR} col+bindColToSqlValue pcstmt (bindCol, pStrLen) = do+ hdbcTrace "bindColToSqlValue"+ strLen <- peek pStrLen+ case strLen of+ #{const SQL_NULL_DATA} -> return SqlNull+ #{const SQL_NO_TOTAL} -> getLongColData pcstmt bindCol+ _ -> bindColToSqlValue' pcstmt bindCol strLen++-- | This is a worker function for `bindcolToSqlValue`. Note that the case+-- where the data is null should already be handled by this stage.+bindColToSqlValue' :: SQLHSTMT -> BindCol -> #{type SQLLEN} -> IO SqlValue+bindColToSqlValue' pcstmt (BindColString buf bufLen col) strLen+ | bufLen >= strLen = do+ bs <- B.packCStringLen (buf, fromIntegral strLen)+ hdbcTrace $ "bindColToSqlValue BindColString " ++ show bs ++ " " ++ show strLen+ return $ SqlByteString bs+ | otherwise = getColData pcstmt #{const SQL_CHAR} col+bindColToSqlValue' pcstmt (BindColWString buf bufLen col) strLen+ | bufLen >= strLen = do+ bs <- B.packCStringLen (castPtr buf, fromIntegral strLen)+ hdbcTrace $ "bindColToSqlValue BindColWString " ++ show bs ++ " " ++ show strLen+ return $ SqlByteString bs+ | otherwise = getColData pcstmt #{const SQL_CHAR} col+bindColToSqlValue' _ (BindColBit buf) strLen = do+ bit <- peek buf+ hdbcTrace $ "bindColToSqlValue BindColBit " ++ show bit+ return $ SqlChar (castCUCharToChar bit)+bindColToSqlValue' _ (BindColTinyInt buf) strLen = do+ tinyInt <- peek buf+ hdbcTrace $ "bindColToSqlValue BindColTinyInt " ++ show tinyInt+ return $ SqlChar (castCCharToChar tinyInt)+bindColToSqlValue' _ (BindColShort buf) strLen = do+ short <- peek buf+ hdbcTrace $ "bindColToSqlValue BindColShort" ++ show short+ return $ SqlInt32 (fromIntegral short)+bindColToSqlValue' _ (BindColLong buf) strLen = do+ long <- peek buf+ hdbcTrace $ "bindColToSqlValue BindColLong " ++ show long+ return $ SqlInt32 (fromIntegral long)+bindColToSqlValue' _ (BindColBigInt buf) strLen = do+ bigInt <- peek buf+ hdbcTrace $ "bindColToSqlValue BindColBigInt " ++ show bigInt+ return $ SqlInt64 (fromIntegral bigInt)+bindColToSqlValue' _ (BindColFloat buf) strLen = do+ float <- peek buf+ hdbcTrace $ "bindColToSqlValue BindColFloat " ++ show float+ return $ SqlDouble (realToFrac float)+bindColToSqlValue' _ (BindColDouble buf) strLen = do+ double <- peek buf+ hdbcTrace $ "bindColToSqlValue BindColDouble " ++ show double+ return $ SqlDouble (realToFrac double)+bindColToSqlValue' pcstmt (BindColBinary buf bufLen col) strLen+ | bufLen >= strLen = do+ bs <- B.packCStringLen (castPtr buf, fromIntegral strLen)+ hdbcTrace $ "bindColToSqlValue BindColBinary " ++ show bs+ return $ SqlByteString bs+ | otherwise = getColData pcstmt (#{const SQL_C_BINARY}) col+bindColToSqlValue' _ (BindColDate buf) strLen = do+ StructDate year month day <- peek buf+ hdbcTrace $ "bindColToSqlValue BindColDate"+ return $ SqlLocalDate $ fromGregorian+ (fromIntegral year) (fromIntegral month) (fromIntegral day)+bindColToSqlValue' _ (BindColTime buf) strLen = do+ StructTime hour minute second <- peek buf+ hdbcTrace $ "bindColToSqlValue BindColTime"+ return $ SqlLocalTimeOfDay $ TimeOfDay+ (fromIntegral hour) (fromIntegral minute) (fromIntegral second)+bindColToSqlValue' _ (BindColTimestamp buf) strLen = do+ StructTimestamp year month day hour minute second nanosecond <- peek buf+ hdbcTrace $ "bindColToSqlValue BindColTimestamp"+ return $ SqlLocalTime $ LocalTime+ (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day))+ (TimeOfDay (fromIntegral hour) (fromIntegral minute)+ (fromIntegral second + (fromIntegral nanosecond / 1000000000)))+bindColToSqlValue' _ (BindColGetData _) _ =+ error "bindColToSqlValue': unexpected BindColGetData!"++fgetcolinfo :: SQLHSTMT -> IO [(String, SqlColDesc)]+fgetcolinfo cstmt =+ do ncols <- getNumResultCols cstmt+ mapM getname [1..ncols]+ where getname icol = alloca $ \colnamelp ->+ allocaBytes 128 $ \cscolname ->+ alloca $ \datatypeptr ->+ alloca $ \colsizeptr ->+ alloca $ \nullableptr ->+ do sqlDescribeCol cstmt icol cscolname 127 colnamelp+ datatypeptr colsizeptr nullPtr nullableptr+ colnamelen <- peek colnamelp+ colnamebs <- B.packCStringLen (cscolname, fromIntegral colnamelen)+ let colname = BUTF8.toString colnamebs+ datatype <- peek datatypeptr+ colsize <- peek colsizeptr+ nullable <- peek nullableptr+ return $ fromOTypeInfo colname datatype colsize nullable++-- FIXME: needs a faster algorithm.+fexecutemany :: SState -> [[SqlValue]] -> IO ()+fexecutemany sstate arglist =+ mapM_ (fexecute sstate) arglist >> return ()++freeBoundCols :: SState -> IO ()+freeBoundCols sstate = modifyMVar_ (bindColsMV sstate) $ \maybeBindCols -> do+ F.mapM_ go maybeBindCols+ return Nothing+ where+ go bindCols = do+ hdbcTrace "freeBoundCols"+ mapM_ (\(bindCol, pSqlLen) -> freeBindCol bindCol >> free pSqlLen) bindCols++ffinish :: SState -> IO ()+ffinish sstate = do+ hdbcTrace "ffinish"+ withMaybeStmt (sstmt sstate) $ F.mapM_ $ \hStmt -> do+ c_sqlFreeStmt hStmt sQL_CLOSE >>= checkError "fexecute c_sqlFreeStmt sQL_CLOSE" (StmtHandle hStmt)+ c_sqlFreeStmt hStmt sQL_UNBIND >>= checkError "fexecute c_sqlFreeStmt sQL_UNBIND" (StmtHandle hStmt)+ c_sqlFreeStmt hStmt sQL_RESET_PARAMS >>= checkError "fexecute c_sqlFreeStmt sQL_RESET_PARAMS" (StmtHandle hStmt)+ freeBoundCols sstate++ffinalize :: SState -> IO ()+ffinalize sstate = do+ ffinish sstate+ freeStmtIfNotAlready $ sstmt sstate++foreign import #{CALLCONV} safe "sql.h SQLDescribeCol"+ sqlDescribeCol :: SQLHSTMT+ -> #{type SQLSMALLINT} -- ^ Column number+ -> CString -- ^ Column name+ -> #{type SQLSMALLINT} -- ^ Buffer length+ -> Ptr (#{type SQLSMALLINT}) -- ^ name length ptr+ -> Ptr (#{type SQLSMALLINT}) -- ^ data type ptr+ -> Ptr (#{type SQLULEN}) -- ^ column size ptr+ -> Ptr (#{type SQLSMALLINT}) -- ^ decimal digits ptr+ -> Ptr (#{type SQLSMALLINT}) -- ^ nullable ptr+ -> IO #{type SQLRETURN}++foreign import #{CALLCONV} safe "sql.h SQLGetData"+ sqlGetData :: SQLHSTMT -- ^ statement handle+ -> #{type SQLUSMALLINT} -- ^ Column number+ -> #{type SQLSMALLINT} -- ^ target type+ -> CString -- ^ target value pointer (void * in C)+ -> #{type SQLLEN} -- ^ buffer len+ -> Ptr (#{type SQLLEN})+ -> IO #{type SQLRETURN}++foreign import #{CALLCONV} safe "sql.h SQLBindCol"+ sqlBindCol :: SQLHSTMT -- ^ statement handle+ -> #{type SQLUSMALLINT} -- ^ Column number+ -> #{type SQLSMALLINT} -- ^ target type+ -> Ptr ColBuf -- ^ target value pointer (void * in C)+ -> #{type SQLLEN} -- ^ buffer len+ -> Ptr (#{type SQLLEN}) -- ^ strlen_or_indptr+ -> IO #{type SQLRETURN}++foreign import #{CALLCONV} safe "sql.h SQLPrepare"+ sqlPrepare :: SQLHSTMT -> CString -> #{type SQLINTEGER}+ -> IO #{type SQLRETURN}++foreign import #{CALLCONV} safe "sql.h SQLExecute"+ sqlExecute :: SQLHSTMT -> IO #{type SQLRETURN}++foreign import #{CALLCONV} safe "sql.h SQLMoreResults"+ sqlMoreResults :: SQLHSTMT -> IO #{type SQLRETURN}++foreign import #{CALLCONV} safe "sql.h SQLNumResultCols"+ sqlNumResultCols :: SQLHSTMT -> Ptr #{type SQLSMALLINT}+ -> IO #{type SQLRETURN}++foreign import #{CALLCONV} safe "sql.h SQLRowCount"+ sqlRowCount :: SQLHSTMT -> Ptr #{type SQLINTEGER} -> IO #{type SQLRETURN}++foreign import #{CALLCONV} safe "sql.h SQLBindParameter"+ sqlBindParameter :: SQLHSTMT -- ^ Statement handle+ -> #{type SQLUSMALLINT} -- ^ Parameter Number+ -> #{type SQLSMALLINT} -- ^ Input or output+ -> #{type SQLSMALLINT} -- ^ Value type+ -> #{type SQLSMALLINT} -- ^ Parameter type+ -> #{type SQLULEN} -- ^ column size+ -> #{type SQLSMALLINT} -- ^ decimal digits+ -> CString -- ^ Parameter value pointer+ -> #{type SQLLEN} -- ^ buffer length+ -> Ptr #{type SQLLEN} -- ^ strlen_or_indptr+ -> IO #{type SQLRETURN}++foreign import ccall safe "hdbc-odbc-helper.h &nullDataHDBC"+ nullDataHDBC :: Ptr #{type SQLLEN}++foreign import #{CALLCONV} safe "sql.h SQLDescribeParam"+ sqlDescribeParam :: SQLHSTMT+ -> #{type SQLUSMALLINT} -- ^ parameter number+ -> Ptr #{type SQLSMALLINT} -- ^ data type ptr+ -> Ptr #{type SQLULEN} -- ^ parameter size ptr+ -> Ptr #{type SQLSMALLINT} -- ^ dec digits ptr+ -> Ptr #{type SQLSMALLINT} -- ^ nullable ptr+ -> IO #{type SQLRETURN}++foreign import #{CALLCONV} safe "sql.h SQLFetch"+ sqlFetch :: SQLHSTMT -> IO #{type SQLRETURN}++foreign import ccall safe "hdbc-odbc-helper.h simpleSqlTables"+ simpleSqlTables :: SQLHSTMT -> IO #{type SQLRETURN}++foreign import ccall safe "hdbc-odbc-helper.h simpleSqlColumns"+ simpleSqlColumns :: SQLHSTMT -> Ptr CChar ->+ #{type SQLSMALLINT} -> IO #{type SQLRETURN}++fgetparminfo :: SQLHSTMT -> IO [SqlColDesc]+fgetparminfo cstmt =+ do ncols <- getNumParams cstmt+ mapM getname [1..ncols]+ where getname icol = -- alloca $ \colnamelp ->+ -- allocaBytes 128 $ \cscolname ->+ alloca $ \datatypeptr ->+ alloca $ \colsizeptr ->+ alloca $ \nullableptr ->+ do poke datatypeptr 127 -- to test if sqlDescribeParam actually writes something to the area+ res <- sqlDescribeParam cstmt (fromInteger $ toInteger icol) -- cscolname 127 colnamelp+ datatypeptr colsizeptr nullPtr nullableptr+ putStrLn $ show res+ -- We need proper error handling here. Not all ODBC drivers supports SQLDescribeParam.+ -- Not supporting SQLDescribeParam is quite allright according to the ODBC standard.+ datatype <- peek datatypeptr+ colsize <- peek colsizeptr+ nullable <- peek nullableptr+ return $ snd $ fromOTypeInfo "" datatype colsize nullable++getNumParams :: SQLHSTMT -> IO Int16+getNumParams sthptr = alloca $ \pcount ->+ do sqlNumParams sthptr pcount >>= checkError "SQLNumResultCols"+ (StmtHandle sthptr)+ peek pcount++foreign import #{CALLCONV} safe "sql.h SQLNumParams"+ sqlNumParams :: SQLHSTMT -> Ptr #{type SQLSMALLINT}+ -> IO #{type SQLRETURN}
Database/HDBC/ODBC/TypeConv.hsc view
@@ -1,102 +1,102 @@--- -*- mode: haskell; -*- -{-# CFILES hdbc-odbc-helper.c #-} --- Above line for hugs -module Database.HDBC.ODBC.TypeConv(fromOTypeInfo, fromOTypeCol) where -import Database.HDBC.Types -import Database.HDBC -import Database.HDBC.DriverUtils -import Database.HDBC.ODBC.Api.Types -import Database.HDBC.ODBC.Utils -import Foreign.C.Types -import Foreign.ForeignPtr -import Foreign.Ptr -import Control.Concurrent.MVar -import Foreign.C.String -import Foreign.Marshal -import Foreign.Storable -import Control.Monad -import Data.List -import Data.Word -import Data.Int -import Control.Exception -import System.IO -import Data.Maybe - -l _ = return () --- l m = hPutStrLn stderr ("\n" ++ m) - -#ifdef mingw32_HOST_OS -#include <windows.h> -#endif -#include <sql.h> -#include <sqlext.h> -#include <sqlucode.h> - -fromOTypeInfo :: String -- ^ Column name - -> #{type SQLSMALLINT} -- ^ Data type - -> #{type SQLULEN} -- ^ Column size - -> #{type SQLSMALLINT} -- ^ Is it nullable - -> (String, SqlColDesc) -fromOTypeInfo colname datatype colsize nullable = - (colname, - SqlColDesc {colType = convdatatype datatype, - colOctetLength = Nothing, - colDecDigits = Nothing, - colSize = Just (fromIntegral colsize), - colNullable = case nullable of - #{const SQL_NO_NULLS} -> Just False - #{const SQL_NULLABLE} -> Just True - _ -> Nothing - } - ) - -fromOTypeCol (_:_:_:colname:datatype:_:colsize:buflen:decdig:precrad:nullable:_:_:_:subtype:octetlen:_) = - fromOTypeInfo (fromSql colname) - (fromIntegral ((fromSql datatype)::Int)) - (fromSql colsize) - (fromIntegral ((fromSql nullable)::Int)) -fromOTypeCol x = error $ "fromOTypeCol: unexpected result set: " ++ show x - -convdatatype :: #{type SQLSMALLINT} -> SqlTypeId -convdatatype intype = - case intype of - #{const SQL_CHAR} -> SqlCharT - #{const SQL_VARCHAR} -> SqlVarCharT - #{const SQL_LONGVARCHAR} -> SqlLongVarCharT - #{const SQL_WCHAR} -> SqlWCharT - #{const SQL_WVARCHAR} -> SqlWVarCharT - #{const SQL_WLONGVARCHAR} -> SqlWLongVarCharT - #{const SQL_DECIMAL} -> SqlDecimalT - #{const SQL_NUMERIC} -> SqlNumericT - #{const SQL_SMALLINT} -> SqlSmallIntT - #{const SQL_INTEGER} -> SqlIntegerT - #{const SQL_REAL} -> SqlRealT - #{const SQL_FLOAT} -> SqlFloatT - #{const SQL_DOUBLE} -> SqlDoubleT - #{const SQL_BIT} -> SqlBitT - #{const SQL_TINYINT} -> SqlTinyIntT - #{const SQL_BIGINT} -> SqlBigIntT - #{const SQL_BINARY} -> SqlBinaryT - #{const SQL_VARBINARY} -> SqlVarBinaryT - #{const SQL_LONGVARBINARY} -> SqlLongVarBinaryT - #{const SQL_TYPE_DATE} -> SqlDateT - #{const SQL_TYPE_TIME} -> SqlTimeT - #{const SQL_TYPE_TIMESTAMP} -> SqlTimestampT - -- ODBC libraries don't seem to define the UTC items - -- {const SQL_TYPE_UTCDATETIME} -> SqlUTCDateTimeT - -- {const SQL_TYPE_UTCTIME} -> SqlUTCTimeT - #{const SQL_INTERVAL_MONTH} -> SqlIntervalT SqlIntervalMonthT - #{const SQL_INTERVAL_YEAR} -> SqlIntervalT SqlIntervalYearT - #{const SQL_INTERVAL_YEAR_TO_MONTH} -> SqlIntervalT SqlIntervalYearToMonthT - #{const SQL_INTERVAL_DAY} -> SqlIntervalT SqlIntervalDayT - #{const SQL_INTERVAL_HOUR} -> SqlIntervalT SqlIntervalHourT - #{const SQL_INTERVAL_MINUTE} -> SqlIntervalT SqlIntervalMinuteT - #{const SQL_INTERVAL_SECOND} -> SqlIntervalT SqlIntervalSecondT - #{const SQL_INTERVAL_DAY_TO_HOUR} -> SqlIntervalT SqlIntervalDayToHourT - #{const SQL_INTERVAL_DAY_TO_MINUTE} -> SqlIntervalT SqlIntervalDayToMinuteT - #{const SQL_INTERVAL_DAY_TO_SECOND} -> SqlIntervalT SqlIntervalDayToSecondT - #{const SQL_INTERVAL_HOUR_TO_MINUTE} -> SqlIntervalT SqlIntervalHourToMinuteT - #{const SQL_INTERVAL_HOUR_TO_SECOND} -> SqlIntervalT SqlIntervalHourToSecondT - #{const SQL_INTERVAL_MINUTE_TO_SECOND} -> SqlIntervalT SqlIntervalMinuteToSecondT - #{const SQL_GUID} -> SqlGUIDT - x -> SqlUnknownT (show x) +-- -*- mode: haskell; -*-+{-# CFILES hdbc-odbc-helper.c #-}+-- Above line for hugs+module Database.HDBC.ODBC.TypeConv(fromOTypeInfo, fromOTypeCol) where+import Database.HDBC.Types+import Database.HDBC+import Database.HDBC.DriverUtils+import Database.HDBC.ODBC.Api.Types+import Database.HDBC.ODBC.Utils+import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Ptr+import Control.Concurrent.MVar+import Foreign.C.String+import Foreign.Marshal+import Foreign.Storable+import Control.Monad+import Data.List+import Data.Word+import Data.Int+import Control.Exception+import System.IO+import Data.Maybe++l _ = return ()+-- l m = hPutStrLn stderr ("\n" ++ m)++#ifdef mingw32_HOST_OS+#include <windows.h>+#endif+#include <sql.h>+#include <sqlext.h>+#include <sqlucode.h>++fromOTypeInfo :: String -- ^ Column name+ -> #{type SQLSMALLINT} -- ^ Data type+ -> #{type SQLULEN} -- ^ Column size+ -> #{type SQLSMALLINT} -- ^ Is it nullable+ -> (String, SqlColDesc)+fromOTypeInfo colname datatype colsize nullable =+ (colname,+ SqlColDesc {colType = convdatatype datatype,+ colOctetLength = Nothing,+ colDecDigits = Nothing,+ colSize = Just (fromIntegral colsize),+ colNullable = case nullable of+ #{const SQL_NO_NULLS} -> Just False+ #{const SQL_NULLABLE} -> Just True+ _ -> Nothing+ }+ )++fromOTypeCol (_:_:_:colname:datatype:_:colsize:buflen:decdig:precrad:nullable:_:_:_:subtype:octetlen:_) =+ fromOTypeInfo (fromSql colname)+ (fromIntegral ((fromSql datatype)::Int))+ (fromSql colsize)+ (fromIntegral ((fromSql nullable)::Int))+fromOTypeCol x = error $ "fromOTypeCol: unexpected result set: " ++ show x++convdatatype :: #{type SQLSMALLINT} -> SqlTypeId+convdatatype intype =+ case intype of+ #{const SQL_CHAR} -> SqlCharT+ #{const SQL_VARCHAR} -> SqlVarCharT+ #{const SQL_LONGVARCHAR} -> SqlLongVarCharT+ #{const SQL_WCHAR} -> SqlWCharT+ #{const SQL_WVARCHAR} -> SqlWVarCharT+ #{const SQL_WLONGVARCHAR} -> SqlWLongVarCharT+ #{const SQL_DECIMAL} -> SqlDecimalT+ #{const SQL_NUMERIC} -> SqlNumericT+ #{const SQL_SMALLINT} -> SqlSmallIntT+ #{const SQL_INTEGER} -> SqlIntegerT+ #{const SQL_REAL} -> SqlRealT+ #{const SQL_FLOAT} -> SqlFloatT+ #{const SQL_DOUBLE} -> SqlDoubleT+ #{const SQL_BIT} -> SqlBitT+ #{const SQL_TINYINT} -> SqlTinyIntT+ #{const SQL_BIGINT} -> SqlBigIntT+ #{const SQL_BINARY} -> SqlBinaryT+ #{const SQL_VARBINARY} -> SqlVarBinaryT+ #{const SQL_LONGVARBINARY} -> SqlLongVarBinaryT+ #{const SQL_TYPE_DATE} -> SqlDateT+ #{const SQL_TYPE_TIME} -> SqlTimeT+ #{const SQL_TYPE_TIMESTAMP} -> SqlTimestampT+ -- ODBC libraries don't seem to define the UTC items+ -- {const SQL_TYPE_UTCDATETIME} -> SqlUTCDateTimeT+ -- {const SQL_TYPE_UTCTIME} -> SqlUTCTimeT+ #{const SQL_INTERVAL_MONTH} -> SqlIntervalT SqlIntervalMonthT+ #{const SQL_INTERVAL_YEAR} -> SqlIntervalT SqlIntervalYearT+ #{const SQL_INTERVAL_YEAR_TO_MONTH} -> SqlIntervalT SqlIntervalYearToMonthT+ #{const SQL_INTERVAL_DAY} -> SqlIntervalT SqlIntervalDayT+ #{const SQL_INTERVAL_HOUR} -> SqlIntervalT SqlIntervalHourT+ #{const SQL_INTERVAL_MINUTE} -> SqlIntervalT SqlIntervalMinuteT+ #{const SQL_INTERVAL_SECOND} -> SqlIntervalT SqlIntervalSecondT+ #{const SQL_INTERVAL_DAY_TO_HOUR} -> SqlIntervalT SqlIntervalDayToHourT+ #{const SQL_INTERVAL_DAY_TO_MINUTE} -> SqlIntervalT SqlIntervalDayToMinuteT+ #{const SQL_INTERVAL_DAY_TO_SECOND} -> SqlIntervalT SqlIntervalDayToSecondT+ #{const SQL_INTERVAL_HOUR_TO_MINUTE} -> SqlIntervalT SqlIntervalHourToMinuteT+ #{const SQL_INTERVAL_HOUR_TO_SECOND} -> SqlIntervalT SqlIntervalHourToSecondT+ #{const SQL_INTERVAL_MINUTE_TO_SECOND} -> SqlIntervalT SqlIntervalMinuteToSecondT+ #{const SQL_GUID} -> SqlGUIDT+ x -> SqlUnknownT (show x)
Database/HDBC/ODBC/Utils.hs view
@@ -1,18 +1,18 @@-{- -*- mode: haskell; -*- --} -module Database.HDBC.ODBC.Utils where -import Foreign.Ptr -import Database.HDBC.ODBC.Api.Types -import Foreign.C.Types -import Control.Exception -import Foreign.Marshal.Array - -withAnyArr0 :: (a -> IO (Ptr b)) -- ^ Function that transforms input data into pointer - -> (Ptr b -> IO ()) -- ^ Function that frees generated data - -> [a] -- ^ List of input data - -> (Ptr (Ptr b) -> IO c) -- ^ Action to run with the C array - -> IO c -- ^ Return value -withAnyArr0 input2ptract freeact inp action = - bracket (mapM input2ptract inp) - (\clist -> mapM_ freeact clist) - (\clist -> withArray0 nullPtr clist action) +{- -*- mode: haskell; -*-+-}+module Database.HDBC.ODBC.Utils where+import Foreign.Ptr+import Database.HDBC.ODBC.Api.Types+import Foreign.C.Types+import Control.Exception+import Foreign.Marshal.Array++withAnyArr0 :: (a -> IO (Ptr b)) -- ^ Function that transforms input data into pointer+ -> (Ptr b -> IO ()) -- ^ Function that frees generated data+ -> [a] -- ^ List of input data+ -> (Ptr (Ptr b) -> IO c) -- ^ Action to run with the C array+ -> IO c -- ^ Return value+withAnyArr0 input2ptract freeact inp action =+ bracket (mapM input2ptract inp)+ (\clist -> mapM_ freeact clist)+ (\clist -> withArray0 nullPtr clist action)
Database/HDBC/ODBC/Wrappers.hs view
@@ -1,179 +1,188 @@-{-| Defines haskell wrappers over native ODBC objects to free - you from some memory (and threading) management. --} -{-# LANGUAGE OverloadedStrings #-} -module Database.HDBC.ODBC.Wrappers - ( EnvWrapper (..) - , sqlAllocEnv - , withMaybeEnv - , withEnvOrDie - , freeEnvIfNotAlready - , DbcWrapper (..) - , sqlAllocDbc - , withMaybeDbc - , withDbcOrDie - , tryDisconnectAndFree - , freeDbcIfNotAlready - , StmtWrapper (..) - , sqlAllocStmt - , withMaybeStmt - , withStmtOrDie - , freeStmtIfNotAlready - ) where - -import Control.Monad (unless, void, when) -import Control.Concurrent.MVar -import Control.Concurrent.ReadWriteVar (RWVar) -import Database.HDBC (SqlError (..), throwSqlError) -import Database.HDBC.ODBC.Api.Errors -import Database.HDBC.ODBC.Api.Imports -import Database.HDBC.ODBC.Api.Types -import Database.HDBC.ODBC.Log -import Foreign.Marshal hiding (void) -import Foreign.Ptr -import Foreign.Storable -import System.Mem.Weak (addFinalizer) - -import qualified Control.Concurrent.ReadWriteVar as RWV -import qualified Data.Foldable as F - -data EnvWrapper = EnvWrapper - { envHandle :: MVar (Maybe SQLHENV) -- ^ If there is Nothing here, environment is already freed - } - -sqlAllocEnv :: IO EnvWrapper -sqlAllocEnv = do - hEnv <- alloca $ \(penvptr :: Ptr SQLHENV) -> do - retVal <- c_sqlAllocHandle sQL_HANDLE_ENV nullPtr (castPtr penvptr) - unless (sqlSucceeded retVal) $ throwSqlError SqlError - { seState = "" - , seNativeError = -1 - , seErrorMsg = "sqlAllocEnv/SqlAllocHandle: Failed to allocate ODBC Environment handle" - } - peek penvptr - - handleVar <- newMVar (Just hEnv) - let wrapper = EnvWrapper handleVar - - addFinalizer wrapper $ freeEnvIfNotAlready wrapper - return wrapper - -freeEnvIfNotAlready :: EnvWrapper -> IO () -freeEnvIfNotAlready w = modifyMVar_ (envHandle w) $ \maybeEnv -> do - F.forM_ maybeEnv $ \hEnv -> do - hdbcTrace $ "Freeing environment with handle " ++ show hEnv - void $ c_sqlFreeHandle sQL_HANDLE_ENV (castPtr hEnv) - return Nothing - -withMaybeEnv :: EnvWrapper -> (Maybe SQLHENV -> IO a) -> IO a -withMaybeEnv = withMVar . envHandle - -withEnvOrDie :: EnvWrapper -> (SQLHENV -> IO a) -> IO a -withEnvOrDie ew act = withMaybeEnv ew $ \maybeHandle -> - case maybeHandle of - Just h -> act h - Nothing -> do - hdbcTrace "Requested an ENV handle from disposed wrapper. Throwing." - throwSqlError SqlError - { seState = "" - , seNativeError = -1 - , seErrorMsg = "Tried to use a disposed ODBC Environment handle" - } - -data DbcWrapper = DbcWrapper - { connHandle :: RWVar (Maybe SQLHDBC) -- ^ If there is Nothing here, connection is already freed - , connEnv :: EnvWrapper - } - --- This one implicitly allocates and initializes an environment. -sqlAllocDbc :: EnvWrapper -> IO DbcWrapper -sqlAllocDbc env = do - hDbc <- withEnvOrDie env $ \hEnv -> alloca $ \(pdbcptr :: Ptr SQLHDBC) -> do - retVal <- c_sqlAllocHandle sQL_HANDLE_DBC (castPtr hEnv) (castPtr pdbcptr) - checkError "sqlAllocConn/SQLAllocHandle" (EnvHandle hEnv) retVal - peek pdbcptr - - handleVar <- RWV.new $ Just hDbc - let wrapper = DbcWrapper handleVar env - - addFinalizer wrapper $ freeDbcIfNotAlready False wrapper - return wrapper - - --- | Tries to perform disconnect and free resources used by connection. If SQLDisconnect call --- fails, an exception gets thrown and connection resources aren't freed. -tryDisconnectAndFree :: DbcWrapper -> IO () -tryDisconnectAndFree = freeDbcIfNotAlready True - -freeDbcIfNotAlready :: Bool -> DbcWrapper -> IO () -freeDbcIfNotAlready checkDisconnect dbc = do - RWV.modify_ (connHandle dbc) $ \maybeHandle -> do - F.forM_ maybeHandle $ \hDbc -> do - hdbcTrace $ "Freeing connection with handle " ++ show hDbc - disconnectResult <- c_sqlDisconnect hDbc - when checkDisconnect $ checkError "freeDbcIfNotAlready/SQLDisconnect" (DbcHandle hDbc) disconnectResult - void $ c_sqlFreeHandle sQL_HANDLE_DBC (castPtr hDbc) - return Nothing - freeEnvIfNotAlready $ connEnv dbc - -withMaybeDbc :: DbcWrapper -> (Maybe SQLHDBC -> IO a) -> IO a -withMaybeDbc = RWV.with . connHandle - -withDbcOrDie :: DbcWrapper -> (SQLHDBC -> IO a) -> IO a -withDbcOrDie dw act = withMaybeDbc dw $ \maybeHandle -> - case maybeHandle of - Just h -> act h - Nothing -> do - hdbcTrace "Requested a DBC handle from a disposed wrapper. Throwing" - throwSqlError SqlError - { seState = "" - , seNativeError = -1 - , seErrorMsg = "Tried to use a disposed ODBC Connection handle" - } - -data StmtWrapper = StmtWrapper - { stmtHandle :: MVar (Maybe SQLHSTMT) -- ^ If there is Nothing here, statement is already finished - , stmtConn :: DbcWrapper - } - -sqlAllocStmt :: DbcWrapper -> IO StmtWrapper -sqlAllocStmt dbc = do - hStmt <- withDbcOrDie dbc $ \hDbc -> alloca $ \(psthptr :: Ptr SQLHSTMT) -> do - retVal <- c_sqlAllocHandle sQL_HANDLE_STMT (castPtr hDbc) (castPtr psthptr) - checkError "sqlAllocStmt/SQLAllocHandle" (DbcHandle hDbc) retVal - peek psthptr - - handleVar <- newMVar $ Just hStmt - let wrapper = StmtWrapper handleVar dbc - - addFinalizer wrapper $ freeStmtIfNotAlready wrapper - return wrapper - -freeStmtIfNotAlready :: StmtWrapper -> IO () -freeStmtIfNotAlready stmt = modifyMVar_ (stmtHandle stmt) $ \maybeHandle -> do - F.forM_ maybeHandle $ \hStmt -> do - hdbcTrace $ "Freeing statement with handle " ++ show hStmt - -- SQL Server might deadlock if closing handle to a statement in process of fetching - -- network data so we have to cancel it explicitly. We also need to protect ourselves - -- from trying to cancel or free a statement, which has its connection already finalized. - RWV.with (connHandle $ stmtConn stmt) $ \maybeConn -> - F.forM_ maybeConn $ \_ -> do - void $ c_sqlCancel hStmt - void $ c_sqlCloseCursor hStmt - void $ c_sqlFreeHandle sQL_HANDLE_STMT (castPtr hStmt) - return Nothing - -withMaybeStmt :: StmtWrapper -> (Maybe SQLHSTMT -> IO a) -> IO a -withMaybeStmt = withMVar . stmtHandle - -withStmtOrDie :: StmtWrapper -> (SQLHSTMT -> IO a) -> IO a -withStmtOrDie sw act = withMaybeStmt sw $ \maybeHandle -> - case maybeHandle of - Just h -> act h - Nothing -> do - hdbcTrace $ "Requested a STMT handle from a disposed wrapper. Throwing." - throwSqlError SqlError - { seState = "" - , seNativeError = -1 - , seErrorMsg = "Tried to use a disposed ODBC Statement handle" - } +{-| Defines haskell wrappers over native ODBC objects to free+ you from some memory (and threading) management.+-}+{-# LANGUAGE OverloadedStrings #-}+module Database.HDBC.ODBC.Wrappers+ ( EnvWrapper (..)+ , sqlAllocEnv+ , withMaybeEnv+ , withEnvOrDie+ , freeEnvIfNotAlready+ , DbcWrapper (..)+ , sqlAllocDbc+ , withMaybeDbc+ , withDbcOrDie+ , tryDisconnectAndFree+ , freeDbcIfNotAlready+ , StmtWrapper (..)+ , sqlAllocStmt+ , withMaybeStmt+ , withStmtOrDie+ , freeStmtIfNotAlready+ ) where++import Control.Monad (unless, void, when)+import Control.Concurrent.MVar+import Control.Concurrent.ReadWriteVar (RWVar)+import Database.HDBC (SqlError (..), throwSqlError)+import Database.HDBC.ODBC.Api.Errors+import Database.HDBC.ODBC.Api.Imports+import Database.HDBC.ODBC.Api.Types+import Database.HDBC.ODBC.Log+import Foreign.Marshal hiding (void)+import Foreign.Ptr+import Foreign.Storable+import System.Mem.Weak (addFinalizer)++import qualified Control.Concurrent.ReadWriteVar as RWV+import qualified Data.Foldable as F++data EnvWrapper = EnvWrapper+ { envHandle :: MVar (Maybe SQLHENV) -- ^ If there is Nothing here, environment is already freed+ }++sqlAllocEnv :: IO EnvWrapper+sqlAllocEnv = do+ hEnv <- alloca $ \(penvptr :: Ptr SQLHENV) -> do+ retVal <- c_sqlAllocHandle sQL_HANDLE_ENV nullPtr (castPtr penvptr)+ unless (sqlSucceeded retVal) $ throwSqlError SqlError+ { seState = ""+ , seNativeError = -1+ , seErrorMsg = "sqlAllocEnv/SqlAllocHandle: Failed to allocate ODBC Environment handle"+ }+ peek penvptr++ handleVar <- newMVar (Just hEnv)+ let wrapper = EnvWrapper handleVar++ addFinalizer wrapper $ freeEnvIfNotAlready wrapper+ return wrapper++freeEnvIfNotAlready :: EnvWrapper -> IO ()+freeEnvIfNotAlready w = modifyMVar_ (envHandle w) $ \maybeEnv -> do+ F.forM_ maybeEnv $ \hEnv -> do+ hdbcTrace $ "Freeing environment with handle " ++ show hEnv+ void $ c_sqlFreeHandle sQL_HANDLE_ENV (castPtr hEnv)+ return Nothing++withMaybeEnv :: EnvWrapper -> (Maybe SQLHENV -> IO a) -> IO a+withMaybeEnv = withMVar . envHandle++withEnvOrDie :: EnvWrapper -> (SQLHENV -> IO a) -> IO a+withEnvOrDie ew act = withMaybeEnv ew $ \maybeHandle ->+ case maybeHandle of+ Just h -> act h+ Nothing -> do+ hdbcTrace "Requested an ENV handle from disposed wrapper. Throwing."+ throwSqlError SqlError+ { seState = ""+ , seNativeError = -1+ , seErrorMsg = "Tried to use a disposed ODBC Environment handle"+ }++data DbcWrapper = DbcWrapper+ { connHandle :: RWVar (Maybe SQLHDBC) -- ^ If there is Nothing here, connection is already freed+ , connEnv :: EnvWrapper+ , connOldStmts :: MVar [SQLHSTMT] -- ^ Statements that are no longer used and need to be freed+ }++-- This one implicitly allocates and initializes an environment.+sqlAllocDbc :: EnvWrapper -> IO DbcWrapper+sqlAllocDbc env = do+ hDbc <- withEnvOrDie env $ \hEnv -> alloca $ \(pdbcptr :: Ptr SQLHDBC) -> do+ retVal <- c_sqlAllocHandle sQL_HANDLE_DBC (castPtr hEnv) (castPtr pdbcptr)+ checkError "sqlAllocConn/SQLAllocHandle" (EnvHandle hEnv) retVal+ peek pdbcptr++ handleVar <- RWV.new $ Just hDbc+ oldStmtsVar <- newMVar []+ let wrapper = DbcWrapper handleVar env oldStmtsVar++ addFinalizer wrapper $ freeDbcIfNotAlready False wrapper+ return wrapper++freeOldStmts :: DbcWrapper -> IO ()+freeOldStmts dbc = RWV.with (connHandle dbc) $ \maybeConn ->+ F.forM_ maybeConn $ \_ ->+ modifyMVar_ (connOldStmts dbc) $ \stmts -> do+ F.forM_ stmts $ \hStmt -> do+ hdbcTrace $ "Freeing statement with handle " ++ show hStmt+ -- SQL Server might deadlock if closing handle to a statement in process of fetching+ -- network data so we have to cancel it explicitly. We also need to protect ourselves+ -- from trying to cancel or free a statement, which has its connection already finalized.+ void $ c_sqlCancel hStmt+ void $ c_sqlCloseCursor hStmt+ void $ c_sqlFreeHandle sQL_HANDLE_STMT (castPtr hStmt)+ return []++-- | Tries to perform disconnect and free resources used by connection. If SQLDisconnect call+-- fails, an exception gets thrown and connection resources aren't freed.+tryDisconnectAndFree :: DbcWrapper -> IO ()+tryDisconnectAndFree = freeDbcIfNotAlready True++freeDbcIfNotAlready :: Bool -> DbcWrapper -> IO ()+freeDbcIfNotAlready checkDisconnect dbc = do+ freeOldStmts dbc+ RWV.modify_ (connHandle dbc) $ \maybeHandle -> do+ F.forM_ maybeHandle $ \hDbc -> do+ hdbcTrace $ "Freeing connection with handle " ++ show hDbc+ disconnectResult <- c_sqlDisconnect hDbc+ when checkDisconnect $ checkError "freeDbcIfNotAlready/SQLDisconnect" (DbcHandle hDbc) disconnectResult+ void $ c_sqlFreeHandle sQL_HANDLE_DBC (castPtr hDbc)+ return Nothing+ freeEnvIfNotAlready $ connEnv dbc++withMaybeDbc :: DbcWrapper -> (Maybe SQLHDBC -> IO a) -> IO a+withMaybeDbc = RWV.with . connHandle++withDbcOrDie :: DbcWrapper -> (SQLHDBC -> IO a) -> IO a+withDbcOrDie dw act = withMaybeDbc dw $ \maybeHandle ->+ case maybeHandle of+ Just h -> act h+ Nothing -> do+ hdbcTrace "Requested a DBC handle from a disposed wrapper. Throwing"+ throwSqlError SqlError+ { seState = ""+ , seNativeError = -1+ , seErrorMsg = "Tried to use a disposed ODBC Connection handle"+ }++data StmtWrapper = StmtWrapper+ { stmtHandle :: MVar (Maybe SQLHSTMT) -- ^ If there is Nothing here, statement is already finished+ , stmtConn :: DbcWrapper+ }++sqlAllocStmt :: DbcWrapper -> IO StmtWrapper+sqlAllocStmt dbc = do+ freeOldStmts dbc+ hStmt <- withDbcOrDie dbc $ \hDbc -> alloca $ \(psthptr :: Ptr SQLHSTMT) -> do+ retVal <- c_sqlAllocHandle sQL_HANDLE_STMT (castPtr hDbc) (castPtr psthptr)+ checkError "sqlAllocStmt/SQLAllocHandle" (DbcHandle hDbc) retVal+ peek psthptr++ handleVar <- newMVar $ Just hStmt+ let wrapper = StmtWrapper handleVar dbc++ addFinalizer wrapper $ freeStmtIfNotAlready wrapper+ return wrapper++freeStmtIfNotAlready :: StmtWrapper -> IO ()+freeStmtIfNotAlready stmt = modifyMVar_ (stmtHandle stmt) $ \maybeHandle -> do+ F.forM_ maybeHandle $ \hStmt ->+ modifyMVar_ (connOldStmts $ stmtConn stmt) $ return . (hStmt :)+ return Nothing++withMaybeStmt :: StmtWrapper -> (Maybe SQLHSTMT -> IO a) -> IO a+withMaybeStmt = withMVar . stmtHandle++withStmtOrDie :: StmtWrapper -> (SQLHSTMT -> IO a) -> IO a+withStmtOrDie sw act = withMaybeStmt sw $ \maybeHandle ->+ case maybeHandle of+ Just h -> act h+ Nothing -> do+ hdbcTrace $ "Requested a STMT handle from a disposed wrapper. Throwing."+ throwSqlError SqlError+ { seState = ""+ , seNativeError = -1+ , seErrorMsg = "Tried to use a disposed ODBC Statement handle"+ }
HDBC-odbc.cabal view
@@ -1,117 +1,117 @@-name: HDBC-odbc -version: 2.5.0.1 -cabal-version: >=1.8 -build-type: Simple -license: BSD3 -maintainer: Anton Dessiatov <anton.dessiatov@gmail.com> -author: John Goerzen -copyright: Copyright (c) 2005-2014 John Goerzen, Nicolas Wu, Anton Dessiatov -license-file: LICENSE -extra-source-files: - LICENSE - , cbits/hdbc-odbc-helper.h - , Makefile - , README.md - , testsrc/TestTime.hs - , changelog.txt -homepage: https://github.com/hdbc/hdbc-odbc -category: Database -synopsis: ODBC driver for HDBC -description: - This package provides an ODBC database backend for HDBC. - It is cross-platform and supports unixODBC on Unix/Linux/POSIX platforms - and Microsoft ODBC on Windows. It is also the preferred way to access - MySQL databases from Haskell. -stability: Beta - -flag buildtests - description: Build the executable to run unit tests - default: False - -flag buildstresstest - description: Build the stress testing executable - default: False - -library - exposed-modules: - Database.HDBC.ODBC - other-modules: - Database.HDBC.ODBC.Api.Errors - , Database.HDBC.ODBC.Api.Imports - , Database.HDBC.ODBC.Api.Types - , Database.HDBC.ODBC.Connection - , Database.HDBC.ODBC.ConnectionImpl - , Database.HDBC.ODBC.Log - , Database.HDBC.ODBC.Statement - , Database.HDBC.ODBC.TypeConv - , Database.HDBC.ODBC.Utils - , Database.HDBC.ODBC.Wrappers - extensions: - ExistentialQuantification - , ForeignFunctionInterface - , ScopedTypeVariables - build-depends: - base >= 4.3.1.0 && < 5 - , concurrent-extra >= 0.7.0.8 - , mtl - , HDBC>=2.1.0 - , time>=1.2.0.3 - , utf8-string - , bytestring - c-sources: - cbits/hdbc-odbc-helper.c - include-dirs: - cbits - - if os(mingw32) || os(win32) - extra-libraries: odbc32 - else - extra-libraries: odbc, pthread - -executable runtests - if flag(buildtests) - buildable: True - build-depends: - base - , HUnit - , HDBC - , HDBC-odbc - , QuickCheck - , testpack - , containers - , old-time - , time - , old-locale - , convertible - else - buildable: False - main-is: runtests.hs - other-modules: - SpecificDB - , SpecificDBTests - , TestMisc - , TestSbasics - , TestUtils - , Testbasics - , Tests - hs-source-dirs: testsrc - ghc-options: -O2 - extensions: - ExistentialQuantification - , ForeignFunctionInterface - , ScopedTypeVariables - -executable stresstest - if flag(buildstresstest) - buildable: True - build-depends: - base - , HDBC - , HDBC-odbc - , random - , resource-pool - else - buildable: False - main-is: stresstest.hs - hs-source-dirs: stresstest - ghc-options: -threaded -rtsopts +name: HDBC-odbc+version: 2.5.1.1+cabal-version: >=1.8+build-type: Simple+license: BSD3+maintainer: Anton Dessiatov <anton.dessiatov@gmail.com>+author: John Goerzen+copyright: Copyright (c) 2005-2014 John Goerzen, Nicolas Wu, Anton Dessiatov+license-file: LICENSE+extra-source-files:+ LICENSE+ , cbits/hdbc-odbc-helper.h+ , Makefile+ , README.md+ , testsrc/TestTime.hs+ , changelog.txt+homepage: https://github.com/hdbc/hdbc-odbc+category: Database+synopsis: ODBC driver for HDBC+description:+ This package provides an ODBC database backend for HDBC.+ It is cross-platform and supports unixODBC on Unix/Linux/POSIX platforms+ and Microsoft ODBC on Windows. It is also the preferred way to access+ MySQL databases from Haskell.+stability: Beta++flag buildtests+ description: Build the executable to run unit tests+ default: False++flag buildstresstest+ description: Build the stress testing executable+ default: False++library+ exposed-modules:+ Database.HDBC.ODBC+ other-modules:+ Database.HDBC.ODBC.Api.Errors+ , Database.HDBC.ODBC.Api.Imports+ , Database.HDBC.ODBC.Api.Types+ , Database.HDBC.ODBC.Connection+ , Database.HDBC.ODBC.ConnectionImpl+ , Database.HDBC.ODBC.Log+ , Database.HDBC.ODBC.Statement+ , Database.HDBC.ODBC.TypeConv+ , Database.HDBC.ODBC.Utils+ , Database.HDBC.ODBC.Wrappers+ extensions:+ ExistentialQuantification+ , ForeignFunctionInterface+ , ScopedTypeVariables+ build-depends:+ base >= 4.3.1.0 && < 5+ , concurrent-extra >= 0.7.0.8+ , mtl+ , HDBC>=2.1.0+ , time>=1.2.0.3+ , utf8-string+ , bytestring+ c-sources:+ cbits/hdbc-odbc-helper.c+ include-dirs:+ cbits++ if os(mingw32) || os(win32)+ extra-libraries: odbc32+ else+ extra-libraries: odbc, pthread++executable runtests+ if flag(buildtests)+ buildable: True+ build-depends:+ base+ , HUnit+ , HDBC+ , HDBC-odbc+ , QuickCheck+ , testpack+ , containers+ , old-time+ , time+ , old-locale+ , convertible+ else+ buildable: False+ main-is: runtests.hs+ other-modules:+ SpecificDB+ , SpecificDBTests+ , TestMisc+ , TestSbasics+ , TestUtils+ , Testbasics+ , Tests+ hs-source-dirs: testsrc+ ghc-options: -O2+ extensions:+ ExistentialQuantification+ , ForeignFunctionInterface+ , ScopedTypeVariables++executable stresstest+ if flag(buildstresstest)+ buildable: True+ build-depends:+ base+ , HDBC+ , HDBC-odbc+ , random+ , resource-pool+ else+ buildable: False+ main-is: stresstest.hs+ hs-source-dirs: stresstest+ ghc-options: -threaded -rtsopts
LICENSE view
@@ -1,27 +1,27 @@-Copyright (c) 2005-2011, John Goerzen -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 John Goerzen nor the names of its - 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 HOLDER 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. +Copyright (c) 2005-2011, John Goerzen+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 John Goerzen nor the names of its+ 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 HOLDER 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.
Makefile view
@@ -1,36 +1,36 @@-all: setup - @echo "Please use Cabal to build this package; not make." - ./setup configure - ./setup build - -setup: Setup.hs - ghc --make -package Cabal -o setup Setup.hs - -install: setup - ./setup install - -clean: - -runghc Setup.hs clean - -rm -rf html `find . -name "*.o"` `find . -name "*.hi" | grep -v debian` \ - `find . -name "*~" | grep -v debian` *.a setup dist testsrc/runtests \ - local-pkg doctmp - -rm -rf testtmp/* testtmp* - -.PHONY: test -test: test-ghc test-hugs - @echo "" - @echo "All tests pass." - -test-hugs: setup - @echo " ****** Running hugs tests" - ./setup configure -f buildtests --hugs --extra-include-dirs=/usr/lib/hugs/include - ./setup build - runhugs -98 +o -P$(PWD)/dist/scratch:$(PWD)/dist/scratch/programs/runtests: \ - dist/scratch/programs/runtests/Main.hs - -test-ghc: setup - @echo " ****** Building GHC tests" - ./setup configure -f buildtests - ./setup build - @echo " ****** Running GHC tests" - ./dist/build/runtests/runtests +all: setup+ @echo "Please use Cabal to build this package; not make."+ ./setup configure+ ./setup build++setup: Setup.hs+ ghc --make -package Cabal -o setup Setup.hs++install: setup+ ./setup install++clean:+ -runghc Setup.hs clean+ -rm -rf html `find . -name "*.o"` `find . -name "*.hi" | grep -v debian` \+ `find . -name "*~" | grep -v debian` *.a setup dist testsrc/runtests \+ local-pkg doctmp+ -rm -rf testtmp/* testtmp*++.PHONY: test+test: test-ghc test-hugs+ @echo ""+ @echo "All tests pass."++test-hugs: setup+ @echo " ****** Running hugs tests"+ ./setup configure -f buildtests --hugs --extra-include-dirs=/usr/lib/hugs/include+ ./setup build+ runhugs -98 +o -P$(PWD)/dist/scratch:$(PWD)/dist/scratch/programs/runtests: \+ dist/scratch/programs/runtests/Main.hs++test-ghc: setup+ @echo " ****** Building GHC tests"+ ./setup configure -f buildtests+ ./setup build+ @echo " ****** Running GHC tests"+ ./dist/build/runtests/runtests
README.md view
@@ -1,107 +1,109 @@-HDBC-ODBC -========= - -Welcome to HDBC, Haskell Database Connectivity. - -This package provides a database backend driver for ODBC. You should -be able to use any ODBC front-end with it. - -Please see HDBC itself for documentation on use. - -This package provides one function in module Database.HDBC.ODBC: - -> Connect to an ODBC server. -> For information on the meaning of the passed string, please see: -> <http://msdn2.microsoft.com/en-us/library/ms715433(VS.85).aspx> - -> ```haskell -> connectODBC :: String -> IO Connection -> ``` - - -For example, you might use `connectODBC` as follows: - - connectODBC "DSN=hdbctest1" - -For more information about HDBC-ODBC, -please visit the [wiki](https://github.com/hdbc/hdbc-odbc/wiki). - -Differences from HDBC standard ------------------------------- - -None known at this time. - -MySQL note ----------- - -Important note for MySQL users: - -Unless you are going to use InnoDB tables, you are strongly encouraged to set - - Option = 262144 - -in your odbc.ini (for Unix users), or to disable transaction support in your -DSN setup for Windows users. - -If you fail to do this, the MySQL ODBC driver will incorrectly state that it -supports transactions. dbTransactionSupport will incorrectly return True. -commit and rollback will then silently fail. This is certainly *NOT* what you -want. It is a bug (or misfeature) in the MySQL driver, not in HDBC. - -You should ignore this advice if you are using InnoDB tables. - -For the error "2013: Mysql server has gone away" error message, you'll have to -use withRTSSignalsBlocked from the HDBC-mysql package. - -query conn stmStr binds = withRTSSignalsBlocked $ quickQuery conn stmStr binds - -Getting Started ---------------- - -Here are some instructions to set up ODBC with a sqlite3 backend, and how -to communicate with that database with HDBC-ODBC. -These instructions are written to work with Ubuntu 11.10. - -First, we'll need to install the appropriate libraries: - - sudo apt-get install unixodbc unixodbc-dev unixodbc-bin - sudo apt-get install libsqliteodbc - -Verify that the sqlite ODBC drivers have been set up correctly: - - odbcinst -q -d -This should return: - - [SQLite] - [SQLite3] - -Next, fire up the `ODBCConfig` too to set up a new DSN: - - ODBCConfig - -If you want to run the HDBC test suite, then set your DSN to `hdbctest`, -and set up to connect to a database of your choice, such as an empty file -in the `hdbc-odbc/testsrc` directory: - - touch hdbc-odbc/testsrc/hdbctest.db - -You can check that everything is working appropriately in ghci: - - ghci> :m + Database.HDBC Database.HDBC.ODBC - ghci> conn <- connectODBC "DSN=hdbctest" - ghci> hdbcDriverName conn - "odbc" - ghci> hdbcClientVer conn - "03.52" - -You can then run some tests on your database: - - cd testsrc - runhaskell runtests.hs - -Contributing ------------- - -Contributions are welcome! If you would like to contribute, please fork the the -[github repository](https://github.com/hdbc/hdbc-odbc), and submit a pull -request. +HDBC-ODBC+=========++[](https://circleci.com/gh/hdbc/hdbc-odbc/tree/master)++Welcome to HDBC, Haskell Database Connectivity.++This package provides a database backend driver for ODBC. You should+be able to use any ODBC front-end with it.++Please see HDBC itself for documentation on use.++This package provides one function in module Database.HDBC.ODBC:++> Connect to an ODBC server.+> For information on the meaning of the passed string, please see:+> <http://msdn2.microsoft.com/en-us/library/ms715433(VS.85).aspx>++> ```haskell+> connectODBC :: String -> IO Connection+> ```+++For example, you might use `connectODBC` as follows:++ connectODBC "DSN=hdbctest1"++For more information about HDBC-ODBC,+please visit the [wiki](https://github.com/hdbc/hdbc-odbc/wiki).++Differences from HDBC standard+------------------------------++None known at this time.++MySQL note+----------++Important note for MySQL users:++Unless you are going to use InnoDB tables, you are strongly encouraged to set++ Option = 262144++in your odbc.ini (for Unix users), or to disable transaction support in your+DSN setup for Windows users.++If you fail to do this, the MySQL ODBC driver will incorrectly state that it+supports transactions. dbTransactionSupport will incorrectly return True.+commit and rollback will then silently fail. This is certainly *NOT* what you+want. It is a bug (or misfeature) in the MySQL driver, not in HDBC.++You should ignore this advice if you are using InnoDB tables.++For the error "2013: Mysql server has gone away" error message, you'll have to+use withRTSSignalsBlocked from the HDBC-mysql package.++query conn stmStr binds = withRTSSignalsBlocked $ quickQuery conn stmStr binds++Getting Started+---------------++Here are some instructions to set up ODBC with a sqlite3 backend, and how+to communicate with that database with HDBC-ODBC.+These instructions are written to work with Ubuntu 11.10.++First, we'll need to install the appropriate libraries:++ sudo apt-get install unixodbc unixodbc-dev unixodbc-bin+ sudo apt-get install libsqliteodbc++Verify that the sqlite ODBC drivers have been set up correctly:++ odbcinst -q -d+This should return:++ [SQLite]+ [SQLite3]++Next, fire up the `ODBCConfig` too to set up a new DSN:++ ODBCConfig++If you want to run the HDBC test suite, then set your DSN to `hdbctest`,+and set up to connect to a database of your choice, such as an empty file+in the `hdbc-odbc/testsrc` directory:++ touch hdbc-odbc/testsrc/hdbctest.db++You can check that everything is working appropriately in ghci:++ ghci> :m + Database.HDBC Database.HDBC.ODBC+ ghci> conn <- connectODBC "DSN=hdbctest"+ ghci> hdbcDriverName conn+ "odbc"+ ghci> hdbcClientVer conn+ "03.52"++You can then run some tests on your database:++ cd testsrc+ runhaskell runtests.hs++Contributing+------------++Contributions are welcome! If you would like to contribute, please fork the the+[github repository](https://github.com/hdbc/hdbc-odbc), and submit a pull+request.
Setup.hs view
@@ -1,5 +1,5 @@-#!/usr/bin/env runhaskell - -import Distribution.Simple - -main = defaultMain +#!/usr/bin/env runhaskell++import Distribution.Simple++main = defaultMain
cbits/hdbc-odbc-helper.c view
@@ -1,23 +1,23 @@-#include "hdbc-odbc-helper.h" -#include <sqlext.h> -#include <stdio.h> -#include <stdlib.h> - -SQLLEN nullDataHDBC = SQL_NULL_DATA; - -int sqlSucceeded(SQLRETURN ret) { - return SQL_SUCCEEDED(ret); -} - -void *getSqlOvOdbc3(void) { - return (void *)SQL_OV_ODBC3; -} - -SQLRETURN simpleSqlTables(SQLHSTMT stmt) { - return SQLTables(stmt, NULL, 0, NULL, 0, "%", 1, "TABLE", 5); -} - -SQLRETURN simpleSqlColumns(SQLHSTMT stmt, SQLCHAR *tablename, - SQLSMALLINT tnlen) { - return SQLColumns(stmt, NULL, 0, NULL, 0, tablename, tnlen, "%", 1); -} +#include "hdbc-odbc-helper.h"+#include <sqlext.h>+#include <stdio.h>+#include <stdlib.h>++SQLLEN nullDataHDBC = SQL_NULL_DATA;++int sqlSucceeded(SQLRETURN ret) {+ return SQL_SUCCEEDED(ret);+}++void *getSqlOvOdbc3(void) {+ return (void *)SQL_OV_ODBC3;+}++SQLRETURN simpleSqlTables(SQLHSTMT stmt) {+ return SQLTables(stmt, NULL, 0, NULL, 0, "%", 1, "TABLE", 5);+}++SQLRETURN simpleSqlColumns(SQLHSTMT stmt, SQLCHAR *tablename,+ SQLSMALLINT tnlen) {+ return SQLColumns(stmt, NULL, 0, NULL, 0, tablename, tnlen, "%", 1);+}
cbits/hdbc-odbc-helper.h view
@@ -1,20 +1,20 @@-#ifndef _HDBC_ODBC_CBITS_HDBC_ODBC_HELPER_H -#define _HDBC_ODBC_CBITS_HDBC_ODBC_HELPER_H - -#if defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__) -#include <windows.h> -#include <winnt.h> -#endif - -#include <sql.h> - -int sqlSucceeded(SQLRETURN ret); - -SQLLEN nullDataHDBC; -void *getSqlOvOdbc3(void); - -SQLRETURN simpleSqlTables(SQLHSTMT stmt); -SQLRETURN simpleSqlColumns(SQLHSTMT stmt, SQLCHAR *tablename, - SQLSMALLINT tnlen); - -#endif /* _HDBC_ODBC_CBITS_HDBC_ODBC_HELPER_H */ +#ifndef _HDBC_ODBC_CBITS_HDBC_ODBC_HELPER_H+#define _HDBC_ODBC_CBITS_HDBC_ODBC_HELPER_H++#if defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)+#include <windows.h>+#include <winnt.h>+#endif++#include <sql.h>++int sqlSucceeded(SQLRETURN ret);++SQLLEN nullDataHDBC;+void *getSqlOvOdbc3(void);++SQLRETURN simpleSqlTables(SQLHSTMT stmt);+SQLRETURN simpleSqlColumns(SQLHSTMT stmt, SQLCHAR *tablename,+ SQLSMALLINT tnlen);++#endif /* _HDBC_ODBC_CBITS_HDBC_ODBC_HELPER_H */
changelog.txt view
@@ -1,15 +1,15 @@-2.4.0.1 - 15 May 2015 - - * Switched to using UTF-8 encoding for binding WCHAR_T values on Linux. Earlier version tried - to use C wchar_t type, which confused some (in particular PostgreSQL) drivers. - -2.4.0.0 - 12 Nov 2014 - - * Changed parameter binding implementation to fix bugs with wide character strings and binary - data not handled well with Microsoft SQL Server on Windows. - - * Implemented atomic reference counting to avoid race conditions in native code when running - with -threaded - - * Implemented workaround for the SQL Server ODBC Driver deadlock, which occured if cursor over a - statement that was in the process of fetching data over the network got closed. +2.4.0.1 - 15 May 2015++ * Switched to using UTF-8 encoding for binding WCHAR_T values on Linux. Earlier version tried+ to use C wchar_t type, which confused some (in particular PostgreSQL) drivers.++2.4.0.0 - 12 Nov 2014++ * Changed parameter binding implementation to fix bugs with wide character strings and binary+ data not handled well with Microsoft SQL Server on Windows.++ * Implemented atomic reference counting to avoid race conditions in native code when running+ with -threaded++ * Implemented workaround for the SQL Server ODBC Driver deadlock, which occured if cursor over a+ statement that was in the process of fetching data over the network got closed.
stresstest/stresstest.hs view
@@ -1,55 +1,55 @@-{-# LANGUAGE BangPatterns #-} -module Main where - -import Control.Applicative -import Control.Concurrent -import Control.Exception -import Control.Monad -import Database.HDBC -import Data.Pool -import System.IO -import System.Random - -import Database.HDBC.ODBC - -connectionString :: String -connectionString = "DSN=hdbctest" - -threadNumber :: Int -threadNumber = 4 - -prepareDatabase :: Pool ConnWrapper -> IO () -prepareDatabase pool = withResource pool $ \conn -> withTransaction conn $ \tran -> - void $ run tran - "if not exists (select * from sysobjects where name='test_table' and xtype='U') \ - \create table test_table ( \ - \id int identity not null, \ - \value nvarchar(64) not null \ - \)" [] - -writerThread :: Pool ConnWrapper -> IO () -writerThread pool = forever $ withResource pool $ \conn -> do - len <- randomRIO (1, 64) - value <- replicateM len $ randomRIO ('a', 'z') - void $ do - run conn "insert into test_table (value) values (?)" [SqlString value] - commit conn - -readerThread :: Pool ConnWrapper -> IO () -readerThread pool = forever $ withResource pool $ \conn -> forever $ do - !offset <- randomRIO (1, 100000) :: IO Int - !limit <- randomRIO (1, 60) :: IO Int - sth <- prepare conn $ "select * from test_table order by id offset " ++ show offset ++ " rows fetch next " ++ show limit ++ " rows only" - execute sth [] - results <- fetchAllRows' sth - finish sth - return () - -main :: IO () -main = handleSqlError $ bracket (createPool (ConnWrapper <$> connectODBC connectionString) disconnect 1 20 2) destroyAllResources $ \pool -> do - prepareDatabase pool - forkIO $ writerThread pool - replicateM_ threadNumber . forkIO $ - readerThread pool - hSetBuffering stdin NoBuffering - void getChar +{-# LANGUAGE BangPatterns #-}+module Main where++import Control.Applicative+import Control.Concurrent+import Control.Exception+import Control.Monad+import Database.HDBC+import Data.Pool+import System.IO+import System.Random++import Database.HDBC.ODBC++connectionString :: String+connectionString = "DSN=hdbctest"++threadNumber :: Int+threadNumber = 4++prepareDatabase :: Pool ConnWrapper -> IO ()+prepareDatabase pool = withResource pool $ \conn -> withTransaction conn $ \tran ->+ void $ run tran+ "if not exists (select * from sysobjects where name='test_table' and xtype='U') \+ \create table test_table ( \+ \id int identity not null, \+ \value nvarchar(64) not null \+ \)" []++writerThread :: Pool ConnWrapper -> IO ()+writerThread pool = forever $ withResource pool $ \conn -> do+ len <- randomRIO (1, 64)+ value <- replicateM len $ randomRIO ('a', 'z')+ void $ do+ run conn "insert into test_table (value) values (?)" [SqlString value]+ commit conn++readerThread :: Pool ConnWrapper -> IO ()+readerThread pool = forever $ withResource pool $ \conn -> forever $ do+ !offset <- randomRIO (1, 100000) :: IO Int+ !limit <- randomRIO (1, 60) :: IO Int+ sth <- prepare conn $ "select * from test_table order by id offset " ++ show offset ++ " rows fetch next " ++ show limit ++ " rows only"+ execute sth []+ results <- fetchAllRows' sth+ finish sth+ return ()++main :: IO ()+main = handleSqlError $ bracket (createPool (ConnWrapper <$> connectODBC connectionString) disconnect 1 20 2) destroyAllResources $ \pool -> do+ prepareDatabase pool+ forkIO $ writerThread pool+ replicateM_ threadNumber . forkIO $+ readerThread pool+ hSetBuffering stdin NoBuffering+ void getChar
testsrc/SpecificDB.hs view
@@ -1,24 +1,24 @@-module SpecificDB where -import Database.HDBC -import Database.HDBC.ODBC -import Test.HUnit - -connectDB = - handleSqlError (connectODBC "DSN=hdbctest") - - --- These are copied from PostgreSQL for now, except for interval -dateTimeTypeOfSqlValue :: SqlValue -> String -dateTimeTypeOfSqlValue (SqlLocalDate _) = "date" -dateTimeTypeOfSqlValue (SqlLocalTimeOfDay _) = "time without time zone" -dateTimeTypeOfSqlValue (SqlZonedLocalTimeOfDay _ _) = "time with time zone" -dateTimeTypeOfSqlValue (SqlLocalTime _) = "timestamp without time zone" -dateTimeTypeOfSqlValue (SqlZonedTime _) = "timestamp with time zone" -dateTimeTypeOfSqlValue (SqlUTCTime _) = "timestamp with time zone" -dateTimeTypeOfSqlValue (SqlDiffTime _) = "numeric" -dateTimeTypeOfSqlValue (SqlPOSIXTime _) = "numeric" -dateTimeTypeOfSqlValue (SqlEpochTime _) = "integer" -dateTimeTypeOfSqlValue (SqlTimeDiff _) = "numeric" -dateTimeTypeOfSqlValue _ = "text" - -supportsFracTime = True +module SpecificDB where+import Database.HDBC+import Database.HDBC.ODBC+import Test.HUnit++connectDB = + handleSqlError (connectODBC "DSN=hdbctest")+++-- These are copied from PostgreSQL for now, except for interval+dateTimeTypeOfSqlValue :: SqlValue -> String+dateTimeTypeOfSqlValue (SqlLocalDate _) = "date"+dateTimeTypeOfSqlValue (SqlLocalTimeOfDay _) = "time without time zone"+dateTimeTypeOfSqlValue (SqlZonedLocalTimeOfDay _ _) = "time with time zone"+dateTimeTypeOfSqlValue (SqlLocalTime _) = "timestamp without time zone"+dateTimeTypeOfSqlValue (SqlZonedTime _) = "timestamp with time zone"+dateTimeTypeOfSqlValue (SqlUTCTime _) = "timestamp with time zone"+dateTimeTypeOfSqlValue (SqlDiffTime _) = "numeric"+dateTimeTypeOfSqlValue (SqlPOSIXTime _) = "numeric"+dateTimeTypeOfSqlValue (SqlEpochTime _) = "integer"+dateTimeTypeOfSqlValue (SqlTimeDiff _) = "numeric"+dateTimeTypeOfSqlValue _ = "text"++supportsFracTime = True
testsrc/SpecificDBTests.hs view
@@ -1,5 +1,5 @@-module SpecificDBTests where -import Database.HDBC -import Test.HUnit - -tests = TestList [] +module SpecificDBTests where+import Database.HDBC+import Test.HUnit++tests = TestList []
testsrc/TestMisc.hs view
@@ -1,181 +1,181 @@-module TestMisc(tests, setup) where -import Test.HUnit -import Database.HDBC -import TestUtils -import System.IO -import Control.Exception -import Data.Char -import Control.Monad -import qualified Data.Map as Map - -rowdata = - [[SqlInt32 0, toSql "Testing", SqlNull], - [SqlInt32 1, toSql "Foo", SqlInt32 5], - [SqlInt32 2, toSql "Bar", SqlInt32 9]] - -colnames = ["testid", "teststring", "testint"] -alrows :: [[(String, SqlValue)]] -alrows = map (zip colnames) rowdata - -setup f = dbTestCase $ \dbh -> - do run dbh "CREATE TABLE hdbctest2 (testid INTEGER PRIMARY KEY NOT NULL, teststring TEXT, testint INTEGER)" [] - sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" - executeMany sth rowdata - commit dbh - finally (f dbh) - (do run dbh "DROP TABLE hdbctest2" [] - commit dbh - ) - -cloneTest dbh a = - do dbh2 <- clone dbh - finally (handleSqlError (a dbh2)) - (handleSqlError (disconnect dbh2)) - -testgetColumnNames = setup $ \dbh -> - do sth <- prepare dbh "SELECT * from hdbctest2" - execute sth [] - cols <- getColumnNames sth - finish sth - ["testid", "teststring", "testint"] @=? map (map toLower) cols - -testdescribeResult = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` - ["sqlite3"])) $ - do sth <- prepare dbh "SELECT * from hdbctest2" - execute sth [] - cols <- describeResult sth - ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols - let coldata = map snd cols - assertBool "r0 type" (colType (coldata !! 0) `elem` - [SqlBigIntT, SqlIntegerT]) - assertBool "r1 type" (colType (coldata !! 1) `elem` - [SqlVarCharT, SqlLongVarCharT]) - assertBool "r2 type" (colType (coldata !! 2) `elem` - [SqlBigIntT, SqlIntegerT]) - finish sth - -testdescribeTable = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem` - ["sqlite3"])) $ - do cols <- describeTable dbh "hdbctest2" - ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols - let coldata = map snd cols - assertBool "r0 type" (colType (coldata !! 0) `elem` - [SqlBigIntT, SqlIntegerT]) - assertEqual "r0 nullable" (Just False) (colNullable (coldata !! 0)) - assertBool "r1 type" (colType (coldata !! 1) `elem` - [SqlVarCharT, SqlLongVarCharT]) - assertEqual "r1 nullable" (Just True) (colNullable (coldata !! 1)) - assertBool "r2 type" (colType (coldata !! 2) `elem` - [SqlBigIntT, SqlIntegerT]) - assertEqual "r2 nullable" (Just True) (colNullable (coldata !! 2)) - -testquickQuery = setup $ \dbh -> - do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] - rowdata @=? results - -testfetchRowAL = setup $ \dbh -> - do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" - execute sth [] - fetchRowAL sth >>= (Just (head alrows) @=?) - fetchRowAL sth >>= (Just (alrows !! 1) @=?) - fetchRowAL sth >>= (Just (alrows !! 2) @=?) - fetchRowAL sth >>= (Nothing @=?) - finish sth - -testfetchRowMap = setup $ \dbh -> - do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" - execute sth [] - fetchRowMap sth >>= (Just (Map.fromList $ head alrows) @=?) - fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 1) @=?) - fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 2) @=?) - fetchRowMap sth >>= (Nothing @=?) - finish sth - -testfetchAllRowsAL = setup $ \dbh -> - do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" - execute sth [] - fetchAllRowsAL sth >>= (alrows @=?) - -testfetchAllRowsMap = setup $ \dbh -> - do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" - execute sth [] - fetchAllRowsMap sth >>= (map (Map.fromList) alrows @=?) - -testexception = setup $ \dbh -> - catchSql (do sth <- prepare dbh "SELECT invalidcol FROM hdbctest2" - execute sth [] - assertFailure "No exception was raised" - ) - (\e -> commit dbh) - -testrowcount = setup $ \dbh -> - do r <- run dbh "UPDATE hdbctest2 SET testint = 25 WHERE testid = 20" [] - assertEqual "UPDATE with no change" 0 r - r <- run dbh "UPDATE hdbctest2 SET testint = 26 WHERE testid = 0" [] - assertEqual "UPDATE with 1 change" 1 r - r <- run dbh "UPDATE hdbctest2 SET testint = 27 WHERE testid <> 0" [] - assertEqual "UPDATE with 2 changes" 2 r - commit dbh - res <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] - assertEqual "final results" - [[SqlInt32 0, toSql "Testing", SqlInt32 26], - [SqlInt32 1, toSql "Foo", SqlInt32 27], - [SqlInt32 2, toSql "Bar", SqlInt32 27]] res - -{- Since we might be running against a live DB, we can't look at a specific -list here (though a SpecificDB test case may be able to). We can ensure -that our test table is, or is not, present, as appropriate. -} - -testgetTables1 = setup $ \dbh -> - do r <- getTables dbh - True @=? "hdbctest2" `elem` r - -testgetTables2 = dbTestCase $ \dbh -> - do r <- getTables dbh - False @=? "hdbctest2" `elem` r - -testclone = setup $ \dbho -> cloneTest dbho $ \dbh -> - do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" [] - rowdata @=? results - -testnulls = setup $ \dbh -> - do let dn = hdbcDriverName dbh - when (not (dn `elem` ["postgresql", "odbc"])) ( - do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" - executeMany sth rows - finish sth - res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" [] - seq (length res) rows @=? res - ) - where rows = [[SqlInt32 100, SqlString "foo\NULbar", SqlNull], - [SqlInt32 101, SqlString "bar\NUL", SqlNull], - [SqlInt32 102, SqlString "\NUL", SqlNull], - [SqlInt32 103, SqlString "\xFF", SqlNull], - [SqlInt32 104, SqlString "regular", SqlNull]] - -testunicode = setup $ \dbh -> - do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)" - executeMany sth rows - finish sth - res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" [] - seq (length res) rows @=? res - where rows = [[SqlInt32 100, SqlString "foo\x263a", SqlNull], - [SqlInt32 101, SqlString "bar\x00A3", SqlNull], - [SqlInt32 102, SqlString (take 263 (repeat 'a')), SqlNull]] - -tests = TestList [ - TestLabel "getColumnNames" testgetColumnNames, - TestLabel "describeResult" testdescribeResult, - TestLabel "describeTable" testdescribeTable, - TestLabel "quickQuery" testquickQuery, - TestLabel "fetchRowAL" testfetchRowAL, - TestLabel "fetchRowMap" testfetchRowMap, - TestLabel "fetchAllRowsAL" testfetchAllRowsAL, - TestLabel "fetchAllRowsMap" testfetchAllRowsMap, - TestLabel "sql exception" testexception, - TestLabel "clone" testclone, - TestLabel "update rowcount" testrowcount, - TestLabel "get tables1" testgetTables1, - TestLabel "get tables2" testgetTables2, - TestLabel "nulls" testnulls, - TestLabel "unicode" testunicode] +module TestMisc(tests, setup) where+import Test.HUnit+import Database.HDBC+import TestUtils+import System.IO+import Control.Exception+import Data.Char+import Control.Monad+import qualified Data.Map as Map++rowdata = + [[SqlInt32 0, toSql "Testing", SqlNull],+ [SqlInt32 1, toSql "Foo", SqlInt32 5],+ [SqlInt32 2, toSql "Bar", SqlInt32 9]]++colnames = ["testid", "teststring", "testint"]+alrows :: [[(String, SqlValue)]]+alrows = map (zip colnames) rowdata++setup f = dbTestCase $ \dbh ->+ do run dbh "CREATE TABLE hdbctest2 (testid INTEGER PRIMARY KEY NOT NULL, teststring TEXT, testint INTEGER)" []+ sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)"+ executeMany sth rowdata+ commit dbh+ finally (f dbh)+ (do run dbh "DROP TABLE hdbctest2" []+ commit dbh+ )++cloneTest dbh a =+ do dbh2 <- clone dbh+ finally (handleSqlError (a dbh2))+ (handleSqlError (disconnect dbh2))++testgetColumnNames = setup $ \dbh ->+ do sth <- prepare dbh "SELECT * from hdbctest2"+ execute sth []+ cols <- getColumnNames sth+ finish sth+ ["testid", "teststring", "testint"] @=? map (map toLower) cols++testdescribeResult = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem`+ ["sqlite3"])) $+ do sth <- prepare dbh "SELECT * from hdbctest2"+ execute sth []+ cols <- describeResult sth+ ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols+ let coldata = map snd cols+ assertBool "r0 type" (colType (coldata !! 0) `elem`+ [SqlBigIntT, SqlIntegerT])+ assertBool "r1 type" (colType (coldata !! 1) `elem`+ [SqlVarCharT, SqlLongVarCharT])+ assertBool "r2 type" (colType (coldata !! 2) `elem`+ [SqlBigIntT, SqlIntegerT])+ finish sth++testdescribeTable = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem`+ ["sqlite3"])) $+ do cols <- describeTable dbh "hdbctest2"+ ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols+ let coldata = map snd cols+ assertBool "r0 type" (colType (coldata !! 0) `elem`+ [SqlBigIntT, SqlIntegerT])+ assertEqual "r0 nullable" (Just False) (colNullable (coldata !! 0))+ assertBool "r1 type" (colType (coldata !! 1) `elem`+ [SqlVarCharT, SqlLongVarCharT])+ assertEqual "r1 nullable" (Just True) (colNullable (coldata !! 1))+ assertBool "r2 type" (colType (coldata !! 2) `elem`+ [SqlBigIntT, SqlIntegerT])+ assertEqual "r2 nullable" (Just True) (colNullable (coldata !! 2))++testquickQuery = setup $ \dbh ->+ do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" []+ rowdata @=? results++testfetchRowAL = setup $ \dbh ->+ do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth []+ fetchRowAL sth >>= (Just (head alrows) @=?)+ fetchRowAL sth >>= (Just (alrows !! 1) @=?)+ fetchRowAL sth >>= (Just (alrows !! 2) @=?)+ fetchRowAL sth >>= (Nothing @=?)+ finish sth++testfetchRowMap = setup $ \dbh ->+ do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth []+ fetchRowMap sth >>= (Just (Map.fromList $ head alrows) @=?)+ fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 1) @=?)+ fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 2) @=?)+ fetchRowMap sth >>= (Nothing @=?)+ finish sth++testfetchAllRowsAL = setup $ \dbh ->+ do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid"+ execute sth []+ fetchAllRowsAL sth >>= (alrows @=?)++testfetchAllRowsMap = setup $ \dbh ->+ do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid"+ execute sth []+ fetchAllRowsMap sth >>= (map (Map.fromList) alrows @=?)++testexception = setup $ \dbh ->+ catchSql (do sth <- prepare dbh "SELECT invalidcol FROM hdbctest2"+ execute sth []+ assertFailure "No exception was raised"+ )+ (\e -> commit dbh)++testrowcount = setup $ \dbh ->+ do r <- run dbh "UPDATE hdbctest2 SET testint = 25 WHERE testid = 20" []+ assertEqual "UPDATE with no change" 0 r+ r <- run dbh "UPDATE hdbctest2 SET testint = 26 WHERE testid = 0" []+ assertEqual "UPDATE with 1 change" 1 r+ r <- run dbh "UPDATE hdbctest2 SET testint = 27 WHERE testid <> 0" []+ assertEqual "UPDATE with 2 changes" 2 r+ commit dbh+ res <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" []+ assertEqual "final results"+ [[SqlInt32 0, toSql "Testing", SqlInt32 26],+ [SqlInt32 1, toSql "Foo", SqlInt32 27],+ [SqlInt32 2, toSql "Bar", SqlInt32 27]] res+ +{- Since we might be running against a live DB, we can't look at a specific+list here (though a SpecificDB test case may be able to). We can ensure+that our test table is, or is not, present, as appropriate. -}+ +testgetTables1 = setup $ \dbh ->+ do r <- getTables dbh+ True @=? "hdbctest2" `elem` r++testgetTables2 = dbTestCase $ \dbh ->+ do r <- getTables dbh+ False @=? "hdbctest2" `elem` r++testclone = setup $ \dbho -> cloneTest dbho $ \dbh ->+ do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" []+ rowdata @=? results++testnulls = setup $ \dbh ->+ do let dn = hdbcDriverName dbh+ when (not (dn `elem` ["postgresql", "odbc"])) (+ do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)"+ executeMany sth rows+ finish sth+ res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" []+ seq (length res) rows @=? res+ )+ where rows = [[SqlInt32 100, SqlString "foo\NULbar", SqlNull],+ [SqlInt32 101, SqlString "bar\NUL", SqlNull],+ [SqlInt32 102, SqlString "\NUL", SqlNull],+ [SqlInt32 103, SqlString "\xFF", SqlNull],+ [SqlInt32 104, SqlString "regular", SqlNull]]+ +testunicode = setup $ \dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)"+ executeMany sth rows+ finish sth+ res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" []+ seq (length res) rows @=? res+ where rows = [[SqlInt32 100, SqlString "foo\x263a", SqlNull],+ [SqlInt32 101, SqlString "bar\x00A3", SqlNull],+ [SqlInt32 102, SqlString (take 263 (repeat 'a')), SqlNull]]++tests = TestList [+ TestLabel "getColumnNames" testgetColumnNames,+ TestLabel "describeResult" testdescribeResult,+ TestLabel "describeTable" testdescribeTable,+ TestLabel "quickQuery" testquickQuery,+ TestLabel "fetchRowAL" testfetchRowAL,+ TestLabel "fetchRowMap" testfetchRowMap,+ TestLabel "fetchAllRowsAL" testfetchAllRowsAL,+ TestLabel "fetchAllRowsMap" testfetchAllRowsMap,+ TestLabel "sql exception" testexception,+ TestLabel "clone" testclone,+ TestLabel "update rowcount" testrowcount,+ TestLabel "get tables1" testgetTables1,+ TestLabel "get tables2" testgetTables2,+ TestLabel "nulls" testnulls,+ TestLabel "unicode" testunicode]
testsrc/TestSbasics.hs view
@@ -1,156 +1,156 @@-module TestSbasics(tests) where -import Test.HUnit -import Database.HDBC -import TestUtils -import System.IO -import Control.Exception - -openClosedb = sqlTestCase $ - do dbh <- connectDB - disconnect dbh - -singleFinish = dbTestCase $ \dbh -> - do sth <- prepare dbh "SELECT 1 + 1" - sExecute sth [] - finish sth - -multiFinish = dbTestCase (\dbh -> - do sth <- prepare dbh "SELECT 1 + 1" - sExecute sth [] - finish sth - finish sth - finish sth - ) - -basicQueries = dbTestCase (\dbh -> - do sth <- prepare dbh "SELECT 1 + 1" - sExecute sth [] - sFetchRow sth >>= (assertEqual "row 1" (Just [Just "2"])) - sFetchRow sth >>= (assertEqual "last row" Nothing) - ) - -createTable = dbTestCase (\dbh -> - do sRun dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] - commit dbh - ) - -dropTable = dbTestCase (\dbh -> - do sRun dbh "DROP TABLE hdbctest1" [] - commit dbh - ) - -runReplace = dbTestCase (\dbh -> - do sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1 - sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, 2, ?)" r2 - commit dbh - sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid" - sExecute sth [] - sFetchRow sth >>= (assertEqual "r1" (Just r1)) - sFetchRow sth >>= (assertEqual "r2" (Just [Just "runReplace", Just "2", - Just "2", Nothing])) - sFetchRow sth >>= (assertEqual "lastrow" Nothing) - ) - where r1 = [Just "runReplace", Just "1", Just "1234", Just "testdata"] - r2 = [Just "runReplace", Just "2", Nothing] - -executeReplace = dbTestCase (\dbh -> - do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)" - sExecute sth [Just "1", Just "1234", Just "Foo"] - sExecute sth [Just "2", Nothing, Just "Bar"] - commit dbh - sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" - sExecute sth [Just "executeReplace"] - sFetchRow sth >>= (assertEqual "r1" - (Just $ map Just ["executeReplace", "1", "1234", - "Foo"])) - sFetchRow sth >>= (assertEqual "r2" - (Just [Just "executeReplace", Just "2", Nothing, - Just "Bar"])) - sFetchRow sth >>= (assertEqual "lastrow" Nothing) - ) - -testExecuteMany = dbTestCase (\dbh -> - do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)" - sExecuteMany sth rows - commit dbh - sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'" - sExecute sth [] - mapM_ (\r -> sFetchRow sth >>= (assertEqual "" (Just r))) rows - sFetchRow sth >>= (assertEqual "lastrow" Nothing) - ) - where rows = [map Just ["1", "1234", "foo"], - map Just ["2", "1341", "bar"], - [Just "3", Nothing, Nothing]] - -testsFetchAllRows = dbTestCase (\dbh -> - do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)" - sExecuteMany sth rows - commit dbh - sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid" - sExecute sth [] - results <- sFetchAllRows sth - assertEqual "" rows results - ) - where rows = map (\x -> [Just . show $ x]) [1..9] - -basicTransactions = dbTestCase (\dbh -> - do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) - sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)" - sExecute sth [Just "0"] - commit dbh - qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid" - sExecute qrysth [] - sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]]) - - -- Now try a rollback - sExecuteMany sth rows - rollback dbh - sExecute qrysth [] - sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]]) - - -- Now try another commit - sExecuteMany sth rows - commit dbh - sExecute qrysth [] - sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows)) - ) - where rows = map (\x -> [Just . show $ x]) [1..9] - -testWithTransaction = dbTestCase (\dbh -> - do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) - sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)" - sExecute sth [Just "0"] - commit dbh - qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid" - sExecute qrysth [] - sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]]) - - -- Let's try a rollback. - catch (withTransaction dbh (\_ -> do sExecuteMany sth rows - fail "Foo")) - (\(_ :: SomeException) -> return ()) - sExecute qrysth [] - sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]]) - - -- And now a commit. - withTransaction dbh (\_ -> sExecuteMany sth rows) - sExecute qrysth [] - sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows)) - ) - where rows = map (\x -> [Just . show $ x]) [1..9] - -tests = TestList - [ - TestLabel "openClosedb" openClosedb, - TestLabel "singleFinish" singleFinish, - TestLabel "multiFinish" multiFinish, - TestLabel "basicQueries" basicQueries, - TestLabel "createTable" createTable, - TestLabel "runReplace" runReplace, - TestLabel "executeReplace" executeReplace, - TestLabel "executeMany" testExecuteMany, - TestLabel "sFetchAllRows" testsFetchAllRows, - TestLabel "basicTransactions" basicTransactions, - TestLabel "withTransaction" testWithTransaction, - TestLabel "dropTable" dropTable - ] +module TestSbasics(tests) where+import Test.HUnit+import Database.HDBC+import TestUtils+import System.IO+import Control.Exception++openClosedb = sqlTestCase $+ do dbh <- connectDB+ disconnect dbh++singleFinish = dbTestCase $ \dbh ->+ do sth <- prepare dbh "SELECT 1 + 1"+ sExecute sth []+ finish sth++multiFinish = dbTestCase (\dbh ->+ do sth <- prepare dbh "SELECT 1 + 1"+ sExecute sth []+ finish sth+ finish sth+ finish sth+ )++basicQueries = dbTestCase (\dbh ->+ do sth <- prepare dbh "SELECT 1 + 1"+ sExecute sth []+ sFetchRow sth >>= (assertEqual "row 1" (Just [Just "2"]))+ sFetchRow sth >>= (assertEqual "last row" Nothing)+ )++createTable = dbTestCase (\dbh ->+ do sRun dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" []+ commit dbh+ )++dropTable = dbTestCase (\dbh ->+ do sRun dbh "DROP TABLE hdbctest1" []+ commit dbh+ )++runReplace = dbTestCase (\dbh ->+ do sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1+ sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, 2, ?)" r2+ commit dbh+ sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid"+ sExecute sth []+ sFetchRow sth >>= (assertEqual "r1" (Just r1))+ sFetchRow sth >>= (assertEqual "r2" (Just [Just "runReplace", Just "2",+ Just "2", Nothing]))+ sFetchRow sth >>= (assertEqual "lastrow" Nothing)+ )+ where r1 = [Just "runReplace", Just "1", Just "1234", Just "testdata"]+ r2 = [Just "runReplace", Just "2", Nothing]++executeReplace = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)"+ sExecute sth [Just "1", Just "1234", Just "Foo"]+ sExecute sth [Just "2", Nothing, Just "Bar"]+ commit dbh+ sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid"+ sExecute sth [Just "executeReplace"]+ sFetchRow sth >>= (assertEqual "r1"+ (Just $ map Just ["executeReplace", "1", "1234",+ "Foo"]))+ sFetchRow sth >>= (assertEqual "r2"+ (Just [Just "executeReplace", Just "2", Nothing,+ Just "Bar"]))+ sFetchRow sth >>= (assertEqual "lastrow" Nothing)+ )++testExecuteMany = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)"+ sExecuteMany sth rows+ commit dbh+ sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'"+ sExecute sth []+ mapM_ (\r -> sFetchRow sth >>= (assertEqual "" (Just r))) rows+ sFetchRow sth >>= (assertEqual "lastrow" Nothing)+ )+ where rows = [map Just ["1", "1234", "foo"],+ map Just ["2", "1341", "bar"],+ [Just "3", Nothing, Nothing]]++testsFetchAllRows = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)"+ sExecuteMany sth rows+ commit dbh+ sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid"+ sExecute sth []+ results <- sFetchAllRows sth+ assertEqual "" rows results+ )+ where rows = map (\x -> [Just . show $ x]) [1..9]++basicTransactions = dbTestCase (\dbh ->+ do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)+ sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)"+ sExecute sth [Just "0"]+ commit dbh+ qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid"+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]])++ -- Now try a rollback+ sExecuteMany sth rows+ rollback dbh+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]])++ -- Now try another commit+ sExecuteMany sth rows+ commit dbh+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows))+ )+ where rows = map (\x -> [Just . show $ x]) [1..9]++testWithTransaction = dbTestCase (\dbh ->+ do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)+ sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)"+ sExecute sth [Just "0"]+ commit dbh+ qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid"+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]])++ -- Let's try a rollback.+ catch (withTransaction dbh (\_ -> do sExecuteMany sth rows+ fail "Foo"))+ (\(_ :: SomeException) -> return ())+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]])++ -- And now a commit.+ withTransaction dbh (\_ -> sExecuteMany sth rows)+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows))+ )+ where rows = map (\x -> [Just . show $ x]) [1..9]++tests = TestList+ [+ TestLabel "openClosedb" openClosedb,+ TestLabel "singleFinish" singleFinish,+ TestLabel "multiFinish" multiFinish,+ TestLabel "basicQueries" basicQueries,+ TestLabel "createTable" createTable,+ TestLabel "runReplace" runReplace,+ TestLabel "executeReplace" executeReplace,+ TestLabel "executeMany" testExecuteMany,+ TestLabel "sFetchAllRows" testsFetchAllRows,+ TestLabel "basicTransactions" basicTransactions,+ TestLabel "withTransaction" testWithTransaction,+ TestLabel "dropTable" dropTable+ ]
testsrc/TestTime.hs view
@@ -1,99 +1,99 @@-module TestTime(tests) where -import Test.HUnit -import Database.HDBC -import TestUtils -import Control.Exception -import Data.Time -import Data.Time.LocalTime -import Data.Time.Clock.POSIX -import Data.Maybe -import Data.Convertible -import SpecificDB -import System.Locale -import qualified System.Time as ST - -instance Eq ZonedTime where - a == b = zonedTimeToUTC a == zonedTimeToUTC b && - zonedTimeZone a == zonedTimeZone b - -testZonedTime :: ZonedTime -testZonedTime = fromJust $ parseTime defaultTimeLocale (iso8601DateFormat (Just "%T %z")) - "1989-08-01 15:33:01 -0500" - -testZonedTimeFrac :: ZonedTime -testZonedTimeFrac = fromJust $ parseTime defaultTimeLocale (iso8601DateFormat (Just "%T%Q %z")) - "1989-08-01 15:33:01.536 -0500" - - -rowdata t = [[SqlInt32 100, toSql t, SqlNull]] - -testDTType inputdata convToSqlValue = dbTestCase $ \dbh -> - do run dbh ("CREATE TABLE hdbctesttime (testid INTEGER PRIMARY KEY NOT NULL, \ - \testvalue " ++ dateTimeTypeOfSqlValue value ++ ")") [] - finally (testIt dbh) (do commit dbh - run dbh "DROP TABLE hdbctesttime" [] - commit dbh - ) - where testIt dbh = - do run dbh "INSERT INTO hdbctesttime (testid, testvalue) VALUES (?, ?)" - [iToSql 5, value] - commit dbh - r <- quickQuery' dbh "SELECT testid, testvalue FROM hdbctesttime" [] - case r of - [[testidsv, testvaluesv]] -> - do assertEqual "testid" (5::Int) (fromSql testidsv) - assertEqual "testvalue" inputdata (fromSql testvaluesv) - value = convToSqlValue inputdata - -mkTest label inputdata convfunc = - TestLabel label (testDTType inputdata convfunc) - -tests = TestList $ - ((TestLabel "Non-frac" $ testIt testZonedTime) : - if supportsFracTime then [TestLabel "Frac" $ testIt testZonedTimeFrac] else []) - -testIt baseZonedTime = - TestList [mkTest "Day" baseDay toSql, - mkTest "TimeOfDay" baseTimeOfDay toSql, - mkTest "ZonedTimeOfDay" baseZonedTimeOfDay toSql, - mkTest "LocalTime" baseLocalTime toSql, - mkTest "ZonedTime" baseZonedTime toSql, - mkTest "UTCTime" baseUTCTime toSql, - mkTest "DiffTime" baseDiffTime toSql, - mkTest "POSIXTime" basePOSIXTime posixToSql, - mkTest "ClockTime" baseClockTime toSql, - mkTest "CalendarTime" baseCalendarTime toSql, - mkTest "TimeDiff" baseTimeDiff toSql - ] - where - baseDay :: Day - baseDay = localDay baseLocalTime - - baseTimeOfDay :: TimeOfDay - baseTimeOfDay = localTimeOfDay baseLocalTime - - baseZonedTimeOfDay :: (TimeOfDay, TimeZone) - baseZonedTimeOfDay = fromSql (SqlZonedTime baseZonedTime) - - baseLocalTime :: LocalTime - baseLocalTime = zonedTimeToLocalTime baseZonedTime - - baseUTCTime :: UTCTime - baseUTCTime = convert baseZonedTime - - baseDiffTime :: NominalDiffTime - baseDiffTime = basePOSIXTime - - basePOSIXTime :: POSIXTime - basePOSIXTime = convert baseZonedTime - - baseTimeDiff :: ST.TimeDiff - baseTimeDiff = convert baseDiffTime - - -- No fractional parts for these two - - baseClockTime :: ST.ClockTime - baseClockTime = convert testZonedTime - - baseCalendarTime :: ST.CalendarTime - baseCalendarTime = convert testZonedTime +module TestTime(tests) where+import Test.HUnit+import Database.HDBC+import TestUtils+import Control.Exception+import Data.Time+import Data.Time.LocalTime+import Data.Time.Clock.POSIX+import Data.Maybe+import Data.Convertible+import SpecificDB+import System.Locale+import qualified System.Time as ST++instance Eq ZonedTime where+ a == b = zonedTimeToUTC a == zonedTimeToUTC b &&+ zonedTimeZone a == zonedTimeZone b++testZonedTime :: ZonedTime+testZonedTime = fromJust $ parseTime defaultTimeLocale (iso8601DateFormat (Just "%T %z"))+ "1989-08-01 15:33:01 -0500"++testZonedTimeFrac :: ZonedTime+testZonedTimeFrac = fromJust $ parseTime defaultTimeLocale (iso8601DateFormat (Just "%T%Q %z"))+ "1989-08-01 15:33:01.536 -0500"+++rowdata t = [[SqlInt32 100, toSql t, SqlNull]]++testDTType inputdata convToSqlValue = dbTestCase $ \dbh ->+ do run dbh ("CREATE TABLE hdbctesttime (testid INTEGER PRIMARY KEY NOT NULL, \+ \testvalue " ++ dateTimeTypeOfSqlValue value ++ ")") []+ finally (testIt dbh) (do commit dbh+ run dbh "DROP TABLE hdbctesttime" []+ commit dbh+ )+ where testIt dbh =+ do run dbh "INSERT INTO hdbctesttime (testid, testvalue) VALUES (?, ?)"+ [iToSql 5, value]+ commit dbh+ r <- quickQuery' dbh "SELECT testid, testvalue FROM hdbctesttime" []+ case r of+ [[testidsv, testvaluesv]] -> + do assertEqual "testid" (5::Int) (fromSql testidsv)+ assertEqual "testvalue" inputdata (fromSql testvaluesv)+ value = convToSqlValue inputdata++mkTest label inputdata convfunc =+ TestLabel label (testDTType inputdata convfunc)++tests = TestList $+ ((TestLabel "Non-frac" $ testIt testZonedTime) :+ if supportsFracTime then [TestLabel "Frac" $ testIt testZonedTimeFrac] else [])++testIt baseZonedTime = + TestList [mkTest "Day" baseDay toSql,+ mkTest "TimeOfDay" baseTimeOfDay toSql,+ mkTest "ZonedTimeOfDay" baseZonedTimeOfDay toSql,+ mkTest "LocalTime" baseLocalTime toSql,+ mkTest "ZonedTime" baseZonedTime toSql,+ mkTest "UTCTime" baseUTCTime toSql,+ mkTest "DiffTime" baseDiffTime toSql,+ mkTest "POSIXTime" basePOSIXTime posixToSql,+ mkTest "ClockTime" baseClockTime toSql,+ mkTest "CalendarTime" baseCalendarTime toSql,+ mkTest "TimeDiff" baseTimeDiff toSql+ ]+ where + baseDay :: Day+ baseDay = localDay baseLocalTime++ baseTimeOfDay :: TimeOfDay+ baseTimeOfDay = localTimeOfDay baseLocalTime++ baseZonedTimeOfDay :: (TimeOfDay, TimeZone)+ baseZonedTimeOfDay = fromSql (SqlZonedTime baseZonedTime)++ baseLocalTime :: LocalTime+ baseLocalTime = zonedTimeToLocalTime baseZonedTime++ baseUTCTime :: UTCTime+ baseUTCTime = convert baseZonedTime++ baseDiffTime :: NominalDiffTime+ baseDiffTime = basePOSIXTime++ basePOSIXTime :: POSIXTime+ basePOSIXTime = convert baseZonedTime++ baseTimeDiff :: ST.TimeDiff+ baseTimeDiff = convert baseDiffTime++ -- No fractional parts for these two++ baseClockTime :: ST.ClockTime+ baseClockTime = convert testZonedTime++ baseCalendarTime :: ST.CalendarTime+ baseCalendarTime = convert testZonedTime
testsrc/TestUtils.hs view
@@ -1,25 +1,25 @@-module TestUtils(connectDB, sqlTestCase, dbTestCase, printDBInfo) where -import Database.HDBC -import Test.HUnit -import Control.Exception -import SpecificDB(connectDB) - -sqlTestCase a = - TestCase (handleSqlError a) - -dbTestCase a = - TestCase (do dbh <- connectDB - finally (handleSqlError (a dbh)) - (handleSqlError (disconnect dbh)) - ) - -printDBInfo = handleSqlError $ - do dbh <- connectDB - putStrLn "+-------------------------------------------------------------------------" - putStrLn $ "| Testing HDBC database module: " ++ hdbcDriverName dbh ++ - ", bound to client: " ++ hdbcClientVer dbh - putStrLn $ "| Proxied driver: " ++ proxiedClientName dbh ++ - ", bound to version: " ++ proxiedClientVer dbh - putStrLn $ "| Connected to server version: " ++ dbServerVer dbh - putStrLn "+-------------------------------------------------------------------------\n" - disconnect dbh +module TestUtils(connectDB, sqlTestCase, dbTestCase, printDBInfo) where+import Database.HDBC+import Test.HUnit+import Control.Exception+import SpecificDB(connectDB)++sqlTestCase a = + TestCase (handleSqlError a)++dbTestCase a =+ TestCase (do dbh <- connectDB+ finally (handleSqlError (a dbh))+ (handleSqlError (disconnect dbh))+ )++printDBInfo = handleSqlError $+ do dbh <- connectDB+ putStrLn "+-------------------------------------------------------------------------"+ putStrLn $ "| Testing HDBC database module: " ++ hdbcDriverName dbh +++ ", bound to client: " ++ hdbcClientVer dbh+ putStrLn $ "| Proxied driver: " ++ proxiedClientName dbh +++ ", bound to version: " ++ proxiedClientVer dbh+ putStrLn $ "| Connected to server version: " ++ dbServerVer dbh+ putStrLn "+-------------------------------------------------------------------------\n"+ disconnect dbh
testsrc/Testbasics.hs view
@@ -1,168 +1,168 @@-module Testbasics(tests) where -import Test.HUnit -import Database.HDBC -import TestUtils -import System.IO -import Control.Exception - -openClosedb = sqlTestCase $ - do dbh <- connectDB - disconnect dbh - -multiFinish = dbTestCase (\dbh -> - do sth <- prepare dbh "SELECT 1 + 1" - r <- execute sth [] - assertEqual "basic count" 0 r - finish sth - finish sth - finish sth - ) - -basicQueries = dbTestCase (\dbh -> - do sth <- prepare dbh "SELECT 1 + 1" - execute sth [] >>= (0 @=?) - r <- fetchAllRows sth - assertEqual "converted from" [["2"]] (map (map fromSql) r) - assertEqual "int32 compare" [[SqlInt32 2]] r - assertEqual "iToSql compare" [[iToSql 2]] r - assertEqual "num compare" [[toSql (2::Int)]] r - assertEqual "nToSql compare" [[nToSql (2::Int)]] r - assertEqual "string compare" [[SqlString "2"]] r - ) - -createTable = dbTestCase (\dbh -> - do run dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] - commit dbh - ) - -dropTable = dbTestCase (\dbh -> - do run dbh "DROP TABLE hdbctest1" [] - commit dbh - ) - -runReplace = dbTestCase (\dbh -> - do r <- run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1 - assertEqual "insert retval" 1 r - run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r2 - commit dbh - sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid" - rv2 <- execute sth [] - assertEqual "select retval" 0 rv2 - r <- fetchAllRows sth - assertEqual "" [r1, r2] r - ) - where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"] - r2 = [toSql "runReplace", iToSql 2, iToSql 2, SqlNull] - -executeReplace = dbTestCase (\dbh -> - do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)" - execute sth [iToSql 1, iToSql 1234, toSql "Foo"] - execute sth [SqlInt32 2, SqlNull, toSql "Bar"] - commit dbh - sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" - execute sth [SqlString "executeReplace"] - r <- fetchAllRows sth - assertEqual "result" - [[toSql "executeReplace", iToSql 1, toSql "1234", - toSql "Foo"], - [toSql "executeReplace", iToSql 2, SqlNull, - toSql "Bar"]] - r - ) - -testExecuteMany = dbTestCase (\dbh -> - do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)" - executeMany sth rows - commit dbh - sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'" - execute sth [] - r <- fetchAllRows sth - assertEqual "" rows r - ) - where rows = [map toSql ["1", "1234", "foo"], - map toSql ["2", "1341", "bar"], - [toSql "3", SqlNull, SqlNull]] - -testFetchAllRows = dbTestCase (\dbh -> - do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)" - executeMany sth rows - commit dbh - sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid" - execute sth [] - results <- fetchAllRows sth - assertEqual "" rows results - ) - where rows = map (\x -> [iToSql x]) [1..9] - -testFetchAllRows' = dbTestCase (\dbh -> - do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows2', ?, NULL, NULL)" - executeMany sth rows - commit dbh - sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows2' ORDER BY testid" - execute sth [] - results <- fetchAllRows' sth - assertEqual "" rows results - ) - where rows = map (\x -> [iToSql x]) [1..9] - -basicTransactions = dbTestCase (\dbh -> - do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) - sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)" - execute sth [iToSql 0] - commit dbh - qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid" - execute qrysth [] - fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]]) - - -- Now try a rollback - executeMany sth rows - rollback dbh - execute qrysth [] - fetchAllRows qrysth >>= (assertEqual "rollback" [[toSql "0"]]) - - -- Now try another commit - executeMany sth rows - commit dbh - execute qrysth [] - fetchAllRows qrysth >>= (assertEqual "final commit" ([SqlString "0"]:rows)) - ) - where rows = map (\x -> [iToSql $ x]) [1..9] - -testWithTransaction = dbTestCase (\dbh -> - do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh) - sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)" - execute sth [toSql "0"] - commit dbh - qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid" - execute qrysth [] - fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]]) - - -- Let's try a rollback. - catch (withTransaction dbh (\_ -> do executeMany sth rows - fail "Foo")) - (\(_ :: SomeException) -> return ()) - execute qrysth [] - fetchAllRows qrysth >>= (assertEqual "rollback" [[SqlString "0"]]) - - -- And now a commit. - withTransaction dbh (\_ -> executeMany sth rows) - execute qrysth [] - fetchAllRows qrysth >>= (assertEqual "final commit" ([iToSql 0]:rows)) - ) - where rows = map (\x -> [iToSql x]) [1..9] - -tests = TestList - [ - TestLabel "openClosedb" openClosedb, - TestLabel "multiFinish" multiFinish, - TestLabel "basicQueries" basicQueries, - TestLabel "createTable" createTable, - TestLabel "runReplace" runReplace, - TestLabel "executeReplace" executeReplace, - TestLabel "executeMany" testExecuteMany, - TestLabel "fetchAllRows" testFetchAllRows, - TestLabel "fetchAllRows'" testFetchAllRows', - TestLabel "basicTransactions" basicTransactions, - TestLabel "withTransaction" testWithTransaction, - TestLabel "dropTable" dropTable - ] +module Testbasics(tests) where+import Test.HUnit+import Database.HDBC+import TestUtils+import System.IO+import Control.Exception++openClosedb = sqlTestCase $+ do dbh <- connectDB+ disconnect dbh++multiFinish = dbTestCase (\dbh ->+ do sth <- prepare dbh "SELECT 1 + 1"+ r <- execute sth []+ assertEqual "basic count" 0 r+ finish sth+ finish sth+ finish sth+ )++basicQueries = dbTestCase (\dbh ->+ do sth <- prepare dbh "SELECT 1 + 1"+ execute sth [] >>= (0 @=?)+ r <- fetchAllRows sth+ assertEqual "converted from" [["2"]] (map (map fromSql) r)+ assertEqual "int32 compare" [[SqlInt32 2]] r+ assertEqual "iToSql compare" [[iToSql 2]] r+ assertEqual "num compare" [[toSql (2::Int)]] r+ assertEqual "nToSql compare" [[nToSql (2::Int)]] r+ assertEqual "string compare" [[SqlString "2"]] r+ )++createTable = dbTestCase (\dbh ->+ do run dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" []+ commit dbh+ )++dropTable = dbTestCase (\dbh ->+ do run dbh "DROP TABLE hdbctest1" []+ commit dbh+ )++runReplace = dbTestCase (\dbh ->+ do r <- run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1+ assertEqual "insert retval" 1 r+ run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r2+ commit dbh+ sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid"+ rv2 <- execute sth []+ assertEqual "select retval" 0 rv2+ r <- fetchAllRows sth+ assertEqual "" [r1, r2] r+ )+ where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"]+ r2 = [toSql "runReplace", iToSql 2, iToSql 2, SqlNull]++executeReplace = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)"+ execute sth [iToSql 1, iToSql 1234, toSql "Foo"]+ execute sth [SqlInt32 2, SqlNull, toSql "Bar"]+ commit dbh+ sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid"+ execute sth [SqlString "executeReplace"]+ r <- fetchAllRows sth+ assertEqual "result"+ [[toSql "executeReplace", iToSql 1, toSql "1234",+ toSql "Foo"],+ [toSql "executeReplace", iToSql 2, SqlNull,+ toSql "Bar"]]+ r+ )++testExecuteMany = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)"+ executeMany sth rows+ commit dbh+ sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'"+ execute sth []+ r <- fetchAllRows sth+ assertEqual "" rows r+ )+ where rows = [map toSql ["1", "1234", "foo"],+ map toSql ["2", "1341", "bar"],+ [toSql "3", SqlNull, SqlNull]]++testFetchAllRows = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)"+ executeMany sth rows+ commit dbh+ sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid"+ execute sth []+ results <- fetchAllRows sth+ assertEqual "" rows results+ )+ where rows = map (\x -> [iToSql x]) [1..9]++testFetchAllRows' = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows2', ?, NULL, NULL)"+ executeMany sth rows+ commit dbh+ sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows2' ORDER BY testid"+ execute sth []+ results <- fetchAllRows' sth+ assertEqual "" rows results+ )+ where rows = map (\x -> [iToSql x]) [1..9]++basicTransactions = dbTestCase (\dbh ->+ do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)+ sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)"+ execute sth [iToSql 0]+ commit dbh+ qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid"+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]])++ -- Now try a rollback+ executeMany sth rows+ rollback dbh+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "rollback" [[toSql "0"]])++ -- Now try another commit+ executeMany sth rows+ commit dbh+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "final commit" ([SqlString "0"]:rows))+ )+ where rows = map (\x -> [iToSql $ x]) [1..9]++testWithTransaction = dbTestCase (\dbh ->+ do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)+ sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)"+ execute sth [toSql "0"]+ commit dbh+ qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid"+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]])++ -- Let's try a rollback.+ catch (withTransaction dbh (\_ -> do executeMany sth rows+ fail "Foo"))+ (\(_ :: SomeException) -> return ())+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "rollback" [[SqlString "0"]])++ -- And now a commit.+ withTransaction dbh (\_ -> executeMany sth rows)+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "final commit" ([iToSql 0]:rows))+ )+ where rows = map (\x -> [iToSql x]) [1..9]++tests = TestList+ [+ TestLabel "openClosedb" openClosedb,+ TestLabel "multiFinish" multiFinish,+ TestLabel "basicQueries" basicQueries,+ TestLabel "createTable" createTable,+ TestLabel "runReplace" runReplace,+ TestLabel "executeReplace" executeReplace,+ TestLabel "executeMany" testExecuteMany,+ TestLabel "fetchAllRows" testFetchAllRows,+ TestLabel "fetchAllRows'" testFetchAllRows',+ TestLabel "basicTransactions" basicTransactions,+ TestLabel "withTransaction" testWithTransaction,+ TestLabel "dropTable" dropTable+ ]
testsrc/Tests.hs view
@@ -1,17 +1,17 @@-{- arch-tag: Tests main file --} - -module Tests(tests) where -import Test.HUnit -import qualified Testbasics -import qualified TestSbasics -import qualified SpecificDBTests -import qualified TestMisc -import qualified TestTime - -tests = TestList [TestLabel "String basics" TestSbasics.tests, - TestLabel "SqlValue basics" Testbasics.tests, - TestLabel "SpecificDB" SpecificDBTests.tests, - TestLabel "Misc tests" TestMisc.tests, - TestLabel "Time tests" TestTime.tests - ] +{- arch-tag: Tests main file+-}++module Tests(tests) where+import Test.HUnit+import qualified Testbasics+import qualified TestSbasics+import qualified SpecificDBTests+import qualified TestMisc+import qualified TestTime++tests = TestList [TestLabel "String basics" TestSbasics.tests,+ TestLabel "SqlValue basics" Testbasics.tests,+ TestLabel "SpecificDB" SpecificDBTests.tests,+ TestLabel "Misc tests" TestMisc.tests,+ TestLabel "Time tests" TestTime.tests+ ]
testsrc/runtests.hs view
@@ -1,12 +1,12 @@-{- arch-tag: Test runner --} - -module Main where - -import Test.HUnit -import Tests -import TestUtils - -main = do printDBInfo - runTestTT tests - +{- arch-tag: Test runner+-}++module Main where ++import Test.HUnit+import Tests+import TestUtils++main = do printDBInfo+ runTestTT tests+