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
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)
}
type FileCache = FileCacheR String
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)
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
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)
query :: forall e a. IsString e
=> FileCacheR e a
-> FilePath
-> IO (R.Either e a)
-> 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))
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) = R.Left x
strict (Right x) = R.Right x
unstrict (R.Left x) = Left x
unstrict (R.Right x) = Right x
getCache :: FileCacheR e a -> IO (M.Map FilePath (R.Either e a))
getCache = atomically . readTVar . _cache