root / src / Ganeti / Kvmd.hs @ 13d26b66
History | View | Annotate | Download (11.5 kB)
1 |
{-| KVM daemon |
---|---|
2 |
|
3 |
The KVM daemon is responsible for determining whether a given KVM |
4 |
instance was shutdown by an administrator or a user. For more |
5 |
information read the design document on the KVM daemon. |
6 |
|
7 |
The KVM daemon design is split in 2 parts, namely, monitors for Qmp |
8 |
sockets and directory/file watching. |
9 |
|
10 |
The monitors are spawned in lightweight Haskell threads and are |
11 |
reponsible for handling the communication between the KVM daemon and |
12 |
the KVM instance using the Qmp protocol. During the communcation, the |
13 |
monitor parses the Qmp messages and if powerdown or shutdown is |
14 |
received, then the shutdown file is written in the KVM control |
15 |
directory. Otherwise, when the communication terminates, that same |
16 |
file is removed. The communication terminates when the KVM instance |
17 |
stops or crashes. |
18 |
|
19 |
The directory and file watching uses inotify to track down events on |
20 |
the KVM control directory and its parents. There is a directory |
21 |
crawler that will try to add a watch to the KVM control directory if |
22 |
available or its parents, thus replacing watches until the KVM control |
23 |
directory becomes available. When this happens, a monitor for the Qmp |
24 |
socket is spawned. Given that the KVM daemon might stop or crash, the |
25 |
directory watching also simulates events for the Qmp sockets that |
26 |
already exist in the KVM control directory when the KVM daemon starts. |
27 |
|
28 |
-} |
29 |
|
30 |
{- |
31 |
|
32 |
Copyright (C) 2013 Google Inc. |
33 |
|
34 |
This program is free software; you can redistribute it and/or modify |
35 |
it under the terms of the GNU General Public License as published by |
36 |
the Free Software Foundation; either version 2 of the License, or |
37 |
(at your option) any later version. |
38 |
|
39 |
This program is distributed in the hope that it will be useful, but |
40 |
WITHOUT ANY WARRANTY; without even the implied warranty of |
41 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
42 |
General Public License for more details. |
43 |
|
44 |
You should have received a copy of the GNU General Public License |
45 |
along with this program; if not, write to the Free Software |
46 |
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
47 |
02110-1301, USA. |
48 |
|
49 |
-} |
50 |
|
51 |
module Ganeti.Kvmd where |
52 |
|
53 |
import Prelude hiding (rem) |
54 |
|
55 |
import Control.Applicative ((<$>)) |
56 |
import Control.Exception (try) |
57 |
import Control.Concurrent |
58 |
import Control.Monad (unless, when) |
59 |
import Data.List |
60 |
import Data.Set (Set) |
61 |
import qualified Data.Set as Set (delete, empty, insert, member) |
62 |
import System.Directory |
63 |
import System.FilePath |
64 |
import System.IO |
65 |
import System.IO.Error (isEOFError) |
66 |
import System.INotify |
67 |
|
68 |
import qualified AutoConf |
69 |
import qualified Ganeti.Constants as Constants |
70 |
import qualified Ganeti.Logging as Logging |
71 |
import qualified Ganeti.UDSServer as UDSServer |
72 |
|
73 |
type Lock = MVar () |
74 |
type Monitors = MVar (Set FilePath) |
75 |
|
76 |
-- * Utils |
77 |
|
78 |
-- | @isPrefixPath x y@ determines whether @x@ is a 'FilePath' prefix |
79 |
-- of 'FilePath' @y@. |
80 |
isPrefixPath :: FilePath -> FilePath -> Bool |
81 |
isPrefixPath x y = |
82 |
(splitPath x `isPrefixOf` splitPath y) || |
83 |
(splitPath (x ++ "/") `isPrefixOf` splitPath y) |
84 |
|
85 |
monitorGreeting :: String |
86 |
monitorGreeting = "{\"execute\": \"qmp_capabilities\"}" |
87 |
|
88 |
-- | KVM control directory containing the Qmp sockets. |
89 |
monitorDir :: String |
90 |
monitorDir = AutoConf.localstatedir </> "run/ganeti/kvm-hypervisor/ctrl/" |
91 |
|
92 |
monitorExtension :: String |
93 |
monitorExtension = ".qmp" |
94 |
|
95 |
isMonitorPath :: FilePath -> Bool |
96 |
isMonitorPath = (== monitorExtension) . takeExtension |
97 |
|
98 |
shutdownExtension :: String |
99 |
shutdownExtension = ".shutdown" |
100 |
|
101 |
shutdownPath :: String -> String |
102 |
shutdownPath = (`replaceExtension` shutdownExtension) |
103 |
|
104 |
touchFile :: FilePath -> IO () |
105 |
touchFile file = withFile file WriteMode (const . return $ ()) |
106 |
|
107 |
-- * Monitors for Qmp sockets |
108 |
|
109 |
-- | @parseQmp isPowerdown isShutdown isStop str@ parses the packet |
110 |
-- @str@ and returns whether a powerdown, shutdown, or stop event is |
111 |
-- contained in that packet, defaulting to the values @isPowerdown@, |
112 |
-- @isShutdown@, and @isStop@, otherwise. |
113 |
parseQmp :: Bool -> Bool -> Bool -> String -> (Bool, Bool, Bool) |
114 |
parseQmp isPowerdown isShutdown isStop str = |
115 |
let |
116 |
isPowerdown' |
117 |
| "\"POWERDOWN\"" `isInfixOf` str = True |
118 |
| otherwise = isPowerdown |
119 |
isShutdown' |
120 |
| "\"SHUTDOWN\"" `isInfixOf` str = True |
121 |
| otherwise = isShutdown |
122 |
isStop' |
123 |
| "\"STOP\"" `isInfixOf` str = True |
124 |
| otherwise = isStop |
125 |
in |
126 |
(isPowerdown', isShutdown', isStop') |
127 |
|
128 |
-- | @receiveQmp handle@ listens for Qmp events on @handle@ and, when |
129 |
-- @handle@ is closed, it returns 'True' if a user shutdown event was |
130 |
-- received, and 'False' otherwise. |
131 |
receiveQmp :: Handle -> IO Bool |
132 |
receiveQmp handle = isUserShutdown <$> receive False False False |
133 |
where -- | A user shutdown consists of a shutdown event with no |
134 |
-- prior powerdown event and no stop event. |
135 |
isUserShutdown (isShutdown, isPowerdown, isStop) |
136 |
= isPowerdown && not isShutdown && not isStop |
137 |
|
138 |
receive isPowerdown isShutdown isStop = |
139 |
do res <- try $ hGetLine handle |
140 |
case res of |
141 |
Left err -> do |
142 |
unless (isEOFError err) $ |
143 |
hPrint stderr err |
144 |
return (isPowerdown, isShutdown, isStop) |
145 |
Right str -> do |
146 |
let (isPowerdown', isShutdown', isStop') = |
147 |
parseQmp isPowerdown isShutdown isStop str |
148 |
Logging.logDebug $ "Receive QMP message: " ++ str |
149 |
receive isPowerdown' isShutdown' isStop' |
150 |
|
151 |
-- | @detectMonitor monitorFile handle@ listens for Qmp events on |
152 |
-- @handle@ for Qmp socket @monitorFile@ and, when communcation |
153 |
-- terminates, it either creates the shutdown file, if a user shutdown |
154 |
-- was detected, or it deletes that same file, if an administrator |
155 |
-- shutdown was detected. |
156 |
detectMonitor :: FilePath -> Handle -> IO () |
157 |
detectMonitor monitorFile handle = |
158 |
do let shutdownFile = shutdownPath monitorFile |
159 |
res <- receiveQmp handle |
160 |
if res |
161 |
then do |
162 |
Logging.logInfo $ "Detect user shutdown, creating file " ++ |
163 |
show shutdownFile |
164 |
touchFile shutdownFile |
165 |
else do |
166 |
Logging.logInfo $ "Detect admin shutdown, removing file " ++ |
167 |
show shutdownFile |
168 |
(try (removeFile shutdownFile) :: IO (Either IOError ())) >> return () |
169 |
|
170 |
-- | @runMonitor monitorFile@ creates a monitor for the Qmp socket |
171 |
-- @monitorFile@ and calls 'detectMonitor'. |
172 |
runMonitor :: FilePath -> IO () |
173 |
runMonitor monitorFile = |
174 |
do handle <- UDSServer.openClientSocket Constants.luxiDefRwto monitorFile |
175 |
hPutStrLn handle monitorGreeting |
176 |
hFlush handle |
177 |
detectMonitor monitorFile handle |
178 |
UDSServer.closeClientSocket handle |
179 |
|
180 |
-- | @ensureMonitor monitors monitorFile@ ensures that there is |
181 |
-- exactly one monitor running for the Qmp socket @monitorFile@, given |
182 |
-- the existing set of monitors @monitors@. |
183 |
ensureMonitor :: Monitors -> FilePath -> IO () |
184 |
ensureMonitor monitors monitorFile = |
185 |
modifyMVar_ monitors $ |
186 |
\files -> |
187 |
if monitorFile `Set.member` files |
188 |
then return files |
189 |
else do |
190 |
forkIO tryMonitor >> return () |
191 |
return $ monitorFile `Set.insert` files |
192 |
where tryMonitor = |
193 |
do Logging.logInfo $ "Start monitor " ++ show monitorFile |
194 |
res <- try (runMonitor monitorFile) :: IO (Either IOError ()) |
195 |
case res of |
196 |
Left err -> |
197 |
Logging.logError $ "Catch monitor exception: " ++ show err |
198 |
_ -> |
199 |
return () |
200 |
Logging.logInfo $ "Stop monitor " ++ show monitorFile |
201 |
modifyMVar_ monitors (return . Set.delete monitorFile) |
202 |
|
203 |
-- * Directory and file watching |
204 |
|
205 |
-- | Handles an inotify event outside the target directory. |
206 |
-- |
207 |
-- Tracks events on the parent directory of the KVM control directory |
208 |
-- until one of its parents becomes available. |
209 |
handleGenericEvent :: Lock -> String -> String -> Event -> IO () |
210 |
handleGenericEvent lock curDir tarDir ev@Created {} |
211 |
| isDirectory ev && curDir /= tarDir && |
212 |
(curDir </> filePath ev) `isPrefixPath` tarDir = putMVar lock () |
213 |
handleGenericEvent lock _ _ event |
214 |
| event == DeletedSelf || event == Unmounted = putMVar lock () |
215 |
handleGenericEvent _ _ _ _ = return () |
216 |
|
217 |
-- | Handles an inotify event in the target directory. |
218 |
-- |
219 |
-- Upon a create or open event inside the KVM control directory, it |
220 |
-- ensures that there is a monitor running for the new Qmp socket. |
221 |
handleTargetEvent :: Lock -> Monitors -> String -> Event -> IO () |
222 |
handleTargetEvent _ monitors tarDir ev@Created {} |
223 |
| not (isDirectory ev) && isMonitorPath (filePath ev) = |
224 |
ensureMonitor monitors $ tarDir </> filePath ev |
225 |
handleTargetEvent lock monitors tarDir ev@Opened {} |
226 |
| not (isDirectory ev) = |
227 |
case maybeFilePath ev of |
228 |
Just p | isMonitorPath p -> |
229 |
ensureMonitor monitors $ tarDir </> filePath ev |
230 |
_ -> |
231 |
handleGenericEvent lock tarDir tarDir ev |
232 |
handleTargetEvent _ _ tarDir ev@Created {} |
233 |
| not (isDirectory ev) && takeExtension (filePath ev) == shutdownExtension = |
234 |
Logging.logInfo $ "User shutdown file opened " ++ |
235 |
show (tarDir </> filePath ev) |
236 |
handleTargetEvent _ _ tarDir ev@Deleted {} |
237 |
| not (isDirectory ev) && takeExtension (filePath ev) == shutdownExtension = |
238 |
Logging.logInfo $ "User shutdown file deleted " ++ |
239 |
show (tarDir </> filePath ev) |
240 |
handleTargetEvent lock _ tarDir ev = |
241 |
handleGenericEvent lock tarDir tarDir ev |
242 |
|
243 |
-- | Dispatches inotify events depending on the directory they occur in. |
244 |
handleDir :: Lock -> Monitors -> String -> String -> Event -> IO () |
245 |
handleDir lock monitors curDir tarDir event = |
246 |
do Logging.logDebug $ "Handle event " ++ show event |
247 |
if curDir == tarDir |
248 |
then handleTargetEvent lock monitors tarDir event |
249 |
else handleGenericEvent lock curDir tarDir event |
250 |
|
251 |
-- | Simulates file creation events for the Qmp sockets that already |
252 |
-- exist in @dir@. |
253 |
recapDir :: Lock -> Monitors -> FilePath -> IO () |
254 |
recapDir lock monitors dir = |
255 |
do files <- getDirectoryContents dir |
256 |
let files' = filter isMonitorPath files |
257 |
mapM_ sendEvent files' |
258 |
where sendEvent file = |
259 |
handleTargetEvent lock monitors dir Created { isDirectory = False |
260 |
, filePath = file } |
261 |
|
262 |
-- | Crawls @tarDir@, or its parents until @tarDir@ becomes available, |
263 |
-- always listening for inotify events. |
264 |
-- |
265 |
-- Used for crawling the KVM control directory and its parents, as |
266 |
-- well as simulating file creation events. |
267 |
watchDir :: Lock -> FilePath -> INotify -> IO () |
268 |
watchDir lock tarDir inotify = watchDir' tarDir |
269 |
where watchDirEvents dir |
270 |
| dir == tarDir = [AllEvents] |
271 |
| otherwise = [Create, DeleteSelf] |
272 |
|
273 |
watchDir' dir = |
274 |
do add <- doesDirectoryExist dir |
275 |
if add |
276 |
then do |
277 |
let events = watchDirEvents dir |
278 |
Logging.logInfo $ "Watch directory " ++ show dir |
279 |
monitors <- newMVar Set.empty |
280 |
wd <- addWatch inotify events dir |
281 |
(handleDir lock monitors dir tarDir) |
282 |
when (dir == tarDir) $ recapDir lock monitors dir |
283 |
() <- takeMVar lock |
284 |
rem <- doesDirectoryExist dir |
285 |
if rem |
286 |
then do |
287 |
Logging.logInfo $ "Unwatch directory " ++ show dir |
288 |
removeWatch wd |
289 |
else |
290 |
Logging.logInfo $ "Throw away watch from directory " ++ |
291 |
show dir |
292 |
else |
293 |
watchDir' (takeDirectory dir) |
294 |
|
295 |
rewatchDir :: Lock -> FilePath -> INotify -> IO () |
296 |
rewatchDir lock tarDir inotify = |
297 |
do watchDir lock tarDir inotify |
298 |
rewatchDir lock tarDir inotify |
299 |
|
300 |
-- * Starting point |
301 |
|
302 |
startWith :: FilePath -> IO () |
303 |
startWith dir = |
304 |
do lock <- newEmptyMVar |
305 |
withINotify (rewatchDir lock dir) |
306 |
|
307 |
start :: IO () |
308 |
start = startWith monitorDir |