Kvmd.hs 13 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
{-| 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.
33
All rights reserved.
Jose A. Lopes's avatar
Jose A. Lopes committed
34

35 36 37
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
Jose A. Lopes's avatar
Jose A. Lopes committed
38

39 40
1. Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
Jose A. Lopes's avatar
Jose A. Lopes committed
41

42 43 44 45 46 47 48 49 50 51 52 53 54 55 56
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Jose A. Lopes's avatar
Jose A. Lopes committed
57 58 59 60 61

-}

module Ganeti.Kvmd where

62
import Prelude hiding (rem)
Jose A. Lopes's avatar
Jose A. Lopes committed
63 64 65 66 67 68 69 70 71 72 73 74 75 76 77

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
78
import qualified Ganeti.BasicTypes as BasicTypes
Jose A. Lopes's avatar
Jose A. Lopes committed
79
import qualified Ganeti.Constants as Constants
80
import qualified Ganeti.Daemon as Daemon (getFQDN)
Jose A. Lopes's avatar
Jose A. Lopes committed
81 82
import qualified Ganeti.Logging as Logging
import qualified Ganeti.UDSServer as UDSServer
83 84
import qualified Ganeti.Ssconf as Ssconf
import qualified Ganeti.Types as Types
Jose A. Lopes's avatar
Jose A. Lopes committed
85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105

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
106
monitorExtension = ".kvmd"
Jose A. Lopes's avatar
Jose A. Lopes committed
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 309 310 311 312 313 314 315 316 317 318 319 320

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 ()
321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343
start =
  do fqdn <- Daemon.getFQDN
     hypervisors <- Ssconf.getHypervisorList Nothing
     userShutdown <- Ssconf.getEnabledUserShutdown Nothing
     vmCapable <- Ssconf.getNodesVmCapable Nothing
     BasicTypes.genericResult
       Logging.logInfo
       (const $ startWith monitorDir) $ do
         isKvm =<< hypervisors
         isUserShutdown =<< userShutdown
         isVmCapable fqdn =<< vmCapable
  where
    isKvm hs
      | Types.Kvm `elem` hs = return ()
      | otherwise = fail "KVM not enabled, exiting"

    isUserShutdown True = return ()
    isUserShutdown _ = fail "User shutdown not enabled, exiting"

    isVmCapable node vmCapables =
      case lookup node vmCapables of
        Just True -> return ()
        _ -> fail $ "Node " ++ show node ++ " is not VM capable, exiting"