htoolkit-cvs

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

Update of /cvsroot/htoolkit/HSQL/Oracle/Database/HSQL
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24808/Oracle/Database/HSQL

Added Files:
	HsOCI.h Oracle.hsc 
Log Message:
Added Oracle driver. It isn't completed yet.


--- NEW FILE: HsOCI.h ---
#define _int64 long long

#include <oci.h>

#undef _int64

--- NEW FILE: Oracle.hsc ---
{-# OPTIONS -fglasgow-exts #-}

-----------------------------------------------------------------------------------------
{-| Module      :  Database.HSQL.Oracle
    Copyright   :  (c) Krasimir Angelov 2003
    License     :  BSD-style

    Maintainer  :  kr....@gm...
    Stability   :  provisional
    Portability :  portable

    The module provides interface to Oracle
-}
-----------------------------------------------------------------------------------------

module Database.HSQL.Oracle(connect, module Database.HSQL) where

import Database.HSQL
import Database.HSQL.Types
import Foreign
import Foreign.C
import Foreign.Concurrent as FC
import Control.Concurrent.MVar

#include <HsOCI.h>

type OCIHandle = Ptr ()
type OCIEnv    = OCIHandle
type OCIError  = OCIHandle
type OCISvcCtx = OCIHandle
type OCIStmt   = OCIHandle

type OCIEnvRef = ForeignPtr ()

foreign import ccall "OCIEnvCreate" ociEnvCreate :: Ptr OCIEnv -> CInt -> Ptr a -> FunPtr a -> FunPtr a -> FunPtr a -> CInt -> Ptr (Ptr a) -> IO CInt
foreign import ccall "OCITerminate" ociTerminate :: CInt -> IO CInt
foreign import ccall "OCIHandleAlloc" ociHandleAlloc :: OCIHandle -> Ptr OCIHandle -> CInt -> CInt -> Ptr a -> IO CInt
foreign import ccall "OCIHandleFree" ociHandleFree :: OCIHandle -> CInt -> IO CInt
foreign import ccall "OCIErrorGet" ociErrorGet :: OCIHandle -> CInt -> CString -> Ptr CInt -> CString -> CInt -> CInt -> IO CInt

foreign import ccall "OCILogon" ociLogon :: OCIEnv -> OCIError -> Ptr OCISvcCtx -> CString -> CInt -> CString -> CInt -> CString -> CInt -> IO CInt
foreign import ccall "OCILogoff" ociLogoff :: OCISvcCtx -> OCIError -> IO CInt

foreign import ccall "OCIStmtPrepare" ociStmtPrepare :: OCIStmt -> OCIError -> CString -> CInt -> CInt -> CInt -> IO CInt
foreign import ccall "OCIStmtExecute" ociStmtExecute :: OCISvcCtx -> OCIStmt -> OCIError -> CInt -> CInt -> OCIHandle -> OCIHandle -> CInt -> IO CInt

-----------------------------------------------------------------------------------------
-- keeper of OCIEnv
-----------------------------------------------------------------------------------------

{-# NOINLINE myEnvironment #-}
myEnvironment :: OCIEnvRef
myEnvironment = unsafePerformIO $ alloca $ \ (pOCIEnv :: Ptr OCIEnv) -> do
  ociEnvCreate pOCIEnv (#const OCI_DEFAULT) nullPtr nullFunPtr nullFunPtr nullFunPtr 0 nullPtr >>= handleSqlResult
  env <- peek pOCIEnv
  FC.newForeignPtr env terminate
  where
    terminate = ociTerminate (#const OCI_DEFAULT) >>= handleSqlResult

-----------------------------------------------------------------------------------------
-- allocate/deallocate handles
-----------------------------------------------------------------------------------------

allocHandle :: CInt -> OCIHandle -> IO OCIHandle
allocHandle handleType parent = 
  alloca $ \pHandle -> do
    ociHandleAlloc parent pHandle handleType 0 nullPtr >>= handleSqlResult
    peek pHandle

freeHandle :: CInt -> OCIHandle -> IO ()
freeHandle handleType handle =
  ociHandleFree handle handleType >>= handleSqlResult

-----------------------------------------------------------------------------------------
-- error handling
-----------------------------------------------------------------------------------------

handleSqlResult err
  | err == 0  = return ()
  | otherwise = putStrLn ("ERROR: "++show err)

-- | Makes a new connection to the Oracle service
connect :: String               -- ^ Service name
        -> String               -- ^ User identifier
        -> String               -- ^ Password
        -> IO Connection        -- ^ the returned value represents the new connection
connect service user pwd =
  withForeignPtr myEnvironment $ \env ->
  withCStringLen user    $ \(user, user_len) ->
  withCStringLen pwd     $ \(pwd, pwd_len) ->
  withCStringLen service $ \(service, service_len) ->
  alloca $ \pSvcCtx -> do
    err <- allocHandle (#const OCI_HTYPE_ERROR) env
    res <- ociLogon env err pSvcCtx user (fromIntegral user_len) pwd (fromIntegral pwd_len) service (fromIntegral service_len)
    if res == (#const OCI_SUCCESS_WITH_INFO)
      then handleSqlResult (#const OCI_ERROR)
      else handleSqlResult res
    svcCtx <- peek pSvcCtx
    refFalse <- newMVar False
    let connection = (Connection
    			{ connDisconnect = disconnect svcCtx err
    			, connExecute    = execute myEnvironment svcCtx err
    			, connQuery      = query connection myEnvironment svcCtx err
    			, connTables     = tables connection svcCtx
    			, connDescribe   = describe connection svcCtx
    			, connBeginTransaction = beginTransaction myEnvironment svcCtx
    			, connCommitTransaction = commitTransaction myEnvironment svcCtx
    			, connRollbackTransaction = rollbackTransaction myEnvironment svcCtx
    			, connClosed     = refFalse
    			})
    return connection
  where
    disconnect svcCtx err = do
      ociLogoff svcCtx err >>= handleSqlResult
      freeHandle (#const OCI_HTYPE_ERROR) err

    execute envRef svcCtx err query =
      withForeignPtr envRef $ \env ->
      withCStringLen query $ \(query,query_len) -> do
        stmt <- allocHandle (#const OCI_HTYPE_STMT) env
        ociStmtPrepare stmt err query (fromIntegral query_len) (#const OCI_NTV_SYNTAX) (#const OCI_DEFAULT) >>= handleSqlResult
        ociStmtExecute svcCtx stmt err 1 0 nullPtr nullPtr (#const OCI_DEFAULT) >>= handleSqlResult
        freeHandle (#const OCI_HTYPE_STMT) stmt

    query connection envRef svcCtx err query = 
      withForeignPtr envRef $ \env ->
      withCStringLen query $ \(query,query_len) -> do
        stmt <- allocHandle (#const OCI_HTYPE_STMT) env
	ociStmtPrepare stmt err query (fromIntegral query_len) (#const OCI_NTV_SYNTAX) (#const OCI_DEFAULT) >>= handleSqlResult
	ociStmtExecute svcCtx stmt err 1 0 nullPtr nullPtr (#const OCI_DEFAULT) >>= handleSqlResult
	let fields = []
	refFalse <- newMVar False
        let statement = Statement
		{ stmtConn   = connection
		, stmtClose  = closeStatement stmt
		, stmtFetch  = fetch stmt
		, stmtGetCol = getColValue stmt
		, stmtFields = fields
		, stmtClosed = refFalse
		}
        return statement

    tables connection svcCtx = undefined
    describe connection svcCtx = undefined
    beginTransaction myEnvironment svcCtx = undefined
    commitTransaction myEnvironment svcCtx = undefined
    rollbackTransaction myEnvironment svcCtx = undefined
    
    closeStatement stmt = undefined
    fetch stmt = undefined
    getColValue stmt = undefined