kqueue: add directory content tracking, and change determination

This *may* now return Add or Delete Changes as appropriate. All I know
for sure is that it compiles.

I had hoped to avoid maintaining my own state about the content of the
directory tree, and rely on git to check what was changed. But I can't;
I need to know about new and deleted subdirectories to add them to the
watch list, and git doesn't deal with (empty) directories.

So, wrote all the code to scan directories, remember their past contents,
compare with current contents, generate appropriate Change events, and
update bookkeeping info appropriately.

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 ()

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
 
-type DirMap = M.Map Fd FilePath
+data Change
+	= Deleted FilePath
+	| Added FilePath
+	deriving (Show)
 
-data Kqueue = Kqueue Fd DirMap
+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
+
+data Kqueue = Kqueue Fd DirMap Pruner
+
+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. -}
+ - Opens each directory in the tree, and records its current contents. -}
-scanRecursive :: FilePath -> (FilePath -> Bool) -> IO DirMap
+scanRecursive :: FilePath -> Pruner -> IO DirMap
-scanRecursive dir prune = M.fromList <$> (mapM opendir =<< dirTree dir prune)
+scanRecursive topdir prune = M.fromList <$> walk [] [topdir]
 	where
-		opendir d = (,)
+		walk c [] = return c
-			<$> openFd d ReadOnly Nothing defaultFileFlags
+		walk c (dir:rest)
-			<*> pure d
+			| 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 subdirectory (and all its subdirectories, unless pruned) to a
+{- Adds a list of subdirectories (and all their children), unless pruned to a
- - directory map. -}
+ - directory map. Adding a subdirectory that's already in the map will
-addSubDir :: DirMap -> FilePath -> (FilePath -> Bool) -> IO DirMap
+ - cause its contents to be refreshed. -}
-addSubDir dirmap dir prune = M.union dirmap <$> scanRecursive dir prune
+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 subdirectories) from a directory map. -}
+{- Removes a subdirectory (and all its children) from a directory map. -}
-removeSubDir :: FilePath -> DirMap -> IO DirMap
+removeSubDir :: DirMap -> FilePath -> IO DirMap
-removeSubDir dir dirmap = do
+removeSubDir dirmap dir = do
-	mapM_ closeFd $ M.keys toremove) $ closeFd
+	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. -}
+{- Initializes a Kqueue to watch a directory, and all its subdirectories. -}
-initKqueue :: DirMap -> IO Kqueue
+initKqueue :: FilePath -> Pruner -> IO Kqueue
-initKqueue dirmap = withArrayLen (M.keys dirmap) $ \fdcnt c_fds -> do
+initKqueue dir pruned = do
-	h <- c_init_kqueue (fromIntegral fdcnt) c_fds
+	dirmap <- scanRecursive dir pruned
-	return $ Kqueue h dirmap
+	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
+{- Waits for a change on a Kqueue.
- - where a change took place.
+ - May update the Kqueue.
- -
+ -}
- - The kqueue interface does not tell what type of change took place in
+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
+ - So to determine this, the contents of the directory are compared
- - initKqueue to get them watched. -}
+ - with its last cached contents. The Kqueue is updated to watch new
-waitChange :: Kqueue -> IO (Maybe FilePath)
+ - directories as necessary.
-waitChange (Kqueue h dirmap) = do
+ -}
-	changed <- c_waitchange_kqueue h
+handleChange :: Kqueue -> Fd -> DirInfo -> IO (Kqueue, [Change])
-	return $ M.lookup changed dirmap
+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)