filecache 0.5.2 → 0.5.3

raw patch · 4 files changed

+142/−131 lines, 4 filesdep +strictdep −mtldep −strict-base-typesdep ~containersdep ~stmPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: strict

Dependencies removed: mtl, strict-base-types

Dependency ranges changed: containers, stm

API changes (from Hackage documentation)

Files

• filecache.cabal +7/−8
• src/Data/FileCache.hs +9/−9
• src/Data/FileCache/Internal.hs +84/−73
• tests/simpletest.hs +42/−41

@@ -1,5 +1,5 @@ name:                filecache-version:             0.5.2+version:             0.5.3 synopsis:            A cache system associating values to files. description:         A 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/@@ -12,11 +12,11 @@ build-type:          Simple cabal-version:       >=1.10 bug-reports:         https://github.com/bartavelle/filecache/issues-tested-with:         GHC == 9.8.2 || ==9.6.6+tested-with:         GHC == 9.8.2 || == 9.6.6 || == 9.10.3 || == 9.12.2  source-repository head   type: git-  location: git://github.com/bartavelle/filecache.git+  location: http://github.com/bartavelle/filecache.git  test-suite simpletest     hs-source-dirs: tests@@ -33,12 +33,11 @@   hs-source-dirs:      src   -- other-modules:   build-depends:       base               >= 4.6   && < 5-                     , containers         >= 0.5     && < 0.8+                     , containers         >= 0.5   && < 0.9                      , directory          >= 1.2   && < 1.4                      , fsnotify           >= 0.4   && < 0.5-                     , strict-base-types  >= 0.2.2-                     , mtl                >= 2.1   && < 2.4+                     , strict             >= 0.5   && < 0.6                      , exceptions         >= 0.8   && < 0.11                      , filepath           >= 1.4   && < 1.6-                     , time               >= 1.5  && < 2-                     , stm+                     , time               >= 1.5   && < 2+                     , stm                < 3

@@ -1,14 +1,14 @@ {-# LANGUAGE ScopedTypeVariables #-}-{- |-This module let you create caches where keys are file names, and values are automatically expired when the file is modified for any reason. -This is usually done in the following fashion :--> cache <- newFileCache-> o <- query cache "/path/to/file" computation--The computation will be used to populate the cache if this call results in a miss. The result is forced to WHNM.--}+-- |+-- This module let you create caches where keys are file names, and values are automatically expired when the file is modified for any reason.+--+-- This is usually done in the following fashion :+--+-- > cache <- newFileCache+-- > o <- query cache "/path/to/file" computation+--+-- The computation will be used to populate the cache if this call results in a miss. The result is forced to WHNM. module Data.FileCache (FileCache, FileCacheR, newFileCache, killFileCache, invalidate, query, OnModified, queryWith, getCache, lazyQuery) where  import Data.FileCache.Internal

@@ -1,37 +1,36 @@ {-# LANGUAGE ScopedTypeVariables #-}-{- | -Internal module ... use at your own risks!---}+-- |+--+-- Internal module ... use at your own risks! module Data.FileCache.Internal where -import qualified Data.Map.Strict as M-import qualified Data.Set as S+import Control.Applicative+import Control.Concurrent import Control.Concurrent.STM-import qualified Data.Either.Strict as R-import System.FSNotify import Control.Monad import Control.Monad.Catch-import Control.Applicative-import Control.Concurrent+import qualified Data.Strict.Either as R+import qualified Data.Map.Strict as M+import qualified Data.Set as S import Data.String-import System.Directory (canonicalizePath)-import System.FilePath (addTrailingPathSeparator, takeDirectory) import Data.Time.Clock (getCurrentTime) import Debug.Trace+import System.Directory (canonicalizePath)+import System.FSNotify+import System.FilePath (addTrailingPathSeparator, takeDirectory) import Prelude  -- | The main FileCache type, for queries returning 'Either r a'. The r -- type must be an instance of 'Error'. data FileCacheR r a-    = FileCache-    { _cache        :: TVar (M.Map FilePath (R.Either r a, OnModified))-    , _watchedDirs  :: TVar (M.Map FilePath (S.Set FilePath, StopListening))-    , _manager      :: WatchManager-    , _channel      :: EventChannel-    , _tid          :: TVar (Maybe ThreadId)-    }+  = FileCache+  { _cache :: TVar (M.Map FilePath (R.Either r a, OnModified)),+    _watchedDirs :: TVar (M.Map FilePath (S.Set FilePath, StopListening)),+    _manager :: WatchManager,+    _channel :: EventChannel,+    _tid :: TVar (Maybe ThreadId)+  }  -- | A default type synonym, for String errors. type FileCache = FileCacheR String@@ -44,42 +43,42 @@ -- functions. newFileCache :: IO (FileCacheR r a) newFileCache = do-    c <- newChan-    tcache <- newTVarIO M.empty-    wcache <- newTVarIO M.empty-    manager <- startManager-    tid <- forkIO $ forever $ do-      e <- readChan c-      let cfp = eventPath e-          dir = addTrailingPathSeparator (takeDirectory cfp)-      join $ atomically $ do-        onModified <- maybe (return ()) snd . M.lookup cfp <$> readTVar tcache-        modifyTVar tcache $ M.delete cfp-        wdirs <- readTVar wcache-        (onModified >>) <$> case M.lookup dir wdirs of-          Nothing -> return $ return ()-          Just (watched, stop) ->-            let watched' = S.delete cfp watched-            in  if S.null watched'-                  then stop <$ modifyTVar wcache (M.delete dir)-                  else return () <$ modifyTVar wcache (M.insert dir (watched', stop))-    FileCache tcache wcache manager c <$> newTVarIO (Just tid)+  c <- newChan+  tcache <- newTVarIO M.empty+  wcache <- newTVarIO M.empty+  manager <- startManager+  tid <- forkIO $ forever $ do+    e <- readChan c+    let cfp = eventPath e+        dir = addTrailingPathSeparator (takeDirectory cfp)+    join $ atomically $ do+      onModified <- maybe (return ()) snd . M.lookup cfp <$> readTVar tcache+      modifyTVar tcache $ M.delete cfp+      wdirs <- readTVar wcache+      (onModified >>) <$> case M.lookup dir wdirs of+        Nothing -> return $ return ()+        Just (watched, stop) ->+          let watched' = S.delete cfp watched+           in if S.null watched'+                then stop <$ modifyTVar wcache (M.delete dir)+                else return () <$ modifyTVar wcache (M.insert dir (watched', stop))+  FileCache tcache wcache manager c <$> newTVarIO (Just tid)  -- | Destroys the thread running the FileCache. Pretty dangerous stuff. killFileCache :: FileCacheR r a -> IO () killFileCache (FileCache tcache twatched mgr _ tid) = do-    atomically $ do-      writeTVar tcache M.empty-      writeTVar twatched M.empty-      writeTVar tid Nothing-    stopManager mgr+  atomically $ do+    writeTVar tcache M.empty+    writeTVar twatched M.empty+    writeTVar tid Nothing+  stopManager mgr  -- | Manually invalidates an entry. invalidate :: FilePath -> FileCacheR e a -> IO () invalidate fp c = do-   cfp <- canon fp-   tm <- getCurrentTime-   writeChan (_channel c) (Removed cfp tm IsFile)+  cfp <- canon fp+  tm <- getCurrentTime+  writeChan (_channel c) (Removed cfp tm IsFile)  canon :: FilePath -> IO FilePath canon fp = canonicalizePath fp `catchAll` const (return fp)@@ -88,20 +87,28 @@ -- 'Either' (from "Data.Either.Strict"). -- -- Queries that fail with an 'IOExeception' will not create a cache entry.-query :: forall e a. IsString e-      => FileCacheR e a-      -> FilePath -- ^ Path of the file entry-      -> IO (R.Either e a) -- ^ The computation that will be used to populate the cache-      -> IO (R.Either e a)+query ::+  forall e a.+  (IsString e) =>+  FileCacheR e a ->+  -- | Path of the file entry+  FilePath ->+  -- | The computation that will be used to populate the cache+  IO (R.Either e a) ->+  IO (R.Either e a) query q fp = queryWith q fp (return ())  -- | Generalization of 'query' that allows to specify an 'OnModified' hook-queryWith :: forall e a. IsString e-          => FileCacheR e a-          -> FilePath -- ^ Path of the file entry-          -> OnModified-          -> IO (R.Either e a) -- ^ The computation that will be used to populate the cache-          -> IO (R.Either e a)+queryWith ::+  forall e a.+  (IsString e) =>+  FileCacheR e a ->+  -- | Path of the file entry+  FilePath ->+  OnModified ->+  -- | The computation that will be used to populate the cache+  IO (R.Either e a) ->+  IO (R.Either e a) queryWith f@(FileCache tcache twatched wm chan tmtid) fp onModified action = do   mtid <- readTVarIO tmtid   case mtid of@@ -110,13 +117,14 @@       canonical <- canon fp       mp <- getCache f       case M.lookup canonical mp of-          Just x -> return x-          Nothing -> (action >>= withWatch canonical)-                       `catchIOError` (return . R.Left . fromString . show)-                       `catchAll` (withWatch canonical . R.Left . fromString . show)+        Just x -> return x+        Nothing ->+          (action >>= withWatch canonical)+            `catchIOError` (return . R.Left . fromString . show)+            `catchAll` (withWatch canonical . R.Left . fromString . show)       where         withWatch :: FilePath -> R.Either e a -> IO (R.Either e a)-        withWatch canonical value = value <$ (addWatch canonical value `catchAll` traceShowM )+        withWatch canonical value = value <$ (addWatch canonical value `catchAll` traceShowM)         addWatch canonical value = join $ atomically $ do           let cpath = addTrailingPathSeparator (takeDirectory canonical)           modifyTVar tcache (M.insert canonical (value, onModified))@@ -131,17 +139,20 @@ -- | Just like `query`, but with the standard "Either" type. Note that it -- is just there for easy interoperability with the more comme "Either" -- type, as the result is still forced.-lazyQuery :: IsString r-          => FileCacheR r a-          -> FilePath -- ^ Path of the file entry-          -> IO (Either r a) -- ^ The computation that will be used to populate the cache-          -> IO (Either r a)+lazyQuery ::+  (IsString r) =>+  FileCacheR r a ->+  -- | Path of the file entry+  FilePath ->+  -- | The computation that will be used to populate the cache+  IO (Either r a) ->+  IO (Either r a) lazyQuery q fp generate = fmap unstrict (query q fp (fmap strict generate))-    where-        strict (Left x) = R.Left x-        strict (Right x) = R.Right x-        unstrict (R.Left x) = Left x-        unstrict (R.Right x) = Right x+  where+    strict (Left x) = R.Left x+    strict (Right x) = R.Right x+    unstrict (R.Left x) = Left x+    unstrict (R.Right x) = Right x  -- | Gets a copy of the cache. getCache :: FileCacheR e a -> IO (M.Map FilePath (R.Either e a))

@@ -1,54 +1,55 @@ module Main where -import System.IO.Temp-import Data.FileCache.Internal-import Control.Monad-import Control.Exception-import System.Directory import Control.Concurrent+import Control.Concurrent.STM hiding (check)+import Control.Exception+import Control.Monad+import Data.FileCache.Internal import qualified Data.Map.Strict as M import qualified Data.Set as S-import Control.Concurrent.STM hiding (check)+import System.Directory import System.FilePath (addTrailingPathSeparator)+import System.IO.Temp import Test.Hspec  computation :: String -> IO (Either String Int) computation f = do-    c <- readFile f-    return $ if length c `mod` 2 == 0-        then Right (length c)-        else Left "odd length"+  c <- readFile f+  return $+    if length c `mod` 2 == 0+      then Right (length c)+      else Left "odd length"  main :: IO () main = withSystemTempDirectory "filecacheXXX.tmp" $ \tempdir -> do-    cache@(FileCache tcache tdirs _ _ _) <- newFileCache :: IO (FileCache Int)-    let indexes = [1,10,100,1000]-        tofilename :: Int -> String-        tofilename i = tempdir ++ "/temp" ++ show i-    forM_ indexes $ \l -> writeFile (tofilename l) (show l)-    let q l = lazyQuery cache (tofilename l) (computation (tofilename l))-        qf l = lazyQuery cache (tofilename l) (throwIO (AssertionFailed "fail"))-    hspec $ describe "Spec" $ do-      it "Should run the actions" $ do-        mapM q indexes `shouldReturn` [Left "odd length",Right 2,Left "odd length",Right 4]-      it "Should have cached the results" $ do-        mapM qf indexes `shouldReturn` [Left "odd length",Right 2,Left "odd length",Right 4]-      it "Should stop watching dropped files" $ do-        removeFile (tofilename 10)-        doesFileExist (tofilename 10) `shouldReturn` False-        threadDelay (1*10^(5 :: Int))-        cacheInfo <- readTVarIO tcache-        M.size cacheInfo `shouldBe` 3-      it "Should update the list of watched files per directory" $ do-        dirs <- fmap fst <$> readTVarIO tdirs-        M.toList dirs `shouldBe` [(addTrailingPathSeparator tempdir, foldMap (S.singleton . tofilename) [1,100,1000])]-      it "Should stop watching directory without watched files" $ do-        forM_ [1,100,1000] $ \i -> do-          removeFile (tofilename i)-          doesFileExist (tofilename i) `shouldReturn` False-        threadDelay (1*10^(5 :: Int))-        dirs <- fmap fst <$> readTVarIO tdirs-        dirs `shouldBe` M.empty-      it "Should stop the watch" $ do-        killFileCache cache-        q 1 `shouldReturn` Left "Closed cache"+  cache@(FileCache tcache tdirs _ _ _) <- newFileCache :: IO (FileCache Int)+  let indexes = [1, 10, 100, 1000]+      tofilename :: Int -> String+      tofilename i = tempdir ++ "/temp" ++ show i+  forM_ indexes $ \l -> writeFile (tofilename l) (show l)+  let q l = lazyQuery cache (tofilename l) (computation (tofilename l))+      qf l = lazyQuery cache (tofilename l) (throwIO (AssertionFailed "fail"))+  hspec $ describe "Spec" $ do+    it "Should run the actions" $ do+      mapM q indexes `shouldReturn` [Left "odd length", Right 2, Left "odd length", Right 4]+    it "Should have cached the results" $ do+      mapM qf indexes `shouldReturn` [Left "odd length", Right 2, Left "odd length", Right 4]+    it "Should stop watching dropped files" $ do+      removeFile (tofilename 10)+      doesFileExist (tofilename 10) `shouldReturn` False+      threadDelay (1 * 10 ^ (5 :: Int))+      cacheInfo <- readTVarIO tcache+      M.size cacheInfo `shouldBe` 3+    it "Should update the list of watched files per directory" $ do+      dirs <- fmap fst <$> readTVarIO tdirs+      M.toList dirs `shouldBe` [(addTrailingPathSeparator tempdir, foldMap (S.singleton . tofilename) [1, 100, 1000])]+    it "Should stop watching directory without watched files" $ do+      forM_ [1, 100, 1000] $ \i -> do+        removeFile (tofilename i)+        doesFileExist (tofilename i) `shouldReturn` False+      threadDelay (1 * 10 ^ (5 :: Int))+      dirs <- fmap fst <$> readTVarIO tdirs+      dirs `shouldBe` M.empty+    it "Should stop the watch" $ do+      killFileCache cache+      q 1 `shouldReturn` Left "Closed cache"