On Fri, Jan 3, 2014 at 9:42 AM, Jose A. Lopes <[email protected]> wrote:
> Add KVM daemon logic, which contains monitors for Qmp sockets and
> directory/file watching.
>
> Signed-off-by: Jose A. Lopes <[email protected]>
> ---
> Makefile.am | 1 +
> src/Ganeti/Kvmd.hs | 308
> +++++++++++++++++++++++++++++++++++++++++++++++++++++
> 2 files changed, 309 insertions(+)
> create mode 100644 src/Ganeti/Kvmd.hs
>
> diff --git a/Makefile.am b/Makefile.am
> index 8611dfe..eb23dfd 100644
> --- a/Makefile.am
> +++ b/Makefile.am
> @@ -692,6 +692,7 @@ HS_LIB_SRCS = \
> src/Ganeti/JQScheduler.hs \
> src/Ganeti/JSON.hs \
> src/Ganeti/Jobs.hs \
> + src/Ganeti/Kvmd.hs \
> src/Ganeti/Logging.hs \
> src/Ganeti/Luxi.hs \
> src/Ganeti/Monitoring/Server.hs \
> diff --git a/src/Ganeti/Kvmd.hs b/src/Ganeti/Kvmd.hs
> new file mode 100644
> index 0000000..1dc678e
> --- /dev/null
> +++ b/src/Ganeti/Kvmd.hs
> @@ -0,0 +1,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 str@ parses the packet @str@ and
> +-- returns whether a powerdown or shutdown event is contained in that
> +-- packet, defaulting to the values @isPowerdown@ and @isShutdown@
> +-- 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')
The function has an isStop parameter, but the documentation line at
its top doesn't mention it.
> +
> +-- | @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
> --
> 1.8.5.1
>
Many description of functions are not properly terminated by full
stops. Please, fix them.
Rest LGTM.
Thanks,
Michele
--
Google Germany GmbH
Dienerstr. 12
80331 München
Registergericht und -nummer: Hamburg, HRB 86891
Sitz der Gesellschaft: Hamburg
Geschäftsführer: Graham Law, Christine Elizabeth Flores
