module Database.HDBC.ODBC.Connection (connectODBC, Impl.Connection) where
import Database.HDBC.Types
import Database.HDBC
import Database.HDBC.DriverUtils
import qualified Database.HDBC.ODBC.ConnectionImpl as Impl
import Database.HDBC.ODBC.Types
import Database.HDBC.ODBC.Statement
import Foreign.C.Types
import Foreign.C.String
import Foreign.Marshal
import Foreign.Storable
import Database.HDBC.ODBC.Utils
import Foreign.ForeignPtr
import Foreign.Ptr
import Data.Word
import Data.Int
import Control.Concurrent.MVar
import Control.Monad (when)
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as BUTF8
connectODBC :: String -> IO Impl.Connection
connectODBC args = B.useAsCStringLen (BUTF8.fromString args) $ \(cs, cslen) ->
alloca $ \(penvptr::Ptr (Ptr CEnv)) ->
alloca $ \(pdbcptr::Ptr (Ptr CConn)) ->
do
rc1 <- sqlAllocHandle 1
nullPtr
(castPtr penvptr)
envptr <- peek penvptr
checkError "connectODBC/alloc env" (EnvHandle envptr) rc1
sqlSetEnvAttr envptr 200
(getSqlOvOdbc3) 0
sqlAllocHandle 2 (castPtr envptr)
(castPtr pdbcptr)
>>= checkError "connectODBC/alloc dbc"
(EnvHandle envptr)
dbcptr <- peek pdbcptr
wrappeddbcptr <- wrapconn dbcptr envptr nullPtr
fdbcptr <- newForeignPtr sqlFreeHandleDbc_ptr wrappeddbcptr
sqlDriverConnect dbcptr nullPtr cs (fromIntegral cslen)
nullPtr 0 nullPtr
0
>>= checkError "connectODBC/sqlDriverConnect"
(DbcHandle dbcptr)
mkConn args fdbcptr
mkConn :: String -> Conn -> IO Impl.Connection
mkConn args iconn = withConn iconn $ \cconn ->
alloca $ \plen ->
alloca $ \psqlusmallint ->
allocaBytes 128 $ \pbuf ->
do
children <- newMVar []
sqlGetInfo cconn 18 (castPtr pbuf) 127 plen
>>= checkError "sqlGetInfo SQL_DBMS_VER" (DbcHandle cconn)
len <- peek plen
serverver <- peekCStringLen (pbuf, fromIntegral len)
sqlGetInfo cconn 7 (castPtr pbuf) 127 plen
>>= checkError "sqlGetInfo SQL_DRIVER_VER" (DbcHandle cconn)
len <- peek plen
proxiedclientver <- peekCStringLen (pbuf, fromIntegral len)
sqlGetInfo cconn 10 (castPtr pbuf) 127 plen
>>= checkError "sqlGetInfo SQL_ODBC_VER" (DbcHandle cconn)
len <- peek plen
clientver <- peekCStringLen (pbuf, fromIntegral len)
sqlGetInfo cconn 17 (castPtr pbuf) 127 plen
>>= checkError "sqlGetInfo SQL_DBMS_NAME" (DbcHandle cconn)
len <- peek plen
clientname <- peekCStringLen (pbuf, fromIntegral len)
sqlGetInfo cconn 46 (castPtr psqlusmallint)
0 nullPtr
>>= checkError "sqlGetInfo SQL_TXN_CAPABLE" (DbcHandle cconn)
txninfo <- ((peek psqlusmallint)::IO (Word16))
let txnsupport = txninfo /= 0
when txnsupport
(disableAutoCommit cconn
>>= checkError "sqlSetConnectAttr" (DbcHandle cconn)
)
return $ Impl.Connection {
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,
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
}
frun conn children query args =
do sth <- newSth conn children query
res <- execute sth args
finish sth
return res
fcommit iconn = withConn iconn $ \cconn ->
sqlEndTran 2 cconn 0
>>= checkError "sqlEndTran commit" (DbcHandle cconn)
frollback iconn = withConn iconn $ \cconn ->
sqlEndTran 2 cconn 1
>>= checkError "sqlEndTran rollback" (DbcHandle cconn)
fdisconnect iconn mchildren = withRawConn iconn $ \rawconn ->
withConn iconn $ \llconn ->
do closeAllChildren mchildren
res <- sqlFreeHandleDbc_app rawconn
checkError "disconnect" (DbcHandle $ llconn) res
foreign import ccall unsafe "sql.h SQLAllocHandle"
sqlAllocHandle :: Int16 -> Ptr () ->
Ptr () -> IO (Int16)
foreign import ccall unsafe "hdbc-odbc-helper.h wrapobjodbc_extra"
wrapconn :: Ptr CConn -> Ptr CEnv -> Ptr WrappedCConn -> IO (Ptr WrappedCConn)
foreign import ccall unsafe "hdbc-odbc-helper.h &sqlFreeHandleDbc_finalizer"
sqlFreeHandleDbc_ptr :: FunPtr (Ptr WrappedCConn -> IO ())
foreign import ccall unsafe "hdbc-odbc-helper.h sqlFreeHandleDbc_app"
sqlFreeHandleDbc_app :: Ptr WrappedCConn -> IO (Int16)
foreign import ccall unsafe "sql.h SQLSetEnvAttr"
sqlSetEnvAttr :: Ptr CEnv -> Int32 ->
Ptr () -> Int32 -> IO Int16
foreign import ccall unsafe "sql.h SQLDriverConnect"
sqlDriverConnect :: Ptr CConn -> Ptr () -> CString -> Int16
-> CString -> Int16
-> Ptr Int16 -> Word16
-> IO Int16
foreign import ccall unsafe "hdbc-odbc-helper.h getSqlOvOdbc3"
getSqlOvOdbc3 :: Ptr ()
foreign import ccall unsafe "hdbc-odbc-helper.h SQLSetConnectAttr"
sqlSetConnectAttr :: Ptr CConn -> Int32
-> Ptr Word32 -> Int32
-> IO Int16
foreign import ccall unsafe "sql.h SQLEndTran"
sqlEndTran :: Int16 -> Ptr CConn -> Int16
-> IO Int16
foreign import ccall unsafe "hdbc-odbc-helper.h disableAutoCommit"
disableAutoCommit :: Ptr CConn -> IO Int16
foreign import ccall unsafe "sql.h SQLGetInfo"
sqlGetInfo :: Ptr CConn -> Word16 -> Ptr () ->
Int16 -> Ptr Int16 ->
IO Int16