diff options
Diffstat (limited to 'Utility/Kqueue.hs')
-rw-r--r-- | Utility/Kqueue.hs | 248 |
1 files changed, 248 insertions, 0 deletions
diff --git a/Utility/Kqueue.hs b/Utility/Kqueue.hs new file mode 100644 index 000000000..7e7e653ec --- /dev/null +++ b/Utility/Kqueue.hs @@ -0,0 +1,248 @@ +{- 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.Kqueue ( + Kqueue, + initKqueue, + stopKqueue, + waitChange, + Change(..), + changedFile, + isAdd, + isDelete, + runHooks, +) where + +import Common +import Utility.Types.DirWatcher + +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 + | Added FilePath + deriving (Show) + +isAdd :: Change -> Bool +isAdd (Added _) = True +isAdd (Deleted _) = False + +isDelete :: Change -> Bool +isDelete = not . isAdd + +changedFile :: Change -> FilePath +changedFile (Added f) = f +changedFile (Deleted f) = f + +data Kqueue = Kqueue + { kqueueFd :: Fd + , kqueueTop :: FilePath + , kqueueMap :: DirMap + , _kqueuePruner :: Pruner + } + +type Pruner = FilePath -> Bool + +type DirMap = M.Map Fd DirInfo + +{- A directory, and its last known contents (with filenames relative to it) -} +data DirInfo = DirInfo + { dirName :: FilePath + , dirCache :: S.Set FilePath + } + deriving (Show) + +getDirInfo :: FilePath -> IO DirInfo +getDirInfo dir = do + contents <- S.fromList . filter (not . dirCruft) + <$> getDirectoryContents dir + return $ DirInfo dir contents + +{- Difference between the dirCaches of two DirInfos. -} +(//) :: DirInfo -> DirInfo -> [Change] +oldc // newc = deleted ++ added + where + deleted = calc Deleted oldc newc + added = calc Added newc oldc + calc a x y = map a . map (dirName x </>) $ + 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 </>) $ + 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 </>) (S.toList $ dirCache i) + search = map snd $ M.toList $ + M.filter (\i -> dirName i == dir) dirmap + +foreign import ccall unsafe "libkqueue.h init_kqueue" c_init_kqueue + :: IO Fd +foreign import ccall unsafe "libkqueue.h addfds_kqueue" c_addfds_kqueue + :: Fd -> CInt -> Ptr Fd -> IO () +foreign import ccall unsafe "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 = 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' + -- Kqueue returns changes for both whole directories + -- being added and deleted, and individual files being + -- added and deleted. + dispatch dirmap change + | isAdd change = withstatus change $ dispatchadd dirmap + | otherwise = callhook delDirHook Nothing change + 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))) |