cc82f81227
Untested, on FreeBSD but enough to fix the listed build errors. Seems that System.Posix.Files must have used to export this stuff and it was split. This commit was sponsored by Peter on Patreon.
268 lines
8.1 KiB
Haskell
268 lines
8.1 KiB
Haskell
{- BSD kqueue file modification notification interface
|
|
-
|
|
- Copyright 2012 Joey Hess <id@joeyh.name>
|
|
-
|
|
- License: BSD-2-clause
|
|
-}
|
|
|
|
{-# 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.Strict as M
|
|
import qualified Data.Set as S
|
|
import qualified System.Posix.Files as Posix
|
|
import qualified System.Posix.IO as Posix
|
|
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 $
|
|
Posix.openFd dir Posix.ReadOnly Nothing Posix.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_ Posix.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 = Posix.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.insert 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
|
|
| Posix.isSymbolicLink s = callhook addSymlinkHook (Just s) change
|
|
| Posix.isDirectory s = recursiveadd dirmap change
|
|
| Posix.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)))
|