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
|
{- higher-level inotify interface
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Utility.Inotify where
import Common hiding (isDirectory)
import Utility.ThreadLock
import System.INotify
import qualified System.Posix.Files as Files
import System.IO.Error
import Control.Exception (throw)
{- A hook is passed some value to act on.
-
- The Bool is False when we're in the intial scan of a directory tree,
- rather than having received a genuine inotify event. -}
type Hook a = Maybe (a -> Bool -> IO ())
data WatchHooks = WatchHooks
{ addHook :: Hook FilePath
, addSymlinkHook :: Hook FilePath
, delHook :: Hook FilePath
, delDirHook :: Hook FilePath
, errHook :: Hook String -- error message
}
{- Watches for changes to files in a directory, and all its subdirectories
- that are not ignored, using inotify. This function returns after
- its initial scan is complete, leaving a thread running. Callbacks are
- made for different events.
-
- Inotify is weak at recursive directory watching; the whole directory
- tree must be scanned and watches set explicitly for each subdirectory.
-
- To notice newly created subdirectories, inotify is used, and
- watches are registered for those directories. There is a race there;
- things can be added to a directory before the watch gets registered.
-
- To close the inotify race, each time a new directory is found, it also
- recursively scans it, assuming all files in it were just added,
- and registering each subdirectory.
-
- Note: Due to the race amelioration, multiple add events may occur
- for the same file.
-
- Note: Moving a file will cause events deleting it from its old location
- and adding it to the new location.
-
- Note: Modification of files is not detected, and it's assumed that when
- a file that was open for write is closed, it's finished being written
- to, and can be added.
-
- Note: inotify has a limit to the number of watches allowed,
- /proc/sys/fs/inotify/max_user_watches (default 8192).
- So this will fail if there are too many subdirectories. The
- errHook is called when this happens.
-}
watchDir :: INotify -> FilePath -> (FilePath -> Bool) -> WatchHooks -> IO ()
watchDir i dir ignored hooks
| ignored dir = noop
| otherwise = do
lock <- newLock
let handler event = withLock lock (void $ go event)
void (addWatch i watchevents dir handler)
`catchIO` failedaddwatch
withLock lock $
mapM_ scan =<< filter (not . dirCruft) <$>
getDirectoryContents dir
where
recurse d = watchDir i d ignored hooks
-- Select only inotify events required by the enabled
-- hooks, but always include Create so new directories can
-- be scanned.
watchevents = Create : addevents ++ delevents
addevents
| hashook addHook || hashook addSymlinkHook = [MoveIn, CloseWrite]
| otherwise = []
delevents
| hashook delHook || hashook delDirHook = [MoveOut, Delete]
| otherwise = []
scan f = unless (ignored f) $ do
let fullf = indir f
r <- catchMaybeIO $ getSymbolicLinkStatus fullf
case r of
Nothing -> return ()
Just s
| Files.isDirectory s -> recurse fullf
| Files.isSymbolicLink s -> addSymlinkHook <@?> f
| Files.isRegularFile s -> addHook <@?> f
| otherwise -> return ()
-- Ignore creation events for regular files, which won't be
-- done being written when initially created, but handle for
-- directories and symlinks.
go (Created { isDirectory = isd, filePath = f })
| isd = recurse $ indir f
| hashook addSymlinkHook =
whenM (filetype Files.isSymbolicLink f) $
addSymlinkHook <@> f
| otherwise = noop
-- Closing a file is assumed to mean it's done being written.
go (Closed { isDirectory = False, maybeFilePath = Just f }) =
whenM (filetype Files.isRegularFile f) $
addHook <@> f
-- When a file or directory is moved in, scan it to add new
-- stuff.
go (MovedIn { filePath = f }) = scan f
go (MovedOut { isDirectory = isd, filePath = f })
| isd = delDirHook <@> f
| otherwise = delHook <@> f
-- Verify that the deleted item really doesn't exist,
-- since there can be spurious deletion events for items
-- in a directory that has been moved out, but is still
-- being watched.
go (Deleted { isDirectory = isd, filePath = f })
| isd = guarded $ delDirHook <@> f
| otherwise = guarded $ delHook <@> f
where
guarded = unlessM (filetype (const True) f)
go _ = noop
hashook h = isJust $ h hooks
runhook h f inscan
| ignored f = noop
| otherwise = maybe noop (\a -> a (indir f) inscan) (h hooks)
h <@> f = runhook h f False
h <@?> f = runhook h f True
indir f = dir </> f
filetype t f = catchBoolIO $ t <$> getSymbolicLinkStatus (indir f)
-- Inotify fails when there are too many watches with a
-- disk full error.
failedaddwatch e
| isFullError e =
case errHook hooks of
Nothing -> throw e
Just hook -> tooManyWatches hook dir
| otherwise = throw e
tooManyWatches :: (String -> Bool -> IO ()) -> FilePath -> IO ()
tooManyWatches hook dir = do
sysctlval <- querySysctl [Param maxwatches] :: IO (Maybe Integer)
hook (unlines $ basewarning : maybe withoutsysctl withsysctl sysctlval) False
where
maxwatches = "fs.inotify.max_user_watches"
basewarning = "Too many directories to watch! (Not watching " ++ dir ++")"
withoutsysctl = ["Increase the value in /proc/sys/fs/inotify/max_user_watches"]
withsysctl n = let new = n * 10 in
[ "Increase the limit permanently by running:"
, " echo " ++ maxwatches ++ "=" ++ show new ++
" | sudo tee -a /etc/sysctl.conf; sudo sysctl -p"
, "Or temporarily by running:"
, " sudo sysctl -w " ++ maxwatches ++ "=" ++ show new
]
querySysctl :: Read a => [CommandParam] -> IO (Maybe a)
querySysctl ps = do
v <- catchMaybeIO $ hPipeFrom "sysctl" $ toCommand ps
case v of
Nothing -> return Nothing
Just (pid, h) -> do
val <- parsesysctl <$> hGetContentsStrict h
void $ getProcessStatus True False $ processID pid
return val
where
parsesysctl s = readish =<< lastMaybe (words s)
|
