hsql-odbc-1.8.2/0000755000175000017500000000000011735606345010652 5ustar iihsql-odbc-1.8.2/ChangeLog0000644000175000017500000000023111331012370012375 0ustar ii2010-1-30 1.8.1.1: removed a silly typo; thank you, Don Steward ;-) 2010-1-29 1.8.1: uses updated exception handling of hsql-1.8.1; refactorings hsql-odbc-1.8.2/DB/0000755000175000017500000000000011330402441011115 5ustar iihsql-odbc-1.8.2/DB/HSQL/0000755000175000017500000000000011330402447011672 5ustar iihsql-odbc-1.8.2/DB/HSQL/ODBC/0000755000175000017500000000000011735606260012411 5ustar iihsql-odbc-1.8.2/DB/HSQL/ODBC/Functions.hsc0000644000175000017500000001161411330542720015052 0ustar ii{-# 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 hsql-odbc-1.8.2/DB/HSQL/ODBC/Status.hsc0000644000175000017500000000112111330523021014346 0ustar iimodule 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) hsql-odbc-1.8.2/DB/HSQL/ODBC/Type.hsc0000644000175000017500000000614611735606140014035 0ustar ii{-# 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 -- | 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 hsql-odbc-1.8.2/DB/HSQL/ODBC/Core.hsc0000644000175000017500000001461411735606074014011 0ustar ii{-# 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 [ColDef] 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 [ColDef] 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 SqlNeedMoreData | 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 SqlNoMoreData 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 -> ColDef -> (ColDef -> 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 hsql-odbc-1.8.2/LICENSE0000644000175000017500000000274311145152653011656 0ustar iiCopyright (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. hsql-odbc-1.8.2/Database/0000755000175000017500000000000010606514424012346 5ustar iihsql-odbc-1.8.2/Database/HSQL/0000755000175000017500000000000011735606264013125 5ustar iihsql-odbc-1.8.2/Database/HSQL/HsODBC.c0000600000175000017500000000052310606514424014253 0ustar ii#include "HsODBC.h" #if defined(mingw32_HOST_OS) // Under Windows SQLFreeEnv function has stdcall calling convention // while in Haskell functions represented with FunPtr must be always // with ccall convention. For that reason we need to redirect calling // to this function. void my_sqlFreeEnv(HENV hEnv) { SQLFreeEnv(hEnv); } #endif hsql-odbc-1.8.2/Database/HSQL/HsODBC.h0000600000175000017500000000073310606514424014263 0ustar ii#ifndef HsODBC #define HsODBC #ifdef mingw32_HOST_OS #include #endif #include #include #define FIELD_NAME_LENGTH 255 typedef struct { HSTMT hSTMT; SQLUSMALLINT fieldsCount; SQLCHAR fieldName[FIELD_NAME_LENGTH]; SQLSMALLINT NameLength; SQLSMALLINT DataType; SQLULEN ColumnSize; SQLSMALLINT DecimalDigits; SQLSMALLINT Nullable; } FIELD; #ifdef mingw32_HOST_OS void my_sqlFreeEnv(HENV hEnv); #endif #endif hsql-odbc-1.8.2/Database/HSQL/ODBC.hs0000644000175000017500000001703511735606224014172 0ustar ii{-# 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) 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 -> HDBC -- ^ ODBC handle -> String -- ^ table name -> IO [ColDef] 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 hsql-odbc-1.8.2/hsql-odbc.cabal0000600000175000017500000000121111735606345013475 0ustar iiname: hsql-odbc version: 1.8.2 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 DB.HSQL.ODBC.Type DB.HSQL.ODBC.Functions DB.HSQL.ODBC.Status DB.HSQL.ODBC.Core build-depends: base >= 4 && < 5, hsql >= 1.8.2, old-time >= 1.0.0.1 extensions: ForeignFunctionInterface, CPP include-dirs: Database/HSQL c-sources: Database/HSQL/HsODBC.c extra-source-files: Database/HSQL/HsODBC.h build-type: Simple extra-libraries: odbc hsql-odbc-1.8.2/Setup.lhs0000600000175000017500000000153711250472161012445 0ustar ii#!/usr/bin/runghc \begin{code} import Distribution.Simple(defaultMainWithHooks ,simpleUserHooks ,preConf) import Distribution.Simple.Setup(ConfigFlags) import Distribution.PackageDescription.Parse(writeHookedBuildInfo) import Distribution.PackageDescription (HookedBuildInfo ,BuildInfo(extraLibs ,ccOptions) ,emptyBuildInfo) import System.Info(os) main = defaultMainWithHooks simpleUserHooks{ preConf=configure } where configure:: [String]-> ConfigFlags-> IO HookedBuildInfo configure args flags = do let binfo | os == "mingw32" = emptyBuildInfo{ extraLibs=["odbc32"] , ccOptions=["-Dmingw32_HOST_OS"] } | otherwise = emptyBuildInfo{ extraLibs=["odbc"] } hbi = (Just binfo ,[]) writeHookedBuildInfo "ODBC.buildinfo" hbi return hbi \end{code}