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