diff --git a/BerkeleyDBXML.cabal b/BerkeleyDBXML.cabal --- a/BerkeleyDBXML.cabal +++ b/BerkeleyDBXML.cabal @@ -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: . @@ -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++ diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -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. diff --git a/Database/Berkeley/Db.hs b/Database/Berkeley/Db.hs deleted file mode 100644 --- a/Database/Berkeley/Db.hs +++ /dev/null @@ -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 () - diff --git a/Database/Berkeley/DbXml.hs b/Database/Berkeley/DbXml.hs --- a/Database/Berkeley/DbXml.hs +++ b/Database/Berkeley/DbXml.hs @@ -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 diff --git a/Database/Berkeley/Util.hs b/Database/Berkeley/Util.hs deleted file mode 100644 --- a/Database/Berkeley/Util.hs +++ /dev/null @@ -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 diff --git a/Database/Berkeley/db_helper.cpp b/Database/Berkeley/db_helper.cpp deleted file mode 100644 --- a/Database/Berkeley/db_helper.cpp +++ /dev/null @@ -1,338 +0,0 @@ -#include "db_helper.h" - -#include -#include - -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(); - } -} - diff --git a/Database/Berkeley/db_helper.h b/Database/Berkeley/db_helper.h deleted file mode 100644 --- a/Database/Berkeley/db_helper.h +++ /dev/null @@ -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 - diff --git a/Database/Berkeley/dbxml_helper.cpp b/Database/Berkeley/dbxml_helper.cpp --- a/Database/Berkeley/dbxml_helper.cpp +++ b/Database/Berkeley/dbxml_helper.cpp @@ -8,6 +8,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) diff --git a/Database/Berkeley/dbxml_helper.h b/Database/Berkeley/dbxml_helper.h --- a/Database/Berkeley/dbxml_helper.h +++ b/Database/Berkeley/dbxml_helper.h @@ -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); diff --git a/README b/README --- a/README +++ b/README @@ -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 diff --git a/examples/adventure.hs b/examples/adventure.hs new file mode 100644 --- /dev/null +++ b/examples/adventure.hs @@ -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 "<>" + 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 ", + " drop ", + " inventory", + " look", + " north, east, west, south, up, down", + " quit" + ] + +process :: (XmlManager, XmlContainer, XmlTransaction) -> String -> String -> IO [String] +process db name cmd = do + case words cmd of + [] -> return [] + (verb:nouns) -> case (verb, unwords nouns) of + ("look", _) -> look db name + ("quit", _) -> fail "User typed 'quit'" + (dir, _) | dir `elem` ["north", "east", "west", "south", "up", "down"] -> + go db name dir + ("get", noun) -> get db name noun + ("inventory", _) -> inventory db name + ("drop", noun) -> Main.drop db name noun + ("help", _) -> return help + otherwise -> return ["I don't understand that."] + +session :: XmlManager -> XmlContainer -> Handle -> IO () +session mgr cont h = do + initGame mgr cont + hPutStrLn h "Welcome to 'DB/XML Haskell binding' adventure by Stephen Blackheath" + hPutStrLn h "Please enter your name." + name <- prompt h + created <- inTransaction mgr$ \trans -> do + let db = (mgr, cont, trans) + mPlayer <- liftM listToMaybe$ query db xpPlayer "collection()/player[@name=$name]" + [("name", xmlString name)] + (created, player) <- case mPlayer of + Just player -> + return (False, player) + Nothing -> do + let player = Player name "beach" + create db player + return (True, player) + -- We create an item for the player to make it so other players can see them. + putPlayer db name (playerLocation player) + return created + if created + then hPutStrLn h$ "Welcome for the first time, "++name++"." + else hPutStrLn h$ "Welcome back, "++name++"." + hPutStrLn h$ "" + hPutStrLn h$ "For help, please type \"help\"." + hPutStrLn h$ "" + + mapM_ (hPutStrLn h) =<< inTransaction mgr (\trans -> do + let db = (mgr, cont, trans) + look db name + ) + catch ( + forever$ do + cmd <- prompt h + mapM_ (hPutStrLn h) =<< inTransaction mgr (\trans -> do + let db = (mgr, cont, trans) + process db name cmd + ) + ) + (\err -> do + hPutStrLn h$ "Bye!" + inTransaction mgr$ \trans -> do + let db = (mgr, cont, trans) + deletePlayer db name + ioError err) + +deleteCadavers :: (XmlManager, XmlContainer, XmlTransaction) -> IO () +deleteCadavers db@(mgr, cont, trans) = do + cadavers <- queryUpdate db xpItem "collection()/item[substring(@key,1,7)='player_']" [] + hPutStrLn stderr$ "tidying up " ++ (show$ length cadavers) ++ " cadavers" + forM_ cadavers$ \(doc, p) -> do + uctx <- xmlManager_createUpdateContext mgr + xmlContainer_deleteDocument cont (Just trans) doc uctx + +main = do + let portNo = 1888 + server <- listenOn (PortNumber portNo) + + dbenv <- dbEnv_create [] + + -- Enable automatic deadlock detection. Deadlock detection is required for + -- multi-threaded applications. Deadlock detection must be started on only + -- one process in a Berkeley DB environment. + dbEnv_set_lk_detect dbenv DB_LOCK_DEFAULT + + -- Note that we are doing DB_RECOVER here. This should always be done before + -- running the application but must be done with no other processes using the + -- environment at the same time. + dbEnv_open [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) + diff --git a/examples/adventure/Adventure.hs b/examples/adventure/Adventure.hs deleted file mode 100644 --- a/examples/adventure/Adventure.hs +++ /dev/null @@ -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 "<>" - 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 ", - " drop ", - " inventory", - " look", - " north, east, west, south, up, down", - " quit" - ] - -process :: (XmlManager, XmlContainer, XmlTransaction) -> String -> String -> IO [String] -process db name cmd = do - case words cmd of - [] -> return [] - (verb:nouns) -> case (verb, unwords nouns) of - ("look", _) -> look db name - ("quit", _) -> fail "User typed 'quit'" - (dir, _) | dir `elem` ["north", "east", "west", "south", "up", "down"] -> - go db name dir - ("get", noun) -> get db name noun - ("inventory", _) -> inventory db name - ("drop", noun) -> Main.drop db name noun - ("help", _) -> return help - otherwise -> return ["I don't understand that."] - -session :: XmlManager -> XmlContainer -> Handle -> IO () -session mgr cont h = do - initGame mgr cont - hPutStrLn h "Welcome to 'DB/XML Haskell binding' adventure by Stephen Blackheath" - hPutStrLn h "Please enter your name." - name <- prompt h - created <- inTransaction mgr$ \trans -> do - let db = (mgr, cont, trans) - mPlayer <- liftM listToMaybe$ query db xpPlayer "collection()/player[@name=$name]" - [("name", xmlString name)] - (created, player) <- case mPlayer of - Just player -> - return (False, player) - Nothing -> do - let player = Player name "beach" - create db player - return (True, player) - -- We create an item for the player to make it so other players can see them. - putPlayer db name (playerLocation player) - return created - if created - then hPutStrLn h$ "Welcome for the first time, "++name++"." - else hPutStrLn h$ "Welcome back, "++name++"." - hPutStrLn h$ "" - hPutStrLn h$ "For help, please type \"help\"." - hPutStrLn h$ "" - - mapM_ (hPutStrLn h) =<< inTransaction mgr (\trans -> do - let db = (mgr, cont, trans) - look db name - ) - catch ( - forever$ do - cmd <- prompt h - mapM_ (hPutStrLn h) =<< inTransaction mgr (\trans -> do - let db = (mgr, cont, trans) - process db name cmd - ) - ) - (\err -> do - hPutStrLn h$ "Bye!" - inTransaction mgr$ \trans -> do - let db = (mgr, cont, trans) - deletePlayer db name - ioError err) - -deleteCadavers :: (XmlManager, XmlContainer, XmlTransaction) -> IO () -deleteCadavers db@(mgr, cont, trans) = do - cadavers <- queryUpdate db xpItem "collection()/item[substring(@key,1,7)='player_']" [] - hPutStrLn stderr$ "tidying up " ++ (show$ length cadavers) ++ " cadavers" - forM_ cadavers$ \(doc, p) -> do - uctx <- xmlManager_createUpdateContext mgr - xmlContainer_deleteDocument cont (Just trans) doc uctx - -main = do - let portNo = 1888 - server <- listenOn (PortNumber portNo) - - dbenv <- dbEnv_create [] - - -- Enable automatic deadlock detection. Deadlock detection is required for - -- multi-threaded applications. Deadlock detection must be started on only - -- one process in a Berkeley DB environment. - dbEnv_set_lk_detect dbenv DB_LOCK_DEFAULT - - -- Note that we are doing DB_RECOVER here. This should always be done before - -- running the application but must be done with no other processes using the - -- environment at the same time. - dbEnv_open dbenv "." [DB_CREATE,DB_INIT_LOCK,DB_INIT_LOG,DB_INIT_MPOOL, - DB_INIT_TXN,DB_THREAD,DB_RECOVER] 0 - mgr <- xmlManager_create dbenv [] - cont <- xmlManager_openContainer mgr "adventure.dbxml" - [DBXML_TRANSACTIONAL,DB_FLAG DB_THREAD,DB_FLAG DB_CREATE] - WholedocContainer 0 - - putStrLn$ "Adventure server - please telnet into port "++show portNo - - inTransaction mgr$ \trans -> do - let db = (mgr, cont, trans) - deleteCadavers db - - forever$ do - (client, host, port) <- accept server - forkIO$ do - catch - (session mgr cont client >> hClose client) - (\err -> do - hPutStrLn stderr (show err) - hClose client) - diff --git a/examples/adventure/Makefile b/examples/adventure/Makefile deleted file mode 100644 --- a/examples/adventure/Makefile +++ /dev/null @@ -1,7 +0,0 @@ -all: adventure - -adventure: Adventure.hs - ghc -threaded --make -o $@ $< - -clean: - rm -f adventure *.hi *.o diff --git a/examples/tests/Makefile b/examples/tests/Makefile deleted file mode 100644 --- a/examples/tests/Makefile +++ /dev/null @@ -1,7 +0,0 @@ -all: test1 - -test1: Test1.hs - ghc --make -o $@ $< - -clean: - rm -f test1 *.o *.hi diff --git a/examples/tests/Test1.hs b/examples/tests/Test1.hs deleted file mode 100644 --- a/examples/tests/Test1.hs +++ /dev/null @@ -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")]