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
data FileCacheR r a = FileCache !(TVar (HM.HashMap FilePath (S.Either r a, WatchDescriptor))) !INotify
type FileCache = FileCacheR String
newFileCache :: IO (FileCacheR r a)
newFileCache = FileCache <$> newTVarIO HM.empty <*> initINotify
killFileCache :: FileCacheR r a -> IO ()
killFileCache (FileCache _ ino) = killINotify ino
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)
query :: IsString e
=> FileCacheR e a
-> FilePath
-> IO (S.Either e a)
-> 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)
]
lazyQuery :: IsString r
=> FileCacheR r a
-> FilePath
-> IO (Either r a)
-> 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
getCache :: FileCacheR e a -> IO (HM.HashMap FilePath (S.Either e a, WatchDescriptor))
getCache (FileCache q _) = atomically (readTVar q)