{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances #-} {-# CFILES Database/Berkeley/dbxml_helper.cpp #-} -- | Berkeley DB binding. All IO monad functions can throw DbXmlException or DbException. module Database.Berkeley.DbXml ( -- * Common DbXmlFlag(..), ExceptionCode(..), DbXmlException(..), XmlResults, XmlResultsReturnable, -- * XmlContainer XmlContainer, xmlContainer_close, xmlContainer_deleteDocument, xmlContainer_getDocument, xmlContainer_getName, xmlContainer_putDocument, xmlContainer_updateDocument, xmlContainer_addIndex, xmlContainer_deleteIndex, -- * XmlDocument XmlDocument, xmlDocument_getContent, xmlDocument_getName, xmlDocument_setContent, xmlDocument_setName, xmlDocument_setMetaData, -- * XmlManager XmlManager, xmlManager_close, xmlManager_create, xmlManager_createDocument, ReturnType(..), EvaluationType(..), xmlManager_createQueryContext, xmlManager_createTransaction, xmlManager_createTransaction_DbTxn, xmlManager_createUpdateContext, ContainerType(..), xmlManager_existsContainer, xmlManager_openContainer, xmlManager_prepare, xmlManager_query, -- * XmlQueryContext XmlQueryContext, xmlQueryContext_setDefaultCollection, xmlQueryContext_setVariableValue, -- * XmlUpdateContext XmlUpdateContext, -- * XmlQueryExpression XmlQueryExpression, xmlQueryExpression_execute, -- * XmlResults xmlResults_hasNext, xmlResults_next, -- * XmlTransaction XmlTransaction, xmlTransaction_abort, xmlTransaction_commit, -- * XmlValue XmlValue, xmlBool, xmlDouble, xmlNone, xmlString, xmlXmlDocument, xmlValue_asString, -- * C++ integration XmlManager_native, xmlManager_toNative, XmlContainer_native, xmlContainer_toNative, xmlContainer_fromNative, XmlTransaction_native, xmlTransaction_fromNative, XmlQueryContext_native, xmlQueryContext_fromNative, XmlUpdateContext_native, xmlUpdateContext_fromNative ) where import Foreign.C import Foreign.Marshal.Alloc import Foreign.Storable import Foreign.Ptr import Foreign.ForeignPtr import Foreign.Marshal.Utils import Data.Bits import Database.Berkeley.Db import Data.Maybe import System.IO.Error import Data.Char import Data.Bits import System.IO.Unsafe import Data.ByteString (ByteString) import Data.Word import qualified Data.ByteString.Internal as BSI import Control.Exception import Data.Typeable import Control.Monad (when) dbOrFlags flags = foldr (.|.) 0 $ map dbToNum flags toUtf8 :: String -> String toUtf8 = concatMap charToUtf8 charToUtf8 :: Char -> String charToUtf8 ch = let c = ord(ch):: Int f0 = c .&. 0x3f f1 = (c `shiftR` 6) .&. 0x3f f2 = (c `shiftR` 12) .&. 0x3f f3 = (c `shiftR` 18) .&. 0x07 in case c of _ | c <= 0x007f -> [ch] _ | c <= 0x07ff -> [chr(0xc0 .|. f1),chr(0x80 .|. f0)] _ | c <= 0xffff -> [chr(0xe0 .|. f2),chr(0x80 .|. f1),chr(0x80 .|. f0)] _ -> [chr(0xf0 .|. f3),chr(0x80 .|. f2),chr(0x80 .|. f1),chr(0x80 .|. f0)] {- charFromUtf8 :: String -> (Char, String) charFromUtf8 (ch:chs) = let c = ord(ch):: Int in case c of _ | (c .&. 0x80) == 0 -> (c, cs) _ | (c .&. 0xc0) == 0xe0 -> ((c .&. 0x1f) `shiftL` 6) .|. -} data ExceptionCode = INTERNAL_ERROR | -- ^ An internal error occured. CONTAINER_OPEN | -- ^ The container is open. CONTAINER_CLOSED | -- ^ The container is closed. NULL_POINTER | -- ^ null pointer exception INDEXER_PARSER_ERROR | -- ^ XML Indexer could not parse a document. -- Note: DATABASE_ERROR is not used. We use DbException instead. QUERY_PARSER_ERROR | -- ^ The query parser was unable to parse the expression. UNUSED1_ERROR | -- ^ Unused QUERY_EVALUATION_ERROR | -- ^ The query evaluator was unable to execute the expression. UNUSED2_ERROR | -- ^ Unused LAZY_EVALUATION | -- ^ XmlResults is lazily evaluated. DOCUMENT_NOT_FOUND | -- ^ The specified document could not be found CONTAINER_EXISTS | -- ^ The container already exists. UNKNOWN_INDEX | -- ^ The indexing strategy name is unknown. INVALID_VALUE | -- ^ An invalid parameter was passed. VERSION_MISMATCH | -- ^ The container version and the dbxml library version are not compatible. EVENT_ERROR | -- ^ Error using the event reader CONTAINER_NOT_FOUND | -- ^ The specified container could not be found TRANSACTION_ERROR | -- ^ An XmlTransaction has already been committed or aborted UNIQUE_ERROR | -- ^ A uniqueness constraint has been violated NO_MEMORY_ERROR | -- ^ Unable to allocate memory OPERATION_TIMEOUT | -- ^ An operation timed out OPERATION_INTERRUPTED | -- ^ An operation was explicitly interrupted UNKNOWN_ERROR -- ^ An unexpected error code was received from Berkeley DbXML deriving (Show,Eq) dbxmlErrFromNum :: Int -> ExceptionCode dbxmlErrFromNum 0 = INTERNAL_ERROR dbxmlErrFromNum 1 = CONTAINER_OPEN dbxmlErrFromNum 2 = CONTAINER_CLOSED dbxmlErrFromNum 3 = NULL_POINTER dbxmlErrFromNum 4 = INDEXER_PARSER_ERROR dbxmlErrFromNum 6 = QUERY_PARSER_ERROR dbxmlErrFromNum 7 = UNUSED1_ERROR dbxmlErrFromNum 8 = QUERY_EVALUATION_ERROR dbxmlErrFromNum 9 = UNUSED2_ERROR dbxmlErrFromNum 10 = LAZY_EVALUATION dbxmlErrFromNum 11 = DOCUMENT_NOT_FOUND dbxmlErrFromNum 12 = CONTAINER_EXISTS dbxmlErrFromNum 13 = UNKNOWN_INDEX dbxmlErrFromNum 14 = INVALID_VALUE dbxmlErrFromNum 15 = VERSION_MISMATCH dbxmlErrFromNum 16 = EVENT_ERROR dbxmlErrFromNum 17 = CONTAINER_NOT_FOUND dbxmlErrFromNum 18 = TRANSACTION_ERROR dbxmlErrFromNum 19 = UNIQUE_ERROR dbxmlErrFromNum 20 = NO_MEMORY_ERROR dbxmlErrFromNum 21 = OPERATION_TIMEOUT dbxmlErrFromNum 22 = OPERATION_INTERRUPTED dbxmlErrFromNum _ = UNKNOWN_ERROR -- | An exception indicating an error in a Berkeley DBXML operation. data DbXmlException = DbXmlException String ExceptionCode deriving (Eq, Show, Typeable) instance Exception DbXmlException where throwDBXML :: String -> CInt -> String -> IO a throwDBXML func code extraText = do let descr = func++extraText if dbXmlCode == 5 -- 5 means 'DATABASE_ERROR' then throwIO $ DbException descr (dbErrFromNum dbCode) else throwIO $ DbXmlException descr (dbxmlErrFromNum dbXmlCode) where dbCode = -(fromIntegral code `mod` 100000) dbXmlCode = (fromIntegral code `div` 100000) - 1 -- | Note: If you want to pass a Berkeley DB flag where the type is DbXmlFlag, -- use the DB_FLAG constructor. data DbXmlFlag = DBXML_ADOPT_DBENV | -- ^ take ownership of DbEnv DBXML_ALLOW_EXTERNAL_ACCESS | -- ^ allow FS and net access DBXML_ALLOW_AUTO_OPEN | -- ^ auto-open in queries -- Flags used for container create/open DBXML_ALLOW_VALIDATION | -- ^ validate if specified DBXML_TRANSACTIONAL | -- ^ transactional container DBXML_CHKSUM | -- ^ use DB_CKSUM DBXML_ENCRYPT | -- ^ db->set_flags(DB_ENCRYPT); DBXML_INDEX_NODES | -- ^ use node indexes DBXML_NO_INDEX_NODES | -- ^ also used by lookupIndex DBXML_STATISTICS | -- ^ Store statistics about the data DBXML_NO_STATISTICS | -- ^ Do not store statistics about the data -- these next three are only used by XmlContainer::lookupIndex, and can -- safely re-use the preceding enumeration values. DBXML_REVERSE_ORDER | -- ^ return in reverse sort DBXML_INDEX_VALUES | -- ^ return values also DBXML_CACHE_DOCUMENTS | -- ^ ensure that two index entries that refer to the same document return the exact same XmlDocument object DBXML_LAZY_DOCS | -- ^ lazily materialize docs DBXML_DOCUMENT_PROJECTION | -- ^Use the document projection optimisation DBXML_NO_AUTO_COMMIT | -- ^ Do not auto transact the operation -- below used for putDocument, and query operations (reuses enum) DBXML_WELL_FORMED_ONLY | -- ^ well-formed parser only -- only used in putDocument, safe to reuse enum above DBXML_GEN_NAME | -- ^ generate name in putDoc DB_FLAG DbFlag -- ^ For wrapping a Berkeley DB flag dbxmlToNum :: DbXmlFlag -> Word32 dbxmlToNum DBXML_ADOPT_DBENV = 0x00000001 dbxmlToNum DBXML_ALLOW_EXTERNAL_ACCESS = 0x00000002 dbxmlToNum DBXML_ALLOW_AUTO_OPEN = 0x00000004 dbxmlToNum DBXML_ALLOW_VALIDATION = 0x00100000 dbxmlToNum DBXML_TRANSACTIONAL = 0x00200000 dbxmlToNum DBXML_CHKSUM = 0x00400000 dbxmlToNum DBXML_ENCRYPT = 0x00800000 dbxmlToNum DBXML_INDEX_NODES = 0x01000000 dbxmlToNum DBXML_NO_INDEX_NODES = 0x00010000 dbxmlToNum DBXML_STATISTICS = 0x02000000 dbxmlToNum DBXML_NO_STATISTICS = 0x04000000 dbxmlToNum DBXML_REVERSE_ORDER = 0x00100000 dbxmlToNum DBXML_INDEX_VALUES = 0x00200000 dbxmlToNum DBXML_CACHE_DOCUMENTS = 0x00400000 dbxmlToNum DBXML_LAZY_DOCS = 0x00800000 dbxmlToNum DBXML_DOCUMENT_PROJECTION = 0x80000000 dbxmlToNum DBXML_NO_AUTO_COMMIT = 0x00020000 dbxmlToNum DBXML_WELL_FORMED_ONLY = 0x01000000 dbxmlToNum DBXML_GEN_NAME = 0x02000000 dbxmlToNum (DB_FLAG f) = dbToNum f dbxmlOrFlags :: [DbXmlFlag] -> Word32 dbxmlOrFlags = foldr (.|.) 0 . map dbxmlToNum data XmlManager_struct type XmlManager = Ptr XmlManager_struct foreign import ccall safe "dbxml_helper.h _xmlManager" _xmlManager :: Ptr DbEnv_struct -> Word32 -> Ptr XmlManager -> IO CInt xmlManager_create :: DbEnv -> [DbXmlFlag] -> IO XmlManager xmlManager_create dbenv flags = withForeignPtr dbenv $ \c_dbenv -> alloca $ \ptr -> do ret <- _xmlManager c_dbenv (dbxmlOrFlags flags) ptr if ret /= 0 then throwDBXML "xmlManager_create" ret "" else peek ptr data XmlManager_native foreign import ccall "dbxml_helper.h _xmlManager_toNative" _xmlManager_toNative :: XmlManager -> Ptr (Ptr XmlManager_native) -> IO CInt -- | Extract a C++ pointer of type XmlManager* from the Haskell handle, which can be -- passed to C++. xmlManager_toNative :: XmlManager -> (Ptr XmlManager_native -> IO a) -> IO a xmlManager_toNative mgr code = alloca $ \pManager -> do ret <- _xmlManager_toNative mgr pManager if ret /= 0 then throwDBXML "xmlManager_toNative" ret "" else code =<< peek pManager data XmlContainer_struct type XmlContainer = ForeignPtr XmlContainer_struct foreign import ccall "dbxml_helper.h &_xmlContainer_delete" _xmlContainer_delete :: FunPtr (Ptr XmlContainer_struct -> IO ()) foreign import ccall "dbxml_helper.h &_xmlContainer_nullDelete" _xmlContainer_nullDelete :: FunPtr (Ptr XmlContainer_struct -> IO ()) data ContainerType = NodeContainer | WholedocContainer foreign import ccall safe "dbxml_helper.h _xmlManager_openContainer" _xmlManager_openContainer :: XmlManager -> CString -> Word32 -> CInt -> CInt -> Ptr (Ptr XmlContainer_struct) -> IO CInt xmlManager_openContainer :: XmlManager -> String -- ^ Container filename -> [DbXmlFlag] -> ContainerType -- ^ Default in C++ interface is NodeContainer -> Int -- ^ Unix file mode -> IO XmlContainer xmlManager_openContainer mgr filename flags cType mode = alloca $ \ptr -> withCAString filename $ \c_filename -> do ret <- _xmlManager_openContainer mgr c_filename (dbxmlOrFlags flags) (numCType cType) (fromIntegral mode) ptr if ret /= 0 then throwDBXML "xmlManager_openContainer" ret "" else do p <- peek ptr newForeignPtr _xmlContainer_delete p where numCType NodeContainer = 0 numCType WholedocContainer = 1 foreign import ccall safe "dbxml_helper.h _xmlManager_existsContainer" _xmlManager_existsContainer :: XmlManager -> CString -> IO CInt xmlManager_existsContainer :: XmlManager -> String -> IO Bool xmlManager_existsContainer mgr filename = withCAString filename $ \c_filename -> do ret <- _xmlManager_existsContainer mgr c_filename return (ret /= 0) data XmlTransaction_struct type XmlTransaction = ForeignPtr XmlTransaction_struct foreign import ccall "dbxml_helper.h &_xmlTransaction_delete" _xmlTransaction_delete :: FunPtr (Ptr XmlTransaction_struct -> IO ()) foreign import ccall safe "dbxml_helper.h _xmlManager_createTransaction" _xmlManager_createTransaction :: XmlManager -> Word32 -> Ptr (Ptr XmlTransaction_struct) -> IO CInt xmlManager_createTransaction :: XmlManager -> [DbFlag] -> IO XmlTransaction xmlManager_createTransaction mgr flags = alloca $ \ptr -> do ret <- _xmlManager_createTransaction mgr (dbOrFlags flags) ptr if ret /= 0 then throwDBXML "xmlManager_createTransaction" ret "" else do p <- peek ptr newForeignPtr _xmlTransaction_delete p foreign import ccall safe "dbxml_helper.h _xmlManager_createTransaction_DbTxn" _xmlManager_createTransaction_DbTxn :: XmlManager -> Ptr DbTxn_struct -> Ptr (Ptr XmlTransaction_struct) -> IO CInt xmlManager_createTransaction_DbTxn :: XmlManager -> DbTxn -> IO XmlTransaction xmlManager_createTransaction_DbTxn mgr dbtxn = alloca $ \ptr -> withForeignPtr dbtxn $ \c_dbtxn -> do ret <- _xmlManager_createTransaction_DbTxn mgr c_dbtxn ptr if ret /= 0 then throwDBXML "xmlManager_createTransaction_DbTxn" ret "" else do p <- peek ptr newForeignPtr _xmlTransaction_delete p data XmlTransaction_native foreign import ccall "dbxml_helper.h &_xmlTransaction_nullDestructor" _xmlTransaction_nullDestructor :: FunPtr (Ptr XmlTransaction_struct -> IO ()) foreign import ccall unsafe "dbxml_helper.h _xmlTransaction_fromNative" _xmlTransaction_fromNative :: Ptr XmlTransaction_native -> IO (Ptr XmlTransaction_struct) -- | Create a Haskell handle for a C++ transaction of type XmlTransaction*. The -- C++ code has the responsibility of cleaning it up. xmlTransaction_fromNative :: Ptr XmlTransaction_native -> IO XmlTransaction xmlTransaction_fromNative nat = do s <- _xmlTransaction_fromNative nat newForeignPtr _xmlTransaction_nullDestructor s -- Do not clean it up when we release it foreign import ccall safe "dbxml_helper.h _xmlTransaction_commit" _xmlTransaction_commit :: Ptr XmlTransaction_struct -> IO CInt xmlTransaction_commit :: XmlTransaction -> IO () xmlTransaction_commit trans = do ret <- withForeignPtr trans $ _xmlTransaction_commit if ret /= 0 then throwDBXML "xmlTransaction_commit" ret "" else return () foreign import ccall safe "dbxml_helper.h _xmlTransaction_abort" _xmlTransaction_abort :: Ptr XmlTransaction_struct -> IO CInt xmlTransaction_abort :: XmlTransaction -> IO () xmlTransaction_abort trans = do ret <- withForeignPtr trans $ _xmlTransaction_abort if ret /= 0 then throwDBXML "xmlTransaction_abort" ret "" else return () data XmlDocument_struct type XmlDocument = ForeignPtr XmlDocument_struct foreign import ccall safe "dbxml_helper.h &_xmlDocument_delete" _xmlDocument_delete :: FunPtr (Ptr XmlDocument_struct -> IO ()) data XmlContainer_native foreign import ccall "dbxml_helper.h _xmlContainer_toNative" _xmlContainer_toNative :: Ptr XmlContainer_struct -> Ptr (Ptr XmlContainer_native) -> IO CInt -- | Extract a C++ pointer of type XmlContainer* from the Haskell handle, which can be -- passed to C++. xmlContainer_toNative :: XmlContainer -> (Ptr XmlContainer_native -> IO a) -> IO a xmlContainer_toNative cont code = alloca $ \pCont -> withForeignPtr cont $ \c_cont -> do ret <- _xmlContainer_toNative c_cont pCont if ret /= 0 then throwDBXML "xmlContainer_toNative" ret "" else code =<< peek pCont foreign import ccall safe "dbxml_helper.h _xmlContainer_fromNative" _xmlContainer_fromNative :: Ptr XmlContainer_native -> Ptr (Ptr XmlContainer_struct) -> IO CInt -- | Make a Haskell handle from a native XmlContainer*, where the XmlContainer* is -- managed by someone else. xmlContainer_fromNative :: Ptr XmlContainer_native -> IO XmlContainer xmlContainer_fromNative c_cont = alloca $ \ptr -> do ret <- _xmlContainer_fromNative c_cont ptr if ret /= 0 then throwDBXML "xmlManager_openContainer" ret "" else do p <- peek ptr newForeignPtr _xmlContainer_nullDelete p foreign import ccall safe "dbxml_helper.h _xmlContainer_getDocument" _xmlContainer_getDocument :: Ptr XmlContainer_struct -> Ptr XmlTransaction_struct -> CString -> Word32 -> Ptr (Ptr XmlDocument_struct) -> IO CInt xmlContainer_getDocument :: XmlContainer -> Maybe XmlTransaction -> String -> [DbFlag] -> IO XmlDocument xmlContainer_getDocument cont mTrans key flags = alloca $ \ptr -> withCAString (toUtf8 key) $ \c_key -> do ret <- withForeignPtr cont $ \c_cont -> case mTrans of Just trans -> do withForeignPtr trans $ \c_trans -> _xmlContainer_getDocument c_cont c_trans c_key (dbOrFlags flags) ptr Nothing -> do _xmlContainer_getDocument c_cont nullPtr c_key (dbOrFlags flags) ptr if ret /= 0 then throwDBXML "xmlContainer_getDocument" ret "" else do p <- peek ptr newForeignPtr _xmlDocument_delete p foreign import ccall unsafe "db_helper.h _deleteString" _deleteString :: CString -> IO () foreign import ccall unsafe "dbxml_helper.h &_deleteString" _deleteString_finalizer :: FunPtr (Ptr Word8 -> IO ()) foreign import ccall safe "dbxml_helper.h _xmlContainer_getName" _xmlContainer_getName :: Ptr XmlContainer_struct -> IO CString xmlContainer_getName :: XmlContainer -> String xmlContainer_getName cont = unsafePerformIO$ do cstr <- withForeignPtr cont $ _xmlContainer_getName str <- peekCAString cstr _deleteString cstr return str foreign import ccall safe "dbxml_helper.h _xmlDocument_getContent" _xmlDocument_getContent :: Ptr XmlDocument_struct -> Ptr (Ptr Word8) -> Ptr CInt -> IO CInt xmlDocument_getContent :: XmlDocument -> IO ByteString xmlDocument_getContent doc = alloca $ \ptr -> alloca $ \pLength -> do ret <- withForeignPtr doc $ \c_doc -> _xmlDocument_getContent c_doc ptr pLength if ret /= 0 then throwDBXML "xmlDocument_getContent" ret "" else do cstr <- peek ptr length <- peek pLength str <- newForeignPtr _deleteString_finalizer cstr return $ BSI.fromForeignPtr str 0 (fromIntegral length) data XmlQueryContext_struct type XmlQueryContext = ForeignPtr XmlQueryContext_struct foreign import ccall safe "dbxml_helper.h &_xmlQueryContext_delete" _xmlQueryContext_delete :: FunPtr (Ptr XmlQueryContext_struct -> IO ()) foreign import ccall safe "dbxml_helper.h _xmlManager_createQueryContext" _xmlManager_createQueryContext :: Ptr XmlManager_struct -> CInt -> CInt -> Ptr (Ptr XmlQueryContext_struct) -> IO CInt data ReturnType = LiveValues rtToInt LiveValues = 0 data EvaluationType = Eager | Lazy evToInt Eager = 0 evToInt Lazy = 1 xmlManager_createQueryContext :: XmlManager -> ReturnType -> EvaluationType -> IO XmlQueryContext xmlManager_createQueryContext mgr rt ev = alloca $ \ptr -> do ret <- _xmlManager_createQueryContext mgr (rtToInt rt) (evToInt ev) ptr if ret /= 0 then throwDBXML "xmlManager_createQueryContext" ret "" else do p <- peek ptr newForeignPtr _xmlQueryContext_delete p data XmlResults_struct type XmlResults = ForeignPtr XmlResults_struct foreign import ccall "dbxml_helper.h &_xmlResults_delete" _xmlResults_delete :: FunPtr (Ptr XmlResults_struct -> IO ()) foreign import ccall safe "dbxml_helper.h _xmlResults_hasNext" _xmlResults_hasNext :: Ptr XmlResults_struct -> Ptr CInt -> IO CInt xmlResults_hasNext :: XmlResults -> IO Bool xmlResults_hasNext res = alloca $ \ptr -> do ret <- withForeignPtr res $ \c_res -> _xmlResults_hasNext c_res ptr if ret /= 0 then throwDBXML "xmlResults_hasNext" ret "" else do answer <- peek ptr return $ if answer /= 0 then True else False class XmlResultsReturnable a where xmlResults_next :: XmlResults -> IO (Maybe a) instance XmlResultsReturnable XmlDocument where xmlResults_next = xmlResults_nextDocument instance XmlResultsReturnable XmlValue where xmlResults_next = xmlResults_nextValue foreign import ccall safe "dbxml_helper.h _xmlResults_nextDocument" _xmlResults_nextDocument :: Ptr XmlResults_struct -> Ptr (Ptr XmlDocument_struct) -> IO CInt xmlResults_nextDocument :: XmlResults -> IO (Maybe XmlDocument) xmlResults_nextDocument res = alloca $ \ptr -> do ret <- withForeignPtr res $ \c_res -> _xmlResults_nextDocument c_res ptr if ret /= 0 then throwDBXML "xmlResults_next" ret "XmlDocument" else do doc <- peek ptr if doc == nullPtr then return Nothing else do fp <- newForeignPtr _xmlDocument_delete doc return $ Just fp foreign import ccall safe "dbxml_helper.h _xmlResults_nextValue" _xmlResults_nextValue :: Ptr XmlResults_struct -> Ptr (Ptr XmlValue_struct) -> IO CInt xmlResults_nextValue :: XmlResults -> IO (Maybe XmlValue) xmlResults_nextValue res = alloca $ \ptr -> do ret <- withForeignPtr res $ \c_res -> _xmlResults_nextValue c_res ptr if ret /= 0 then throwDBXML "xmlResults_next" ret "XmlValue" else do doc <- peek ptr if doc == nullPtr then return Nothing else do fp <- newForeignPtr _xmlValue_delete doc return $ Just fp -- Safe so it doesn't block other Haskell threads, since this one can take a while to execute foreign import ccall safe "dbxml_helper.h _xmlManager_query" _xmlManager_query :: Ptr XmlManager_struct -> Ptr XmlTransaction_struct -> CString -> Ptr XmlQueryContext_struct -> Word32 -> Ptr (Ptr XmlResults_struct) -> IO CInt xmlManager_query :: XmlManager -> Maybe XmlTransaction -> String -> XmlQueryContext -> [DbXmlFlag] -> IO XmlResults xmlManager_query mgr mTrans query ctx flags = alloca $ \ptr -> withCAString (toUtf8 query) $ \c_query -> withForeignPtr ctx $ \c_ctx -> do ret <- case mTrans of Just trans -> do withForeignPtr trans $ \c_trans -> _xmlManager_query mgr c_trans c_query c_ctx (dbxmlOrFlags flags) ptr Nothing -> do _xmlManager_query mgr nullPtr c_query c_ctx (dbxmlOrFlags flags) ptr if ret /= 0 then throwDBXML "xmlManager_query" ret (" query="++query) else do p <- peek ptr newForeignPtr _xmlResults_delete p data XmlQueryExpression_struct type XmlQueryExpression = ForeignPtr XmlQueryExpression_struct foreign import ccall "dbxml_helper.h &_xmlQueryExpression_delete" _xmlQueryExpression_delete :: FunPtr (Ptr XmlQueryExpression_struct -> IO ()) foreign import ccall safe "dbxml_helper.h _xmlManager_prepare" _xmlManager_prepare :: Ptr XmlManager_struct -> Ptr XmlTransaction_struct -> CString -> Ptr XmlQueryContext_struct -> Ptr (Ptr XmlQueryExpression_struct) -> IO CInt xmlManager_prepare :: XmlManager -> Maybe XmlTransaction -> String -> XmlQueryContext -> IO XmlQueryExpression xmlManager_prepare mgr mTrans query ctx = alloca $ \ptr -> withCAString (toUtf8 query) $ \c_query -> withForeignPtr ctx $ \c_ctx -> do ret <- case mTrans of Just trans -> do withForeignPtr trans $ \c_trans -> _xmlManager_prepare mgr c_trans c_query c_ctx ptr Nothing -> do _xmlManager_prepare mgr nullPtr c_query c_ctx ptr if ret /= 0 then throwDBXML "xmlManager_prepare" ret (" query="++query) else do p <- peek ptr newForeignPtr _xmlQueryExpression_delete p foreign import ccall safe "dbxml_helper.h _xmlQueryContext_setDefaultCollection" _xmlQueryContext_setDefaultCollection :: Ptr XmlQueryContext_struct -> CString -> IO CInt xmlQueryContext_setDefaultCollection :: XmlQueryContext -> String -> IO () xmlQueryContext_setDefaultCollection ctx coll = withCAString coll $ \c_coll -> do ret <- withForeignPtr ctx $ \c_ctx -> _xmlQueryContext_setDefaultCollection c_ctx c_coll if ret /= 0 then throwDBXML "xmlQueryContext_setDefaultCollection" ret (" arg="++coll) else return () data XmlValue_struct type XmlValue = ForeignPtr XmlValue_struct foreign import ccall "dbxml_helper.h &_xmlValue_delete" _xmlValue_delete :: FunPtr (Ptr XmlValue_struct -> IO ()) foreign import ccall safe "dbxml_helper.h _xmlNone" _xmlNone :: IO (Ptr XmlValue_struct) xmlNone :: XmlValue xmlNone = unsafePerformIO $ do xv <- _xmlNone newForeignPtr _xmlValue_delete xv foreign import ccall safe "dbxml_helper.h _xmlString" _xmlString :: CString -> IO (Ptr XmlValue_struct) xmlString :: String -> XmlValue xmlString text = unsafePerformIO $ do withCAString (toUtf8 text) $ \c_text -> do xv <- _xmlString c_text newForeignPtr _xmlValue_delete xv foreign import ccall safe "dbxml_helper.h _xmlBool" _xmlBool :: CInt -> IO (Ptr XmlValue_struct) xmlBool :: Bool -> XmlValue xmlBool b = unsafePerformIO $ do xv <- _xmlBool $ if b then 1 else 0 newForeignPtr _xmlValue_delete xv foreign import ccall safe "dbxml_helper.h _xmlDouble" _xmlDouble :: CDouble -> IO (Ptr XmlValue_struct) xmlDouble :: Double -> XmlValue xmlDouble value = unsafePerformIO $ do xv <- _xmlDouble $ realToFrac value newForeignPtr _xmlValue_delete xv foreign import ccall safe "dbxml_helper.h _xmlXmlDocument" _xmlXmlDocument :: Ptr XmlDocument_struct -> IO (Ptr XmlValue_struct) xmlXmlDocument :: XmlDocument -> XmlValue xmlXmlDocument doc = unsafePerformIO $ do withForeignPtr doc $ \c_doc -> do xv <- _xmlXmlDocument c_doc newForeignPtr _xmlValue_delete xv foreign import ccall safe "dbxml_helper.h _xmlValue_asString" _xmlValue_asString :: Ptr XmlValue_struct -> Ptr (Ptr Word8) -> Ptr CInt -> IO CInt -- | Get the string content of this XmlValue object and return it as a ByteString. xmlValue_asString :: XmlValue -> ByteString xmlValue_asString value = unsafePerformIO $ alloca $ \ptr -> alloca $ \pLength -> do ret <- withForeignPtr value $ \c_value -> _xmlValue_asString c_value ptr pLength if ret /= 0 then throwDBXML "xmlValue_asString" ret "" else do cstr <- peek ptr length <- peek pLength str <- newForeignPtr _deleteString_finalizer cstr return $ BSI.fromForeignPtr str 0 (fromIntegral length) foreign import ccall safe "dbxml_helper.h _xmlQueryContext_setVariableValue" _xmlQueryContext_setVariableValue :: Ptr XmlQueryContext_struct -> CString -> Ptr XmlValue_struct -> IO CInt xmlQueryContext_setVariableValue :: XmlQueryContext -> String -> XmlValue -> IO () xmlQueryContext_setVariableValue ctx name value = withCAString (toUtf8 name) $ \c_name -> do ret <- withForeignPtr ctx $ \c_ctx -> withForeignPtr value $ \c_value -> _xmlQueryContext_setVariableValue c_ctx c_name c_value if ret /= 0 then throwDBXML "xmlQueryContext_setVariableValue" ret (" name="++name++" value="++(show value)) else return () data XmlQueryContext_native foreign import ccall "dbxml_helper.h &_xmlQueryContext_nullDestructor" _xmlQueryContext_nullDestructor :: FunPtr (Ptr XmlQueryContext_struct -> IO ()) foreign import ccall unsafe "dbxml_helper.h _xmlQueryContext_fromNative" _xmlQueryContext_fromNative :: Ptr XmlQueryContext_native -> IO (Ptr XmlQueryContext_struct) xmlQueryContext_fromNative :: Ptr XmlQueryContext_native -> IO XmlQueryContext xmlQueryContext_fromNative uc_c = do uc <- _xmlQueryContext_fromNative uc_c newForeignPtr _xmlQueryContext_nullDestructor uc -- Safe so it doesn't block other Haskell threads, since this one can take a while to execute foreign import ccall safe "dbxml_helper.h _xmlQueryExpression_execute" _xmlQueryExpression_execute :: Ptr XmlQueryExpression_struct -> Ptr XmlTransaction_struct -> Ptr XmlValue_struct -> Ptr XmlQueryContext_struct -> Word32 -> Ptr (Ptr XmlResults_struct) -> IO CInt xmlQueryExpression_execute :: XmlQueryExpression -> Maybe XmlTransaction -> Maybe XmlValue -> XmlQueryContext -> [DbXmlFlag] -> IO XmlResults xmlQueryExpression_execute exp mTrans mContextItem qctx flags = alloca $ \ptr -> do ret <- withForeignPtr exp $ \c_exp -> withForeignPtr qctx $ \c_qctx -> do let flags_ = (dbxmlOrFlags flags) case (mTrans, mContextItem) of (Just trans, Just contextItem) -> do withForeignPtr trans $ \c_trans -> withForeignPtr contextItem $ \c_contextItem -> _xmlQueryExpression_execute c_exp c_trans c_contextItem c_qctx flags_ ptr (Just trans, Nothing) -> do withForeignPtr trans $ \c_trans -> _xmlQueryExpression_execute c_exp c_trans nullPtr c_qctx flags_ ptr (Nothing, Just contextItem) -> do withForeignPtr contextItem $ \c_contextItem -> _xmlQueryExpression_execute c_exp nullPtr c_contextItem c_qctx flags_ ptr (Nothing, Nothing) -> do _xmlQueryExpression_execute c_exp nullPtr nullPtr c_qctx flags_ ptr if ret /= 0 then throwDBXML "xmlQueryExpression_execute" ret "" else do p <- peek ptr newForeignPtr _xmlResults_delete p foreign import ccall safe "dbxml_helper.h _xmlManager_createDocument" _xmlManager_createDocument :: Ptr XmlManager_struct -> Ptr (Ptr XmlDocument_struct) -> IO CInt xmlManager_createDocument :: XmlManager -> IO XmlDocument xmlManager_createDocument mgr = alloca $ \ptr -> do ret <- _xmlManager_createDocument mgr ptr if ret /= 0 then throwDBXML "xmlManager_createDocument" ret "" else do p <- peek ptr newForeignPtr _xmlDocument_delete p foreign import ccall safe "dbxml_helper.h _xmlDocument_getName" _xmlDocument_getName :: Ptr XmlDocument_struct -> Ptr CString -> IO CInt xmlDocument_getName :: XmlDocument -> IO String xmlDocument_getName doc = alloca $ \ptr -> do ret <- withForeignPtr doc $ \c_doc -> _xmlDocument_getName c_doc ptr if ret /= 0 then throwDBXML "xmlDocument_getName" ret "" else do cstr <- peek ptr str <- peekCAString cstr _deleteString cstr return str foreign import ccall safe "dbxml_helper.h _xmlDocument_setName" _xmlDocument_setName :: Ptr XmlDocument_struct -> CString -> IO CInt xmlDocument_setName :: XmlDocument -> String -> IO () xmlDocument_setName doc name = withCAString name $ \c_name -> do ret <- withForeignPtr doc $ \c_doc -> _xmlDocument_setName c_doc c_name if ret /= 0 then throwDBXML "xmlDocument_setName" ret "" else return () foreign import ccall safe "dbxml_helper.h _xmlDocument_setMetaData" _xmlDocument_setMetaData :: Ptr XmlDocument_struct -> CString -> CString -> Ptr XmlValue_struct -> IO CInt xmlDocument_setMetaData :: XmlDocument -> String -> String -> XmlValue -> IO () xmlDocument_setMetaData doc uri name value = withCAString (toUtf8 uri) $ \c_uri -> withCAString (toUtf8 name) $ \c_name -> withForeignPtr doc $ \c_doc -> withForeignPtr value $ \c_value -> do ret <- _xmlDocument_setMetaData c_doc c_uri c_name c_value when (ret /= 0) $ throwDBXML "xmlDocument_setMetaData" ret (" uri=" ++ uri ++ " name=" ++ name ++ " value=" ++ show value) data XmlUpdateContext_struct type XmlUpdateContext = ForeignPtr XmlUpdateContext_struct foreign import ccall "dbxml_helper.h &_xmlUpdateContext_delete" _xmlUpdateContext_delete :: FunPtr (Ptr XmlUpdateContext_struct -> IO ()) foreign import ccall safe "dbxml_helper.h _xmlManager_createUpdateContext" _xmlManager_createUpdateContext :: Ptr XmlManager_struct -> Ptr (Ptr XmlUpdateContext_struct) -> IO CInt xmlManager_createUpdateContext :: XmlManager -> IO XmlUpdateContext xmlManager_createUpdateContext mgr = alloca $ \ptr -> do ret <- _xmlManager_createUpdateContext mgr ptr if ret /= 0 then throwDBXML "xmlManager_createUpdateContext" ret "" else do p <- peek ptr newForeignPtr _xmlUpdateContext_delete p data XmlUpdateContext_native foreign import ccall "dbxml_helper.h &_xmlUpdateContext_nullDestructor" _xmlUpdateContext_nullDestructor :: FunPtr (Ptr XmlUpdateContext_struct -> IO ()) foreign import ccall unsafe "dbxml_helper.h _xmlUpdateContext_fromNative" _xmlUpdateContext_fromNative :: Ptr XmlUpdateContext_native -> IO (Ptr XmlUpdateContext_struct) xmlUpdateContext_fromNative :: Ptr XmlUpdateContext_native -> IO XmlUpdateContext xmlUpdateContext_fromNative uc_c = do uc <- _xmlUpdateContext_fromNative uc_c newForeignPtr _xmlUpdateContext_nullDestructor uc foreign import ccall safe "dbxml_helper.h _xmlDocument_setContent" _xmlDocument_setContent :: Ptr XmlDocument_struct -> Ptr Word8 -> CUInt -> IO CInt xmlDocument_setContent :: XmlDocument -> ByteString -> IO () xmlDocument_setContent doc text = withByteString text $ \c_text text_length -> do ret <- withForeignPtr doc $ \c_doc -> _xmlDocument_setContent c_doc c_text (fromIntegral text_length) if ret /= 0 then throwDBXML "xmlDocument_setContent" ret "" else return () withByteString :: ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a withByteString bs code = do let (fp, fp_offset, length) = BSI.toForeignPtr bs withForeignPtr fp $ \c_fp -> code (c_fp `plusPtr` fp_offset) length foreign import ccall safe "dbxml_helper.h _xmlContainer_updateDocument" _xmlContainer_updateDocument :: Ptr XmlContainer_struct -> Ptr XmlTransaction_struct -> Ptr XmlDocument_struct -> Ptr XmlUpdateContext_struct -> IO CInt xmlContainer_updateDocument :: XmlContainer -> Maybe XmlTransaction -> XmlDocument -> XmlUpdateContext -> IO () xmlContainer_updateDocument cont mTrans doc uctx = do ret <- withForeignPtr cont $ \c_cont -> withForeignPtr doc $ \c_doc -> withForeignPtr uctx $ \c_uctx -> do case mTrans of Just trans -> do ret <- withForeignPtr trans $ \c_trans -> _xmlContainer_updateDocument c_cont c_trans c_doc c_uctx return ret Nothing -> do _xmlContainer_updateDocument c_cont nullPtr c_doc c_uctx if ret /= 0 then throwDBXML "xmlContainer_updateDocument" ret "" else return () foreign import ccall safe "dbxml_helper.h _xmlContainer_putDocument" _xmlContainer_putDocument :: Ptr XmlContainer_struct -> Ptr XmlTransaction_struct -> Ptr XmlDocument_struct -> Ptr XmlUpdateContext_struct -> Word32 -> IO CInt xmlContainer_putDocument :: XmlContainer -> Maybe XmlTransaction -> XmlDocument -> XmlUpdateContext -> [DbXmlFlag] -> IO () xmlContainer_putDocument cont mTrans doc uctx flags = do ret <- withForeignPtr cont $ \c_cont -> withForeignPtr doc $ \c_doc -> withForeignPtr uctx $ \c_uctx -> do case mTrans of Just trans -> do ret <- withForeignPtr trans $ \c_trans -> _xmlContainer_putDocument c_cont c_trans c_doc c_uctx (dbxmlOrFlags flags) return ret Nothing -> do _xmlContainer_putDocument c_cont nullPtr c_doc c_uctx (dbxmlOrFlags flags) if ret /= 0 then throwDBXML "xmlContainer_updateDocument" ret "" else return () foreign import ccall safe "dbxml_helper.h _xmlContainer_deleteDocument" _xmlContainer_deleteDocument :: Ptr XmlContainer_struct -> Ptr XmlTransaction_struct -> Ptr XmlDocument_struct -> Ptr XmlUpdateContext_struct -> IO CInt xmlContainer_deleteDocument :: XmlContainer -> Maybe XmlTransaction -> XmlDocument -> XmlUpdateContext -> IO () xmlContainer_deleteDocument cont mTrans doc uctx = do ret <- withForeignPtr cont $ \c_cont -> withForeignPtr doc $ \c_doc -> withForeignPtr uctx $ \c_uctx -> do case mTrans of Just trans -> do ret <- withForeignPtr trans $ \c_trans -> _xmlContainer_deleteDocument c_cont c_trans c_doc c_uctx return ret Nothing -> do _xmlContainer_deleteDocument c_cont nullPtr c_doc c_uctx if ret /= 0 then throwDBXML "xmlContainer_deleteDocument" ret "" else return () foreign import ccall safe "dbxml_helper.h _xmlContainer_close" _xmlContainer_close :: Ptr XmlContainer_struct -> IO () -- | Closes a container. Equivalent to destructing the XmlContainer object in C++. xmlContainer_close :: XmlContainer -> IO () xmlContainer_close cont = withForeignPtr cont $ \cont_ -> _xmlContainer_close cont_ foreign import ccall safe "dbxml_helper.h _xmlContainer_addIndex" _xmlContainer_addIndex :: Ptr XmlContainer_struct -> Ptr XmlTransaction_struct -> CString -> CString -> CString -> Ptr XmlUpdateContext_struct -> IO CInt xmlContainer_addIndex :: XmlContainer -> Maybe XmlTransaction -> String -- ^ The namespace of the node to be indexed. -- The default namespace is selected by passing -- an empty string for the namespace. -> String -- ^ The name of the element or attribute node to be indexed -> String -- ^ A comma-separated list of strings that represent -- the indexing strategy. The strings must contain the -- following information in the following order: -- -- * unique-{path type}-{node type}-{key type}-{syntax} -> XmlUpdateContext -- ^ The update context to use for the index insertion. -> IO () xmlContainer_addIndex cont mTrans uri name index uc = withForeignPtr cont $ \c_cont -> withCString uri $ \c_uri -> withCString name $ \c_name -> withCString index $ \c_index -> withForeignPtr uc $ \c_uc -> do ret <- case mTrans of Just trans -> do withForeignPtr trans $ \c_trans -> _xmlContainer_addIndex c_cont c_trans c_uri c_name c_index c_uc Nothing -> do _xmlContainer_addIndex c_cont nullPtr c_uri c_name c_index c_uc if ret /= 0 then throwDBXML "xmlContainer_addIndex" ret "" else return () foreign import ccall safe "dbxml_helper.h _xmlContainer_deleteIndex" _xmlContainer_deleteIndex :: Ptr XmlContainer_struct -> Ptr XmlTransaction_struct -> CString -> CString -> CString -> Ptr XmlUpdateContext_struct -> IO CInt xmlContainer_deleteIndex :: XmlContainer -> Maybe XmlTransaction -> String -- ^ The namespace of the node to be indexed. -- The default namespace is selected by passing -- an empty string for the namespace. -> String -- ^ The name of the element or attribute node to be indexed -> String -- ^ A comma-separated list of strings that represent -- the indexing strategy. The strings must contain the -- following information in the following order: -- -- * unique-{path type}-{node type}-{key type}-{syntax} -> XmlUpdateContext -- ^ The update context to use for the index insertion. -> IO () xmlContainer_deleteIndex cont mTrans uri name index uc = withForeignPtr cont $ \c_cont -> withCString uri $ \c_uri -> withCString name $ \c_name -> withCString index $ \c_index -> withForeignPtr uc $ \c_uc -> do ret <- case mTrans of Just trans -> do withForeignPtr trans $ \c_trans -> _xmlContainer_deleteIndex c_cont c_trans c_uri c_name c_index c_uc Nothing -> do _xmlContainer_deleteIndex c_cont nullPtr c_uri c_name c_index c_uc if ret /= 0 then throwDBXML "xmlContainer_deleteIndex" ret "" else return () foreign import ccall safe "dbxml_helper.h _xmlManager_close" _xmlManager_close :: Ptr XmlManager_struct -> IO () -- | Closes an XmlManager. Equivalent to destructing the XmlManager object in C++. xmlManager_close :: XmlManager -> IO () xmlManager_close mgr = _xmlManager_close mgr