reorg
This commit is contained in:
parent
c08a4d3d93
commit
c077cee44a
5 changed files with 8 additions and 8 deletions
267
Utility/DirWatcher/Kqueue.hs
Normal file
267
Utility/DirWatcher/Kqueue.hs
Normal file
|
@ -0,0 +1,267 @@
|
|||
{- 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.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)))
|
Loading…
Add table
Add a link
Reference in a new issue