hsql-odbc 1.7.1 → 1.8.1
raw patch · 9 files changed
+752/−435 lines, 9 filesdep ~hsql
Dependency ranges changed: hsql
Files
- ChangeLog +2/−0
- DB/HSQL/ODBC/Core.hsc +187/−0
- DB/HSQL/ODBC/Functions.hsc +174/−0
- DB/HSQL/ODBC/Status.hsc +26/−0
- DB/HSQL/ODBC/Type.hsc +106/−0
- Database/HSQL/ODBC.hs +218/−0
- Database/HSQL/ODBC.hsc +0/−432
- LICENSE +29/−0
- hsql-odbc.cabal +10/−3
+ ChangeLog view
@@ -0,0 +1,2 @@+2010-1-29+ 1.8.1: uses updated exception handling of hsql-1.8.1; refactorings
+ DB/HSQL/ODBC/Core.hsc view
@@ -0,0 +1,187 @@+{-# LANGUAGE ScopedTypeVariables #-}+module DB.HSQL.ODBC.Core(handleSqlResult,withStatement) +where+++import Control.Exception(throw)+import Database.HSQL+import Database.HSQL.Types+import Control.Concurrent.MVar(newMVar)+import Foreign(plusPtr,peekByteOff,toBool,Ptr,nullPtr,castPtr,copyBytes+ ,allocaBytes,alloca,mallocBytes,free,peek)+import Foreign.C(CString,peekCString)+#ifdef DEBUG+import Debug.Trace(putTraceMsg)+#endif++import DB.HSQL.ODBC.Type+import DB.HSQL.ODBC.Functions+import DB.HSQL.ODBC.Status++#include <HsODBC.h>++-- | +withStatement :: Connection -> HDBC -> (HSTMT -> IO SQLRETURN) -> IO Statement+withStatement connection hDBC f = + allocaBytes sizeOfField $ \pFIELD -> do+ res <- sqlAllocStmt hDBC ((#ptr FIELD, hSTMT) pFIELD)+ handleSqlResult sqlHandleDbc hDBC res+ hSTMT <- (#peek FIELD, hSTMT) pFIELD+ let handleResult res = handleSqlResult sqlHandleStmt hSTMT res++#if defined(MSSQL_ODBC)+ sqlSetStmtAttr hSTMT sqlAttrRowArraySize 2 sqlIsInteger+ sqlSetStmtAttr hSTMT sqlAttrCursorType sqlCursorStatic sqlIsInteger+#endif++ f hSTMT >>= handleResult+ fields <- moveToFirstResult hSTMT pFIELD+ buffer <- mallocBytes (fromIntegral stmtBufferSize)+ refFalse <- newMVar False+ let statement = Statement+ { stmtConn = connection+ , stmtClose = odbcCloseStatement hSTMT buffer+ , stmtFetch = odbcFetch hSTMT+ , stmtGetCol = getColValue hSTMT buffer+ , stmtFields = fields+ , stmtClosed = refFalse }+ return statement+++-- | +getFieldDefs:: HSTMT -> Ptr a -> SQLUSMALLINT -> SQLUSMALLINT -> IO [FieldDef]+getFieldDefs hSTMT pFIELD n count+ | n > count = return []+ | otherwise = do+ res <- sqlDescribeCol hSTMT n + ((#ptr FIELD, fieldName) pFIELD) fieldNameLength + ((#ptr FIELD, NameLength) pFIELD) + ((#ptr FIELD, DataType) pFIELD) + ((#ptr FIELD, ColumnSize) pFIELD) + ((#ptr FIELD, DecimalDigits) pFIELD) + ((#ptr FIELD, Nullable) pFIELD)+ handleSqlResult sqlHandleStmt hSTMT res+ name <- peekCString ((#ptr FIELD, fieldName) pFIELD)+ dataType <- (#peek FIELD, DataType) pFIELD+ columnSize <- (#peek FIELD, ColumnSize) pFIELD+ decimalDigits <- (#peek FIELD, DecimalDigits) pFIELD+ (nullable :: SQLSMALLINT) <- (#peek FIELD, Nullable) pFIELD+ let sqlType = mkSqlType dataType columnSize decimalDigits+ fields <- getFieldDefs hSTMT pFIELD (n+1) count+ return ((name,sqlType,toBool nullable):fields)+++-- | +moveToFirstResult :: HSTMT -> Ptr a -> IO [FieldDef]+moveToFirstResult hSTMT pFIELD = do+ res <- sqlNumResultCols hSTMT ((#ptr FIELD, fieldsCount) pFIELD)+ handleSqlResult sqlHandleStmt hSTMT res+ count <- (#peek FIELD, fieldsCount) pFIELD+ if count == 0+ then do++#if defined(MSSQL_ODBC)+ sqlSetStmtAttr hSTMT sqlAttrRowArraySize 2 sqlIsInteger+ sqlSetStmtAttr hSTMT sqlAttrCursorType sqlCursorStatic sqlIsInteger+#endif++ res <- sqlMoreResults hSTMT+ handleSqlResult sqlHandleStmt hSTMT res+ if res == sqlNoData+ then return []+ else moveToFirstResult hSTMT pFIELD+ else getFieldDefs hSTMT pFIELD 1 count++++-- |+odbcFetch :: HSTMT -> IO Bool+odbcFetch hSTMT = do+ res <- sqlFetch hSTMT+ handleSqlResult sqlHandleStmt hSTMT res+ return (res /= sqlNoData)+++-- |+odbcCloseStatement :: HSTMT -> CString -> IO ()+odbcCloseStatement hSTMT buffer = do+ free buffer+ sqlFreeStmt hSTMT sqlDrop >>= handleSqlResult sqlHandleStmt hSTMT+++------------------------------------------------------------------------------+-- routines for handling exceptions+------------------------------------------------------------------------------+-- |+handleSqlResult :: SQLSMALLINT -> SQLHANDLE -> SQLRETURN -> IO ()+handleSqlResult handleType handle res+ | res == sqlSuccess || res == sqlNoData = return ()+ | res == sqlSuccessWithInfo = do++#ifdef DEBUG+ getSqlError >>= (putTraceMsg . show)+#else+ return ()+#endif++ | res == sqlInvalidHandle = throw SqlInvalidHandle+ | res == sqlStillExecuting = throw SqlStillExecuting+ | res == sqlNeedData = throw SqlNeedData+ | res == sqlError = do+ getSqlError >>= throw+ | otherwise = error (show res)+ where+ getSqlError =+ allocaBytes 256 $ \pState ->+ alloca $ \pNative ->+ allocaBytes 256 $ \pMsg ->+ alloca $ \pTextLen -> do+ res <- sqlGetDiagRec handleType handle 1 + pState pNative pMsg 256 pTextLen+ if res == sqlNoData+ then return SqlNoData+ else do+ state <- peekCString pState+ native <- peek pNative+ msg <- peekCString pMsg+ return (SqlError { seState=state+ , seNativeError=fromIntegral native+ , seErrorMsg=msg })+++-- |+stmtBufferSize = 256+++-- |+getColValue :: HSTMT -> CString -> Int -> FieldDef -> (FieldDef -> CString -> Int -> IO a) -> IO a+getColValue hSTMT buffer colNumber fieldDef f = do+ (res,len_or_ind) <- getData buffer (fromIntegral stmtBufferSize)+ if len_or_ind == sqlNullData+ then f fieldDef nullPtr 0+ else if res == sqlSuccessWithInfo+ then getLongData len_or_ind+ else f fieldDef buffer (fromIntegral len_or_ind)+ where getData :: CString -> SQLINTEGER -> IO (SQLRETURN, SQLINTEGER)+ getData buffer size = alloca $ \lenP -> do+ res <- sqlGetData hSTMT (fromIntegral colNumber+1) + sqlCChar (castPtr buffer) size lenP+ handleSqlResult sqlHandleStmt hSTMT res+ len_or_ind <- peek lenP+ return (res, len_or_ind)++ -- gets called only when there is more data than would+ -- fit in the normal buffer. This call to+ -- SQLGetData() will fetch the rest of the data.+ -- We create a new buffer big enough to hold the+ -- old and the new data, copy the old data into+ -- it and put the new data in buffer after the old.+ getLongData len = allocaBytes (fromIntegral newBufSize) $ \newBuf-> do+ copyBytes newBuf buffer stmtBufferSize+ -- The last byte of the old data with always be null,+ -- so it is overwritten with the first byte of the new data.+ let newDataStart = newBuf `plusPtr` (stmtBufferSize - 1)+ newDataLen = newBufSize - (fromIntegral stmtBufferSize - 1)+ (res,_) <- getData newDataStart newDataLen+ f fieldDef newBuf (fromIntegral newBufSize-1)+ where newBufSize = len+1 -- to allow for terminating null character
+ DB/HSQL/ODBC/Functions.hsc view
@@ -0,0 +1,174 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module DB.HSQL.ODBC.Functions where++import Foreign(FunPtr,Ptr)+import Foreign.C(CString)++import DB.HSQL.ODBC.Type(SQLSMALLINT,SQLUSMALLINT,SQLINTEGER,SQLLEN,SQLULEN+ ,SQLRETURN,HSTMT,HDBC,HENV,SQLHANDLE)+++#include <HsODBC.h>++#ifdef mingw32_HOST_OS+#let CALLCONV = "stdcall"+#else+#let CALLCONV = "ccall"+#endif++foreign import #{CALLCONV} "HsODBC.h SQLAllocEnv" + sqlAllocEnv:: Ptr HENV -> IO SQLRETURN++#ifdef mingw32_HOST_OS+foreign import ccall "HsODBC.h &my_sqlFreeEnv" + sqlFreeEnv_p:: FunPtr (HENV -> IO ())+#else+foreign import ccall "HsODBC.h &SQLFreeEnv" + sqlFreeEnv_p:: FunPtr (HENV -> IO ())+#endif++foreign import #{CALLCONV} "HsODBC.h SQLAllocConnect" + sqlAllocConnect:: HENV -> Ptr HDBC -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLFreeConnect" + sqlFreeConnect:: HDBC -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLConnect" + sqlConnect:: HDBC -> CString -> Int -> CString -> Int -> CString -> Int + -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLDriverConnect" + sqlDriverConnect:: HDBC -> Ptr () -> CString -> SQLSMALLINT -> CString + -> SQLSMALLINT -> Ptr SQLSMALLINT -> SQLUSMALLINT + -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLDisconnect" + sqlDisconnect:: HDBC -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLAllocStmt" + sqlAllocStmt:: HDBC -> Ptr HSTMT -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLFreeStmt" + sqlFreeStmt:: HSTMT -> SQLUSMALLINT -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLNumResultCols" + sqlNumResultCols:: HSTMT -> Ptr SQLUSMALLINT -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLDescribeCol" + sqlDescribeCol:: HSTMT -> SQLUSMALLINT -> CString -> SQLSMALLINT + -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLULEN + -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT + -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLBindCol" + sqlBindCol:: HSTMT -> SQLUSMALLINT -> SQLSMALLINT -> Ptr a + -> SQLLEN -> Ptr SQLINTEGER + -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLFetch" + sqlFetch:: HSTMT -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLGetDiagRec" + sqlGetDiagRec:: SQLSMALLINT -> SQLHANDLE -> SQLSMALLINT -> CString + -> Ptr SQLINTEGER -> CString -> SQLSMALLINT -> Ptr SQLSMALLINT + -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLExecDirect" + sqlExecDirect:: HSTMT -> CString -> Int -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLSetConnectOption" + sqlSetConnectOption:: HDBC -> SQLUSMALLINT -> SQLULEN -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLTransact" + sqlTransact:: HENV -> HDBC -> SQLUSMALLINT -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLGetData" + sqlGetData:: HSTMT -> SQLUSMALLINT -> SQLSMALLINT -> Ptr () + -> SQLINTEGER -> Ptr SQLINTEGER + -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLTables" + sqlTables:: HSTMT -> CString -> SQLSMALLINT -> CString -> SQLSMALLINT + -> CString -> SQLSMALLINT -> CString -> SQLSMALLINT + -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLColumns" + sqlColumns:: HSTMT -> CString -> SQLSMALLINT -> CString -> SQLSMALLINT + -> CString -> SQLSMALLINT -> CString -> SQLSMALLINT + -> IO SQLRETURN++foreign import #{CALLCONV} "HsODBC.h SQLMoreResults" + sqlMoreResults:: HSTMT -> IO SQLRETURN++#if defined(MSSQL_ODBC)+foreign import #{CALLCONV} "HsODBC.h SQLSetStmtAttr" + sqlSetStmtAttr:: HSTMT -> SQLINTEGER -> SQLINTEGER -> SQLINTEGER + -> IO SQLRETURN +#endif+++-- |++-- ptrField thinc = (#ptr FIELD, thinc)++-- peekField = #peek FIELD+++-- | +sqlNts:: SQLSMALLINT+sqlNts = #const SQL_NTS ++sqlDriverNoPrompt:: SQLUSMALLINT+sqlDriverNoPrompt = #const SQL_DRIVER_NOPROMPT++sqlHandleEnv:: SQLSMALLINT+sqlHandleEnv = #const SQL_HANDLE_ENV++sqlHandleDbc:: SQLSMALLINT+sqlHandleDbc = #const SQL_HANDLE_DBC++sizeOfHStmt:: Int+sizeOfHStmt = #const sizeof(HSTMT)++sizeOfField:: Int+sizeOfField = #const sizeof(FIELD)++sqlHandleStmt:: SQLSMALLINT+sqlHandleStmt = #const SQL_HANDLE_STMT++sqlDrop:: SQLUSMALLINT+sqlDrop = #const SQL_DROP++fieldNameLength:: SQLSMALLINT+fieldNameLength = #const FIELD_NAME_LENGTH++sqlAutoCommit:: SQLUSMALLINT+sqlAutoCommit = #const SQL_AUTOCOMMIT++sqlAutoCommitOff:: SQLULEN+sqlAutoCommitOff = #const SQL_AUTOCOMMIT_OFF++sqlAutoCommitOn:: SQLULEN+sqlAutoCommitOn = #const SQL_AUTOCOMMIT_ON ++sqlCommit:: SQLUSMALLINT+sqlCommit = #const SQL_COMMIT++sqlRollback:: SQLUSMALLINT+sqlRollback = #const SQL_ROLLBACK++sqlNullData:: SQLINTEGER+sqlNullData = #const SQL_NULL_DATA++sqlCChar:: SQLSMALLINT+sqlCChar = #const SQL_C_CHAR++-- (no #include <HsODBC.h> needed??+sqlAttrRowArraySize = #const SQL_ATTR_ROW_ARRAY_SIZE++sqlIsInteger = #const SQL_IS_INTEGER++sqlAttrCursorType = #const SQL_ATTR_CURSOR_TYPE++sqlCursorStatic = #const SQL_CURSOR_STATIC+
+ DB/HSQL/ODBC/Status.hsc view
@@ -0,0 +1,26 @@+module DB.HSQL.ODBC.Status where++import DB.HSQL.ODBC.Type(SQLRETURN,SQLSMALLINT,SQLUSMALLINT,SQLULEN)++#include <HsODBC.h>++sqlSuccess:: SQLRETURN+sqlSuccess = (#const SQL_SUCCESS)++sqlNoData:: SQLRETURN+sqlNoData = (#const SQL_NO_DATA)++sqlSuccessWithInfo:: SQLRETURN+sqlSuccessWithInfo = (#const SQL_SUCCESS_WITH_INFO)++sqlInvalidHandle:: SQLRETURN+sqlInvalidHandle = (#const SQL_INVALID_HANDLE)++sqlStillExecuting:: SQLRETURN+sqlStillExecuting = (#const SQL_STILL_EXECUTING)++sqlNeedData:: SQLRETURN+sqlNeedData = (#const SQL_NEED_DATA)++sqlError:: SQLRETURN+sqlError = (#const SQL_ERROR)
+ DB/HSQL/ODBC/Type.hsc view
@@ -0,0 +1,106 @@+{-# LANGUAGE ForeignFunctionInterface #-}+module DB.HSQL.ODBC.Type where++import Data.Int(Int32, Int16)+import Data.Word(Word32, Word16)+import Foreign(Ptr,ForeignPtr)++import Database.HSQL.Types(SqlType(..))++#include <HsODBC.h>++type SQLHANDLE = Ptr ()+type HENV = SQLHANDLE+type HDBC = SQLHANDLE+type HSTMT = SQLHANDLE+type HENVRef = ForeignPtr ()++type SQLSMALLINT = #type SQLSMALLINT+type SQLUSMALLINT = #type SQLUSMALLINT+type SQLINTEGER = #type SQLINTEGER+type SQLUINTEGER = #type SQLUINTEGER+type SQLRETURN = SQLSMALLINT+type SQLLEN = SQLINTEGER+type SQLULEN = SQLINTEGER++type SQL = String++-- |+mkSqlType :: SQLSMALLINT -> SQLULEN -> SQLSMALLINT -> SqlType+mkSqlType sqlChar size _ = SqlChar (fromIntegral size)+mkSqlType sqlVarChar size _ = SqlVarChar (fromIntegral size)+mkSqlType sqlLongVarChar size _ = SqlLongVarChar (fromIntegral size)+mkSqlType sqlDecimal size prec = + SqlDecimal (fromIntegral size) (fromIntegral prec)+mkSqlType sqlNumeric size prec = + SqlNumeric (fromIntegral size) (fromIntegral prec)+mkSqlType sqlSmallint _ _ = SqlSmallInt+mkSqlType sqlInteger _ _ = SqlInteger+mkSqlType sqlReal _ _ = SqlReal+-- From: http://msdn.microsoft.com/library/en-us/odbc/htm/odappdpr_2.asp+-- "Depending on the implementation, the precision of SQL_FLOAT can be+-- either 24 or 53:+-- if it is 24, the SQL_FLOAT data type is the same as SQL_REAL;+-- if it is 53, the SQL_FLOAT data type is the same as SQL_DOUBLE."+mkSqlType sqlFloat _ _ = SqlFloat+mkSqlType sqlDouble _ _ = SqlDouble+mkSqlType sqlBit _ _ = SqlBit+mkSqlType sqlTinyInt _ _ = SqlTinyInt+mkSqlType sqlBigint _ _ = SqlBigInt+mkSqlType sqlBinary size _ = SqlBinary (fromIntegral size)+mkSqlType sqlVarBinary size _ = SqlVarBinary (fromIntegral size)+mkSqlType sqlLongVarBinary size _ = SqlLongVarBinary (fromIntegral size)+mkSqlType sqlDate _ _ = SqlDate+mkSqlType sqlTime _ _ = SqlTime+mkSqlType sqlTimestamp _ _ = SqlDateTime+mkSqlType sqlWChar size _ = SqlWChar (fromIntegral size)+mkSqlType sqlWVarChar size _ = SqlWVarChar (fromIntegral size)+mkSqlType sqlWLongVarChar size _ = + SqlWLongVarChar (fromIntegral size)+mkSqlType tp _ _ = SqlUnknown (fromIntegral tp)++-- | #const+sqlChar = #const SQL_CHAR++sqlVarChar = #const SQL_VARCHAR++sqlLongVarChar = #const SQL_LONGVARCHAR++sqlDecimal = #const SQL_DECIMAL++sqlNumeric = #const SQL_NUMERIC++sqlSmallint = #const SQL_SMALLINT++sqlInteger = #const SQL_INTEGER++sqlReal = #const SQL_REAL++sqlFloat = #const SQL_FLOAT++sqlDouble = #const SQL_DOUBLE++sqlBit = #const SQL_BIT++sqlTinyInt = #const SQL_TINYINT++sqlBigint = #const SQL_BIGINT++sqlBinary = #const SQL_BINARY++sqlVarBinary = #const SQL_VARBINARY++sqlLongVarBinary = #const SQL_LONGVARBINARY++sqlDate = #const SQL_DATE++sqlTime = #const SQL_TIME++sqlTimestamp = #const SQL_TIMESTAMP++sqlWChar = #const SQL_WCHAR++sqlWVarChar = #const SQL_WVARCHAR++sqlWLongVarChar = #const SQL_WLONGVARCHAR+
+ Database/HSQL/ODBC.hs view
@@ -0,0 +1,218 @@+{-# OPTIONS -fglasgow-exts #-}+{-| Module : Database.HSQL.ODBC+ Copyright : (c) Krasimir Angelov 2003+ License : BSD-style++ Maintainer : kr.angelov@gmail.com+ Stability : provisional+ Portability : portable++ The module provides interface to ODBC+-}+module Database.HSQL.ODBC(connect, driverConnect+ ,module Database.HSQL) where++import Database.HSQL+import Database.HSQL.Types+import Foreign(toBool,Ptr,allocaBytes,alloca,nullPtr,peek+ ,newForeignPtr,withForeignPtr)+import Foreign.C(withCString,withCStringLen)+import Control.Concurrent.MVar(newMVar)+import System.IO.Unsafe(unsafePerformIO)++import DB.HSQL.ODBC.Type(HDBC,SQLRETURN,HENV,HENVRef,mkSqlType,SQL)+import DB.HSQL.ODBC.Functions+import DB.HSQL.ODBC.Core(handleSqlResult,withStatement)++------------------------------------------------------------------------------+-- Connect/Disconnect+------------------------------------------------------------------------------+-- | Makes a new connection to the ODBC data source+connect :: String -- ^ Data source name+ -> String -- ^ User identifier+ -> String -- ^ Authentication string (password)+ -> IO Connection -- ^ the returned value represents+ -- the new connection+connect server user authentication = connectHelper $ \hDBC ->+ withCString server $ \pServer ->+ withCString user $ \pUser ->+ withCString authentication $ \pAuthentication ->+ sqlConnect hDBC + pServer (fromIntegral sqlNts)+ pUser (fromIntegral sqlNts)+ pAuthentication (fromIntegral sqlNts)++-- | 'driverConnect' is an alternative to 'connect'. It supports data sources+-- that require more connection information than the three arguments in+-- 'connect' and data sources that are not defined in the system information.+driverConnect :: String -- ^ Connection string+ -> IO Connection -- ^ the returned value represents+ -- the new connection+driverConnect connString = connectHelper $ \hDBC -> + withCString connString $ \pConnString ->+ allocaBytes 1024 $ \pOutConnString ->+ alloca $ \pLen ->+ sqlDriverConnect hDBC + nullPtr + pConnString + sqlNts + pOutConnString 1024 + pLen + sqlDriverNoPrompt++-- |+connectHelper :: (HDBC -> IO SQLRETURN) -> IO Connection+connectHelper connectFunction = withForeignPtr myEnvironment $ \hEnv -> do+ hDBC <- alloca $ \ (phDBC :: Ptr HDBC) -> do+ res <- sqlAllocConnect hEnv phDBC+ handleSqlResult sqlHandleEnv hEnv res+ peek phDBC+ res <- connectFunction hDBC+ handleSqlResult sqlHandleDbc hDBC res+ refFalse <- newMVar False+ let connection + = Connection { connDisconnect = odbcDisconnect hDBC+ , connExecute = odbcExecute hDBC+ , connQuery = odbcQuery connection hDBC+ , connTables = odbcTables connection hDBC+ , connDescribe = odbcDescribe connection hDBC+ , connBeginTransaction = + beginTransaction myEnvironment hDBC+ , connCommitTransaction = + commitTransaction myEnvironment hDBC+ , connRollbackTransaction = + rollbackTransaction myEnvironment hDBC+ , connClosed = refFalse }+ return connection++{-|++-}+odbcDisconnect :: HDBC -- ^ ODBC handle+ -> IO ()+odbcDisconnect hDBC = do+ sqlDisconnect hDBC >>= handleSqlResult sqlHandleDbc hDBC+ sqlFreeConnect hDBC >>= handleSqlResult sqlHandleDbc hDBC++{-|++-}+odbcExecute :: HDBC -- ^ ODBC handle+ -> SQL -- ^ SQL Query+ -> IO ()+odbcExecute hDBC query = allocaBytes sizeOfHStmt $ \pStmt -> do+ res <- sqlAllocStmt hDBC pStmt+ handleSqlResult sqlHandleDbc hDBC res+ hSTMT <- peek pStmt+ withCStringLen query $ \(pQuery,len) -> do+ res <- sqlExecDirect hSTMT pQuery len+ handleSqlResult sqlHandleStmt hSTMT res+ res <- sqlFreeStmt hSTMT sqlDrop+ handleSqlResult sqlHandleStmt hSTMT res++{-|++-}+odbcQuery :: Connection + -> HDBC -- ^ ODBC handle+ -> String -- ^ SQL Query+ -> IO Statement+odbcQuery connection hDBC q = + withStatement connection hDBC doQuery+ where doQuery hSTMT = + withCStringLen q (uncurry (sqlExecDirect hSTMT))++{-|++-}+odbcTables :: Connection + -> HDBC -- ^ ODBC handle+ -> IO [String]+odbcTables connection hDBC = do+ stmt <- withStatement connection hDBC sqlTables'+ -- SQLTables returns (column names may vary):+ -- Column name # Type+ -- TABLE_NAME 3 VARCHAR+ collectRows (\s -> getFieldValue s "TABLE_NAME") stmt+ where sqlTables' hSTMT = sqlTables hSTMT nullPtr 0 + nullPtr 0 + nullPtr 0 + nullPtr 0++{-|+-}+odbcDescribe :: Connection + -> HDBCC -- ^ ODBC handle+ -> String -- ^ table name+ -> IO [FieldDef]+odbcDescribe connection hDBC table = do+ stmt <- withStatement connection hDBC (odbcSqlColumns table)+ collectRows getColumnInfo stmt++-- |+odbcSqlColumns table hSTMT =+ withCStringLen table (\(pTable,len) ->+ sqlColumns hSTMT nullPtr 0 + nullPtr 0 + pTable (fromIntegral len) + nullPtr 0)++-- | SQLColumns returns (column names may vary):+-- Column name # Type+-- COLUMN_NAME 4 Varchar not NULL+-- DATA_TYPE 5 Smallint not NULL+-- COLUMN_SIZE 7 Integer+-- DECIMAL_DIGITS 9 Smallint+-- NULLABLE 11 Smallint not NULL+getColumnInfo stmt = do+ column_name <- getFieldValue stmt "COLUMN_NAME"+ (data_type::Int) <- getFieldValue stmt "DATA_TYPE"+ (column_size::Int) <- getFieldValue' stmt "COLUMN_SIZE" 0+ (decimal_digits::Int) <- getFieldValue' stmt "DECIMAL_DIGITS" 0+ let sqlType = mkSqlType (fromIntegral data_type) + (fromIntegral column_size) + (fromIntegral decimal_digits)+ (nullable::Int) <- getFieldValue stmt "NULLABLE"+ return (column_name, sqlType, toBool nullable)++------------------------------------------------------------------------------+-- transaction management+------------------------------------------------------------------------------+{-|+-}+beginTransaction:: HENVRef-> HDBC-> IO ()+beginTransaction myEnvironment hDBC = do+ sqlSetConnectOption hDBC sqlAutoCommit sqlAutoCommitOff+ return ()++{-|+-}+commitTransaction:: HENVRef-> HDBC-> IO ()+commitTransaction myEnvironment hDBC = + withForeignPtr myEnvironment $ \hEnv -> do+ sqlTransact hEnv hDBC sqlCommit+ sqlSetConnectOption hDBC sqlAutoCommit sqlAutoCommitOn+ return ()++{-|+-}+rollbackTransaction:: HENVRef-> HDBC-> IO ()+rollbackTransaction myEnvironment hDBC = + withForeignPtr myEnvironment $ \hEnv -> do+ sqlTransact hEnv hDBC sqlRollback+ sqlSetConnectOption hDBC sqlAutoCommit sqlAutoCommitOn+ return ()++------------------------------------------------------------------------------+-- keeper of HENV+------------------------------------------------------------------------------+{-|+-}+{-# NOINLINE myEnvironment #-}+myEnvironment :: HENVRef+myEnvironment = unsafePerformIO $ alloca $ \ (phEnv :: Ptr HENV) -> do+ res <- sqlAllocEnv phEnv+ hEnv <- peek phEnv+ handleSqlResult 0 nullPtr res+ newForeignPtr sqlFreeEnv_p hEnv+
− Database/HSQL/ODBC.hsc
@@ -1,432 +0,0 @@-{-# OPTIONS -fglasgow-exts #-} - --------------------------------------------------------------------------------{-| Module : Database.HSQL.ODBC- Copyright : (c) Krasimir Angelov 2003- License : BSD-style-- Maintainer : kr.angelov@gmail.com- Stability : provisional- Portability : portable-- The module provides interface to ODBC--}---------------------------------------------------------------------------------module Database.HSQL.ODBC(connect, driverConnect, module Database.HSQL) where--import Database.HSQL-import Database.HSQL.Types-import Data.Word(Word32, Word16)-import Data.Int(Int32, Int16)-import Data.Maybe-import Foreign-import Foreign.C-import Control.Monad(unless)-import Control.OldException(throwDyn)-import Control.Concurrent.MVar-import System.IO.Unsafe-import System.Time-#ifdef DEBUG-import Debug.Trace-#endif--#include <time.h>-#include <HsODBC.h>--type SQLHANDLE = Ptr ()-type HENV = SQLHANDLE-type HDBC = SQLHANDLE-type HSTMT = SQLHANDLE-type HENVRef = ForeignPtr ()--type SQLSMALLINT = #type SQLSMALLINT-type SQLUSMALLINT = #type SQLUSMALLINT-type SQLINTEGER = #type SQLINTEGER-type SQLUINTEGER = #type SQLUINTEGER-type SQLRETURN = SQLSMALLINT-type SQLLEN = SQLINTEGER-type SQLULEN = SQLINTEGER--#ifdef mingw32_HOST_OS-#let CALLCONV = "stdcall"-#else-#let CALLCONV = "ccall"-#endif--foreign import #{CALLCONV} "HsODBC.h SQLAllocEnv" - sqlAllocEnv:: Ptr HENV -> IO SQLRETURN--#ifdef mingw32_HOST_OS-foreign import ccall "HsODBC.h &my_sqlFreeEnv" - sqlFreeEnv_p:: FunPtr (HENV -> IO ())-#else-foreign import ccall "HsODBC.h &SQLFreeEnv" - sqlFreeEnv_p:: FunPtr (HENV -> IO ())-#endif--foreign import #{CALLCONV} "HsODBC.h SQLAllocConnect" - sqlAllocConnect:: HENV -> Ptr HDBC -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLFreeConnect" - sqlFreeConnect:: HDBC -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLConnect" - sqlConnect:: HDBC -> CString -> Int -> CString -> Int -> CString -> Int - -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLDriverConnect" - sqlDriverConnect:: HDBC -> Ptr () -> CString -> SQLSMALLINT -> CString - -> SQLSMALLINT -> Ptr SQLSMALLINT -> SQLUSMALLINT - -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLDisconnect" - sqlDisconnect:: HDBC -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLAllocStmt" - sqlAllocStmt:: HDBC -> Ptr HSTMT -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLFreeStmt" - sqlFreeStmt:: HSTMT -> SQLUSMALLINT -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLNumResultCols" - sqlNumResultCols:: HSTMT -> Ptr SQLUSMALLINT -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLDescribeCol" - sqlDescribeCol:: HSTMT -> SQLUSMALLINT -> CString -> SQLSMALLINT - -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLULEN - -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT - -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLBindCol" - sqlBindCol:: HSTMT -> SQLUSMALLINT -> SQLSMALLINT -> Ptr a - -> SQLLEN -> Ptr SQLINTEGER - -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLFetch" - sqlFetch:: HSTMT -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLGetDiagRec" - sqlGetDiagRec:: SQLSMALLINT -> SQLHANDLE -> SQLSMALLINT -> CString - -> Ptr SQLINTEGER -> CString -> SQLSMALLINT -> Ptr SQLSMALLINT - -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLExecDirect" - sqlExecDirect:: HSTMT -> CString -> Int -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLSetConnectOption" - sqlSetConnectOption:: HDBC -> SQLUSMALLINT -> SQLULEN -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLTransact" - sqlTransact:: HENV -> HDBC -> SQLUSMALLINT -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLGetData" - sqlGetData:: HSTMT -> SQLUSMALLINT -> SQLSMALLINT -> Ptr () - -> SQLINTEGER -> Ptr SQLINTEGER - -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLTables" - sqlTables:: HSTMT -> CString -> SQLSMALLINT -> CString -> SQLSMALLINT - -> CString -> SQLSMALLINT -> CString -> SQLSMALLINT - -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLColumns" - sqlColumns:: HSTMT -> CString -> SQLSMALLINT -> CString -> SQLSMALLINT - -> CString -> SQLSMALLINT -> CString -> SQLSMALLINT - -> IO SQLRETURN-foreign import #{CALLCONV} "HsODBC.h SQLMoreResults" - sqlMoreResults:: HSTMT -> IO SQLRETURN--#if defined(MSSQL_ODBC)-foreign import #{CALLCONV} "HsODBC.h SQLSetStmtAttr" - sqlSetStmtAttr:: HSTMT -> SQLINTEGER -> SQLINTEGER -> SQLINTEGER - -> IO SQLRETURN -#endif----------------------------------------------------------------------------------- routines for handling exceptions---------------------------------------------------------------------------------handleSqlResult :: SQLSMALLINT -> SQLHANDLE -> SQLRETURN -> IO ()-handleSqlResult handleType handle res- | res == (#const SQL_SUCCESS) || res == (#const SQL_NO_DATA) = return ()- | res == (#const SQL_SUCCESS_WITH_INFO) = do-#ifdef DEBUG- e <- getSqlError- putTraceMsg (show e)-#else- return ()-#endif- | res == (#const SQL_INVALID_HANDLE) = throwDyn SqlInvalidHandle- | res == (#const SQL_STILL_EXECUTING) = throwDyn SqlStillExecuting- | res == (#const SQL_NEED_DATA) = throwDyn SqlNeedData- | res == (#const SQL_ERROR) = do- e <- getSqlError- throwDyn e- | otherwise = error (show res)- where- getSqlError =- allocaBytes 256 $ \pState ->- alloca $ \pNative ->- allocaBytes 256 $ \pMsg ->- alloca $ \pTextLen -> do- res <- sqlGetDiagRec handleType handle 1 - pState pNative pMsg 256 pTextLen- if res == (#const SQL_NO_DATA)- then return SqlNoData- else do- state <- peekCString pState- native <- peek pNative- msg <- peekCString pMsg- return (SqlError { seState=state- , seNativeError=fromIntegral native- , seErrorMsg=msg })----------------------------------------------------------------------------------- keeper of HENV---------------------------------------------------------------------------------{-# NOINLINE myEnvironment #-}-myEnvironment :: HENVRef-myEnvironment = unsafePerformIO $ alloca $ \ (phEnv :: Ptr HENV) -> do- res <- sqlAllocEnv phEnv- hEnv <- peek phEnv- handleSqlResult 0 nullPtr res- newForeignPtr sqlFreeEnv_p hEnv----------------------------------------------------------------------------------- Connect/Disconnect----------------------------------------------------------------------------------- | Makes a new connection to the ODBC data source-connect :: String -- ^ Data source name- -> String -- ^ User identifier- -> String -- ^ Authentication string (password)- -> IO Connection -- ^ the returned value represents the new connection-connect server user authentication = connectHelper $ \hDBC ->- withCString server $ \pServer ->- withCString user $ \pUser ->- withCString authentication $ \pAuthentication ->- sqlConnect hDBC - pServer (#const SQL_NTS) - pUser (#const SQL_NTS) - pAuthentication (#const SQL_NTS)---- | 'driverConnect' is an alternative to 'connect'. It supports data sources that --- require more connection information than the three arguments in 'connect' --- and data sources that are not defined in the system information.-driverConnect :: String -- ^ Connection string- -> IO Connection -- ^ the returned value represents the new connection-driverConnect connString = connectHelper $ \hDBC -> - withCString connString $ \pConnString ->- allocaBytes 1024 $ \pOutConnString ->- alloca $ \pLen ->- sqlDriverConnect hDBC nullPtr pConnString (#const SQL_NTS) pOutConnString 1024 pLen (#const SQL_DRIVER_NOPROMPT)--connectHelper :: (HDBC -> IO SQLRETURN) -> IO Connection-connectHelper connectFunction = withForeignPtr myEnvironment $ \hEnv -> do- hDBC <- alloca $ \ (phDBC :: Ptr HDBC) -> do- res <- sqlAllocConnect hEnv phDBC- handleSqlResult (#const SQL_HANDLE_ENV) hEnv res- peek phDBC- res <- connectFunction hDBC- handleSqlResult (#const SQL_HANDLE_DBC) hDBC res- refFalse <- newMVar False- let connection = (Connection- { connDisconnect = disconnect hDBC- , connExecute = execute hDBC- , connQuery = query connection hDBC- , connTables = tables connection hDBC- , connDescribe = describe connection hDBC- , connBeginTransaction = beginTransaction myEnvironment hDBC- , connCommitTransaction = commitTransaction myEnvironment hDBC- , connRollbackTransaction = rollbackTransaction myEnvironment hDBC- , connClosed = refFalse- })- return connection- where- disconnect :: HDBC -> IO ()- disconnect hDBC = do- sqlDisconnect hDBC >>= handleSqlResult (#const SQL_HANDLE_DBC) hDBC- sqlFreeConnect hDBC >>= handleSqlResult (#const SQL_HANDLE_DBC) hDBC-- execute :: HDBC -> String -> IO ()- execute hDBC query = allocaBytes (#const sizeof(HSTMT)) $- \pStmt -> do- res <- sqlAllocStmt hDBC pStmt- handleSqlResult (#const SQL_HANDLE_DBC) hDBC res- hSTMT <- peek pStmt- withCStringLen query $ \(pQuery,len) -> do- res <- sqlExecDirect hSTMT pQuery len- handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res- res <- sqlFreeStmt hSTMT (#const SQL_DROP)- handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res-- stmtBufferSize = 256-- withStatement :: Connection -> HDBC -> (HSTMT -> IO SQLRETURN) -> IO Statement- withStatement connection hDBC f = - allocaBytes (#const sizeof(FIELD)) $ \pFIELD -> do- res <- sqlAllocStmt hDBC ((#ptr FIELD, hSTMT) pFIELD)- handleSqlResult (#const SQL_HANDLE_DBC) hDBC res- hSTMT <- (#peek FIELD, hSTMT) pFIELD- let handleResult res = handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res-#if defined(MSSQL_ODBC)- sqlSetStmtAttr hSTMT (#const SQL_ATTR_ROW_ARRAY_SIZE) 2 (#const SQL_IS_INTEGER)- sqlSetStmtAttr hSTMT (#const SQL_ATTR_CURSOR_TYPE) (#const SQL_CURSOR_STATIC) (#const SQL_IS_INTEGER)-#endif- f hSTMT >>= handleResult- fields <- moveToFirstResult hSTMT pFIELD- buffer <- mallocBytes (fromIntegral stmtBufferSize)- refFalse <- newMVar False- let statement = Statement- { stmtConn = connection- , stmtClose = closeStatement hSTMT buffer- , stmtFetch = fetch hSTMT- , stmtGetCol = getColValue hSTMT buffer- , stmtFields = fields- , stmtClosed = refFalse- }- return statement- where- moveToFirstResult :: HSTMT -> Ptr a -> IO [FieldDef]- moveToFirstResult hSTMT pFIELD = do- res <- sqlNumResultCols hSTMT ((#ptr FIELD, fieldsCount) pFIELD)- handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res- count <- (#peek FIELD, fieldsCount) pFIELD- if count == 0- then do-#if defined(MSSQL_ODBC)- sqlSetStmtAttr hSTMT (#const SQL_ATTR_ROW_ARRAY_SIZE) 2 (#const SQL_IS_INTEGER)- sqlSetStmtAttr hSTMT (#const SQL_ATTR_CURSOR_TYPE) (#const SQL_CURSOR_STATIC) (#const SQL_IS_INTEGER)-#endif- res <- sqlMoreResults hSTMT- handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res- if res == (#const SQL_NO_DATA)- then return []- else moveToFirstResult hSTMT pFIELD- else- getFieldDefs hSTMT pFIELD 1 count-- getFieldDefs :: HSTMT -> Ptr a -> SQLUSMALLINT -> SQLUSMALLINT -> IO [FieldDef]- getFieldDefs hSTMT pFIELD n count- | n > count = return []- | otherwise = do- res <- sqlDescribeCol hSTMT n ((#ptr FIELD, fieldName) pFIELD) (#const FIELD_NAME_LENGTH) ((#ptr FIELD, NameLength) pFIELD) ((#ptr FIELD, DataType) pFIELD) ((#ptr FIELD, ColumnSize) pFIELD) ((#ptr FIELD, DecimalDigits) pFIELD) ((#ptr FIELD, Nullable) pFIELD)- handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res- name <- peekCString ((#ptr FIELD, fieldName) pFIELD)- dataType <- (#peek FIELD, DataType) pFIELD- columnSize <- (#peek FIELD, ColumnSize) pFIELD- decimalDigits <- (#peek FIELD, DecimalDigits) pFIELD- (nullable :: SQLSMALLINT) <- (#peek FIELD, Nullable) pFIELD- let sqlType = mkSqlType dataType columnSize decimalDigits- fields <- getFieldDefs hSTMT pFIELD (n+1) count- return ((name,sqlType,toBool nullable):fields)-- mkSqlType :: SQLSMALLINT -> SQLULEN -> SQLSMALLINT -> SqlType- mkSqlType (#const SQL_CHAR) size _ = SqlChar (fromIntegral size)- mkSqlType (#const SQL_VARCHAR) size _ = SqlVarChar (fromIntegral size)- mkSqlType (#const SQL_LONGVARCHAR) size _ = SqlLongVarChar (fromIntegral size)- mkSqlType (#const SQL_DECIMAL) size prec = SqlDecimal (fromIntegral size) (fromIntegral prec)- mkSqlType (#const SQL_NUMERIC) size prec = SqlNumeric (fromIntegral size) (fromIntegral prec)- mkSqlType (#const SQL_SMALLINT) _ _ = SqlSmallInt- mkSqlType (#const SQL_INTEGER) _ _ = SqlInteger- mkSqlType (#const SQL_REAL) _ _ = SqlReal- -- From: http://msdn.microsoft.com/library/en-us/odbc/htm/odappdpr_2.asp- -- "Depending on the implementation, the precision of SQL_FLOAT can be either 24 or 53:- -- if it is 24, the SQL_FLOAT data type is the same as SQL_REAL;- -- if it is 53, the SQL_FLOAT data type is the same as SQL_DOUBLE."- mkSqlType (#const SQL_FLOAT) _ _ = SqlFloat- mkSqlType (#const SQL_DOUBLE) _ _ = SqlDouble- mkSqlType (#const SQL_BIT) _ _ = SqlBit- mkSqlType (#const SQL_TINYINT) _ _ = SqlTinyInt- mkSqlType (#const SQL_BIGINT) _ _ = SqlBigInt- mkSqlType (#const SQL_BINARY) size _ = SqlBinary (fromIntegral size)- mkSqlType (#const SQL_VARBINARY) size _ = SqlVarBinary (fromIntegral size)- mkSqlType (#const SQL_LONGVARBINARY)size _ = SqlLongVarBinary (fromIntegral size)- mkSqlType (#const SQL_DATE) _ _ = SqlDate- mkSqlType (#const SQL_TIME) _ _ = SqlTime- mkSqlType (#const SQL_TIMESTAMP) _ _ = SqlDateTime- mkSqlType (#const SQL_WCHAR) size _ = SqlWChar (fromIntegral size)- mkSqlType (#const SQL_WVARCHAR) size _ = SqlWVarChar (fromIntegral size)- mkSqlType (#const SQL_WLONGVARCHAR) size _ = SqlWLongVarChar (fromIntegral size)- mkSqlType tp _ _ = SqlUnknown (fromIntegral tp)-- query :: Connection -> HDBC -> String -> IO Statement- query connection hDBC q = withStatement connection hDBC doQuery- where doQuery hSTMT = withCStringLen q (uncurry (sqlExecDirect hSTMT))-- beginTransaction myEnvironment hDBC = do- sqlSetConnectOption hDBC (#const SQL_AUTOCOMMIT) (#const SQL_AUTOCOMMIT_OFF)- return ()-- commitTransaction myEnvironment hDBC = withForeignPtr myEnvironment $ \hEnv -> do- sqlTransact hEnv hDBC (#const SQL_COMMIT)- sqlSetConnectOption hDBC (#const SQL_AUTOCOMMIT) (#const SQL_AUTOCOMMIT_ON)- return ()-- rollbackTransaction myEnvironment hDBC = withForeignPtr myEnvironment $ \hEnv -> do- sqlTransact hEnv hDBC (#const SQL_ROLLBACK)- sqlSetConnectOption hDBC (#const SQL_AUTOCOMMIT) (#const SQL_AUTOCOMMIT_ON)- return ()-- tables :: Connection -> HDBC -> IO [String]- tables connection hDBC = do- stmt <- withStatement connection hDBC sqlTables'- -- SQLTables returns (column names may vary):- -- Column name # Type- -- TABLE_NAME 3 VARCHAR- collectRows (\s -> getFieldValue s "TABLE_NAME") stmt- where sqlTables' hSTMT = sqlTables hSTMT nullPtr 0 nullPtr 0 nullPtr 0 nullPtr 0-- describe :: Connection -> HDBC -> String -> IO [FieldDef]- describe connection hDBC table = do- stmt <- withStatement connection hDBC (sqlColumns' table)- collectRows getColumnInfo stmt- where- sqlColumns' table hSTMT =- withCStringLen table (\(pTable,len) ->- sqlColumns hSTMT nullPtr 0 nullPtr 0 pTable (fromIntegral len) nullPtr 0)- -- SQLColumns returns (column names may vary):- -- Column name # Type- -- COLUMN_NAME 4 Varchar not NULL- -- DATA_TYPE 5 Smallint not NULL- -- COLUMN_SIZE 7 Integer- -- DECIMAL_DIGITS 9 Smallint- -- NULLABLE 11 Smallint not NULL-- getColumnInfo stmt = do- column_name <- getFieldValue stmt "COLUMN_NAME"- (data_type::Int) <- getFieldValue stmt "DATA_TYPE"- (column_size::Int) <- getFieldValue' stmt "COLUMN_SIZE" 0- (decimal_digits::Int) <- getFieldValue' stmt "DECIMAL_DIGITS" 0- (nullable::Int) <- getFieldValue stmt "NULLABLE"- let sqlType = mkSqlType (fromIntegral data_type) (fromIntegral column_size) (fromIntegral decimal_digits)- return (column_name, sqlType, toBool nullable)-- fetch :: HSTMT -> IO Bool- fetch hSTMT = do- res <- sqlFetch hSTMT- handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res- return (res /= (#const SQL_NO_DATA))-- getColValue :: HSTMT -> CString -> Int -> FieldDef -> (FieldDef -> CString -> Int -> IO a) -> IO a- getColValue hSTMT buffer colNumber fieldDef f = do- (res,len_or_ind) <- getData buffer (fromIntegral stmtBufferSize)- if len_or_ind == (#const SQL_NULL_DATA)- then f fieldDef nullPtr 0- else if res == (#const SQL_SUCCESS_WITH_INFO)- then getLongData len_or_ind- else f fieldDef buffer (fromIntegral len_or_ind)- where- getData :: CString -> SQLINTEGER -> IO (SQLRETURN, SQLINTEGER)- getData buffer size = alloca $ \lenP -> do- res <- sqlGetData hSTMT (fromIntegral colNumber+1) (#const SQL_C_CHAR) (castPtr buffer) size lenP- handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res- len_or_ind <- peek lenP- return (res, len_or_ind)-- -- gets called only when there is more data than would- -- fit in the normal buffer. This call to- -- SQLGetData() will fetch the rest of the data.- -- We create a new buffer big enough to hold the- -- old and the new data, copy the old data into- -- it and put the new data in buffer after the old.- getLongData len = allocaBytes (fromIntegral newBufSize) $ \newBuf -> do- copyBytes newBuf buffer stmtBufferSize- -- The last byte of the old data with always be null,- -- so it is overwritten with the first byte of the new data.- let newDataStart = newBuf `plusPtr` (stmtBufferSize - 1)- newDataLen = newBufSize - (fromIntegral stmtBufferSize - 1)- (res,_) <- getData newDataStart newDataLen- f fieldDef newBuf (fromIntegral newBufSize-1)- where- newBufSize = len+1 -- to allow for terminating null character-- closeStatement :: HSTMT -> CString -> IO ()- closeStatement hSTMT buffer = do- free buffer- sqlFreeStmt hSTMT (#const SQL_DROP) >>= handleSqlResult (#const SQL_HANDLE_STMT) hSTMT
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2009, Krasimir Angelov <kr.angelov@gmail.com>+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 the author 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 OWNER 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.
hsql-odbc.cabal view
@@ -1,12 +1,19 @@ name: hsql-odbc-version: 1.7.1+version: 1.8.1+Synopsis: A Haskell Interface to ODBC. license: BSD3+License-file: LICENSE author: Krasimir Angelov <kr.angelov@gmail.com> maintainer: nick.rudnick@googlemail.com category: Database description: ODBC driver for HSQL.-exposed-modules:Database.HSQL.ODBC-build-depends: base >= 4 && < 5, hsql >= 1.7, old-time >= 1.0.0.1+exposed-modules:+ Database.HSQL.ODBC+ DB.HSQL.ODBC.Type+ DB.HSQL.ODBC.Functions+ DB.HSQL.ODBC.Status+ DB.HSQL.ODBC.Core+build-depends: base >= 4 && < 5, hsql >= 1.8, old-time >= 1.0.0.1 extensions: ForeignFunctionInterface, CPP include-dirs: Database/HSQL c-sources: Database/HSQL/HsODBC.c