summaryrefslogtreecommitdiff
path: root/Utility/Kqueue.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Utility/Kqueue.hs')
-rw-r--r--Utility/Kqueue.hs196
1 files changed, 97 insertions, 99 deletions
diff --git a/Utility/Kqueue.hs b/Utility/Kqueue.hs
index 4b72961b2..f9f965f6f 100644
--- a/Utility/Kqueue.hs
+++ b/Utility/Kqueue.hs
@@ -78,44 +78,44 @@ 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 <- getFileStatus (dir </> f)
- return $ DirEnt f (fileID s) (isDirectory s)
+ where
+ getDirEnt f = catchMaybeIO $ do
+ s <- getFileStatus (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)
+ 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)
+ 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
@@ -131,16 +131,16 @@ 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
+ 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
+ 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
@@ -181,8 +181,8 @@ waitChange kq@(Kqueue h _ dirmap _) = do
else case M.lookup changedfd dirmap of
Nothing -> nochange
Just info -> handleChange kq changedfd info
- where
- nochange = return (kq, [])
+ 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
@@ -196,36 +196,36 @@ waitChange kq@(Kqueue h _ dirmap _) = do
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 }, [])
+ 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. -}
@@ -235,35 +235,33 @@ runHooks kq hooks = do
-- 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
+ 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)))
+ 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)))
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-30 21:58:33 +0000