{-# 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
    { 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)
    }

-- | 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 :: 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)

-- | Destroys the thread running the FileCache. Pretty dangerous stuff.
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

-- | Manually invalidates an entry.
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)

-- | 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 :: 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))

-- | 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 :: 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

-- | Gets a copy of the cache.
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