diff --git a/BerkeleyDBXML.cabal b/BerkeleyDBXML.cabal --- a/BerkeleyDBXML.cabal +++ b/BerkeleyDBXML.cabal @@ -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 diff --git a/Database/Berkeley/Db.hs b/Database/Berkeley/Db.hs --- a/Database/Berkeley/Db.hs +++ b/Database/Berkeley/Db.hs @@ -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 () diff --git a/Database/Berkeley/DbXml.hs b/Database/Berkeley/DbXml.hs --- a/Database/Berkeley/DbXml.hs +++ b/Database/Berkeley/DbXml.hs @@ -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 diff --git a/Database/Berkeley/db_helper.cpp b/Database/Berkeley/db_helper.cpp --- a/Database/Berkeley/db_helper.cpp +++ b/Database/Berkeley/db_helper.cpp @@ -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(); diff --git a/Database/Berkeley/db_helper.h b/Database/Berkeley/db_helper.h --- a/Database/Berkeley/db_helper.h +++ b/Database/Berkeley/db_helper.h @@ -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 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 @@ -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; 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 @@ -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); diff --git a/README b/README --- a/README +++ b/README @@ -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 \ diff --git a/examples/Makefile b/examples/Makefile deleted file mode 100644 --- a/examples/Makefile +++ /dev/null @@ -1,8 +0,0 @@ -all: test1 test2 - -test1: Test1.hs - ghc --make -o $@ $< - -test2: Test2.hs - ghc --make -o $@ $< - diff --git a/examples/Test1.hs b/examples/Test1.hs deleted file mode 100644 --- a/examples/Test1.hs +++ /dev/null @@ -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")] diff --git a/examples/Test2.hs b/examples/Test2.hs deleted file mode 100644 --- a/examples/Test2.hs +++ /dev/null @@ -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." - diff --git a/examples/adventure/Adventure.hs b/examples/adventure/Adventure.hs new file mode 100644 --- /dev/null +++ b/examples/adventure/Adventure.hs @@ -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 "<>" + 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 ", + " drop ", + " 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) + diff --git a/examples/adventure/Makefile b/examples/adventure/Makefile new file mode 100644 --- /dev/null +++ b/examples/adventure/Makefile @@ -0,0 +1,5 @@ +all: adventure + +adventure: Adventure.hs + ghc -threaded --make -o $@ $< + diff --git a/examples/tests/Makefile b/examples/tests/Makefile new file mode 100644 --- /dev/null +++ b/examples/tests/Makefile @@ -0,0 +1,5 @@ +all: test1 + +test1: Test1.hs + ghc --make -o $@ $< + diff --git a/examples/tests/Test1.hs b/examples/tests/Test1.hs new file mode 100644 --- /dev/null +++ b/examples/tests/Test1.hs @@ -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")]