diff --git a/Makefile.am b/Makefile.am
index 65f8b81a1c15246c79e152d752b2d2af24bad818..fb8758212937c15ab510a2a6c685de9e03e41096 100644
--- a/Makefile.am
+++ b/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 \
diff --git a/src/Ganeti/Kvmd.hs b/src/Ganeti/Kvmd.hs
new file mode 100644
index 0000000000000000000000000000000000000000..d9ae13929e6afca16840d305d5ccff5dcc9686ba
--- /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 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