From 38480793489981910d3e53c8dc978c97ee7abd4c Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 4 Dec 2013 23:09:54 -0400 Subject: reorg --- Utility/DirWatcher.hs | 8 +- Utility/DirWatcher/FSEvents.hs | 92 +++++++++++++ Utility/DirWatcher/INotify.hs | 185 ++++++++++++++++++++++++++ Utility/DirWatcher/Kqueue.hs | 267 ++++++++++++++++++++++++++++++++++++++ Utility/DirWatcher/Win32Notify.hs | 65 ++++++++++ Utility/FSEvents.hs | 92 ------------- Utility/INotify.hs | 185 -------------------------- Utility/Kqueue.hs | 267 -------------------------------------- Utility/Win32Notify.hs | 65 ---------- 9 files changed, 613 insertions(+), 613 deletions(-) create mode 100644 Utility/DirWatcher/FSEvents.hs create mode 100644 Utility/DirWatcher/INotify.hs create mode 100644 Utility/DirWatcher/Kqueue.hs create mode 100644 Utility/DirWatcher/Win32Notify.hs delete mode 100644 Utility/FSEvents.hs delete mode 100644 Utility/INotify.hs delete mode 100644 Utility/Kqueue.hs delete mode 100644 Utility/Win32Notify.hs (limited to 'Utility') diff --git a/Utility/DirWatcher.hs b/Utility/DirWatcher.hs index 5231286fc..9eeddce3d 100644 --- a/Utility/DirWatcher.hs +++ b/Utility/DirWatcher.hs @@ -16,19 +16,19 @@ module Utility.DirWatcher where import Utility.DirWatcher.Types #if WITH_INOTIFY -import qualified Utility.INotify as INotify +import qualified Utility.DirWatcher.INotify as INotify import qualified System.INotify as INotify #endif #if WITH_KQUEUE -import qualified Utility.Kqueue as Kqueue +import qualified Utility.DirWatcher.Kqueue as Kqueue import Control.Concurrent #endif #if WITH_FSEVENTS -import qualified Utility.FSEvents as FSEvents +import qualified Utility.DirWatcher.FSEvents as FSEvents import qualified System.OSX.FSEvents as FSEvents #endif #if WITH_WIN32NOTIFY -import qualified Utility.Win32Notify as Win32Notify +import qualified Utility.DirWatcher.Win32Notify as Win32Notify import qualified System.Win32.Notify as Win32Notify #endif 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 + - + - 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 + - + - 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 + - + - 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 + - + - 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 diff --git a/Utility/FSEvents.hs b/Utility/FSEvents.hs deleted file mode 100644 index d6663e9d7..000000000 --- a/Utility/FSEvents.hs +++ /dev/null @@ -1,92 +0,0 @@ -{- FSEvents interface - - - - Copyright 2012 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Utility.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/INotify.hs b/Utility/INotify.hs deleted file mode 100644 index ffdad8be3..000000000 --- a/Utility/INotify.hs +++ /dev/null @@ -1,185 +0,0 @@ -{- higher-level inotify interface - - - - Copyright 2012 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Utility.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/Kqueue.hs b/Utility/Kqueue.hs deleted file mode 100644 index eb5feab00..000000000 --- a/Utility/Kqueue.hs +++ /dev/null @@ -1,267 +0,0 @@ -{- BSD kqueue file modification notification interface - - - - Copyright 2012 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE ForeignFunctionInterface #-} - -module Utility.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/Win32Notify.hs b/Utility/Win32Notify.hs deleted file mode 100644 index edde5309c..000000000 --- a/Utility/Win32Notify.hs +++ /dev/null @@ -1,65 +0,0 @@ -{- Win32-notify interface - - - - Copyright 2013 Joey Hess - - - - Licensed under the GNU GPL version 3 or higher. - -} - -module Utility.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 -- cgit v1.2.3