module Watcher
( watch
, unwatch
, Action(Added, Changed, Moved, Removed)
, Warning(MovedOutOfScope)
, Watcher
, Handler
) where
import Control.Applicative
import Control.Concurrent
import Control.Monad (unless)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Traversable (mapM)
import Prelude hiding (mapM)
import System.Directory
import System.INotify
import System.FilePath
data Action
= Added
| Changed
| Moved FilePath
| Removed
deriving (Eq, Show)
data Warning
= MovedOutOfScope FilePath
deriving (Eq, Show)
type Handler = Action -> FilePath -> IO ()
data Watcher
= Watcher
{ notifier :: INotify
, descriptors :: MVar (Map FilePath WatchDescriptor)
, moves :: MVar (Map Cookie FilePath)
} deriving Eq
popM :: (Monad m, Ord k) => (v -> m u) -> m w -> k -> Map k v -> m (Map k v)
popM function fallback key dict = if key `Map.member` dict
then function (dict Map.! key) >> return (key `Map.delete` dict)
else fallback >> return dict
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM mpred t f = do
predicate <- mpred
if predicate then t else f
isDirectoryReference :: FilePath -> Bool
isDirectoryReference = (`elem` [".", ".."])
startsWith :: FilePath -> FilePath -> Bool
startsWith prefix path = take (length prefix) path == prefix
ls :: FilePath -> IO [FilePath]
ls dir = do
children <- getDirectoryContents dir
pure $ addDirToEach $ filter isRelevant children
where
isRelevant = not . isDirectoryReference
addDirToEach = map (dir </>)
directoriesAndFiles :: FilePath -> IO [Either FilePath FilePath]
directoriesAndFiles path = mapM partition =<< ls path
where
partition x = ifM (doesDirectoryExist x) (dir x) (file x)
dir = pure . Left
file = pure . Right
watch :: Handler -> FilePath -> IO Watcher
watch handler filepath = do
isDir <- doesDirectoryExist filepath
unless isDir (ioError $ userError $ "Not a directory: " ++ filepath)
watcher <- Watcher
<$> initINotify
<*> newMVar Map.empty
<*> newMVar Map.empty
watchDir watcher handler filepath
pure watcher
watchDirWithInitializer
:: (FilePath -> IO ())
-> Watcher
-> Handler
-> FilePath
-> IO ()
watchDirWithInitializer initialize watcher handler dir = do
watchd <- addWatch (notifier watcher) relevantEvents dir event
modifyMVar_ (descriptors watcher) (pure . Map.insert dir watchd)
mapM_ (either recurse initialize) =<< directoriesAndFiles dir
where
recurse = watchDirWithInitializer initialize watcher handler
moveFileTo = handler . Moved
moveDirTo source = moveWatchedDir source watcher handler
event :: Event -> IO ()
event (Created False child) = handler Added (dir </> child)
event (Created True child) = recurse (dir </> child)
event (Modified False Nothing) = handler Changed dir
event (Modified False (Just child)) = handler Changed (dir </> child)
event (MovedIn True child cookie) = modifyMVar_ (moves watcher) (popM
(`moveDirTo` (dir </> child))
(recurse (dir </> child))
cookie)
event (MovedIn False child cookie) = modifyMVar_ (moves watcher) (popM
(`moveFileTo` (dir </> child))
(handler Added (dir </> child))
cookie)
event (MovedOut _ child cookie) = modifyMVar_ (moves watcher)
(pure . Map.insert cookie (dir </> child))
event (Deleted True child) = unwatchDir watcher (dir </> child)
event (Deleted False child) = handler Removed (dir </> child)
event _ = pure ()
watchDir :: Watcher -> Handler -> FilePath -> IO ()
watchDir watcher handler
= watchDirWithInitializer (handler Added) watcher handler
moveWatchedDir :: FilePath -> Watcher -> Handler -> FilePath -> IO ()
moveWatchedDir source watcher handler dest = do
unwatchDir watcher source
watchDirWithInitializer moved watcher handler dest
where
oldPath path = source </> makeRelative dest path
moved path = handler (Moved $ oldPath path) path
unwatchDir :: Watcher -> FilePath -> IO ()
unwatchDir watcher dir = modifyMVar_ (descriptors watcher) killChildren
where
killChildren dict = do
let dying = Map.filterWithKey (\k _ -> startsWith dir k) dict
mapM_ removeWatch $ Map.elems dying
pure $ dict Map.\\ dying
unwatch :: Watcher -> IO [Warning]
unwatch watcher = do
lost <- withMVar (moves watcher) (pure . map MovedOutOfScope . Map.elems)
modifyMVar_ (descriptors watcher) killDescriptors
killINotify (notifier watcher)
pure lost
where
killDescriptors dict = mapM removeWatch dict *> pure Map.empty
relevantEvents :: [EventVariety]
relevantEvents =
[ Modify
, Create
, MoveIn
, MoveOut
, Delete
]