diff options
Diffstat (limited to 'Utility')
| -rw-r--r-- | Utility/Directory.hs | 27 | ||||
| -rw-r--r-- | Utility/Kqueue.hs | 162 |
2 files changed, 121 insertions, 68 deletions
diff --git a/Utility/Directory.hs b/Utility/Directory.hs index b8ed63a36..2f2960a9d 100644 --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -56,33 +56,6 @@ dirContentsRecursive' topdir (dir:dirs) = unsafeInterleaveIO $ do , collect (dirEntry:files) dirs' entries ) -{- Gets the subdirectories in a directory, and their subdirectories, - - recursively, and lazily. Prunes sections of the tree matching a - - condition. -} -dirTree :: FilePath -> (FilePath -> Bool) -> IO [FilePath] -dirTree topdir prune - | prune topdir = return [] - | otherwise = (:) topdir <$> dirTree' topdir prune [""] - -dirTree' :: FilePath -> (FilePath -> Bool) -> [FilePath] -> IO [FilePath] -dirTree' _ _ [] = return [] -dirTree' topdir prune (dir:dirs) - | prune dir = dirTree' topdir prune dirs - | otherwise = unsafeInterleaveIO $ do - subdirs <- collect [] =<< dirContents (topdir </> dir) - subdirs' <- dirTree' topdir prune (subdirs ++ dirs) - return $ subdirs ++ subdirs' - where - collect dirs' [] = return dirs' - collect dirs' (entry:entries) - | dirCruft entry || prune entry = collect dirs' entries - | otherwise = do - let dirEntry = dir </> entry - ifM (doesDirectoryExist $ topdir </> dirEntry) - ( collect (dirEntry:dirs') entries - , collect dirs' entries - ) - {- Moves one filename to another. - First tries a rename, but falls back to moving across devices if needed. -} moveFile :: FilePath -> FilePath -> IO () diff --git a/Utility/Kqueue.hs b/Utility/Kqueue.hs index d0b3c8a99..911eb71a9 100644 --- a/Utility/Kqueue.hs +++ b/Utility/Kqueue.hs @@ -8,14 +8,10 @@ {-# LANGUAGE ForeignFunctionInterface #-} module Utility.Kqueue ( - scanRecursive, - addSubDir, - removeSubDir, - initKqueue, stopKqueue, - waitChange, + Change(..), ) where import Common @@ -25,60 +21,144 @@ import Foreign.C.Types import Foreign.Ptr import Foreign.Marshal import qualified Data.Map as M +import qualified Data.Set as S + +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 -type DirMap = M.Map Fd FilePath +data Kqueue = Kqueue Fd DirMap Pruner -data Kqueue = Kqueue Fd DirMap +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] +old // new = deleted ++ added + where + deleted = calc Deleted old new + added = calc Added new old + 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. -} -scanRecursive :: FilePath -> (FilePath -> Bool) -> IO DirMap -scanRecursive dir prune = M.fromList <$> (mapM opendir =<< dirTree dir prune) + - Opens each directory in the tree, and records its current contents. -} +scanRecursive :: FilePath -> Pruner -> IO DirMap +scanRecursive topdir prune = M.fromList <$> walk [] [topdir] where - opendir d = (,) - <$> openFd d ReadOnly Nothing defaultFileFlags - <*> pure d - -{- Adds a subdirectory (and all its subdirectories, unless pruned) to a - - directory map. -} -addSubDir :: DirMap -> FilePath -> (FilePath -> Bool) -> IO DirMap -addSubDir dirmap dir prune = M.union dirmap <$> scanRecursive dir prune - -{- Removes a subdirectory (and all its subdirectories) from a directory map. -} -removeSubDir :: FilePath -> DirMap -> IO DirMap -removeSubDir dir dirmap = do - mapM_ closeFd $ M.keys toremove) $ closeFd + walk c [] = return c + walk c (dir:rest) + | prune dir = walk c rest + | otherwise = do + info <- getDirInfo dir + fd <- openFd dir ReadOnly Nothing defaultFileFlags + dirs <- filterM (\d -> doesDirectoryExist $ dir </> d) + (S.toList $ dirCache info) + walk ((fd, info):c) (dirs++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) dirmap + (toremove, rest) = M.partition (dirContains dir . dirName) dirmap foreign import ccall unsafe "libkqueue.h init_kqueue" c_init_kqueue :: CInt -> Ptr Fd -> IO Fd foreign import ccall unsafe "libkqueue.h waitchange_kqueue" c_waitchange_kqueue :: Fd -> IO Fd -{- Initializes a Kqueue to watch a map of directories. -} -initKqueue :: DirMap -> IO Kqueue -initKqueue dirmap = withArrayLen (M.keys dirmap) $ \fdcnt c_fds -> do - h <- c_init_kqueue (fromIntegral fdcnt) c_fds - return $ Kqueue h dirmap +{- Initializes a Kqueue to watch a directory, and all its subdirectories. -} +initKqueue :: FilePath -> Pruner -> IO Kqueue +initKqueue dir pruned = do + dirmap <- scanRecursive dir pruned + withArrayLen (M.keys dirmap) $ \fdcnt c_fds -> do + h <- c_init_kqueue (fromIntegral fdcnt) c_fds + return $ Kqueue h dirmap pruned {- Stops a Kqueue. Note: Does not directly close the Fds in the dirmap, - so it can be reused. -} stopKqueue :: Kqueue -> IO () -stopKqueue (Kqueue h _) = closeFd h +stopKqueue (Kqueue h _ _) = closeFd h -{- Waits for a change on a Kqueue, and returns the directory - - where a change took place. - - - - The kqueue interface does not tell what type of change took place in +{- 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 + case M.lookup changedfd dirmap of + Nothing -> return (kq, []) + Just info -> handleChange kq changedfd info + +{- 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. + - subdirectory. - - - Note that if subdirectories have changed, the caller should re-run - - initKqueue to get them watched. -} -waitChange :: Kqueue -> IO (Maybe FilePath) -waitChange (Kqueue h dirmap) = do - changed <- c_waitchange_kqueue h - return $ M.lookup changed dirmap + - 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 h 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' + ret (newmap'', changes) + go Nothing = do + -- The directory has been moved or deleted, so + -- remove it from our map. + newmap <- removeSubDir dirmap (dirName olddirinfo) + ret (newmap, []) + ret (newmap, changes) = return $ (Kqueue h newmap pruner, changes) |