[htoolkit-cvs] HSQL/ODBC HSQL.hsc,NONE,1.1 HSQLStructs.h,NONE,1.1

[<kr_...@us...>]

Update of /cvsroot/htoolkit/HSQL/ODBC
In directory sc8-pr-cvs1:/tmp/cvs-serv9791/ODBC

Added Files:
	HSQL.hsc HSQLStructs.h 
Log Message:
Full redesign of build system


--- NEW FILE: HSQL.hsc ---
-----------------------------------------------------------------------------------------
{-| Module      :  Database.ODBC.HSQL
    Copyright   :  (c) Krasimir Angelov 2003
    License     :  BSD-style

    Maintainer  :  ka2...@ya...
    Stability   :  provisional
    Portability :  portable
    
    The module provides interface to ODBC
-}
-----------------------------------------------------------------------------------------

module Database.ODBC.HSQL
		( SqlBind(..), SqlError(..), SqlType(..), Connection, Statement
		, catchSql		-- :: IO a -> (SqlError -> IO a) -> IO a
		, handleSql		-- :: (SqlError -> IO a) -> IO a -> IO a
		, sqlExceptions		-- :: Exception -> Maybe SqlError
		, connect		-- :: String -> String -> String -> IO Connection
		, disconnect		-- :: Connection -> IO ()
		, execute		-- :: Connection -> String -> IO ()
		, query			-- :: Connection -> String -> IO Statement
		, closeStatement	-- :: Statement -> IO ()
		, fetch			-- :: Statement -> IO Bool
		, inTransaction		-- :: Connection -> (Connection -> IO a) -> IO a
		, getFieldValueMB	-- :: SqlBind a => Statement -> String -> IO (Maybe a)
		, getFieldValue		-- :: SqlBind a => Statement -> String -> IO a
		, getFieldValue'	-- :: SqlBind a => Statement -> String -> a -> IO a
		, getFieldValueType	-- :: Statement -> String -> (SqlType, Bool)
		, getFieldsTypes	-- :: Statement -> [(String, SqlType, Bool)]
		, forEachRow		-- :: (Statement -> s -> IO s) -> Statement -> s -> IO s
		, forEachRow'		-- :: (Statement -> IO ()) -> Statement -> IO ()
		, collectRows		-- :: (Statement -> IO s) -> Statement -> IO [s]
		) where

import Data.Word(Word32, Word16)
import Data.Int(Int32, Int16)
import Data.IORef
import Data.Dynamic
import Foreign
import Foreign.C
import qualified Foreign.Concurrent as C
import Control.Monad(when,unless)
import Control.Exception (throwDyn, catchDyn, dynExceptions, Exception(..))
import System.IO.Unsafe
import System.Time

#include <time.h>
#include <HSQLStructs.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

foreign import stdcall "sqlext.h SQLAllocEnv" sqlAllocEnv :: Ptr HENV -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLFreeEnv" sqlFreeEnv :: HENV -> IO ()
foreign import stdcall "sqlext.h SQLAllocConnect" sqlAllocConnect :: HENV -> Ptr HDBC -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLFreeConnect" sqlFreeConnect:: HDBC -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLConnect" sqlConnect :: HDBC -> CString -> Int -> CString -> Int -> CString -> Int -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLDisconnect" sqlDisconnect :: HDBC -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLAllocStmt" sqlAllocStmt :: HDBC -> Ptr HSTMT -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLFreeStmt" sqlFreeStmt :: HSTMT -> SQLUSMALLINT -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLNumResultCols" sqlNumResultCols :: HSTMT -> Ptr SQLUSMALLINT -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLDescribeCol" sqlDescribeCol :: HSTMT -> SQLUSMALLINT -> CString -> SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLULEN -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLBindCol" sqlBindCol :: HSTMT -> SQLUSMALLINT -> SQLSMALLINT -> Ptr a -> SQLLEN -> Ptr SQLINTEGER -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLFetch" sqlFetch :: HSTMT -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLGetDiagRec" sqlGetDiagRec :: SQLSMALLINT -> SQLHANDLE -> SQLSMALLINT -> CString -> Ptr SQLINTEGER -> CString -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLExecDirect" sqlExecDirect :: HSTMT -> CString -> Int -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLSetConnectOption" sqlSetConnectOption :: HDBC -> SQLUSMALLINT -> SQLULEN -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLTransact" sqlTransact :: HENV -> HDBC -> SQLUSMALLINT -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLGetData" sqlGetData :: HSTMT -> SQLUSMALLINT -> SQLSMALLINT -> Ptr () -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN


-- | A 'Connection' type represents a connection to a data source, through which you can operate on the data source. 
-- A data source is a specific instance of data hosted by some database management system.
data Connection
  =  Connection
		{ hDBC :: HDBC
		, environment :: HENVRef
		}

data Statement
  =  Statement
		{ hSTMT	          :: !HSTMT
		, connection	  :: !Connection
		, fields          :: ![FieldDef]
		, fetchBuffer	  :: !(Ptr ())
		, fetchBufferSize :: !SQLINTEGER
		}

type FieldDef = (String, SqlType, Bool)

data SqlType	
	= SqlChar			Int
	| SqlVarChar		Int
	| SqlLongVarChar	Int
	| SqlDecimal		Int Int
	| SqlNumeric		Int Int
	| SqlSmallInt
	| SqlInteger
	| SqlReal
	| SqlDouble
	| SqlBit
	| SqlTinyInt
	| SqlBigInt
	| SqlBinary			Int
	| SqlVarBinary		Int
	| SqlLongVarBinary  Int
	| SqlDate
	| SqlTime
	| SqlTimeStamp
	deriving (Eq, Show)
	
data SqlError
   = SqlError
		{ seState		:: String
		, seNativeError	:: Int
		, seErrorMsg	:: String
		}
   | SqlNoData
   | SqlInvalidHandle
   | SqlStillExecuting
   | SqlNeedData
   deriving Show
   
-----------------------------------------------------------------------------------------
-- routines for handling exceptions
-----------------------------------------------------------------------------------------

{-# NOINLINE sqlErrorTy #-}
sqlErrorTy = mkAppTy (mkTyCon "SqlError") []

instance Typeable SqlError where
	typeOf x = sqlErrorTy

catchSql :: IO a -> (SqlError -> IO a) -> IO a
catchSql = catchDyn

handleSql :: (SqlError -> IO a) -> IO a -> IO a
handleSql h f = catchDyn f h

sqlExceptions :: Exception -> Maybe SqlError
sqlExceptions e = dynExceptions e >>= fromDynamic

sqlSuccess :: SQLRETURN -> Bool
sqlSuccess res = 
	(res == (#const SQL_SUCCESS)) || (res == (#const SQL_SUCCESS_WITH_INFO)) || (res == (#const SQL_NO_DATA))

handleSqlResult :: SQLSMALLINT -> SQLHANDLE -> SQLRETURN -> IO ()
handleSqlResult handleType handle res
	| sqlSuccess res = return ()
	| 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	
		pState  <- mallocBytes 256
		pNative <- malloc
		pMsg    <- mallocBytes 256
		pTextLen <- malloc
		sqlGetDiagRec handleType handle 1 pState pNative pMsg 256 pTextLen
		state <- peekCString pState
		free pState
		native <- peek pNative
		free pNative
		msg <- peekCString pMsg
		free pMsg
		free pTextLen	
		throwDyn (SqlError {seState=state, seNativeError=fromIntegral native, seErrorMsg=msg})
	| otherwise = error (show res)

-----------------------------------------------------------------------------------------
-- keeper of HENV
-----------------------------------------------------------------------------------------

{-# NOINLINE myEnvironment #-}
myEnvironment :: HENVRef
myEnvironment = unsafePerformIO $ do
	(phEnv :: Ptr HENV) <- malloc
	res <- sqlAllocEnv phEnv
	hEnv <- peek phEnv
	free phEnv
	handleSqlResult 0 nullPtr res
	C.newForeignPtr hEnv (sqlFreeEnv hEnv)

-----------------------------------------------------------------------------------------
-- Connect/Disconnect
-----------------------------------------------------------------------------------------

connect :: String -> String -> String -> IO Connection
connect server user authentication = withForeignPtr myEnvironment $ \hEnv -> do
	(phDBC :: Ptr HDBC) <- malloc
	res <- sqlAllocConnect hEnv phDBC
	hDBC <- peek phDBC
	free phDBC
	handleSqlResult (#const SQL_HANDLE_ENV) hEnv res
	pServer <- newCString server
	pUser <- newCString user
	pAuthentication <- newCString authentication
	res <- sqlConnect hDBC pServer (length server) pUser (length user) pAuthentication (length authentication)
	free pServer
	free pUser
	free pAuthentication
	handleSqlResult (#const SQL_HANDLE_ENV) hEnv res
	return (Connection {hDBC=hDBC, environment=myEnvironment})
	
disconnect :: Connection -> IO ()
disconnect (Connection {hDBC=hDBC}) = do
	sqlDisconnect hDBC >>= handleSqlResult (#const SQL_HANDLE_DBC) hDBC
	sqlFreeConnect hDBC >>= handleSqlResult (#const SQL_HANDLE_DBC) hDBC
	return ()
	
-----------------------------------------------------------------------------------------
-- queries
-----------------------------------------------------------------------------------------

execute :: Connection -> String -> IO ()
execute conn@(Connection {hDBC=hDBC}) query = do
	pFIELD <- mallocBytes (#const sizeof(FIELD))
	res <- sqlAllocStmt hDBC ((#ptr FIELD, hSTMT) pFIELD)
	unless (sqlSuccess res) (free pFIELD)
	handleSqlResult (#const SQL_HANDLE_DBC) hDBC res
	hSTMT <- (#peek FIELD, hSTMT) pFIELD
	let handleResult res = do
		unless (sqlSuccess res) (free pFIELD)
		handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res
	pQuery <- newCString query
	res <- sqlExecDirect hSTMT pQuery (length query)
	free pQuery
	handleResult res
	sqlFreeStmt hSTMT 0 >>= handleSqlResult (#const SQL_HANDLE_STMT) hSTMT
	free pFIELD

query :: Connection -> String -> IO Statement
query conn@(Connection {hDBC=hDBC}) query = do
	pFIELD <- mallocBytes (#const sizeof(FIELD))	
	res <- sqlAllocStmt hDBC ((#ptr FIELD, hSTMT) pFIELD)
	unless (sqlSuccess res) (free pFIELD)
	handleSqlResult (#const SQL_HANDLE_DBC) hDBC res
	hSTMT <- (#peek FIELD, hSTMT) pFIELD
	let handleResult res = do
		unless (sqlSuccess res) (free pFIELD)
		handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res
	pQuery <- newCString query
	res <- sqlExecDirect hSTMT pQuery (length query)
	free pQuery
	handleResult res
	sqlNumResultCols hSTMT ((#ptr FIELD, fieldsCount) pFIELD) >>= handleResult
	count <- (#peek FIELD, fieldsCount) pFIELD
	(fields, bufSize) <- getFieldDefs hSTMT pFIELD 1 count
	free pFIELD
	buffer <- mallocBytes (fromIntegral (bufSize+(#const sizeof(SQLINTEGER))))
	let statement = Statement {hSTMT=hSTMT, connection=conn, fields=fields, fetchBuffer=buffer, fetchBufferSize=bufSize}
	return statement
	where
		getFieldDefs :: HSTMT -> Ptr a -> SQLUSMALLINT -> SQLUSMALLINT -> IO ([FieldDef], SQLINTEGER)
		getFieldDefs hSTMT pFIELD n count
			| n > count  = return ([], 0)
			| 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)
				unless (sqlSuccess res) (free 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, bufSize) = mkSqlType dataType columnSize decimalDigits
				(fields, fullBufSize) <- getFieldDefs hSTMT pFIELD (n+1) count
				return ((name,sqlType,toBool nullable):fields, max bufSize fullBufSize)
				
		mkSqlType :: SQLSMALLINT -> SQLULEN -> SQLSMALLINT -> (SqlType, SQLINTEGER)
		mkSqlType (#const SQL_CHAR)		size 	_	= (SqlChar (fromIntegral size), (#const sizeof(SQLCHAR))*(fromIntegral size+1))
		mkSqlType (#const SQL_VARCHAR)		size 	_	= (SqlVarChar (fromIntegral size), (#const sizeof(SQLCHAR))*(fromIntegral size+1))
		mkSqlType (#const SQL_LONGVARCHAR)	size 	_	= (SqlLongVarChar (fromIntegral size), 1) -- dummy bufSize
		mkSqlType (#const SQL_DECIMAL)		size 	prec	= (SqlDecimal (fromIntegral size) (fromIntegral prec), (#const sizeof(SQLDOUBLE)))
		mkSqlType (#const SQL_NUMERIC)		size 	prec	= (SqlNumeric (fromIntegral size) (fromIntegral prec), (#const sizeof(SQLDOUBLE)))
		mkSqlType (#const SQL_SMALLINT)		_    	_	= (SqlSmallInt, (#const sizeof(SQLSMALLINT)))
		mkSqlType (#const SQL_INTEGER)		_    	_	= (SqlInteger, (#const sizeof(SQLINTEGER)))
		mkSqlType (#const SQL_REAL)		_    	_	= (SqlReal, (#const sizeof(SQLDOUBLE)))
		mkSqlType (#const SQL_DOUBLE)		_    	_	= (SqlDouble, (#const sizeof(SQLDOUBLE)))
		mkSqlType (#const SQL_BIT)		_	_	= (SqlBit, (#const sizeof(SQLINTEGER)))
		mkSqlType (#const SQL_TINYINT)		_	_	= (SqlTinyInt, (#const sizeof(SQLSMALLINT)))
		mkSqlType (#const SQL_BIGINT)		_	_	= (SqlBigInt, (#const sizeof(SQLINTEGER)))
		mkSqlType (#const SQL_BINARY)		size 	_	= (SqlBinary (fromIntegral size), (#const sizeof(SQLCHAR))*(fromIntegral size+1))
		mkSqlType (#const SQL_VARBINARY)	size 	_	= (SqlVarBinary (fromIntegral size), (#const sizeof(SQLCHAR))*(fromIntegral size+1))
		mkSqlType (#const SQL_LONGVARBINARY)size _		= (SqlLongVarBinary (fromIntegral size), 1) -- dummy bufSize
		mkSqlType (#const SQL_DATE)		_	_	= (SqlDate, (#const sizeof(SQL_DATE_STRUCT)))
		mkSqlType (#const SQL_TIME)		_	_	= (SqlTime, (#const sizeof(SQL_TIME_STRUCT)))
		mkSqlType (#const SQL_TIMESTAMP)	_	_	= (SqlTimeStamp, (#const sizeof(SQL_TIMESTAMP_STRUCT)))


{-# NOINLINE fetch #-}
fetch :: Statement -> IO Bool
fetch stmt = do
	res <- sqlFetch (hSTMT stmt)
	handleSqlResult (#const SQL_HANDLE_STMT) (hSTMT stmt) res
	return (res /= (#const SQL_NO_DATA))
	

closeStatement :: Statement -> IO ()
closeStatement stmt = do
	free (fetchBuffer stmt)
	sqlFreeStmt (hSTMT stmt) 0 >>= handleSqlResult (#const SQL_HANDLE_STMT) (hSTMT stmt)

-----------------------------------------------------------------------------------------
-- transactions
-----------------------------------------------------------------------------------------

inTransaction :: Connection -> (Connection -> IO a) -> IO a
inTransaction conn@(Connection {hDBC=hDBC, environment=envRef}) action = withForeignPtr envRef $ \hEnv -> do
	sqlSetConnectOption hDBC (#const SQL_AUTOCOMMIT) (#const SQL_AUTOCOMMIT_OFF)
	r <- catchSql (action conn) (\err -> do
			sqlTransact hEnv hDBC (#const SQL_ROLLBACK)
			sqlSetConnectOption hDBC (#const SQL_AUTOCOMMIT) (#const SQL_AUTOCOMMIT_ON)
			throwDyn err)
	sqlTransact hEnv hDBC (#const SQL_COMMIT)
	sqlSetConnectOption hDBC (#const SQL_AUTOCOMMIT) (#const SQL_AUTOCOMMIT_ON)
	return r
-----------------------------------------------------------------------------------------
-- binding
-----------------------------------------------------------------------------------------

class SqlBind a where
	getSqlValue :: SqlType -> Ptr () -> Int -> IO a

instance SqlBind Int where
	getSqlValue SqlInteger ptr size = peek (castPtr ptr)
	getSqlValue SqlSmallInt ptr size = do
		(n :: Int16) <- peek (castPtr ptr)
		return (fromIntegral n)
		
instance SqlBind Integer where
	getSqlValue SqlInteger ptr size = do
		(n :: Int32) <- peek (castPtr ptr)
		return (fromIntegral n)
	getSqlValue SqlSmallInt ptr size = do
		(n :: Int16) <- peek (castPtr ptr)
		return (fromIntegral n)
	getSqlValue SqlBigInt ptr size = do
		str <- peekCStringLen (castPtr ptr, size)
		return (read str)
	
instance SqlBind String where
	getSqlValue (SqlChar _) ptr size = peekCStringLen (castPtr ptr, size)
	getSqlValue (SqlVarChar _) ptr size = peekCStringLen (castPtr ptr, size)
	getSqlValue (SqlLongVarChar _) ptr size = peekCStringLen (castPtr ptr, size)
		
instance SqlBind Double where
	getSqlValue (SqlDecimal _ _) ptr size = peek (castPtr ptr)
	getSqlValue (SqlNumeric _ _) ptr size = peek (castPtr ptr)
	getSqlValue SqlDouble ptr size = peek (castPtr ptr)
	getSqlValue SqlReal ptr size = peek (castPtr ptr)
	
instance SqlBind ClockTime where
	getSqlValue SqlDate ptr size = allocaBytes (#const sizeof(struct tm)) $ \p_tm -> do
		(year :: SQLSMALLINT) <- (#peek TIMESTAMP_STRUCT, year) ptr
		(#poke struct tm,tm_year ) p_tm	(fromIntegral (year-1900) :: CInt)
		(month :: SQLUSMALLINT) <- (#peek TIMESTAMP_STRUCT, month) ptr
		(#poke struct tm,tm_mon ) p_tm	(fromIntegral (month-1) :: CInt)
		(day :: SQLUSMALLINT) <- (#peek TIMESTAMP_STRUCT, day) ptr
		(#poke struct tm,tm_mday) p_tm	(fromIntegral day :: CInt)
		(hour :: SQLUSMALLINT) <- (#peek TIMESTAMP_STRUCT, hour) ptr
		(#poke struct tm,tm_hour ) p_tm	(fromIntegral hour :: CInt)
		(minute :: SQLUSMALLINT) <- (#peek TIMESTAMP_STRUCT, minute) ptr
		(#poke struct tm,tm_min   ) p_tm	(fromIntegral minute  :: CInt)
		(second :: SQLUSMALLINT) <- (#peek TIMESTAMP_STRUCT, second) ptr
		(#poke struct tm,tm_sec   ) p_tm	(fromIntegral second  :: CInt)
		(fraction :: SQLUINTEGER) <- (#peek TIMESTAMP_STRUCT, fraction) ptr			
		(#poke struct tm,tm_isdst) p_tm	(-1 :: CInt)
		t <- mktime p_tm
		return (TOD (fromIntegral t) (fromIntegral fraction*1000))
foreign import ccall unsafe mktime :: Ptr () -> IO CTime	

getFieldValueMB :: SqlBind a => Statement -> String -> IO (Maybe a)
getFieldValueMB (Statement {hSTMT=hSTMT, fields=fields, fetchBuffer=buffer, fetchBufferSize=bufferSize}) name = do
	let dataBuffer = buffer `plusPtr` (#const sizeof(SQLINTEGER))
	res <- sqlGetData hSTMT colNumber targetType dataBuffer bufferSize (castPtr buffer)
	handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res
	(len_or_ind :: SQLINTEGER) <- peek (castPtr buffer)
	if len_or_ind == (#const SQL_NULL_DATA) 
		then return Nothing
		else fmap Just $
				(if res == (#const SQL_SUCCESS_WITH_INFO)
					then getLongData len_or_ind
					else getSqlValue sqlType dataBuffer (fromIntegral len_or_ind))
	where
		(sqlType,nullable,colNumber) = findFieldInfo name fields 1
		
		getLongData len = do
			buffer <- mallocBytes (fromIntegral (len+(#const sizeof(SQLINTEGER))+1))
			let dataBuffer = buffer `plusPtr` (#const sizeof(SQLINTEGER))
			res <- sqlGetData hSTMT colNumber targetType dataBuffer (len+1) (castPtr buffer)
			unless (sqlSuccess res) (free buffer)
			handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res
			(len_or_ind :: SQLINTEGER) <- peek (castPtr buffer)
			r <- getSqlValue sqlType dataBuffer (fromIntegral len_or_ind)
			free buffer
			return r
			
		targetType = case sqlType of
			SqlBit			-> (#const SQL_C_BIT)
			SqlTinyInt		-> (#const SQL_C_UTINYINT)
			SqlSmallInt		-> (#const SQL_C_SSHORT)
			SqlInteger		-> (#const SQL_C_SLONG)
			SqlReal			-> (#const SQL_C_FLOAT)
			SqlDouble		-> (#const SQL_C_DOUBLE)
			SqlDate			-> (#const SQL_C_TIMESTAMP)
			SqlTime			-> (#const SQL_C_TIMESTAMP)
			SqlTimeStamp		-> (#const SQL_C_TIMESTAMP)
			SqlNumeric _ _		-> (#const SQL_C_DOUBLE)
			SqlDecimal _ _		-> (#const SQL_C_DOUBLE)
			SqlBigInt		-> (#const SQL_C_CHAR)
			SqlChar _		-> (#const SQL_C_CHAR)
			SqlVarChar _		-> (#const SQL_C_CHAR)			
			SqlBinary _		-> (#const SQL_C_BINARY)
			SqlVarBinary _		-> (#const SQL_C_BINARY)
			SqlLongVarChar _	-> (#const SQL_C_CHAR)
			SqlLongVarBinary _	-> (#const SQL_C_BINARY)

getFieldValue :: SqlBind a => Statement -> String -> IO a
getFieldValue stmt name = do
	mb_v <- getFieldValueMB stmt name
	case mb_v of 
		Nothing -> fail ("Column \"" ++ name ++ "\" has null value")
		Just a -> return a

getFieldValue' :: SqlBind a => Statement -> String -> a -> IO a
getFieldValue' stmt name def = do
	mb_v <- getFieldValueMB stmt name
	return (case mb_v of { Nothing -> def; Just a -> a })
	
getFieldValueType :: Statement -> String -> (SqlType, Bool)
getFieldValueType stmt name = (sqlType, nullable)
	where
		(sqlType,nullable,colNumber) = findFieldInfo name (fields stmt) 1

getFieldsTypes :: Statement -> [(String, SqlType, Bool)]
getFieldsTypes = fields

findFieldInfo :: String -> [FieldDef] -> SQLUSMALLINT -> (SqlType,Bool,SQLUSMALLINT)
findFieldInfo name [] colNumber = error ("Undefined column name \"" ++ name ++ "\"")
findFieldInfo name (fieldDef@(name',sqlType,nullable):fields) colNumber
	| name == name' = (sqlType,nullable,colNumber)
	| otherwise		= findFieldInfo name fields (colNumber+1)

-----------------------------------------------------------------------------------------
-- helpers
-----------------------------------------------------------------------------------------

forEachRow :: (Statement -> s -> IO s) -> Statement -> s -> IO s
forEachRow f stmt s = do
	success <- fetch stmt
	if success then f stmt s >>= forEachRow f stmt else closeStatement stmt >> return s
	
forEachRow' :: (Statement -> IO ()) -> Statement -> IO ()
forEachRow' f stmt = do
	success <- fetch stmt
	if success then f stmt >> forEachRow' f stmt else closeStatement stmt
	
collectRows :: (Statement -> IO a) -> Statement -> IO [a]
collectRows f stmt = loop
	where 
		loop = do
			success <- fetch stmt
			if success
				then do
					x <- f stmt
					xs <- loop
					return (x:xs)
				else closeStatement stmt >> return []

--- NEW FILE: HSQLStructs.h ---
#ifdef WIN32
#include <windows.h>
#endif

#include <sqlext.h>

#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 WIN32
void sqlFreeEnv(HENV hEnv);
#else
#define sqlFreeEnv SQLFreeEnv
#endif