Synnefo » snf-ganeti

	src/Ganeti/Kvmd.hs \

{-| 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