diff options
Diffstat (limited to 'Utility/Kqueue.hs')
| -rw-r--r-- | Utility/Kqueue.hs | 68 |
1 files changed, 44 insertions, 24 deletions
diff --git a/Utility/Kqueue.hs b/Utility/Kqueue.hs index 7e7e653ec..f44893195 100644 --- a/Utility/Kqueue.hs +++ b/Utility/Kqueue.hs @@ -14,8 +14,6 @@ module Utility.Kqueue ( waitChange, Change(..), changedFile, - isAdd, - isDelete, runHooks, ) where @@ -34,19 +32,19 @@ import Control.Concurrent data Change = Deleted FilePath + | DeletedDir FilePath | Added FilePath deriving (Show) isAdd :: Change -> Bool isAdd (Added _) = True isAdd (Deleted _) = False - -isDelete :: Change -> Bool -isDelete = not . isAdd +isAdd (DeletedDir _) = False changedFile :: Change -> FilePath changedFile (Added f) = f changedFile (Deleted f) = f +changedFile (DeletedDir f) = f data Kqueue = Kqueue { kqueueFd :: Fd @@ -59,27 +57,43 @@ type Pruner = FilePath -> Bool type DirMap = M.Map Fd DirInfo -{- A directory, and its last known contents (with filenames relative to it) -} +{- 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 FilePath + , dirCache :: S.Set DirEnt } deriving (Show) getDirInfo :: FilePath -> IO DirInfo getDirInfo dir = do - contents <- S.fromList . filter (not . dirCruft) - <$> getDirectoryContents dir + 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) {- 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) + 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. -} @@ -99,7 +113,7 @@ scanRecursive topdir prune = M.fromList <$> walk [] [topdir] case mfd of Nothing -> walk c rest Just fd -> do - let subdirs = map (dir </>) $ + let subdirs = map (dir </>) . map dirEnt $ S.toList $ dirCache info walk ((fd, info):c) (subdirs ++ rest) @@ -123,15 +137,16 @@ removeSubDir dirmap dir = do findDirContents :: DirMap -> FilePath -> [FilePath] findDirContents dirmap dir = concatMap absolutecontents $ search where - absolutecontents i = map (dirName i </>) (S.toList $ dirCache i) + 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 unsafe "libkqueue.h init_kqueue" c_init_kqueue +foreign import ccall safe "libkqueue.h init_kqueue" c_init_kqueue :: IO Fd -foreign import ccall unsafe "libkqueue.h addfds_kqueue" c_addfds_kqueue +foreign import ccall safe "libkqueue.h addfds_kqueue" c_addfds_kqueue :: Fd -> CInt -> Ptr Fd -> IO () -foreign import ccall unsafe "libkqueue.h waitchange_kqueue" c_waitchange_kqueue +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. -} @@ -224,12 +239,14 @@ runHooks kq hooks = 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 + + 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 @@ -237,12 +254,15 @@ runHooks kq hooks = do | 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))) |