Add KVM daemon logic

Add KVM daemon logic, which contains monitors for Qmp sockets and
directory/file watching.
Signed-off-by: Jose A. Lopes <jabolopes@google.com>
Reviewed-by: Michele Tartara <mtartara@google.com>

Makefile.am

@@ -705,6 +705,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 \

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