watcher-0.0.1: src/Watcher.hs

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

-- |The types of actions that are reported.
data Action
	= Added
	| Changed
	| Moved FilePath
	| Removed
	deriving (Eq, Show)

-- |Badness that happened during a watch, usually due to inotify limitations.
data Warning
	= MovedOutOfScope FilePath
	deriving (Eq, Show)

-- |Functions that handle events
-- The filepaths passed will be joined with the path used to set up the watcher.
-- If you have
--    mydir/
--      file1
--      file2
-- And you do (watch myHandler "mydir") and file1 changes, myHandler will be
-- passed "mydir/file1" as the FilePath.
type Handler = Action -> FilePath -> IO ()

-- |A handler used to mutate and reference watchers.
data Watcher
	= Watcher
	{ notifier :: INotify
	, descriptors :: MVar (Map FilePath WatchDescriptor)
	, moves :: MVar (Map Cookie FilePath)
	} deriving Eq

-- |Applies a monadic function to a specific value of a map, and returns the map
-- with that value removed. If the key specifying the value is not in the map,
-- then the fallback is executed and the map is returned unmolested.
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

-- |Monadic variant of if.
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM mpred t f = do
	predicate <- mpred
	if predicate then t else f

-- |Whether a file is . or ..
isDirectoryReference :: FilePath -> Bool
isDirectoryReference = (`elem` [".", ".."])

startsWith :: FilePath -> FilePath -> Bool
startsWith prefix path = take (length prefix) path == prefix

-- All non-directory-reference files in a directory.
-- The returned paths are extensions of the input path.
-- If you have
--     mydir/
--       file1
--       file2
-- then (ls "mydir") yields [mydir/file1, mydir/file2]
ls :: FilePath -> IO [FilePath]
ls dir = do
	children <- getDirectoryContents dir
	pure $ addDirToEach $ filter isRelevant children
	where
	isRelevant = not . isDirectoryReference
	addDirToEach = map (dir </>)

-- |Like ls, but sorted. Directories on the left, files on the right.
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

-- |Creates a watch for a single handler on a single directory.
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

-- |Used to generate watchDir and moveWatchedDir
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 ()
	-- New file created
	event (Created False child) = handler Added (dir </> child)
	-- New directory created.
	event (Created True child) = recurse (dir </> child)
	-- This file modified.
	event (Modified False Nothing) = handler Changed dir
	-- Child file modified.
	event (Modified False (Just child)) = handler Changed (dir </> child)
	-- Directory added via move.
	event (MovedIn True child cookie) = modifyMVar_ (moves watcher) (popM
		(`moveDirTo` (dir </> child))
		(recurse (dir </> child))
		cookie)
	-- File added via move.
	event (MovedIn False child cookie) = modifyMVar_ (moves watcher) (popM
		(`moveFileTo` (dir </> child))
		(handler Added (dir </> child))
		cookie)
	-- Something moved out. If it was moved out of scope, we can't fire events
	-- on it, because we don't know where it moved to. If you move watched/foo
	-- to ../bar, the MovedOut event only knows that watched/foo/ is gone.
	-- There's no way for us to figure out that it went to bar/, recurse bar/,
	-- and fire the moved events manually on the files there. Using inotify,
	-- there's no way for us to send move events unless the moved file lands in
	-- a watched directory.
	event (MovedOut _ child cookie) = modifyMVar_ (moves watcher)
		(pure . Map.insert cookie (dir </> child))
	-- Directory removed.
	event (Deleted True child) = unwatchDir watcher (dir </> child)
	-- File removed.
	event (Deleted False child) = handler Removed (dir </> child)
	-- Not relevant.
	-- Note that we don't in general care about directory modification.
	-- Self events are ignored and passed on to be handled by the parent.
	-- Other non-created/moved/modified/deleted events are ignored.
	event _ = pure ()

-- |Creates watchers on one directory, recursively.
watchDir :: Watcher -> Handler -> FilePath -> IO ()
watchDir watcher handler
	= watchDirWithInitializer (handler Added) watcher handler

-- |Moves a directory, firing the appropriate move events recursively.
-- The subdirectory watchers will be killed and recreated, which is a bit
-- expensive, but is far cleaner than manually maintaining the root-relative
-- path of each directory watcher.
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

-- |Removes the watcher on one subdir and updates the watch dict accordingly.
-- Might be called after the directory has been moved/removed. It is not
-- possible in general to check the contents of the directory.
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

-- |Shuts down all watching and the inotifier.
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

-- |inotify events that are listened to.
relevantEvents :: [EventVariety]
relevantEvents =
	[ Modify
	, Create
	, MoveIn
	, MoveOut
	, Delete
	]