watcher-0.0.3.0: src/Watcher.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Watcher
	( watch
	, unwatch
	, Action(Added, Changed, Moved, Removed)
	, Warning(MovedOutOfScope)
	, Watcher
	, Handler
	) where
import BasicPrelude hiding (stripPrefix, mapM)
import Control.Concurrent
	( MVar
	, newMVar
	, modifyMVar_
	, withMVar )
import qualified Data.Map as Map
import Data.Traversable (mapM)
import Filesystem
import Filesystem.Path.CurrentOS
import System.INotify
	( Cookie
	, EventVariety(Create, Modify, Delete, MoveIn, MoveOut)
	, Event(Created, Modified, Deleted, MovedIn, MovedOut)
	, INotify
	, WatchDescriptor
	, addWatch
	, initINotify
	, killINotify
	, removeWatch )


-- |The types of actions that are reported.
data Action
	= Added
	| Changed
	-- NOTE: It is the user's responsibility to check if the destination already
	-- existed and, in the event that a file was overwritten, handle the
	-- overwritten file's removal.
	| 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


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


-- |Makes path relative to base.
makeRelative :: FilePath -> FilePath -> FilePath
makeRelative base path = fromMaybe path stripped
	where
	stripped = stripPrefix (commonPrefix [base, path]) path


-- |Whether or not path starts with prefix.
startsWith :: FilePath -> FilePath -> Bool
startsWith prefix path = commonPrefix [prefix, path] == prefix


-- |Like listDirectory, but partitioned: directories left, files right.
directoriesAndFiles :: FilePath -> IO [Either FilePath FilePath]
directoriesAndFiles path = mapM divvy =<< listDirectory path
	where
	divvy x = ifM (isDirectory 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
	-- Ensures that the path is treated as a directory.
	let dirpath = filepath </> ""
	isDir <- isDirectory dirpath
	unless isDir $ ioError $
		userError $ "Not a directory: " ++ encodeString dirpath
	watcher <- Watcher
		<$> initINotify
		<*> newMVar Map.empty
		<*> newMVar Map.empty
	watchDir watcher handler dirpath
	pure watcher


-- |Used to generate watchDir and moveWatchedDir
watchDirWithInitializer
	:: (FilePath -> IO ())
	-> Watcher
	-> Handler
	-> FilePath
	-> IO ()
watchDirWithInitializer initialize watcher handler filepath = do
	-- The filepath, guaranteed to be treated like a directory.
	let strdir = encodeString dir
	watchd <- addWatch (notifier watcher) relevantEvents strdir event
	modifyMVar_ (descriptors watcher) (pure . Map.insert dir watchd)
	mapM_ (either recurse initialize) =<< directoriesAndFiles dir
	where
	dir = filepath </> ""
	into child = dir </> decodeString child
	recurse = watchDirWithInitializer initialize watcher handler
	descend = recurse . into
	ascend = unwatchDir watcher . into
	add = handler Added . into
	remove = handler Removed . into
	change = handler Changed . into
	prepMove child cookie = modifyMVar_ (moves watcher)
		(pure . Map.insert cookie (into child))
	moveFile child cookie = modifyMVar_ (moves watcher) (\dict ->
		let source = dict Map.! cookie in
		if cookie `Map.member` dict
		then do
			handler (Moved source) (into child)
			pure $ Map.delete cookie dict
		else handler Added (into child) *> pure dict)
	moveDir child cookie = modifyMVar_ (moves watcher) (\dict ->
		let source = dict Map.! cookie in
		if cookie `Map.member` dict
		then do
			moveWatchedDir source watcher handler (into child)
			pure $ Map.delete cookie dict
		else recurse (into child) *> pure dict)
	event ev = case ev of
		-- New file created
		Created False child -> add child
		-- New directory created.
		Created True child -> descend child
		-- This file modified.
		Modified False Nothing -> handler Changed dir
		-- Child file modified.
		Modified False (Just child) -> change child
		-- Directory added via move.
		MovedIn True child cookie -> moveDir child cookie
		-- File added via move.
		MovedIn False child cookie -> moveFile 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.
		MovedOut _ child cookie -> prepMove child cookie
		-- Directory removed.
		Deleted True child -> ascend child
		-- File removed.
		Deleted False child -> remove child
		-- Not relevant.
		-- 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.
		_ -> 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
	]