sednaDBXML-0.1.0: src/Database/SednaDB/SednaBindings.hs
module Database.SednaDB.SednaBindings
( sednaBegin
, sednaCloseConnection
, sednaCommit
, sednaConnect
, sednaEndLoadData
, sednaExecute
, sednaExecuteLong
, sednaGetConnectionAttr
, sednaGetData
, sednaGetLastErrorCode
, sednaGetLastErrorMsg
, sednaGetResultString
, sednaLoadData
, sednaNext
, sednaResetAllConnectionAttr
, sednaRollBack
, sednaSetConnectionAttr
, sednaShowTime
, sednaTransactionStatus
, sednaLoadFile
) where
--------------------------------------------------------------------------------
import Data.ByteString as BS
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 Data.Iteratee as I hiding (mapM_, peek)
import Data.Iteratee.IO
import Control.Monad.Trans
import Data.ByteString.Char8 as C
import Control.Exception
import Database.SednaDB.SednaTypes
import Database.SednaDB.Internal.SednaCBindings
import Database.SednaDB.Internal.SednaConnectionAttributes
import Database.SednaDB.Internal.SednaResponseCodes
import Database.SednaDB.SednaExceptions
--------------------------------------------------------------------------------
sednaConnect :: URL
-> DBName
-> UserName
-> Password
-> IO (SednaResponseCode, 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]
return (fromCConstant status, conn)
--------------------------------------------------------------------------------
withSednaConnection :: (SednaConnection -> IO CInt)
-> SednaConnection
-> IO SednaResponseCode
withSednaConnection sednaAction conn =
do
response <- sednaAction $ conn
return $ fromCConstant response
--------------------------------------------------------------------------------
sednaCloseConnection :: SednaConnection -> IO SednaResponseCode
sednaCloseConnection = withSednaConnection c'SEclose
--------------------------------------------------------------------------------
sednaBegin :: SednaConnection -> IO SednaResponseCode
sednaBegin = withSednaConnection c'SEbegin
--------------------------------------------------------------------------------
sednaRollBack :: SednaConnection -> IO SednaResponseCode
sednaRollBack = withSednaConnection c'SErollback
--------------------------------------------------------------------------------
sednaCommit :: SednaConnection -> IO SednaResponseCode
sednaCommit = withSednaConnection c'SEcommit
--------------------------------------------------------------------------------
sednaExecuteAction :: (SednaConnection -> CString -> IO CInt)
-> SednaConnection
-> Query
-> IO SednaResponseCode
sednaExecuteAction sednaQueryAction conn query = do
resultCode <- withCString query $ sednaQueryAction conn
return $ fromCConstant resultCode
--------------------------------------------------------------------------------
sednaExecuteLong :: SednaConnection -> Query -> IO SednaResponseCode
sednaExecuteLong = sednaExecuteAction c'SEexecuteLong
--------------------------------------------------------------------------------
sednaExecute :: SednaConnection -> Query -> IO SednaResponseCode
sednaExecute = sednaExecuteAction c'SEexecute
--------------------------------------------------------------------------------
-- SednaGetData deals with an underlying c function c'SEgetData which
-- has heterogeneous response types. To remedy this, SednaGetData
-- returns an OperationSucceeded response on success when receiving
-- the number of bytes read from the underlying c function. This is
-- why you see this function returning its own response code instead
-- of simply encoding values from the response of c'SEgetData.
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 SednaResponseCode
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]
return $ fromCConstant response
--------------------------------------------------------------------------------
sednaEndLoadData :: SednaConnection -> IO SednaResponseCode
sednaEndLoadData = withSednaConnection c'SEendLoadData
--------------------------------------------------------------------------------
sednaNext :: SednaConnection -> IO SednaResponseCode
sednaNext = withSednaConnection c'SEnext
--------------------------------------------------------------------------------
sednaGetLastErrorCode :: SednaConnection -> IO SednaResponseCode
sednaGetLastErrorCode = withSednaConnection c'SEgetLastErrorCode
--------------------------------------------------------------------------------
sednaGetLastErrorMsg :: SednaConnection -> IO SednaResponseCode
sednaGetLastErrorMsg = withSednaConnection c'SEgetLastErrorMsg
--------------------------------------------------------------------------------
sednaTransactionStatus :: SednaConnection -> IO SednaResponseCode
sednaTransactionStatus = withSednaConnection c'SEtransactionStatus
--------------------------------------------------------------------------------
sednaShowTime :: SednaConnection -> IO SednaResponseCode
sednaShowTime = withSednaConnection c'SEshowTime
--------------------------------------------------------------------------------
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 SednaResponseCode
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
return $ fromCConstant response)
--------------------------------------------------------------------------------
sednaGetConnectionAttr :: SednaConnection
-> SednaConnectionAttr
-> IO (SednaResponseCode, SednaConnAttrValue)
sednaGetConnectionAttr conn connAttr =
alloca (\sizePtr -> do
let attr = fromIntegral $ sednaConnectionAttr connAttr
resultPtr <- malloc :: IO (Ptr CInt)
resultCode <- c'SEgetConnectionAttr conn
attr
(castPtr resultPtr)
sizePtr
response <- peek (castPtr resultPtr)
return (fromCConstant resultCode, SednaConnAttrValue response))
--------------------------------------------------------------------------------
sednaResetAllConnectionAttr :: SednaConnection -> IO SednaResponseCode
sednaResetAllConnectionAttr = withSednaConnection c'SEresetAllConnectionAttr
--------------------------------------------------------------------------------
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 s@(I.Chunk xs)
| xs == (C.pack "") = liftI step
| otherwise = do
response <- liftIO $ sednaLoadData conn xs doc coll
if response == DataChunkLoaded
then liftIO (print s) >> liftI step
else throw SednaFailedException
step stream = do
response <- liftIO $ sednaEndLoadData conn
case response of
BulkLoadSucceeded -> liftIO (sednaCommit conn) >> idone () stream
BulkLoadFailed -> throw SednaBulkLoadFailedException
_ -> throw SednaFailedException
--------------------------------------------------------------------------------
sednaLoadFile :: FilePath -> SednaConnection -> Document -> Collection -> IO ()
sednaLoadFile file conn doc coll = do
iteratee <- enumFile 8 file $ loadXMLBytes
conn
doc
coll
run iteratee