diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,2 @@ +2010-1-29 + 1.8.1: uses updated exception handling of hsql-1.8.1; refactorings diff --git a/DB/HSQL/ODBC/Core.hsc b/DB/HSQL/ODBC/Core.hsc new file mode 100644 --- /dev/null +++ b/DB/HSQL/ODBC/Core.hsc @@ -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 + +-- | +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 diff --git a/DB/HSQL/ODBC/Functions.hsc b/DB/HSQL/ODBC/Functions.hsc new file mode 100644 --- /dev/null +++ b/DB/HSQL/ODBC/Functions.hsc @@ -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 + +#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 needed?? +sqlAttrRowArraySize = #const SQL_ATTR_ROW_ARRAY_SIZE + +sqlIsInteger = #const SQL_IS_INTEGER + +sqlAttrCursorType = #const SQL_ATTR_CURSOR_TYPE + +sqlCursorStatic = #const SQL_CURSOR_STATIC + diff --git a/DB/HSQL/ODBC/Status.hsc b/DB/HSQL/ODBC/Status.hsc new file mode 100644 --- /dev/null +++ b/DB/HSQL/ODBC/Status.hsc @@ -0,0 +1,26 @@ +module DB.HSQL.ODBC.Status where + +import DB.HSQL.ODBC.Type(SQLRETURN,SQLSMALLINT,SQLUSMALLINT,SQLULEN) + +#include + +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) diff --git a/DB/HSQL/ODBC/Type.hsc b/DB/HSQL/ODBC/Type.hsc new file mode 100644 --- /dev/null +++ b/DB/HSQL/ODBC/Type.hsc @@ -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 + +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 + diff --git a/Database/HSQL/ODBC.hs b/Database/HSQL/ODBC.hs new file mode 100644 --- /dev/null +++ b/Database/HSQL/ODBC.hs @@ -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 + diff --git a/Database/HSQL/ODBC.hsc b/Database/HSQL/ODBC.hsc deleted file mode 100644 --- a/Database/HSQL/ODBC.hsc +++ /dev/null @@ -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 -#include - -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2009, Krasimir Angelov +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. diff --git a/hsql-odbc.cabal b/hsql-odbc.cabal --- a/hsql-odbc.cabal +++ b/hsql-odbc.cabal @@ -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 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