BerkeleyDBXML 0.5 → 0.6
raw patch · 15 files changed
+616/−2017 lines, 15 filesdep +BerkeleyDBdep ~base
Dependencies added: BerkeleyDB
Dependency ranges changed: base
Files
- BerkeleyDBXML.cabal +4/−15
- ChangeLog +3/−0
- Database/Berkeley/Db.hs +0/−734
- Database/Berkeley/DbXml.hs +119/−112
- Database/Berkeley/Util.hs +0/−37
- Database/Berkeley/db_helper.cpp +0/−338
- Database/Berkeley/db_helper.h +0/−47
- Database/Berkeley/dbxml_helper.cpp +19/−1
- Database/Berkeley/dbxml_helper.h +2/−1
- README +1/−9
- examples/adventure.hs +468/−0
- examples/adventure/Adventure.hs +0/−467
- examples/adventure/Makefile +0/−7
- examples/tests/Makefile +0/−7
- examples/tests/Test1.hs +0/−242
BerkeleyDBXML.cabal view
@@ -1,9 +1,9 @@ name: BerkeleyDBXML-version: 0.5+version: 0.6 license: BSD3 license-file: LICENSE cabal-version: >= 1.4-copyright: (c) Stephen Blackheath+copyright: (c) 2009 Stephen Blackheath author: Stephen Blackheath maintainer: http://blacksapphire.com/antispam/ stability: beta@@ -13,9 +13,6 @@ XQuery as its query language. Berkeley DB XML is built on top of Berkeley DB. It is NOT an SQL database. .- This package provides a 70% complete Haskell binding for Berkeley DB and Berkeley- DB XML. It is also possible to compile for Berkeley DB only.- . Berkeley DB XML home page: <http://www.oracle.com/database/berkeley-db/xml/index.html> .@@ -31,22 +28,14 @@ extra-source-files: README, ChangeLog,- Database/Berkeley/db_helper.h, Database/Berkeley/dbxml_helper.h,- examples/adventure/Makefile- examples/adventure/Adventure.hs- examples/tests/Test1.hs- examples/tests/Makefile+ examples/adventure.hs Library- exposed-modules: Database.Berkeley.Db- c-sources: Database/Berkeley/db_helper.cpp- exposed-modules: Database.Berkeley.DbXml c-sources: Database/Berkeley/dbxml_helper.cpp - other-modules: Database.Berkeley.Util- build-depends: base, bytestring >= 0.9+ build-depends: base >= 4, bytestring >= 0.9, BerkeleyDB >= 0.6 include-dirs: Database/Berkeley/ extra-libraries: db, dbxml, db_cxx, xqilla, xerces-c, xml2 ghc-options: -pgml c++
ChangeLog view
@@ -1,3 +1,6 @@+0.6 05 Jan 2009+ - Split BerkeleyDB into a separate package.+ - Change to the new Control.Exception from base version 4. 0.5 13 Dec 2008 - Change all 'unsafe' to 'safe' so it'll work better in a threaded environment.
− Database/Berkeley/Db.hs
@@ -1,734 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}-{-# CFILES Database/Berkeley/db_helper.cpp #-}---- | All IO monad functions can throw exceptions. Use getDbError to fetch the--- error code.--module Database.Berkeley.Db (- -- * General- DbFlag(..),- DbError(..),- getDbError,- -- * DbEnv- DbEnv,- dbEnv_close,- dbEnv_create,- dbEnv_get_cache_size,- dbEnv_get_lg_regionmax,- dbEnv_get_lk_max_lockers,- dbEnv_get_lk_max_locks,- dbEnv_get_lk_max_objects,- dbEnv_get_tx_max,- DbLocker,- DbLockMode(..),- dbEnv_lock_get,- dbEnv_lock_put,- dbEnv_open,- dbEnv_set_cache_size,- dbEnv_set_lg_regionmax,- DbLockFlag(..),- dbEnv_set_lk_detect,- dbEnv_set_lk_max_lockers,- dbEnv_set_lk_max_locks,- dbEnv_set_lk_max_objects,- dbEnv_set_tx_max,- dbEnv_txn_begin,- dbEnv_txn_checkpoint,- -- * DbTxn- DbTxn,- dbTxn_abort,- dbTxn_commit,- dbTxn_id,- -- * Db- Db,- db_close,- db_create,- db_del,- db_get,- DbType(..),- db_open,- db_put,- db_set_pagesize,- -- * Private- dbOrFlags, -- Private to DbXml- dbToNum, -- Private to DbXml- DbTxn_struct -- Private to DbXml- ) where--import Foreign.C-import Foreign.Marshal.Alloc-import Foreign.Storable-import Foreign.Ptr-import Control.Monad-import Data.Bits-import Database.Berkeley.Util-import Data.Maybe-import System.IO.Error-import Foreign.ForeignPtr-import System.IO.Unsafe-import Data.ByteString (ByteString)-import qualified Data.ByteString.Internal as BSI-import Data.Word--data DbEnv_struct-type DbEnv = Ptr DbEnv_struct--{-- DB (user visible) error return codes.- - !!!- We don't want our error returns to conflict with other packages where- possible, so pick a base error value that's hopefully not common. We- document that we own the error name space from -30,800 to -30,999.- -}-data DbError = - DB_BUFFER_SMALL | -- User memory too small for return.- DB_DONOTINDEX | -- "Null" return from 2ndary callbk.- DB_KEYEMPTY | -- Key/data deleted or never created.- DB_KEYEXIST | -- The key/data pair already exists.- DB_LOCK_DEADLOCK | -- Deadlock.- DB_LOCK_NOTGRANTED | -- Lock unavailable.- DB_LOG_BUFFER_FULL | -- In-memory log buffer full.- DB_NOSERVER | -- Server panic return.- DB_NOSERVER_HOME | -- Bad home sent to server.- DB_NOSERVER_ID | -- Bad ID sent to server.- DB_NOTFOUND | -- Key/data pair not found (EOF).- DB_OLD_VERSION | -- Out-of-date version.- DB_PAGE_NOTFOUND | -- Requested page not found.- DB_REP_DUPMASTER | -- There are two masters.- DB_REP_HANDLE_DEAD | -- Rolled back a commit.- DB_REP_HOLDELECTION | -- Time to hold an election.- DB_REP_IGNORE | -- This msg should be ignored.*/- DB_REP_ISPERM | -- Cached not written perm written.*/- DB_REP_JOIN_FAILURE | -- Unable to join replication group.- DB_REP_LEASE_EXPIRED | -- Master lease has expired.- DB_REP_LOCKOUT | -- API/Replication lockout now.- DB_REP_NEWSITE | -- New site entered system.- DB_REP_NOTPERM | -- Permanent log record not written.- DB_REP_UNAVAIL | -- Site cannot currently be reached.- DB_RUNRECOVERY | -- Panic return.- DB_SECONDARY_BAD | -- Secondary index corrupt.- DB_VERIFY_BAD | -- Verify failed; bad format.- DB_VERSION_MISMATCH | -- Environment version mismatch.- SYSTEM_ERROR Int- deriving (Eq,Show)--dbErrFromNum (-30999) = Just DB_BUFFER_SMALL-dbErrFromNum (-30998) = Just DB_DONOTINDEX-dbErrFromNum (-30997) = Just DB_KEYEMPTY-dbErrFromNum (-30996) = Just DB_KEYEXIST-dbErrFromNum (-30995) = Just DB_LOCK_DEADLOCK-dbErrFromNum (-30994) = Just DB_LOCK_NOTGRANTED-dbErrFromNum (-30993) = Just DB_LOG_BUFFER_FULL-dbErrFromNum (-30992) = Just DB_NOSERVER-dbErrFromNum (-30991) = Just DB_NOSERVER_HOME-dbErrFromNum (-30990) = Just DB_NOSERVER_ID-dbErrFromNum (-30989) = Just DB_NOTFOUND-dbErrFromNum (-30988) = Just DB_OLD_VERSION-dbErrFromNum (-30987) = Just DB_PAGE_NOTFOUND-dbErrFromNum (-30986) = Just DB_REP_DUPMASTER-dbErrFromNum (-30985) = Just DB_REP_HANDLE_DEAD-dbErrFromNum (-30984) = Just DB_REP_HOLDELECTION-dbErrFromNum (-30983) = Just DB_REP_IGNORE-dbErrFromNum (-30982) = Just DB_REP_ISPERM-dbErrFromNum (-30981) = Just DB_REP_JOIN_FAILURE-dbErrFromNum (-30980) = Just DB_REP_LEASE_EXPIRED-dbErrFromNum (-30979) = Just DB_REP_LOCKOUT-dbErrFromNum (-30978) = Just DB_REP_NEWSITE-dbErrFromNum (-30977) = Just DB_REP_NOTPERM-dbErrFromNum (-30976) = Just DB_REP_UNAVAIL-dbErrFromNum (-30975) = Just DB_RUNRECOVERY-dbErrFromNum (-30974) = Just DB_SECONDARY_BAD-dbErrFromNum (-30973) = Just DB_VERIFY_BAD-dbErrFromNum (-30972) = Just DB_VERSION_MISMATCH-dbErrFromNum 0 = Nothing-dbErrFromNum n = Just (SYSTEM_ERROR n)---- | Helper specific to Haskell binding: Fetches a DbError value out of a Haskell--- IOError, so the caller can catch an exception and check the error code.-getDbError :: IOError -> Maybe DbError-getDbError ioError =- if isUserError ioError- then- let s = ioeGetErrorString ioError in- case extract "db=\"" s ['"'] of- Just nStr -> dbErrFromNum $ fromMaybe 0 $ maybeRead nStr- Nothing -> Nothing- else Nothing--throw :: String -> CInt -> IO a-throw func code = do- ioError $ userError $ "db error func="++func++" db=\""++(show $ fromIntegral code)++"\""--foreign import ccall safe "db_helper.h _dbenv_create__" _dbenv_create__- :: Ptr DbEnv -> CUInt -> IO CInt--data DbEnvCreateFlag = DB_RPCCLIENT--dbEnv_create :: [DbEnvCreateFlag] -> IO DbEnv-dbEnv_create flags =- alloca $ \ptr -> do- ret <- _dbenv_create__ ptr orFlags- if ret /= 0- then throw "_dbenv_create" ret- else peek ptr- where- orFlags = foldr (.|.) 0 $ map toNum flags- toNum DB_RPCCLIENT = 0x0000002---foreign import ccall safe "db_helper.h _dbenv_get_lk_max_lockers" _dbenv_get_lk_max_lockers- :: DbEnv -> Ptr CUInt -> IO CInt--dbEnv_get_lk_max_lockers :: DbEnv -> IO Int-dbEnv_get_lk_max_lockers dbenv =- alloca $ \ptr -> do- ret <- _dbenv_get_lk_max_lockers dbenv ptr- if ret /= 0- then throw "dbEnv_get_lk_max_lockers" ret- else do- ci <- peek ptr- return $ fromIntegral ci--foreign import ccall safe "db_helper.h _dbenv_set_lk_max_lockers" _dbenv_set_lk_max_lockers- :: DbEnv -> CUInt -> IO CInt--dbEnv_set_lk_max_lockers :: DbEnv -> Int -> IO ()-dbEnv_set_lk_max_lockers dbenv max = do- ret <- _dbenv_set_lk_max_lockers dbenv (fromIntegral max)- if ret /= 0- then throw "dbEnv_set_lk_max_lockers" ret- else return ()-- -foreign import ccall safe "db_helper.h _dbenv_get_lk_max_locks" _dbenv_get_lk_max_locks- :: DbEnv -> Ptr CUInt -> IO CInt- -dbEnv_get_lk_max_locks :: DbEnv -> IO Int-dbEnv_get_lk_max_locks dbenv =- alloca $ \ptr -> do- ret <- _dbenv_get_lk_max_locks dbenv ptr- if ret /= 0- then throw "dbEnv_get_lk_max_locks" ret- else do- ci <- peek ptr- return $ fromIntegral ci--foreign import ccall safe "db_helper.h _dbenv_set_lk_max_locks" _dbenv_set_lk_max_locks- :: DbEnv -> CUInt -> IO CInt--dbEnv_set_lk_max_locks :: DbEnv -> Int -> IO ()-dbEnv_set_lk_max_locks dbenv max = do- ret <- _dbenv_set_lk_max_locks dbenv (fromIntegral max)- if ret /= 0- then throw "dbEnv_set_lk_max_locks" ret- else return ()-- -foreign import ccall safe "db_helper.h _dbenv_get_lk_max_objects" _dbenv_get_lk_max_objects- :: DbEnv -> Ptr CUInt -> IO CInt--dbEnv_get_lk_max_objects :: DbEnv -> IO Int-dbEnv_get_lk_max_objects dbenv =- alloca $ \ptr -> do- ret <- _dbenv_get_lk_max_objects dbenv ptr- if ret /= 0- then throw "dbEnv_get_lk_max_objects" ret- else do- ci <- peek ptr- return $ fromIntegral ci--foreign import ccall safe "db_helper.h _dbenv_set_lk_max_objects" _dbenv_set_lk_max_objects- :: DbEnv -> CUInt -> IO CInt--dbEnv_set_lk_max_objects :: DbEnv -> Int -> IO ()-dbEnv_set_lk_max_objects dbenv max = do- ret <- _dbenv_set_lk_max_objects dbenv (fromIntegral max)- if ret /= 0- then throw "dbEnv_set_lk_max_objects" ret- else return ()-- -foreign import ccall safe "db_helper.h _dbenv_get_tx_max" _dbenv_get_tx_max- :: DbEnv -> Ptr CUInt -> IO CInt--dbEnv_get_tx_max :: DbEnv -> IO Int-dbEnv_get_tx_max dbenv =- alloca $ \ptr -> do- ret <- _dbenv_get_tx_max dbenv ptr- if ret /= 0- then throw "dbEnv_get_tx_max" ret- else do- ci <- peek ptr- return $ fromIntegral ci--foreign import ccall safe "db_helper.h _dbenv_set_tx_max" _dbenv_set_tx_max- :: DbEnv -> CUInt -> IO CInt--dbEnv_set_tx_max :: DbEnv -> Int -> IO ()-dbEnv_set_tx_max dbenv max = do- ret <- _dbenv_set_tx_max dbenv (fromIntegral max)- if ret /= 0- then throw "dbEnv_set_tx_max" ret- else return ()---foreign import ccall safe "db_helper.h _dbenv_get_cachesize" _dbenv_get_cachesize- :: DbEnv -> Ptr CUInt -> Ptr CUInt -> Ptr Int -> IO CInt--dbEnv_get_cache_size :: DbEnv -> IO (Int, Int, Int)-dbEnv_get_cache_size dbenv =- alloca $ \ptr1 -> alloca $ \ptr2 -> alloca $ \ptr3 -> do- ret <- _dbenv_get_cachesize dbenv ptr1 ptr2 ptr3- if ret /= 0- then throw "dbEnv_get_cache_size" ret- else do- c1 <- peek ptr1- c2 <- peek ptr2- c3 <- peek ptr3- return $ (fromIntegral c1, fromIntegral c2, fromIntegral c3)--foreign import ccall safe "db_helper.h _dbenv_set_cachesize" _dbenv_set_cachesize- :: DbEnv -> CUInt -> CUInt -> CInt -> IO CInt--dbEnv_set_cache_size :: DbEnv -> Int -> Int -> Int -> IO ()-dbEnv_set_cache_size dbenv gbytes bytes ncache = do- ret <- _dbenv_set_cachesize dbenv (fromIntegral gbytes) (fromIntegral bytes) (fromIntegral ncache)- if ret /= 0- then throw "dbEnv_set_cache_size" ret- else return ()---foreign import ccall safe "db_helper.h _dbenv_get_lg_regionmax" _dbenv_get_lg_regionmax- :: DbEnv -> Ptr CUInt -> IO CInt--dbEnv_get_lg_regionmax :: DbEnv -> IO Int-dbEnv_get_lg_regionmax dbenv =- alloca $ \ptr -> do- ret <- _dbenv_get_lg_regionmax dbenv ptr- if ret /= 0- then throw "dbEnv_get_lg_regionmax" ret- else do- ci <- peek ptr- return $ fromIntegral ci--foreign import ccall safe "db_helper.h _dbenv_set_lg_regionmax" _dbenv_set_lg_regionmax- :: DbEnv -> CUInt -> IO CInt--dbEnv_set_lg_regionmax :: DbEnv -> Int -> IO ()-dbEnv_set_lg_regionmax dbenv max = do- ret <- _dbenv_set_lg_regionmax dbenv (fromIntegral max)- if ret /= 0- then throw "dbEnv_set_lg_regionmax" ret- else return ()---foreign import ccall safe "db_helper.h _dbenv_open" _dbenv_open- :: DbEnv -> CString -> CUInt -> CInt -> IO CInt--data DbFlag =- DB_CREATE |- DB_DURABLE_UNKNOWN |- DB_FORCE |- DB_MULTIVERSION |- DB_NOMMAP |- DB_RDONLY |- DB_RECOVER |- DB_THREAD |- DB_TRUNCATE |- DB_TXN_NOSYNC |- DB_TXN_NOWAIT |- DB_TXN_NOT_DURABLE |- DB_TXN_WRITE_NOSYNC |- DB_SPARE_FLAG |- DB_TXN_SYNC |- DB_TXN_WAIT |- DB_IGNORE_LEASE |- DB_AUTO_COMMIT |- DB_READ_COMMITTED |- DB_DEGREE_2 |- DB_READ_UNCOMMITTED |- DB_DIRTY_READ |- DB_TXN_SNAPSHOT |- DB_CXX_NO_EXCEPTIONS |- DB_XA_CREATE |- DB_USE_ENVIRON |- DB_USE_ENVIRON_ROOT |- DB_INIT_CDB |- DB_INIT_LOCK |- DB_INIT_LOG |- DB_INIT_MPOOL |- DB_INIT_REP |- DB_INIT_TXN |- DB_LOCKDOWN |- DB_PRIVATE |- DB_RECOVER_FATAL |- DB_REGISTER |- DB_SYSTEM_MEM |- DB_EXCL |- DB_FCNTL_LOCKING |- DB_NO_AUTO_COMMIT |- DB_RDWRMASTER |- DB_WRITEOPEN |- DB_MULTIPLE |- DB_MULTIPLE_KEY |- DB_RMW |- DB_LOCK_NOWAIT--dbToNum DB_CREATE = 0x0000001-dbToNum DB_DURABLE_UNKNOWN = 0x0000002-dbToNum DB_FORCE = 0x0000004-dbToNum DB_MULTIVERSION = 0x0000008-dbToNum DB_NOMMAP = 0x0000010-dbToNum DB_RDONLY = 0x0000020-dbToNum DB_RECOVER = 0x0000040-dbToNum DB_THREAD = 0x0000080-dbToNum DB_TRUNCATE = 0x0000100-dbToNum DB_TXN_NOSYNC = 0x0000200-dbToNum DB_TXN_NOWAIT = 0x0000400-dbToNum DB_TXN_NOT_DURABLE = 0x0000800-dbToNum DB_TXN_WRITE_NOSYNC = 0x0001000-dbToNum DB_SPARE_FLAG = 0x0002000-dbToNum DB_TXN_SYNC = 0x0004000-dbToNum DB_TXN_WAIT = 0x0008000-dbToNum DB_IGNORE_LEASE = 0x01000000-dbToNum DB_AUTO_COMMIT = 0x02000000-dbToNum DB_READ_COMMITTED = 0x04000000-dbToNum DB_DEGREE_2 = 0x04000000-dbToNum DB_READ_UNCOMMITTED = 0x08000000-dbToNum DB_DIRTY_READ = 0x08000000-dbToNum DB_TXN_SNAPSHOT = 0x10000000-dbToNum DB_CXX_NO_EXCEPTIONS = 0x0000001 -dbToNum DB_XA_CREATE = 0x0000002 -dbToNum DB_USE_ENVIRON = 0x0004000 -dbToNum DB_USE_ENVIRON_ROOT = 0x0008000 -dbToNum DB_INIT_CDB = 0x0010000 -dbToNum DB_INIT_LOCK = 0x0020000 -dbToNum DB_INIT_LOG = 0x0040000 -dbToNum DB_INIT_MPOOL = 0x0080000 -dbToNum DB_INIT_REP = 0x0100000 -dbToNum DB_INIT_TXN = 0x0200000 -dbToNum DB_LOCKDOWN = 0x0400000 -dbToNum DB_PRIVATE = 0x0800000 -dbToNum DB_RECOVER_FATAL = 0x1000000 -dbToNum DB_REGISTER = 0x2000000 -dbToNum DB_SYSTEM_MEM = 0x4000000 -dbToNum DB_EXCL = 0x0004000 -dbToNum DB_FCNTL_LOCKING = 0x0008000 -dbToNum DB_NO_AUTO_COMMIT = 0x0010000 -dbToNum DB_RDWRMASTER = 0x0020000 -dbToNum DB_WRITEOPEN = 0x0040000 -dbToNum DB_MULTIPLE = 0x10000000-dbToNum DB_MULTIPLE_KEY = 0x20000000-dbToNum DB_RMW = 0x40000000-dbToNum DB_LOCK_NOWAIT = 0x002--dbOrFlags flags = foldr (.|.) 0 $ map dbToNum flags--dbEnv_open :: DbEnv -> String -> [DbFlag] -> Int -> IO ()-dbEnv_open dbenv db_home flags mode =- withCAString db_home $ \c_db_home -> do- ret <- _dbenv_open dbenv c_db_home (dbOrFlags flags) (fromIntegral mode)- if ret /= 0- then throw "dbEnv_open" ret- else return ()--data Db_struct-type Db = ForeignPtr Db_struct-foreign import ccall "db_helper.h &_db_delete" _db_delete- :: FunPtr (Ptr Db_struct -> IO ())--foreign import ccall safe "db_helper.h _db_create" _db_create- :: Ptr DbEnv_struct -> CUInt -> Ptr (Ptr Db_struct) -> IO CInt--db_create :: DbEnv -> [DbFlag] -> IO Db-db_create dbenv flags =- alloca$ \ptr -> do- ret <- _db_create dbenv (dbOrFlags flags) ptr- if ret /= 0- then throw "db_create" ret- else do- p <- peek ptr- newForeignPtr _db_delete p--foreign import ccall safe "db_helper.h _db_set_pagesize" _db_set_pagesize- :: Ptr Db_struct -> CUInt -> IO CInt--db_set_pagesize :: Db -> Int -> IO ()-db_set_pagesize db size =- withForeignPtr db$ \c_db -> do- ret <- _db_set_pagesize c_db (fromIntegral size)- if ret /= 0- then throw "db_set_pagesize" ret- else return ()--data DbType = DB_BTREE | DB_HASH | DB_RECNO | DB_QUEUE | DB_UNKNOWN--dbTypeToNum DB_BTREE = 1-dbTypeToNum DB_HASH = 2-dbTypeToNum DB_RECNO = 3-dbTypeToNum DB_QUEUE = 4-dbTypeToNum DB_UNKNOWN = 5--data DbTxn_struct-type DbTxn = ForeignPtr DbTxn_struct-foreign import ccall "db_helper.h &_dbtxn_delete" _dbtxn_delete- :: FunPtr (Ptr DbTxn_struct -> IO ())--foreign import ccall "db_helper.h _db_open" _db_open- :: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CString -> CInt -> CUInt -> CInt -> IO CInt--db_open :: Db -> Maybe DbTxn -> String -> Maybe String -> DbType -> [DbFlag] -> Int -> IO ()-db_open db mTxn file mDatabase typ flags mode =- withCAString file$ \c_file ->- withForeignPtr db$ \c_db -> do- ret <- case mTxn of- Just dbtxn ->- withForeignPtr dbtxn$ \c_dbtxn ->- case mDatabase of- Just database ->- withCAString database$ \c_database ->- _db_open c_db c_dbtxn c_file c_database- (dbTypeToNum typ) (dbOrFlags flags) (fromIntegral mode)- Nothing ->- _db_open c_db c_dbtxn c_file nullPtr- (dbTypeToNum typ) (dbOrFlags flags) (fromIntegral mode)- Nothing ->- case mDatabase of- Just database ->- withCAString database$ \c_database ->- _db_open c_db nullPtr c_file c_database- (dbTypeToNum typ) (dbOrFlags flags) (fromIntegral mode)- Nothing ->- _db_open c_db nullPtr c_file nullPtr- (dbTypeToNum typ) (dbOrFlags flags) (fromIntegral mode)- if ret /= 0- then throw ("db_open file="++(show file)++" database="++(show mDatabase)) ret- else return ()--foreign import ccall "db_helper.h _dbenv_txn_begin" _dbenv_txn_begin- :: Ptr DbEnv_struct -> Ptr DbTxn_struct -> Ptr (Ptr DbTxn_struct) -> CUInt -> IO CInt--dbEnv_txn_begin :: DbEnv -> Maybe DbTxn -> [DbFlag] -> IO DbTxn-dbEnv_txn_begin dbenv mParent flags = do- alloca$ \ptr -> do- ret <- case mParent of- Nothing -> do- _dbenv_txn_begin dbenv nullPtr ptr (dbOrFlags flags)- Just parent ->- withForeignPtr parent$ \c_parent -> do- _dbenv_txn_begin dbenv c_parent ptr (dbOrFlags flags)- if ret /= 0- then throw "dbEnv_txn_begin" ret- else do- p <- peek ptr- newForeignPtr _dbtxn_delete p--foreign import ccall "db_helper.h _dbenv_txn_checkpoint" _dbenv_txn_checkpoint- :: Ptr DbEnv_struct -> CUInt -> CUInt -> CUInt -> IO CInt--dbEnv_txn_checkpoint :: DbEnv -> CUInt -> CUInt -> [DbFlag] -> IO ()-dbEnv_txn_checkpoint dbenv kbyte min flags = do- ret <- _dbenv_txn_checkpoint dbenv kbyte min (dbOrFlags flags)- if ret /= 0- then throw "dbEnv_txn_checkpoint" ret- else return ()--foreign import ccall "db_helper.h _dbtxn_abort" _dbtxn_abort- :: Ptr DbTxn_struct -> IO CInt--dbTxn_abort :: DbTxn -> IO ()-dbTxn_abort dbtxn = do- withForeignPtr dbtxn$ \c_dbtxn -> do- ret <- _dbtxn_abort c_dbtxn- if ret /= 0- then throw "dbTxn_abort" ret- else return ()--foreign import ccall "db_helper.h _dbtxn_commit" _dbtxn_commit- :: Ptr DbTxn_struct -> CUInt -> IO CInt--dbTxn_commit :: DbTxn -> [DbFlag] -> IO ()-dbTxn_commit dbtxn flags = do- withForeignPtr dbtxn$ \c_dbtxn -> do- ret <- _dbtxn_commit c_dbtxn (dbOrFlags flags)- if ret /= 0- then throw "dbTxn_commit" ret- else return ()--newtype DbLocker = DbLocker CUInt--foreign import ccall "db_helper.h _dbtxn_id" _dbtxn_id- :: Ptr DbTxn_struct -> IO CUInt--dbTxn_id :: DbTxn -> DbLocker-dbTxn_id dbtxn =- unsafePerformIO$- withForeignPtr dbtxn$ \c_dbtxn ->- liftM DbLocker$ _dbtxn_id c_dbtxn- -data DbLockMode = DB_LOCK_READ | DB_LOCK_WRITE | DB_LOCK_IWRITE | DB_LOCK_IREAD | DB_LOCK_IWR--dbLockModeToNum DB_LOCK_READ = 1-dbLockModeToNum DB_LOCK_WRITE = 2-dbLockModeToNum DB_LOCK_IWRITE = 4-dbLockModeToNum DB_LOCK_IREAD = 5-dbLockModeToNum DB_LOCK_IWR = 6--data DbLock_struct-type DbLock = ForeignPtr DbLock_struct-foreign import ccall "db_helper.h &_dblock_delete" _dblock_delete- :: FunPtr (Ptr DbLock_struct -> IO ())--foreign import ccall "db_helper.h _dbenv_lock_get" _dbenv_lock_get- :: Ptr DbEnv_struct -> CUInt -> CUInt -> CString -> CUInt -> CUInt -> Ptr (Ptr DbLock_struct) -> IO CInt--dbEnv_lock_get :: DbEnv -> DbLocker -> [DbFlag] -> String -> DbLockMode -> IO DbLock-dbEnv_lock_get dbenv (DbLocker locker) flags object lockMode =- alloca$ \ptr ->- withCAStringLen object$ \(c_object, object_len) -> do- ret <- _dbenv_lock_get dbenv locker (dbOrFlags flags) c_object- (fromIntegral object_len) (dbLockModeToNum lockMode) ptr- if ret /= 0- then throw "dbEnv_lock_get" ret- else do- p <- peek ptr- newForeignPtr _dblock_delete p--foreign import ccall "db_helper.h _dbenv_lock_put" _dbenv_lock_put- :: Ptr DbEnv_struct -> Ptr DbLock_struct -> IO CInt--dbEnv_lock_put :: DbEnv -> DbLock -> IO ()-dbEnv_lock_put dbenv dblock =- withForeignPtr dblock$ \c_dblock -> do- ret <- _dbenv_lock_put dbenv c_dblock- if ret /= 0- then throw "dbEnv_lock_put" ret- else return ()--foreign import ccall unsafe "db_helper.h _deleteString" _deleteString- :: CString -> IO ()--foreign import ccall unsafe "db_helper.h _freeString" _freeString- :: CString -> IO ()--foreign import ccall unsafe "db_helper.h &_freeString" _freeString_finalizer- :: FunPtr (Ptr Word8 -> IO ())--foreign import ccall "db_helper.h _db_get" _db_get- :: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CUInt -> Ptr (Ptr Word8) -> Ptr CUInt -> CUInt -> IO CInt--db_get :: Db -> Maybe DbTxn -> String -> [DbFlag] -> IO (Maybe ByteString)-db_get db mTxn key flags =- alloca$ \ptr1 ->- alloca$ \ptr2 ->- withCAStringLen key$ \(c_key, key_len) ->- withForeignPtr db$ \c_db -> do- ret <- case mTxn of- Nothing ->- _db_get c_db nullPtr c_key (fromIntegral key_len) ptr1 ptr2 (dbOrFlags flags)- Just txn ->- withForeignPtr txn$ \c_txn ->- _db_get c_db c_txn c_key (fromIntegral key_len) ptr1 ptr2 (dbOrFlags flags)- if ret /= 0- then- if (dbErrFromNum$ fromIntegral ret) == Just DB_NOTFOUND- then return Nothing- else throw "db_get" ret- else do- c_value <- peek ptr1- value_len <- peek ptr2- str <- newForeignPtr _freeString_finalizer c_value- return $ Just $ BSI.fromForeignPtr str 0 (fromIntegral value_len)--foreign import ccall "db_helper.h _db_put" _db_put- :: Ptr Db_struct -> Ptr DbTxn_struct -> CString -> CUInt -> Ptr Word8 -> CUInt -> CUInt -> IO CInt--db_put :: Db -> Maybe DbTxn -> String -> ByteString -> [DbFlag] -> IO ()-db_put db mTxn key value flags =- withCAStringLen key$ \(c_key, key_len) ->- withByteString value $ \c_value value_len ->- withForeignPtr db$ \c_db -> do- ret <- case mTxn of- Nothing ->- _db_put c_db nullPtr c_key (fromIntegral key_len)- c_value (fromIntegral value_len) (dbOrFlags flags)- Just txn ->- withForeignPtr txn$ \c_txn ->- _db_put c_db c_txn c_key (fromIntegral key_len)- c_value (fromIntegral value_len) (dbOrFlags flags)- if ret /= 0- 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- -db_close :: Db -> [DbFlag] -> IO ()-db_close db flags =- withForeignPtr db$ \c_db -> do- ret <- _db_close c_db (dbOrFlags flags)- if ret /= 0- then throw "db_close" ret- else return ()--foreign import ccall "db_helper.h _dbenv_close" _dbenv_close- :: Ptr DbEnv_struct -> CUInt -> IO CInt--dbEnv_close :: DbEnv -> [DbFlag] -> IO ()-dbEnv_close dbEnv flags = do- 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
@@ -1,16 +1,15 @@-{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, TypeSynonymInstances #-}+{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls, TypeSynonymInstances, DeriveDataTypeable #-} {-# CFILES Database/Berkeley/dbxml_helper.cpp #-} --- | All IO monad functions can throw exceptions. Use getDbXmlError to fetch the--- error code.+-- | Berkeley DB binding. All IO monad functions can throw DbXmlException or DbException. module Database.Berkeley.DbXml (- -- * General+ -- * Common DbXmlFlag(..), ExceptionCode(..),+ DbXmlException(..), XmlResults, XmlResultsReturnable,- getDbXmlError, -- * XmlContainer XmlContainer, xmlContainer_close,@@ -72,7 +71,6 @@ import Foreign.Marshal.Utils import Data.Bits import Database.Berkeley.Db-import Database.Berkeley.Util import Data.Maybe import System.IO.Error import Data.Char@@ -81,7 +79,11 @@ import Data.ByteString (ByteString) import Data.Word import qualified Data.ByteString.Internal as BSI+import Control.Exception+import Data.Typeable +dbOrFlags flags = foldr (.|.) 0 $ map dbToNum flags+ toUtf8 :: String -> String toUtf8 = concatMap charToUtf8 @@ -111,68 +113,73 @@ _ | (c .&. 0xc0) == 0xe0 -> ((c .&. 0x1f) `shiftL` 6) .|. -} data ExceptionCode =- INTERNAL_ERROR | --An internal error occured.- CONTAINER_OPEN | --The container is open.- CONTAINER_CLOSED | --The container is closed.- NULL_POINTER | --null pointer exception- INDEXER_PARSER_ERROR | --XML Indexer could not parse a document.- DATABASE_ERROR | --Berkeley DB reported a database problem.- QUERY_PARSER_ERROR | --The query parser was unable to parse the expression.- UNUSED1_ERROR | --Unused- QUERY_EVALUATION_ERROR | --The query evaluator was unable to execute the expression.- UNUSED2_ERROR | --Unused- LAZY_EVALUATION | --XmlResults is lazily evaluated.- DOCUMENT_NOT_FOUND | --The specified document could not be found- CONTAINER_EXISTS | --The container already exists.- UNKNOWN_INDEX | --The indexing strategy name is unknown.- INVALID_VALUE | --An invalid parameter was passed.- VERSION_MISMATCH | --The container version and the dbxml library version are not compatible.- EVENT_ERROR | --Error using the event reader- CONTAINER_NOT_FOUND | --The specified container could not be found- TRANSACTION_ERROR | --An XmlTransaction has already been committed or aborted- UNIQUE_ERROR | --A uniqueness constraint has been violated- NO_MEMORY_ERROR | --Unable to allocate memory- OPERATION_TIMEOUT | --An operation timed out- OPERATION_INTERRUPTED --An operation was explicitly interrupted+ INTERNAL_ERROR | -- ^ An internal error occured.+ CONTAINER_OPEN | -- ^ The container is open.+ CONTAINER_CLOSED | -- ^ The container is closed.+ NULL_POINTER | -- ^ null pointer exception+ INDEXER_PARSER_ERROR | -- ^ XML Indexer could not parse a document.+ -- Note: DATABASE_ERROR is not used. We use DbException instead.+ QUERY_PARSER_ERROR | -- ^ The query parser was unable to parse the expression.+ UNUSED1_ERROR | -- ^ Unused+ QUERY_EVALUATION_ERROR | -- ^ The query evaluator was unable to execute the expression.+ UNUSED2_ERROR | -- ^ Unused+ LAZY_EVALUATION | -- ^ XmlResults is lazily evaluated.+ DOCUMENT_NOT_FOUND | -- ^ The specified document could not be found+ CONTAINER_EXISTS | -- ^ The container already exists.+ UNKNOWN_INDEX | -- ^ The indexing strategy name is unknown.+ INVALID_VALUE | -- ^ An invalid parameter was passed.+ VERSION_MISMATCH | -- ^ The container version and the dbxml library version are not compatible.+ EVENT_ERROR | -- ^ Error using the event reader+ CONTAINER_NOT_FOUND | -- ^ The specified container could not be found+ TRANSACTION_ERROR | -- ^ An XmlTransaction has already been committed or aborted+ UNIQUE_ERROR | -- ^ A uniqueness constraint has been violated+ NO_MEMORY_ERROR | -- ^ Unable to allocate memory+ OPERATION_TIMEOUT | -- ^ An operation timed out+ OPERATION_INTERRUPTED | -- ^ An operation was explicitly interrupted+ UNKNOWN_ERROR -- ^ An unexpected error code was received from Berkeley DbXML deriving (Show,Eq)+ +dbxmlErrFromNum :: Int -> ExceptionCode+dbxmlErrFromNum 0 = INTERNAL_ERROR+dbxmlErrFromNum 1 = CONTAINER_OPEN+dbxmlErrFromNum 2 = CONTAINER_CLOSED+dbxmlErrFromNum 3 = NULL_POINTER+dbxmlErrFromNum 4 = INDEXER_PARSER_ERROR+dbxmlErrFromNum 6 = QUERY_PARSER_ERROR+dbxmlErrFromNum 7 = UNUSED1_ERROR+dbxmlErrFromNum 8 = QUERY_EVALUATION_ERROR+dbxmlErrFromNum 9 = UNUSED2_ERROR+dbxmlErrFromNum 10 = LAZY_EVALUATION+dbxmlErrFromNum 11 = DOCUMENT_NOT_FOUND+dbxmlErrFromNum 12 = CONTAINER_EXISTS+dbxmlErrFromNum 13 = UNKNOWN_INDEX+dbxmlErrFromNum 14 = INVALID_VALUE+dbxmlErrFromNum 15 = VERSION_MISMATCH+dbxmlErrFromNum 16 = EVENT_ERROR+dbxmlErrFromNum 17 = CONTAINER_NOT_FOUND+dbxmlErrFromNum 18 = TRANSACTION_ERROR+dbxmlErrFromNum 19 = UNIQUE_ERROR+dbxmlErrFromNum 20 = NO_MEMORY_ERROR+dbxmlErrFromNum 21 = OPERATION_TIMEOUT+dbxmlErrFromNum 22 = OPERATION_INTERRUPTED+dbxmlErrFromNum _ = UNKNOWN_ERROR -dbxmlErrFromNum 0 = Just INTERNAL_ERROR-dbxmlErrFromNum 1 = Just CONTAINER_OPEN-dbxmlErrFromNum 2 = Just CONTAINER_CLOSED-dbxmlErrFromNum 3 = Just NULL_POINTER-dbxmlErrFromNum 4 = Just INDEXER_PARSER_ERROR-dbxmlErrFromNum 5 = Just DATABASE_ERROR-dbxmlErrFromNum 6 = Just QUERY_PARSER_ERROR-dbxmlErrFromNum 7 = Just UNUSED1_ERROR-dbxmlErrFromNum 8 = Just QUERY_EVALUATION_ERROR-dbxmlErrFromNum 9 = Just UNUSED2_ERROR-dbxmlErrFromNum 10 = Just LAZY_EVALUATION-dbxmlErrFromNum 11 = Just DOCUMENT_NOT_FOUND-dbxmlErrFromNum 12 = Just CONTAINER_EXISTS-dbxmlErrFromNum 13 = Just UNKNOWN_INDEX-dbxmlErrFromNum 14 = Just INVALID_VALUE-dbxmlErrFromNum 15 = Just VERSION_MISMATCH-dbxmlErrFromNum 16 = Just EVENT_ERROR-dbxmlErrFromNum 17 = Just CONTAINER_NOT_FOUND-dbxmlErrFromNum 18 = Just TRANSACTION_ERROR-dbxmlErrFromNum 19 = Just UNIQUE_ERROR-dbxmlErrFromNum 20 = Just NO_MEMORY_ERROR-dbxmlErrFromNum 21 = Just OPERATION_TIMEOUT-dbxmlErrFromNum 22 = Just OPERATION_INTERRUPTED-dbxmlErrFromNum _ = Nothing+-- | An exception indicating an error in a Berkeley DBXML operation.+data DbXmlException = DbXmlException String ExceptionCode+ deriving (Eq, Show, Typeable) --- | Helper specific to Haskell binding: Fetches a Berkeley DB XML ExceptionCode--- value out of a Haskell IOError so the caller can check the return code.-getDbXmlError :: IOError -> Maybe ExceptionCode-getDbXmlError ioError =- if isUserError ioError- then- let s = ioeGetErrorString ioError in- case extract "dbxml=\"" s ['"'] of- Just nStr -> dbxmlErrFromNum $ fromMaybe 0 $ maybeRead nStr- Nothing -> Nothing- else Nothing+instance Exception DbXmlException where +throwDBXML :: String -> CInt -> String -> IO a+throwDBXML func code extraText = do+ let descr = func++extraText+ if dbXmlCode == 5 -- 5 means 'DATABASE_ERROR'+ then throwIO $ DbException descr (dbErrFromNum dbCode)+ else throwIO $ DbXmlException descr (dbxmlErrFromNum dbXmlCode)+ where+ dbCode = -(fromIntegral code `mod` 100000)+ dbXmlCode = (fromIntegral code `div` 100000) - 1+ -- | Note: If you want to pass a Berkeley DB flag where the type is DbXmlFlag, -- use the DB_FLAG constructor. data DbXmlFlag =@@ -228,25 +235,19 @@ dbxmlOrFlags flags = foldr (.|.) 0 $ map dbxmlToNum flags -throw :: String -> CInt -> String -> IO a-throw func code extra = do- ioError $ userError $ "db error func="++func++" db=\""++(show dbCode)++"\" dbxml=\""++(show dbXmlCode)++"\""++extra- where- dbCode = -(code `mod` 100000)- dbXmlCode = (code `div` 100000) - 1- data XmlManager_struct type XmlManager = Ptr XmlManager_struct foreign import ccall safe "dbxml_helper.h _xmlManager" _xmlManager- :: DbEnv -> CUInt -> Ptr XmlManager -> IO CInt+ :: Ptr DbEnv_struct -> CUInt -> Ptr XmlManager -> IO CInt xmlManager_create :: DbEnv -> [DbXmlFlag] -> IO XmlManager xmlManager_create dbenv flags =+ withForeignPtr dbenv $ \c_dbenv -> alloca $ \ptr -> do- ret <- _xmlManager dbenv (dbxmlOrFlags flags) ptr+ ret <- _xmlManager c_dbenv (dbxmlOrFlags flags) ptr if ret /= 0- then throw "xmlManager" ret ""+ then throwDBXML "xmlManager_create" ret "" else peek ptr data XmlContainer_struct@@ -265,7 +266,7 @@ withCAString filename $ \c_filename -> do ret <- _xmlManager_openContainer mgr c_filename (dbxmlOrFlags flags) (numCType cType) (fromIntegral mode) ptr if ret /= 0- then throw "xmlManager_openContainer" ret ""+ then throwDBXML "xmlManager_openContainer" ret "" else do p <- peek ptr newForeignPtr _xmlContainer_delete p@@ -286,7 +287,7 @@ alloca $ \ptr -> do ret <- _xmlManager_createTransaction mgr (dbOrFlags flags) ptr if ret /= 0- then throw "xmlManager_createTransaction" ret ""+ then throwDBXML "xmlManager_createTransaction" ret "" else do p <- peek ptr newForeignPtr _xmlTransaction_delete p@@ -297,10 +298,10 @@ xmlManager_createTransaction_DbTxn :: XmlManager -> DbTxn -> IO XmlTransaction xmlManager_createTransaction_DbTxn mgr dbtxn = alloca $ \ptr ->- withForeignPtr dbtxn$ \c_dbtxn -> do+ withForeignPtr dbtxn $ \c_dbtxn -> do ret <- _xmlManager_createTransaction_DbTxn mgr c_dbtxn ptr if ret /= 0- then throw "xmlManager_createTransaction_DbTxn" ret ""+ then throwDBXML "xmlManager_createTransaction_DbTxn" ret "" else do p <- peek ptr newForeignPtr _xmlTransaction_delete p@@ -313,7 +314,7 @@ ret <- _xmlTransaction_commit (unsafeForeignPtrToPtr trans) touchForeignPtr trans if ret /= 0- then throw "xmlTransaction_commit" ret ""+ then throwDBXML "xmlTransaction_commit" ret "" else return () foreign import ccall safe "dbxml_helper.h _xmlTransaction_abort" _xmlTransaction_abort@@ -324,7 +325,7 @@ ret <- _xmlTransaction_abort (unsafeForeignPtrToPtr trans) touchForeignPtr trans if ret /= 0- then throw "xmlTransaction_abort" ret ""+ then throwDBXML "xmlTransaction_abort" ret "" else return () data XmlDocument_struct@@ -349,7 +350,7 @@ _xmlContainer_getDocument cont_ nullPtr c_key (dbOrFlags flags) ptr touchForeignPtr cont if ret /= 0- then throw "xmlContainer_getDocument" ret ""+ then throwDBXML "xmlContainer_getDocument" ret "" else do p <- peek ptr newForeignPtr _xmlDocument_delete p@@ -380,7 +381,7 @@ ret <- _xmlDocument_getContent (unsafeForeignPtrToPtr doc) ptr pLength touchForeignPtr doc if ret /= 0- then throw "xmlDocument_getContent" ret ""+ then throwDBXML "xmlDocument_getContent" ret "" else do cstr <- peek ptr length <- peek pLength@@ -407,7 +408,7 @@ alloca $ \ptr -> do ret <- _xmlManager_createQueryContext mgr (rtToInt rt) (evToInt ev) ptr if ret /= 0- then throw "xmlManager_createQueryContext" ret ""+ then throwDBXML "xmlManager_createQueryContext" ret "" else do p <- peek ptr newForeignPtr _xmlQueryContext_delete p@@ -426,7 +427,7 @@ ret <- _xmlResults_hasNext (unsafeForeignPtrToPtr res) ptr touchForeignPtr res if ret /= 0- then throw "xmlResults_hasNext" ret ""+ then throwDBXML "xmlResults_hasNext" ret "" else do answer <- peek ptr return $ if answer /= 0 then True else False@@ -449,7 +450,7 @@ ret <- _xmlResults_nextDocument (unsafeForeignPtrToPtr res) ptr touchForeignPtr res if ret /= 0- then throw "xmlResults_next" ret "XmlDocument"+ then throwDBXML "xmlResults_next" ret "XmlDocument" else do doc <- peek ptr if doc == nullPtr@@ -467,7 +468,7 @@ ret <- _xmlResults_nextValue (unsafeForeignPtrToPtr res) ptr touchForeignPtr res if ret /= 0- then throw "xmlResults_next" ret "XmlValue"+ then throwDBXML "xmlResults_next" ret "XmlValue" else do doc <- peek ptr if doc == nullPtr@@ -500,7 +501,7 @@ _xmlManager_query mgr nullPtr c_query (unsafeForeignPtrToPtr ctx) (dbxmlOrFlags flags) ptr if ret /= 0- then throw "xmlManager_query" ret (" query="++query)+ then throwDBXML "xmlManager_query" ret (" query="++query) else do p <- peek ptr newForeignPtr _xmlResults_delete p@@ -528,7 +529,7 @@ _xmlManager_prepare mgr nullPtr c_query (unsafeForeignPtrToPtr ctx) ptr if ret /= 0- then throw "xmlManager_prepare" ret (" query="++query)+ then throwDBXML "xmlManager_prepare" ret (" query="++query) else do p <- peek ptr newForeignPtr _xmlQueryExpression_delete p@@ -542,7 +543,7 @@ ret <- _xmlQueryContext_setDefaultCollection (unsafeForeignPtrToPtr ctx) c_coll touchForeignPtr ctx if ret /= 0- then throw "xmlQueryContext_setDefaultCollection" ret (" arg="++coll)+ then throwDBXML "xmlQueryContext_setDefaultCollection" ret (" arg="++coll) else return () data XmlValue_struct@@ -562,7 +563,7 @@ :: CString -> IO (Ptr XmlValue_struct) xmlString :: String -> XmlValue-xmlString text = unsafePerformIO$ do+xmlString text = unsafePerformIO $ do withCAString (toUtf8 text) $ \c_text -> do xv <- _xmlString c_text newForeignPtr _xmlValue_delete xv@@ -571,7 +572,7 @@ :: CInt -> IO (Ptr XmlValue_struct) xmlBool :: Bool -> XmlValue-xmlBool b = unsafePerformIO$ do+xmlBool b = unsafePerformIO $ do xv <- _xmlBool$ if b then 1 else 0 newForeignPtr _xmlValue_delete xv @@ -579,7 +580,7 @@ :: CDouble -> IO (Ptr XmlValue_struct) xmlDouble :: Double -> XmlValue-xmlDouble value = unsafePerformIO$ do+xmlDouble value = unsafePerformIO $ do xv <- _xmlDouble$ realToFrac value newForeignPtr _xmlValue_delete xv @@ -588,12 +589,12 @@ -- | Get the string content of this XmlValue object and decode UTF-8 to return -- a Unicode string.-xmlValue_asString :: XmlValue -> IO String-xmlValue_asString value = alloca$ \ptr -> do+xmlValue_asString :: XmlValue -> String+xmlValue_asString value = unsafePerformIO $ alloca $ \ptr -> do ret <- _xmlValue_asString (unsafeForeignPtrToPtr value) ptr touchForeignPtr value if ret /= 0- then throw "xmlValue_asString" ret ""+ then throwDBXML "xmlValue_asString" ret "" else do cstr <- peek ptr str <- peekCAString cstr@@ -603,8 +604,8 @@ -- | 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 -> IO String-xmlValue_asString8Bit value = alloca$ \ptr -> do+xmlValue_asString8Bit :: XmlValue -> String+xmlValue_asString8Bit value = unsafePerformIO $ alloca $ \ptr -> do ret <- _xmlValue_asString (unsafeForeignPtrToPtr value) ptr touchForeignPtr value cstr <- peek ptr@@ -622,7 +623,7 @@ touchForeignPtr ctx touchForeignPtr value if ret /= 0- then throw "xmlQueryContext_setVariableValue" ret (" name="++name++" value="++(show value))+ then throwDBXML "xmlQueryContext_setVariableValue" ret (" name="++name++" value="++(show value)) else return () -- Safe so it doesn't block other Haskell threads, since this one can take a while to execute@@ -637,7 +638,7 @@ -> [DbXmlFlag] -> IO XmlResults xmlQueryExpression_execute exp mTrans mContextItem qctx flags =- alloca$ \ptr -> do+ alloca $ \ptr -> do let p2p = unsafeForeignPtrToPtr let exp_ = p2p exp let qctx_ = p2p qctx@@ -661,7 +662,7 @@ touchForeignPtr exp touchForeignPtr qctx if ret /= 0- then throw "xmlQueryExpression_execute" ret ""+ then throwDBXML "xmlQueryExpression_execute" ret "" else do p <- peek ptr newForeignPtr _xmlResults_delete p@@ -671,10 +672,10 @@ xmlManager_createDocument :: XmlManager -> IO XmlDocument xmlManager_createDocument mgr =- alloca$ \ptr -> do+ alloca $ \ptr -> do ret <- _xmlManager_createDocument mgr ptr if ret /= 0- then throw "xmlManager_createDocument" ret ""+ then throwDBXML "xmlManager_createDocument" ret "" else do p <- peek ptr newForeignPtr _xmlDocument_delete p@@ -683,11 +684,11 @@ :: Ptr XmlDocument_struct -> Ptr CString -> IO CInt xmlDocument_getName :: XmlDocument -> IO String-xmlDocument_getName doc = alloca$ \ptr -> do+xmlDocument_getName doc = alloca $ \ptr -> do ret <- _xmlDocument_getName (unsafeForeignPtrToPtr doc) ptr touchForeignPtr doc if ret /= 0- then throw "xmlDocument_getName" ret ""+ then throwDBXML "xmlDocument_getName" ret "" else do cstr <- peek ptr str <- peekCAString cstr@@ -698,11 +699,11 @@ :: Ptr XmlDocument_struct -> CString -> IO CInt xmlDocument_setName :: XmlDocument -> String -> IO ()-xmlDocument_setName doc name = withCAString name$ \c_name -> do+xmlDocument_setName doc name = withCAString name $ \c_name -> do ret <- _xmlDocument_setName (unsafeForeignPtrToPtr doc) c_name touchForeignPtr doc if ret /= 0- then throw "xmlDocument_setName" ret ""+ then throwDBXML "xmlDocument_setName" ret "" else return () data XmlUpdateContext_struct@@ -715,10 +716,10 @@ xmlManager_createUpdateContext :: XmlManager -> IO XmlUpdateContext xmlManager_createUpdateContext mgr =- alloca$ \ptr -> do+ alloca $ \ptr -> do ret <- _xmlManager_createUpdateContext mgr ptr if ret /= 0- then throw "xmlManager_createUpdateContext" ret ""+ then throwDBXML "xmlManager_createUpdateContext" ret "" else do p <- peek ptr newForeignPtr _xmlUpdateContext_delete p@@ -732,9 +733,15 @@ ret <- _xmlDocument_setContent (unsafeForeignPtrToPtr doc) c_text (fromIntegral text_length) touchForeignPtr doc if ret /= 0- then throw "xmlDocument_setContent" ret ""+ then throwDBXML "xmlDocument_setContent" ret "" else return () +withByteString :: ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a+withByteString bs code = do+ let (fp, fp_offset, length) = BSI.toForeignPtr bs+ withForeignPtr fp $ \c_fp ->+ code (c_fp `plusPtr` fp_offset) length+ foreign import ccall safe "dbxml_helper.h _xmlContainer_updateDocument" _xmlContainer_updateDocument :: Ptr XmlContainer_struct -> Ptr XmlTransaction_struct -> Ptr XmlDocument_struct -> Ptr XmlUpdateContext_struct -> IO CInt@@ -756,7 +763,7 @@ touchForeignPtr doc touchForeignPtr uctx if ret /= 0- then throw "xmlContainer_updateDocument" ret ""+ then throwDBXML "xmlContainer_updateDocument" ret "" else return () foreign import ccall safe "dbxml_helper.h _xmlContainer_putDocument" _xmlContainer_putDocument@@ -781,7 +788,7 @@ touchForeignPtr doc touchForeignPtr uctx if ret /= 0- then throw "xmlContainer_updateDocument" ret ""+ then throwDBXML "xmlContainer_updateDocument" ret "" else return () foreign import ccall safe "dbxml_helper.h _xmlContainer_deleteDocument" _xmlContainer_deleteDocument@@ -805,7 +812,7 @@ touchForeignPtr doc touchForeignPtr uctx if ret /= 0- then throw "xmlContainer_deleteDocument" ret ""+ then throwDBXML "xmlContainer_deleteDocument" ret "" else return () foreign import ccall safe "dbxml_helper.h _xmlContainer_close" _xmlContainer_close
− Database/Berkeley/Util.hs
@@ -1,37 +0,0 @@-module Database.Berkeley.Util- where--import Data.List-import Data.ByteString (ByteString)-import qualified Data.ByteString.Internal as BSI-import Foreign.ForeignPtr-import Foreign.Ptr-import Data.Word--locate :: (Eq a) => [a] -> [a] -> Maybe Int-locate needle haystack = locate_ needle haystack 0 where- locate_ _ [] _ = Nothing- locate_ needle haystack idx =- if isPrefixOf needle haystack- then Just idx- else locate_ needle (tail haystack) (idx+1)--maybeRead :: Read a => String -> Maybe a -maybeRead s = case reads s of- [(x, "")] -> Just x- _ -> Nothing--toDelim :: String -> Int -> [Char] -> String-toDelim line idx delims = takeWhile (flip notElem delims) (drop idx line)--extract :: String -> String -> [Char] -> Maybe String-extract tag line delims =- case locate tag line of- Just idx -> Just $ toDelim line (idx+(length tag)) delims- _ -> Nothing--withByteString :: ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a-withByteString bs code = do- let (fp, fp_offset, length) = BSI.toForeignPtr bs- withForeignPtr fp $ \c_fp ->- code (c_fp `plusPtr` fp_offset) length
− Database/Berkeley/db_helper.cpp
@@ -1,338 +0,0 @@-#include "db_helper.h"--#include <string.h>-#include <stdlib.h>--int _dbenv_create__(DbEnv** dbenv, u_int32_t flags) {- *dbenv = new DbEnv(flags);- return 0;-}--int _dbenv_get_lk_max_lockers(DbEnv *dbenv, u_int32_t *lk_maxp) {- try {- return dbenv->get_lk_max_lockers(lk_maxp);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _dbenv_set_lk_max_lockers(DbEnv *dbenv, u_int32_t max) {- try {- return dbenv->set_lk_max_lockers(max);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _dbenv_get_lk_max_locks(DbEnv *dbenv, u_int32_t *lk_maxp) {- try {- return dbenv->get_lk_max_locks(lk_maxp);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _dbenv_set_lk_max_locks(DbEnv *dbenv, u_int32_t max) {- try {- return dbenv->set_lk_max_locks(max);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _dbenv_get_lk_max_objects(DbEnv *dbenv, u_int32_t *lk_maxp) {- try {- return dbenv->get_lk_max_objects(lk_maxp);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _dbenv_set_lk_max_objects(DbEnv *dbenv, u_int32_t max) {- try {- return dbenv->set_lk_max_objects(max);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _dbenv_get_tx_max(DbEnv *dbenv, u_int32_t *lk_maxp) {- try {- return dbenv->get_tx_max(lk_maxp);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _dbenv_set_tx_max(DbEnv *dbenv, u_int32_t max) {- try {- return dbenv->set_tx_max(max);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _dbenv_get_cachesize(DbEnv *dbenv, u_int32_t *gbytesp, u_int32_t *bytesp, int *ncachep) {- try {- return dbenv->get_cachesize(gbytesp, bytesp, ncachep);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _dbenv_set_cachesize(DbEnv *dbenv, u_int32_t gbytes, u_int32_t bytes, int ncache) {- try {- return dbenv->set_cachesize(gbytes, bytes, ncache);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _dbenv_get_lg_regionmax(DbEnv *dbenv, u_int32_t *lk_maxp) {- try {- return dbenv->get_lg_regionmax(lk_maxp);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _dbenv_set_lg_regionmax(DbEnv *dbenv, u_int32_t max) {- try {- return dbenv->set_lg_regionmax(max);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _dbenv_open(DbEnv *dbenv, char *db_home, u_int32_t flags, int mode) {- try {- return dbenv->open(db_home, flags, mode);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _db_create(DbEnv* dbenv, u_int32_t flags, Db** db)-{- try {- *db = new Db(dbenv, flags);- return 0;- }- catch (DbException& exc) {- return exc.get_errno();- }-}--void _db_delete(Db* db)-{- delete db;-}--int _db_set_pagesize(Db* db, u_int32_t pagesize)-{- try {- return db->set_pagesize(pagesize);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _db_open(Db* db, DbTxn* txn, const char* file, const char* database,- int type, u_int32_t flags, int mode)-{- try {- return db->open(txn, file, database, (DBTYPE) type, flags, mode);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _dbenv_txn_begin(DbEnv* dbenv, DbTxn* parent, DbTxn** txn, u_int32_t flags)-{- try {- return dbenv->txn_begin(parent, txn, flags);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _dbenv_txn_checkpoint(DbEnv* dbenv, u_int32_t kbyte, u_int32_t min, u_int32_t flags)-{- try {- return dbenv->txn_checkpoint(kbyte, min, flags);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _dbtxn_abort(DbTxn* dbtxn)-{- try {- return dbtxn->abort();- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _dbtxn_commit(DbTxn* dbtxn, u_int32_t flags)-{- try {- return dbtxn->commit(flags);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--void _dbtxn_delete(DbTxn* dbtxn)-{- // dbtxn_abort or dbtxn_commit actually do the delete.- // To do: Make it so memory leaks aren't possible.-}--u_int32_t _dbtxn_id(DbTxn* dbtxn)-{- return dbtxn->id();-}--void _dblock_delete(DbLock* dblock)-{- delete dblock;-}--int _dbenv_lock_get(DbEnv* dbenv, u_int32_t lockerID, u_int32_t flags,- const char* object, u_int32_t object_len, u_int32_t lockmode, DbLock** dblock)-{- Dbt dbt;- memset(&dbt, 0, sizeof(dbt));- dbt.set_data((void*)object);- dbt.set_size(object_len);- *dblock = new DbLock;- try {- int ret = dbenv->lock_get(lockerID, flags, &dbt, (db_lockmode_t)lockmode, *dblock);- if (ret != 0) {- delete *dblock;- *dblock = NULL;- }- return ret;- }- catch (DbException& exc) {- delete *dblock;- *dblock = NULL;- return exc.get_errno();- }-}--int _dbenv_lock_put(DbEnv* dbenv, DbLock* dblock)-{- try {- dbenv->lock_put(dblock);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--void _deleteString(char* str)-{- delete[] str;-}--void _freeString(char* str)-{- free(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)-{- Dbt keyDbt((void*)key, key_len);- Dbt valueDbt;- valueDbt.set_flags(DB_DBT_MALLOC);- *value = NULL;- *value_len = 0;- try {- int ret = db->get(dbtxn, &keyDbt, &valueDbt, flags);- if (ret == 0) {- *value = (char*)valueDbt.get_data();- *value_len = valueDbt.get_size();- }- return ret;- }- catch (DbException& exc) {- return exc.get_errno();- }-}--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)-{- Dbt keyDbt((void*)key, key_len);- Dbt valueDbt((void*)value, value_len);- try {- return db->put(dbtxn, &keyDbt, &valueDbt, flags);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--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 {- return db->close(flags);- }- catch (DbException& exc) {- return exc.get_errno();- }-}--int _dbenv_close(DbEnv* dbEnv, u_int32_t flags)-{- try {- 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
@@ -1,47 +0,0 @@-#ifndef _DB_HELPER_H_-#define _DB_HELPER_H_--#include "db_cxx.h"--extern "C" {- int _dbenv_create__(DbEnv** dbenv, u_int32_t flags);- int _dbenv_get_lk_max_lockers(DbEnv *dbenv, u_int32_t *lk_maxp);- int _dbenv_set_lk_max_lockers(DbEnv *dbenv, u_int32_t max);- int _dbenv_get_lk_max_locks(DbEnv *dbenv, u_int32_t *lk_maxp);- int _dbenv_set_lk_max_locks(DbEnv *dbenv, u_int32_t max);- int _dbenv_get_lk_max_objects(DbEnv *dbenv, u_int32_t *lk_maxp);- int _dbenv_set_lk_max_objects(DbEnv *dbenv, u_int32_t max);- int _dbenv_get_tx_max(DbEnv *dbenv, u_int32_t *lk_maxp);- int _dbenv_set_tx_max(DbEnv *dbenv, u_int32_t max);- int _dbenv_get_cachesize(DbEnv *dbenv, u_int32_t *gbytesp, u_int32_t *bytesp, int *ncachep);- int _dbenv_set_cachesize(DbEnv *dbenv, u_int32_t gbytes, u_int32_t bytes, int ncache);- int _dbenv_get_lg_regionmax(DbEnv *dbenv, u_int32_t *lk_maxp);- int _dbenv_set_lg_regionmax(DbEnv *dbenv, u_int32_t max);- int _dbenv_open(DbEnv *dbenv, char *db_home, u_int32_t flags, int mode);- int _db_create(DbEnv* dbenv, u_int32_t flags, Db** db);- void _db_delete(Db* db);- int _db_set_pagesize(Db* db, u_int32_t pagesize);- int _db_open(Db* db, DbTxn* txn, const char* file, const char* database,- int type, u_int32_t flags, int mode);- int _dbenv_txn_begin(DbEnv* dbenv, DbTxn* parent, DbTxn** txn, u_int32_t flags);- int _dbenv_txn_checkpoint(DbEnv* dbenv, u_int32_t kbyte, u_int32_t min, u_int32_t flags);- int _dbtxn_abort(DbTxn* dbtxn);- int _dbtxn_commit(DbTxn* dbtxn, u_int32_t flags);- void _dbtxn_delete(DbTxn* dbtxn);- u_int32_t _dbtxn_id(DbTxn* dbtxn);- void _dblock_delete(DbLock* dblock);- int _dbenv_lock_get(DbEnv* dbenv, u_int32_t lockerID, u_int32_t flags,- const char* object, u_int32_t object_len, u_int32_t lockmode, DbLock** dblock);- int _dbenv_lock_put(DbEnv* dbenv, DbLock* dblock);- void _deleteString(char* str);- 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
@@ -8,6 +8,18 @@ using namespace DbXml; using namespace std; +#define UNWRAP_DBTXN_() \+ if (dbtxnp == NULL) \+ dbtxn = NULL; \+ else { \+ dbtxn = *dbtxnp; \+ if (dbtxn == NULL) return -20883; /* Haskell binding-specific error code */ \+ }++#define UNWRAP_DBTXN() \+ DbTxn* dbtxn; \+ UNWRAP_DBTXN_()+ XmlManagerInfo::XmlManagerInfo() { pthread_mutexattr_t attr;@@ -122,8 +134,9 @@ } } -int _xmlManager_createTransaction_DbTxn(XmlManagerInfo* mgr, DbTxn* dbtxn, DbXml::XmlTransaction** trans)+int _xmlManager_createTransaction_DbTxn(XmlManagerInfo* mgr, DbTxn** dbtxnp, DbXml::XmlTransaction** trans) {+ UNWRAP_DBTXN(); try { XmlTransaction t = mgr->mgr.createTransaction(dbtxn); *trans = new XmlTransaction(t);@@ -186,6 +199,11 @@ char* str = new char[s.length()+1]; strcpy(str, s.c_str()); return str;+}++void _deleteString(char* str)+{+ delete[] str; } void _xmlDocument_delete(DbXml::XmlDocument* doc)
Database/Berkeley/dbxml_helper.h view
@@ -34,13 +34,14 @@ 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* dbtxn, DbXml::XmlTransaction** trans);+ int _xmlManager_createTransaction_DbTxn(XmlManagerInfo* mgr, DbTxn** dbtxnp, DbXml::XmlTransaction** trans); void _xmlTransaction_delete(DbXml::XmlTransaction* trans); int _xmlTransaction_commit(DbXml::XmlTransaction* trans); int _xmlTransaction_abort(DbXml::XmlTransaction* trans); int _xmlContainer_getDocument(DbXml::XmlContainer** cont, DbXml::XmlTransaction* trans, const char* key, u_int32_t flags, DbXml::XmlDocument** doc); char* _xmlContainer_getName(DbXml::XmlContainer** cont);+ void _deleteString(char* str); void _xmlDocument_delete(DbXml::XmlDocument* doc); int _xmlDocument_getContent(DbXml::XmlDocument* doc, char** str, int* length); int _xmlManager_createQueryContext(XmlManagerInfo* mgr, int rt, int ev, DbXml::XmlQueryContext** ctx);
README view
@@ -1,5 +1,5 @@ Berkeley DB / Berkeley DB XML binding for Haskell-Version 0.5 13 Dec 2008+Version 0.6 5 Jan 2009 by Stephen Blackheath email me: http://blacksapphire.com/antispam/@@ -23,20 +23,12 @@ serious application. If you would like a particular part of the API added, please contact me. -If you just want Berkeley DB without Berkeley DB XML, you can do this by deleting-the lines in BerkeleyDBXML.cabal that pertain to Berkeley DB XML. (The Berkeley DB-parts do not depend on the Berkeley DB XML parts.) I would like to make this a-build option.- To install, use the standard Cabal install procedure: sudo cabal install or -runhaskell Setup.hs configure-runhaskell Setup.hs build-runhaskell Setup.hs haddock (optional documentation in dist/doc) sudo runhaskell Setup.hs install If Berkeley DB or DB XML is not installed in the default location of /usr or
+ examples/adventure.hs view
@@ -0,0 +1,468 @@+-- | 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.Exception+import Control.Monad+import System.IO+import qualified Data.ByteString as B+import Data.List+import Data.Char+import Data.Maybe+import Prelude hiding (catch)++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+ )+ (\exc -> do+ hPutStrLn stderr $ "EXCEPTION "++show exc+ xmlTransaction_abort trans+ case fromException exc of+ Just (DbException _ DB_LOCK_DEADLOCK) | retryCount < 20 -> do+ hPutStrLn stderr "<<retry deadlocked thread>>"+ inTransaction_ mgr code (retryCount+1)+ otherwise -> throwIO exc)++toXML :: XmlPickler p => p -> IO String+toXML p = do+ mText <- liftM listToMaybe$ runX (+ constA p >>>+ xpickleVal (xpickle) >>>+ writeDocumentToString [(a_indent, v_0)]+ )+ case mText of+ Just text -> return text+ Nothing -> ioError (userError "pickle failed!")++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 []++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+ -> 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 <- 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+ 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 (toByteString 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 (toByteString 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+ if itemPortable i+ then do+ update db iDoc i {itemLocation = "player_"++name}+ return ["You pick up "++(itemDescription i)++"."]+ else+ return ["Hurrrrgh. No, it isn't portable."]++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+ 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 [DB_CREATE,DB_INIT_LOCK,DB_INIT_LOG,DB_INIT_MPOOL,+ DB_INIT_TXN,DB_THREAD,DB_RECOVER] 0 dbenv "."+ mgr <- xmlManager_create dbenv []+ cont <- xmlManager_openContainer mgr "adventure.dbxml"+ [DBXML_TRANSACTIONAL,DB_FLAG DB_THREAD,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)+ (\exc -> do+ hPutStrLn stderr $ show (exc::SomeException)+ hClose client)+
− examples/adventure/Adventure.hs
@@ -1,467 +0,0 @@--- | 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 qualified Data.ByteString as B-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 []--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- -> 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 <- 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- 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 (toByteString 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 (toByteString 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- if itemPortable i- then do- update db iDoc i {itemLocation = "player_"++name}- return ["You pick up "++(itemDescription i)++"."]- else- return ["Hurrrrgh. No, it isn't portable."]--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- 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_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
@@ -1,7 +0,0 @@-all: adventure--adventure: Adventure.hs- ghc -threaded --make -o $@ $<--clean:- rm -f adventure *.hi *.o
− examples/tests/Makefile
@@ -1,7 +0,0 @@-all: test1--test1: Test1.hs- ghc --make -o $@ $<--clean:- rm -f test1 *.o *.hi
− examples/tests/Test1.hs
@@ -1,242 +0,0 @@-module Main where--import System.Environment-import Database.Berkeley.Db-import Control.Monad-import qualified Data.ByteString as B-import Data.Char--toByteString :: String -> B.ByteString-toByteString = B.pack . map (fromIntegral . ord)--data Action = Read | Write | Fail deriving Eq--writeDb :: Db -> IO ()-writeDb db = do- forM_ testData$ \(country, capital) -> do- db_put db Nothing country (toByteString 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")]