filecache 0.2.3 → 0.2.4

raw patch · 2 files changed

+34/−57 lines, 2 filesdep +stmdep ~strict-base-types

Dependencies added: stm

Dependency ranges changed: strict-base-types

Files

• Data/FileCache.hs +31/−55
• filecache.cabal +3/−2

@@ -12,21 +12,17 @@  import qualified Data.HashMap.Strict as HM import System.INotify-import Control.Concurrent+import Control.Concurrent.STM import qualified Data.Either.Strict as S import Control.Exception-import Control.Monad import Control.Monad.Error.Class import Control.Exception.Lens--data Messages r a = Invalidate !FilePath-                  | Query !FilePath !(IO (S.Either r a)) !(MVar (S.Either r a))-                  | GetCopy !(MVar (HM.HashMap FilePath (S.Either r a, WatchDescriptor)))-                  | Stop+import Control.Applicative+import Control.Monad (join)  -- | The main FileCache type, for queries returning 'Either r a'. The r -- type must be an instance of 'Error'.-data FileCacheR r a = FileCache !(Chan (Messages r a))+data FileCacheR r a = FileCache !(TVar (HM.HashMap FilePath (S.Either r a, WatchDescriptor))) !INotify  -- | A default type synonym, for String errors. type FileCache = FileCacheR String@@ -34,50 +30,21 @@ -- | Generates a new file cache. The opaque type is for use with other -- functions. newFileCache :: Error r => IO (FileCacheR r a)-newFileCache = do-    q <- newChan-    ino <- initINotify-    void $ forkIO (mapMaster HM.empty q ino)-    return (FileCache q)+newFileCache = FileCache <$> newTVarIO HM.empty <*> initINotify  -- | Destroys the thread running the FileCache. Pretty dangerous stuff. killFileCache :: FileCacheR r a -> IO ()-killFileCache (FileCache q) = writeChan q Stop--mapMaster :: Error r => HM.HashMap FilePath (S.Either r a, WatchDescriptor) -> Chan (Messages r a) -> INotify -> IO ()-mapMaster mp q ino = do-    let nochange = return (Just mp)-        change x = return (Just (x mp))-    msg <- readChan q-    nmp <- case msg of-            Stop -> killINotify ino >> return Nothing-            Invalidate fp ->-                case HM.lookup fp mp of-                    Nothing -> nochange-                    Just (_,desc) -> catching_ id (removeWatch desc) (return ()) >> change (HM.delete fp)-            Query fp action respvar ->-                case HM.lookup fp mp of-                    Just (x,_) -> putMVar respvar x >> nochange-                    Nothing -> do-                        let addw value = do-                                wm <- addWatch ino [CloseWrite,Delete,Move,Attrib,Create] fp (const $ invalidate fp (FileCache q))-                                change (HM.insert fp (value,wm))-                            withWatch value = do-                                putMVar respvar value-                                catching_ id (addw value) nochange-                            noWatch x = putMVar respvar x >> nochange-                        catches (action >>= withWatch)-                            [ handler _IOException (\io -> noWatch   (S.Left (strMsg $ show io)))-                            , handler id           (\e  -> withWatch (S.Left (strMsg $ show e)))-                            ]-            GetCopy mv -> putMVar mv mp >> nochange-    case nmp of-        Just x -> mapMaster x q ino-        Nothing -> return ()+killFileCache (FileCache _ ino) = killINotify ino  -- | Manually invalidates an entry. invalidate :: Error r => FilePath -> FileCacheR r a -> IO ()-invalidate fp (FileCache q) = writeChan q (Invalidate fp)+invalidate fp (FileCache q _) = join $ atomically $ do+    mp <- readTVar q+    case HM.lookup fp mp of+        Nothing -> return (return ())+        Just (_,desc) -> do+            writeTVar q (HM.delete fp mp)+            return (removeWatch desc)  -- | Queries the cache, populating it if necessary, returning a strict -- 'Either' (from "Data.Either.Strict").@@ -90,11 +57,23 @@       -> FilePath -- ^ Path of the file entry       -> IO (S.Either r a) -- ^ The computation that will be used to populate the cache       -> IO (S.Either r a)-query (FileCache q) fp generate = do-    v <- newEmptyMVar-    writeChan q (Query fp generate v)-    readMVar v-+query f@(FileCache q ino) fp action = do+    mp <- getCache f+    case HM.lookup fp mp of+        Just (x,_) -> return x+        Nothing -> do+            let addw value = do+                    wm <- addWatch ino [CloseWrite,Delete,Move,Attrib,Create] fp (const $ invalidate fp f)+                    change (HM.insert fp (value,wm))+                withWatch value = do+                    catching_ id (addw value) nochange+                    return value+                change = atomically . modifyTVar q+                nochange = return ()+            catches (action >>= withWatch)+                [ handler _IOException (\io -> return    (S.Left (strMsg $ show io)))+                , handler id           (\e  -> withWatch (S.Left (strMsg $ show e)))+                ] -- | Just like `query`, but with the standard "Either" type. lazyQuery :: Error r       => FileCacheR r a@@ -110,8 +89,5 @@  -- | Gets a copy of the cache. getCache :: Error r => FileCacheR r a -> IO (HM.HashMap FilePath (S.Either r a, WatchDescriptor))-getCache (FileCache q) = do-    v <- newEmptyMVar-    writeChan q (GetCopy v)-    readMVar v+getCache (FileCache q _) = atomically (readTVar q) 

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                filecache-version:             0.2.3+version:             0.2.4 synopsis:            A Linux-only cache system associating values to files. description:         A Linux-only cache system, that works by associating computation results with file names. When the files are modified, the cache entries are discarded. homepage:            http://lpuppet.banquise.net/@@ -30,6 +30,7 @@                      , unordered-containers == 0.2.*                      , hashable             >= 1.2   && < 1.3                      , hinotify             >= 0.3.6 && < 0.4-                     , strict-base-types    >= 0.2+                     , strict-base-types    >= 0.2.2                      , mtl                  == 2.1.*                      , lens                 >= 3.9 && < 5+                     , stm