filecache 0.2.9 → 0.3.0

raw patch · 5 files changed

+209/−130 lines, 5 filesdep +containersdep +filepathdep +fsnotifydep −hashabledep −hinotifydep −lensdep ~directoryPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, filepath, fsnotify, hspec, time

Dependencies removed: hashable, hinotify, lens, unordered-containers

Dependency ranges changed: directory

API changes (from Hackage documentation)

Files

• Data/FileCache.hs +0/−95
• filecache.cabal +26/−20
• src/Data/FileCache.hs +14/−0
• src/Data/FileCache/Internal.hs +135/−0
• tests/simpletest.hs +34/−15

@@ -1,95 +0,0 @@-{- |-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--import qualified Data.HashMap.Strict as HM-import System.INotify-import Control.Concurrent.STM-import qualified Data.Either.Strict as S-import Control.Monad.Catch-import Control.Exception.Lens-import Control.Applicative-import Control.Monad (join)-import Data.String---- | The main FileCache type, for queries returning 'Either r a'. The r--- type must be an instance of 'Error'.-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---- | Generates a new file cache. The opaque type is for use with other--- functions.-newFileCache :: IO (FileCacheR r a)-newFileCache = FileCache <$> newTVarIO HM.empty <*> initINotify---- | Destroys the thread running the FileCache. Pretty dangerous stuff.-killFileCache :: FileCacheR r a -> IO ()-killFileCache (FileCache _ ino) = killINotify ino---- | Manually invalidates an entry.-invalidate :: FilePath -> FileCacheR e a -> IO ()-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").------ Queries that fail with an 'IOExeception' will not create a cache entry.--- Also please note that there is a race condition between the potential--- execution of the computation and the establishment of the watch.-query :: IsString e-      => FileCacheR e a-      -> FilePath -- ^ Path of the file entry-      -> IO (S.Either e a) -- ^ The computation that will be used to populate the cache-      -> IO (S.Either e a)-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 (return . S.Left . fromString . show)-                , handler id           (withWatch . S.Left . fromString . show)-                ]--- | 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 q fp generate = fmap unstrict (query q fp (fmap strict generate))-    where-        strict (Left x) = S.Left x-        strict (Right x) = S.Right x-        unstrict (S.Left x) = Left x-        unstrict (S.Right x) = Right x---- | Gets a copy of the cache.-getCache :: FileCacheR e a -> IO (HM.HashMap FilePath (S.Either e a, WatchDescriptor))-getCache (FileCache q _) = atomically (readTVar q)-

@@ -1,37 +1,43 @@--- Initial filecache.cabal generated by cabal init.  For further --- documentation, see http://haskell.org/cabal/users-guide/- name:                filecache-version:             0.2.9-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.+version:             0.3.0+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/ license:             BSD3 license-file:        LICENSE author:              Simon Marechal maintainer:          bartavelle@gmail.com--- copyright:           +copyright:           Simon Marechal category:            Data build-type:          Simple-cabal-version:       >=1.8+cabal-version:       >=1.10+bug-reports:         https://github.com/bartavelle/filecache/issues +source-repository head+  type: git+  location: git://github.com/bartavelle/filecache.git+ test-suite simpletest     hs-source-dirs: tests     type:           exitcode-stdio-1.0-    ghc-options:    -Wall -rtsopts -threaded -with-rtsopts-N-    build-depends:  base, filecache, temporary, directory, unordered-containers+    ghc-options:    -Wall -rtsopts -threaded -with-rtsopts=-N+    build-depends:  base, filecache, temporary, directory, containers, stm, hspec, filepath     main-is:        simpletest.hs+    default-language:    Haskell2010  library-  exposed-modules:     Data.FileCache+  exposed-modules:     Data.FileCache Data.FileCache.Internal   ghc-options:         -Wall-  -- other-modules:       -  build-depends:       base                 >= 4.6   && < 5-                     , unordered-containers == 0.2.*-                     , hashable             >= 1.2   && < 1.3-                     , hinotify             >= 0.3.6 && < 0.4-                     , strict-base-types    >= 0.2.2-                     , mtl                  >= 2.1   && < 2.3-                     , lens                 >= 3.9 && < 5-                     , exceptions           == 0.8.*+  default-language:    Haskell2010+  hs-source-dirs:      src+  -- other-modules:+  build-depends:       base               >= 4.6   && < 5+                     , containers         == 0.5.*+                     , directory          >= 1.2   && < 1.4+                     , fsnotify           == 0.2.*+                     , strict-base-types  >= 0.2.2+                     , mtl                >= 2.1   && < 2.3+                     , exceptions         == 0.8.*+                     , filepath           == 1.4.*+                     , time               >= 1.5  && < 2                      , stm

@@ -0,0 +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++import Data.FileCache.Internal

@@ -0,0 +1,135 @@+{-# LANGUAGE ScopedTypeVariables #-}+{- |++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.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 Data.String+import System.Directory (canonicalizePath)+import System.FilePath (addTrailingPathSeparator, takeDirectory)+import Data.Time.Clock (getCurrentTime)+import Debug.Trace+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)+    }++-- | A default type synonym, for String errors.+type FileCache = FileCacheR String++-- | 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)++-- | 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++-- | 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)++canon :: FilePath -> IO FilePath+canon fp = canonicalizePath fp `catchAll` const (return fp)++-- | Queries the cache, populating it if necessary, returning a strict+-- '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+  mtid <- readTVarIO tmtid+  case mtid of+    Nothing -> return (R.Left (fromString "Closed cache"))+    Just _ -> do+      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)+      where+        withWatch :: FilePath -> R.Either e a -> IO (R.Either e a)+        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)+          watched <- readTVar twatched+          case M.lookup cpath watched of+            Nothing -> return $ do+              stop <- watchDirChan wm cpath (const True) chan+              atomically (modifyTVar twatched (M.insert cpath (S.singleton canonical, stop)))+            Just (wfiles, stop) ->+              return () <$ modifyTVar twatched (M.insert cpath (S.insert canonical wfiles, stop))++-- | 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 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++-- | Gets a copy of the cache.+getCache :: FileCacheR e a -> IO (M.Map FilePath (R.Either e a))+getCache = atomically . readTVar . _cache+

@@ -1,35 +1,54 @@ module Main where  import System.IO.Temp-import Data.FileCache+import Data.FileCache.Internal import Control.Monad import Control.Exception import System.Directory import Control.Concurrent-import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as M+import qualified Data.Set as S+import Control.Concurrent.STM hiding (check)+import System.FilePath (addTrailingPathSeparator)+import Test.Hspec  computation :: String -> IO (Either String Int) computation f = do     c <- readFile f-    if length c `mod` 2 == 0-        then return (Right (length c))-        else return (Left "odd length")+    return $ if length c `mod` 2 == 0+        then Right (length c)+        else Left "odd length"  main :: IO () main = withSystemTempDirectory "filecacheXXX.tmp" $ \tempdir -> do-    cache <- newFileCache :: IO (FileCache Int)+    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"))-        check x m = unless x (error m)-    lst1 <- mapM q indexes-    lst2 <- mapM qf indexes-    check (lst1 == lst2) "Request result was not cached"-    removeFile (tofilename 10)-    threadDelay (1*10^(6 :: Int))-    cacheInfo <- getCache cache-    check (HM.size cacheInfo == 3) "Invalidation didn't work"-+    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"