diff --git a/filecache.cabal b/filecache.cabal --- a/filecache.cabal +++ b/filecache.cabal @@ -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 diff --git a/src/Data/FileCache.hs b/src/Data/FileCache.hs --- a/src/Data/FileCache.hs +++ b/src/Data/FileCache.hs @@ -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 diff --git a/src/Data/FileCache/Internal.hs b/src/Data/FileCache/Internal.hs --- a/src/Data/FileCache/Internal.hs +++ b/src/Data/FileCache/Internal.hs @@ -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)) diff --git a/tests/simpletest.hs b/tests/simpletest.hs --- a/tests/simpletest.hs +++ b/tests/simpletest.hs @@ -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"