267 lines
8 KiB
Haskell
267 lines
8 KiB
Haskell
{- 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,
|
|
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
|
|
| 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)))
|