HDBC-odbc 2.3.1.1 → 2.6.0.0
raw patch · 23 files changed
Files
- Database/HDBC/ODBC.hs +2/−2
- Database/HDBC/ODBC/Api/Errors.hs +81/−0
- Database/HDBC/ODBC/Api/Imports.hsc +177/−0
- Database/HDBC/ODBC/Api/Types.hsc +37/−0
- Database/HDBC/ODBC/Connection.hsc +55/−75
- Database/HDBC/ODBC/ConnectionImpl.hs +8/−2
- Database/HDBC/ODBC/Log.hs +15/−0
- Database/HDBC/ODBC/Statement.hsc +451/−384
- Database/HDBC/ODBC/TypeConv.hsc +2/−19
- Database/HDBC/ODBC/Types.hs +0/−24
- Database/HDBC/ODBC/Utils.hs +16/−0
- Database/HDBC/ODBC/Utils.hsc +0/−127
- Database/HDBC/ODBC/Wrappers.hs +188/−0
- HDBC-odbc.cabal +106/−81
- README.md +10/−4
- cbits/hdbc-odbc-helper.c +23/−0
- cbits/hdbc-odbc-helper.h +20/−0
- changelog.txt +35/−0
- hdbc-odbc-helper.c +0/−137
- hdbc-odbc-helper.h +0/−35
- stresstest/stresstest.hs +55/−0
- testsrc/TestSbasics.hs +8/−8
- testsrc/Testbasics.hs +7/−7
Database/HDBC/ODBC.hs view
@@ -14,10 +14,10 @@ module Database.HDBC.ODBC (- connectODBC, Connection(), getQueryInfo+ connectODBC, Connection(), getQueryInfo, setAutoCommit ) where import Database.HDBC.ODBC.Connection(connectODBC, Connection())-import Database.HDBC.ODBC.ConnectionImpl(getQueryInfo)+import Database.HDBC.ODBC.ConnectionImpl(getQueryInfo, setAutoCommit)
+ Database/HDBC/ODBC/Api/Errors.hs view
@@ -0,0 +1,81 @@+{-# 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++-- ODBC uses Windows unicode convention (i.e. UCS-2 encoding and+-- 2-byte wchar_t), and is incompatible with Unix wchar_t. See+-- https://www.easysoft.com/developer/interfaces/odbc/linux.html#unicode_unixodbc+-- for more information.+#ifdef mingw32_HOST_OS+getDiag :: SQLSMALLINT -> SQLHANDLE -> SQLSMALLINT -> IO [(String, String)]+getDiag ht hp irow =+ allocaBytes (6 * sizeOf (undefined :: CWchar)) $ \csstate ->+ alloca $ \pnaterr ->+ allocaBytes (1024 * sizeOf (undefined :: CWchar)) $ \csmsg ->+ alloca $ \pmsglen -> do+ ret <- c_sqlGetDiagRecW ht hp irow csstate pnaterr csmsg 1024 pmsglen+ if sqlSucceeded ret+ then do+ state <- peekCWString csstate+ nat <- peek pnaterr+ msglen <- peek pmsglen+ msgstr <- peekCWString csmsg+ next <- getDiag ht hp (irow + 1)+ return $ (state, show nat ++ ": " ++ msgstr) : next+ else+ return []+#else+getDiag :: SQLSMALLINT -> SQLHANDLE -> SQLSMALLINT -> IO [(String, String)]+getDiag ht hp irow =+ allocaBytes 6 $ \csstate ->+ alloca $ \pnaterr ->+ allocaBytes 1024 $ \csmsg ->+ alloca $ \pmsglen -> do+ ret <- c_sqlGetDiagRec ht hp irow csstate pnaterr csmsg 1024 pmsglen+ if sqlSucceeded ret+ then do+ state <- peekCString csstate+ nat <- peek pnaterr+ msglen <- peek pmsglen+ msgstr <- peekCString csmsg+ next <- getDiag ht hp (irow + 1)+ return $ (state, show nat ++ ": " ++ msgstr) : next+ else+ return []+#endif
+ Database/HDBC/ODBC/Api/Imports.hsc view
@@ -0,0 +1,177 @@+{-# 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+#ifdef mingw32_HOST_OS+ , c_sqlGetDiagRecW+#else+ , c_sqlGetDiagRec+#endif+ , 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 :: SQLHDBC -> IO SQLRETURN+c_sqlDisconnect hDbc = do+ result <- imp_sqlDisconnect hDbc+ hdbcTrace $ printf "SQLDisconnect(%s) returned %d" (show hDbc) result+ return result++#ifdef mingw32_HOST_OS+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 "SqlGetDiagRecW(%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+#else+foreign import #{CALLCONV} safe "sql.h SQLGetDiagRec"+ imp_sqlGetDiagRec :: SQLSMALLINT -> Ptr () -> SQLSMALLINT -> CString+ -> Ptr SQLINTEGER -> CString -> SQLSMALLINT+ -> Ptr SQLSMALLINT -> IO SQLRETURN++c_sqlGetDiagRec :: SQLSMALLINT -> Ptr () -> SQLSMALLINT -> CString -> Ptr SQLINTEGER+ -> CString -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN+c_sqlGetDiagRec handleType handle recNumber sqlState nativeErrorPtr messageText bufferLength textLengthPtr = do+ result <- imp_sqlGetDiagRec 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+#endif++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
@@ -0,0 +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 ()
Database/HDBC/ODBC/Connection.hsc view
@@ -5,22 +5,21 @@ 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.Types+import Database.HDBC.ODBC.Api.Imports+import Database.HDBC.ODBC.Api.Errors+import Database.HDBC.ODBC.Api.Types import Database.HDBC.ODBC.Statement-import Foreign.C.Types+import Database.HDBC.ODBC.Wrappers import Foreign.C.String-import Foreign.Marshal+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)+import Control.Monad (when, void) import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BUTF8 @@ -50,7 +49,7 @@ 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 +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:@@ -71,44 +70,31 @@ -} connectODBC :: String -> IO Impl.Connection-connectODBC args = B.useAsCStringLen (BUTF8.fromString args) $ \(cs, cslen) -> - alloca $ \(penvptr::Ptr (Ptr CEnv)) ->- alloca $ \(pdbcptr::Ptr (Ptr CConn)) ->- do -- Create the Environment Handle- rc1 <- sqlAllocHandle #{const SQL_HANDLE_ENV}- nullPtr -- {const SQL_NULL_HANDLE}- (castPtr penvptr)- envptr <- peek penvptr -- checkError "connectODBC/alloc env" (EnvHandle envptr) rc1- sqlSetEnvAttr envptr #{const SQL_ATTR_ODBC_VERSION}- (getSqlOvOdbc3) 0+connectODBC args =+ B.useAsCStringLen (BUTF8.fromString args) $ \(cs, cslen) -> do+ -- Create the Environment Handle+ env <- sqlAllocEnv+ withEnvOrDie env $ \hEnv ->+ void $ sqlSetEnvAttr hEnv #{const SQL_ATTR_ODBC_VERSION} (getSqlOvOdbc3) 0 - -- Create the DBC handle.- sqlAllocHandle #{const SQL_HANDLE_DBC} (castPtr envptr) - (castPtr pdbcptr)- >>= checkError "connectODBC/alloc dbc"- (EnvHandle envptr)- dbcptr <- peek pdbcptr- wrappeddbcptr <- wrapconn dbcptr envptr nullPtr- fdbcptr <- newForeignPtr sqlFreeHandleDbc_ptr wrappeddbcptr+ -- 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) - -- Now connect.- sqlDriverConnect dbcptr nullPtr cs (fromIntegral cslen)- nullPtr 0 nullPtr- #{const SQL_DRIVER_NOPROMPT}- >>= checkError "connectODBC/sqlDriverConnect" - (DbcHandle dbcptr)- mkConn args fdbcptr+ mkConn args dbc -- FIXME: environment vars may have changed, should use pgsql enquiries -- for clone.-mkConn :: String -> Conn -> IO Impl.Connection-mkConn args iconn = withConn iconn $ \cconn -> +mkConn :: String -> DbcWrapper -> IO Impl.Connection+mkConn args iconn = withDbcOrDie iconn $ \cconn -> alloca $ \plen -> alloca $ \psqlusmallint ->- allocaBytes 128 $ \pbuf -> - do + allocaBytes 128 $ \pbuf ->+ do children <- newMVar [] sqlGetInfo cconn #{const SQL_DBMS_VER} (castPtr pbuf) 127 plen >>= checkError "sqlGetInfo SQL_DBMS_VER" (DbcHandle cconn)@@ -136,10 +122,7 @@ txninfo <- ((peek psqlusmallint)::IO (#{type SQLUSMALLINT})) let txnsupport = txninfo /= #{const SQL_TC_NONE} - when txnsupport- (disableAutoCommit cconn- >>= checkError "sqlSetConnectAttr" (DbcHandle cconn)- )+ when txnsupport . void $ fSetAutoCommit cconn False return $ Impl.Connection { Impl.getQueryInfo = fGetQueryInfo iconn children, Impl.disconnect = fdisconnect iconn children,@@ -156,53 +139,58 @@ Impl.dbServerVer = serverver, Impl.dbTransactionSupport = txnsupport, Impl.getTables = fgettables iconn,- Impl.describeTable = fdescribetable iconn+ Impl.describeTable = fdescribetable iconn,+ Impl.setAutoCommit = \x -> withDbcOrDie iconn $ \conn -> fSetAutoCommit conn x } -------------------------------------------------- -- Guts here -------------------------------------------------- +frun :: DbcWrapper -> ChildList -> String -> [SqlValue] -> IO Integer frun conn children query args = do sth <- newSth conn children query res <- execute sth args finish sth return res -fcommit iconn = withConn iconn $ \cconn ->+fcommit :: DbcWrapper -> IO ()+fcommit iconn = withDbcOrDie iconn $ \cconn -> sqlEndTran #{const SQL_HANDLE_DBC} cconn #{const SQL_COMMIT} >>= checkError "sqlEndTran commit" (DbcHandle cconn) -frollback iconn = withConn iconn $ \cconn ->+frollback :: DbcWrapper -> IO ()+frollback iconn = withDbcOrDie iconn $ \cconn -> sqlEndTran #{const SQL_HANDLE_DBC} cconn #{const SQL_ROLLBACK} >>= checkError "sqlEndTran rollback" (DbcHandle cconn) -fdisconnect iconn mchildren = withRawConn iconn $ \rawconn -> - withConn iconn $ \llconn ->- do closeAllChildren mchildren- res <- sqlFreeHandleDbc_app rawconn- -- FIXME: will this checkError segfault?- checkError "disconnect" (DbcHandle $ llconn) res--foreign import #{CALLCONV} safe "sql.h SQLAllocHandle"- sqlAllocHandle :: #{type SQLSMALLINT} -> Ptr () -> - Ptr () -> IO (#{type SQLRETURN})--foreign import ccall safe "hdbc-odbc-helper.h wrapobjodbc_extra"- wrapconn :: Ptr CConn -> Ptr CEnv -> Ptr WrappedCConn -> IO (Ptr WrappedCConn)+fdisconnect :: DbcWrapper -> ChildList -> IO ()+fdisconnect iconn mchildren = do+ closeAllChildren mchildren+ freeDbcIfNotAlready True iconn -foreign import ccall safe "hdbc-odbc-helper.h &sqlFreeHandleDbc_finalizer"- sqlFreeHandleDbc_ptr :: FunPtr (Ptr WrappedCConn -> IO ())+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 -foreign import ccall safe "hdbc-odbc-helper.h sqlFreeHandleDbc_app"- sqlFreeHandleDbc_app :: Ptr WrappedCConn -> IO (#{type SQLRETURN})+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 :: Ptr CEnv -> #{type SQLINTEGER} -> + sqlSetEnvAttr :: SQLHENV -> #{type SQLINTEGER} -> Ptr () -> #{type SQLINTEGER} -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLDriverConnect"- sqlDriverConnect :: Ptr CConn -> Ptr () -> CString -> #{type SQLSMALLINT}+ sqlDriverConnect :: SQLHDBC -> Ptr () -> CString -> #{type SQLSMALLINT} -> CString -> #{type SQLSMALLINT} -> Ptr #{type SQLSMALLINT} -> #{type SQLUSMALLINT} -> IO #{type SQLRETURN}@@ -210,19 +198,11 @@ foreign import ccall safe "hdbc-odbc-helper.h getSqlOvOdbc3" getSqlOvOdbc3 :: Ptr () -foreign import ccall safe "hdbc-odbc-helper.h SQLSetConnectAttr"- sqlSetConnectAttr :: Ptr CConn -> #{type SQLINTEGER} - -> Ptr #{type SQLUINTEGER} -> #{type SQLINTEGER}- -> IO #{type SQLRETURN}- foreign import #{CALLCONV} safe "sql.h SQLEndTran"- sqlEndTran :: #{type SQLSMALLINT} -> Ptr CConn -> #{type SQLSMALLINT}+ sqlEndTran :: #{type SQLSMALLINT} -> SQLHDBC -> #{type SQLSMALLINT} -> IO #{type SQLRETURN} -foreign import ccall safe "hdbc-odbc-helper.h disableAutoCommit"- disableAutoCommit :: Ptr CConn -> IO #{type SQLRETURN}- foreign import #{CALLCONV} safe "sql.h SQLGetInfo"- sqlGetInfo :: Ptr CConn -> #{type SQLUSMALLINT} -> Ptr () ->+ sqlGetInfo :: SQLHDBC -> #{type SQLUSMALLINT} -> Ptr () -> #{type SQLSMALLINT} -> Ptr #{type SQLSMALLINT} -> IO #{type SQLRETURN}
Database/HDBC/ODBC/ConnectionImpl.hs view
@@ -3,8 +3,9 @@ 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 = +data Connection = Connection { getQueryInfo :: String -> IO ([SqlColDesc], [(String, SqlColDesc)]), disconnect :: IO (),@@ -20,7 +21,9 @@ dbServerVer :: String, dbTransactionSupport :: Bool, getTables :: IO [String],- describeTable :: String -> IO [(String, ColTypes.SqlColDesc)]+ 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@@ -28,6 +31,9 @@ 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
+ Database/HDBC/ODBC/Log.hs view
@@ -0,0 +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)
Database/HDBC/ODBC/Statement.hsc view
@@ -13,17 +13,18 @@ import Database.HDBC.Types import Database.HDBC import Database.HDBC.DriverUtils-import Database.HDBC.ODBC.Types-import Database.HDBC.ODBC.Utils+import Database.HDBC.ODBC.Api.Errors+import Database.HDBC.ODBC.Api.Imports+import Database.HDBC.ODBC.Api.Types+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.Concurrent.MVar import Foreign.C.String-import Foreign.Marshal+import Foreign.Marshal hiding (void) import Foreign.Storable import Control.Monad import Data.Word@@ -34,14 +35,8 @@ 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--l :: String -> IO ()-l _ = return ()--- l m = hPutStrLn stderr ("\n" ++ m)+import qualified Data.Foldable as F #ifdef mingw32_HOST_OS #include <windows.h>@@ -55,182 +50,164 @@ #let CALLCONV = "ccall" #endif -fGetQueryInfo :: Conn -> ChildList -> String+fGetQueryInfo :: DbcWrapper -> ChildList -> String -> IO ([SqlColDesc], [(String, SqlColDesc)]) fGetQueryInfo iconn children query =- do l "in fGetQueryInfo"+ 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 = withConn (dbo sstate) $ \cconn ->- withCStringLen (squery sstate) $ \(cquery, cqlen) ->- alloca $ \(psthptr::Ptr (Ptr CStmt)) ->- do l "in fexecute"- -- public_ffinish sstate - rc1 <- sqlAllocStmtHandle #{const SQL_HANDLE_STMT} cconn psthptr- sthptr <- peek psthptr- wrappedsthptr <- withRawConn (dbo sstate)- (\rawconn -> wrapstmt sthptr rawconn)- fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr- checkError "execute allocHandle" (DbcHandle cconn) rc1+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) - sqlPrepare sthptr cquery (fromIntegral cqlen) >>= - checkError "execute prepare" (StmtHandle sthptr)+ -- parmCount <- getNumParams sthptr+ parmInfo <- fgetparminfo hStmt - -- parmCount <- getNumParams sthptr- parmInfo <- fgetparminfo sthptr- - -- rc <- getNumResultCols sthptr- colInfo <- fgetcolinfo sthptr- return (parmInfo, colInfo)+ -- rc <- getNumResultCols sthptr+ colInfo <- fgetcolinfo hStmt+ return (parmInfo, colInfo) -- | The Stament State data SState = SState- { stomv :: MVar (Maybe Stmt)- , dbo :: Conn- , squery :: String- , colinfomv :: MVar [(String, SqlColDesc)]- , bindColsMV :: MVar (Maybe [(BindCol, Ptr #{type SQLLEN})])+ { 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 :: Conn -> String -> IO SState-newSState indbo query =- do newstomv <- newMVar Nothing- newcolinfomv <- newMVar []- newBindCols <- newMVar Nothing- return SState- { stomv = newstomv- , dbo = indbo- , squery = query- , colinfomv = newcolinfomv- , bindColsMV = newBindCols- }+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 ()+ , executeRaw = fexecuteraw sstate , executeMany = fexecutemany sstate- , finish = public_ffinish sstate+ , finish = ffinish sstate , fetchRow = ffetchrow sstate , originalQuery = (squery sstate) , getColumnNames = readMVar (colinfomv sstate) >>= (return . map fst) , describeResult = readMVar (colinfomv sstate) } -newSth :: Conn -> ChildList -> String -> IO Statement+newSth :: DbcWrapper -> ChildList -> String -> IO Statement newSth indbo mchildren query =- do l "in newSth"+ do hdbcTrace "in newSth" sstate <- newSState indbo query let retval = wrapStmt sstate addChild mchildren retval return retval -makesth :: Conn -> [Char] -> IO (ForeignPtr WrappedCStmt)-makesth iconn name = alloca $ \(psthptr::Ptr (Ptr CStmt)) ->- withConn iconn $ \cconn -> - withCString "" $ \emptycs ->- do rc1 <- sqlAllocStmtHandle #{const SQL_HANDLE_STMT} cconn psthptr- sthptr <- peek psthptr- wrappedsthptr <- withRawConn iconn- (\rawconn -> wrapstmt sthptr rawconn)- fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr- checkError (name ++ " allocHandle") (DbcHandle cconn) rc1- return fsthptr--wrapTheStmt :: Conn -> Stmt -> IO (Statement, SState)-wrapTheStmt iconn fsthptr =- do sstate <- newSState iconn ""- sstate <- newSState iconn ""- swapMVar (stomv sstate) (Just fsthptr)- let sth = wrapStmt sstate- return (sth, sstate)--fgettables :: Conn -> IO [String]-fgettables iconn =- do fsthptr <- makesth iconn "fgettables"- l "fgettables: after makesth"- withStmt fsthptr (\sthptr ->- simpleSqlTables sthptr >>=- checkError "gettables simpleSqlTables" - (StmtHandle sthptr)- )- l "fgettables: after withStmt"- (sth, sstate) <- wrapTheStmt iconn fsthptr- withStmt fsthptr (\sthptr -> fgetcolinfo sthptr >>= swapMVar (colinfomv sstate))- l "fgettables: after wrapTheStmt"- results <- fetchAllRows' sth- l ("fgettables: results: " ++ (show results))- return $ map (\x -> fromSql (x !! 2)) results+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 >>= void . swapMVar (colinfomv sstate)+ results <- fetchAllRows' $ wrapStmt sstate+ return $ map (\x -> fromSql (x !! 2)) results -fdescribetable :: Conn -> String -> IO [(String, SqlColDesc)]-fdescribetable iconn tablename = B.useAsCStringLen (BUTF8.fromString tablename) $ - \(cs, csl) ->- do fsthptr <- makesth iconn "fdescribetable"- withStmt fsthptr (\sthptr ->- simpleSqlColumns sthptr cs (fromIntegral csl) >>=- checkError "fdescribetable simpleSqlColumns"- (StmtHandle sthptr)- )- (sth, sstate) <- wrapTheStmt iconn fsthptr- withStmt fsthptr (\sthptr -> fgetcolinfo sthptr >>= swapMVar (colinfomv sstate))- results <- fetchAllRows' sth- l (show results)- return $ map fromOTypeCol 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 >>= void . 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 =- withConn (dbo sstate) $ \cconn ->- B.useAsCStringLen (BUTF8.fromString (squery sstate)) $ \(cquery, cqlen) ->- alloca $ \(psthptr::Ptr (Ptr CStmt)) ->- do l $ "in fexecute: " ++ show (squery sstate) ++ show args- public_ffinish sstate- rc1 <- sqlAllocStmtHandle #{const SQL_HANDLE_STMT} cconn psthptr- sthptr <- peek psthptr- wrappedsthptr <- withRawConn (dbo sstate)- (\rawconn -> wrapstmt sthptr rawconn)- fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr- checkError "execute allocHandle" (DbcHandle cconn) rc1+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. - sqlPrepare sthptr cquery (fromIntegral cqlen) >>= - checkError "execute prepare" (StmtHandle sthptr)+ 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) - bindArgs <- zipWithM (bindParam sthptr) args [1..]- l $ "Ready for sqlExecute: " ++ show (squery sstate) ++ show args- r <- sqlExecute sthptr- 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 - case r of- #{const SQL_NO_DATA} -> return () -- Update that did nothing- x -> checkError "execute execute" (StmtHandle sthptr) x+ rc <- getNumResultCols hStmt - rc <- getNumResultCols sthptr+ case rc of+ 0 -> do rowcount <- getSqlRowCount hStmt+ return (True, fromIntegral rowcount)+ _ -> do fgetcolinfo hStmt >>= void . swapMVar (colinfomv sstate)+ return (False, 0)+ when finish $ ffinish sstate+ return result - case rc of- 0 -> do rowcount <- getSqlRowCount sthptr- ffinish fsthptr- swapMVar (colinfomv sstate) []- touchForeignPtr fsthptr- return (fromIntegral rowcount)- colcount -> do fgetcolinfo sthptr >>= swapMVar (colinfomv sstate)- swapMVar (stomv sstate) (Just fsthptr)- touchForeignPtr fsthptr- return 0+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. -getNumResultCols :: Ptr CStmt -> IO #{type SQLSMALLINT}+ 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" + do sqlNumResultCols sthptr pcount >>= checkError "SQLNumResultCols" (StmtHandle sthptr) peek pcount -- Bind a parameter column before execution.-bindParam :: Ptr CStmt -> SqlValue -> Word16+bindParam :: SQLHSTMT -> SqlValue -> Word16 -> IO (Maybe (Ptr #{type SQLLEN}, Ptr CChar)) bindParam sthptr arg icol = alloca $ \pdtype -> alloca $ \pcolsize ->@@ -246,93 +223,163 @@ So, make sure we either free of have foreignized everything before control passes out of this function. -} - do l $ "Binding col " ++ show icol ++ ": " ++ show arg+ do hdbcTrace $ "Binding col " ++ show icol ++ ": " ++ show arg rc1 <- sqlDescribeParam sthptr icol pdtype pcolsize pdecdigits pnullable- l $ "rc1 is " ++ show (isOK rc1)- when (not (isOK rc1)) $ -- Some drivers don't support that call- do poke pdtype #{const SQL_CHAR}- poke pcolsize 0- poke pdecdigits 0- coltype <- peek pdtype- colsize <- peek pcolsize- decdigits <- peek pdecdigits- l $ "Results: " ++ show (coltype, colsize, decdigits)+ 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 l "Binding null"+ do hdbcTrace "Binding null" rc2 <- sqlBindParameter sthptr (fromIntegral icol) #{const SQL_PARAM_INPUT}- #{const SQL_C_CHAR} coltype colsize decdigits+ #{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...- (csptr, cslen) <- cstrUtf8BString (fromSql x)- do pcslen <- malloc - poke pcslen (fromIntegral cslen)+ boundValue <- bindSqlValue x+ do pcslen <- malloc+ poke pcslen . fromIntegral $ bvBufferSize boundValue rc2 <- sqlBindParameter sthptr (fromIntegral icol) #{const SQL_PARAM_INPUT}- #{const SQL_C_CHAR} coltype - (if isOK rc1 then colsize else fromIntegral cslen + 1) decdigits- csptr (fromIntegral cslen + 1) pcslen- if isOK rc2+ (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, csptr)+ return $ Just (pcslen, castPtr $ bvBuffer boundValue) else do -- Binding failed. Free the data and raise -- error. free pcslen- free csptr- checkError ("bindparameter " ++ show icol) + free (bvBuffer boundValue)+ checkError ("bindparameter " ++ show icol) (StmtHandle sthptr) rc2 return Nothing -- will never get hit -getSqlRowCount :: Ptr CStmt -> IO Int32+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) -cstrUtf8BString :: B.ByteString -> IO CStringLen-cstrUtf8BString bs = do- B.unsafeUseAsCStringLen bs $ \(s,len) -> do- res <- mallocBytes (len+1)- -- copy in- copyBytes res s len- -- null terminate- poke (plusPtr res len) (0::CChar)- -- return ptr- return (res, len)+-- | 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 = modifyMVar (stomv sstate) $ \stmt -> do- l $ "ffetchrow"- case stmt of+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- l "ffetchrow: no statement"- return (stmt, Nothing)- Just cmstmt -> withStmt cmstmt $ \cstmt -> do- bindCols <- getBindCols sstate cstmt- l "ffetchrow: fetching"- rc <- sqlFetch cstmt- if rc == #{const SQL_NO_DATA}- then do- l "ffetchrow: no more rows"- ffinish cmstmt- return (Nothing, Nothing)- else do- l "ffetchrow: fetching data"- checkError "sqlFetch" (StmtHandle cstmt) rc- sqlValues <- if rc == #{const SQL_SUCCESS} || rc == #{const SQL_SUCCESS_WITH_INFO}- then mapM (bindColToSqlValue cstmt) bindCols- else raiseError "sqlGetData" rc (StmtHandle cstmt)- return (stmt, Just sqlValues)+ ffinish sstate+ return Nothing -getBindCols :: SState -> Ptr CStmt -> IO [(BindCol, Ptr #{type SQLLEN})]+getBindCols :: SState -> SQLHSTMT -> IO [(BindCol, Ptr #{type SQLLEN})] getBindCols sstate cstmt = do- l "getBindCols"+ hdbcTrace "getBindCols" modifyMVar (bindColsMV sstate) $ \mBindCols -> case mBindCols of Nothing -> do@@ -343,17 +390,19 @@ 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 :: SQLHSTMT -> BindCol -> IO SqlValue getLongColData cstmt bindCol = do let (BindColString buf bufLen col) = bindCol- l $ "buflen: " ++ show bufLen+ hdbcTrace $ "buflen: " ++ show bufLen bs <- B.packCStringLen (buf, fromIntegral (bufLen - 1))- l $ "sql_no_total col " ++ show (BUTF8.toString bs)+ hdbcTrace $ "sql_no_total col " ++ show (BUTF8.toString bs) bs2 <- getRestLongColData cstmt #{const SQL_CHAR} col bs return $ SqlByteString bs2 +getRestLongColData :: Integral a => SQLHSTMT -> Int16 -> a -> BUTF8.ByteString -> IO BUTF8.ByteString getRestLongColData cstmt cBinding icol acc = do- l "getLongColData"+ hdbcTrace "getLongColData" alloca $ \plen -> allocaBytes colBufSizeMaximum $ \buf -> do res <- sqlGetData cstmt (fromIntegral icol) cBinding@@ -366,7 +415,7 @@ else do let bufmax = fromIntegral $ colBufSizeMaximum - 1 bs <- B.packCStringLen (buf, fromIntegral (if len == #{const SQL_NO_TOTAL} || len > bufmax then bufmax else len))- l $ "sql_no_total col is: " ++ show (BUTF8.toString bs)+ 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@@ -375,6 +424,7 @@ -- TODO: This code does not deal well with data that is extremely large, -- where multiple fetches are required.+getColData :: Integral a => SQLHSTMT -> Int16 -> a -> IO SqlValue getColData cstmt cBinding icol = do alloca $ \plen -> allocaBytes colBufSizeDefault $ \buf ->@@ -387,7 +437,7 @@ #{const SQL_NULL_DATA} -> return SqlNull #{const SQL_NO_TOTAL} -> fail $ "Unexpected SQL_NO_TOTAL" _ -> do bs <- B.packCStringLen (buf, fromIntegral len)- l $ "col is: " ++ show (BUTF8.toString bs)+ hdbcTrace $ "col is: " ++ show (BUTF8.toString bs) return (SqlByteString bs) #{const SQL_SUCCESS_WITH_INFO} -> do len <- peek plen@@ -401,20 +451,26 @@ _ -> colBufSizeDefault - 1 -- strip off NUL bs <- liftM2 (B.append) (B.packCStringLen (buf, firstbuf)) (B.packCStringLen (buf2, fromIntegral len2))- l $ "col is: " ++ (BUTF8.toString bs)+ 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 :: forall t. SState -> IO (Maybe [t]) ffetchrowBaseline sstate = do- Just cmstmt <- readMVar (stomv sstate)- withStmt cmstmt $ \cstmt -> do- rc <- sqlFetch cstmt+ hdbcTrace "ffetchrowBaseline"+ result <- withStmtOrDie (sstmt sstate) $ \hStmt -> do+ hdbcTrace "ffetchrowBaseline got stmt handle"+ rc <- sqlFetch hStmt if rc == #{const SQL_NO_DATA}- then do ffinish cmstmt- return Nothing- else do return (Just [])+ then return Nothing+ else return (Just [])+ case result of+ Just x -> return $ Just x+ Nothing -> do+ ffinish sstate+ return Nothing data ColBuf @@ -437,6 +493,13 @@ | 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.@@ -444,14 +507,14 @@ -- | BindColInterval -- typedef struct tagSQL_INTERVAL_STRUCT -- {--- SQLINTERVAL interval_type; +-- 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 +-- typedef enum -- { -- SQL_IS_YEAR = 1, -- SQL_IS_MONTH = 2,@@ -467,13 +530,13 @@ -- SQL_IS_HOUR_TO_SECOND = 12, -- SQL_IS_MINUTE_TO_SECOND = 13 -- } SQLINTERVAL;--- +-- -- typedef struct tagSQL_YEAR_MONTH -- { -- SQLUINTEGER year;--- SQLUINTEGER month; +-- SQLUINTEGER month; -- } SQL_YEAR_MONTH_STRUCT;--- +-- -- typedef struct tagSQL_DAY_SECOND -- { -- SQLUINTEGER day;@@ -489,9 +552,9 @@ -- 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+ #{type SQLSMALLINT} -- year+ #{type SQLUSMALLINT} -- month+ #{type SQLUSMALLINT} -- day deriving Show instance Storable StructDate where@@ -509,9 +572,9 @@ -- | StructTime is used to marshals the TIME_STRUCT: data StructTime = StructTime- #{type SQLUSMALLINT} -- ^ hour- #{type SQLUSMALLINT} -- ^ minute- #{type SQLUSMALLINT} -- ^ second+ #{type SQLUSMALLINT} -- hour+ #{type SQLUSMALLINT} -- minute+ #{type SQLUSMALLINT} -- second instance Storable StructTime where sizeOf _ = #{size TIME_STRUCT}@@ -527,13 +590,13 @@ -- | 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+ #{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}@@ -561,7 +624,7 @@ -- #{type WORD} -- ^ Data2 -- #{type WORD} -- ^ Data3 -- [#{type BYTE}] -- ^ Data4[8]--- +-- -- instance Storable StructGUID where -- sizeOf _ = #{size SQLGUID} -- alignment _ = alignment (undefined :: CLong)@@ -602,17 +665,17 @@ -- 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 -> Ptr CStmt -> #{type SQLSMALLINT} -> IO (BindCol, Ptr #{type SQLLEN})+mkBindCol :: SState -> SQLHSTMT -> #{type SQLSMALLINT} -> IO (BindCol, Ptr #{type SQLLEN}) mkBindCol sstate cstmt col = do- l "mkBindCol"+ hdbcTrace "mkBindCol" colInfo <- readMVar (colinfomv sstate) let colDesc = (snd (colInfo !! ((fromIntegral col) -1))) case colType colDesc of- SqlCharT -> mkBindColString cstmt col' (colSize colDesc)- SqlVarCharT -> mkBindColString cstmt col' (colSize colDesc)+ SqlCharT -> mkBindColStringEC cstmt col' (colSize colDesc)+ SqlVarCharT -> mkBindColStringEC cstmt col' (colSize colDesc) SqlLongVarCharT -> mkBindColString cstmt col' (colSize colDesc)- SqlWCharT -> mkBindColWString cstmt col' (colSize colDesc)- SqlWVarCharT -> mkBindColWString 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)@@ -641,106 +704,121 @@ where col' = fromIntegral col +colBufSizeDefault :: Int colBufSizeDefault = 1024+colBufSizeMaximum :: Int colBufSizeMaximum = 4096 +utf8EncodingMaximum :: Int+utf8EncodingMaximum = 6+wcSize :: Int+wcSize = 2+ -- The functions that follow do the marshalling from C into a Haskell type+mkBindColString :: SQLHSTMT -> Word16 -> Maybe Int -> IO (BindCol, Ptr Int64) mkBindColString cstmt col mColSize = do- l "mkBindCol: BindColString"+ 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+ (bufLen, buf, pStrLen) <- mallocBuffer (colSize + 1)+ void $ sqlBindCol cstmt col (#{const SQL_C_CHAR}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColString buf (fromIntegral bufLen) col, pStrLen)++mkBindColStringEC :: SQLHSTMT -> Word16 -> Maybe Int -> IO (BindCol, Ptr Int64)+mkBindColStringEC cstmt col = mkBindColString cstmt col . fmap (* utf8EncodingMaximum)++mkBindColWString :: SQLHSTMT -> Word16 -> Maybe Int -> IO (BindCol, Ptr Int64) mkBindColWString cstmt col mColSize = do- l "mkBindCol: BindColWString"+ 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+ (bufLen, buf, pStrLen) <- mallocBuffer (colSize + 1)+ void $ sqlBindCol cstmt col (#{const SQL_C_WCHAR}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColWString buf (fromIntegral bufLen) col, pStrLen)-mkBindColBit cstmt col mColSize = do- l "mkBindCol: BindColBit"- let bufLen = sizeOf (undefined :: CChar)- buf <- malloc- pStrLen <- malloc- sqlBindCol cstmt col (#{const SQL_C_BIT}) (castPtr buf) (fromIntegral bufLen) pStrLen++mkBindColWStringEC :: SQLHSTMT -> Word16 -> Maybe Int -> IO (BindCol, Ptr Int64)+mkBindColWStringEC cstmt col = mkBindColString cstmt col . fmap extendFactor where+ extendFactor sz = sz * ((utf8EncodingMaximum + wcSize - 1) `quot` wcSize)++mkBindColBit :: SQLHSTMT -> Word16 -> Maybe Int -> IO (BindCol, Ptr Int64)+mkBindColBit cstmt col _ = do+ hdbcTrace "mkBindCol: BindColBit"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ void $ sqlBindCol cstmt col (#{const SQL_C_BIT}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColBit buf, pStrLen)-mkBindColTinyInt cstmt col mColSize = do- l "mkBindCol: BindColTinyInt"- let bufLen = sizeOf (undefined :: CUChar)- buf <- malloc- pStrLen <- malloc- sqlBindCol cstmt col (#{const SQL_C_STINYINT}) (castPtr buf) (fromIntegral bufLen) pStrLen++mkBindColTinyInt :: SQLHSTMT -> Word16 -> Maybe Int -> IO (BindCol, Ptr Int64)+mkBindColTinyInt cstmt col _ = do+ hdbcTrace "mkBindCol: BindColTinyInt"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ void $ sqlBindCol cstmt col (#{const SQL_C_STINYINT}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColTinyInt buf, pStrLen)-mkBindColShort cstmt col mColSize = do- l "mkBindCol: BindColShort"- let bufLen = sizeOf (undefined :: CShort)- buf <- malloc- pStrLen <- malloc- sqlBindCol cstmt col (#{const SQL_C_SSHORT}) (castPtr buf) (fromIntegral bufLen) pStrLen++mkBindColShort :: SQLHSTMT -> Word16 -> Maybe Int -> IO (BindCol, Ptr Int64)+mkBindColShort cstmt col _ = do+ hdbcTrace "mkBindCol: BindColShort"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ void $ sqlBindCol cstmt col (#{const SQL_C_SSHORT}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColShort buf, pStrLen)-mkBindColLong cstmt col mColSize = do- l "mkBindCol: BindColSize"- let bufLen = sizeOf (undefined :: CLong)- buf <- malloc- pStrLen <- malloc- sqlBindCol cstmt col (#{const SQL_C_SLONG}) (castPtr buf) (fromIntegral bufLen) pStrLen++mkBindColLong :: SQLHSTMT -> Word16 -> Maybe Int -> IO (BindCol, Ptr Int64)+mkBindColLong cstmt col _ = do+ hdbcTrace "mkBindCol: BindColSize"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ void $ sqlBindCol cstmt col (#{const SQL_C_SLONG}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColLong buf, pStrLen)-mkBindColBigInt cstmt col mColSize = do- l "mkBindCol: BindColBigInt"- let bufLen = sizeOf (undefined :: CInt)- buf <- malloc- pStrLen <- malloc- sqlBindCol cstmt col (#{const SQL_C_SBIGINT}) (castPtr buf) (fromIntegral bufLen) pStrLen++mkBindColBigInt :: SQLHSTMT -> Word16 -> Maybe Int -> IO (BindCol, Ptr Int64)+mkBindColBigInt cstmt col _ = do+ hdbcTrace "mkBindCol: BindColBigInt"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ void $ sqlBindCol cstmt col (#{const SQL_C_SBIGINT}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColBigInt buf, pStrLen)-mkBindColFloat cstmt col mColSize = do- l "mkBindCol: BindColFloat"- let bufLen = sizeOf (undefined :: CFloat)- buf <- malloc- pStrLen <- malloc- sqlBindCol cstmt col (#{const SQL_C_FLOAT}) (castPtr buf) (fromIntegral bufLen) pStrLen++mkBindColFloat :: SQLHSTMT -> Word16 -> Maybe Int -> IO (BindCol, Ptr Int64)+mkBindColFloat cstmt col _ = do+ hdbcTrace "mkBindCol: BindColFloat"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ void $ sqlBindCol cstmt col (#{const SQL_C_FLOAT}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColFloat buf, pStrLen)-mkBindColDouble cstmt col mColSize = do- l "mkBindCol: BindColDouble"- let bufLen = sizeOf (undefined :: CDouble)- buf <- malloc- pStrLen <- malloc- sqlBindCol cstmt col (#{const SQL_C_DOUBLE}) (castPtr buf) (fromIntegral bufLen) pStrLen++mkBindColDouble :: SQLHSTMT -> Word16 -> Maybe Int -> IO (BindCol, Ptr Int64)+mkBindColDouble cstmt col _ = do+ hdbcTrace "mkBindCol: BindColDouble"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ void $ sqlBindCol cstmt col (#{const SQL_C_DOUBLE}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColDouble buf, pStrLen)++mkBindColBinary :: SQLHSTMT -> Word16 -> Maybe Int -> IO (BindCol, Ptr Int64) mkBindColBinary cstmt col mColSize = do- l "mkBindCol: BindColBinary"+ 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+ (bufLen, buf, pStrLen) <- mallocBuffer (colSize + 1)+ void $ sqlBindCol cstmt col (#{const SQL_C_BINARY}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColBinary buf (fromIntegral bufLen) col, pStrLen)-mkBindColDate cstmt col mColSize = do- l "mkBindCol: BindColDate"- let bufLen = sizeOf (undefined :: StructDate)- buf <- malloc- pStrLen <- malloc- sqlBindCol cstmt col (#{const SQL_C_TYPE_DATE}) (castPtr buf) (fromIntegral bufLen) pStrLen++mkBindColDate :: SQLHSTMT -> Word16 -> Maybe Int -> IO (BindCol, Ptr Int64)+mkBindColDate cstmt col _ = do+ hdbcTrace "mkBindCol: BindColDate"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ void $ sqlBindCol cstmt col (#{const SQL_C_TYPE_DATE}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColDate buf, pStrLen)-mkBindColTime cstmt col mColSize = do- l "mkBindCol: BindColTime"- let bufLen = sizeOf (undefined :: StructTime)- buf <- malloc- pStrLen <- malloc- sqlBindCol cstmt col (#{const SQL_C_TYPE_TIME}) (castPtr buf) (fromIntegral bufLen) pStrLen++mkBindColTime :: SQLHSTMT -> Word16 -> Maybe Int -> IO (BindCol, Ptr Int64)+mkBindColTime cstmt col _ = do+ hdbcTrace "mkBindCol: BindColTime"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ void $ sqlBindCol cstmt col (#{const SQL_C_TYPE_TIME}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColTime buf, pStrLen)-mkBindColTimestamp cstmt col mColSize = do- l "mkBindCol: BindColTimestamp"- let bufLen = sizeOf (undefined :: StructTimestamp)- buf <- malloc- pStrLen <- malloc- sqlBindCol cstmt col (#{const SQL_C_TYPE_TIMESTAMP}) (castPtr buf) (fromIntegral bufLen) pStrLen++mkBindColTimestamp :: SQLHSTMT -> Word16 -> Maybe Int -> IO (BindCol, Ptr Int64)+mkBindColTimestamp cstmt col _ = do+ hdbcTrace "mkBindCol: BindColTimestamp"+ (bufLen, buf, pStrLen) <- mallocBuffer 1+ void $ sqlBindCol cstmt col (#{const SQL_C_TYPE_TIMESTAMP}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColTimestamp buf, pStrLen)++mkBindColGetData :: Word16 -> IO (BindCol, Ptr a) mkBindColGetData col = do- l "mkBindCol: BindColGetData"+ hdbcTrace "mkBindCol: BindColGetData" return (BindColGetData col, nullPtr) freeBindCol :: BindCol -> IO ()@@ -765,80 +843,80 @@ -- 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 :: Ptr CStmt -> (BindCol, Ptr #{type SQLLEN}) -> IO SqlValue+bindColToSqlValue :: SQLHSTMT -> (BindCol, Ptr #{type SQLLEN}) -> IO SqlValue bindColToSqlValue pcstmt (BindColGetData col, _) = do- l "bindColToSqlValue: BindColGetData"+ hdbcTrace "bindColToSqlValue: BindColGetData" getColData pcstmt #{const SQL_CHAR} col bindColToSqlValue pcstmt (bindCol, pStrLen) = do- l "bindColToSqlValue"+ hdbcTrace "bindColToSqlValue" strLen <- peek pStrLen case strLen of #{const SQL_NULL_DATA} -> return SqlNull- #{const SQL_NO_TOTAL} -> getLongColData pcstmt bindCol + #{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' :: Ptr CStmt -> BindCol -> #{type SQLLEN} -> IO SqlValue+bindColToSqlValue' :: SQLHSTMT -> BindCol -> #{type SQLLEN} -> IO SqlValue bindColToSqlValue' pcstmt (BindColString buf bufLen col) strLen | bufLen >= strLen = do bs <- B.packCStringLen (buf, fromIntegral strLen)- l $ "bindColToSqlValue BindColString " ++ show bs ++ " " ++ show 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)- l $ "bindColToSqlValue BindColWString " ++ show bs ++ " " ++ show strLen+ hdbcTrace $ "bindColToSqlValue BindColWString " ++ show bs ++ " " ++ show strLen return $ SqlByteString bs | otherwise = getColData pcstmt #{const SQL_CHAR} col-bindColToSqlValue' _ (BindColBit buf) strLen = do+bindColToSqlValue' _ (BindColBit buf) _ = do bit <- peek buf- l $ "bindColToSqlValue BindColBit " ++ show bit+ hdbcTrace $ "bindColToSqlValue BindColBit " ++ show bit return $ SqlChar (castCUCharToChar bit)-bindColToSqlValue' _ (BindColTinyInt buf) strLen = do+bindColToSqlValue' _ (BindColTinyInt buf) _ = do tinyInt <- peek buf- l $ "bindColToSqlValue BindColTinyInt " ++ show tinyInt+ hdbcTrace $ "bindColToSqlValue BindColTinyInt " ++ show tinyInt return $ SqlChar (castCCharToChar tinyInt)-bindColToSqlValue' _ (BindColShort buf) strLen = do+bindColToSqlValue' _ (BindColShort buf) _ = do short <- peek buf- l $ "bindColToSqlValue BindColShort" ++ show short+ hdbcTrace $ "bindColToSqlValue BindColShort" ++ show short return $ SqlInt32 (fromIntegral short)-bindColToSqlValue' _ (BindColLong buf) strLen = do+bindColToSqlValue' _ (BindColLong buf) _ = do long <- peek buf- l $ "bindColToSqlValue BindColLong " ++ show long+ hdbcTrace $ "bindColToSqlValue BindColLong " ++ show long return $ SqlInt32 (fromIntegral long)-bindColToSqlValue' _ (BindColBigInt buf) strLen = do+bindColToSqlValue' _ (BindColBigInt buf) _ = do bigInt <- peek buf- l $ "bindColToSqlValue BindColBigInt " ++ show bigInt+ hdbcTrace $ "bindColToSqlValue BindColBigInt " ++ show bigInt return $ SqlInt64 (fromIntegral bigInt)-bindColToSqlValue' _ (BindColFloat buf) strLen = do+bindColToSqlValue' _ (BindColFloat buf) _ = do float <- peek buf- l $ "bindColToSqlValue BindColFloat " ++ show float+ hdbcTrace $ "bindColToSqlValue BindColFloat " ++ show float return $ SqlDouble (realToFrac float)-bindColToSqlValue' _ (BindColDouble buf) strLen = do+bindColToSqlValue' _ (BindColDouble buf) _ = do double <- peek buf- l $ "bindColToSqlValue BindColDouble " ++ show double+ 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)- l $ "bindColToSqlValue BindColBinary " ++ show bs+ hdbcTrace $ "bindColToSqlValue BindColBinary " ++ show bs return $ SqlByteString bs | otherwise = getColData pcstmt (#{const SQL_C_BINARY}) col-bindColToSqlValue' _ (BindColDate buf) strLen = do+bindColToSqlValue' _ (BindColDate buf) _ = do StructDate year month day <- peek buf- l $ "bindColToSqlValue BindColDate"+ hdbcTrace $ "bindColToSqlValue BindColDate" return $ SqlLocalDate $ fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day)-bindColToSqlValue' _ (BindColTime buf) strLen = do+bindColToSqlValue' _ (BindColTime buf) _ = do StructTime hour minute second <- peek buf- l $ "bindColToSqlValue BindColTime"+ hdbcTrace $ "bindColToSqlValue BindColTime" return $ SqlLocalTimeOfDay $ TimeOfDay (fromIntegral hour) (fromIntegral minute) (fromIntegral second)-bindColToSqlValue' _ (BindColTimestamp buf) strLen = do+bindColToSqlValue' _ (BindColTimestamp buf) _ = do StructTimestamp year month day hour minute second nanosecond <- peek buf- l $ "bindColToSqlValue BindColTimestamp"+ hdbcTrace $ "bindColToSqlValue BindColTimestamp" return $ SqlLocalTime $ LocalTime (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day)) (TimeOfDay (fromIntegral hour) (fromIntegral minute)@@ -846,7 +924,7 @@ bindColToSqlValue' _ (BindColGetData _) _ = error "bindColToSqlValue': unexpected BindColGetData!" -fgetcolinfo :: Ptr CStmt -> IO [(String, SqlColDesc)]+fgetcolinfo :: SQLHSTMT -> IO [(String, SqlColDesc)] fgetcolinfo cstmt = do ncols <- getNumResultCols cstmt mapM getname [1..ncols]@@ -855,8 +933,8 @@ alloca $ \datatypeptr -> alloca $ \colsizeptr -> alloca $ \nullableptr ->- do sqlDescribeCol cstmt icol cscolname 127 colnamelp - datatypeptr colsizeptr nullPtr nullableptr+ do void $ sqlDescribeCol cstmt icol cscolname 127 colnamelp+ datatypeptr colsizeptr nullPtr nullableptr colnamelen <- peek colnamelp colnamebs <- B.packCStringLen (cscolname, fromIntegral colnamelen) let colname = BUTF8.toString colnamebs@@ -870,30 +948,26 @@ fexecutemany sstate arglist = mapM_ (fexecute sstate) arglist >> return () --- Finish and change state-public_ffinish :: SState -> IO ()-public_ffinish sstate = do- l "public_ffinish"- modifyMVar_ (stomv sstate) freeMStmt- modifyMVar_ (bindColsMV sstate) freeBindCols- where- freeMStmt Nothing = return Nothing- freeMStmt (Just sth) = ffinish sth >> return Nothing- freeBindCols Nothing = return Nothing- freeBindCols (Just bindCols) = do- l "public_ffinish: freeing bindcols"- mapM_ (\(bindCol, pSqlLen) -> freeBindCol bindCol >> free pSqlLen) bindCols+freeBoundCols :: SState -> IO ()+freeBoundCols sstate = modifyMVar_ (bindColsMV sstate) $ \maybeBindCols -> do+ F.mapM_ go maybeBindCols return Nothing--ffinish :: Stmt -> IO ()-ffinish stmt = withRawStmt stmt $ sqlFreeHandleSth_app -+ where+ go bindCols = do+ hdbcTrace "freeBoundCols"+ mapM_ (\(bindCol, pSqlLen) -> freeBindCol bindCol >> free pSqlLen) bindCols -foreign import ccall safe "hdbc-odbc-helper.h wrapobjodbc"- wrapstmt :: Ptr CStmt -> Ptr WrappedCConn -> IO (Ptr WrappedCStmt)+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 foreign import #{CALLCONV} safe "sql.h SQLDescribeCol"- sqlDescribeCol :: Ptr CStmt + sqlDescribeCol :: SQLHSTMT -> #{type SQLSMALLINT} -- ^ Column number -> CString -- ^ Column name -> #{type SQLSMALLINT} -- ^ Buffer length@@ -905,7 +979,7 @@ -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLGetData"- sqlGetData :: Ptr CStmt -- ^ statement handle+ sqlGetData :: SQLHSTMT -- ^ statement handle -> #{type SQLUSMALLINT} -- ^ Column number -> #{type SQLSMALLINT} -- ^ target type -> CString -- ^ target value pointer (void * in C)@@ -914,7 +988,7 @@ -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLBindCol"- sqlBindCol :: Ptr CStmt -- ^ statement handle+ sqlBindCol :: SQLHSTMT -- ^ statement handle -> #{type SQLUSMALLINT} -- ^ Column number -> #{type SQLSMALLINT} -- ^ target type -> Ptr ColBuf -- ^ target value pointer (void * in C)@@ -922,32 +996,25 @@ -> Ptr (#{type SQLLEN}) -- ^ strlen_or_indptr -> IO #{type SQLRETURN} -foreign import ccall safe "hdbc-odbc-helper.h sqlFreeHandleSth_app"- sqlFreeHandleSth_app :: Ptr WrappedCStmt -> IO ()--foreign import ccall safe "hdbc-odbc-helper.h &sqlFreeHandleSth_finalizer"- sqlFreeHandleSth_ptr :: FunPtr (Ptr WrappedCStmt -> IO ())- foreign import #{CALLCONV} safe "sql.h SQLPrepare"- sqlPrepare :: Ptr CStmt -> CString -> #{type SQLINTEGER} + sqlPrepare :: SQLHSTMT -> CString -> #{type SQLINTEGER} -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLExecute"- sqlExecute :: Ptr CStmt -> IO #{type SQLRETURN}+ sqlExecute :: SQLHSTMT -> IO #{type SQLRETURN} -foreign import #{CALLCONV} safe "sql.h SQLAllocHandle"- sqlAllocStmtHandle :: #{type SQLSMALLINT} -> Ptr CConn ->- Ptr (Ptr CStmt) -> IO #{type SQLRETURN}+foreign import #{CALLCONV} safe "sql.h SQLMoreResults"+ sqlMoreResults :: SQLHSTMT -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLNumResultCols"- sqlNumResultCols :: Ptr CStmt -> Ptr #{type SQLSMALLINT} + sqlNumResultCols :: SQLHSTMT -> Ptr #{type SQLSMALLINT} -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLRowCount"- sqlRowCount :: Ptr CStmt -> Ptr #{type SQLINTEGER} -> IO #{type SQLRETURN}+ sqlRowCount :: SQLHSTMT -> Ptr #{type SQLINTEGER} -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLBindParameter"- sqlBindParameter :: Ptr CStmt -- ^ Statement handle+ sqlBindParameter :: SQLHSTMT -- ^ Statement handle -> #{type SQLUSMALLINT} -- ^ Parameter Number -> #{type SQLSMALLINT} -- ^ Input or output -> #{type SQLSMALLINT} -- ^ Value type@@ -963,7 +1030,7 @@ nullDataHDBC :: Ptr #{type SQLLEN} foreign import #{CALLCONV} safe "sql.h SQLDescribeParam"- sqlDescribeParam :: Ptr CStmt + sqlDescribeParam :: SQLHSTMT -> #{type SQLUSMALLINT} -- ^ parameter number -> Ptr #{type SQLSMALLINT} -- ^ data type ptr -> Ptr #{type SQLULEN} -- ^ parameter size ptr@@ -972,16 +1039,16 @@ -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLFetch"- sqlFetch :: Ptr CStmt -> IO #{type SQLRETURN}+ sqlFetch :: SQLHSTMT -> IO #{type SQLRETURN} foreign import ccall safe "hdbc-odbc-helper.h simpleSqlTables"- simpleSqlTables :: Ptr CStmt -> IO #{type SQLRETURN}+ simpleSqlTables :: SQLHSTMT -> IO #{type SQLRETURN} foreign import ccall safe "hdbc-odbc-helper.h simpleSqlColumns"- simpleSqlColumns :: Ptr CStmt -> Ptr CChar -> + simpleSqlColumns :: SQLHSTMT -> Ptr CChar -> #{type SQLSMALLINT} -> IO #{type SQLRETURN} -fgetparminfo :: Ptr CStmt -> IO [SqlColDesc]+fgetparminfo :: SQLHSTMT -> IO [SqlColDesc] fgetparminfo cstmt = do ncols <- getNumParams cstmt mapM getname [1..ncols]@@ -991,7 +1058,7 @@ 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 + 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.@@ -1001,12 +1068,12 @@ nullable <- peek nullableptr return $ snd $ fromOTypeInfo "" datatype colsize nullable -getNumParams :: Ptr CStmt -> IO Int16+getNumParams :: SQLHSTMT -> IO Int16 getNumParams sthptr = alloca $ \pcount ->- do sqlNumParams sthptr pcount >>= checkError "SQLNumResultCols" + do sqlNumParams sthptr pcount >>= checkError "SQLNumResultCols" (StmtHandle sthptr) peek pcount foreign import #{CALLCONV} safe "sql.h SQLNumParams"- sqlNumParams :: Ptr CStmt -> Ptr #{type SQLSMALLINT} + sqlNumParams :: SQLHSTMT -> Ptr #{type SQLSMALLINT} -> IO #{type SQLRETURN}
Database/HDBC/ODBC/TypeConv.hsc view
@@ -4,27 +4,9 @@ module Database.HDBC.ODBC.TypeConv(fromOTypeInfo, fromOTypeCol) where import Database.HDBC.Types import Database.HDBC-import Database.HDBC.DriverUtils-import Database.HDBC.ODBC.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@@ -50,7 +32,8 @@ } ) -fromOTypeCol (_:_:_:colname:datatype:_:colsize:buflen:decdig:precrad:nullable:_:_:_:subtype:octetlen:_) =+fromOTypeCol :: [SqlValue] -> (String, SqlColDesc)+fromOTypeCol (_:_:_:colname:datatype:_:colsize:_:_:_:nullable:_:_:_:_:_:_) = fromOTypeInfo (fromSql colname) (fromIntegral ((fromSql datatype)::Int)) (fromSql colsize)
− Database/HDBC/ODBC/Types.hs
@@ -1,24 +0,0 @@-module Database.HDBC.ODBC.Types-where--import Foreign.ForeignPtr-import Foreign---- This may be wrong -- is SqlHandle always a pointer to something?--- but it works with hsql so I'm going to use it here until I hear of it--- breaking.---newtype SqlHandle = Ptr ()--data CEnv = CEnv-type WrappedCEnv = Ptr CEnv-type Env = ForeignPtr WrappedCEnv--data CConn = CConn-type WrappedCConn = Ptr CConn-type Conn = ForeignPtr WrappedCConn--data CStmt = CStmt-type WrappedCStmt = Ptr CStmt-type Stmt = ForeignPtr WrappedCStmt--
+ Database/HDBC/ODBC/Utils.hs view
@@ -0,0 +1,16 @@+{- -*- mode: haskell; -*-+-}+module Database.HDBC.ODBC.Utils where+import Foreign.Ptr+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/Utils.hsc
@@ -1,127 +0,0 @@-{- -*- mode: haskell; -*- --}--module Database.HDBC.ODBC.Utils where-import Foreign.C.String-import Foreign.ForeignPtr-import Foreign.Ptr-import Data.Int-import Database.HDBC(throwSqlError)-import Database.HDBC.Types-import Database.HDBC.ODBC.Types-import Foreign.C.Types-import Control.Exception-import Foreign.Storable-import Foreign.Marshal.Array-import Foreign.Marshal.Alloc-import Data.Word-import qualified Data.ByteString as B-import qualified Data.ByteString.UTF8 as BUTF8--#ifdef mingw32_HOST_OS-#include <windows.h>-#endif-#include "hdbc-odbc-helper.h"--#ifdef mingw32_HOST_OS-#let CALLCONV = "stdcall"-#else-#let CALLCONV = "ccall"-#endif--data SqlHandleT = EnvHandle (Ptr CEnv)- | DbcHandle (Ptr CConn)- | StmtHandle (Ptr CStmt)--checkError :: String -> SqlHandleT -> #{type SQLRETURN} -> IO ()-checkError msg o res =- do let rc = sqlSucceeded res- if rc == 0- then raiseError msg res o- else return ()--raiseError :: String -> #{type SQLRETURN} -> SqlHandleT -> 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::(Ptr ())) = case cconn of- EnvHandle c -> (#{const SQL_HANDLE_ENV}, castPtr c)- DbcHandle c -> (#{const SQL_HANDLE_DBC}, castPtr c)- StmtHandle c -> (#{const SQL_HANDLE_STMT}, castPtr c)- getdiag ht hp irow = allocaBytes 6 $ \csstate ->- alloca $ \pnaterr ->- allocaBytes 1025 $ \csmsg ->- alloca $ \pmsglen ->- do ret <- sqlGetDiagRec ht hp irow csstate pnaterr- csmsg 1024 pmsglen- if sqlSucceeded ret == 0- then return []- else do state <- peekCStringLen (csstate, 5)- nat <- peek pnaterr- msglen <- peek pmsglen- msgbs <- B.packCStringLen (csmsg,- fromIntegral msglen)- let msg = BUTF8.toString msgbs- next <- getdiag ht hp (irow + 1)- return $ (state, - (show nat) ++ ": " ++ msg) : next--{- This is a little hairy.--We have a Conn object that is actually a finalizeonce wrapper around-the real object. We use withConn to dereference the foreign pointer,-and then extract the pointer to the real object from the finalizeonce struct.--But, when we close the connection, we need the finalizeonce struct, so that's-done by withRawConn.--Ditto for statements. -}--withConn :: Conn -> (Ptr CConn -> IO b) -> IO b-withConn = genericUnwrap--withRawConn :: Conn -> (Ptr WrappedCConn -> IO b) -> IO b-withRawConn = withForeignPtr--withStmt :: Stmt -> (Ptr CStmt -> IO b) -> IO b-withStmt = genericUnwrap--withRawStmt :: Stmt -> (Ptr WrappedCStmt -> IO b) -> IO b-withRawStmt = withForeignPtr--withEnv :: Env -> (Ptr CEnv -> IO b) -> IO b-withEnv = genericUnwrap--withRawEnv :: Env -> (Ptr WrappedCEnv -> IO b) -> IO b-withRawEnv = withForeignPtr--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)---genericUnwrap :: ForeignPtr (Ptr a) -> (Ptr a -> IO b) -> IO b-genericUnwrap fptr action = withForeignPtr fptr (\structptr ->- do objptr <- #{peek finalizeonce, encapobj} structptr- action objptr- )-isOK :: #{type SQLRETURN} -> Bool-isOK r = sqlSucceeded r /= 0--foreign import ccall safe "sqlSucceeded"- sqlSucceeded :: #{type SQLRETURN} -> CInt--foreign import #{CALLCONV} safe "sql.h SQLGetDiagRec"- sqlGetDiagRec :: #{type SQLSMALLINT} -> Ptr () -> - #{type SQLSMALLINT} -> CString -> Ptr (#{type SQLINTEGER})- -> CString -> #{type SQLSMALLINT} - -> Ptr (#{type SQLSMALLINT}) -> IO #{type SQLRETURN}
+ Database/HDBC/ODBC/Wrappers.hs view
@@ -0,0 +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+ , 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,92 +1,117 @@-Name: HDBC-odbc-Version: 2.3.1.1-Cabal-Version: >=1.2.3-Build-type: Simple-License: BSD3-Maintainer: Nicolas Wu <nicolas.wu@gmail.com>-Author: John Goerzen-Copyright: Copyright (c) 2005-2011 John Goerzen-license-file: LICENSE-extra-source-files: LICENSE, hdbc-odbc-helper.h,- Makefile,- README.md,- testsrc/TestTime.hs-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-Cabal-Version: >=1.6+name: HDBC-odbc+version: 2.6.0.0+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+flag buildtests description: Build the executable to run unit tests default: False -source-repository head- type: git- location: https://github.com/hdbc/hdbc-odbc.git+flag buildstresstest+ description: Build the stress testing executable+ default: False -Library- Exposed-Modules: Database.HDBC.ODBC- Other-Modules: Database.HDBC.ODBC.Connection,- Database.HDBC.ODBC.Statement,- Database.HDBC.ODBC.Types,- Database.HDBC.ODBC.Utils,- Database.HDBC.ODBC.TypeConv,- Database.HDBC.ODBC.ConnectionImpl- Extensions: - ExistentialQuantification,- ForeignFunctionInterface,- ScopedTypeVariables- Build-Depends: base >= 4.3.1.0 && < 5- , mtl- , HDBC>=2.1.0- , time>=1.2.0.3- , utf8-string- , bytestring- GHC-Options: -O2- C-Sources: hdbc-odbc-helper.c+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+ extra-libraries: odbc32 else- Extra-Libraries: odbc- include-dirs: .- -- extra-lib-dirs: + extra-libraries: odbc, pthread -Executable runtests+executable runtests if flag(buildtests)- Buildable: True- Build-Depends: HUnit, QuickCheck, testpack, containers, old-time,- time, old-locale, convertible+ 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: Database.HDBC.ODBC,- Database.HDBC.ODBC.Connection,- Database.HDBC.ODBC.Statement,- Database.HDBC.ODBC.Types,- Database.HDBC.ODBC.Utils,- Database.HDBC.ODBC.TypeConv,- Database.HDBC.ODBC.ConnectionImpl- SpecificDB,- SpecificDBTests,- TestMisc,- TestSbasics,- TestUtils,- Testbasics,- Tests- Hs-Source-Dirs: ., testsrc- C-Sources: hdbc-odbc-helper.c- if os(mingw32) || os(win32)- Extra-Libraries: odbc32+ 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- Extra-Libraries: odbc- include-dirs: .- GHC-Options: -O2- Extensions: - ExistentialQuantification,- ForeignFunctionInterface,- PatternSignatures+ buildable: False+ main-is: stresstest.hs+ hs-source-dirs: stresstest+ ghc-options: -threaded -rtsopts
README.md view
@@ -1,6 +1,8 @@ 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@@ -10,10 +12,14 @@ 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://msdn.microsoft.com/library/default.asp?url=/library/en-us/odbc/htm/odbcsqldrivers.asp>- connectODBC :: String -> IO Connection+> 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:
+ cbits/hdbc-odbc-helper.c view
@@ -0,0 +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, (SQLCHAR *)"%", 1, (SQLCHAR *)"TABLE", 5);+}++SQLRETURN simpleSqlColumns(SQLHSTMT stmt, SQLCHAR *tablename,+ SQLSMALLINT tnlen) {+ return SQLColumns(stmt, NULL, 0, NULL, 0, tablename, tnlen, (SQLCHAR *)"%", 1);+}
+ cbits/hdbc-odbc-helper.h view
@@ -0,0 +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 */
+ changelog.txt view
@@ -0,0 +1,35 @@+2.6.0.0 - 8 Apr 2019++ * Only use Unicode API for getting diagnostic messages when on Windows,+ switched to non-Unicode API on other OS.++2.5.1.1 - 6 Apr 2019++ * Support for fetching errors from compound statements+ * Fix segfault when statement gets finalized by GC during execution of another+ one on same connection.++2.5.0.1 - 24 Nov 2016++ * Haddock fixes and documentation updates.++2.5.0.0 - 9 Dec 2015++ * Support for Unicode diagnostic messages on Windows.+ * Added support for getting and setting AutoCommit flag.++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.
− hdbc-odbc-helper.c
@@ -1,137 +0,0 @@-#if defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)-#include <windows.h>-#include <winnt.h>-#endif-#include <sql.h>-#include <sqlext.h>-#include <stdio.h>-#include <stdlib.h>-#include "hdbc-odbc-helper.h"--SQLLEN nullDataHDBC = SQL_NULL_DATA;--int sqlSucceeded(SQLRETURN ret) {- return SQL_SUCCEEDED(ret);-}--/* Things can't finalize more than once. -We'd like to let people call them from the app.-Yet we'd also like to be able to have a ForeignPtr finalize them.--So, here's a little wrapper for things. */--void dbc_conditional_finalizer(finalizeonce *conn);--finalizeonce *wrapobjodbc(void *obj, finalizeonce *parentobj) {- finalizeonce *newobj;- newobj = malloc(sizeof(finalizeonce));- if (newobj == NULL) {- fprintf(stderr, "\nHDBC: could not allocate wrapper!\n");- return NULL;- }- newobj->isfinalized = 0;- newobj -> refcount = 1;- newobj->encapobj = obj;- newobj->extrainfo = NULL;- newobj->parent = parentobj;- if (parentobj != NULL)- (parentobj->refcount)++;-#ifdef HDBC_DEBUG- fprintf(stderr, "\nWrapped %p at %p\n", obj, newobj);-#endif- return newobj;-}--finalizeonce *wrapobjodbc_extra(void *obj, void *extra, finalizeonce *parentobj) {- finalizeonce *newobj = wrapobjodbc(obj, parentobj);- if (newobj != NULL)- newobj->extrainfo = extra;- return newobj;-}- -void sqlFreeHandleSth_app(finalizeonce *res) {-#ifdef HDBC_DEBUG- fprintf(stderr, "\nApp cleanup of sth %p requested: %d\n", - res->encapobj, res->isfinalized);-#endif- if (res->isfinalized)- return;- SQLCloseCursor((SQLHSTMT) (res->encapobj));- SQLFreeHandle(SQL_HANDLE_STMT, (SQLHANDLE) (res->encapobj));- res->isfinalized = 1;- res->encapobj = NULL;-}--void sqlFreeHandleSth_finalizer(finalizeonce *res) {-#ifdef HDBC_DEBUG- fprintf(stderr, "\nFinalizer cleanup of sth %p requested: %d\n", - res->encapobj, res->isfinalized);-#endif- sqlFreeHandleSth_app(res);- (res->refcount)--; /* Not really important since this is never a - parent */- (res->parent->refcount)--;- dbc_conditional_finalizer(res->parent);- free(res);-}--SQLRETURN sqlFreeHandleDbc_app(finalizeonce *res) {- SQLRETURN retval;-#ifdef HDBC_DEBUG- fprintf(stderr, "\nApp cleanup of dbc %p requested: %d\n", - res->encapobj, res->isfinalized);-#endif- if (res->isfinalized)- return 0;- retval = SQLDisconnect((SQLHDBC) (res->encapobj));- if (SQL_SUCCEEDED(retval)) {- SQLFreeHandle(SQL_HANDLE_DBC, (SQLHANDLE) (res->encapobj));- SQLFreeHandle(SQL_HANDLE_ENV, (SQLHANDLE) (res->extrainfo));- res->isfinalized = 1;- res->encapobj = NULL;- }- return retval;-}--void sqlFreeHandleDbc_finalizer(finalizeonce *res) {-#ifdef HDBC_DEBUG- fprintf(stderr, "\nFinalizer cleanup of dbc %p requested: %d\n", - res->encapobj, res->isfinalized);-#endif- (res->refcount)--;- dbc_conditional_finalizer(res);-}--void dbc_conditional_finalizer(finalizeonce *res) {- if (res->refcount < 1) {- /* Don't use sqlFreeHandleDbc_app here, because we want to clear it out- regardless of the success or failues of SQLDisconnect. */- if (! (res->isfinalized)) {- SQLDisconnect((SQLHDBC) (res->encapobj));- SQLFreeHandle(SQL_HANDLE_DBC, (SQLHANDLE) (res->encapobj));- SQLFreeHandle(SQL_HANDLE_ENV, (SQLHANDLE) (res->extrainfo));- res->encapobj = NULL;- res->isfinalized = 1;- }- free(res);- }-}--void *getSqlOvOdbc3(void) {- return (void *)SQL_OV_ODBC3;-}--SQLRETURN disableAutoCommit(SQLHDBC conn) {- return SQLSetConnectAttr(conn, SQL_ATTR_AUTOCOMMIT, - (SQLPOINTER) SQL_AUTOCOMMIT_OFF,- SQL_IS_UINTEGER);-}--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);-}
− hdbc-odbc-helper.h
@@ -1,35 +0,0 @@-#if defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)-#include <windows.h>-#include <winnt.h>-#endif-#include <sql.h>--extern int sqlSucceeded(SQLRETURN ret);-extern SQLRETURN sqlFreeHandleEnv(SQLHANDLE hdl);--typedef struct TAG_finalizeonce {- void *encapobj;- int refcount;- int isfinalized;- void *extrainfo;- struct TAG_finalizeonce *parent;-} finalizeonce;--extern finalizeonce *wrapobjodbc(void *obj, finalizeonce *parentobj);-extern finalizeonce *wrapobjodbc_extra(void *obj, void *extra,- finalizeonce *parentobj);--extern SQLRETURN sqlFreeHandleDbc_app(finalizeonce *res);-extern void sqlFreeHandleDbc_finalizer(finalizeonce *res);--extern void sqlFreeHandleSth_app(finalizeonce *res);-extern void sqlFreeHandleSth_finalizer(finalizeonce *res);--extern SQLLEN nullDataHDBC;-extern void *getSqlOvOdbc3(void);--extern SQLRETURN disableAutoCommit(SQLHDBC conn);-extern SQLRETURN simpleSqlTables(SQLHSTMT stmt);-extern SQLRETURN simpleSqlColumns(SQLHSTMT stmt, SQLCHAR *tablename, - SQLSMALLINT tnlen);-
+ stresstest/stresstest.hs view
@@ -0,0 +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
testsrc/TestSbasics.hs view
@@ -3,9 +3,9 @@ import Database.HDBC import TestUtils import System.IO-import Control.Exception hiding (catch)+import Control.Exception -openClosedb = sqlTestCase $ +openClosedb = sqlTestCase $ do dbh <- connectDB disconnect dbh @@ -28,7 +28,7 @@ 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@@ -60,8 +60,8 @@ 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", + sFetchRow sth >>= (assertEqual "r1"+ (Just $ map Just ["executeReplace", "1", "1234", "Foo"])) sFetchRow sth >>= (assertEqual "r2" (Just [Just "executeReplace", Just "2", Nothing,@@ -124,11 +124,11 @@ 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"))- (\_ -> return ())+ (\(_ :: SomeException) -> return ()) sExecute qrysth [] sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]]) @@ -138,7 +138,7 @@ sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows)) ) where rows = map (\x -> [Just . show $ x]) [1..9]- + tests = TestList [ TestLabel "openClosedb" openClosedb,
testsrc/Testbasics.hs view
@@ -3,9 +3,9 @@ import Database.HDBC import TestUtils import System.IO-import Control.Exception hiding (catch)+import Control.Exception -openClosedb = sqlTestCase $ +openClosedb = sqlTestCase $ do dbh <- connectDB disconnect dbh @@ -29,7 +29,7 @@ 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@@ -51,7 +51,7 @@ r <- fetchAllRows sth assertEqual "" [r1, r2] r )- where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"] + where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"] r2 = [toSql "runReplace", iToSql 2, iToSql 2, SqlNull] executeReplace = dbTestCase (\dbh ->@@ -136,11 +136,11 @@ 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"))- (\_ -> return ())+ (\(_ :: SomeException) -> return ()) execute qrysth [] fetchAllRows qrysth >>= (assertEqual "rollback" [[SqlString "0"]]) @@ -150,7 +150,7 @@ fetchAllRows qrysth >>= (assertEqual "final commit" ([iToSql 0]:rows)) ) where rows = map (\x -> [iToSql x]) [1..9]- + tests = TestList [ TestLabel "openClosedb" openClosedb,