hsql-odbc-1.8.2: Database/HSQL/ODBC.hs
{-# 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