diff --git a/BerkeleyDBXML.cabal b/BerkeleyDBXML.cabal --- a/BerkeleyDBXML.cabal +++ b/BerkeleyDBXML.cabal @@ -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 stability: beta synopsis: Berkeley DB XML binding description: @@ -21,6 +21,8 @@ . DARCS repository: + . + 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 diff --git a/Database/Berkeley/DbXml.hs b/Database/Berkeley/DbXml.hs --- a/Database/Berkeley/DbXml.hs +++ b/Database/Berkeley/DbXml.hs @@ -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 diff --git a/Database/Berkeley/dbxml_helper.cpp b/Database/Berkeley/dbxml_helper.cpp --- a/Database/Berkeley/dbxml_helper.cpp +++ b/Database/Berkeley/dbxml_helper.cpp @@ -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); + } +} diff --git a/Database/Berkeley/dbxml_helper.h b/Database/Berkeley/dbxml_helper.h --- a/Database/Berkeley/dbxml_helper.h +++ b/Database/Berkeley/dbxml_helper.h @@ -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 diff --git a/README b/README --- a/README +++ b/README @@ -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. diff --git a/examples/adventure.hs b/examples/adventure.hs --- a/examples/adventure.hs +++ b/examples/adventure.hs @@ -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 "<>" 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