| {-| 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. |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are |
| met: |
| |
| 1. Redistributions of source code must retain the above copyright notice, |
| this list of conditions and the following disclaimer. |
| |
| 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. |
| |
| -} |
| |
| module Ganeti.Kvmd where |
| |
| import Prelude () |
| import Ganeti.Prelude hiding (rem) |
| |
| import Control.Exception (try) |
| import Control.Concurrent |
| import Control.Monad (unless, when) |
| import Data.List (isPrefixOf, isInfixOf) |
| 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.BasicTypes as BasicTypes |
| import qualified Ganeti.Constants as Constants |
| import qualified Ganeti.Daemon as Daemon (getFQDN) |
| import qualified Ganeti.Logging as Logging |
| import qualified Ganeti.UDSServer as UDSServer |
| import qualified Ganeti.Ssconf as Ssconf |
| import qualified Ganeti.Types as Types |
| |
| 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 = ".kvmd" |
| |
| 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 = |
| 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" |
