git-annex/Utility/DirWatcher/Kqueue.hs

{- 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 Utility.OpenFd

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 $
						openFdWithMode (toRawFilePath 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 (toRawFilePath dir) . toRawFilePath . 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)))