diff --git a/Data/TMap.hs b/Data/TMap.hs --- a/Data/TMap.hs +++ b/Data/TMap.hs @@ -24,7 +24,7 @@ member, adjust, -- * Handling the size of the TMap - purgeTMap, +-- purgeTMap, purgeTMapIO, getMaximumSize, setMaximumSize, @@ -42,8 +42,8 @@ import Control.Monad( liftM, when ) import Control.Monad.Trans( MonadIO, liftIO ) -import qualified Control.Exception as Exc -import Data.Maybe( isJust ) +import qualified Control.Exception as E +import Data.Maybe( isJust, isNothing ) import Prelude hiding (lookup,catch) import qualified Data.TMap.Backend as B @@ -59,12 +59,15 @@ data Entry a = Entry a -- ^ Cache hit | NotInTMap -- ^ Cache miss | NotInBackend -- ^ Element exists neither in backend nor in cache - deriving (Show,Eq) + | Exc E.SomeException -- ^ An exception occurred in the retry IO action + deriving (Show) + instance Functor Entry where fmap _ NotInBackend = NotInBackend fmap _ NotInTMap = NotInTMap fmap f (Entry a) = Entry (f a) + fmap _ (Exc e) = Exc e data TMap map k a b c = TMap @@ -131,8 +134,9 @@ -- onCommit $ print ("NewAccess List: ",C.toList $ C.hit k accSeq) return $ Just v NotInBackend -> return Nothing - NotInTMap -> retryWith $ do --- print $ "Lookup: Didn't find " ++ show k ++ ", retrying lookup..." + Exc e -> E.throw e + NotInTMap -> retryWith $ E.handle onExc $ do +-- print $ "Lookup: Didn't find key retrying lookup..." result <- B.lookup (backend tmap) k case result of Nothing -> do @@ -147,7 +151,15 @@ writeTVar (tmapTVar tmap) ( M.insert k (Entry v) themap' , C.hit k accSeq') -- onCommit $ print ("Access List: ",C.toList $ C.hit k accSeq') + where + -- Sends backend exceptions back to the STM monad: + onExc (e::E.SomeException) = do + -- print "BACKEND EXCEPTION!" + atomically $ do + (themap',accSeq') <- readTVar (tmapTVar tmap) + writeTVar (tmapTVar tmap) (M.insert k (Exc e) themap', accSeq') + -- | Checks whether the given key is in the map. member :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b,C.CacheStructure c k) => k -> TMap map k a b c -> m Bool @@ -160,13 +172,10 @@ => k -> a -> TMap map k a b c -> m () insert k a tmap = do res <- lookup k tmap - case res of - Just _ -> Exc.throw $ DuplicateEntry -- (show (k,v)) - Nothing -> do - (themap,accSeq) <- readTVar (tmapTVar tmap) - writeTVar (tmapTVar tmap) ( M.insert k (Entry a) themap - , C.hit k accSeq) - onCommit $ B.insert (backend tmap) k a + when (isJust res) $ E.throw $ DuplicateEntry -- (show (k,v)) + (themap,accSeq) <- readTVar (tmapTVar tmap) + writeTVar (tmapTVar tmap) (M.insert k (Entry a) themap, C.hit k accSeq) + onCommit $ B.insert (backend tmap) k a -- | Applies a function to the element identified by the key. Can throw an 'EntryNotFound' exception. @@ -174,12 +183,10 @@ => (a -> a) -> k -> TMap map k a b c -> m () adjust f k tmap = do res <- lookup k tmap - case res of - Nothing -> Exc.throw EntryNotFound - Just _ -> do - (themap,accSeq) <- readTVar (tmapTVar tmap) - writeTVar (tmapTVar tmap) (M.adjust (fmap f) k themap, C.hit k accSeq) - onCommit $ B.adjust (backend tmap) f k + when (isNothing res) $ E.throw EntryNotFound + (themap,accSeq) <- readTVar (tmapTVar tmap) + writeTVar (tmapTVar tmap) (M.adjust (fmap f) k themap, C.hit k accSeq) + onCommit $ B.adjust (backend tmap) f k -- | Removes a key from the map. Can throw an 'EntryNotFound' exception. @@ -187,12 +194,10 @@ => k -> TMap map k a b c -> m () delete k tmap = do res <- lookup k tmap - case res of - Nothing -> Exc.throw EntryNotFound - Just _ -> do - (themap,accSeq) <- readTVar (tmapTVar tmap) - writeTVar (tmapTVar tmap) (M.insert k NotInBackend themap, accSeq) - onCommit $ B.delete (backend tmap) k + when (isNothing res) $ E.throw EntryNotFound + (themap,accSeq) <- readTVar (tmapTVar tmap) + writeTVar (tmapTVar tmap) (M.insert k NotInBackend themap, accSeq) + onCommit $ B.delete (backend tmap) k -------------------------------------------------------------------------------- @@ -207,7 +212,7 @@ -- | Reduces the map to the appropriate size if the maximum size was exceeded. -- Calls /Data.TMap.Backend.flush/ if the map is purged. -- Runs in /O(1)/ if the map size is within bounds, otherwise /O(n)/. --- /Warning:/ This function should always be called at the end of a transaction to +-- /Warning:/ This function should only be called at the end of a transaction to -- prevent nonterminating retry-loops! purgeTMap :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k) => TMap map k a b c -> m () @@ -231,7 +236,7 @@ setMaximumSize :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k) => TMap map k a b c -> Int -> m () setMaximumSize tmap maxSize - | maxSize <= 0 = Exc.throw $ TMapDefaultExc "setMaximumSize: Invalid size specified." + | maxSize <= 0 = E.throw $ TMapDefaultExc "setMaximumSize: Invalid size specified." | otherwise = writeTVar (sizeTVar tmap) $ Just maxSize -- | Gets the maximum size of the map. /O(1)/. diff --git a/Data/TMap/Backend/Binary.hs b/Data/TMap/Backend/Binary.hs --- a/Data/TMap/Backend/Binary.hs +++ b/Data/TMap/Backend/Binary.hs @@ -8,7 +8,7 @@ -- Stability : experimental -- Portability : non-portable (requires STM) -- --- Proivides a (simplistic) backend using the binary package. +-- Proivides a (very simplistic) backend using the binary package. -- Every entry of the map is written to a separate file where the filename -- is the key. -- @@ -67,6 +67,8 @@ insert b k a = do let fp = workingDir b (show k) + exDir <- doesDirectoryExist (workingDir b) + when (not exDir) $ throw (BackendException "insert: Directory doesn't exist!") ex <- doesFileExist fp when ex $ throw $ BackendException "insert: Entry already exists!" l <- newTMVarIO () @@ -78,8 +80,10 @@ lookup b k = do let fp = workingDir b (show k) - ex <- doesFileExist fp - if not ex + exDir <- doesDirectoryExist (workingDir b) + when (not exDir) $ throw (BackendException "lookup: Directory doesn't exist!") + exFile <- doesFileExist fp + if not exFile then return Nothing else do res <- withLockOnEntry b k $ decodeFile fp @@ -91,9 +95,13 @@ adjust b f k = do let fp = workingDir b (show k) let tmp = tempDir b (show k) + exDir <- doesDirectoryExist (workingDir b) + when (not exDir) $ throw (BackendException "adjust: Directory doesn't exist!") ex <- doesFileExist fp when (not ex) $ throw (BackendException "adjust: Did not find entry in backend.") withLockOnEntry b k $ do a <- (decodeFile fp :: IO a) encodeFile tmp (f a) renameFile tmp fp + + diff --git a/Data/TStorage.hs b/Data/TStorage.hs --- a/Data/TStorage.hs +++ b/Data/TStorage.hs @@ -26,7 +26,7 @@ remove, removeByKey, apply, - purgeTMap, +-- purgeTMap, purgeTMapIO, ) diff --git a/Sample.hs b/Sample.hs --- a/Sample.hs +++ b/Sample.hs @@ -13,6 +13,7 @@ import Data.Typeable import Data.Binary import Prelude hiding( lookup ) +import System.Directory data Sometype = Sometype { theid :: Int, name :: String } deriving (Show,Eq,Ord,Data,Typeable) @@ -30,7 +31,8 @@ sample = Exc.handle (\(e::Exc.SomeException) -> print e) $ do -- Let's create a TMap that uses the binary-serialization backend: - backend <- mkBinaryBackend "/home/thaldyron/var/test" + backend <- mkBinaryBackend "test" +-- removeDirectory "/home/thaldyron/var/test" tmap <- newTMapIO backend (Just 4) :: IO (TMap (M.FM Int) Int Sometype BinaryBackend C.LRU) @@ -46,9 +48,10 @@ delete 2 tmap lookup 2 tmap) -- Catch duplicate-inserts exceptions: - `catchSTM` (\(e::TMapException) -> if e==DuplicateEntry then return Nothing - else throw e) - atomically $ purgeTMap tmap + `catchSTM` (\(e::TMapException) -> + if e==DuplicateEntry then return Nothing + else throw (AssertionFailed (show e))) + purgeTMapIO tmap print ("Result1: ",res) -- Let's try the high-level TStorage interface: @@ -62,7 +65,7 @@ test :: IO () test = do - backend <- mkBinaryBackend "/home/thaldyron/var/test2" + backend <- mkBinaryBackend "test2" tmap <- newTMapIO backend (Just 4) :: IO (TMap (M.FM Int) Int String BinaryBackend C.LRU) atomically $ do diff --git a/persistent-map.cabal b/persistent-map.cabal --- a/persistent-map.cabal +++ b/persistent-map.cabal @@ -2,6 +2,11 @@ Synopsis: A thread-safe interface for finite map types with optional persistency support. Description: + /Changes in 0.2.*:/ + . + * Improved error handling. Backend lookup-exceptions are now rethrown in the + AdvSTM monad. + . /Changes in 0.1.*:/ . * Added the binary serialization backend. @@ -42,7 +47,7 @@ to the list of retry-IO actions. (This is done using the 'retryWith' IO hook of the stm-io-package.) . - If the value does not exist yet, function 'insert' adds the key-value mapping to the + If the value does not yet exist, function 'insert' adds the key-value mapping to the TMap and sends an insert-request to the backend using the 'onCommit' hook of the stm-io-package. Note that 'onCommit' guarantees that the backend IO action is only executed iff the transaction commits. Any @@ -58,11 +63,11 @@ /Warning:/ This package is very experimental and the interface will probably change. -Author: Peter Robinson +Author: Peter Robinson 2009 Maintainer: Peter Robinson License: LGPL License-file: LICENSE -Version: 0.1.1 +Version: 0.2.2 Category: Middleware, Concurrency Stability: experimental Homepage: http://darcs.monoid.at/persistent-map