{-# LANGUAGE ScopedTypeVariables #-}
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
{ forall r a. FileCacheR r a -> TVar (Map FilePath (Either r a))
_cache :: TVar (M.Map FilePath (R.Either r a))
, forall r a.
FileCacheR r a -> TVar (Map FilePath (Set FilePath, StopListening))
_watchedDirs :: TVar (M.Map FilePath (S.Set FilePath, StopListening))
, forall r a. FileCacheR r a -> WatchManager
_manager :: WatchManager
, forall r a. FileCacheR r a -> EventChannel
_channel :: EventChannel
, forall r a. FileCacheR r a -> TVar (Maybe ThreadId)
_tid :: TVar (Maybe ThreadId)
}
type FileCache = FileCacheR String
newFileCache :: IO (FileCacheR r a)
newFileCache :: forall r a. IO (FileCacheR r a)
newFileCache = do
EventChannel
c <- IO EventChannel
forall a. IO (Chan a)
newChan
TVar (Map FilePath (Either r a))
tcache <- Map FilePath (Either r a) -> IO (TVar (Map FilePath (Either r a)))
forall a. a -> IO (TVar a)
newTVarIO Map FilePath (Either r a)
forall k a. Map k a
M.empty
TVar (Map FilePath (Set FilePath, StopListening))
wcache <- Map FilePath (Set FilePath, StopListening)
-> IO (TVar (Map FilePath (Set FilePath, StopListening)))
forall a. a -> IO (TVar a)
newTVarIO Map FilePath (Set FilePath, StopListening)
forall k a. Map k a
M.empty
WatchManager
manager <- IO WatchManager
startManager
ThreadId
tid <- StopListening -> IO ThreadId
forkIO (StopListening -> IO ThreadId) -> StopListening -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ StopListening -> StopListening
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (StopListening -> StopListening) -> StopListening -> StopListening
forall a b. (a -> b) -> a -> b
$ do
Event
e <- EventChannel -> IO Event
forall a. Chan a -> IO a
readChan EventChannel
c
let cfp :: FilePath
cfp = Event -> FilePath
eventPath Event
e
dir :: FilePath
dir = FilePath -> FilePath
addTrailingPathSeparator (FilePath -> FilePath
takeDirectory FilePath
cfp)
IO StopListening -> StopListening
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO StopListening -> StopListening)
-> IO StopListening -> StopListening
forall a b. (a -> b) -> a -> b
$ STM StopListening -> IO StopListening
forall a. STM a -> IO a
atomically (STM StopListening -> IO StopListening)
-> STM StopListening -> IO StopListening
forall a b. (a -> b) -> a -> b
$ do
TVar (Map FilePath (Either r a))
-> (Map FilePath (Either r a) -> Map FilePath (Either r a))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map FilePath (Either r a))
tcache ((Map FilePath (Either r a) -> Map FilePath (Either r a))
-> STM ())
-> (Map FilePath (Either r a) -> Map FilePath (Either r a))
-> STM ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Map FilePath (Either r a) -> Map FilePath (Either r a)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete FilePath
cfp
Map FilePath (Set FilePath, StopListening)
wdirs <- TVar (Map FilePath (Set FilePath, StopListening))
-> STM (Map FilePath (Set FilePath, StopListening))
forall a. TVar a -> STM a
readTVar TVar (Map FilePath (Set FilePath, StopListening))
wcache
case FilePath
-> Map FilePath (Set FilePath, StopListening)
-> Maybe (Set FilePath, StopListening)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FilePath
dir Map FilePath (Set FilePath, StopListening)
wdirs of
Maybe (Set FilePath, StopListening)
Nothing -> StopListening -> STM StopListening
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (StopListening -> STM StopListening)
-> StopListening -> STM StopListening
forall a b. (a -> b) -> a -> b
$ () -> StopListening
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (Set FilePath
watched, StopListening
stop) ->
let watched' :: Set FilePath
watched' = FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
S.delete FilePath
cfp Set FilePath
watched
in if Set FilePath -> Bool
forall a. Set a -> Bool
S.null Set FilePath
watched'
then StopListening
stop StopListening -> STM () -> STM StopListening
forall a b. a -> STM b -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TVar (Map FilePath (Set FilePath, StopListening))
-> (Map FilePath (Set FilePath, StopListening)
-> Map FilePath (Set FilePath, StopListening))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map FilePath (Set FilePath, StopListening))
wcache (FilePath
-> Map FilePath (Set FilePath, StopListening)
-> Map FilePath (Set FilePath, StopListening)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete FilePath
dir)
else () -> StopListening
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () StopListening -> STM () -> STM StopListening
forall a b. a -> STM b -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TVar (Map FilePath (Set FilePath, StopListening))
-> (Map FilePath (Set FilePath, StopListening)
-> Map FilePath (Set FilePath, StopListening))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map FilePath (Set FilePath, StopListening))
wcache (FilePath
-> (Set FilePath, StopListening)
-> Map FilePath (Set FilePath, StopListening)
-> Map FilePath (Set FilePath, StopListening)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
dir (Set FilePath
watched', StopListening
stop))
TVar (Map FilePath (Either r a))
-> TVar (Map FilePath (Set FilePath, StopListening))
-> WatchManager
-> EventChannel
-> TVar (Maybe ThreadId)
-> FileCacheR r a
forall r a.
TVar (Map FilePath (Either r a))
-> TVar (Map FilePath (Set FilePath, StopListening))
-> WatchManager
-> EventChannel
-> TVar (Maybe ThreadId)
-> FileCacheR r a
FileCache TVar (Map FilePath (Either r a))
tcache TVar (Map FilePath (Set FilePath, StopListening))
wcache WatchManager
manager EventChannel
c (TVar (Maybe ThreadId) -> FileCacheR r a)
-> IO (TVar (Maybe ThreadId)) -> IO (FileCacheR r a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ThreadId -> IO (TVar (Maybe ThreadId))
forall a. a -> IO (TVar a)
newTVarIO (ThreadId -> Maybe ThreadId
forall a. a -> Maybe a
Just ThreadId
tid)
killFileCache :: FileCacheR r a -> IO ()
killFileCache :: forall r a. FileCacheR r a -> StopListening
killFileCache (FileCache TVar (Map FilePath (Either r a))
tcache TVar (Map FilePath (Set FilePath, StopListening))
twatched WatchManager
mgr EventChannel
_ TVar (Maybe ThreadId)
tid) = do
STM () -> StopListening
forall a. STM a -> IO a
atomically (STM () -> StopListening) -> STM () -> StopListening
forall a b. (a -> b) -> a -> b
$ do
TVar (Map FilePath (Either r a))
-> Map FilePath (Either r a) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Map FilePath (Either r a))
tcache Map FilePath (Either r a)
forall k a. Map k a
M.empty
TVar (Map FilePath (Set FilePath, StopListening))
-> Map FilePath (Set FilePath, StopListening) -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Map FilePath (Set FilePath, StopListening))
twatched Map FilePath (Set FilePath, StopListening)
forall k a. Map k a
M.empty
TVar (Maybe ThreadId) -> Maybe ThreadId -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe ThreadId)
tid Maybe ThreadId
forall a. Maybe a
Nothing
WatchManager -> StopListening
stopManager WatchManager
mgr
invalidate :: FilePath -> FileCacheR e a -> IO ()
invalidate :: forall e a. FilePath -> FileCacheR e a -> StopListening
invalidate FilePath
fp FileCacheR e a
c = do
FilePath
cfp <- FilePath -> IO FilePath
canon FilePath
fp
UTCTime
tm <- IO UTCTime
getCurrentTime
EventChannel -> Event -> StopListening
forall a. Chan a -> a -> StopListening
writeChan (FileCacheR e a -> EventChannel
forall r a. FileCacheR r a -> EventChannel
_channel FileCacheR e a
c) (FilePath -> UTCTime -> EventIsDirectory -> Event
Removed FilePath
cfp UTCTime
tm EventIsDirectory
IsFile)
canon :: FilePath -> IO FilePath
canon :: FilePath -> IO FilePath
canon FilePath
fp = FilePath -> IO FilePath
canonicalizePath FilePath
fp IO FilePath -> (SomeException -> IO FilePath) -> IO FilePath
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAll` IO FilePath -> SomeException -> IO FilePath
forall a b. a -> b -> a
const (FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
fp)
query :: forall e a. IsString e
=> FileCacheR e a
-> FilePath
-> IO (R.Either e a)
-> IO (R.Either e a)
query :: forall e a.
IsString e =>
FileCacheR e a -> FilePath -> IO (Either e a) -> IO (Either e a)
query f :: FileCacheR e a
f@(FileCache TVar (Map FilePath (Either e a))
tcache TVar (Map FilePath (Set FilePath, StopListening))
twatched WatchManager
wm EventChannel
chan TVar (Maybe ThreadId)
tmtid) FilePath
fp IO (Either e a)
action = do
Maybe ThreadId
mtid <- TVar (Maybe ThreadId) -> IO (Maybe ThreadId)
forall a. TVar a -> IO a
readTVarIO TVar (Maybe ThreadId)
tmtid
case Maybe ThreadId
mtid of
Maybe ThreadId
Nothing -> Either e a -> IO (Either e a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> Either e a
forall a b. a -> Either a b
R.Left (FilePath -> e
forall a. IsString a => FilePath -> a
fromString FilePath
"Closed cache"))
Just ThreadId
_ -> do
FilePath
canonical <- FilePath -> IO FilePath
canon FilePath
fp
Map FilePath (Either e a)
mp <- FileCacheR e a -> IO (Map FilePath (Either e a))
forall e a. FileCacheR e a -> IO (Map FilePath (Either e a))
getCache FileCacheR e a
f
case FilePath -> Map FilePath (Either e a) -> Maybe (Either e a)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FilePath
canonical Map FilePath (Either e a)
mp of
Just Either e a
x -> Either e a -> IO (Either e a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either e a
x
Maybe (Either e a)
Nothing -> (IO (Either e a)
action IO (Either e a)
-> (Either e a -> IO (Either e a)) -> IO (Either e a)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> Either e a -> IO (Either e a)
withWatch FilePath
canonical)
IO (Either e a) -> (IOError -> IO (Either e a)) -> IO (Either e a)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (IOError -> m a) -> m a
`catchIOError` (Either e a -> IO (Either e a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e a -> IO (Either e a))
-> (IOError -> Either e a) -> IOError -> IO (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e a
forall a b. a -> Either a b
R.Left (e -> Either e a) -> (IOError -> e) -> IOError -> Either e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> e
forall a. IsString a => FilePath -> a
fromString (FilePath -> e) -> (IOError -> FilePath) -> IOError -> e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> FilePath
forall a. Show a => a -> FilePath
show)
IO (Either e a)
-> (SomeException -> IO (Either e a)) -> IO (Either e a)
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAll` (FilePath -> Either e a -> IO (Either e a)
withWatch FilePath
canonical (Either e a -> IO (Either e a))
-> (SomeException -> Either e a)
-> SomeException
-> IO (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e a
forall a b. a -> Either a b
R.Left (e -> Either e a)
-> (SomeException -> e) -> SomeException -> Either e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> e
forall a. IsString a => FilePath -> a
fromString (FilePath -> e)
-> (SomeException -> FilePath) -> SomeException -> e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> FilePath
forall a. Show a => a -> FilePath
show)
where
withWatch :: FilePath -> R.Either e a -> IO (R.Either e a)
withWatch :: FilePath -> Either e a -> IO (Either e a)
withWatch FilePath
canonical Either e a
value = Either e a
value Either e a -> StopListening -> IO (Either e a)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (FilePath -> Either e a -> StopListening
addWatch FilePath
canonical Either e a
value StopListening -> (SomeException -> StopListening) -> StopListening
forall (m :: * -> *) a.
(HasCallStack, MonadCatch m) =>
m a -> (SomeException -> m a) -> m a
`catchAll` SomeException -> StopListening
forall a (f :: * -> *). (Show a, Applicative f) => a -> f ()
traceShowM )
addWatch :: FilePath -> Either e a -> StopListening
addWatch FilePath
canonical Either e a
value = IO StopListening -> StopListening
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO StopListening -> StopListening)
-> IO StopListening -> StopListening
forall a b. (a -> b) -> a -> b
$ STM StopListening -> IO StopListening
forall a. STM a -> IO a
atomically (STM StopListening -> IO StopListening)
-> STM StopListening -> IO StopListening
forall a b. (a -> b) -> a -> b
$ do
let cpath :: FilePath
cpath = FilePath -> FilePath
addTrailingPathSeparator (FilePath -> FilePath
takeDirectory FilePath
canonical)
TVar (Map FilePath (Either e a))
-> (Map FilePath (Either e a) -> Map FilePath (Either e a))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map FilePath (Either e a))
tcache (FilePath
-> Either e a
-> Map FilePath (Either e a)
-> Map FilePath (Either e a)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
canonical Either e a
value)
Map FilePath (Set FilePath, StopListening)
watched <- TVar (Map FilePath (Set FilePath, StopListening))
-> STM (Map FilePath (Set FilePath, StopListening))
forall a. TVar a -> STM a
readTVar TVar (Map FilePath (Set FilePath, StopListening))
twatched
case FilePath
-> Map FilePath (Set FilePath, StopListening)
-> Maybe (Set FilePath, StopListening)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FilePath
cpath Map FilePath (Set FilePath, StopListening)
watched of
Maybe (Set FilePath, StopListening)
Nothing -> StopListening -> STM StopListening
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (StopListening -> STM StopListening)
-> StopListening -> STM StopListening
forall a b. (a -> b) -> a -> b
$ do
StopListening
stop <- WatchManager
-> FilePath -> ActionPredicate -> EventChannel -> IO StopListening
watchDirChan WatchManager
wm FilePath
cpath (Bool -> ActionPredicate
forall a b. a -> b -> a
const Bool
True) EventChannel
chan
STM () -> StopListening
forall a. STM a -> IO a
atomically (TVar (Map FilePath (Set FilePath, StopListening))
-> (Map FilePath (Set FilePath, StopListening)
-> Map FilePath (Set FilePath, StopListening))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map FilePath (Set FilePath, StopListening))
twatched (FilePath
-> (Set FilePath, StopListening)
-> Map FilePath (Set FilePath, StopListening)
-> Map FilePath (Set FilePath, StopListening)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
cpath (FilePath -> Set FilePath
forall a. a -> Set a
S.singleton FilePath
canonical, StopListening
stop)))
Just (Set FilePath
wfiles, StopListening
stop) ->
() -> StopListening
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () StopListening -> STM () -> STM StopListening
forall a b. a -> STM b -> STM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TVar (Map FilePath (Set FilePath, StopListening))
-> (Map FilePath (Set FilePath, StopListening)
-> Map FilePath (Set FilePath, StopListening))
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar TVar (Map FilePath (Set FilePath, StopListening))
twatched (FilePath
-> (Set FilePath, StopListening)
-> Map FilePath (Set FilePath, StopListening)
-> Map FilePath (Set FilePath, StopListening)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
cpath (FilePath -> Set FilePath -> Set FilePath
forall a. Ord a => a -> Set a -> Set a
S.insert FilePath
canonical Set FilePath
wfiles, StopListening
stop))
lazyQuery :: IsString r
=> FileCacheR r a
-> FilePath
-> IO (Either r a)
-> IO (Either r a)
lazyQuery :: forall r a.
IsString r =>
FileCacheR r a -> FilePath -> IO (Either r a) -> IO (Either r a)
lazyQuery FileCacheR r a
q FilePath
fp IO (Either r a)
generate = (Either r a -> Either r a) -> IO (Either r a) -> IO (Either r a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either r a -> Either r a
forall {a} {b}. Either a b -> Either a b
unstrict (FileCacheR r a -> FilePath -> IO (Either r a) -> IO (Either r a)
forall e a.
IsString e =>
FileCacheR e a -> FilePath -> IO (Either e a) -> IO (Either e a)
query FileCacheR r a
q FilePath
fp ((Either r a -> Either r a) -> IO (Either r a) -> IO (Either r a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either r a -> Either r a
forall {a} {b}. Either a b -> Either a b
strict IO (Either r a)
generate))
where
strict :: Either a b -> Either a b
strict (Left a
x) = a -> Either a b
forall a b. a -> Either a b
R.Left a
x
strict (Right b
x) = b -> Either a b
forall a b. b -> Either a b
R.Right b
x
unstrict :: Either a b -> Either a b
unstrict (R.Left a
x) = a -> Either a b
forall a b. a -> Either a b
Left a
x
unstrict (R.Right b
x) = b -> Either a b
forall a b. b -> Either a b
Right b
x
getCache :: FileCacheR e a -> IO (M.Map FilePath (R.Either e a))
getCache :: forall e a. FileCacheR e a -> IO (Map FilePath (Either e a))
getCache = STM (Map FilePath (Either e a)) -> IO (Map FilePath (Either e a))
forall a. STM a -> IO a
atomically (STM (Map FilePath (Either e a)) -> IO (Map FilePath (Either e a)))
-> (FileCacheR e a -> STM (Map FilePath (Either e a)))
-> FileCacheR e a
-> IO (Map FilePath (Either e a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Map FilePath (Either e a)) -> STM (Map FilePath (Either e a))
forall a. TVar a -> STM a
readTVar (TVar (Map FilePath (Either e a))
-> STM (Map FilePath (Either e a)))
-> (FileCacheR e a -> TVar (Map FilePath (Either e a)))
-> FileCacheR e a
-> STM (Map FilePath (Either e a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileCacheR e a -> TVar (Map FilePath (Either e a))
forall r a. FileCacheR r a -> TVar (Map FilePath (Either r a))
_cache