packages feed

persistent-map 0.0.0 → 0.1.0

raw patch · 9 files changed

+197/−59 lines, 9 filesdep +binarydep +directorydep +filepathdep ~stm-io-hooks

Dependencies added: binary, directory, filepath

Dependency ranges changed: stm-io-hooks

Files

Data/TMap.hs view
@@ -81,18 +81,19 @@ -- the caching policy, e.g., -- -- @---   import Data.TMap.Backend.StdoutBackend( newStdoutBackend )+--   import Data.TMap.Backend.Binary( BinaryBackend,mkBinaryBackend ) --   import Data.TMap.CacheStructure.LRU -- @ ----- will simply log all backend operations to Stdout and use a \"least recently--- used\" cache algorithm.+-- will use a binary-serialization backend for persistent storage and a \"least recently+-- used\" caching algorithm. -- -- Now, to create an unbounded map that uses the 'FM Int String' (see package EdisonCore)  -- as the map type, you can write -- -- @---   tmap = newTMapIO newStdoutBackend Nothing :: IO (TMap (FM Int) Int String StdoutBackend LRU)+--   backend <- mkBinaryBackend \"myworkdir\" \"mytempdir\"+--   tmap <- newTMapIO backend Nothing :: IO (TMap (FM Int) Int String BinaryBackend LRU) -- @ newTMapIO :: (M.FiniteMapX map k, Ord k, B.Backend k a b,C.CacheStructure c k)            => b k a            -- ^ the backend@@ -254,7 +255,7 @@  -- | Sends a /B.flush/ request to the backend. Useful for asynchronous backend -- implementations.-flushBackend :: (M.FiniteMapX map k, MonadIO m, Ord k, B.Backend k a b, C.CacheStructure c k) -             => TMap map k a b c -> m ()+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)
Data/TMap/Backend.hs view
@@ -8,39 +8,48 @@ -- Stability   :  experimental -- Portability :  non-portable (requires STM) ----- Provides a type class for backend instantiations. To avoid data--- inconsistencies, these functions should not be used directly but only by +-- 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. -- -----------------------------------------------------------------------------  module Data.TMap.Backend( Backend(..) ) where-import Control.Monad.Trans( MonadIO )+import Prelude hiding(lookup)  -- | This class needs to be instantiated when developing a new -- backend. The backend is expected to be able to handle concurrent -- (non-conflicting) requests.-class Backend k a b | a -> k where+class Ord k => Backend k a b | a -> k where      -- | Called when a new element was inserted.-    insert     :: MonadIO m => b k a -> k -> a -> m ()+    insert     :: b k a -> k -> a -> IO ()      -- | Called when an element was updated.-    adjust     :: MonadIO m => b k a-> (a -> a) -> k -> m ()+    adjust     :: b k a-> (a -> a) -> k -> IO ()          -- | Called when an element was deleted from the map.-    delete     :: MonadIO m => b k a-> k -> m ()+    delete     :: b k a-> k -> IO ()          -- | Called when an element is not found in the map. -    lookup     :: MonadIO m => b k a -> k -> m (Maybe a)+    lookup     :: b k a -> k -> IO (Maybe a)      -- | Called by /flushBackend/ and /purgeTMap/.-    flush      :: MonadIO m => b k a -> m ()+    flush      :: b k a -> IO ()      -- | Called in 'newTMapIO' -    initialize :: MonadIO m => b k a -> m ()+    initialize :: b k a -> IO ()      flush      _ = return ()     initialize _ = return () +{-+instance Backend k a b IO where+  insert b k a = liftIO (insert b k a)+  adjust b f k = liftIO (adjust b f k)+  delete b k   = liftIO (delete b k)+  lookup b k   = liftIO (lookup b k)+  flush        = liftIO . flush+  initialize   = liftIO . initialize+-}
+ Data/TMap/Backend/Binary.hs view
@@ -0,0 +1,99 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.TMap.Backend.Binary+-- Copyright   :  Peter Robinson 2009+-- License     :  LGPL+--+-- Maintainer  :  Peter Robinson <thaldyron@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-- Proivides a (simplistic) backend using the binary package.+-- Every entry of the map is written to a separate file where the filename+-- is the key. +--+-- Note: This interface is only thread-safe when being used via TMap!+--+-----------------------------------------------------------------------------+module Data.TMap.Backend.Binary( mkBinaryBackend, BinaryBackend)+where+import Data.TMap.Backend+import Data.TMap.Exception+import Control.Concurrent.AdvSTM+import Control.Concurrent.AdvSTM.TVar+import Control.Concurrent.AdvSTM.TMVar ++import Data.Binary+import Control.Monad(when)+import Control.Exception+import System.FilePath+import System.Directory+import Prelude hiding(lookup,catch)++-- | The binary-backend type+data BinaryBackend k a = BinaryBackend+  { workingDir :: FilePath +  , tempDir    :: FilePath+  , entryLock :: TVar (k -> TMVar ())+  }++-- | Creates a new backend that stores one file per entry in the given working directory.+mkBinaryBackend :: FilePath  +                -> IO (BinaryBackend k a)+mkBinaryBackend wd = do +  ex  <- doesDirectoryExist wd+  tmp <- getTemporaryDirectory +  when (not 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)+++withLockOnEntry :: 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+  res <- m+  atomically $ putTMVar (eLocks k) ()+  return res++--------------------------------------------------------------------------------++instance (Show k,Ord k,Binary a) => Backend k a BinaryBackend where++  insert b k a = do +    let fp = workingDir b </> (show k)+    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)+    ex <- doesFileExist fp+    if not ex+      then return Nothing+      else do+        res <- withLockOnEntry b k $ decodeFile fp+        return (Just $! res) ++  delete b k = do +    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)+    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
Data/TMap/Backend/NoBackend.hs view
@@ -18,7 +18,7 @@  data NoBackend k a = NoBackend -instance Backend k a NoBackend where+instance (Ord k) => Backend k a NoBackend where   insert _ _ _ = return ()   adjust _ _ _ = return ()   lookup _ _   = return Nothing
Data/TMap/Backend/StdoutBackend.hs view
@@ -20,7 +20,7 @@  data StdoutBackend k a = StdoutBackend -instance (Show a,Show k) => Backend k a StdoutBackend where+instance (Show a,Show k,Ord k) => Backend k a StdoutBackend where     insert _ _ a = liftIO (print ("inserting: ",a)) >> return ()     adjust _ _ k = liftIO (print ("adjusting: ",k)) >> return ()     lookup _ k   = liftIO (print ("looking up: ",k)) >> return Nothing
Data/TMap/Exception.hs view
@@ -19,7 +19,7 @@  data TMapException = DuplicateEntry                     | EntryNotFound -                   | TMapNotFound +--                   | TMapNotFound                     | TMapDefaultExc String                    | BackendException String                    deriving (Show,Eq,Typeable)
Data/TStorage.hs view
@@ -24,7 +24,7 @@                       tryComplete,                       complete,                       remove,-                      removeKey,+                      removeByKey,                       apply,                       purgeTMap,                       purgeTMapIO,@@ -48,46 +48,46 @@  -- | Adds a new element to the map. The key is automatically deduced by the -- 'HasKey' instantiation.-add :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k+add :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b, C.CacheStructure c k        , HasKey a k) -    => a -> TMap map k a b c -> m () +    => a -> TMap map k a b c -> stm ()  add a = insert (key a) a   -- | Tries to fill a partially initialized value with data from the TMap. Returns -- 'Nothing' if the TMap does not contain a corresponding entry. -tryComplete :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k+tryComplete :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k,B.Backend k a b, C.CacheStructure c k                , HasKey a k) -            => a -> TMap map k a b c -> m (Maybe a)+            => a -> TMap map k a b c -> stm (Maybe a) tryComplete a = lookup (key a)  -- | Fills a partially initialized value with data from the TMap. Throws--- a 'TMapNotFound' exception if there is no corresponding entry.-complete :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k+-- an 'EntryNotFound' exception if there is no corresponding entry.+complete :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b, C.CacheStructure c k             , HasKey a k) -         => a -> TMap map k a b c -> m a+         => a -> TMap map k a b c -> stm a complete a tmap = do   mval <- tryComplete a tmap   case mval of     Just val -> return val-    Nothing  -> throw TMapNotFound+    Nothing  -> throw EntryNotFound  -- | Removes the element from the map.-remove :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k+remove :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b, C.CacheStructure c k           , HasKey a k) -       => a -> TMap map k a b c -> m ()+       => a -> TMap map k a b c -> stm () remove a = delete (key a)   -- | Removes the entry that has the supplied key.-removeKey :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k+removeByKey :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b, C.CacheStructure c k              , HasKey a k) -          => k -> TMap map k a b c -> m ()-removeKey = delete +            => k -> TMap map k a b c -> stm ()+removeByKey = delete   -- | Applies a function to an element that might be only partially initialized.-apply :: (M.FiniteMapX map k, MonadAdvSTM m, Ord k, B.Backend k a b, C.CacheStructure c k+apply :: (M.FiniteMapX map k, MonadAdvSTM stm, Ord k, B.Backend k a b, C.CacheStructure c k          , HasKey a k) -       => (a -> a) -> a -> TMap map k a b c -> m a+       => (a -> a) -> a -> TMap map k a b c -> stm a apply f a tmap = do   adjust f (key a) tmap   complete a tmap
Sample.hs view
@@ -1,27 +1,41 @@ module Sample where import Control.Monad( when )+import Control.Exception import Data.TStorage import Data.TMap-import Data.TMap.Backend.StdoutBackend+import Data.TMap.Backend.Binary 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 Data.Data+import Data.Typeable+import Data.Binary import Prelude hiding( lookup )  data Sometype = Sometype { theid :: Int, name :: String }-                deriving (Show,Eq,Ord)+                deriving (Show,Eq,Ord,Data,Typeable) +instance Binary Sometype where+  put (Sometype a b) = put a >> put b+  get = get >>= \a -> get >>= \b -> return (Sometype a b)++ instance HasKey Sometype Int where   key = theid + sample :: IO () sample = Exc.handle (\(e::Exc.SomeException) -> print e) $ do-  tmap <- newTMapIO newStdoutBackend (Just 4) -            :: IO (TMap (M.FM Int) Int Sometype StdoutBackend C.LRU)-  -- First the low level TMap interface:-  res  <- atomically $ do++  -- Let's create a TMap that uses the binary-serialization backend:+  backend <- mkBinaryBackend "/home/thaldyron/var/test" +  tmap <- newTMapIO backend (Just 4) +            :: IO (TMap (M.FM Int) Int Sometype BinaryBackend C.LRU)++  -- First let's use the low level TMap interface:+  res  <- atomically $ (do     insert 1 (Sometype 1 "somename")  tmap     insert 2 (Sometype 2 "somename2") tmap     insert 3 (Sometype 3 "somename3") tmap@@ -30,29 +44,38 @@     insert 6 (Sometype 6 "somename6") tmap     lookup 2 tmap     delete 2 tmap-    lookup 2 tmap+    lookup 2 tmap) +    -- Catch duplicate-inserts exceptions:+    `catchSTM` (\(e::TMapException) -> if e==DuplicateEntry then return Nothing+                                                            else throw e)   atomically $ purgeTMap tmap-  print ("Result1: ",res) +  print ("Result1: ",res)      -- Let's try the high-level TStorage interface:   res2 <- atomically $ do     add (Sometype 7 "somename7") tmap-    v1 <- apply (\s -> s{name="_"}) (Sometype {theid = 4}) tmap-    v2 <- complete (Sometype {theid = 5}) tmap+    v1 <- apply (\s -> s{name="_"}) (Sometype {theid = 1}) tmap+    v2 <- complete (Sometype {theid = 1}) tmap+--    return v2     return (v1,v2)   print ("Result2: ",res2)  test :: IO () test = do-   tmap <- newTMapIO newStdoutBackend (Just 4) -            :: IO (TMap (M.FM Int) Int String StdoutBackend C.LRU)+   backend <- mkBinaryBackend "/home/thaldyron/var/test2" +   tmap <- newTMapIO backend (Just 4) +            :: IO (TMap (M.FM Int) Int String BinaryBackend C.LRU)    atomically $ do        isMemb <- member 1 tmap-       when (not isMemb) $ +       when (not isMemb) $ do          insert 1 "john doe" tmap-      atomically $ do      v <- lookup 1 tmap      -- ... doing something here with 'v'-     adjust (\_ -> "jd") 1 tmap+     case v of+       Nothing -> return ()+       Just v' -> do +         adjust (\_ -> "jd") 1 tmap+         onCommit $ print v'+
persistent-map.cabal view
@@ -1,6 +1,11 @@ Name:           persistent-map Synopsis:       A thread-safe interface for finite map types with optional persistency support. Description:++    /Changes in 0.1.0:/+    .+    * Added the binary serialization backend.+    .     This library provides a thread-safe (STM) frontend for finite map types together with a     backend interface for persistent storage. The /TMap/ data type     is thread-safe, since all access functions run inside an STM monad . Any type @@ -54,23 +59,23 @@     probably change.  Author:         Peter Robinson-Maintainer:     thaldyron@gmail.com+Maintainer:     Peter Robinson <thaldyron@gmail.com> License:        LGPL License-file:   LICENSE-Version:        0.0.0-Category:       Data, Concurrency+Version:        0.1.0+Category:       Middleware, Concurrency Stability:      experimental Homepage:       http://darcs.monoid.at/persistent-map  build-type:     Simple                         cabal-version: >= 1.2.3 library-    ghc-options:        -Wall -fno-ignore-asserts+    ghc-options:        -Wall -fno-ignore-asserts -fno-warn-missing-fields      exposed-modules:    Data.TMap                         Data.TStorage---                        Data.TMap.Exception                         Data.TMap.Backend+                        Data.TMap.Backend.Binary                         Data.TMap.Backend.NoBackend                         Data.TMap.Backend.StdoutBackend                         Data.CacheStructure@@ -83,11 +88,12 @@                         EdisonAPI  >= 1.2.1 && < 1.3,                         LRU >= 0.1.1 && < 0.2,                         EdisonCore >= 1.2.1.3 && < 1.3,---                        binary,-                        stm-io-hooks >= 0.2.0 && < 0.3, +                        stm-io-hooks >= 0.3.0 && < 0.4,  --                        HDBC >= 2.0 && < 2.1, -                        mtl >= 1.1.0.2 && < 1.2---                        MonadCatchIO-mtl+                        mtl >= 1.1.0.2 && < 1.2,+                        binary >= 0.5 && < 0.6,+                        filepath >= 1.1 && < 1.2,+                        directory >= 1.0.0.3 && < 1.1      extensions:         MultiParamTypeClasses,                         RankNTypes,