{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Database.Oracle.Enumerator
( Session, connect
, prepareQuery, prepareLargeQuery, prepareCommand, prepareLargeCommand
, sql, sqlbind, prefetch, cmdbind
, StmtHandle, Out(..)
, module Database.Enumerator
)
where
import Database.Enumerator
import Database.InternalEnumerator
import Database.Oracle.OCIConstants
import qualified Database.Oracle.OCIFunctions as OCI
import Database.Oracle.OCIFunctions
( OCIHandle, EnvHandle, ErrorHandle, ServerHandle, ConnHandle, SessHandle, StmtHandle
, OCIException (..), catchOCI)
import Foreign
import Foreign.C
import Control.Monad
import Control.Exception
import Control.Monad.Trans
import Control.Monad.Reader
import Data.Char (toLower)
import Data.Dynamic
import Data.List (isPrefixOf)
import Data.IORef
import Data.Int
import Data.Time
import System.IO (hPutStrLn, stderr)
import System.Time
nullAction :: IO ()
nullAction = return ()
between i (l, u) = i >= l && i <= u
errorSqlState :: Int -> (String, String)
errorSqlState 0 = ("00", "000")
errorSqlState 1403 = ("02", "000")
errorSqlState 1095 = ("02", "000")
errorSqlState 1 = ("23", "000")
errorSqlState e | e >= 2290 && e <= 2299 = ("23", "000")
errorSqlState 22 = ("42", "000")
errorSqlState 251 = ("42", "000")
errorSqlState e | e `between` (900, 999) = ("42", "000")
errorSqlState 1031 = ("42", "000")
errorSqlState e | e `between` (1490, 1493) = ("42", "000")
errorSqlState e | e `between` (1700, 1799) = ("42", "000")
errorSqlState e | e `between` (1900, 2099) = ("42", "000")
errorSqlState e | e `between` (2140, 2289) = ("42", "000")
errorSqlState e | e `between` (2420, 2424) = ("42", "000")
errorSqlState e | e `between` (2450, 2499) = ("42", "000")
errorSqlState e | e `between` (3276, 3299) = ("42", "000")
errorSqlState e | e `between` (4040, 4059) = ("42", "000")
errorSqlState e | e `between` (4070, 4099) = ("42", "000")
errorSqlState 12154 = ("08", "001")
errorSqlState _ = ("01", "000")
throwSqlError e m = do
let
s@(ssc,sssc) = errorSqlState e
ec = case ssc of
"XX" -> DBFatal
"58" -> DBFatal
"57" -> DBFatal
"54" -> DBFatal
"53" -> DBFatal
"08" -> DBFatal
_ -> DBError
throwDB (ec s e m)
class OCIExceptionHandler a where
rethrow :: a -> OCIException -> IO () -> IO b
instance OCIExceptionHandler ErrorHandle where
rethrow err ex finaliser = do
(e, m) <- OCI.formatErrorMsg ex err
finaliser
throwSqlError e m
instance OCIExceptionHandler EnvHandle where
rethrow env ex finaliser = do
(e, m) <- OCI.formatEnvMsg ex env
finaliser
throwSqlError e m
reportOCIExc :: OCIException -> IO a
reportOCIExc (OCIException e m) = do
let s = OCI.formatErrorCodeDesc e m
printError s
throwDB (DBError (errorSqlState 0) 0 s)
return undefined
printError :: String -> IO ()
printError s = hPutStrLn stderr s
data Session = Session
{ envHandle :: EnvHandle
, errorHandle :: ErrorHandle
, connHandle :: ConnHandle
}
deriving Typeable
class FreeHandle ht where dispose :: ht -> IO ()
instance FreeHandle EnvHandle where dispose h = freeHandle (castPtr h) oci_HTYPE_ENV
instance FreeHandle ErrorHandle where dispose h = freeHandle (castPtr h) oci_HTYPE_ERROR
instance FreeHandle ServerHandle where dispose h = freeHandle (castPtr h) oci_HTYPE_SERVER
instance FreeHandle ConnHandle where dispose h = freeHandle (castPtr h) oci_HTYPE_SVCCTX
instance FreeHandle SessHandle where dispose h = freeHandle (castPtr h) oci_HTYPE_SESSION
instance FreeHandle StmtHandle where dispose h = freeHandle (castPtr h) oci_HTYPE_STMT
freeHandle :: OCIHandle -> CInt -> IO ()
freeHandle ocihandle handleType = catchOCI ( do
OCI.handleFree handleType ocihandle
) (\(OCIException e m) -> do
let s = OCI.formatErrorCodeDesc e m
printError s
)
inOCI :: EnvHandle -> ErrorHandle -> IO a -> IO a
inOCI env err action = catchOCI action $ \e -> do
rethrow err e $ do
dispose err
dispose env
inSession :: Session -> (EnvHandle -> ErrorHandle -> ConnHandle -> IO a) -> IO () -> IO a
inSession session action finaliser = do
let
env = envHandle session
err = errorHandle session
conn = connHandle session
catchOCI (action env err conn) (\e -> rethrow err e finaliser)
getEnv :: IO EnvHandle
getEnv = catchOCI OCI.envCreate reportOCIExc
getErr :: EnvHandle -> IO ErrorHandle
getErr env = catchOCI ( do
err <- OCI.handleAlloc oci_HTYPE_ERROR (castPtr env)
return (castPtr err)
) (\e -> rethrow env e (dispose env))
getServer :: EnvHandle -> ErrorHandle -> IO ServerHandle
getServer env err = inOCI env err $ do
server <- OCI.handleAlloc oci_HTYPE_SERVER (castPtr env)
return (castPtr server)
getConnection :: EnvHandle -> ErrorHandle -> IO ConnHandle
getConnection env err = inOCI env err $ do
conn <- OCI.handleAlloc oci_HTYPE_SVCCTX (castPtr env)
return (castPtr conn)
getSessionHandle :: EnvHandle -> ErrorHandle -> IO SessHandle
getSessionHandle env err = inOCI env err $ do
session <- OCI.handleAlloc oci_HTYPE_SESSION (castPtr env)
return (castPtr session)
startServerSession :: String -> String -> EnvHandle -> ErrorHandle -> ServerHandle -> IO ConnHandle
startServerSession user pswd env err server = do
conn <- getConnection env err
OCI.setHandleAttr err (castPtr conn) oci_HTYPE_SVCCTX (castPtr server) oci_ATTR_SERVER
session <- getSessionHandle env err
if (user == "")
then do
OCI.sessionBegin err conn session oci_CRED_EXT
else do
OCI.setHandleAttrString err (castPtr session) oci_HTYPE_SESSION user oci_ATTR_USERNAME
OCI.setHandleAttrString err (castPtr session) oci_HTYPE_SESSION pswd oci_ATTR_PASSWORD
OCI.sessionBegin err conn session oci_CRED_RDBMS
OCI.setHandleAttr err (castPtr conn) oci_HTYPE_SVCCTX (castPtr session) oci_ATTR_SESSION
trans <- OCI.handleAlloc oci_HTYPE_TRANS (castPtr env)
OCI.setHandleAttr err (castPtr conn) oci_HTYPE_SVCCTX (castPtr trans) oci_ATTR_TRANS
return conn
logon :: String -> String -> String -> EnvHandle -> ErrorHandle -> IO ConnHandle
logon user pswd dbname env err = inOCI env err $ do
server <- getServer env err
OCI.serverAttach err server dbname
startServerSession user pswd env err server
logoff :: ErrorHandle -> ConnHandle -> IO ()
logoff err conn = catchOCI (do
session <- OCI.getHandleAttr err (castPtr conn) oci_HTYPE_SVCCTX oci_ATTR_SESSION
server <- OCI.getHandleAttr err (castPtr conn) oci_HTYPE_SVCCTX oci_ATTR_SERVER
OCI.sessionEnd err conn session
OCI.serverDetach err server
dispose session
dispose conn
dispose server
) (\e -> rethrow err e nullAction)
dbConnect :: String -> String -> String -> IO Session
dbConnect user pswd dbname = do
env <- getEnv
err <- getErr env
conn <- logon user pswd dbname env err
return (Session env err conn)
dbDisconnect :: Session -> IO ()
dbDisconnect session = do
let
env = envHandle session
err = errorHandle session
conn = connHandle session
logoff err conn
dispose err
dispose env
OCI.terminate
beginTrans :: Session -> IsolationLevel -> IO ()
beginTrans session isolation = inSession session
(\_ err conn -> do
case isolation of
ReadUncommitted -> OCI.beginTrans err conn oci_TRANS_READWRITE
ReadCommitted -> OCI.beginTrans err conn oci_TRANS_READWRITE
RepeatableRead -> OCI.beginTrans err conn oci_TRANS_SERIALIZABLE
Serialisable -> OCI.beginTrans err conn oci_TRANS_SERIALIZABLE
Serializable -> OCI.beginTrans err conn oci_TRANS_SERIALIZABLE
) nullAction
commitTrans :: Session -> IO ()
commitTrans session = inSession session
(\_ err conn -> OCI.commitTrans err conn)
nullAction
rollbackTrans :: Session -> IO ()
rollbackTrans session = inSession session
(\_ err conn -> OCI.rollbackTrans err conn)
nullAction
getStmt :: Session -> IO StmtHandle
getStmt session = inSession session
(\ env err _ -> do
stmt <- OCI.handleAlloc oci_HTYPE_STMT (castPtr env)
return (castPtr stmt)
) nullAction
closeStmt :: Session -> StmtHandle -> IO ()
closeStmt _ stmt = dispose stmt
setPrefetchCount :: Session -> StmtHandle -> Int -> IO ()
setPrefetchCount session stmt count = inSession session
(\_ err _ -> with count $ \countPtr ->
OCI.setHandleAttr err (castPtr stmt) oci_HTYPE_STMT countPtr oci_ATTR_PREFETCH_ROWS
) (closeStmt session stmt)
stmtPrepare :: Session -> StmtHandle -> String -> IO ()
stmtPrepare session stmt sql = inSession session
(\_ err _ -> OCI.stmtPrepare err stmt sql
) (closeStmt session stmt)
word32ToInt :: Word32 -> Int
word32ToInt n = fromIntegral n
getRowCount :: Session -> StmtHandle -> IO Int
getRowCount session stmt = inSession session
(\_ err _ -> do
rc <- OCI.getHandleAttr err (castPtr stmt) oci_HTYPE_STMT oci_ATTR_ROW_COUNT
return (word32ToInt rc)
) (closeStmt session stmt)
execute :: Session -> StmtHandle -> Int -> IO Int
execute session stmt iterations = inSession session
(\_ err conn -> do
OCI.stmtExecute err conn stmt iterations
getRowCount session stmt
) (closeStmt session stmt)
fetchRow :: Session -> PreparedStmtObj -> IO CInt
fetchRow session stmt = inSession session
(\_ err _ -> OCI.stmtFetch err (stmtHandle stmt))
nullAction
defineCol :: Session -> PreparedStmtObj -> Int -> Int -> CInt -> IO OCI.ColumnInfo
defineCol session stmt posn bufsize sqldatatype = inSession session
(\_ err _ -> OCI.defineByPos err (stmtHandle stmt) posn bufsize sqldatatype)
(closeStmt session (stmtHandle stmt))
bindByPos :: Session -> PreparedStmtObj -> Int -> CShort -> OCI.BufferPtr -> Int -> CInt -> IO ()
bindByPos session stmt posn nullind val bufsize sqldatatype = inSession session
(\_ err _ -> OCI.bindByPos err (stmtHandle stmt) posn nullind val bufsize sqldatatype)
(closeStmt session (stmtHandle stmt))
bindOutputByPos :: Session -> PreparedStmtObj -> Int -> OCI.BindBuffer -> Int -> CInt -> IO OCI.BindHandle
bindOutputByPos session stmt posn buffer bufsize sqldatatype = inSession session
(\_ err _ -> OCI.bindOutputByPos err (stmtHandle stmt) posn buffer bufsize sqldatatype)
(closeStmt session (stmtHandle stmt))
connect :: String -> String -> String -> ConnectA Session
connect user pswd dbname = ConnectA (dbConnect user pswd dbname)
newtype QueryString = QueryString String
sql :: String -> QueryString
sql str = QueryString str
instance Command QueryString Session where
executeCommand sess (QueryString str) = doCommand sess str
doCommand sess str = do
stmt <- getStmt sess
stmtPrepare sess stmt str
rc <- execute sess stmt 1
closeStmt sess stmt
return rc
instance Command String Session where
executeCommand sess str = executeCommand sess (sql str)
data CommandBind = CommandBind String [BindA Session PreparedStmtObj BindObj]
cmdbind :: String -> [BindA Session PreparedStmtObj BindObj] -> CommandBind
cmdbind sql parms = CommandBind sql parms
instance Command CommandBind Session where
executeCommand sess (CommandBind sqltext bas) = do
let (PreparationA pa) = prepareStmt' 0 sqltext FreeWithQuery CommandType
ps <- pa sess
bindRun sess ps bas (\(BoundStmt bs) -> do
n <- getRowCount sess (stmtHandle bs)
closeStmt (stmtSession ps) (stmtHandle ps)
return n
)
instance Command BoundStmt Session where
executeCommand s (BoundStmt pstmt) =
getRowCount s (stmtHandle pstmt)
instance ISession Session where
disconnect sess = dbDisconnect sess
beginTransaction sess isolation = beginTrans sess isolation
commit sess = commitTrans sess
rollback sess = rollbackTrans sess
data StmtLifetime = FreeWithQuery | FreeManually
data StmtType = SelectType | CommandType
data PreparedStmtObj = PreparedStmtObj
{ stmtLifetime :: StmtLifetime
, stmtType :: StmtType
, stmtHandle :: StmtHandle
, stmtSession :: Session
, stmtCursors :: IORef [RefCursor StmtHandle]
, stmtBuffers :: IORef [ColumnBuffer]
}
beginsWithSelect "" = False
beginsWithSelect text = isPrefixOf "select" . map toLower $ text
inferStmtType text = if beginsWithSelect text then SelectType else CommandType
prepareQuery :: QueryString -> PreparationA Session PreparedStmtObj
prepareQuery (QueryString sqltext) =
prepareStmt' (prefetchRowCount defaultResourceUsage) sqltext FreeManually SelectType
prepareLargeQuery :: Int -> QueryString -> PreparationA Session PreparedStmtObj
prepareLargeQuery count (QueryString sqltext) =
prepareStmt' count sqltext FreeManually SelectType
prepareCommand :: QueryString -> PreparationA Session PreparedStmtObj
prepareCommand (QueryString sqltext) =
prepareStmt' 0 sqltext FreeManually CommandType
prepareLargeCommand :: Int -> QueryString -> PreparationA Session PreparedStmtObj
prepareLargeCommand n (QueryString sqltext) =
prepareStmt' n sqltext FreeManually CommandType
prepareStmt' count sqltext lifetime stmtype =
PreparationA (\sess -> do
stmt <- getStmt sess
stmtPrepare sess stmt (OCI.substituteBindPlaceHolders sqltext)
setPrefetchCount sess stmt count
newPreparedStmt lifetime stmtype sess stmt
)
newPreparedStmt lifetime iteration sess stmt = do
c <- newIORef []
b <- newIORef []
return (PreparedStmtObj lifetime iteration stmt sess c b)
newtype BoundStmt = BoundStmt { boundStmt :: PreparedStmtObj }
type BindObj = Int -> IO ()
newtype Out a = Out a
instance IPrepared PreparedStmtObj Session BoundStmt BindObj where
bindRun sess stmt bas action = do
sequence_ (zipWith (\i (BindA ba) -> ba sess stmt i) [1..] bas)
let iteration = case (stmtType stmt) of
SelectType -> 0
CommandType -> 1
execute sess (stmtHandle stmt) iteration
writeIORef (stmtCursors stmt) []
action (BoundStmt stmt)
destroyStmt sess pstmt = closeStmt sess (stmtHandle pstmt)
instance DBBind (Maybe String) Session PreparedStmtObj BindObj where
bindP = makeBindAction
instance DBBind (Out (Maybe String)) Session PreparedStmtObj BindObj where
bindP (Out v) = makeOutputBindAction v
instance DBBind (Maybe Int) Session PreparedStmtObj BindObj where
bindP = makeBindAction
instance DBBind (Out (Maybe Int)) Session PreparedStmtObj BindObj where
bindP (Out v) = makeOutputBindAction v
instance DBBind (Maybe Double) Session PreparedStmtObj BindObj where
bindP = makeBindAction
instance DBBind (Out (Maybe Double)) Session PreparedStmtObj BindObj where
bindP (Out v) = makeOutputBindAction v
instance DBBind (Maybe CalendarTime) Session PreparedStmtObj BindObj where
bindP = makeBindAction
instance DBBind (Maybe UTCTime) Session PreparedStmtObj BindObj where
bindP = makeBindAction
instance DBBind (Out (Maybe UTCTime)) Session PreparedStmtObj BindObj where
bindP (Out v) = makeOutputBindAction v
instance DBBind (Out (Maybe StmtHandle)) Session PreparedStmtObj BindObj where
bindP (Out v) = BindA (\sess stmt pos -> do
stmt2 <- getStmt sess
bindOutputMaybe sess stmt (Just stmt2) pos
)
instance DBBind (Maybe a) Session PreparedStmtObj BindObj
=> DBBind a Session PreparedStmtObj BindObj where
bindP x = bindP (Just x)
instance DBBind (Out (Maybe a)) Session PreparedStmtObj BindObj
=> DBBind (Out a) Session PreparedStmtObj BindObj where
bindP (Out x) = bindP (Out (Just x))
instance (Show a) => DBBind (Maybe a) Session PreparedStmtObj BindObj where
bindP (Just x) = bindP (Just (show x))
bindP Nothing = bindP (Nothing `asTypeOf` Just "")
instance (Show a) => DBBind (Out (Maybe a)) Session PreparedStmtObj BindObj where
bindP (Out (Just x)) = bindP (Out (Just (show x)))
bindP (Out Nothing) = bindP (Out (Nothing `asTypeOf` Just ""))
makeBindAction x = BindA (\ses st -> bindMaybe ses st x)
bindMaybe :: (OracleBind a)
=> Session -> PreparedStmtObj -> Maybe a -> Int -> IO ()
bindMaybe sess stmt v pos =
bindWithValue v $ \ptrv -> do
bindByPos sess stmt pos (bindNullInd v) (castPtr ptrv) (bindDataSize v) (bindType v)
makeOutputBindAction v = BindA (\sess stmt -> bindOutputMaybe sess stmt v)
bindOutputMaybe :: (OracleBind a)
=> Session -> PreparedStmtObj -> Maybe a -> Int -> IO ()
bindOutputMaybe sess stmt v pos = do
buffer <- mallocForeignPtrBytes (bindBufferSize v)
nullind <- mallocForeignPtr
sizeind <- mallocForeignPtr
withForeignPtr buffer $ \bufptr ->
withForeignPtr nullind $ \indptr ->
withForeignPtr sizeind $ \szeptr -> do
poke (castPtr indptr) (bindNullInd v)
poke (castPtr szeptr) (bindDataSize v)
bindWriteBuffer (castPtr bufptr) v
bindOutputByPos sess stmt pos (nullind, buffer, sizeind) (bindBufferSize v) (bindType v)
let
colbuf = ColumnBuffer
{ colBufBufferFPtr = buffer
, colBufNullFPtr = nullind
, colBufSizeFPtr = sizeind
, colBufColPos = 0
, colBufSqlType = (bindType v)
}
appendOutputBindBuffer stmt colbuf
appendOutputBindBuffer stmt buffer = do
buffers <- readIORef (stmtBuffers stmt)
modifyIORef (stmtBuffers stmt) (++ [buffer { colBufColPos = 1 + length buffers }])
class OracleBind a where
bindWithValue :: a -> (Ptr Word8 -> IO ()) -> IO ()
bindWriteBuffer :: Ptr Word8 -> a -> IO ()
bindDataSize :: a -> Int
bindBufferSize :: a -> Int
bindBufferSize v = bindDataSize v
bindNullInd :: a -> CShort
bindNullInd _ = 0
bindType :: a -> CInt
instance OracleBind a => OracleBind (Maybe a) where
bindWithValue (Just v) a = bindWithValue v a
bindWithValue Nothing a = a nullPtr
bindWriteBuffer b (Just v) = bindWriteBuffer b v
bindWriteBuffer b Nothing = return ()
bindDataSize (Just v) = bindDataSize v
bindDataSize Nothing = 0
bindBufferSize (Just v) = bindBufferSize v
bindBufferSize x@Nothing =
let (Just v) = (Just undefined) `asTypeOf` x in bindBufferSize v
bindNullInd (Just v) = 0
bindNullInd Nothing = -1
bindType (Just v) = bindType v
bindType Nothing = bindType (undefined :: a)
instance OracleBind String where
bindWithValue v a = withCString v (\p -> a (castPtr p))
bindWriteBuffer b s = withCStringLen s (\(p,l) ->
copyBytes (castPtr b) p (1+l))
bindDataSize s = fromIntegral (length s)
bindBufferSize _ = 32000
bindType _ = oci_SQLT_CHR
instance OracleBind Int where
bindWithValue v a = withBinaryValue toCInt v (\p v -> poke (castPtr p) v) a
bindWriteBuffer b v = poke (castPtr b) v
bindDataSize _ = (sizeOf (toCInt 0))
bindType _ = oci_SQLT_INT
instance OracleBind Double where
bindWithValue v a = withBinaryValue toCDouble v (\p v -> poke (castPtr p) v) a
bindWriteBuffer b v = poke (castPtr b) v
bindDataSize _ = (sizeOf (toCDouble 0.0))
bindType _ = oci_SQLT_FLT
instance OracleBind CalendarTime where
bindWithValue v a = withBinaryValue id v (\p dt -> calTimeToBuffer (castPtr p) dt) a
bindWriteBuffer b v = calTimeToBuffer (castPtr b) v
bindDataSize _ = 7
bindType _ = oci_SQLT_DAT
instance OracleBind UTCTime where
bindWithValue v a = withBinaryValue id v (\p dt -> utcTimeToBuffer (castPtr p) dt) a
bindWriteBuffer b v = utcTimeToBuffer (castPtr b) v
bindDataSize _ = 7
bindType _ = oci_SQLT_DAT
instance OracleBind StmtHandle where
bindWithValue v a = alloca (\p -> poke p v >> a (castPtr p))
bindWriteBuffer b v = poke (castPtr b) v
bindDataSize _ = sizeOf nullPtr
bindType _ = oci_SQLT_RSET
withBinaryValue :: (OracleBind b) =>
(b -> a)
-> b
-> (Ptr Word8 -> a -> IO ())
-> (Ptr Word8 -> IO ())
-> IO ()
withBinaryValue fn v pok action =
allocaBytes (bindDataSize v) $ \p -> do
pok p (fn v)
action (castPtr p)
clength :: Foldable m => m a -> Integer
clength = fromIntegral . length
toCInt :: Int -> CInt; toCInt = fromIntegral
fromCInt :: CInt -> Int; fromCInt = fromIntegral
toCChar :: Char -> CChar; toCChar = toEnum . fromEnum
fromCChar :: CChar -> Char; fromCChar = toEnum . fromEnum
toCDouble :: Double -> CDouble; toCDouble = realToFrac
fromCDouble :: CDouble -> Double; fromCDouble = realToFrac
toCFloat :: Float -> CFloat; toCFloat = realToFrac
fromCFloat :: CFloat -> Float; fromCFloat = realToFrac
data Query = Query
{ queryStmt :: PreparedStmtObj
, querySess :: Session
, queryParent :: Maybe PreparedStmtObj
}
data QueryResourceUsage = QueryResourceUsage { prefetchRowCount :: Int }
defaultResourceUsage :: QueryResourceUsage
defaultResourceUsage = QueryResourceUsage 100
data QueryStringTuned = QueryStringTuned QueryResourceUsage String [BindA Session PreparedStmtObj BindObj]
sqlbind :: String -> [BindA Session PreparedStmtObj BindObj] -> QueryStringTuned
sqlbind sql parms = QueryStringTuned defaultResourceUsage sql parms
prefetch :: Int -> String -> [BindA Session PreparedStmtObj BindObj] -> QueryStringTuned
prefetch count sql parms = QueryStringTuned (QueryResourceUsage count) sql parms
instance Statement BoundStmt Session Query where
makeQuery sess bstmt = return (Query (boundStmt bstmt) sess (Just (boundStmt bstmt)))
instance Statement PreparedStmtObj Session Query where
makeQuery sess pstmt = return (Query pstmt sess (Just pstmt))
instance Statement QueryString Session Query where
makeQuery sess (QueryString sqltext) = makeQuery sess sqltext
instance Statement String Session Query where
makeQuery sess sqltext = makeQuery sess (QueryStringTuned defaultResourceUsage sqltext [])
instance Statement (RefCursor StmtHandle) Session Query where
makeQuery sess (RefCursor stmt) = do
pstmt <- newPreparedStmt FreeManually SelectType sess stmt
return (Query pstmt sess Nothing)
instance Statement (NextResultSet mark PreparedStmtObj) Session Query where
makeQuery sess (NextResultSet (PreparedStmt pstmt)) = do
cursors <- readIORef (stmtCursors pstmt)
if null cursors then throwDB (DBError ("02", "000") (-1) "No more result sets to process.") else return ()
writeIORef (stmtCursors pstmt) (tail cursors)
makeQuery sess (head cursors)
instance Statement QueryStringTuned Session Query where
makeQuery sess (QueryStringTuned resUsage sqltext bas) = do
let
(PreparationA action) =
prepareStmt' (prefetchRowCount resUsage) sqltext FreeWithQuery SelectType
pstmt <- action sess
sequence_ (zipWith (\i (BindA ba) -> ba sess pstmt i) [1..] bas)
execute sess (stmtHandle pstmt) 0
return (Query pstmt sess (Just pstmt))
instance Statement CommandBind Session Query where
makeQuery sess (CommandBind sqltext bas) = do
let
(PreparationA action) =
prepareStmt' 1 sqltext FreeWithQuery CommandType
pstmt <- action sess
sequence_ (zipWith (\i (BindA ba) -> ba sess pstmt i) [1..] bas)
execute sess (stmtHandle pstmt) 1
return (Query pstmt sess (Just pstmt))
data ColumnBuffer = ColumnBuffer
{ colBufBufferFPtr :: OCI.ColumnResultBuffer
, colBufNullFPtr :: ForeignPtr CShort
, colBufSizeFPtr :: ForeignPtr CUShort
, colBufColPos :: Int
, colBufSqlType :: CInt
}
instance IQuery Query Session ColumnBuffer where
destroyQuery query = do
let pstmt = queryStmt query
case stmtLifetime pstmt of
FreeWithQuery -> closeStmt (stmtSession pstmt) (stmtHandle pstmt)
_ -> return ()
fetchOneRow query = do
let pstmt = queryStmt query
buffers <- readIORef (stmtBuffers pstmt)
if not (null buffers) then return True
else do
rc <- fetchRow (querySess query) pstmt
return (rc /= oci_NO_DATA)
currentRowNum query =
getRowCount (querySess query) (stmtHandle (queryStmt query))
freeBuffer q buffer = return ()
allocBuffer query (bufsize, ociBufferType) colpos = do
buffers <- readIORef (stmtBuffers (queryStmt query))
if null buffers
then do
(_, buf, nullptr, sizeptr) <- liftIO $ defineCol (querySess query) (queryStmt query) colpos bufsize ociBufferType
return $ ColumnBuffer
{ colBufBufferFPtr = buf
, colBufNullFPtr = nullptr
, colBufSizeFPtr = sizeptr
, colBufColPos = colpos
, colBufSqlType = ociBufferType
}
else do
if length buffers >= colpos
then return (buffers !! (colpos - 1))
else
throwDB (DBError ("02", "000") (-1) ( "There are " ++ show (length buffers)
++ " output buffers, but you have asked for buffer " ++ show colpos ))
allocStmtBuffer query colpos = do
colbuf <- allocBuffer query (sizeOf nullPtr, oci_SQLT_RSET) colpos
buffers <- readIORef (stmtBuffers (queryStmt query))
if null buffers
then do
stmt <- getStmt (querySess query)
withForeignPtr (colBufBufferFPtr colbuf) $ \p -> poke (castPtr p) stmt
else return ()
return colbuf
bufferToString :: ColumnBuffer -> IO (Maybe String)
bufferToString buffer = OCI.bufferToString (undefined, colBufBufferFPtr buffer, colBufNullFPtr buffer, colBufSizeFPtr buffer)
bufferToCaltime :: ColumnBuffer -> IO (Maybe CalendarTime)
bufferToCaltime buffer = OCI.bufferToCaltime (colBufNullFPtr buffer) (colBufBufferFPtr buffer)
bufferToUTCTime :: ColumnBuffer -> IO (Maybe UTCTime)
bufferToUTCTime buffer = OCI.bufferToUTCTime (colBufNullFPtr buffer) (colBufBufferFPtr buffer)
calTimeToBuffer :: OCI.BufferPtr -> CalendarTime -> IO ()
calTimeToBuffer buf ct = OCI.calTimeToBuffer buf ct
utcTimeToBuffer :: OCI.BufferPtr -> UTCTime -> IO ()
utcTimeToBuffer buf utc = OCI.utcTimeToBuffer buf utc
bufferToInt :: ColumnBuffer -> IO (Maybe Int)
bufferToInt buffer = OCI.bufferToInt (colBufNullFPtr buffer) (colBufBufferFPtr buffer)
bufferToDouble :: ColumnBuffer -> IO (Maybe Double)
bufferToDouble buffer = OCI.bufferToDouble (colBufNullFPtr buffer) (colBufBufferFPtr buffer)
bufferToStmtHandle :: ColumnBuffer -> IO (RefCursor StmtHandle)
bufferToStmtHandle buffer = do
v <- OCI.bufferToStmtHandle (colBufBufferFPtr buffer)
return (RefCursor v)
instance DBType (RefCursor StmtHandle) Query ColumnBuffer where
allocBufferFor _ q n = allocStmtBuffer q n
fetchCol q buffer = do
rawstmt <- OCI.bufferToStmtHandle (colBufBufferFPtr buffer)
appendRefCursor q (RefCursor rawstmt)
appendRefCursor query refc = do
case queryParent query of
Nothing -> return ()
Just pstmt -> modifyIORef (stmtCursors pstmt) (++ [refc])
return refc
instance DBType (Maybe String) Query ColumnBuffer where
allocBufferFor _ q n = allocBuffer q (16000, oci_SQLT_CHR) n
fetchCol q buffer = bufferToString buffer
instance DBType (Maybe Int) Query ColumnBuffer where
allocBufferFor _ q n = allocBuffer q (4, oci_SQLT_INT) n
fetchCol q buffer = bufferToInt buffer
instance DBType (Maybe Double) Query ColumnBuffer where
allocBufferFor _ q n = allocBuffer q (8, oci_SQLT_FLT) n
fetchCol q buffer = bufferToDouble buffer
instance DBType (Maybe UTCTime) Query ColumnBuffer where
allocBufferFor _ q n = allocBuffer q (7, oci_SQLT_DAT) n
fetchCol q buffer = bufferToUTCTime buffer
instance DBType (Maybe CalendarTime) Query ColumnBuffer where
allocBufferFor _ q n = allocBuffer q (7, oci_SQLT_DAT) n
fetchCol q buffer = bufferToCaltime buffer
instance DBType (Maybe a) Query ColumnBuffer
=> DBType a Query ColumnBuffer where
allocBufferFor v q n = allocBufferFor (Just v) q n
fetchCol q buffer = throwIfDBNull (buffer_pos q buffer) (fetchCol q buffer)
buffer_pos q buffer = do
row <- currentRowNum q
return (row, colBufColPos buffer)
instance (Show a, Read a) => DBType (Maybe a) Query ColumnBuffer where
allocBufferFor _ q n = allocBuffer q (16000, oci_SQLT_CHR) n
fetchCol q buffer = do
v <- bufferToString buffer
case v of
Just s -> if s == "" then return Nothing else return (Just (read s))
Nothing -> return Nothing