BerkeleyDBXML 0.1 → 0.2
raw patch · 15 files changed
+829/−281 lines, 15 files
Files
- BerkeleyDBXML.cabal +8/−6
- Database/Berkeley/Db.hs +57/−3
- Database/Berkeley/DbXml.hs +16/−0
- Database/Berkeley/db_helper.cpp +21/−0
- Database/Berkeley/db_helper.h +2/−0
- Database/Berkeley/dbxml_helper.cpp +13/−0
- Database/Berkeley/dbxml_helper.h +1/−0
- README +7/−7
- examples/Makefile +0/−8
- examples/Test1.hs +0/−237
- examples/Test2.hs +0/−20
- examples/adventure/Adventure.hs +457/−0
- examples/adventure/Makefile +5/−0
- examples/tests/Makefile +5/−0
- examples/tests/Test1.hs +237/−0
BerkeleyDBXML.cabal view
@@ -1,5 +1,5 @@ name: BerkeleyDBXML-version: 0.1+version: 0.2 license: BSD3 license-file: LICENSE cabal-version: >= 1.4@@ -7,17 +7,19 @@ author: Stephen Blackheath maintainer: http://blacksapphire.com/antispam/ stability: alpha-synopsis: Berkeley DB and Berkeley DB/XML binding for Haskell-description: Berkeley DB and Berkeley DB/XML binding for Haskell+synopsis: Berkeley DB and Berkeley DB XML binding+description: Berkeley DB and Berkeley DB XML binding category: Database build-type: Simple+homepage: http://www.haskell.org/haskellwiki/BerkeleyDBXML extra-source-files: README, Database/Berkeley/db_helper.h, Database/Berkeley/dbxml_helper.h,- examples/Makefile,- examples/Test1.hs,- examples/Test2.hs+ examples/adventure/Makefile+ examples/adventure/Adventure.hs+ examples/tests/Test1.hs+ examples/tests/Makefile Library exposed-modules: Database.Berkeley.Db
Database/Berkeley/Db.hs view
@@ -20,13 +20,14 @@ dbEnv_set_lg_regionmax, DbFlag(..), dbEnv_open,- dbToNum, -- ^ Used by DbXml- dbOrFlags, -- ^ Used by DbXml+ dbToNum, -- ^ Private to DbXml+ dbOrFlags, -- ^ Private to DbXml Db, db_create, db_set_pagesize, DbType(..), DbTxn,+ DbTxn_struct, -- ^ Private to DbXml db_open, dbEnv_txn_begin, dbEnv_txn_checkpoint,@@ -39,8 +40,11 @@ dbEnv_lock_put, db_get, db_put,+ db_del, db_close,- dbEnv_close+ dbEnv_close,+ DbLockFlag(..),+ dbEnv_set_lk_detect ) where import Foreign.C@@ -642,6 +646,23 @@ then throw "db_put" ret else return () +foreign import ccall "db_helper.h _db_del" _db_del+ :: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CUInt -> CUInt -> IO CInt++db_del :: Db -> Maybe DbTxn -> String -> [DbFlag] -> IO ()+db_del db mTxn key flags =+ withCAStringLen key$ \(c_key, key_len) ->+ withForeignPtr db$ \c_db -> do+ ret <- case mTxn of+ Nothing ->+ _db_del c_db nullPtr c_key (fromIntegral key_len) (dbOrFlags flags)+ Just txn ->+ withForeignPtr txn$ \c_txn ->+ _db_del c_db c_txn c_key (fromIntegral key_len) (dbOrFlags flags)+ if ret /= 0+ then throw "db_del" ret+ else return ()+ foreign import ccall "db_helper.h _db_close" _db_close :: Ptr Db_struct -> CUInt -> IO CInt @@ -661,5 +682,38 @@ ret <- _dbenv_close dbEnv (dbOrFlags flags) if ret /= 0 then throw "dbEnv_close" ret+ else return ()+ +data DbLockFlag =+ DB_LOCK_NORUN |+ DB_LOCK_DEFAULT |+ DB_LOCK_EXPIRE |+ DB_LOCK_MAXLOCKS | + DB_LOCK_MAXWRITE |+ DB_LOCK_MINLOCKS |+ DB_LOCK_MINWRITE |+ DB_LOCK_OLDEST |+ DB_LOCK_RANDOM |+ DB_LOCK_YOUNGEST++dbLockToNum DB_LOCK_NORUN = 0+dbLockToNum DB_LOCK_DEFAULT = 1+dbLockToNum DB_LOCK_EXPIRE = 2+dbLockToNum DB_LOCK_MAXLOCKS = 3+dbLockToNum DB_LOCK_MAXWRITE = 4+dbLockToNum DB_LOCK_MINLOCKS = 5+dbLockToNum DB_LOCK_MINWRITE = 6+dbLockToNum DB_LOCK_OLDEST = 7+dbLockToNum DB_LOCK_RANDOM = 8+dbLockToNum DB_LOCK_YOUNGEST = 9++foreign import ccall "db_helper.h _dbenv_set_lk_detect" _dbenv_set_lk_detect+ :: Ptr DbEnv_struct -> CUInt -> IO CInt++dbEnv_set_lk_detect :: DbEnv -> DbLockFlag -> IO ()+dbEnv_set_lk_detect dbenv flag = do+ ret <- _dbenv_set_lk_detect dbenv (dbLockToNum flag)+ if ret /= 0+ then throw "dbEnv_set_lk_detect" ret else return ()
Database/Berkeley/DbXml.hs view
@@ -12,8 +12,10 @@ xmlManager_openContainer, XmlTransaction, xmlManager_createTransaction,+ xmlManager_createTransaction_DbTxn, xmlTransaction_commit, xmlTransaction_abort,+ XmlDocument, xmlContainer_getDocument, xmlContainer_getName, xmlDocument_getContent,@@ -271,6 +273,20 @@ ret <- _xmlManager_createTransaction mgr (dbOrFlags flags) ptr if ret /= 0 then throw "xmlManager_createTransaction" ret ""+ else do+ p <- peek ptr+ newForeignPtr _xmlTransaction_delete p++foreign import ccall unsafe "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 throw "xmlManager_createTransaction_DbTxn" ret "" else do p <- peek ptr newForeignPtr _xmlTransaction_delete p
Database/Berkeley/db_helper.cpp view
@@ -290,6 +290,17 @@ } } +int _db_del(Db* db, DbTxn* dbtxn, const char* key, u_int32_t key_len, u_int32_t flags)+{+ Dbt keyDbt((void*)key, key_len);+ try {+ return db->del(dbtxn, &keyDbt, flags);+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}+ int _db_close(Db* db, u_int32_t flags) { try {@@ -306,6 +317,16 @@ int ret = dbEnv->close(flags); delete dbEnv; return ret;+ }+ catch (DbException& exc) {+ return exc.get_errno();+ }+}++int _dbenv_set_lk_detect(DbEnv* dbEnv, u_int32_t flag)+{+ try {+ return dbEnv->set_lk_detect(flag); } catch (DbException& exc) { return exc.get_errno();
Database/Berkeley/db_helper.h view
@@ -37,8 +37,10 @@ void _freeString(char* str); int _db_get(Db* db, DbTxn* dbtxn, const char* key, u_int32_t key_len, char** value, u_int32_t* value_len, u_int32_t flags); int _db_put(Db* db, DbTxn* dbtxn, const char* key, u_int32_t key_len, char* value, u_int32_t value_len, u_int32_t flags);+ int _db_del(Db* db, DbTxn* dbtxn, const char* key, u_int32_t key_len, u_int32_t flags); int _db_close(Db* db, u_int32_t flags); int _dbenv_close(DbEnv* dbEnv, u_int32_t flags);+ int _dbenv_set_lk_detect(DbEnv* dbEnv, u_int32_t flag); } #endif
Database/Berkeley/dbxml_helper.cpp view
@@ -63,6 +63,19 @@ } } +int _xmlManager_createTransaction_DbTxn(DbXml::XmlManager* mgr, DbTxn* dbtxn, DbXml::XmlTransaction** trans)+{+ try {+ XmlTransaction t = mgr->createTransaction(dbtxn);+ *trans = new XmlTransaction(t);+ return 0;+ }+ catch (XmlException& exc) {+ *trans = NULL;+ return asInt(exc);+ }+}+ void _xmlTransaction_delete(DbXml::XmlTransaction* trans) { delete trans;
Database/Berkeley/dbxml_helper.h view
@@ -9,6 +9,7 @@ int cType, int mode, DbXml::XmlContainer** container); void _xmlContainer_delete(DbXml::XmlContainer* cont); int _xmlManager_createTransaction(DbXml::XmlManager* mgr, u_int32_t flags, DbXml::XmlTransaction** trans);+ int _xmlManager_createTransaction_DbTxn(DbXml::XmlManager* mgr, DbTxn* dbtxn, DbXml::XmlTransaction** trans); void _xmlTransaction_delete(DbXml::XmlTransaction* trans); int _xmlTransaction_commit(DbXml::XmlTransaction* trans); int _xmlTransaction_abort(DbXml::XmlTransaction* trans);
README view
@@ -1,17 +1,17 @@-Berkeley DB / Berkeley DB/XML binding for Haskell-Version 0.1 23 Sep 2008+Berkeley DB / Berkeley DB XML binding for Haskell+Version 0.2 23 Sep 2008 by Stephen Blackheath email me: http://blacksapphire.com/antispam/ darcs repository: http://blacksapphire.com/BerkeleyDBXML/ -Berkeley DB/XML is a powerful, fully transactional, XML-based database that uses+Berkeley DB XML is a powerful, fully transactional, XML-based database that uses XQuery as its query language. You can download it here: http://www.oracle.com/database/berkeley-db/xml/index.html -This package provides a Haskell binding for Berkeley DB/XML. It is a tolerable+This package provides a Haskell binding for Berkeley DB XML. It is a tolerable subset of the API, and I hope to improve it over time. I have stuck closely to the C++ API, with some minor changes where a Haskell idiom seemed appropriate. I hope that people will develop higher level wrappers for it. I have had great@@ -26,9 +26,9 @@ belief that SQL is holding us back. An advanced language should have an advanced database. -If you just want Berkeley DB without Berkeley DB/XML, you should be able to+If you just want Berkeley DB without Berkeley DB XML, you should be able to achieve this easily by modifying the BerkeleyDBXML.cabal file. The Berkeley DB-parts do not depend on the Berkeley DB/XML parts. Some time I will make this+parts do not depend on the Berkeley DB XML parts. Some time I will make this easier. To install, use the standard Cabal install procedure:@@ -37,7 +37,7 @@ runhaskell Setup.hs build sudo runhaskell Setup.hs install -If Berkeley DB or DB/XML is not installed in the default location of /usr or+If Berkeley DB or DB XML is not installed in the default location of /usr or /usr/local, you will need to specify the paths in this way: runhaskell Setup.hs configure \
− examples/Makefile
@@ -1,8 +0,0 @@-all: test1 test2--test1: Test1.hs- ghc --make -o $@ $<--test2: Test2.hs- ghc --make -o $@ $<-
− examples/Test1.hs
@@ -1,237 +0,0 @@-module Main where--import System.Environment-import Database.Berkeley.Db-import Control.Monad--data Action = Read | Write | Fail deriving Eq--writeDb :: Db -> IO ()-writeDb db = do- forM_ testData$ \(country, capital) -> do- db_put db Nothing country capital []--readDb :: Db -> IO ()-readDb db = do- forM_ testData$ \(country, capital) -> do- capital <- db_get db Nothing country []- putStrLn$ country ++ " - " ++ (show capital)--main = do- args <- getArgs- let action = case args of- ["read"] -> Read- ["write"] -> Write- otherwise -> Fail- if action == Fail- then putStrLn "Please say 'read' or 'write' on the command line"- else do- dbenv <- dbEnv_create []- dbEnv_open dbenv "." [DB_CREATE,DB_INIT_MPOOL] 0- db <- db_create dbenv []- db_set_pagesize db 2048- db_open db Nothing "capitals.db" Nothing DB_HASH- [DB_CREATE] 0- if action == Read- then readDb db- else writeDb db- db_close db []- dbEnv_close dbenv []- putStrLn "Finished."--testData = [- ("Afghanistan", "Kabul"),- ("Albania", "Tirane"),- ("Algeria", "Algiers"),- ("Andorra", "Andorra la Vella"),- ("Angola", "Luanda"),- ("Antigua and Barbuda", "Saint John's"),- ("Argentina", "Buenos Aires"),- ("Armenia", "Yerevan"),- ("Australia", "Canberra"),- ("Austria", "Vienna"),- ("Azerbaijan", "Baku"),- ("The Bahamas", "Nassau"),- ("Bahrain", "Manama"),- ("Bangladesh", "Dhaka"),- ("Barbados", "Bridgetown"),- ("Belarus", "Minsk"),- ("Belgium", "Brussels"),- ("Belize", "Belmopan"),- ("Benin", "Porto-Novo"),- ("Bhutan", "Thimphu"),- ("Bolivia", "La Paz (administrative); Sucre (judicial)"),- ("Bosnia and Herzegovina", "Sarajevo"),- ("Botswana", "Gaborone"),- ("Brazil", "Brasilia"),- ("Brunei", "Bandar Seri Begawan"),- ("Bulgaria", "Sofia"),- ("Burkina Faso", "Ouagadougou"),- ("Burundi", "Bujumbura"),- ("Cambodia", "Phnom Penh"),- ("Cameroon", "Yaounde"),- ("Canada", "Ottawa"),- ("Cape Verde", "Praia"),- ("Central African Republic", "Bangui"),- ("Chad", "N'Djamena"),- ("Chile", "Santiago"),- ("China", "Beijing"),- ("Colombia", "Bogota"),- ("Comoros", "Moroni"),- ("Congo, Republic of the", "Brazzaville"),- ("Congo, Democratic Republic of the", "Kinshasa"),- ("Costa Rica", "San Jose"),- ("Cote d'Ivoire", "Yamoussoukro (official); Abidjan (de facto)"),- ("Croatia", "Zagreb"),- ("Cuba", "Havana"),- ("Cyprus", "Nicosia"),- ("Czech Republic", "Prague"),- ("Denmark", "Copenhagen"),- ("Djibouti", "Djibouti"),- ("Dominica", "Roseau"),- ("Dominican Republic", "Santo Domingo"),- ("East Timor (Timor-Leste)", "Dili"),- ("Ecuador", "Quito"),- ("Egypt", "Cairo"),- ("El Salvador", "San Salvador"),- ("Equatorial Guinea", "Malabo"),- ("Eritrea", "Asmara"),- ("Estonia", "Tallinn"),- ("Ethiopia", "Addis Ababa"),- ("Fiji", "Suva"),- ("Finland", "Helsinki"),- ("France", "Paris"),- ("Gabon", "Libreville"),- ("The Gambia", "Banjul"),- ("Georgia", "Tbilisi"),- ("Germany", "Berlin"),- ("Ghana", "Accra"),- ("Greece", "Athens"),- ("Grenada", "Saint George's"),- ("Guatemala", "Guatemala City"),- ("Guinea", "Conakry"),- ("Guinea-Bissau", "Bissau"),- ("Guyana", "Georgetown"),- ("Haiti", "Port-au-Prince"),- ("Honduras", "Tegucigalpa"),- ("Hungary", "Budapest"),- ("Iceland", "Reykjavik"),- ("India", "New Delhi"),- ("Indonesia", "Jakarta"),- ("Iran", "Tehran"),- ("Iraq", "Baghdad"),- ("Ireland", "Dublin"),- ("Israel", "Jerusalem"),- ("Italy", "Rome"),- ("Jamaica", "Kingston"),- ("Japan", "Tokyo"),- ("Jordan", "Amman"),- ("Kazakhstan", "Astana"),- ("Kenya", "Nairobi"),- ("Kiribati", "Tarawa Atoll"),- ("Korea, North", "Pyongyang"),- ("Korea, South", "Seoul"),- ("Kosovo", "Pristina"),- ("Kuwait", "Kuwait City"),- ("Kyrgyzstan", "Bishkek"),- ("Laos", "Vientiane"),- ("Latvia", "Riga"),- ("Lebanon", "Beirut"),- ("Lesotho", "Maseru"),- ("Liberia", "Monrovia"),- ("Libya", "Tripoli"),- ("Liechtenstein", "Vaduz"),- ("Lithuania", "Vilnius"),- ("Luxembourg", "Luxembourg"),- ("Macedonia", "Skopje"),- ("Madagascar", "Antananarivo"),- ("Malawi", "Lilongwe"),- ("Malaysia", "Kuala Lumpur"),- ("Maldives", "Male"),- ("Mali", "Bamako"),- ("Malta", "Valletta"),- ("Marshall Islands", "Majuro"),- ("Mauritania", "Nouakchott"),- ("Mauritius", "Port Louis"),- ("Mexico", "Mexico City"),- ("Micronesia, Federated States of", "Palikir"),- ("Moldova", "Chisinau"),- ("Monaco", "Monaco"),- ("Mongolia", "Ulaanbaatar"),- ("Montenegro", "Podgorica"),- ("Morocco", "Rabat"),- ("Mozambique", "Maputo"),- ("Myanmar (Burma)", "Rangoon (Yangon); Naypyidaw or Nay Pyi Taw (administrative)"),- ("Namibia", "Windhoek"),- ("Nauru", "no official capital; government offices in Yaren District"),- ("Nepal", "Kathmandu"),- ("Netherlands", "Amsterdam; The Hague (seat of government)"),- ("New Zealand", "Wellington"),- ("Nicaragua", "Managua"),- ("Niger", "Niamey"),- ("Nigeria", "Abuja"),- ("Norway", "Oslo"),- ("Oman", "Muscat"),- ("Pakistan", "Islamabad"),- ("Palau", "Melekeok"),- ("Panama", "Panama City"),- ("Papua New Guinea", "Port Moresby"),- ("Paraguay", "Asuncion"),- ("Peru", "Lima"),- ("Philippines", "Manila"),- ("Poland", "Warsaw"),- ("Portugal", "Lisbon"),- ("Qatar", "Doha"),- ("Romania", "Bucharest"),- ("Russia", "Moscow"),- ("Rwanda", "Kigali"),- ("Saint Kitts and Nevis", "Basseterre"),- ("Saint Lucia", "Castries"),- ("Saint Vincent and the Grenadines", "Kingstown"),- ("Samoa", "Apia"),- ("San Marino", "San Marino"),- ("Sao Tome and Principe", "Sao Tome"),- ("Saudi Arabia", "Riyadh"),- ("Senegal", "Dakar"),- ("Serbia", "Belgrade"),- ("Seychelles", "Victoria"),- ("Sierra Leone", "Freetown"),- ("Singapore", "Singapore"),- ("Slovakia", "Bratislava"),- ("Slovenia", "Ljubljana"),- ("Solomon Islands", "Honiara"),- ("Somalia", "Mogadishu"),- ("South Africa", "Pretoria (administrative); Cape Town (legislative); Bloemfontein (judiciary)"),- ("Spain", "Madrid"),- ("Sri Lanka", "Colombo; Sri Jayewardenepura Kotte (legislative)"),- ("Sudan", "Khartoum"),- ("Suriname", "Paramaribo"),- ("Swaziland", "Mbabane"),- ("Sweden", "Stockholm"),- ("Switzerland", "Bern"),- ("Syria", "Damascus"),- ("Taiwan", "Taipei"),- ("Tajikistan", "Dushanbe"),- ("Tanzania", "Dar es Salaam; Dodoma (legislative)"),- ("Thailand", "Bangkok"),- ("Togo", "Lome"),- ("Tonga", "Nuku'alofa"),- ("Trinidad and Tobago", "Port-of-Spain"),- ("Tunisia", "Tunis"),- ("Turkey", "Ankara"),- ("Turkmenistan", "Ashgabat"),- ("Tuvalu", "Vaiaku village, Funafuti province"),- ("Uganda", "Kampala"),- ("Ukraine", "Kyiv"),- ("United Arab Emirates", "Abu Dhabi"),- ("United Kingdom", "London"),- ("United States of America", "Washington D.C."),- ("Uruguay", "Montevideo"),- ("Uzbekistan", "Tashkent"),- ("Vanuatu", "Port-Vila"),- ("Vatican City (Holy See)", "Vatican City"),- ("Venezuela", "Caracas"),- ("Vietnam", "Hanoi"),- ("Yemen", "Sanaa"),- ("Zambia", "Lusaka"),- ("Zimbabwe", "Harare")]
− examples/Test2.hs
@@ -1,20 +0,0 @@-module Main where--import System.Environment-import Database.Berkeley.Db-import Database.Berkeley.DbXml-import Control.Monad--data Action = Read | Write | Fail deriving Eq--main = do- dbenv <- dbEnv_create []- dbEnv_open dbenv "." [DB_CREATE,DB_INIT_MPOOL] 0- mgr <- xmlManager_create dbenv []- db <- xmlManager_openContainer mgr "metabarter.dbxml"- [DBXML_TRANSACTIONAL,DB_FLAG DB_READ_UNCOMMITTED,DB_FLAG DB_THREAD,DB_FLAG DB_MULTIVERSION,DB_FLAG DB_CREATE]- WholedocContainer 0-- -- To do: Make this test more interesting- putStrLn "Finished."-
+ examples/adventure/Adventure.hs view
@@ -0,0 +1,457 @@+-- | This is a simple persistent multi-user adventure game, to demonstrate the+-- use of Berkeley DB/XML combined with HXT 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+--+-- telnet localhost 1888+--+-- 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 Network+import Control.Concurrent+import Control.Monad+import System.IO+import Data.List+import Data.Char+import Data.Maybe++data Player = Player {+ playerName :: String,+ playerLocation :: String+ }+ deriving (Show)++instance XmlPickler Player where+ xpickle = xpPlayer++xpPlayer :: PU Player+xpPlayer =+ xpElem "player"$+ xpWrap (+ (\(nam, loc) -> Player nam loc),+ (\(Player nam loc) -> (nam, loc))+ )$+ xpPair+ (xpAttr "name"$ xpText0)+ (xpAttr "location"$ xpText0)++data Room = Room {+ roomKey :: String,+ roomDescription :: String,+ roomExits :: [(String, String)]+ }+ deriving (Show)++instance XmlPickler Room where+ xpickle = xpRoom++xpRoom :: PU 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"$+ xpPair+ (xpAttr "name"$ xpText0)+ (xpAttr "room"$ xpText0)+ )++data Item = Item {+ itemKey :: String,+ itemLocation :: String,+ itemDescription :: String,+ itemNames :: [String],+ itemPortable :: Bool+ }+ deriving (Show)++instance XmlPickler Item where+ xpickle = xpItem++xpItem :: PU 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)++initialRooms = [+ Room "beach"+ ("You are on a wide, white sandy beach. A bright blue ocean stretches to the horizon. "+++ "Along the beach to the north you can see some large rocks. There is thick jungle to the west.")+ [("west", "jungle"),("north", "rocks1")],+ Room "jungle"+ "You are in a dense, jungle."+ [("west", "jungle"),("east", "beach"),("north", "jungle"),("south", "jungle"),("up","tree")],+ Room "tree"+ "You are up in a tree. To the south, you can see mountains."+ [("down", "jungle")],+ Room "rocks1"+ ("The beach here is strewn with large boulders. It gets more rocky to the north. "+++ "The sea is to the east.")+ [("south", "beach"),("north", "rocks2")],+ Room "rocks2"+ ("You are in a passage between huge rocks. To the west you can see the entrance to a cave. "+++ "The beach is to the south.")+ [("south", "beach"),("west", "cave")],+ Room "cave"+ ("You are in a cave, exit to the east.")+ [("east", "rocks2")]+ ]++initialItems = [+ Item "starfish" "beach" "a starfish" ["starfish","fish"] True,+ Item "tree" "jungle" "a tall, twisty tree" ["tree"] False,+ Item "nest" "tree" "an empty bird's nest" ["nest", "bird's nest", "bird nest"] True,+ Item "shell" "rocks1" "a beautiful shell" ["shell"] True,+ Item "troll" "cave" "a fierce-looking troll" ["troll"] False,+ Item "coin" "cave" "a gold coin" ["coin", "gold", "gold coin"] True+ ]++-- Get a non-empty line and strip leading and trailing whitespace+prompt :: Handle -> IO String+prompt h = do+ hPutStr h "> "+ hFlush h+ l <- hGetLine h+ let strip = dropWhile isSpace+ let l' = (reverse . strip . reverse . strip) l+ if l' == []+ then prompt h+ else return l'++-- Execute the specified code within a database transaction, automatically+-- re-trying if a deadlock is detected.+inTransaction :: XmlManager -> (XmlTransaction -> IO a) -> IO a+inTransaction mgr code = inTransaction_ mgr code 0+ where+ inTransaction_ mgr code retryCount = do+ trans <- xmlManager_createTransaction mgr []+ catch+ (do+ result <- code trans+ xmlTransaction_commit trans+ return result+ )+ (\err -> do+ xmlTransaction_abort trans+ let dbErr = getDbError err+ if (dbErr == Just DB_LOCK_DEADLOCK) && (retryCount < 20)+ then do+ hPutStrLn stderr "<<retry deadlocked thread>>"+ inTransaction_ mgr code (retryCount+1)+ else ioError err+ )++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!")++collectM :: Monad m => m (Maybe a) -> m [a]+collectM valueM = do+ value <- valueM+ case value of+ Just item -> do+ rest <- collectM valueM+ return (item:rest)+ Nothing -> do+ return []++query_ :: XmlPickler p => (XmlManager, XmlContainer, XmlTransaction) -> PU p+ -> String -> [(String, XmlValue)] -> [DbXmlFlag] -> IO [(XmlDocument, p)]+query_ (mgr, cont, trans) pickler queryText params flags = do+ qctx <- xmlManager_createQueryContext mgr LiveValues Eager+ let collection = xmlContainer_getName cont+ xmlQueryContext_setDefaultCollection qctx collection+ forM params $ \(name, value) -> do+ 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 <- xmlDocument_getContent doc+ ps <- runX (+ readString [ (a_validate, v_0),(a_remove_whitespace, v_1)] text+ >>> xunpickleVal pickler)+ return$ map (\p -> (doc, p)) ps+ return records++query :: XmlPickler p => (XmlManager, XmlContainer, XmlTransaction) -> PU p+ -> String -> [(String, XmlValue)] -> IO [p]+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+ -> 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 (mgr, cont, trans) p = do+ doc <- xmlManager_createDocument mgr+ text <- toXML p+ xmlDocument_setContent doc text+ uctx <- xmlManager_createUpdateContext mgr+ xmlContainer_putDocument cont (Just trans) doc uctx [DBXML_GEN_NAME]++update :: XmlPickler p => (XmlManager, XmlContainer, XmlTransaction) -> XmlDocument -> p -> IO ()+update (mgr, cont, trans) doc p = do+ text <- toXML p+ xmlDocument_setContent doc text+ uctx <- xmlManager_createUpdateContext mgr+ xmlContainer_updateDocument cont (Just trans) doc uctx++-- | Create an item for the player so other players can see them.+putPlayer :: (XmlManager, XmlContainer, XmlTransaction) -> String -> String -> IO ()+putPlayer db name room = do+ items <- queryUpdate db xpItem "collection()/item[@key=$key]" [("key", xmlString$ "player_"++name)]+ case items of+ ((doc, p):_) -> do+ let p' = p {itemLocation = room}+ update db doc p'+ otherwise -> do+ create db$ Item ("player_"++name) room name [] False++deletePlayer :: (XmlManager, XmlContainer, XmlTransaction) -> String -> IO ()+deletePlayer db@(mgr, cont, trans) name = do+ items <- queryUpdate db xpItem "collection()/item[@key=$key]" [("key", xmlString$ "player_"++name)]+ case items of+ ((doc, p):_) -> do+ uctx <- xmlManager_createUpdateContext mgr+ xmlContainer_deleteDocument cont (Just trans) doc uctx+ otherwise -> return ()++initGame :: XmlManager -> XmlContainer -> IO ()+initGame mgr cont = do+ inTransaction mgr$ \trans -> do+ let db = (mgr, cont, trans)+ beaches <- query db xpRoom "collection()/room[@key=$key]" [("key", xmlString "beach")]+ if null beaches+ then do+ hPutStrLn stderr $ "Creating the game world..."+ forM_ initialRooms$ \room -> do+ create db room+ forM_ initialItems$ \item -> do+ create db item+ else return ()++look :: (XmlManager, XmlContainer, XmlTransaction) -> String -> IO [String]+look db name = do+ -- Not very good error checking here.+ player <- liftM head$ query db xpPlayer "collection()/player[@name=$name]"+ [("name", xmlString name)]+ let loc = playerLocation player+ room <- liftM head$ query db xpRoom "collection()/room[@key=$loc]"+ [("loc", xmlString loc)]+ items <- query db xpItem "collection()/item[@location=$loc]"+ [("loc", xmlString loc)]+ let notMe item = -- True if this item doesn't describe the player+ (itemKey item /= "player_"++name)+ let itemsOtherThanMe = filter notMe items+ return$+ (roomDescription room):+ (if null itemsOtherThanMe+ then []+ else "You can see":map (\i -> " "++(itemDescription i)) itemsOtherThanMe)++go :: (XmlManager, XmlContainer, XmlTransaction) -> String -> String -> IO [String]+go db name dir = do+ (playerDoc, player) <- liftM head$ queryUpdate db xpPlayer "collection()/player[@name=$name]"+ [("name", xmlString name)]+ let loc = playerLocation player+ room <- liftM head$ query db xpRoom "collection()/room[@key=$loc]"+ [("loc", xmlString loc)]+ let mExit = dir `lookup` (roomExits room)+ case mExit of+ Just newRoom -> do+ putPlayer db name newRoom+ update db playerDoc player {+ playerLocation = newRoom+ }+ look db name+ Nothing -> do+ return ["You can't go that way."]++get :: (XmlManager, XmlContainer, XmlTransaction) -> String -> String -> IO [String]+get db name noun = do+ player <- liftM head$ query db xpPlayer "collection()/player[@name=$name]"+ [("name", xmlString name)]+ let loc = playerLocation player+ room <- liftM head$ query db xpRoom "collection()/room[@key=$loc]"+ [("loc", xmlString loc)]+ items <- queryUpdate db xpItem "collection()/item[@location=$loc]"+ [("loc", xmlString loc)]+ let yes = filter (\(iDoc, i) -> noun `elem` itemNames i) items+ case yes of+ [] -> return ["I can't see one of those here."]+ ((iDoc, i):_) -> do+ update db iDoc i {itemLocation = "player_"++name}+ return ["You pick up "++(itemDescription i)++"."]++drop :: (XmlManager, XmlContainer, XmlTransaction) -> String -> String -> IO [String]+drop db name noun = do+ player <- liftM head$ query db xpPlayer "collection()/player[@name=$name]"+ [("name", xmlString name)]+ let loc = playerLocation player+ items <- queryUpdate db xpItem "collection()/item[@location=$loc]"+ [("loc", xmlString$ "player_"++name)]+ let yes = filter (\(iDoc, i) -> noun `elem` itemNames i) items+ case yes of+ [] -> return ["I am not carrying one of those."]+ ((iDoc, i):_) -> do+ update db iDoc i {itemLocation = loc}+ return ["You drop "++(itemDescription i)++"."]++inventory :: (XmlManager, XmlContainer, XmlTransaction) -> String -> IO [String]+inventory db name = do+ -- Not very good error checking here.+ items <- query db xpItem "collection()/item[@location=$loc]"+ [("loc", xmlString$ "player_"++name)]+ return$+ (if null items+ then ["You are not carrying anything."]+ else "You are carrying":map (\i -> " "++(itemDescription i)) items)+ +help :: [String]+help = [+ "These are the only commands I understand:",+ " get <item>",+ " drop <item>",+ " inventory",+ " look",+ " north, east, west, south, up, down",+ " quit"+ ]++process :: (XmlManager, XmlContainer, XmlTransaction) -> String -> String -> IO [String]+process db name cmd = do+ case words cmd of+ [] -> return []+ (verb:nouns) -> case (verb, unwords nouns) of+ ("look", _) -> look db name+ ("quit", _) -> fail "User typed 'quit'"+ (dir, _) | dir `elem` ["north", "east", "west", "south", "up", "down"] ->+ go db name dir+ ("get", noun) -> get db name noun+ ("inventory", _) -> inventory db name+ ("drop", noun) -> Main.drop db name noun+ ("help", _) -> return help+ otherwise -> return ["I don't understand that."]++session :: XmlManager -> XmlContainer -> Handle -> IO ()+session mgr cont h = do+ initGame mgr cont+ hPutStrLn h "Welcome to 'DB/XML Haskell binding' adventure by Stephen Blackheath"+ hPutStrLn h "Please enter your name."+ name <- prompt h+ created <- inTransaction mgr$ \trans -> do+ let db = (mgr, cont, trans)+ mPlayer <- liftM listToMaybe$ query db xpPlayer "collection()/player[@name=$name]"+ [("name", xmlString name)]+ (created, player) <- case mPlayer of+ Just player ->+ return (False, player)+ Nothing -> do+ let player = Player name "beach"+ create db player+ return (True, player)+ -- We create an item for the player to make it so other players can see them.+ putPlayer db name (playerLocation player)+ return created+ if created+ then hPutStrLn h$ "Welcome for the first time, "++name++"."+ else hPutStrLn h$ "Welcome back, "++name++"."+ hPutStrLn h$ ""+ hPutStrLn h$ "For help, please type \"help\"."+ hPutStrLn h$ ""++ mapM_ (hPutStrLn h) =<< inTransaction mgr (\trans -> do+ let db = (mgr, cont, trans)+ look db name+ )+ catch (+ forever$ do+ cmd <- prompt h+ mapM_ (hPutStrLn h) =<< inTransaction mgr (\trans -> do+ let db = (mgr, cont, trans)+ process db name cmd+ )+ )+ (\err -> do+ hPutStrLn h$ "Bye!"+ inTransaction mgr$ \trans -> do+ let db = (mgr, cont, trans)+ deletePlayer db name+ ioError err)++deleteCadavers :: (XmlManager, XmlContainer, XmlTransaction) -> IO ()+deleteCadavers db@(mgr, cont, trans) = do+ cadavers <- queryUpdate db xpItem "collection()/item[substring(@key,1,7)='player_']" []+ hPutStrLn stderr$ "tidying up " ++ (show$ length cadavers) ++ " cadavers"+ forM_ cadavers$ \(doc, p) -> do+ uctx <- xmlManager_createUpdateContext mgr+ xmlContainer_deleteDocument cont (Just trans) doc uctx++main = do+ let portNo = 1888+ server <- listenOn (PortNumber portNo)++ dbenv <- dbEnv_create []++ -- Enable automatic deadlock detection. Deadlock detection is required for+ -- multi-threaded applications. Deadlock detection must be started on only+ -- one process in a Berkeley DB environment.+ dbEnv_set_lk_detect dbenv DB_LOCK_DEFAULT++ -- Note that we are doing DB_RECOVER here. This should always be done before+ -- running the application but must be done with no other processes using the+ -- environment at the same time.+ dbEnv_open dbenv "." [DB_CREATE,DB_INIT_LOCK,DB_INIT_LOG,DB_INIT_MPOOL,+ DB_INIT_TXN,DB_THREAD,DB_RECOVER] 0+ mgr <- xmlManager_create dbenv []+ cont <- xmlManager_openContainer mgr "adventure.dbxml"+ [DBXML_TRANSACTIONAL,DB_FLAG DB_THREAD,DB_FLAG DB_MULTIVERSION,DB_FLAG DB_CREATE]+ WholedocContainer 0++ putStrLn$ "Adventure server - please telnet into port "++show portNo++ inTransaction mgr$ \trans -> do+ let db = (mgr, cont, trans)+ deleteCadavers db+ + forever$ do+ (client, host, port) <- accept server+ forkIO$ do+ catch+ (session mgr cont client >> hClose client)+ (\err -> do+ hPutStrLn stderr (show err)+ hClose client)+
+ examples/adventure/Makefile view
@@ -0,0 +1,5 @@+all: adventure++adventure: Adventure.hs+ ghc -threaded --make -o $@ $<+
+ examples/tests/Makefile view
@@ -0,0 +1,5 @@+all: test1++test1: Test1.hs+ ghc --make -o $@ $<+
+ examples/tests/Test1.hs view
@@ -0,0 +1,237 @@+module Main where++import System.Environment+import Database.Berkeley.Db+import Control.Monad++data Action = Read | Write | Fail deriving Eq++writeDb :: Db -> IO ()+writeDb db = do+ forM_ testData$ \(country, capital) -> do+ db_put db Nothing country capital []++readDb :: Db -> IO ()+readDb db = do+ forM_ testData$ \(country, capital) -> do+ capital <- db_get db Nothing country []+ putStrLn$ country ++ " - " ++ (show capital)++main = do+ args <- getArgs+ let action = case args of+ ["read"] -> Read+ ["write"] -> Write+ otherwise -> Fail+ if action == Fail+ then putStrLn "Please say 'read' or 'write' on the command line"+ else do+ dbenv <- dbEnv_create []+ dbEnv_open dbenv "." [DB_CREATE,DB_INIT_MPOOL] 0+ db <- db_create dbenv []+ db_set_pagesize db 2048+ db_open db Nothing "capitals.db" Nothing DB_HASH+ [DB_CREATE] 0+ if action == Read+ then readDb db+ else writeDb db+ db_close db []+ dbEnv_close dbenv []+ putStrLn "Finished."++testData = [+ ("Afghanistan", "Kabul"),+ ("Albania", "Tirane"),+ ("Algeria", "Algiers"),+ ("Andorra", "Andorra la Vella"),+ ("Angola", "Luanda"),+ ("Antigua and Barbuda", "Saint John's"),+ ("Argentina", "Buenos Aires"),+ ("Armenia", "Yerevan"),+ ("Australia", "Canberra"),+ ("Austria", "Vienna"),+ ("Azerbaijan", "Baku"),+ ("The Bahamas", "Nassau"),+ ("Bahrain", "Manama"),+ ("Bangladesh", "Dhaka"),+ ("Barbados", "Bridgetown"),+ ("Belarus", "Minsk"),+ ("Belgium", "Brussels"),+ ("Belize", "Belmopan"),+ ("Benin", "Porto-Novo"),+ ("Bhutan", "Thimphu"),+ ("Bolivia", "La Paz (administrative); Sucre (judicial)"),+ ("Bosnia and Herzegovina", "Sarajevo"),+ ("Botswana", "Gaborone"),+ ("Brazil", "Brasilia"),+ ("Brunei", "Bandar Seri Begawan"),+ ("Bulgaria", "Sofia"),+ ("Burkina Faso", "Ouagadougou"),+ ("Burundi", "Bujumbura"),+ ("Cambodia", "Phnom Penh"),+ ("Cameroon", "Yaounde"),+ ("Canada", "Ottawa"),+ ("Cape Verde", "Praia"),+ ("Central African Republic", "Bangui"),+ ("Chad", "N'Djamena"),+ ("Chile", "Santiago"),+ ("China", "Beijing"),+ ("Colombia", "Bogota"),+ ("Comoros", "Moroni"),+ ("Congo, Republic of the", "Brazzaville"),+ ("Congo, Democratic Republic of the", "Kinshasa"),+ ("Costa Rica", "San Jose"),+ ("Cote d'Ivoire", "Yamoussoukro (official); Abidjan (de facto)"),+ ("Croatia", "Zagreb"),+ ("Cuba", "Havana"),+ ("Cyprus", "Nicosia"),+ ("Czech Republic", "Prague"),+ ("Denmark", "Copenhagen"),+ ("Djibouti", "Djibouti"),+ ("Dominica", "Roseau"),+ ("Dominican Republic", "Santo Domingo"),+ ("East Timor (Timor-Leste)", "Dili"),+ ("Ecuador", "Quito"),+ ("Egypt", "Cairo"),+ ("El Salvador", "San Salvador"),+ ("Equatorial Guinea", "Malabo"),+ ("Eritrea", "Asmara"),+ ("Estonia", "Tallinn"),+ ("Ethiopia", "Addis Ababa"),+ ("Fiji", "Suva"),+ ("Finland", "Helsinki"),+ ("France", "Paris"),+ ("Gabon", "Libreville"),+ ("The Gambia", "Banjul"),+ ("Georgia", "Tbilisi"),+ ("Germany", "Berlin"),+ ("Ghana", "Accra"),+ ("Greece", "Athens"),+ ("Grenada", "Saint George's"),+ ("Guatemala", "Guatemala City"),+ ("Guinea", "Conakry"),+ ("Guinea-Bissau", "Bissau"),+ ("Guyana", "Georgetown"),+ ("Haiti", "Port-au-Prince"),+ ("Honduras", "Tegucigalpa"),+ ("Hungary", "Budapest"),+ ("Iceland", "Reykjavik"),+ ("India", "New Delhi"),+ ("Indonesia", "Jakarta"),+ ("Iran", "Tehran"),+ ("Iraq", "Baghdad"),+ ("Ireland", "Dublin"),+ ("Israel", "Jerusalem"),+ ("Italy", "Rome"),+ ("Jamaica", "Kingston"),+ ("Japan", "Tokyo"),+ ("Jordan", "Amman"),+ ("Kazakhstan", "Astana"),+ ("Kenya", "Nairobi"),+ ("Kiribati", "Tarawa Atoll"),+ ("Korea, North", "Pyongyang"),+ ("Korea, South", "Seoul"),+ ("Kosovo", "Pristina"),+ ("Kuwait", "Kuwait City"),+ ("Kyrgyzstan", "Bishkek"),+ ("Laos", "Vientiane"),+ ("Latvia", "Riga"),+ ("Lebanon", "Beirut"),+ ("Lesotho", "Maseru"),+ ("Liberia", "Monrovia"),+ ("Libya", "Tripoli"),+ ("Liechtenstein", "Vaduz"),+ ("Lithuania", "Vilnius"),+ ("Luxembourg", "Luxembourg"),+ ("Macedonia", "Skopje"),+ ("Madagascar", "Antananarivo"),+ ("Malawi", "Lilongwe"),+ ("Malaysia", "Kuala Lumpur"),+ ("Maldives", "Male"),+ ("Mali", "Bamako"),+ ("Malta", "Valletta"),+ ("Marshall Islands", "Majuro"),+ ("Mauritania", "Nouakchott"),+ ("Mauritius", "Port Louis"),+ ("Mexico", "Mexico City"),+ ("Micronesia, Federated States of", "Palikir"),+ ("Moldova", "Chisinau"),+ ("Monaco", "Monaco"),+ ("Mongolia", "Ulaanbaatar"),+ ("Montenegro", "Podgorica"),+ ("Morocco", "Rabat"),+ ("Mozambique", "Maputo"),+ ("Myanmar (Burma)", "Rangoon (Yangon); Naypyidaw or Nay Pyi Taw (administrative)"),+ ("Namibia", "Windhoek"),+ ("Nauru", "no official capital; government offices in Yaren District"),+ ("Nepal", "Kathmandu"),+ ("Netherlands", "Amsterdam; The Hague (seat of government)"),+ ("New Zealand", "Wellington"),+ ("Nicaragua", "Managua"),+ ("Niger", "Niamey"),+ ("Nigeria", "Abuja"),+ ("Norway", "Oslo"),+ ("Oman", "Muscat"),+ ("Pakistan", "Islamabad"),+ ("Palau", "Melekeok"),+ ("Panama", "Panama City"),+ ("Papua New Guinea", "Port Moresby"),+ ("Paraguay", "Asuncion"),+ ("Peru", "Lima"),+ ("Philippines", "Manila"),+ ("Poland", "Warsaw"),+ ("Portugal", "Lisbon"),+ ("Qatar", "Doha"),+ ("Romania", "Bucharest"),+ ("Russia", "Moscow"),+ ("Rwanda", "Kigali"),+ ("Saint Kitts and Nevis", "Basseterre"),+ ("Saint Lucia", "Castries"),+ ("Saint Vincent and the Grenadines", "Kingstown"),+ ("Samoa", "Apia"),+ ("San Marino", "San Marino"),+ ("Sao Tome and Principe", "Sao Tome"),+ ("Saudi Arabia", "Riyadh"),+ ("Senegal", "Dakar"),+ ("Serbia", "Belgrade"),+ ("Seychelles", "Victoria"),+ ("Sierra Leone", "Freetown"),+ ("Singapore", "Singapore"),+ ("Slovakia", "Bratislava"),+ ("Slovenia", "Ljubljana"),+ ("Solomon Islands", "Honiara"),+ ("Somalia", "Mogadishu"),+ ("South Africa", "Pretoria (administrative); Cape Town (legislative); Bloemfontein (judiciary)"),+ ("Spain", "Madrid"),+ ("Sri Lanka", "Colombo; Sri Jayewardenepura Kotte (legislative)"),+ ("Sudan", "Khartoum"),+ ("Suriname", "Paramaribo"),+ ("Swaziland", "Mbabane"),+ ("Sweden", "Stockholm"),+ ("Switzerland", "Bern"),+ ("Syria", "Damascus"),+ ("Taiwan", "Taipei"),+ ("Tajikistan", "Dushanbe"),+ ("Tanzania", "Dar es Salaam; Dodoma (legislative)"),+ ("Thailand", "Bangkok"),+ ("Togo", "Lome"),+ ("Tonga", "Nuku'alofa"),+ ("Trinidad and Tobago", "Port-of-Spain"),+ ("Tunisia", "Tunis"),+ ("Turkey", "Ankara"),+ ("Turkmenistan", "Ashgabat"),+ ("Tuvalu", "Vaiaku village, Funafuti province"),+ ("Uganda", "Kampala"),+ ("Ukraine", "Kyiv"),+ ("United Arab Emirates", "Abu Dhabi"),+ ("United Kingdom", "London"),+ ("United States of America", "Washington D.C."),+ ("Uruguay", "Montevideo"),+ ("Uzbekistan", "Tashkent"),+ ("Vanuatu", "Port-Vila"),+ ("Vatican City (Holy See)", "Vatican City"),+ ("Venezuela", "Caracas"),+ ("Vietnam", "Hanoi"),+ ("Yemen", "Sanaa"),+ ("Zambia", "Lusaka"),+ ("Zimbabwe", "Harare")]