filecache 0.4.1 → 0.5.3
raw patch · 4 files changed
Files
- filecache.cabal +9/−9
- src/Data/FileCache.hs +10/−10
- src/Data/FileCache/Internal.hs +94/−70
- tests/simpletest.hs +42/−41
filecache.cabal view
@@ -1,5 +1,5 @@ name: filecache-version: 0.4.1+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,10 +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 || == 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@@ -32,12 +33,11 @@ hs-source-dirs: src -- other-modules: build-depends: base >= 4.6 && < 5- , containers >= 0.5 && < 0.7+ , containers >= 0.5 && < 0.9 , directory >= 1.2 && < 1.4- , fsnotify == 0.3.*- , strict-base-types >= 0.2.2- , mtl >= 2.1 && < 2.3+ , fsnotify >= 0.4 && < 0.5+ , strict >= 0.5 && < 0.6 , exceptions >= 0.8 && < 0.11- , filepath == 1.4.*- , time >= 1.5 && < 2- , stm+ , filepath >= 1.4 && < 1.6+ , time >= 1.5 && < 2+ , stm < 3
src/Data/FileCache.hs view
@@ -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.--}-module Data.FileCache (FileCache, FileCacheR, newFileCache, killFileCache, invalidate, query, getCache, lazyQuery) where+-- |+-- 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
src/Data/FileCache/Internal.hs view
@@ -1,80 +1,84 @@ {-# 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))- , _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 +-- | Hook to invoke after an entry is removed from the cache+-- (because the corresponding file has been modified)+type OnModified = IO ()+ -- | Generates a new file cache. The opaque type is for use with other -- 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- modifyTVar tcache $ M.delete cfp- wdirs <- readTVar wcache- 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 False)+ cfp <- canon fp+ tm <- getCurrentTime+ writeChan (_channel c) (Removed cfp tm IsFile) canon :: FilePath -> IO FilePath canon fp = canonicalizePath fp `catchAll` const (return fp)@@ -83,12 +87,29 @@ -- '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 f@(FileCache tcache twatched wm chan tmtid) fp action = do+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 ->+ -- | 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 Nothing -> return (R.Left (fromString "Closed cache"))@@ -96,16 +117,17 @@ 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)+ modifyTVar tcache (M.insert canonical (value, onModified)) watched <- readTVar twatched case M.lookup cpath watched of Nothing -> return $ do@@ -117,19 +139,21 @@ -- | 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))-getCache = atomically . readTVar . _cache-+getCache = atomically . fmap (fmap fst) . readTVar . _cache
tests/simpletest.hs view
@@ -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"