-- |

-- Module      :  Database.Oracle.OCIFunctions

-- Copyright   :  (c) 2004 Oleg Kiselyov, Alistair Bayley

-- License     :  BSD-style

-- Maintainer  :  oleg@pobox.com, alistair@abayley.org

-- Stability   :  experimental

-- Portability :  non-portable



-- Simple wrappers for OCI functions (FFI).



-- The functions in this file are simple wrappers for OCI functions.

-- The wrappers add error detection and exceptions;

-- functions in this module raise 'OCIException'.

-- The next layer up traps these and turns them into 'Database.Enumerator.DBException'.



-- Note that 'OCIException' /does not/ contain the error number and text

-- returned by 'getOCIErrorMsg'.

-- It is the job of the next layer (module) up to catch the 'OCIException'

-- and then call 'getOCIErrorMsg' to get the actual error details.

-- The 'OCIException' simply contains the error number returned by

-- the OCI call, and some text identifying the wrapper function.

-- See 'formatErrorCodeDesc' for the set of possible values for the OCI error numbers.



{-# LANGUAGE ForeignFunctionInterface #-}

{-# LANGUAGE DeriveDataTypeable #-}





module Database.Oracle.OCIFunctions where





import Prelude hiding (catch)

import Database.Oracle.OCIConstants

import Database.Util

import Foreign

import Foreign.C

import Control.Monad

import Control.Exception

import Data.Dynamic

import Data.Time

import System.Time





-- |

--  * Each handle type has its own data type, to prevent stupid errors

--    i.e. using the wrong handle at the wrong time.



--  * In GHC you can simply say @data OCIStruct@ i.e. there's no need for @= OCIStruct@.

--    I've decided to be more portable, as it doesn't cost much.



--  * Use castPtr if you need to convert handles (say 'OCIHandle' to a more specific type, or vice versa).



data OCIStruct = OCIStruct

type OCIHandle = Ptr OCIStruct  -- generic Handle for OCI functions that return Handles

data OCIBuffer = OCIBuffer  -- generic buffer. Could hold anything: value or pointer.

type BufferPtr = Ptr OCIBuffer

type BufferFPtr = ForeignPtr OCIBuffer

type ColumnResultBuffer = ForeignPtr OCIBuffer  -- use ForeignPtr to ensure GC'd

-- triple of (nullind, buffer, size)

type BindBuffer = (ForeignPtr CShort, ForeignPtr OCIBuffer, ForeignPtr CUShort)

data Context = Context

type ContextPtr = Ptr Context



data EnvStruct = EnvStruct

type EnvHandle = Ptr EnvStruct

data ErrorStruct = ErrorStruct

type ErrorHandle = Ptr ErrorStruct

data ServerStruct = ServerStruct

type ServerHandle = Ptr ServerStruct

data UserStruct = UserStruct

type UserHandle = Ptr UserStruct

data ConnStruct = ConnStruct

type ConnHandle = Ptr ConnStruct  -- AKA Service Context

data SessStruct = SessStruct

type SessHandle = Ptr SessStruct

data StmtStruct = StmtStruct

type StmtHandle = Ptr StmtStruct

data DefnStruct = DefnStruct

type DefnHandle = Ptr DefnStruct

data ParamStruct = ParamStruct

type ParamHandle = Ptr ParamStruct

data BindStruct = BindStruct

type BindHandle = Ptr BindStruct

type ColumnInfo = (DefnHandle, ColumnResultBuffer, ForeignPtr CShort, ForeignPtr CUShort)





-- |Low-level, OCI library errors.



data OCIException = OCIException CInt String

  deriving (Typeable, Show)



-- If we can't derive Typeable then the following code should do the trick:



--  > data OCIException = OCIException CInt String

--  > ociExceptionTc :: TyCon

--  > ociExceptionTc = mkTyCon "Database.Oracle.OCIFunctions.OCIException"

--  > instance Typeable OCIException where typeOf _ = mkAppTy ociExceptionTc []





catchOCI :: IO a -> (OCIException -> IO a) -> IO a

throwOCI :: OCIException -> a

instance Exception OCIException

catchOCI = catch

throwOCI = throw





mkCInt :: Int -> CInt

mkCInt n = fromIntegral n



mkCShort :: CInt -> CShort

mkCShort n = fromIntegral n



mkCUShort :: CInt -> CUShort

mkCUShort n = fromIntegral n



cStrLen :: CStringLen -> CInt

cStrLen = mkCInt . snd



cStr :: CStringLen -> CString

cStr = fst







-- ---------------------------------------------------------------------------------

-- -- ** Foreign OCI functions

-- ---------------------------------------------------------------------------------





foreign import ccall "OCIEnvCreate" ociEnvCreate :: Ptr EnvHandle -> CInt -> Ptr a -> FunPtr a -> FunPtr a -> FunPtr a -> CInt -> Ptr (Ptr a) -> IO CInt

foreign import ccall "OCIHandleAlloc" ociHandleAlloc :: OCIHandle -> Ptr OCIHandle -> CInt -> CInt -> Ptr a -> IO CInt

foreign import ccall "oci.h OCIHandleFree" ociHandleFree :: OCIHandle -> CInt -> IO CInt

foreign import ccall "oci.h OCIErrorGet" ociErrorGet :: OCIHandle -> CInt -> CString -> Ptr CInt -> CString -> CInt -> CInt -> IO CInt





foreign import ccall "oci.h OCIParamGet" ociParamGet :: OCIHandle -> CInt -> ErrorHandle -> Ptr OCIHandle -> CInt -> IO CInt

foreign import ccall "oci.h OCIAttrGet" ociAttrGet

  :: OCIHandle -> CInt -> BufferPtr -> Ptr CInt -> CInt -> ErrorHandle -> IO CInt

foreign import ccall "oci.h OCIAttrSet" ociAttrSet

  :: OCIHandle -> CInt -> BufferPtr -> CInt -> CInt -> ErrorHandle -> IO CInt





foreign import ccall "oci.h OCILogon" ociLogon

  :: EnvHandle -> ErrorHandle -> Ptr ConnHandle -> CString -> CInt -> CString -> CInt -> CString -> CInt -> IO CInt

foreign import ccall "oci.h OCILogoff" ociLogoff :: ConnHandle -> ErrorHandle -> IO CInt

foreign import ccall "oci.h OCISessionBegin" ociSessionBegin :: ConnHandle -> ErrorHandle -> SessHandle -> CInt -> CInt -> IO CInt

foreign import ccall "oci.h OCISessionEnd" ociSessionEnd :: ConnHandle -> ErrorHandle -> SessHandle -> CInt -> IO CInt

foreign import ccall "oci.h OCIServerAttach" ociServerAttach :: ServerHandle -> ErrorHandle -> CString -> CInt -> CInt -> IO CInt

foreign import ccall "oci.h OCIServerDetach" ociServerDetach :: ServerHandle -> ErrorHandle -> CInt -> IO CInt

foreign import ccall "oci.h OCITerminate" ociTerminate :: CInt -> IO CInt



foreign import ccall "oci.h OCITransStart" ociTransStart :: ConnHandle -> ErrorHandle -> Word8 -> CInt -> IO CInt

foreign import ccall "oci.h OCITransCommit" ociTransCommit :: ConnHandle -> ErrorHandle -> CInt -> IO CInt

foreign import ccall "oci.h OCITransRollback" ociTransRollback :: ConnHandle -> ErrorHandle -> CInt -> IO CInt



foreign import ccall "oci.h OCIStmtPrepare" ociStmtPrepare :: StmtHandle -> ErrorHandle -> CString -> CInt -> CInt -> CInt -> IO CInt

foreign import ccall "oci.h OCIDefineByPos" ociDefineByPos

  :: StmtHandle -> Ptr DefnHandle -> ErrorHandle -> CInt -> BufferPtr -> CInt -> CUShort -> Ptr CShort -> Ptr CUShort -> Ptr CUShort -> CInt -> IO CInt

foreign import ccall "oci.h OCIStmtExecute" ociStmtExecute :: ConnHandle -> StmtHandle -> ErrorHandle -> CInt -> CInt -> OCIHandle -> OCIHandle -> CInt -> IO CInt

foreign import ccall "oci.h OCIStmtFetch" ociStmtFetch :: StmtHandle -> ErrorHandle -> CInt -> CShort -> CInt -> IO CInt



-- stmt, ptr bindHdl, err, pos, valuePtr, sizeOfValue,

-- datatype, indicatorPtr, lenArrayPtr, retCodeArrayPtr,

-- plsqlArrayMaxLen, plsqlCurrEltPtr, mode



foreign import ccall "oci.h OCIBindByPos" ociBindByPos ::

  StmtHandle

  -> Ptr BindHandle

  -> ErrorHandle

  -> CUInt  -- ^ position

  -> BufferPtr  -- ^ buffer containing data

  -> CInt  -- ^ max size of buffer

  -> CUShort  -- ^ SQL data type

  -> Ptr CShort  -- ^ null indicator ptr

  -> Ptr CUShort  -- ^ input + output size, or array of sizes

  -> Ptr CUShort  -- ^ array of return codes

  -> CUInt  -- ^ max array elements

  -> Ptr CUInt  -- ^ number of array elements

  -> CUInt  -- ^ mode

  -> IO CInt



foreign import ccall "oci.h OCIBindDynamic" ociBindDynamic ::

  BindHandle -> ErrorHandle -> ContextPtr -> FunPtr OCICallbackInBind

  -> ContextPtr -> FunPtr OCICallbackOutBind -> IO CInt



type OCICallbackInBind = ContextPtr -> BindHandle -> CInt -> CInt

  -> Ptr BufferPtr -> CInt -> Ptr Word8 -> Ptr CShort -> IO CInt



type OCICallbackOutBind = ContextPtr -> BindHandle -> CInt -> CInt

  -> Ptr BufferPtr -> Ptr CInt -> Ptr Word8 -> Ptr CShort -> Ptr (Ptr CShort) -> IO CInt



foreign import ccall "wrapper" mkOCICallbackInBind ::

  OCICallbackInBind -> IO (FunPtr OCICallbackInBind)

foreign import ccall "wrapper" mkOCICallbackOutBind ::

  OCICallbackOutBind -> IO (FunPtr OCICallbackOutBind)



-- ---------------------------------------------------------------------------------

-- -- ** OCI error reporting

-- ---------------------------------------------------------------------------------



-- |This is just an auxiliary function for getOCIErrorMsg.



getOCIErrorMsg2 :: OCIHandle -> CInt -> Ptr CInt -> CString -> CInt -> IO (CInt, String)

getOCIErrorMsg2 ocihandle handleType errCodePtr errMsgBuf maxErrMsgLen = do

  rc <- ociErrorGet ocihandle 1 nullPtr errCodePtr errMsgBuf maxErrMsgLen handleType

  if rc < 0

    then return (0, "Error message not available.")

    else do

      msg <- peekCString errMsgBuf

      e <- peek errCodePtr

      return (e, msg)





getOCIErrorMsg :: OCIHandle -> CInt -> IO (CInt, String)

getOCIErrorMsg ocihandle handleType = do

  let stringBufferLen = 1000

  allocaBytes stringBufferLen $ \errMsg ->

    alloca $ \errCode ->

    getOCIErrorMsg2 ocihandle handleType errCode errMsg (mkCInt stringBufferLen)



fromEnumOCIErrorCode :: CInt -> String

fromEnumOCIErrorCode err

  | err == oci_SUCCESS = "OCI_SUCCESS"

  | err == oci_SUCCESS_WITH_INFO = "OCI_SUCCESS_WITH_INFO"

  | err == oci_NEED_DATA = "OCI_NEED_DATA"

  | err == oci_NO_DATA = "OCI_NO_DATA"

  | err == oci_INVALID_HANDLE = "OCI_INVALID_HANDLE"

  | err == oci_STILL_EXECUTING = "OCI_STILL_EXECUTING"

  | err == oci_CONTINUE = "OCI_CONTINUE"

  | err == oci_RESERVED_FOR_INT_USE = "OCI_RESERVED_FOR_INT_USE"

  | otherwise = "OCI_ERROR"



formatErrorCodeDesc :: CInt -> String -> String

formatErrorCodeDesc err desc

  | err == oci_ERROR = ""

  | otherwise = (fromEnumOCIErrorCode err) ++ " - " ++ desc





-- |Given the two parts of an 'OCIException' (the error number and text)

-- get the actual error message from the DBMS and construct an error message

-- from all of these pieces.



formatOCIMsg :: CInt -> String -> OCIHandle -> CInt -> IO (Int, String)

formatOCIMsg e m ocihandle handleType = do

  (err, msg) <- getOCIErrorMsg ocihandle handleType

  --return (fromIntegral err, (formatErrorCodeDesc e m) ++ " : " ++ (show err) ++ " - " ++ msg)

  if msg == ""

    then return (fromIntegral err, (formatErrorCodeDesc e m))

    else return (fromIntegral err, (formatErrorCodeDesc e m) ++ " : " ++ msg)







-- |We have two format functions: 'formatEnvMsg' takes the 'EnvHandle',

-- 'formatErrorMsg' takes the 'ErrorHandle'.

-- They're just type-safe wrappers for 'formatMsgCommon'.



formatMsgCommon :: OCIException -> OCIHandle -> CInt -> IO (Int, String)

formatMsgCommon (OCIException e m) h handleType = do

  if e == 0

    then return (0, "")

    else case () of

      _ | e == oci_ERROR -> do (formatOCIMsg e m h handleType)

        | e == oci_SUCCESS_WITH_INFO -> do (formatOCIMsg e m h handleType)

        | otherwise -> return (fromIntegral e, formatErrorCodeDesc e m)



formatErrorMsg :: OCIException -> ErrorHandle -> IO (Int, String)

formatErrorMsg exc err = formatMsgCommon exc (castPtr err) oci_HTYPE_ERROR



formatEnvMsg :: OCIException -> EnvHandle -> IO (Int, String)

formatEnvMsg exc err = formatMsgCommon exc (castPtr err) oci_HTYPE_ENV







-- |The testForError functions are the only places where OCIException is thrown,

-- so if you want to change or embellish it, your changes will be localised here.

-- These functions factor out common error handling code

-- from the OCI wrapper functions that follow.



-- Typically an OCI wrapper function would look like:



--  > handleAlloc handleType env = alloca ptr -> do

--  >   rc <- ociHandleAlloc env ptr handleType 0 nullPtr

--  >   if rc < 0

--  >     then throwOCI (OCIException rc msg)

--  >     else return ()



-- where the code from @if rc < 0@ onwards was identical.

-- 'testForError' replaces the code from @if rc < 0 ...@ onwards.



testForError :: CInt -> String -> a -> IO a

testForError rc msg retval = do

  if rc < 0

    then throwOCI (OCIException rc msg)

    else return retval





-- |Like 'testForError' but when the value you want to return

-- is at the end of a pointer.

-- Either there was an error, in which case the pointer probably isn't valid,

-- or there is something at the end of the pointer to return.

-- See 'dbLogon' and 'getHandleAttr' for example usage.



testForErrorWithPtr :: Storable a => CInt -> String -> Ptr a -> IO a

testForErrorWithPtr rc msg retval = do

  if rc < 0

    then throwOCI (OCIException rc msg)

    else peek retval





-- ---------------------------------------------------------------------------------

-- -- ** Allocating Handles (i.e. creating OCI data structures, and memory management)

-- ---------------------------------------------------------------------------------





envCreate :: IO EnvHandle

envCreate = alloca $ \ptr -> do

  rc <- ociEnvCreate ptr oci_THREADED nullPtr nullFunPtr nullFunPtr nullFunPtr 0 nullPtr

  testForErrorWithPtr rc "allocate initial end" ptr



handleAlloc :: CInt -> OCIHandle -> IO OCIHandle

handleAlloc handleType env = alloca $ \ptr -> do

  rc <- ociHandleAlloc env ptr handleType 0 nullPtr

  testForErrorWithPtr rc "allocate handle" ptr



handleFree :: CInt -> OCIHandle -> IO ()

handleFree handleType ptr = do

   rc <- ociHandleFree ptr handleType

   testForError rc "free handle" ()







setHandleAttr :: ErrorHandle -> OCIHandle -> CInt -> Ptr a -> CInt -> IO ()

setHandleAttr err ocihandle handleType handleAttr attrType = do

  rc <- ociAttrSet ocihandle handleType (castPtr handleAttr) 0 attrType err

  testForError rc "setHandleAttr" ()





setHandleAttrString :: ErrorHandle -> OCIHandle -> CInt -> String -> CInt -> IO ()

setHandleAttrString err ocihandle handleType s attrType = do

  withCStringLen s $ \sC -> do

    rc <- ociAttrSet ocihandle handleType (castPtr (cStr sC)) (cStrLen sC) attrType err

    testForError rc "setHandleAttrString" ()





-- ociAttrGet returns a pointer to something - maybe a handle or a chunk of memory.

-- Sometimes it's a pointer to a Handle, i.e. a Ptr to a Ptr to a Struct,

-- so we want to peek it to get the Handle.

-- Other times it's a pointer to (say) a few bytes which might contain a number or a string.

-- Deref'ing it returns that value immediately, rather than a Ptr to that value.



getHandleAttr :: (Storable a) => ErrorHandle -> OCIHandle -> CInt -> CInt -> IO a

getHandleAttr err ocihandle handleType attrType = alloca $ \ptr -> do

  -- 3rd arg has type Ptr OCIBuffer.

  rc <- ociAttrGet ocihandle handleType (castPtr ptr) nullPtr attrType err

  testForErrorWithPtr rc "getAttrHandle" ptr



getParam :: ErrorHandle -> StmtHandle -> Int -> IO ParamHandle

getParam err stmt posn = alloca $ \ptr -> do

  rc <- ociParamGet (castPtr stmt) oci_HTYPE_STMT err ptr (mkCInt posn)

  testForErrorWithPtr rc "getParam" (castPtr ptr)





-- ---------------------------------------------------------------------------------

-- -- ** Connecting and detaching

-- ---------------------------------------------------------------------------------



-- |The OCI Logon function doesn't behave as you'd expect when the password is due to expire.

-- 'ociLogon' returns 'Database.Oracle.OCIConstants.oci_SUCCESS_WITH_INFO',

-- but the 'ConnHandle' returned is not valid.

-- In this case we have to change 'Database.Oracle.OCIConstants.oci_SUCCESS_WITH_INFO'

-- to 'Database.Oracle.OCIConstants.oci_ERROR',

-- so that the error handling code will catch it and abort. 

-- I don't know why the handle returned isn't valid,

-- as the logon process should be able to complete successfully in this case.





dbLogon :: String -> String -> String -> EnvHandle -> ErrorHandle -> IO ConnHandle

dbLogon user pswd db env err =

  withCStringLen user $ \userC ->

  withCStringLen pswd $ \pswdC ->

  withCStringLen db   $ \dbC ->

  alloca $ \conn -> do

    rc <- ociLogon env err conn (cStr userC) (cStrLen userC) (cStr pswdC) (cStrLen pswdC) (cStr dbC) (cStrLen dbC)

    case () of

      _ | rc == oci_SUCCESS_WITH_INFO -> testForErrorWithPtr oci_ERROR "logon" conn

        | otherwise -> testForErrorWithPtr rc "logon" conn





dbLogoff :: ErrorHandle -> ConnHandle -> IO ()

dbLogoff err conn = do

  rc <- ociLogoff conn err

  testForError rc "logoff" ()





terminate :: IO ()

terminate = do

  rc <- ociTerminate oci_DEFAULT

  testForError rc "terminate" ()







serverDetach :: ErrorHandle -> ServerHandle -> IO ()

serverDetach err server = do

  rc <- ociServerDetach server err oci_DEFAULT

  testForError rc "server detach" ()





serverAttach :: ErrorHandle -> ServerHandle -> String -> IO ()

serverAttach err server dblink = do

  withCStringLen dblink $ \s -> do

    rc <- ociServerAttach server err (cStr s) (cStrLen s) oci_DEFAULT

    testForError rc "server attach" ()





-- |Having established a connection (Service Context), now get the Session.

-- You can have more than one session per connection,

-- but I haven't implemented it yet.



getSession :: ErrorHandle -> ConnHandle -> IO SessHandle

getSession err conn = liftM castPtr (getHandleAttr err (castPtr conn) oci_HTYPE_SVCCTX oci_ATTR_SESSION)





sessionBegin :: ErrorHandle -> ConnHandle -> SessHandle -> CInt -> IO ()

sessionBegin err conn sess cred = do

  rc <- ociSessionBegin conn err sess cred oci_DEFAULT

  testForError rc "session begin" ()





sessionEnd :: ErrorHandle -> ConnHandle -> SessHandle -> IO ()

sessionEnd err conn sess = do

  rc <- ociSessionEnd conn err sess oci_DEFAULT

  testForError rc "session end" ()







-- ---------------------------------------------------------------------------------

-- -- ** Transactions

-- ---------------------------------------------------------------------------------



beginTrans :: ErrorHandle -> ConnHandle -> CInt -> IO ()

beginTrans err conn isolation = do

  rc <- ociTransStart conn err 0 isolation

  testForError rc "begin transaction" ()



commitTrans :: ErrorHandle -> ConnHandle -> IO ()

commitTrans err conn = do

  rc <- ociTransCommit conn err oci_DEFAULT

  testForError rc "commit" ()



rollbackTrans :: ErrorHandle -> ConnHandle -> IO ()

rollbackTrans err conn = do

  rc <- ociTransRollback conn err oci_DEFAULT

  testForError rc "rollback" ()





-- ---------------------------------------------------------------------------------

-- -- ** Issuing queries

-- ---------------------------------------------------------------------------------



-- |With the OCI you do queries with these steps:



--  * prepare your statement (it's just a String) - no communication with DBMS



--  * execute it (this sends it to the DBMS for parsing etc)



--  * allocate result set buffers by calling 'defineByPos' for each column



--  * call fetch for each row.



--  * call 'handleFree' for the 'StmtHandle'

--    (I assume this is the approved way of terminating the query;

--    the OCI docs aren't explicit about this.)





stmtPrepare :: ErrorHandle -> StmtHandle -> String -> IO ()

stmtPrepare err stmt sqltext = do

  withCStringLen sqltext $ \sqltextC -> do

    rc <- ociStmtPrepare stmt err (cStr sqltextC) (cStrLen sqltextC) oci_NTV_SYNTAX oci_DEFAULT

    testForError rc "stmtPrepare" ()





stmtExecute :: ErrorHandle -> ConnHandle -> StmtHandle -> Int -> IO ()

stmtExecute err conn stmt iterations = do

  rc <- ociStmtExecute conn stmt err (mkCInt iterations) 0 nullPtr nullPtr oci_DEFAULT

  testForError rc "stmtExecute" ()







-- |defineByPos allocates memory for a single column value.

-- The allocated components are:



--  * the result (i.e. value) - you have to say how big with bufsize.



--  * the null indicator (int16)



--  * the size of the returned data (int16)



-- Previously it was the caller's responsibility to free the memory after they're done with it.

-- Now we use 'Foreign.ForeignPtr.mallocForeignPtr', so manual memory management is hopefully

-- a thing of the past.

-- The caller will also have to cast the data in bufferptr to the expected type

-- (using 'Foreign.Ptr.castPtr').





defineByPos :: ErrorHandle

  -> StmtHandle

  -> Int   -- ^ Position

  -> Int   -- ^ Buffer size in bytes

  -> CInt  -- ^ SQL Datatype (from "Database.Oracle.OCIConstants")

  -> IO ColumnInfo  -- ^ tuple: (DefnHandle, Ptr to buffer, Ptr to null indicator, Ptr to size of value in buffer)

defineByPos err stmt posn bufsize sqldatatype = do

  bufferFPtr <- mallocForeignPtrBytes bufsize

  nullIndFPtr <- mallocForeignPtr

  retSizeFPtr <- mallocForeignPtr

  alloca $ \defnPtr ->

    withForeignPtr bufferFPtr $ \bufferPtr ->

    withForeignPtr nullIndFPtr $ \nullIndPtr ->

    withForeignPtr retSizeFPtr $ \retSizePtr -> do

    rc <- ociDefineByPos stmt defnPtr err (mkCInt posn) bufferPtr (mkCInt bufsize) (mkCUShort sqldatatype) nullIndPtr retSizePtr nullPtr oci_DEFAULT

    defn <- peek defnPtr  -- no need for caller to free defn; I think freeing the stmt handle does it.

    testForError rc "defineByPos" (defn, bufferFPtr, nullIndFPtr, retSizeFPtr)





-- |Oracle only understands bind variable placeholders using syntax :x,

-- where x is a number or a variable name.

-- Most other DBMS's use ? as a placeholder,

-- so we have this function to substitute ? with :n,

-- where n starts at one and increases with each ?.



-- We don't use this function in this library though;

-- it's used in the higher-level implementation of Enumerator.

-- We prefer to retain flexibility at this lower-level,

-- and not force arbitrary implementation choices too soon.

-- If you want to use this library and use :x style syntax, you can.



substituteBindPlaceHolders sql =

  sbph sql 1 False ""



sbph :: String -> Int -> Bool -> String -> String

sbph [] _ _ acc = reverse acc

sbph ('\'':cs) i inQuote acc = sbph cs i (not inQuote) ('\'':acc)

sbph ('?':cs) i False acc = sbph cs (i+1) False ((reverse (show i)) ++ (':':acc))

sbph (c:cs) i inQuote acc = sbph cs i inQuote (c:acc)







bindByPos ::

  ErrorHandle

  -> StmtHandle

  -> Int   -- ^ Position

  -> CShort   -- ^ Null ind: 0 == not null, -1 == null

  -> BufferPtr  -- ^ payload

  -> Int   -- ^ payload size in bytes

  -> CInt  -- ^ SQL Datatype (from "Database.Oracle.OCIConstants")

  -> IO ()

bindByPos err stmt pos nullInd bufptr sze sqltype = do

  indFPtr <- mallocForeignPtr

  sizeFPtr <- mallocForeignPtr

  withForeignPtr indFPtr $ \p -> poke p nullInd

  -- You can't put any old junk in the return-size field,

  -- even if the parameter is IN-only.

  -- So tell it how big the input buffer is.

  withForeignPtr sizeFPtr $ \p -> poke p (fromIntegral sze)

  bufFPtr <- newForeignPtr_ bufptr

  bindOutputByPos err stmt pos (indFPtr, bufFPtr, sizeFPtr) sze sqltype

  return ()



-- Note that this function takes a ForeignPtr to the output-size

-- (in the triple) and also a size parameter, which is the input size.

-- We need to provide both, apparently, regardless of actual parameter

-- direction.



bindOutputByPos ::

  ErrorHandle

  -> StmtHandle

  -> Int   -- ^ Position

  -> BindBuffer  -- ^ triple of (null-ind, payload, input-size)

  -> Int   -- ^ buffer max size in bytes

  -> CInt  -- ^ SQL Datatype (from "Database.Oracle.OCIConstants")

  -> IO BindHandle

bindOutputByPos err stmt pos (nullIndFPtr, bufFPtr, sizeFPtr) sze sqltype =

  alloca $ \bindHdl ->

    withForeignPtr nullIndFPtr $ \indPtr -> do

      withForeignPtr sizeFPtr $ \sizePtr ->

        withForeignPtr bufFPtr $ \bufPtr -> do

          rc <- ociBindByPos stmt bindHdl err (fromIntegral pos) bufPtr

              (fromIntegral sze) (fromIntegral sqltype)

              indPtr sizePtr nullPtr 0 nullPtr (fromIntegral oci_DEFAULT)

          testForError rc "bindOutputByPos" ()

          bptr <- peek bindHdl

          return bptr





-- | Fetch a single row into the buffers.

-- If you have specified a prefetch count > 1 then the row

-- might already be cached by the OCI library.



stmtFetch :: ErrorHandle -> StmtHandle -> IO CInt

stmtFetch err stmt = do

  let numRowsToFetch = 1

  rc <- ociStmtFetch stmt err numRowsToFetch (mkCShort oci_FETCH_NEXT) oci_DEFAULT

  if rc == oci_NO_DATA

    then return rc

    else testForError rc "stmtFetch" rc



-- From the "Bindind and Defining" chapter in the OCI docs:



-- Binding RETURNING...INTO variables



-- An OCI application implements the placeholders in the RETURNING clause

-- as pure OUT bind variables. However, all binds in the RETURNING clause

-- are initially IN and must be properly initialized.

-- To provide a valid value, you can provide a NULL indicator

-- and set that indicator to -1 (NULL).



-- An application must adhere to the following rules when working with

-- bind variables in a RETURNING clause:



--    1. Bind RETURNING clause placeholders in OCI_DATA_AT_EXEC mode using

--       OCIBindByName() or OCIBindByPos(), followed by a call to

--       OCIBindDynamic() for each placeholder.



--       Note: The OCI only supports the callback mechanism for

--       RETURNING clause binds. The polling mechanism is not supported.



--    2. When binding RETURNING clause placeholders, you must supply a valid out

--       bind function as the ocbfp parameter of the OCIBindDynamic() call.

--       This function must provide storage to hold the returned data.



--    3. The icbfp parameter of OCIBindDynamic() call should provide a

--       "dummy" function which returns NULL values when called.



--    4. The piecep parameter of OCIBindDynamic() must be set to OCI_ONE_PIECE.



--    5. No duplicate binds are allowed in a DML statement with a

--       RETURNING clause, such as no duplication between bind variables

--       in the DML section and the RETURNING section of the statement.



-- |Short-circuit null test: if the buffer contains a null then return Nothing.

-- Otherwise, run the IO action to extract a value from the buffer and return Just it.



maybeBufferNull :: ForeignPtr CShort -> Maybe a -> IO a -> IO (Maybe a)

maybeBufferNull nullIndFPtr nullVal action =

  withForeignPtr nullIndFPtr $ \nullIndPtr -> do

    nullInd <- liftM cShort2Int (peek nullIndPtr)

    if (nullInd == -1)  -- -1 == null, 0 == value

      then return nullVal

      else do

        v <- action

        return (Just v)





nullByte :: CChar

nullByte = 0



cShort2Int :: CShort -> Int

cShort2Int n = fromIntegral n



cUShort2Int :: CUShort -> Int

cUShort2Int n = fromIntegral n



cuCharToInt :: CUChar -> Int

cuCharToInt c = fromIntegral c



byteToInt :: Ptr CUChar -> Int -> IO Int

byteToInt buffer n = do

  b <- peekByteOff buffer n

  return (cuCharToInt b)





bufferToString :: ColumnInfo -> IO (Maybe String)

bufferToString (_, bufFPtr, nullFPtr, sizeFPtr) =

  withForeignPtr nullFPtr $ \nullIndPtr -> do

    nullInd <- liftM cShort2Int (peek nullIndPtr)

    if (nullInd == -1)  -- -1 == null, 0 == value

      then return Nothing

      else do

        -- Given a column buffer, extract a string of variable length

        -- (you have to terminate it yourself).

        withForeignPtr bufFPtr $ \bufferPtr ->

          withForeignPtr sizeFPtr $ \retSizePtr -> do

            retsize <- liftM cUShort2Int (peek retSizePtr)

            --putStrLn ("bufferToString: size = " ++ show retsize)

            pokeByteOff (castPtr bufferPtr) retsize nullByte

            val <- peekCString (castPtr bufferPtr)

            return (Just val)





-- | Oracle's excess-something-or-other encoding for years:

-- year = 100*(c - 100) + (y - 100),

-- c = (year div 100) + 100,

-- y = (year mod 100) + 100.



-- +1999 -> 119, 199

-- +0100 -> 101, 100

-- +0001 -> 100, 101

-- -0001 -> 100,  99

-- -0100 ->  99, 100

-- -1999 ->  81,   1



makeYear :: Int -> Int -> Int

makeYear c100 y100 = 100 * (c100 - 100) + (y100 - 100)



makeYearByte :: Int -> Word8

makeYearByte y = fromIntegral ((rem y 100) + 100)



makeCentByte :: Int -> Word8

makeCentByte y = fromIntegral ((quot y 100) + 100)



dumpBuffer :: Ptr Word8 -> IO ()

dumpBuffer buf = do

  dumpByte 0

  dumpByte 1

  dumpByte 2

  dumpByte 3

  dumpByte 4

  dumpByte 5

  dumpByte 6

  putStrLn ""

  where

  dumpByte n = do

    b <- (peekByteOff buf n :: IO Word8)

    putStr $ (show b) ++ " "





bufferToCaltime :: ForeignPtr CShort -> BufferFPtr -> IO (Maybe CalendarTime)

bufferToCaltime nullind fptr = maybeBufferNull nullind Nothing $

  withForeignPtr fptr $ \bufferPtr -> do

    let buffer = castPtr bufferPtr

    --dumpBuffer (castPtr buffer)

    century100 <- byteToInt buffer 0

    year100 <- byteToInt buffer 1

    month <- byteToInt buffer 2

    day <- byteToInt buffer 3

    hour <- byteToInt buffer 4

    minute <- byteToInt buffer 5

    second <- byteToInt buffer 6

    return $ CalendarTime

      { ctYear = makeYear century100 year100

      , ctMonth = toEnum (month - 1)

      , ctDay = day

      , ctHour = hour - 1

      , ctMin = minute - 1

      , ctSec = second - 1

      , ctPicosec = 0

      , ctWDay = Sunday

      , ctYDay = -1

      , ctTZName = "UTC"

      , ctTZ = 0

      , ctIsDST = False

      }



bufferToUTCTime :: ForeignPtr CShort -> BufferFPtr -> IO (Maybe UTCTime)

bufferToUTCTime nullind fptr = maybeBufferNull nullind Nothing $

  withForeignPtr fptr $ \bufferPtr -> do

    let buffer = castPtr bufferPtr

    --dumpBuffer (castPtr buffer)

    century100 <- byteToInt buffer 0

    year100 <- byteToInt buffer 1

    month <- byteToInt buffer 2

    day <- byteToInt buffer 3

    hour <- byteToInt buffer 4

    minute <- byteToInt buffer 5

    second <- byteToInt buffer 6

    let year = makeYear century100 year100

    return (mkUTCTime year month day (hour-1) (minute-1) (second-1))



setBufferByte :: BufferPtr -> Int -> Word8 -> IO ()

setBufferByte buf n v = pokeByteOff buf n v



calTimeToBuffer :: BufferPtr -> CalendarTime -> IO ()

calTimeToBuffer buf ct = do

  setBufferByte buf 0 (makeCentByte (ctYear ct))

  setBufferByte buf 1 (makeYearByte (ctYear ct))

  setBufferByte buf 2 (fromIntegral ((fromEnum (ctMonth ct)) + 1))

  setBufferByte buf 3 (fromIntegral (ctDay ct))

  setBufferByte buf 4 (fromIntegral (ctHour ct + 1))

  setBufferByte buf 5 (fromIntegral (ctMin ct + 1))

  setBufferByte buf 6 (fromIntegral (ctSec ct + 1))



utcTimeToBuffer :: BufferPtr -> UTCTime -> IO ()

utcTimeToBuffer buf utc = do

  let (LocalTime ltday time) = utcToLocalTime (hoursToTimeZone 0) utc

  let (TimeOfDay hour minute second) = time

  let (year, month, day) = toGregorian ltday

  setBufferByte buf 0 (makeCentByte (fromIntegral year))

  setBufferByte buf 1 (makeYearByte (fromIntegral year))

  setBufferByte buf 2 (fromIntegral month)

  setBufferByte buf 3 (fromIntegral day)

  setBufferByte buf 4 (fromIntegral (hour+1))

  setBufferByte buf 5 (fromIntegral (minute+1))

  setBufferByte buf 6 (round (second+1))





bufferPeekValue :: (Storable a) => BufferFPtr -> IO a

bufferPeekValue buffer = do

  v <- withForeignPtr buffer $ \bufferPtr -> peek $ castPtr bufferPtr

  return v



bufferToA :: (Storable a) => ForeignPtr CShort -> BufferFPtr -> IO (Maybe a)

bufferToA nullind buffer = maybeBufferNull nullind Nothing (bufferPeekValue buffer)



bufferToCInt :: ForeignPtr CShort -> BufferFPtr -> IO (Maybe CInt)

bufferToCInt = bufferToA



bufferToInt :: ForeignPtr CShort -> BufferFPtr -> IO (Maybe Int)

bufferToInt nullind b = do

  cint <- bufferToCInt nullind b

  return $ maybe Nothing (Just . fromIntegral) cint



bufferToCDouble :: ForeignPtr CShort -> BufferFPtr -> IO (Maybe CDouble)

bufferToCDouble = bufferToA



bufferToDouble :: ForeignPtr CShort -> BufferFPtr -> IO (Maybe Double)

bufferToDouble nullind b = do

  cdbl <- bufferToCDouble nullind b

  return $ maybe Nothing (Just . realToFrac) cdbl



bufferToStmtHandle :: BufferFPtr -> IO StmtHandle

bufferToStmtHandle buffer = do

  withForeignPtr buffer $ \bufferPtr -> do

    v <- peek (castPtr bufferPtr)

    return v