BerkeleyDBXML 0.6.2 → 0.7
raw patch · 6 files changed
+158/−116 lines, 6 filesdep ~BerkeleyDB
Dependency ranges changed: BerkeleyDB
Files
- BerkeleyDBXML.cabal +7/−6
- Database/Berkeley/DbXml.hs +44/−23
- Database/Berkeley/dbxml_helper.cpp +33/−9
- Database/Berkeley/dbxml_helper.h +6/−3
- README +4/−4
- examples/adventure.hs +64/−71
BerkeleyDBXML.cabal view
@@ -1,11 +1,11 @@ name: BerkeleyDBXML-version: 0.6.2+version: 0.7 license: BSD3 license-file: LICENSE cabal-version: >= 1.6-copyright: (c) 2009 Stephen Blackheath+copyright: (c) 2009 Stephen Blackheath, (c) 2010 typLAB author: Stephen Blackheath-maintainer: http://blacksapphire.com/antispam/+maintainer: http://blacksapphire.com/antispam/, typLAB <code@typlab.com> stability: beta synopsis: Berkeley DB XML binding description:@@ -21,6 +21,8 @@ . DARCS repository: <http://blacksapphire.com/BerkeleyDBXML/>+ .+ Changes: 0.7: Compatible (only) with dbxml 2.5. category: Database build-type: Simple@@ -35,8 +37,7 @@ exposed-modules: Database.Berkeley.DbXml c-sources: Database/Berkeley/dbxml_helper.cpp - build-depends: base == 4.*, bytestring >= 0.9, BerkeleyDB >= 0.7.1+ build-depends: base == 4.*, bytestring >= 0.9, BerkeleyDB >= 0.8 include-dirs: Database/Berkeley/- extra-libraries: db, dbxml, db_cxx, xqilla, xerces-c, xml2- ghc-options: -pgml c+++ extra-libraries: db, dbxml, xqilla, xerces-c, xml2
Database/Berkeley/DbXml.hs view
@@ -24,6 +24,7 @@ xmlDocument_getName, xmlDocument_setContent, xmlDocument_setName,+ xmlDocument_setMetaData, -- * XmlManager XmlManager, xmlManager_close,@@ -36,6 +37,7 @@ xmlManager_createTransaction_DbTxn, xmlManager_createUpdateContext, ContainerType(..),+ xmlManager_existsContainer, xmlManager_openContainer, xmlManager_prepare, xmlManager_query,@@ -59,8 +61,8 @@ xmlDouble, xmlNone, xmlString,+ xmlXmlDocument, xmlValue_asString,- xmlValue_asString8Bit ) where import Foreign.C@@ -81,6 +83,7 @@ import qualified Data.ByteString.Internal as BSI import Control.Exception import Data.Typeable+import Control.Monad (when) dbOrFlags flags = foldr (.|.) 0 $ map dbToNum flags @@ -273,7 +276,16 @@ 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@@ -574,34 +586,30 @@ 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 CString -> IO CInt+ :: Ptr XmlValue_struct -> Ptr (Ptr Word8) -> Ptr CInt -> 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+-- | 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+ _xmlValue_asString c_value ptr pLength 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+ 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@@ -688,6 +696,19 @@ 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
Database/Berkeley/dbxml_helper.cpp view
@@ -8,6 +8,11 @@ using namespace DbXml; using namespace std; +#define UNWRAP_DBENV() \+ DB_ENV* dbenv; \+ if (*dbenvp == NULL) return -20881; /* Haskell binding-specific error code */ \+ dbenv = *dbenvp;+ #define UNWRAP_DBTXN_() \ if (dbtxnp == NULL) \ dbtxn = NULL; \@@ -17,7 +22,7 @@ } #define UNWRAP_DBTXN() \- DbTxn* dbtxn; \+ DB_TXN* dbtxn; \ UNWRAP_DBTXN_() XmlManagerInfo::XmlManagerInfo()@@ -73,8 +78,9 @@ return (exc.getExceptionCode() + 1) * 100000 + dbE; } -int _xmlManager(DbEnv* dbenv, u_int32_t flags, XmlManagerInfo** mgr)+int _xmlManager(DB_ENV** dbenvp, u_int32_t flags, XmlManagerInfo** mgr) {+ UNWRAP_DBENV(); *mgr = new XmlManagerInfo; try { (*mgr)->mgr = XmlManager(dbenv, flags);@@ -109,6 +115,11 @@ } } +int _xmlManager_existsContainer(XmlManagerInfo* mgr, const char* name)+{+ return mgr->mgr.existsContainer(name);+}+ void _xmlContainer_delete(DbXml::XmlContainer** cont) { delete *cont;@@ -134,15 +145,10 @@ } } -int _xmlManager_createTransaction_DbTxn(XmlManagerInfo* mgr, DbTxn** dbtxnp, DbXml::XmlTransaction** trans)+int _xmlManager_createTransaction_DbTxn(XmlManagerInfo* mgr, DB_TXN** dbtxnp, DbXml::XmlTransaction** trans) { UNWRAP_DBTXN(); try {- void detach_DbTxn(DbTxn** dbtxnp); // Defined in Berkeley DB-- detach_DbTxn(dbtxnp); // Detach the DbTxn so that Berkeley DB doesn't- // try to clean it up by running DbTxn_abort in- // its finalizer. XmlTransaction t = mgr->mgr.createTransaction(dbtxn); *trans = new XmlTransaction(t); return 0;@@ -390,8 +396,13 @@ return new XmlValue(value); } -int _xmlValue_asString(DbXml::XmlValue* value, char** str)+DbXml::XmlValue* _xmlXmlDocument(DbXml::XmlDocument* doc) {+ return new XmlValue(*doc);+}++int _xmlValue_asString(DbXml::XmlValue* value, char** str, int* length)+{ string s; try { s = value->asString();@@ -400,6 +411,7 @@ *str = NULL; return asInt(exc); }+ *length = (int)s.length(); *str = new char[s.length()+1]; strcpy(*str, s.c_str()); return 0;@@ -543,3 +555,15 @@ } } +int _xmlDocument_setMetaData(DbXml::XmlDocument* doc, const char* uri , const char* name, DbXml::XmlValue* value)+{+ try {+ string uri_ (uri);+ string name_ (name);+ doc->setMetaData(uri_, name_, *value);+ return 0;+ }+ catch (XmlException& exc) {+ return asInt(exc);+ }+}
Database/Berkeley/dbxml_helper.h view
@@ -27,14 +27,15 @@ XmlManagerInfo* mi; }; - int _xmlManager(DbEnv* dbenv, u_int32_t flags, XmlManagerInfo** mgr);+ int _xmlManager(DB_ENV** dbenv, u_int32_t flags, XmlManagerInfo** mgr); void _xmlManager_close(XmlManagerInfo* mgr); int _xmlManager_openContainer(XmlManagerInfo* mgr, const char* name, u_int32_t flags, int cType, int mode, DbXml::XmlContainer*** container);+ int _xmlManager_existsContainer(XmlManagerInfo* mgr, const char* name); void _xmlContainer_delete(DbXml::XmlContainer** cont); void _xmlContainer_close(DbXml::XmlContainer** cont); int _xmlManager_createTransaction(XmlManagerInfo* mgr, u_int32_t flags, DbXml::XmlTransaction** trans);- int _xmlManager_createTransaction_DbTxn(XmlManagerInfo* mgr, DbTxn** dbtxnp, DbXml::XmlTransaction** trans);+ int _xmlManager_createTransaction_DbTxn(XmlManagerInfo* mgr, DB_TXN ** dbtxnp, DbXml::XmlTransaction** trans); void _xmlTransaction_delete(DbXml::XmlTransaction* trans); int _xmlTransaction_commit(DbXml::XmlTransaction* trans); int _xmlTransaction_abort(DbXml::XmlTransaction* trans);@@ -62,7 +63,8 @@ DbXml::XmlValue* _xmlString(const char* text); DbXml::XmlValue* _xmlBool(int value); DbXml::XmlValue* _xmlDouble(double value);- int _xmlValue_asString(DbXml::XmlValue* value, char** str);+ DbXml::XmlValue* _xmlXmlDocument(DbXml::XmlDocument* doc);+ int _xmlValue_asString(DbXml::XmlValue* value, char** str, int* length); int _xmlQueryExpression_execute(XmlQueryExpressionInfo* exp, DbXml::XmlTransaction* trans, DbXml::XmlValue* contextItem, DbXml::XmlQueryContext* qctx, u_int32_t flags, DbXml::XmlResults** res); int _xmlManager_createDocument(XmlManagerInfo* mgr, DbXml::XmlDocument** doc);@@ -77,6 +79,7 @@ DbXml::XmlDocument* doc, DbXml::XmlUpdateContext* uctx, u_int32_t flags); int _xmlContainer_deleteDocument(DbXml::XmlContainer** cont, DbXml::XmlTransaction* trans, DbXml::XmlDocument* doc, DbXml::XmlUpdateContext* uctx);+ int _xmlDocument_setMetaData(DbXml::XmlDocument* doc, const char* uri, const char* name, DbXml::XmlValue* value); } #endif
README view
@@ -1,5 +1,5 @@ Berkeley DB / Berkeley DB XML binding for Haskell-Version 0.6 5 Jan 2009+28 Jan 2010 by Stephen Blackheath email me: http://blacksapphire.com/antispam/@@ -35,9 +35,9 @@ /usr/local, you will need to specify the paths in this way: cabal install \- --extra-include-dirs=/usr/local/dbxml-2.4.16/include/ \- --extra-include-dirs=/usr/local/dbxml-2.4.16/include/dbxml/ \- --extra-lib-dirs=/usr/local/dbxml-2.4.16/lib/+ --extra-include-dirs=/usr/local/dbxml-2.5.16/include/ \+ --extra-include-dirs=/usr/local/dbxml-2.5.16/include/dbxml/ \+ --extra-lib-dirs=/usr/local/dbxml-2.5.16/lib/ See the examples/ directory for examples.
examples/adventure.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts,+ ScopedTypeVariables #-} -- | This is a simple persistent multi-user adventure game, to demonstrate the--- use of Berkeley DB/XML combined with HXT picklers.+-- use of Berkeley DB/XML combined with hexpat-pickle picklers. -- The HXT library is required for this, which can be downloaded from Hackage. -- -- To log in, you need to use a telnet client. The command is@@ -8,12 +10,13 @@ -- -- It is assumed that your telnet client will echo and buffer the text you type. -- This is usually the case on Unix systems.- module Main where import Database.Berkeley.Db import Database.Berkeley.DbXml-import Text.XML.HXT.Arrow hiding (when)+import Text.XML.Expat.Tree+import Text.XML.Expat.Format+import Text.XML.Expat.Pickle import Network import Control.Concurrent import Control.Exception@@ -31,19 +34,19 @@ } deriving (Show) -instance XmlPickler Player where+instance XmlPickler [UNode String] Player where xpickle = xpPlayer -xpPlayer :: PU Player+xpPlayer :: PU [UNode String] Player xpPlayer =- xpElem "player"$+ xpElemAttrs "player" $ xpWrap ( (\(nam, loc) -> Player nam loc), (\(Player nam loc) -> (nam, loc))- )$+ ) $ xpPair- (xpAttr "name"$ xpText0)- (xpAttr "location"$ xpText0)+ (xpAttr "name" $ xpText0)+ (xpAttr "location" $ xpText0) data Room = Room { roomKey :: String,@@ -52,25 +55,24 @@ } deriving (Show) -instance XmlPickler Room where+instance XmlPickler [UNode String] Room where xpickle = xpRoom -xpRoom :: PU Room+xpRoom :: PU [UNode String] Room xpRoom =- xpElem "room"$ xpWrap (- (\(key, des, exi) -> Room key des exi),- (\(Room key des exi) -> (key, des, exi))- )$- xpTriple- (xpAttr "key"$ xpText0)- (xpElem "descr"$ xpText0)- (xpElem "exits"$- xpList$- xpElem "exit"$+ (\(key, (des, exi)) -> Room key des exi),+ (\(Room key des exi) -> (key, (des, exi)))+ ) $+ xpElem "room" (xpAttr "key" xpText0) $+ xpPair+ (xpElemNodes "descr" $ xpContent xpText0)+ (xpElemNodes "exits" $+ xpList $+ xpElemAttrs "exit" $ xpPair- (xpAttr "name"$ xpText0)- (xpAttr "room"$ xpText0)+ (xpAttr "name" $ xpText0)+ (xpAttr "room" $ xpText0) ) data Item = Item {@@ -82,22 +84,25 @@ } deriving (Show) -instance XmlPickler Item where+instance XmlPickler [UNode String] Item where xpickle = xpItem -xpItem :: PU Item+xpItem :: PU [UNode String] Item xpItem =- xpElem "item"$ xpWrap (- (\(key, loc, des, nam, por) -> Item key loc des nam (read por)),- (\(Item key loc des nam por) -> (key, loc, des, nam, (show por)))- )$- xp5Tuple- (xpAttr "key"$ xpText0)- (xpAttr "location"$ xpText0)- (xpElem "descr"$ xpText0)- (xpElem "names"$ xpList$ xpElem "name"$ xpAttr "name"$ xpText0)- (xpAttr "portable"$ xpText0)+ (\((key, loc, por), (des, nam)) -> Item key loc des nam (read por)),+ (\(Item key loc des nam por) -> ((key, loc, show por), (des, nam)))+ ) $+ xpElem "item" (+ xpTriple+ (xpAttr "key" $ xpText0)+ (xpAttr "location" $ xpText0)+ (xpAttr "portable" $ xpText0)+ ) (+ xpPair+ (xpElemNodes "descr" $ xpContent xpText0)+ (xpElemNodes "names" $ xpList $ xpElemAttrs "name" $ xpAttr "name" $ xpText0)+ ) initialRooms = [ Room "beach"@@ -164,18 +169,7 @@ Just (DbException _ DB_LOCK_DEADLOCK) | retryCount < 20 -> do hPutStrLn stderr "<<retry deadlocked thread>>" inTransaction_ mgr code (retryCount+1)- otherwise -> throwIO exc)--toXML :: XmlPickler p => p -> IO String-toXML p = do- mText <- liftM listToMaybe$ runX (- constA p >>>- xpickleVal (xpickle) >>>- writeDocumentToString [(a_indent, v_0)]- )- case mText of- Just text -> return text- Nothing -> ioError (userError "pickle failed!")+ _ -> throwIO exc) collectM :: Monad m => m (Maybe a) -> m [a] collectM valueM = do@@ -187,13 +181,7 @@ Nothing -> do return [] -fromByteString :: B.ByteString -> String-fromByteString = map (chr . fromIntegral) . B.unpack--toByteString :: String -> B.ByteString-toByteString = B.pack . map (fromIntegral . ord)--query_ :: XmlPickler p => (XmlManager, XmlContainer, XmlTransaction) -> PU p+query_ :: (XmlManager, XmlContainer, XmlTransaction) -> PU [UNode String] p -> String -> [(String, XmlValue)] -> [DbXmlFlag] -> IO [(XmlDocument, p)] query_ (mgr, cont, trans) pickler queryText params flags = do qctx <- xmlManager_createQueryContext mgr LiveValues Eager@@ -203,36 +191,41 @@ xmlQueryContext_setVariableValue qctx name value res <- xmlManager_query mgr (Just trans) queryText qctx flags docs <- collectM (xmlResults_next res)- records <- liftM (concat) $ forM docs $ \doc -> do- text <- liftM fromByteString $ xmlDocument_getContent doc- ps <- runX (- readString [ (a_validate, v_0),(a_remove_whitespace, v_1)] text- >>> xunpickleVal pickler)- return$ map (\p -> (doc, p)) ps+ records <- forM docs $ \doc -> do+ text <- xmlDocument_getContent doc+ value <- case unpickleXML' defaultParserOptions (xpRoot pickler) text of+ Left err -> fail $ "unpickle failed: "++err+ Right value -> return value+ return (doc, value) return records -query :: XmlPickler p => (XmlManager, XmlContainer, XmlTransaction) -> PU p+query :: XmlPickler [UNode String] p => (XmlManager, XmlContainer, XmlTransaction) -> PU [UNode String] p -> String -> [(String, XmlValue)] -> IO [p]-query ctx pickler queryText params = liftM (map snd)$ query_ ctx pickler queryText params []+query ctx pickler queryText params = liftM (map snd) $ query_ ctx pickler queryText params [] -- | Query with write lock. Returned document allows the document to be updated -- without having to specify its document name.-queryUpdate :: XmlPickler p => (XmlManager, XmlContainer, XmlTransaction) -> PU p+queryUpdate :: XmlPickler [UNode String] p => (XmlManager, XmlContainer, XmlTransaction) -> PU [UNode String] p -> String -> [(String, XmlValue)] -> IO [(XmlDocument, p)] queryUpdate ctx pickler queryText params = query_ ctx pickler queryText params [DB_FLAG DB_RMW] -create :: XmlPickler p => (XmlManager, XmlContainer, XmlTransaction) -> p -> IO ()+create :: forall p . XmlPickler [UNode String] p =>+ (XmlManager, XmlContainer, XmlTransaction)+ -> p+ -> IO () create (mgr, cont, trans) p = do doc <- xmlManager_createDocument mgr- text <- toXML p- xmlDocument_setContent doc (toByteString text)+ xmlDocument_setContent doc (pickleXML' (xpRoot xpickle :: PU (UNode String) p) p) uctx <- xmlManager_createUpdateContext mgr xmlContainer_putDocument cont (Just trans) doc uctx [DBXML_GEN_NAME] -update :: XmlPickler p => (XmlManager, XmlContainer, XmlTransaction) -> XmlDocument -> p -> IO ()+update :: forall p . XmlPickler [UNode String] p =>+ (XmlManager, XmlContainer, XmlTransaction)+ -> XmlDocument+ -> p+ -> IO () update (mgr, cont, trans) doc p = do- text <- toXML p- xmlDocument_setContent doc (toByteString text)+ xmlDocument_setContent doc (pickleXML' (xpRoot xpickle :: PU (UNode String) p) p) uctx <- xmlManager_createUpdateContext mgr xmlContainer_updateDocument cont (Just trans) doc uctx @@ -244,7 +237,7 @@ ((doc, p):_) -> do let p' = p {itemLocation = room} update db doc p'- otherwise -> do+ _ -> do create db$ Item ("player_"++name) room name [] False deletePlayer :: (XmlManager, XmlContainer, XmlTransaction) -> String -> IO ()@@ -254,7 +247,7 @@ ((doc, p):_) -> do uctx <- xmlManager_createUpdateContext mgr xmlContainer_deleteDocument cont (Just trans) doc uctx- otherwise -> return ()+ _ -> return () initGame :: XmlManager -> XmlContainer -> IO () initGame mgr cont = do