BerkeleyDBXML-0.6: 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 <- _xmlTransaction_commit (unsafeForeignPtrToPtr trans)
touchForeignPtr trans
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 <- _xmlTransaction_abort (unsafeForeignPtrToPtr trans)
touchForeignPtr trans
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
let cont_ = unsafeForeignPtrToPtr cont
ret <- case mTrans of
Just trans -> do
ret_ <- _xmlContainer_getDocument cont_ (unsafeForeignPtrToPtr trans) c_key (dbOrFlags flags) ptr
touchForeignPtr trans
return ret_
Nothing -> do
_xmlContainer_getDocument cont_ nullPtr c_key (dbOrFlags flags) ptr
touchForeignPtr cont
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
let cont_ = unsafeForeignPtrToPtr cont
cstr <- _xmlContainer_getName cont_
touchForeignPtr cont
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 <- _xmlDocument_getContent (unsafeForeignPtrToPtr doc) ptr pLength
touchForeignPtr doc
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 <- _xmlResults_hasNext (unsafeForeignPtrToPtr res) ptr
touchForeignPtr res
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 <- _xmlResults_nextDocument (unsafeForeignPtrToPtr res) ptr
touchForeignPtr res
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 <- _xmlResults_nextValue (unsafeForeignPtrToPtr res) ptr
touchForeignPtr res
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 -> do
ret <- case mTrans of
Just trans -> do
ret_ <- _xmlManager_query mgr (unsafeForeignPtrToPtr trans) c_query
(unsafeForeignPtrToPtr ctx) (dbxmlOrFlags flags) ptr
touchForeignPtr trans
return ret_
Nothing -> do
_xmlManager_query mgr nullPtr c_query
(unsafeForeignPtrToPtr 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 -> do
ret <- case mTrans of
Just trans -> do
ret_ <- _xmlManager_prepare mgr (unsafeForeignPtrToPtr trans) c_query
(unsafeForeignPtrToPtr ctx) ptr
touchForeignPtr trans
return ret_
Nothing -> do
_xmlManager_prepare mgr nullPtr c_query
(unsafeForeignPtrToPtr 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 <- _xmlQueryContext_setDefaultCollection (unsafeForeignPtrToPtr ctx) c_coll
touchForeignPtr ctx
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 <- _xmlValue_asString (unsafeForeignPtrToPtr value) ptr
touchForeignPtr value
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 <- _xmlValue_asString (unsafeForeignPtrToPtr value) ptr
touchForeignPtr value
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 <- _xmlQueryContext_setVariableValue (unsafeForeignPtrToPtr ctx) c_name (unsafeForeignPtrToPtr value)
touchForeignPtr ctx
touchForeignPtr 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
let p2p = unsafeForeignPtrToPtr
let exp_ = p2p exp
let qctx_ = p2p qctx
let flags_ = (dbxmlOrFlags flags)
ret <- case (mTrans, mContextItem) of
(Just trans, Just contextItem) -> do
ret <- _xmlQueryExpression_execute exp_ (p2p trans) (p2p contextItem) qctx_ flags_ ptr
touchForeignPtr trans
touchForeignPtr contextItem
return ret
(Just trans, Nothing) -> do
ret <- _xmlQueryExpression_execute exp_ (p2p trans) nullPtr qctx_ flags_ ptr
touchForeignPtr trans
return ret
(Nothing, Just contextItem) -> do
ret <- _xmlQueryExpression_execute exp_ nullPtr (p2p contextItem) qctx_ flags_ ptr
touchForeignPtr contextItem
return ret
(Nothing, Nothing) -> do
_xmlQueryExpression_execute exp_ nullPtr nullPtr qctx_ flags_ ptr
touchForeignPtr exp
touchForeignPtr qctx
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 <- _xmlDocument_getName (unsafeForeignPtrToPtr doc) ptr
touchForeignPtr doc
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 <- _xmlDocument_setName (unsafeForeignPtrToPtr doc) c_name
touchForeignPtr doc
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 <- _xmlDocument_setContent (unsafeForeignPtrToPtr doc) c_text (fromIntegral text_length)
touchForeignPtr doc
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
let cont_ = unsafeForeignPtrToPtr cont
let doc_ = unsafeForeignPtrToPtr doc
let uctx_ = unsafeForeignPtrToPtr uctx
ret <- case mTrans of
Just trans -> do
let trans_ = unsafeForeignPtrToPtr trans
ret <- _xmlContainer_updateDocument cont_ trans_ doc_ uctx_
touchForeignPtr trans
return ret
Nothing -> do
_xmlContainer_updateDocument cont_ nullPtr doc_ uctx_
touchForeignPtr cont
touchForeignPtr doc
touchForeignPtr 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
let cont_ = unsafeForeignPtrToPtr cont
let doc_ = unsafeForeignPtrToPtr doc
let uctx_ = unsafeForeignPtrToPtr uctx
ret <- case mTrans of
Just trans -> do
let trans_ = unsafeForeignPtrToPtr trans
ret <- _xmlContainer_putDocument cont_ trans_ doc_ uctx_ (dbxmlOrFlags flags)
touchForeignPtr trans
return ret
Nothing -> do
_xmlContainer_putDocument cont_ nullPtr doc_ uctx_ (dbxmlOrFlags flags)
touchForeignPtr cont
touchForeignPtr doc
touchForeignPtr uctx
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
let cont_ = unsafeForeignPtrToPtr cont
let doc_ = unsafeForeignPtrToPtr doc
let uctx_ = unsafeForeignPtrToPtr uctx
ret <- case mTrans of
Just trans -> do
let trans_ = unsafeForeignPtrToPtr trans
ret <- _xmlContainer_deleteDocument cont_ trans_ doc_ uctx_
touchForeignPtr trans
return ret
Nothing -> do
_xmlContainer_deleteDocument cont_ nullPtr doc_ uctx_
touchForeignPtr cont
touchForeignPtr doc
touchForeignPtr 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