module Database.SednaDB.SednaBindings ( sednaBegin , sednaCloseConnection , sednaCommit , sednaConnect , sednaEndLoadData , sednaExecute , sednaExecuteLong , sednaGetConnectionAttr , sednaGetData , sednaGetLastErrorCode , sednaGetLastErrorMsg , sednaGetResultString , sednaNext , sednaResetAllConnectionAttr , sednaRollBack , sednaSetConnectionAttr , sednaShowTime , sednaTransactionStatus , sednaLoadFile , sednaLoadData ) 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 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 :: FilePath -> SednaConnection -> Document -> Collection -> IO () sednaLoadFile file conn doc coll = do iteratee <- enumFile 8 file $ loadXMLBytes conn doc coll run iteratee