persistent-map 0.2.2 → 0.3.3
raw patch · 7 files changed
+155/−88 lines, 7 filesdep +containersdep ~stm-io-hooks
Dependencies added: containers
Dependency ranges changed: stm-io-hooks
Files
- Data/HasKey.hs +18/−0
- Data/TMap.hs +78/−41
- Data/TMap/Backend.hs +2/−2
- Data/TMap/Backend/Binary.hs +33/−28
- Data/TStorage.hs +2/−4
- Sample.hs +7/−8
- persistent-map.cabal +15/−5
+ Data/HasKey.hs view
@@ -0,0 +1,18 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.HasKey+-- Copyright : Peter Robinson 2009+-- License : LGPL+--+-- Maintainer : Peter Robinson <thaldyron@gmail.com>+-- Stability : experimental+-- Portability : non-portable (requires STM)+--+-----------------------------------------------------------------------------++module Data.HasKey( HasKey(key) )+where++-- | Types where values have a key for indexing.+class HasKey a k | a -> k where+ key :: a -> k
Data/TMap.hs view
@@ -13,32 +13,35 @@ -- ----------------------------------------------------------------------------- -module Data.TMap( -- * TMap +module Data.TMap( -- * TMap Types TMap, + TFiniteMap, -- * Creating a new TMap newTMapIO, + newTFiniteMapIO, -- * Finite Map Interace lookup, insert, delete, member, adjust, - -- * Handling the size of the TMap + -- * Controlling the size of the TMap -- purgeTMap, purgeTMapIO, getMaximumSize, setMaximumSize, getCurrentSize,- -- * Flushing the backend+ -- * Backend Communication+ markAsDirty,+ tryMarkAsDirty, flushBackend, -- * Exception Type- TMapException(..),- )+ module Data.TMap.Exception,+ ) where import Control.Concurrent.AdvSTM import Control.Concurrent.AdvSTM.TVar--- import Control.Monad.CatchIO import Control.Monad( liftM, when ) import Control.Monad.Trans( MonadIO, liftIO ) @@ -48,9 +51,11 @@ import qualified Data.TMap.Backend as B import qualified Data.CacheStructure as C+import Data.CacheStructure.LRU(LRU) import Data.TMap.Exception( TMapException(..) ) import qualified Data.Edison.Assoc as M+import qualified Data.Edison.Assoc.StandardMap as FM --------------------------------------------------------------------------------@@ -69,14 +74,16 @@ fmap f (Entry a) = Entry (f a) fmap _ (Exc e) = Exc e --data TMap map k a b c = TMap - { backend :: B.Backend k a b => b k a+-- | The generic transactional map type.+data TMap map key val backendType cacheType = TMap + { backend :: {- B.Backend k a b => -} backendType key val , sizeTVar :: TVar (Maybe Int)- , tmapTVar :: (M.FiniteMapX map k, C.CacheStructure c k) - => TVar (map (Entry a),c k)+ , tmapTVar :: {- (M.FiniteMapX map k, C.CacheStructure c k) + => -} TVar (map (Entry val),cacheType key) } +-- | The standard library type 'Data.Map' repackaged as a 'TMap'.+type TFiniteMap key val backendType = TMap (FM.FM key) key val backendType LRU -------------------------------------------------------------------------------- @@ -85,19 +92,22 @@ -- -- @ -- import Data.TMap.Backend.Binary( BinaryBackend,mkBinaryBackend )--- import Data.TMap.CacheStructure.LRU+-- import Data.CacheStructure.LRU(LRU) -- @ -- -- will use a binary-serialization backend for persistent storage and a \"least recently--- used\" caching algorithm.+-- used\" caching algorithm. See 'newTFiniteMapIO' for a less generic construction method. -- -- Now, to create an unbounded map that uses the 'FM Int String' (see package EdisonCore) -- as the map type, you can write -- -- @ -- backend <- mkBinaryBackend \"myworkdir\" \"mytempdir\"--- tmap <- newTMapIO backend Nothing :: IO (TMap (FM Int) Int String BinaryBackend LRU)+-- tmap <- newTMapIO backend Nothing :: IO (TMap (FM.FM key) key val BinaryBackend LRU) -- @+--+-- Note that 'newTFiniteMapIO' provides an easier construction method.+-- See file /Sample.hs/ for further examples. newTMapIO :: (M.FiniteMapX map k, Ord k, B.Backend k a b,C.CacheStructure c k) => b k a -- ^ the backend -> Maybe Int -- ^ maximum-size: Use 'Nothing' for unbounded size.@@ -108,13 +118,21 @@ B.initialize b return $ TMap b tvarSize tvar ++-- | Creates an (unbounded) 'TFiniteMap'. +newTFiniteMapIO :: (Ord k, B.Backend k a b) + => b k a -- ^ the backend+ -> IO (TFiniteMap k a b)+newTFiniteMapIO b = newTMapIO b Nothing++ {- - Deactivated --- Can cause a non-terminating retry-loop when used with lookup k: - When key 'k' is not found lookup retries. (Cond 1) - But this causes the creation of the tmap to be rolled back too, and so - (Cond 1) holds forever.-newTMap :: (M.FiniteMapX map k, Ord k, B.Backend k a b, MonadAdvSTM m) - => b -> m (TMap map k a b)+newTMap :: (M.FiniteMapX map k, Ord k, B.Backend k a b, MonadAdvSTM stm) + => b -> stm (TMap map k a b) newTMap b = do tvar <- newTVar M.empty return $ TMap b tvar @@ -123,8 +141,8 @@ -- | Looks for a given key in the map and (if necessary) in the persistent storage -- and updates the map if necessary.-lookup :: (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 (Maybe a) +lookup :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b,C.CacheStructure c k)+ => k -> TMap map k a b c -> stm (Maybe a) lookup k tmap = do (themap,accSeq) <- readTVar (tmapTVar tmap) case M.lookupWithDefault NotInTMap k themap of@@ -143,7 +161,7 @@ -- print "Entry not in backend" atomically $ do (themap',accSeq') <- readTVar (tmapTVar tmap)- writeTVar (tmapTVar tmap) (M.insert k (NotInBackend) themap', accSeq')+ writeTVar (tmapTVar tmap) (M.insert k NotInBackend themap', accSeq') Just v -> do -- print "Found entry in backend" atomically $ do @@ -161,26 +179,26 @@ -- | 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-member k tmap = liftM isJust (lookup k tmap)+member :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b,C.CacheStructure c k) + => k -> TMap map k a b c -> stm Bool+member k = liftM isJust . lookup k -- | Adds a key-value mapping to the map. Can throw a 'DuplicateEntry' -- exception.-insert :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k) - => k -> a -> TMap map k a b c -> m () +insert :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b, C.CacheStructure c k) + => k -> a -> TMap map k a b c -> stm () insert k a tmap = do res <- lookup k tmap - when (isJust res) $ E.throw $ DuplicateEntry -- (show (k,v))+ 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.-adjust :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k) - => (a -> a) -> k -> TMap map k a b c -> m () +adjust :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b, C.CacheStructure c k) + => (a -> a) -> k -> TMap map k a b c -> stm () adjust f k tmap = do res <- lookup k tmap when (isNothing res) $ E.throw EntryNotFound @@ -190,8 +208,8 @@ -- | Removes a key from the map. Can throw an 'EntryNotFound' exception.-delete :: (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 () +delete :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b,C.CacheStructure c k) + => k -> TMap map k a b c -> stm () delete k tmap = do res <- lookup k tmap when (isNothing res) $ E.throw EntryNotFound @@ -204,9 +222,9 @@ -- | 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)/.-purgeTMapIO :: (M.FiniteMapX map k, MonadIO m, Ord k, B.Backend k a b, C.CacheStructure c k) - => TMap map k a b c -> m ()-purgeTMapIO tmap = liftIO . atomically $ purgeTMap tmap +purgeTMapIO :: (M.FiniteMapX map k, MonadIO io, Ord k, B.Backend k a b, C.CacheStructure c k) + => TMap map k a b c -> io ()+purgeTMapIO = liftIO . atomically . purgeTMap -- | Reduces the map to the appropriate size if the maximum size was exceeded.@@ -214,8 +232,8 @@ -- Runs in /O(1)/ if the map size is within bounds, otherwise /O(n)/. -- /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 () +purgeTMap :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b, C.CacheStructure c k) + => TMap map k a b c -> stm () purgeTMap tmap = do mSize <- readTVar (sizeTVar tmap) case mSize of@@ -233,34 +251,53 @@ -- | Sets the maximum size of the map. /O(1)/. Note that the size of the TMap needs -- to be reduced manually to the maximum size by calling /purgeTMap/.-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 :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b, C.CacheStructure c k) + => TMap map k a b c -> Int -> stm () setMaximumSize tmap maxSize | maxSize <= 0 = E.throw $ TMapDefaultExc "setMaximumSize: Invalid size specified." | otherwise = writeTVar (sizeTVar tmap) $ Just maxSize -- | Gets the maximum size of the map. /O(1)/.-getMaximumSize :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k) +getMaximumSize :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b, C.CacheStructure c k) => TMap map k a b c - -> m (Maybe Int)+ -> stm (Maybe Int) getMaximumSize tmap | otherwise = readTVar (sizeTVar tmap) -- | Gets the current size of the map. /O(1)/.-getCurrentSize :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k) +getCurrentSize :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b, C.CacheStructure c k) => TMap map k a b c - -> m Int+ -> stm Int getCurrentSize tmap = do (_,accSeq) <- readTVar (tmapTVar tmap) return $ C.size accSeq +-- | Causes the element to be reread from the backend on the next 'lookup'.+-- Throws an 'EntryNotFound' exception if the entry does not exist.+markAsDirty :: (M.FiniteMapX map k, Ord k, B.Backend k a b, C.CacheStructure c k) + => k -> TMap map k a b c -> IO ()+markAsDirty k tmap = atomically $ do+ res <- lookup k tmap + when (isNothing res) $ E.throw EntryNotFound + (themap,accSeq) <- readTVar (tmapTVar tmap)+ writeTVar (tmapTVar tmap) (M.insert k NotInTMap themap, accSeq)++-- | Causes the element to be reread from the backend on the next 'lookup'. Does+-- not throw an error when the element does not exist.+tryMarkAsDirty :: (M.FiniteMapX map k, Ord k, B.Backend k a b, C.CacheStructure c k) + => k -> TMap map k a b c -> IO ()+tryMarkAsDirty k tmap = + markAsDirty k tmap `E.catch` (\(e::TMapException) -> + if e == EntryNotFound then return ()+ else E.throw e)+ -------------------------------------------------------------------------------- -- | Sends a /B.flush/ request to the backend. Useful for asynchronous backend -- implementations. flushBackend :: (M.FiniteMapX map k, Ord k, B.Backend k a b, C.CacheStructure c k) => TMap map k a b c -> IO ()-flushBackend tmap = B.flush (backend tmap)+flushBackend = B.flush . backend
Data/TMap/Backend.hs view
@@ -9,8 +9,8 @@ -- Portability : non-portable (requires STM) -- -- Provides a type class for backends. To avoid data--- inconsistencies, these functmns should not be used directly but only by --- means of the TMap interface.+-- inconsistencies, these functions should not be used directly but only +-- via the TMap interface. -- -----------------------------------------------------------------------------
Data/TMap/Backend/Binary.hs view
@@ -23,8 +23,9 @@ import Control.Concurrent.AdvSTM.TVar import Control.Concurrent.AdvSTM.TMVar +import qualified Data.Map as M import Data.Binary-import Control.Monad(when)+import Control.Monad(when,unless) import Control.Exception import System.FilePath import System.Directory@@ -34,7 +35,7 @@ data BinaryBackend k a = BinaryBackend { workingDir :: FilePath , tempDir :: FilePath- , entryLock :: TVar (k -> TMVar ())+ , entryLockMap :: TVar (M.Map k (TMVar ())) } -- | Creates a new backend that stores one file per entry in the given working directory.@@ -43,45 +44,49 @@ mkBinaryBackend wd = do ex <- doesDirectoryExist wd tmp <- getTemporaryDirectory - when (not ex) $ throw (BackendException "mkBinaryBackend: Working directory does not exist.")+ unless ex $ throw (BackendException "mkBinaryBackend: Working directory does not exist.") when (wd==tmp) $ throw (BackendException "mkBinaryBackend: Cannot use the temporary directory as working directory.")- l <- newTMVarIO ()- eLock <- newTVarIO (\_ -> l)- return (BinaryBackend wd tmp eLock)+ eLocks <- newTVarIO M.empty+ return $ BinaryBackend wd tmp eLocks -withLockOnEntry :: BinaryBackend k a -> k -> IO c -> IO c+withLockOnEntry :: (Ord k) => BinaryBackend k a -> k -> IO c -> IO c withLockOnEntry b k m = do - eLocks <- atomically $ do - eLocks <- readTVar (entryLock b)- takeTMVar (eLocks k)- return eLocks+ atomically $ do + eLocks <- readTVar (entryLockMap b)+ tmvar <- case M.lookup k eLocks of+ Nothing -> do+ tmvar <- newTMVar ()+ eLock <- readTVar (entryLockMap b)+ writeTVar (entryLockMap b) $ M.insert k tmvar eLock+ return tmvar+ Just tmvar -> return tmvar+ takeTMVar tmvar res <- m- atomically $ putTMVar (eLocks k) ()+ atomically $ do + eLocks <- readTVar (entryLockMap b)+ putTMVar (M.findWithDefault throwExc k eLocks) () return res+ where + throwExc = throw $ BackendException "withLockOnEntry: Entry not found!" -------------------------------------------------------------------------------- instance (Show k,Ord k,Binary a) => Backend k a BinaryBackend where insert b k a = do - let fp = workingDir b </> (show k)+ let fp = workingDir b </> show k exDir <- doesDirectoryExist (workingDir b)- when (not exDir) $ throw (BackendException "insert: Directory doesn't exist!")+ unless exDir $ throw (BackendException "insert: Directory doesn't exist!") ex <- doesFileExist fp when ex $ throw $ BackendException "insert: Entry already exists!"- l <- newTMVarIO ()- atomically $ do - eLock <- readTVar (entryLock b)- writeTVar (entryLock b) (\k' -> if k'==k then l- else eLock k') withLockOnEntry b k $ encodeFile fp a lookup b k = do - let fp = workingDir b </> (show k)+ let fp = workingDir b </> show k exDir <- doesDirectoryExist (workingDir b)- when (not exDir) $ throw (BackendException "lookup: Directory doesn't exist!")+ unless exDir $ throw (BackendException "lookup: Directory doesn't exist!") exFile <- doesFileExist fp if not exFile then return Nothing@@ -89,19 +94,19 @@ res <- withLockOnEntry b k $ decodeFile fp return (Just $! res) - delete b k = do - withLockOnEntry b k $ removeFile (workingDir b </> (show k))+ delete b k = + withLockOnEntry b k $ removeFile (workingDir b </> show k) adjust b f k = do- let fp = workingDir b </> (show k)- let tmp = tempDir b </> (show k)+ 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!")+ unless exDir $ throw (BackendException "adjust: Directory doesn't exist!") ex <- doesFileExist fp- when (not ex) $ throw (BackendException "adjust: Did not find entry in backend.")+ unless 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+ renameFile tmp fp
Data/TStorage.hs view
@@ -18,7 +18,6 @@ ----------------------------------------------------------------------------- module Data.TStorage( TMap,- HasKey(..), newTMapIO, add, tryComplete,@@ -28,6 +27,7 @@ apply, -- purgeTMap, purgeTMapIO,+ HasKey(key), ) where@@ -41,10 +41,8 @@ import qualified Data.Edison.Assoc as M import Data.TMap+import Data.HasKey(HasKey(key)) --- | Instantiated by types where values have a unique key. -class HasKey a k | a -> k where- key :: a -> k -- | Adds a new element to the map. The key is automatically deduced by the -- 'HasKey' instantiation.
Sample.hs view
@@ -5,15 +5,15 @@ import Data.TStorage import Data.TMap import Data.TMap.Backend.Binary-import qualified Data.CacheStructure.LRU as C+--import qualified Data.CacheStructure.LRU as C import Control.Concurrent.AdvSTM import qualified Control.Exception as Exc-import qualified Data.Edison.Assoc.StandardMap as M+--import qualified Data.Edison.Assoc.StandardMap as M import Data.Data import Data.Typeable import Data.Binary import Prelude hiding( lookup )-import System.Directory+--import System.Directory data Sometype = Sometype { theid :: Int, name :: String } deriving (Show,Eq,Ord,Data,Typeable)@@ -33,8 +33,8 @@ -- Let's create a TMap that uses the binary-serialization backend: backend <- mkBinaryBackend "test" -- removeDirectory "/home/thaldyron/var/test"- tmap <- newTMapIO backend (Just 4) - :: IO (TMap (M.FM Int) Int Sometype BinaryBackend C.LRU)+ tmap <- newTFiniteMapIO backend + :: IO (TFiniteMap Int Sometype BinaryBackend) -- First let's use the low level TMap interface: res <- atomically $ (do@@ -67,7 +67,7 @@ test = do backend <- mkBinaryBackend "test2" tmap <- newTMapIO backend (Just 4) - :: IO (TMap (M.FM Int) Int String BinaryBackend C.LRU)+ :: IO (TFiniteMap Int String BinaryBackend) atomically $ do isMemb <- member 1 tmap when (not isMemb) $ do@@ -80,5 +80,4 @@ Just v' -> do adjust (\_ -> "jd") 1 tmap onCommit $ print v'- -+
persistent-map.cabal view
@@ -1,7 +1,14 @@ Name: persistent-map Synopsis: A thread-safe interface for finite map types with optional persistency support. Description:-+ /Changes in 0.3.*:/+ .+ * Added the 'TFiniteMap' type to make type construction more convenient.+ .+ * Added 'markAsDirty'. + .+ * Fixed data corruption issues with 'Backend.Binary'.+ . /Changes in 0.2.*:/ . * Improved error handling. Backend lookup-exceptions are now rethrown in the@@ -67,7 +74,7 @@ Maintainer: Peter Robinson <thaldyron@gmail.com> License: LGPL License-file: LICENSE-Version: 0.2.2+Version: 0.3.3 Category: Middleware, Concurrency Stability: experimental Homepage: http://darcs.monoid.at/persistent-map@@ -85,6 +92,7 @@ Data.TMap.Backend.StdoutBackend Data.CacheStructure Data.CacheStructure.LRU+ Data.HasKey other-modules: Sample Data.TMap.Exception@@ -93,12 +101,13 @@ EdisonAPI >= 1.2.1 && < 1.3, LRU >= 0.1.1 && < 0.2, EdisonCore >= 1.2.1.3 && < 1.3,- stm-io-hooks >= 0.3.0 && < 0.4, + stm-io-hooks >= 0.4.0 && < 0.5, -- HDBC >= 2.0 && < 2.1, mtl >= 1.1.0.2 && < 1.2, binary >= 0.5 && < 0.6, filepath >= 1.1 && < 1.2,- directory >= 1.0.0.3 && < 1.1+ directory >= 1.0.0.3 && < 1.1,+ containers >= 0.2.0.1 && < 0.3 extensions: MultiParamTypeClasses, RankNTypes, @@ -107,5 +116,6 @@ FlexibleInstances, UndecidableInstances, DeriveDataTypeable,- ScopedTypeVariables+ ScopedTypeVariables,+ TypeSynonymInstances