Kvmd.hs 11.5 KB
Newer Older
Jose A. Lopes's avatar
Jose A. Lopes committed
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
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
{-| KVM daemon

The KVM daemon is responsible for determining whether a given KVM
instance was shutdown by an administrator or a user.  For more
information read the design document on the KVM daemon.

The KVM daemon design is split in 2 parts, namely, monitors for Qmp
sockets and directory/file watching.

The monitors are spawned in lightweight Haskell threads and are
reponsible for handling the communication between the KVM daemon and
the KVM instance using the Qmp protocol.  During the communcation, the
monitor parses the Qmp messages and if powerdown or shutdown is
received, then the shutdown file is written in the KVM control
directory.  Otherwise, when the communication terminates, that same
file is removed.  The communication terminates when the KVM instance
stops or crashes.

The directory and file watching uses inotify to track down events on
the KVM control directory and its parents.  There is a directory
crawler that will try to add a watch to the KVM control directory if
available or its parents, thus replacing watches until the KVM control
directory becomes available.  When this happens, a monitor for the Qmp
socket is spawned.  Given that the KVM daemon might stop or crash, the
directory watching also simulates events for the Qmp sockets that
already exist in the KVM control directory when the KVM daemon starts.

-}

{-

Copyright (C) 2013 Google Inc.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
02110-1301, USA.

-}

module Ganeti.Kvmd where

import Prelude hiding (catch, rem)

import Control.Applicative ((<$>))
import Control.Exception (try)
import Control.Concurrent
import Control.Monad (unless, when)
import Data.List
import Data.Set (Set)
import qualified Data.Set as Set (delete, empty, insert, member)
import System.Directory
import System.FilePath
import System.IO
import System.IO.Error (isEOFError)
import System.INotify

import qualified AutoConf
import qualified Ganeti.Constants as Constants
import qualified Ganeti.Logging as Logging
import qualified Ganeti.UDSServer as UDSServer

type Lock = MVar ()
type Monitors = MVar (Set FilePath)

-- * Utils

-- | @isPrefixPath x y@ determines whether @x@ is a 'FilePath' prefix
-- of 'FilePath' @y@.
isPrefixPath :: FilePath -> FilePath -> Bool
isPrefixPath x y =
  (splitPath x `isPrefixOf` splitPath y) ||
  (splitPath (x ++ "/") `isPrefixOf` splitPath y)

monitorGreeting :: String
monitorGreeting = "{\"execute\": \"qmp_capabilities\"}"

-- | KVM control directory containing the Qmp sockets.
monitorDir :: String
monitorDir = AutoConf.localstatedir </> "run/ganeti/kvm-hypervisor/ctrl/"

monitorExtension :: String
monitorExtension = ".qmp"

isMonitorPath :: FilePath -> Bool
isMonitorPath = (== monitorExtension) . takeExtension

shutdownExtension :: String
shutdownExtension = ".shutdown"

shutdownPath :: String -> String
shutdownPath = (`replaceExtension` shutdownExtension)

touchFile :: FilePath -> IO ()
touchFile file = withFile file WriteMode (const . return $ ())

-- * Monitors for Qmp sockets

-- | @parseQmp isPowerdown isShutdown isStop str@ parses the packet
-- @str@ and returns whether a powerdown, shutdown, or stop event is
-- contained in that packet, defaulting to the values @isPowerdown@,
-- @isShutdown@, and @isStop@, otherwise.
parseQmp :: Bool -> Bool -> Bool -> String -> (Bool, Bool, Bool)
parseQmp isPowerdown isShutdown isStop str =
  let
    isPowerdown'
      | "\"POWERDOWN\"" `isInfixOf` str = True
      | otherwise = isPowerdown
    isShutdown'
      | "\"SHUTDOWN\"" `isInfixOf` str = True
      | otherwise = isShutdown
    isStop'
      | "\"STOP\"" `isInfixOf` str = True
      | otherwise = isStop
  in
   (isPowerdown', isShutdown', isStop')

-- | @receiveQmp handle@ listens for Qmp events on @handle@ and, when
-- @handle@ is closed, it returns 'True' if a user shutdown event was
-- received, and 'False' otherwise.
receiveQmp :: Handle -> IO Bool
receiveQmp handle = isUserShutdown <$> receive False False False
  where -- | A user shutdown consists of a shutdown event with no
        -- prior powerdown event and no stop event.
        isUserShutdown (isShutdown, isPowerdown, isStop)
          = isPowerdown && not isShutdown && not isStop

        receive isPowerdown isShutdown isStop =
          do res <- try $ hGetLine handle
             case res of
               Left err -> do
                 unless (isEOFError err) $
                   hPrint stderr err
                 return (isPowerdown, isShutdown, isStop)
               Right str -> do
                 let (isPowerdown', isShutdown', isStop') =
                       parseQmp isPowerdown isShutdown isStop str
                 Logging.logDebug $ "Receive QMP message: " ++ str
                 receive isPowerdown' isShutdown' isStop'

-- | @detectMonitor monitorFile handle@ listens for Qmp events on
-- @handle@ for Qmp socket @monitorFile@ and, when communcation
-- terminates, it either creates the shutdown file, if a user shutdown
-- was detected, or it deletes that same file, if an administrator
-- shutdown was detected.
detectMonitor :: FilePath -> Handle -> IO ()
detectMonitor monitorFile handle =
  do let shutdownFile = shutdownPath monitorFile
     res <- receiveQmp handle
     if res
       then do
         Logging.logInfo $ "Detect user shutdown, creating file " ++
           show shutdownFile
         touchFile shutdownFile
       else do
         Logging.logInfo $ "Detect admin shutdown, removing file " ++
           show shutdownFile
         (try (removeFile shutdownFile) :: IO (Either IOError ())) >> return ()

-- | @runMonitor monitorFile@ creates a monitor for the Qmp socket
-- @monitorFile@ and calls 'detectMonitor'.
runMonitor :: FilePath -> IO ()
runMonitor monitorFile =
  do handle <- UDSServer.openClientSocket Constants.luxiDefRwto monitorFile
     hPutStrLn handle monitorGreeting
     hFlush handle
     detectMonitor monitorFile handle
     UDSServer.closeClientSocket handle

-- | @ensureMonitor monitors monitorFile@ ensures that there is
-- exactly one monitor running for the Qmp socket @monitorFile@, given
-- the existing set of monitors @monitors@.
ensureMonitor :: Monitors -> FilePath -> IO ()
ensureMonitor monitors monitorFile =
  modifyMVar_ monitors $
    \files ->
      if monitorFile `Set.member` files
      then return files
      else do
        forkIO tryMonitor >> return ()
        return $ monitorFile `Set.insert` files
  where tryMonitor =
          do Logging.logInfo $ "Start monitor " ++ show monitorFile
             res <- try (runMonitor monitorFile) :: IO (Either IOError ())
             case res of
               Left err ->
                 Logging.logError $ "Catch monitor exception: " ++ show err
               _ ->
                 return ()
             Logging.logInfo $ "Stop monitor " ++ show monitorFile
             modifyMVar_ monitors (return . Set.delete monitorFile)

-- * Directory and file watching

-- | Handles an inotify event outside the target directory.
--
-- Tracks events on the parent directory of the KVM control directory
-- until one of its parents becomes available.
handleGenericEvent :: Lock -> String -> String -> Event -> IO ()
handleGenericEvent lock curDir tarDir ev@Created {}
  | isDirectory ev && curDir /= tarDir &&
    (curDir </> filePath ev) `isPrefixPath` tarDir = putMVar lock ()
handleGenericEvent lock _ _ event
  | event == DeletedSelf || event == Unmounted = putMVar lock ()
handleGenericEvent _ _ _ _ = return ()

-- | Handles an inotify event in the target directory.
--
-- Upon a create or open event inside the KVM control directory, it
-- ensures that there is a monitor running for the new Qmp socket.
handleTargetEvent :: Lock -> Monitors -> String -> Event -> IO ()
handleTargetEvent _ monitors tarDir ev@Created {}
  | not (isDirectory ev) && isMonitorPath (filePath ev) =
    ensureMonitor monitors $ tarDir </> filePath ev
handleTargetEvent lock monitors tarDir ev@Opened {}
  | not (isDirectory ev) =
    case maybeFilePath ev of
      Just p | isMonitorPath p ->
        ensureMonitor monitors $ tarDir </> filePath ev
      _ ->
        handleGenericEvent lock tarDir tarDir ev
handleTargetEvent _ _ tarDir ev@Created {}
  | not (isDirectory ev) && takeExtension (filePath ev) == shutdownExtension =
    Logging.logInfo $ "User shutdown file opened " ++
      show (tarDir </> filePath ev)
handleTargetEvent _ _ tarDir ev@Deleted {}
  | not (isDirectory ev) && takeExtension (filePath ev) == shutdownExtension =
    Logging.logInfo $ "User shutdown file deleted " ++
      show (tarDir </> filePath ev)
handleTargetEvent lock _ tarDir ev =
  handleGenericEvent lock tarDir tarDir ev

-- | Dispatches inotify events depending on the directory they occur in.
handleDir :: Lock -> Monitors -> String -> String -> Event -> IO ()
handleDir lock monitors curDir tarDir event =
  do Logging.logDebug $ "Handle event " ++ show event
     if curDir == tarDir
       then handleTargetEvent lock monitors tarDir event
       else handleGenericEvent lock curDir tarDir event

-- | Simulates file creation events for the Qmp sockets that already
-- exist in @dir@.
recapDir :: Lock -> Monitors -> FilePath -> IO ()
recapDir lock monitors dir =
  do files <- getDirectoryContents dir
     let files' = filter isMonitorPath files
     mapM_ sendEvent files'
  where sendEvent file =
          handleTargetEvent lock monitors dir Created { isDirectory = False
                                                      , filePath = file }

-- | Crawls @tarDir@, or its parents until @tarDir@ becomes available,
-- always listening for inotify events.
--
-- Used for crawling the KVM control directory and its parents, as
-- well as simulating file creation events.
watchDir :: Lock -> FilePath -> INotify -> IO ()
watchDir lock tarDir inotify = watchDir' tarDir
  where watchDirEvents dir
          | dir == tarDir = [AllEvents]
          | otherwise = [Create, DeleteSelf]

        watchDir' dir =
          do add <- doesDirectoryExist dir
             if add
               then do
                 let events = watchDirEvents dir
                 Logging.logInfo $ "Watch directory " ++ show dir
                 monitors <- newMVar Set.empty
                 wd <- addWatch inotify events dir
                       (handleDir lock monitors dir tarDir)
                 when (dir == tarDir) $ recapDir lock monitors dir
                 () <- takeMVar lock
                 rem <- doesDirectoryExist dir
                 if rem
                   then do
                     Logging.logInfo $ "Unwatch directory " ++ show dir
                     removeWatch wd
                   else
                     Logging.logInfo $ "Throw away watch from directory " ++
                       show dir
               else
                 watchDir' (takeDirectory dir)

rewatchDir :: Lock -> FilePath -> INotify -> IO ()
rewatchDir lock tarDir inotify =
  do watchDir lock tarDir inotify
     rewatchDir lock tarDir inotify

-- * Starting point

startWith :: FilePath -> IO ()
startWith dir =
  do lock <- newEmptyMVar
     withINotify (rewatchDir lock dir)

start :: IO ()
start = startWith monitorDir