sednaDBXML-0.1.2.4: src/Database/SednaBindings.hs
module Database.SednaBindings
( sednaBegin
, sednaCloseConnection
, sednaCommit
, sednaConnect
, sednaEndLoadData
, sednaExecute
, sednaExecuteLong
, sednaGetConnectionAttr
, sednaGetData
, sednaGetLastErrorCode
, sednaGetLastErrorMsg
, sednaGetResultString
, sednaNext
, sednaResetAllConnectionAttr
, sednaRollBack
, sednaSetConnectionAttr
, sednaShowTime
, sednaTransactionStatus
, sednaLoadFile
, sednaLoadData
) where
--------------------------------------------------------------------------------
import Control.Exception
import Control.Monad.Trans
import Data.ByteString as BS
import Data.ByteString.Char8 as C
import Data.Iteratee as I hiding (mapM_, peek)
import Data.Iteratee.IO
import Data.Maybe
import Foreign
import Foreign.C.String
import Foreign.C.Types
import Prelude hiding (replicate,concat)
import qualified Data.Map as DM (fromList, lookup)
import Database.Internal.SednaCBindings
import Database.Internal.SednaConnectionAttributes
import Database.Internal.SednaResponseCodes
import Database.SednaExceptions
import Database.SednaTypes
--------------------------------------------------------------------------------
sednaConnect :: URL
-> DBName
-> UserName
-> Password
-> IO SednaConnection
sednaConnect url dbname login password =
do
conn <- malloc
cUrl <- newCString url
cDbname <- newCString dbname
cLogin <- newCString login
cPassword <- newCString password
status <- c'SEconnect conn
cUrl
cDbname
cLogin
cPassword
mapM_ free [cUrl,cDbname,cLogin,cPassword]
case fromCConstant status of
SessionOpen -> return $ conn
OpenSessionFailed -> free conn >> throw SednaOpenSessionFailedException
AuthenticationFailed -> free conn >> throw SednaAuthenticationFailedException
_ -> free conn >> throw SednaFailedException
--------------------------------------------------------------------------------
sednaCloseConnection :: SednaConnection -> IO ()
sednaCloseConnection conn = do
resultCode <- c'SEclose conn
free conn
case fromCConstant resultCode of
SessionClosed -> return ()
CloseSessionFailed -> throw SednaCloseSessionFailedException
_ -> throw SednaFailedException
--------------------------------------------------------------------------------
sednaBegin :: SednaConnection -> IO ()
sednaBegin conn = do
resultCode <- c'SEbegin conn
case fromCConstant resultCode of
BeginTransactionSucceeded -> return ()
BeginTransactionFailed -> throw SednaBeginTransactionFailedException
_ -> throw SednaFailedException
--------------------------------------------------------------------------------
sednaRollBack :: SednaConnection -> IO ()
sednaRollBack conn = do
resultCode <- c'SErollback conn
case fromCConstant resultCode of
RollBackTansactionSucceeded -> return ()
RollBackTransactionFailed -> throw SednaRollBackTransactionFailedException
_ -> throw SednaFailedException
--------------------------------------------------------------------------------
sednaCommit :: SednaConnection -> IO ()
sednaCommit conn = do
resultCode <- c'SEcommit conn
case fromCConstant resultCode of
CommitTransactionSucceeded -> return ()
CommitTransactionFailed -> throw SednaCommitTransactionFailedException
_ -> throw SednaFailedException
--------------------------------------------------------------------------------
sednaExecuteAction :: (SednaConnection -> CString -> IO CInt)
-> SednaConnection
-> Query
-> IO ()
sednaExecuteAction sednaQueryAction conn query = do
resultCode <- withCString query $ sednaQueryAction conn
case fromCConstant resultCode of
QuerySucceeded -> return ()
QueryFailed -> throw SednaQueryFailedException
_ -> throw SednaFailedException
--------------------------------------------------------------------------------
sednaExecuteLong :: SednaConnection -> Query -> IO ()
sednaExecuteLong = sednaExecuteAction c'SEexecuteLong
--------------------------------------------------------------------------------
sednaExecute :: SednaConnection -> Query -> IO ()
sednaExecute = sednaExecuteAction c'SEexecute
--------------------------------------------------------------------------------
sednaGetData :: SednaConnection -> Int -> IO (SednaResponseCode, ByteString)
sednaGetData conn size = useAsCStringLen (BS.replicate size 0) loadData
where
loadData bufferLengthPair = do
let buff = fst bufferLengthPair
let size' = fromIntegral (snd bufferLengthPair)
numOfBytesRead <- c'SEgetData conn buff size'
response <- return $ getResponse numOfBytesRead size'
bytes <- packCStringLen (buff, fromIntegral numOfBytesRead)
return $ (response, bytes)
where
getResponse num buffSize | num > buffSize = SednaError
| num < 0 = fromCConstant num
| num == 0 = ResultEnd
| num > 0 = OperationSucceeded
| otherwise = SednaError
--------------------------------------------------------------------------------
sednaLoadData :: SednaConnection
-> ByteString
-> Document
-> Collection
-> IO ()
sednaLoadData conn buff docName colName = do
useAsCStringLen buff loadData
where
loadData s = do
let buff' = fst s
let bytes = fromIntegral $ snd s
cDocName <- newCString docName
cColName <- newCString colName
response <- c'SEloadData conn buff' bytes cDocName cColName
mapM_ free [cDocName, cColName]
case fromCConstant response of
DataChunkLoaded -> return ()
_ -> throw SednaFailedException
--------------------------------------------------------------------------------
sednaEndLoadData :: SednaConnection -> IO ()
sednaEndLoadData conn = do
resultCode <- c'SEendLoadData conn
case fromCConstant resultCode of
BulkLoadSucceeded -> return ()
_ -> throw SednaFailedException
--------------------------------------------------------------------------------
sednaNext :: SednaConnection -> IO SednaResponseCode
sednaNext conn = do
resultCode <- c'SEnext conn
return $ fromCConstant resultCode
--------------------------------------------------------------------------------
sednaGetLastErrorCode :: SednaConnection -> IO SednaResponseCode
sednaGetLastErrorCode conn = do
resultCode <- c'SEgetLastErrorCode conn
return $ fromCConstant resultCode
--------------------------------------------------------------------------------
sednaGetLastErrorMsg :: SednaConnection -> IO String
sednaGetLastErrorMsg conn = peekCAString =<< c'SEgetLastErrorMsg conn
--------------------------------------------------------------------------------
sednaTransactionStatus :: SednaConnection -> IO SednaResponseCode
sednaTransactionStatus conn = do resultCode <- c'SEtransactionStatus conn
return $ fromCConstant resultCode
--------------------------------------------------------------------------------
sednaShowTime :: SednaConnection -> IO String
sednaShowTime conn = peekCAString =<< c'SEshowTime conn
--------------------------------------------------------------------------------
sednaConnectionAttributeMap :: SednaConnAttrValue -> Maybe SednaConnectionAttr
sednaConnectionAttributeMap attr = DM.lookup attr attrValToAttrMap
where
attrValToAttrMap =
DM.fromList [ (autoCommitOff , attrAutoCommit)
, (autoCommitOn , attrAutoCommit)
, (readOnlyTransaction , attrConcurrencyType)
, (updateTransaction , attrConcurrencyType)
, (debugOn , attrDebug)
, (debugOff , attrDebug)
, (logLess , attrLogAmount)
, (logFull , attrLogAmount)
, (boundarySpacePreserveOn , attrBoundarySpacePreserveWhileLoad)
, (boundarySpacePreserveOff , attrBoundarySpacePreserveWhileLoad)
]
--------------------------------------------------------------------------------
sednaSetConnectionAttr :: SednaConnection
-> SednaConnAttrValue
-> IO ()
sednaSetConnectionAttr conn attrVal =
alloca (\ptrAttrVal -> do
let connAttr = fromIntegral $
sednaConnectionAttr $
fromJust (sednaConnectionAttributeMap attrVal)
let attr = sednaConnAttrValue attrVal
let size = fromIntegral $ sizeOf attr
poke ptrAttrVal attr
response <- c'SEsetConnectionAttr
conn
connAttr
(castPtr ptrAttrVal)
size
case fromCConstant response of
SetAttributeSucceeded -> return ()
_ -> throw SednaFailedException)
--------------------------------------------------------------------------------
sednaGetConnectionAttr :: SednaConnection
-> SednaConnectionAttr
-> IO SednaConnAttrValue
sednaGetConnectionAttr conn connAttr =
alloca (\sizePtr -> do
let attr = fromIntegral $ sednaConnectionAttr connAttr
responsePtr <- malloc :: IO (Ptr CInt)
resultCode <- c'SEgetConnectionAttr conn
attr
(castPtr responsePtr)
sizePtr
response <- peek (castPtr responsePtr)
case fromCConstant resultCode of
GetAttributeSucceeded -> return (SednaConnAttrValue response)
_ -> throw SednaFailedException)
--------------------------------------------------------------------------------
sednaResetAllConnectionAttr :: SednaConnection -> IO ()
sednaResetAllConnectionAttr conn = do
resultCode <- c'SEresetAllConnectionAttr conn
case fromCConstant resultCode of
ResetAttributeSucceeded -> return ()
_ -> throw SednaFailedException
--------------------------------------------------------------------------------
sednaGetResultString :: SednaConnection -> IO QueryResult
sednaGetResultString conn = procItemStream conn 8 getXMLData
--------------------------------------------------------------------------------
getXMLData :: (Monad m) => Iteratee [ByteString] m QueryResult
getXMLData = icont (step C.empty) Nothing
where
step acc (Chunk bs)
| bs == [] = icont (step acc) Nothing
| otherwise = icont (step $ C.append acc (C.concat $ bs)) Nothing
step acc (EOF _) = idone (C.unpack acc) (EOF Nothing)
--------------------------------------------------------------------------------
procItemStream :: SednaConnection -> Int -> Iteratee [ByteString] IO a -> IO a
procItemStream conn size iter = step iter
where step iter' = do
iter'' <- enumItemChunked conn size iter' >>= run
res <- sednaNext conn
case res of
NextItemSucceeded -> step iter''
ResultEnd -> run iter''
NextItemFailed -> throw SednaNextItemFailedException
_ -> throw SednaFailedException
--------------------------------------------------------------------------------
enumItemChunked :: SednaConnection
-> Int
-> Iteratee [ByteString] IO a
-> IO (Iteratee ByteString IO (Iteratee [ByteString] IO a))
enumItemChunked conn size = (enumItem conn size) . I.group size
--------------------------------------------------------------------------------
enumItem :: SednaConnection -> Int -> Enumerator ByteString IO a
enumItem conn size = enumFromCallback cb ()
where
cb () = do
(code, result) <- sednaGetData conn size
case code of
OperationSucceeded -> return $ Right ((True, ()), result)
ResultEnd -> return $ Right ((False, ()), result)
_ -> throw SednaFailedException
--------------------------------------------------------------------------------
loadXMLBytes:: MonadIO m => SednaConnection
-> String
-> String
-> Iteratee ByteString m ()
loadXMLBytes conn doc coll = liftIO (sednaBegin conn) >> liftI step
where
step (I.Chunk xs)
| xs == (C.pack "") = liftI step
| otherwise = do
liftIO $ sednaLoadData conn xs doc coll
liftI step
step stream = do
response <- liftIO $ c'SEendLoadData conn
case fromCConstant response of
BulkLoadSucceeded -> liftIO (sednaCommit conn) >> idone () stream
BulkLoadFailed -> throw SednaBulkLoadFailedException
_ -> throw SednaFailedException
--------------------------------------------------------------------------------
sednaLoadFile :: SednaConnection -> FilePath -> Document -> Collection -> IO ()
sednaLoadFile conn file doc coll = do
iteratee <- enumFile 8 file $ loadXMLBytes
conn
doc
coll
run iteratee