reorg

4 files changed, 609 insertions, 0 deletions

diff --git a/Utility/DirWatcher/FSEvents.hs b/Utility/DirWatcher/FSEvents.hs
new file mode 100644
index 000000000..18c73ec57
--- /dev/null
+++ b/Utility/DirWatcher/FSEvents.hs
@@ -0,0 +1,92 @@
+{- FSEvents interface
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.DirWatcher.FSEvents where
+
+import Common hiding (isDirectory)
+import Utility.DirWatcher.Types
+
+import System.OSX.FSEvents
+import qualified System.Posix.Files as Files
+import Data.Bits ((.&.))
+
+watchDir :: FilePath -> (FilePath -> Bool) -> WatchHooks -> IO EventStream
+watchDir dir ignored hooks = do
+	unlessM fileLevelEventsSupported $
+		error "Need at least OSX 10.7.0 for file-level FSEvents"
+	scan dir
+	eventStreamCreate [dir] 1.0 True True True handle
+  where
+	handle evt
+		| ignoredPath ignored (eventPath evt) = noop
+		| otherwise = do
+			{- More than one flag may be set, if events occurred
+			 - close together. 
+			 - 
+			 - Order is important..
+			 - If a file is added and then deleted, we'll see it's
+			 - not present, and addHook won't run.
+			 - OTOH, if a file is deleted and then re-added,
+			 - the delHook will run first, followed by the addHook.
+			 -}
+
+			when (hasflag eventFlagItemRemoved) $
+				if hasflag eventFlagItemIsDir
+					then runhook delDirHook Nothing
+					else runhook delHook Nothing
+			when (hasflag eventFlagItemCreated) $
+				maybe noop handleadd =<< getstatus (eventPath evt)
+			{- When a file or dir is renamed, a rename event is
+			 - received for both its old and its new name. -}
+			when (hasflag eventFlagItemRenamed) $
+				if hasflag eventFlagItemIsDir
+					then ifM (doesDirectoryExist $ eventPath evt)
+						( scan $ eventPath evt
+						, runhook delDirHook Nothing
+						)
+					else maybe (runhook delHook Nothing) handleadd
+						=<< getstatus (eventPath evt)
+			{- Add hooks are run when a file is modified for 
+			 - compatability with INotify, which calls the add
+			 - hook when a file is closed, and so tends to call
+			 - both add and modify for file modifications. -}
+			when (hasflag eventFlagItemModified && not (hasflag eventFlagItemIsDir)) $ do
+				ms <- getstatus $ eventPath evt
+				maybe noop handleadd ms
+				runhook modifyHook ms
+	  where
+		hasflag f = eventFlags evt .&. f /= 0
+		runhook h s = maybe noop (\a -> a (eventPath evt) s) (h hooks)
+		handleadd s
+			| Files.isSymbolicLink s = runhook addSymlinkHook $ Just s
+			| Files.isRegularFile s = runhook addHook $ Just s
+			| otherwise = noop
+	
+	scan d = unless (ignoredPath ignored d) $
+		mapM_ go =<< dirContentsRecursive d
+	  where		
+		go f
+			| ignoredPath ignored f = noop
+			| otherwise = do
+				ms <- getstatus f
+				case ms of
+					Nothing -> noop
+					Just s
+						| Files.isSymbolicLink s ->
+							runhook addSymlinkHook ms
+						| Files.isRegularFile s ->
+							runhook addHook ms
+						| otherwise ->
+							noop
+		  where
+			runhook h s = maybe noop (\a -> a f s) (h hooks)
+		
+	getstatus = catchMaybeIO . getSymbolicLinkStatus
+
+{- Check each component of the path to see if it's ignored. -}
+ignoredPath :: (FilePath -> Bool) -> FilePath -> Bool
+ignoredPath ignored = any ignored . map dropTrailingPathSeparator . splitPath
diff --git a/Utility/DirWatcher/INotify.hs b/Utility/DirWatcher/INotify.hs
new file mode 100644
index 000000000..922f202a4
--- /dev/null
+++ b/Utility/DirWatcher/INotify.hs
@@ -0,0 +1,185 @@
+{- higher-level inotify interface
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.DirWatcher.INotify where
+
+import Common hiding (isDirectory)
+import Utility.ThreadLock
+import Utility.DirWatcher.Types
+
+import System.INotify
+import qualified System.Posix.Files as Files
+import System.IO.Error
+import Control.Exception (throw)
+
+{- Watches for changes to files in a directory, and all its subdirectories
+ - that are not ignored, using inotify. This function returns after
+ - its initial scan is complete, leaving a thread running. Callbacks are
+ - made for different events.
+ -
+ - Inotify is weak at recursive directory watching; the whole directory
+ - tree must be scanned and watches set explicitly for each subdirectory.
+ -
+ - To notice newly created subdirectories, inotify is used, and
+ - watches are registered for those directories. There is a race there;
+ - things can be added to a directory before the watch gets registered.
+ -
+ - To close the inotify race, each time a new directory is found, it also 
+ - recursively scans it, assuming all files in it were just added,
+ - and registering each subdirectory.
+ -
+ - Note: Due to the race amelioration, multiple add events may occur
+ - for the same file.
+ - 
+ - Note: Moving a file will cause events deleting it from its old location
+ - and adding it to the new location. 
+ - 
+ - Note: It's assumed that when a file that was open for write is closed, 
+ - it's finished being written to, and can be added.
+ -
+ - Note: inotify has a limit to the number of watches allowed,
+ - /proc/sys/fs/inotify/max_user_watches (default 8192).
+ - So this will fail if there are too many subdirectories. The
+ - errHook is called when this happens.
+ -}
+watchDir :: INotify -> FilePath -> (FilePath -> Bool) -> WatchHooks -> IO ()
+watchDir i dir ignored hooks
+	| ignored dir = noop
+	| otherwise = do
+		-- Use a lock to make sure events generated during initial
+		-- scan come before real inotify events.
+		lock <- newLock
+		let handler event = withLock lock (void $ go event)
+		flip catchNonAsync failedwatch $ do
+			void (addWatch i watchevents dir handler)
+				`catchIO` failedaddwatch
+			withLock lock $
+				mapM_ scan =<< filter (not . dirCruft) <$>
+					getDirectoryContents dir
+  where
+	recurse d = watchDir i d ignored hooks
+
+	-- Select only inotify events required by the enabled
+	-- hooks, but always include Create so new directories can
+	-- be scanned.
+	watchevents = Create : addevents ++ delevents ++ modifyevents
+	addevents
+		| hashook addHook || hashook addSymlinkHook = [MoveIn, CloseWrite]
+		| otherwise = []
+	delevents
+		| hashook delHook || hashook delDirHook = [MoveOut, Delete]
+		| otherwise = []
+	modifyevents
+		| hashook modifyHook = [Modify]
+		| otherwise = []
+
+	scan f = unless (ignored f) $ do
+		ms <- getstatus f
+		case ms of
+			Nothing -> return ()
+			Just s
+				| Files.isDirectory s ->
+					recurse $ indir f
+				| Files.isSymbolicLink s ->
+					runhook addSymlinkHook f ms
+				| Files.isRegularFile s ->
+					runhook addHook f ms
+				| otherwise ->
+					noop
+
+	go (Created { isDirectory = isd, filePath = f })
+		| isd = recurse $ indir f
+		| otherwise = do
+			ms <- getstatus f
+			case ms of
+				Just s
+					| Files.isSymbolicLink s -> 
+						when (hashook addSymlinkHook) $
+							runhook addSymlinkHook f ms
+					| Files.isRegularFile s ->
+						when (hashook addHook) $
+							runhook addHook f ms
+				_ -> noop
+	-- Closing a file is assumed to mean it's done being written,
+	-- so a new add event is sent.
+	go (Closed { isDirectory = False, maybeFilePath = Just f }) =
+			checkfiletype Files.isRegularFile addHook f
+	-- When a file or directory is moved in, scan it to add new
+	-- stuff.
+	go (MovedIn { filePath = f }) = scan f
+	go (MovedOut { isDirectory = isd, filePath = f })
+		| isd = runhook delDirHook f Nothing
+		| otherwise = runhook delHook f Nothing
+	-- Verify that the deleted item really doesn't exist,
+	-- since there can be spurious deletion events for items
+	-- in a directory that has been moved out, but is still
+	-- being watched.
+	go (Deleted { isDirectory = isd, filePath = f })
+		| isd = guarded $ runhook delDirHook f Nothing
+		| otherwise = guarded $ runhook delHook f Nothing
+	  where
+		guarded = unlessM (filetype (const True) f)
+	go (Modified { isDirectory = isd, maybeFilePath = Just f })
+		| isd = noop
+		| otherwise = runhook modifyHook f Nothing
+	go _ = noop
+
+	hashook h = isJust $ h hooks
+
+	runhook h f s
+		| ignored f = noop
+		| otherwise = maybe noop (\a -> a (indir f) s) (h hooks)
+
+	indir f = dir </> f
+
+	getstatus f = catchMaybeIO $ getSymbolicLinkStatus $ indir f
+	checkfiletype check h f = do
+		ms <- getstatus f
+		case ms of
+			Just s
+				| check s -> runhook h f ms
+			_ -> noop
+	filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f)
+
+	failedaddwatch e
+		-- Inotify fails when there are too many watches with a
+		-- disk full error.
+		| isFullError e =
+			case errHook hooks of
+				Nothing -> error $ "failed to add inotify watch on directory " ++ dir ++ " (" ++ show e ++ ")"
+				Just hook -> tooManyWatches hook dir
+		-- The directory could have been deleted.
+		| isDoesNotExistError e = return ()
+		| otherwise = throw e
+
+	failedwatch e = hPutStrLn stderr $ "failed to add watch on directory " ++ dir ++ " (" ++ show e ++ ")"
+
+tooManyWatches :: (String -> Maybe FileStatus -> IO ()) -> FilePath -> IO ()
+tooManyWatches hook dir = do
+	sysctlval <- querySysctl [Param maxwatches] :: IO (Maybe Integer)
+	hook (unlines $ basewarning : maybe withoutsysctl withsysctl sysctlval) Nothing
+  where
+	maxwatches = "fs.inotify.max_user_watches"
+	basewarning = "Too many directories to watch! (Not watching " ++ dir ++")"
+	withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"]
+	withsysctl n = let new = n * 10 in
+		[ "Increase the limit permanently by running:"
+		, "  echo " ++ maxwatches ++ "=" ++ show new ++
+		  " | sudo tee -a /etc/sysctl.conf; sudo sysctl -p"
+		, "Or temporarily by running:"
+		, "  sudo sysctl -w " ++ maxwatches ++ "=" ++ show new
+		]
+
+querySysctl :: Read a => [CommandParam] -> IO (Maybe a)
+querySysctl ps = getM go ["sysctl", "/sbin/sysctl", "/usr/sbin/sysctl"]
+  where
+	go p = do
+		v <- catchMaybeIO $ readProcess p (toCommand ps)
+		case v of
+			Nothing -> return Nothing
+			Just s -> return $ parsesysctl s
+	parsesysctl s = readish =<< lastMaybe (words s)
diff --git a/Utility/DirWatcher/Kqueue.hs b/Utility/DirWatcher/Kqueue.hs
new file mode 100644
index 000000000..3ddef603f
--- /dev/null
+++ b/Utility/DirWatcher/Kqueue.hs
@@ -0,0 +1,267 @@
+{- BSD kqueue file modification notification interface
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Utility.DirWatcher.Kqueue (
+	Kqueue,
+	initKqueue,
+	stopKqueue,
+	waitChange,
+	Change(..),
+	changedFile,
+	runHooks,
+) where
+
+import Common
+import Utility.DirWatcher.Types
+
+import System.Posix.Types
+import Foreign.C.Types
+import Foreign.C.Error
+import Foreign.Ptr
+import Foreign.Marshal
+import qualified Data.Map as M
+import qualified Data.Set as S
+import qualified System.Posix.Files as Files
+import Control.Concurrent
+
+data Change
+	= Deleted FilePath
+	| DeletedDir FilePath
+	| Added FilePath
+	deriving (Show)
+
+isAdd :: Change -> Bool
+isAdd (Added _) = True
+isAdd (Deleted _) = False
+isAdd (DeletedDir _) = False
+
+changedFile :: Change -> FilePath
+changedFile (Added f) = f
+changedFile (Deleted f) = f
+changedFile (DeletedDir f) = f
+
+data Kqueue = Kqueue 
+	{ kqueueFd :: Fd
+	, kqueueTop :: FilePath
+	, kqueueMap :: DirMap
+	, _kqueuePruner :: Pruner
+	}
+
+type Pruner = FilePath -> Bool
+
+type DirMap = M.Map Fd DirInfo
+
+{- Enough information to uniquely identify a file in a directory,
+ - but not too much. -}
+data DirEnt = DirEnt
+	{ dirEnt :: FilePath -- relative to the parent directory
+	, _dirInode :: FileID -- included to notice file replacements
+	, isSubDir :: Bool
+	}
+	deriving (Eq, Ord, Show)
+
+{- A directory, and its last known contents. -}
+data DirInfo = DirInfo
+	{ dirName :: FilePath
+	, dirCache :: S.Set DirEnt
+	}
+	deriving (Show)
+
+getDirInfo :: FilePath -> IO DirInfo
+getDirInfo dir = do
+	l <- filter (not . dirCruft) <$> getDirectoryContents dir
+	contents <- S.fromList . catMaybes <$> mapM getDirEnt l
+	return $ DirInfo dir contents
+  where
+	getDirEnt f = catchMaybeIO $ do
+		s <- getSymbolicLinkStatus (dir </> f)
+		return $ DirEnt f (fileID s) (isDirectory s)
+
+{- Difference between the dirCaches of two DirInfos. -}
+(//) :: DirInfo -> DirInfo -> [Change]
+oldc // newc = deleted ++ added
+  where
+	deleted = calc gendel oldc newc
+	added   = calc genadd newc oldc
+	gendel x = (if isSubDir x then DeletedDir else Deleted) $
+		dirName oldc </> dirEnt x
+	genadd x = Added $ dirName newc </> dirEnt x
+	calc a x y = map a $ S.toList $
+		S.difference (dirCache x) (dirCache y)
+
+{- Builds a map of directories in a tree, possibly pruning some.
+ - Opens each directory in the tree, and records its current contents. -}
+scanRecursive :: FilePath -> Pruner -> IO DirMap
+scanRecursive topdir prune = M.fromList <$> walk [] [topdir]
+  where
+	walk c [] = return c
+	walk c (dir:rest)
+		| prune dir = walk c rest
+		| otherwise = do
+			minfo <- catchMaybeIO $ getDirInfo dir
+			case minfo of
+				Nothing -> walk c rest
+				Just info -> do
+					mfd <- catchMaybeIO $
+						openFd dir ReadOnly Nothing defaultFileFlags
+					case mfd of
+						Nothing -> walk c rest
+						Just fd -> do
+							let subdirs = map (dir </>) . map dirEnt $
+								S.toList $ dirCache info
+							walk ((fd, info):c) (subdirs ++ rest)
+
+{- Adds a list of subdirectories (and all their children), unless pruned to a
+ - directory map. Adding a subdirectory that's already in the map will
+ - cause its contents to be refreshed. -}
+addSubDirs :: DirMap -> Pruner -> [FilePath] -> IO DirMap
+addSubDirs dirmap prune dirs = do
+	newmap <- foldr M.union M.empty <$>
+		mapM (\d -> scanRecursive d prune) dirs
+	return $ M.union newmap dirmap -- prefer newmap
+
+{- Removes a subdirectory (and all its children) from a directory map. -}
+removeSubDir :: DirMap -> FilePath -> IO DirMap
+removeSubDir dirmap dir = do
+	mapM_ closeFd $ M.keys toremove
+	return rest
+  where
+	(toremove, rest) = M.partition (dirContains dir . dirName) dirmap
+
+findDirContents :: DirMap -> FilePath -> [FilePath]
+findDirContents dirmap dir = concatMap absolutecontents $ search
+  where
+	absolutecontents i = map (dirName i </>)
+		(map dirEnt $ S.toList $ dirCache i)
+	search = map snd $ M.toList $
+		M.filter (\i -> dirName i == dir) dirmap
+
+foreign import ccall safe "libkqueue.h init_kqueue" c_init_kqueue
+	:: IO Fd
+foreign import ccall safe "libkqueue.h addfds_kqueue" c_addfds_kqueue
+	:: Fd -> CInt -> Ptr Fd -> IO ()
+foreign import ccall safe "libkqueue.h waitchange_kqueue" c_waitchange_kqueue
+	:: Fd -> IO Fd
+
+{- Initializes a Kqueue to watch a directory, and all its subdirectories. -}
+initKqueue :: FilePath -> Pruner -> IO Kqueue
+initKqueue dir pruned = do
+	dirmap <- scanRecursive dir pruned
+	h <- c_init_kqueue
+	let kq = Kqueue h dir dirmap pruned
+	updateKqueue kq
+	return kq
+
+{- Updates a Kqueue, adding watches for its map. -}
+updateKqueue :: Kqueue -> IO ()
+updateKqueue (Kqueue h _ dirmap _) =
+	withArrayLen (M.keys dirmap) $ \fdcnt c_fds -> do
+		c_addfds_kqueue h (fromIntegral fdcnt) c_fds
+
+{- Stops a Kqueue. Note: Does not directly close the Fds in the dirmap,
+ - so it can be reused.  -}
+stopKqueue :: Kqueue -> IO ()
+stopKqueue = closeFd . kqueueFd
+
+{- Waits for a change on a Kqueue.
+ - May update the Kqueue.
+ -}
+waitChange :: Kqueue -> IO (Kqueue, [Change])
+waitChange kq@(Kqueue h _ dirmap _) = do
+	changedfd <- c_waitchange_kqueue h
+	if changedfd == -1
+		then ifM ((==) eINTR <$> getErrno)
+			(yield >> waitChange kq, nochange)
+		else case M.lookup changedfd dirmap of
+			Nothing -> nochange
+			Just info -> handleChange kq changedfd info
+  where
+	nochange = return (kq, [])
+
+{- The kqueue interface does not tell what type of change took place in
+ - the directory; it could be an added file, a deleted file, a renamed
+ - file, a new subdirectory, or a deleted subdirectory, or a moved
+ - subdirectory. 
+ -
+ - So to determine this, the contents of the directory are compared
+ - with its last cached contents. The Kqueue is updated to watch new
+ - directories as necessary.
+ -}
+handleChange :: Kqueue -> Fd -> DirInfo -> IO (Kqueue, [Change])
+handleChange kq@(Kqueue _ _ dirmap pruner) fd olddirinfo =
+	go =<< catchMaybeIO (getDirInfo $ dirName olddirinfo)
+  where
+	go (Just newdirinfo) = do
+		let changes = filter (not . pruner . changedFile) $
+			 olddirinfo // newdirinfo
+		let (added, deleted) = partition isAdd changes
+
+		-- Scan newly added directories to add to the map.
+		-- (Newly added files will fail getDirInfo.)
+		newdirinfos <- catMaybes <$>
+			mapM (catchMaybeIO . getDirInfo . changedFile) added
+		newmap <- addSubDirs dirmap pruner $ map dirName newdirinfos
+
+		-- Remove deleted directories from the map.
+		newmap' <- foldM removeSubDir newmap (map changedFile deleted)
+
+		-- Update the cached dirinfo just looked up.
+		let newmap'' = M.insertWith' const fd newdirinfo newmap'
+
+		-- When new directories were added, need to update
+		-- the kqueue to watch them.
+		let kq' = kq { kqueueMap = newmap'' }
+		unless (null newdirinfos) $
+			updateKqueue kq'
+
+		return (kq', changes)
+	go Nothing = do
+		-- The directory has been moved or deleted, so
+		-- remove it from our map.
+		newmap <- removeSubDir dirmap (dirName olddirinfo)
+		return (kq { kqueueMap = newmap }, [])
+
+{- Processes changes on the Kqueue, calling the hooks as appropriate.
+ - Never returns. -}
+runHooks :: Kqueue -> WatchHooks -> IO ()
+runHooks kq hooks = do
+	-- First, synthetic add events for the whole directory tree contents,
+	-- to catch any files created beforehand.
+	recursiveadd (kqueueMap kq) (Added $ kqueueTop kq)
+	loop kq
+  where
+	loop q = do
+		(q', changes) <- waitChange q
+		forM_ changes $ dispatch (kqueueMap q')
+		loop q'
+
+	dispatch _ change@(Deleted _) = 
+		callhook delHook Nothing change
+	dispatch _ change@(DeletedDir _) =
+		callhook delDirHook Nothing change
+	dispatch dirmap change@(Added _) =
+		withstatus change $ dispatchadd dirmap
+		
+	dispatchadd dirmap change s
+		| Files.isSymbolicLink s = callhook addSymlinkHook (Just s) change
+		| Files.isDirectory s = recursiveadd dirmap change
+		| Files.isRegularFile s = callhook addHook (Just s) change
+		| otherwise = noop
+
+	recursiveadd dirmap change = do
+		let contents = findDirContents dirmap $ changedFile change
+		forM_ contents $ \f ->
+			withstatus (Added f) $ dispatchadd dirmap
+
+	callhook h s change = case h hooks of
+		Nothing -> noop
+		Just a -> a (changedFile change) s
+
+	withstatus change a = maybe noop (a change) =<<
+		(catchMaybeIO (getSymbolicLinkStatus (changedFile change)))
diff --git a/Utility/DirWatcher/Win32Notify.hs b/Utility/DirWatcher/Win32Notify.hs
new file mode 100644
index 000000000..74b36b4f1
--- /dev/null
+++ b/Utility/DirWatcher/Win32Notify.hs
@@ -0,0 +1,65 @@
+{- Win32-notify interface
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.DirWatcher.Win32Notify where
+
+import Common hiding (isDirectory)
+import Utility.DirWatcher.Types
+
+import System.Win32.Notify
+import qualified System.PosixCompat.Files as Files
+
+watchDir :: FilePath -> (FilePath -> Bool) -> WatchHooks -> IO WatchManager
+watchDir dir ignored hooks = do
+	scan dir
+	wm <- initWatchManager
+	void $ watchDirectory wm dir True [Create, Delete, Modify, Move] handle
+	return wm
+  where
+	handle evt
+		| ignoredPath ignored (filePath evt) = noop
+		| otherwise = case evt of
+			(Deleted _ _)
+				| isDirectory evt -> runhook delDirHook Nothing
+				| otherwise -> runhook delHook Nothing
+			(Created _ _)
+				| isDirectory evt -> noop
+				| otherwise -> runhook addHook Nothing
+			(Modified _ _)
+				| isDirectory evt -> noop
+				{- Add hooks are run when a file is modified for 
+				 - compatability with INotify, which calls the add
+				 - hook when a file is closed, and so tends to call
+				 - both add and modify for file modifications. -}
+				| otherwise -> do
+					runhook addHook Nothing
+					runhook modifyHook Nothing
+	  where
+		runhook h s = maybe noop (\a -> a (filePath evt) s) (h hooks)
+
+	scan d = unless (ignoredPath ignored d) $
+		mapM_ go =<< dirContentsRecursive d
+	  where		
+		go f
+			| ignoredPath ignored f = noop
+			| otherwise = do
+				ms <- getstatus f
+				case ms of
+					Nothing -> noop
+					Just s
+						| Files.isRegularFile s ->
+							runhook addHook ms
+						| otherwise ->
+							noop
+		  where
+			runhook h s = maybe noop (\a -> a f s) (h hooks)
+		
+	getstatus = catchMaybeIO . getFileStatus
+
+{- Check each component of the path to see if it's ignored. -}
+ignoredPath :: (FilePath -> Bool) -> FilePath -> Bool
+ignoredPath ignored = any ignored . map dropTrailingPathSeparator . splitPath