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.Exception
import Control.Monad.Error.Class
import Control.Exception.Lens
import Control.Applicative
import Control.Monad (join)
data FileCacheR r a = FileCache !(TVar (HM.HashMap FilePath (S.Either r a, WatchDescriptor))) !INotify
type FileCache = FileCacheR String
newFileCache :: Error r => IO (FileCacheR r a)
newFileCache = FileCache <$> newTVarIO HM.empty <*> initINotify
killFileCache :: FileCacheR r a -> IO ()
killFileCache (FileCache _ ino) = killINotify ino
invalidate :: Error r => FilePath -> FileCacheR r 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 :: Error r
=> FileCacheR r a
-> FilePath
-> IO (S.Either r a)
-> IO (S.Either r 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 (\io -> return (S.Left (strMsg $ show io)))
, handler id (\e -> withWatch (S.Left (strMsg $ show e)))
]
lazyQuery :: Error 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 :: Error r => FileCacheR r a -> IO (HM.HashMap FilePath (S.Either r a, WatchDescriptor))
getCache (FileCache q _) = atomically (readTVar q)