BerkeleyDBXML-0.6.1: Database/Berkeley/DbXml.hs
{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, TypeSynonymInstances, DeriveDataTypeable #-}
{-# 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,
-- * XmlDocument
XmlDocument,
xmlDocument_getContent,
xmlDocument_getName,
xmlDocument_setContent,
xmlDocument_setName,
-- * XmlManager
XmlManager,
xmlManager_close,
xmlManager_create,
xmlManager_createDocument,
ReturnType(..),
EvaluationType(..),
xmlManager_createQueryContext,
xmlManager_createTransaction,
xmlManager_createTransaction_DbTxn,
xmlManager_createUpdateContext,
ContainerType(..),
xmlManager_openContainer,
xmlManager_prepare,
xmlManager_query,
-- * XmlQueryContext
XmlQueryContext,
xmlQueryContext_setDefaultCollection,
xmlQueryContext_setVariableValue,
-- * XmlQueryExpression
XmlQueryExpression,
xmlQueryExpression_execute,
-- * XmlResults
xmlResults_hasNext,
xmlResults_next,
-- * XmlTransaction
XmlTransaction,
xmlTransaction_abort,
xmlTransaction_commit,
-- * XmlValue
XmlValue,
xmlBool,
xmlDouble,
xmlNone,
xmlString,
xmlValue_asString,
xmlValue_asString8Bit
) 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
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 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 flags = foldr (.|.) 0 $ map dbxmlToNum flags
data XmlManager_struct
type XmlManager = Ptr XmlManager_struct
foreign import ccall safe "dbxml_helper.h _xmlManager" _xmlManager
:: Ptr DbEnv_struct -> CUInt -> 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 XmlContainer_struct
type XmlContainer = ForeignPtr XmlContainer_struct
foreign import ccall "dbxml_helper.h &_xmlContainer_delete" _xmlContainer_delete
:: FunPtr (Ptr XmlContainer_struct -> IO ())
data ContainerType = NodeContainer | WholedocContainer
foreign import ccall safe "dbxml_helper.h _xmlManager_openContainer" _xmlManager_openContainer
:: XmlManager -> CString -> CUInt -> CInt -> CInt -> Ptr (Ptr XmlContainer_struct) -> IO CInt
xmlManager_openContainer :: XmlManager -> String -> [DbXmlFlag] -> ContainerType -> Int -> 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
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 -> CUInt -> 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
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 ())
foreign import ccall safe "dbxml_helper.h _xmlContainer_getDocument" _xmlContainer_getDocument
:: Ptr XmlContainer_struct -> Ptr XmlTransaction_struct -> CString -> CUInt -> 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 -> CUInt -> 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 _xmlValue_asString" _xmlValue_asString
:: Ptr XmlValue_struct -> Ptr CString -> IO CInt
-- | Get the string content of this XmlValue object and decode UTF-8 to return
-- a Unicode string.
xmlValue_asString :: XmlValue -> String
xmlValue_asString value = unsafePerformIO $ alloca $ \ptr -> do
ret <- withForeignPtr value $ \c_value ->
_xmlValue_asString c_value ptr
if ret /= 0
then throwDBXML "xmlValue_asString" ret ""
else do
cstr <- peek ptr
str <- peekCAString cstr
_deleteString cstr
return str
-- | Get the string content of this XmlValue object, returning the string as
-- 8-bit data. This is what you need if you are going to feed it into an XML
-- parser.
xmlValue_asString8Bit :: XmlValue -> String
xmlValue_asString8Bit value = unsafePerformIO $ alloca $ \ptr -> do
ret <- withForeignPtr value $ \c_value ->
_xmlValue_asString c_value ptr
cstr <- peek ptr
str <- peekCAString cstr
_deleteString cstr
return str
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 ()
-- 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 -> CUInt -> 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 ()
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
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 -> CUInt -> 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 _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