summaryrefslogtreecommitdiff
path: root/Utility/Kqueue.hs
blob: 7e7e653ec36d2e2f2071c456f7c4a0610bb796da (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
{- 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,
	isAdd,
	isDelete,
	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
	| Added FilePath
	deriving (Show)

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 
	{ kqueueFd :: Fd
	, kqueueTop :: FilePath
	, kqueueMap :: DirMap
	, _kqueuePruner :: 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]
oldc // newc = deleted ++ added
	where
		deleted = calc Deleted oldc newc
		added   = calc Added newc oldc
		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, 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 </>) $
									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 </>) (S.toList $ dirCache i)
		search = map snd $ M.toList $
			M.filter (\i -> dirName i == dir) dirmap

foreign import ccall unsafe "libkqueue.h init_kqueue" c_init_kqueue
	:: IO Fd
foreign import ccall unsafe "libkqueue.h addfds_kqueue" c_addfds_kqueue
	:: Fd -> CInt -> Ptr Fd -> IO ()
foreign import ccall unsafe "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 = 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'
		-- Kqueue returns changes for both whole directories
		-- being added and deleted, and individual files being
		-- added and deleted.
		dispatch dirmap change
			| isAdd change = withstatus change $ dispatchadd dirmap
			| otherwise = callhook delDirHook Nothing change
		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)))