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
|
{- 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 (
initKqueue,
stopKqueue,
waitChange,
Change(..),
changedFile,
isAdd,
isDelete,
) where
import Common
import System.Posix.Types
import Foreign.C.Types
import Foreign.Ptr
import Foreign.Marshal
import qualified Data.Map as M
import qualified Data.Set as S
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 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]
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
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 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 (Kqueue h _ _) = closeFd h
{- 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
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.
-
- 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 (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'
-- When new directories were added, need to update
-- the kqueue to watch them.
let kq' = Kqueue h newmap'' pruner
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 (Kqueue h newmap pruner, [])
|
