RFC/WIP: reboot with shutdown/start not reboot

xenmgr/Vm/Actions.hs

@@ -23,7 +23,6 @@ module Vm.Actions
           , trashUnusedServiceVms
           , createVm, CreateVmPms(..), defaultCreateVmPms
           , removeVm
-          , restartVm
           , startVm
           , startVmInternal
           , rebootVm
@@ -505,16 +504,11 @@ getVhdReferences vhd = concat <$> (mapM (diskVhdReferences vhd) =<< getVms) wher
     references vhd disk = diskPath disk == vhd
 
 startVm :: Uuid -> XM ()
-startVm uuid = _startVm False uuid
-
-restartVm :: Uuid -> XM ()
-restartVm uuid = _startVm True uuid
-
-_startVm :: Bool -> Uuid -> XM ()
-_startVm is_reboot uuid = do
+startVm uuid = do
+  info $ "Starting " ++ show uuid
   withPreCreationState uuid $ do
     ran <- liftRpc $ runEventScript HardFail uuid getVmRunInsteadofStart [uuidStr uuid]
-    when (not ran) $ startVmInternal uuid is_reboot
+    when (not ran) $ startVmInternal uuid
 
 --Add a passthrough rule to vm config
 add_pt_rule_bdf uuid dev = modifyVmPciPtRules uuid $ pciAddRule (form_rule_bdf (show (devAddr dev)))
@@ -523,14 +517,14 @@ form_rule_bdf = rule . fromMaybe (error "error parsing rule") . pciAndSlotFromSt
   rule (addr,sl) = PciPtRuleBDF addr sl
 
 -- Start a VM! (maybe, because stuff can happen not)
-startVmInternal :: Uuid -> Bool -> XM ()
-startVmInternal uuid is_reboot = do
+startVmInternal :: Uuid -> XM ()
+startVmInternal uuid = do
     unlessM (dbExists $ "/vm/" ++ show uuid) $ error ("vm does not have a database entry: " ++ show uuid)
     info $ "starting VM " ++ show uuid
     liftRpc $ maybePtGpuFuncs uuid
     config <- prepareAndCheckConfig uuid
     case config of
-      Just c -> info ("done checks for VM " ++ show uuid) >> bootVm c is_reboot
+      Just c -> info ("done checks for VM " ++ show uuid) >> bootVm c
       Nothing-> return ()
   where
 
@@ -833,8 +827,8 @@ checkAndPerformSnapshotIfReq uuid disks = do
             _                                -> return disk --other Snapshot types unimplemented for now since UI can't set them
 
 
-bootVm :: VmConfig -> Bool -> XM ()
-bootVm config reboot
+bootVm :: VmConfig -> XM ()
+bootVm config
   = do
        monitor <- vm_monitor <$> xmRunVm uuid vmContext
 
@@ -875,10 +869,8 @@ bootVm config reboot
                   then return False
                   else liftIO (doesFileExist suspend_file)
            if not exists
-                then do 
-                  if reboot 
-                    then do liftIO $ Xl.signal uuid
-                    else do liftIO $ Xl.start uuid --we start paused by default
+                then do tapenv <- tapEnvForVm uuid
+                        liftIO $ Xl.start uuid tapenv --we start paused by default
                 else do liftIO $ xsWrite (vmSuspendImageStatePath uuid) "resume"
                         liftIO $ Xl.resumeFromFile uuid suspend_file False True
          return bootstrap
@@ -1020,15 +1012,15 @@ applyVmBackendShift bkuuid = do
 
 
 -- Reboot a VM
-rebootVm :: Uuid -> Rpc ()
+rebootVm :: Uuid -> XM ()
 rebootVm uuid = do
     info $ "rebooting VM " ++ show uuid
-    -- Write XL configuration file
-    writeXlConfig =<< getVmConfig uuid True
-    --Let xl take care of bringing down the domain and updating our state
-    --When xenmgr sees the 'Rebooted' state, it fires off a startVm call,
-    --which performs all the normal guest boot tasks, while xl brings up the domain.
-    liftIO $ Xl.reboot uuid
+    debug $ "reboot issuing shutdown to " ++ show uuid
+    liftRpc $ shutdownVm uuid
+    debug $ "reboot done issuing shutdown to " ++ show uuid
+    done <- liftIO $ Xl.waitForState uuid Shutdown (Just 60)
+    debug $ "reboot waitForState returned " ++ show done
+    when done $ startVm uuid
 
 shutdownVm :: Uuid -> Rpc ()
 shutdownVm uuid = do

xenmgr/Vm/Config.hs

@@ -606,6 +606,7 @@ getXlConfig cfg =
                           , "pci_msitranslate=1"
                           , "pci_seize=1"
                           , "pci_power_mgmt=1"
+                          , "on_reboot='destroy'"
                           ]
                             ++ nameStr
                             ++ hdtype

xenmgr/Vm/React.hs

@@ -315,7 +315,7 @@ whenShutdown xm reason = do
     maybeCleanupSnapshots
     if reason == Reboot
       then do
-        uuidRpc (backgroundRpc . runXM xm . restartVm)
+        uuidRpc (backgroundRpc . runXM xm . startVm)
       else do
         runXM xm (maybeKeepVmAlive uuid)
         return ()

xenmgr/XenMgr/Connect/Xl.hs

@@ -20,7 +20,6 @@ module XenMgr.Connect.Xl
     , pause
     , destroy
     , resumeFromSleep
-    , reboot
     , sleep
     , hibernate
     , suspendToFile
@@ -30,7 +29,6 @@ module XenMgr.Connect.Xl
     , acpiState
     , waitForAcpiState
     , waitForState
-    , signal
 
     --xl/toolstack queries
     , domainID
@@ -160,19 +158,25 @@ domainXsPath uuid = do
       "" -> return $ "/local/domain/unknown"
       _  -> return $ "/local/domain/" ++ domid
 
+pushPowerButton :: Uuid -> Int -> IO ()
+pushPowerButton uuid count = do
+      domid <- getDomainId uuid
+      stubdomid <- getStubDomainID uuid
+      let xs_path = "/local/domain/" ++ stubdomid ++ "/device-model/" ++ domid
+      _pushPowerButton uuid domid xs_path 1 count
+    where
+      _pushPowerButton :: Uuid -> String -> String -> Int -> Int -> IO ()
+      _pushPowerButton uuid domid xs_path i max = do
+          debug $ "push power button " ++ show uuid ++ " " ++ show i ++ " of " ++ show max
+          xsWrite (xs_path ++ "/hvm-shutdown") "poweroff"
+          system ("xl trigger " ++ domid ++ " power")
+          if i < max
+              then do threadDelay $ 10^6
+                      _pushPowerButton uuid domid xs_path ( i + 1 ) max
+              else return ()
 
 --The following functions are all domain lifecycle operations, and self-explanatory
 
-reboot :: Uuid -> IO ()
-reboot uuid =
-    do
-      domid <- getDomainId uuid
-      exitCode <- system ("xl reboot " ++ domid)
-      case exitCode of
-        ExitSuccess   -> return ()
-        _             -> do _ <- system ("xl reboot -F " ++ domid)
-                            return ()
-
 shutdown :: Uuid -> IO ()
 shutdown uuid =
     do
@@ -184,8 +188,7 @@ shutdown uuid =
         Just g  -> do exitCode  <- system ("xl shutdown -w " ++ domid)
                       case exitCode of
                         ExitSuccess   -> return ()
-                        _             -> do xsWrite (xs_path ++ "/hvm-shutdown") "poweroff"
-                                            _ <- system ("xl trigger " ++ domid ++ " power")
+                        _             -> do forkIO $ pushPowerButton uuid 3
                                             _ <- system ("xl shutdown -F -w " ++ domid)
                                             return ()
         Nothing -> do system ("xl shutdown -c -w " ++ domid)
@@ -213,47 +216,36 @@ getXlProcess uuid = do
     case ec of
         ExitSuccess -> return $ TT.strip str_pid
         _           -> return ""
-
-
--- Sends sigusr1 to specified xl process, in order to unblock
--- it from a reboot
-signal :: Uuid -> IO ()
-signal uuid = do
-    pid <- getXlProcess uuid
-    if pid /= ""
-      then do
-        info $ "signal xl process for uuid: " ++ (show uuid) ++ " pid: " ++ pid
-        readProcessOrDie "kill" ["-s", "SIGUSR1", pid] ""
-        return ()
-      else do
-        info $ "Couldn't find xl process for uuid: " ++ (show uuid)
-        return ()
 
 --It should be noted that by design, we start our domains paused to ensure all the
 --backend components are created and xenstore nodes are written before the domain
 --begins running.
-start :: Uuid -> IO ()
-start uuid =
+start :: Uuid -> [(String, String)] -> IO ()
+start uuid extraEnv =
     do
       --if domain already has a pid don't try to create another.
       pid <- getXlProcess uuid
       state <- state uuid
       if pid == ""
         then do
           case state of
-            Shutdown -> do
-                          (_, _, Just err, handle) <- createProcess (proc "xl" ["create", configPath uuid, "-p"]){std_err = CreatePipe,
-                                  close_fds = True}
-                          ec <- waitForProcess handle
-                          stderr <- hGetContents err
-                          case ec of
-                            ExitSuccess -> return ()
-                            _           -> do
-                                             updateVmDomainStateIO uuid Shutdown
-                                             throw $ XlException $ L.intercalate "<br>" $ L.lines stderr
+            Shutdown -> _start
+            Rebooted -> _start
             _        -> do return ()
         else do
           throw $ XlException "Don't try to start a guest twice"
+    where
+      _start = do
+                (_, _, Just err, handle) <- createProcess (proc "xl" ["create", configPath uuid, "-p"]){std_err = CreatePipe,
+                        close_fds = True,
+                        env = Just extraEnv}
+                ec <- waitForProcess handle
+                stderr <- hGetContents err
+                case ec of
+                  ExitSuccess -> return ()
+                  _           -> do
+                                   updateVmDomainStateIO uuid Shutdown
+                                   throw $ XlException $ L.intercalate "<br>" $ L.lines stderr
 
 --if domain has no domid, the domain is already dead. But we should make sure
 --the xenstore state is set to 'shutdown'.  Sometimes when domains crash on startup,

xenmgr/XenMgr/Expose/VmObject.hs

@@ -103,8 +103,8 @@ implementationFor xm uuid = self where
   , comCitrixXenclientXenmgrVmDelete             = unlessM policyQueryVmDeletion failActionSuppressedByPolicy >> removeVm uuid
   , comCitrixXenclientXenmgrVmSwitch             = switchVm uuid >> return ()
   , comCitrixXenclientXenmgrVmStart              = runXM xm (startVm uuid) >> return ()
-  , comCitrixXenclientXenmgrVmStartInternal      = runXM xm (startVmInternal uuid False) >> return ()
-  , comCitrixXenclientXenmgrVmReboot             = rebootVm uuid
+  , comCitrixXenclientXenmgrVmStartInternal      = runXM xm (startVmInternal uuid) >> return ()
+  , comCitrixXenclientXenmgrVmReboot             = runXM xm (rebootVm uuid) >> return ()
   , comCitrixXenclientXenmgrVmShutdown           = runvm invokeShutdownVm
   , comCitrixXenclientXenmgrVmDestroy            = runvm invokeForceShutdownVm
   , comCitrixXenclientXenmgrVmSleep              = sleepVm uuid

xenmgr/XenMgr/PowerManagement.hs

@@ -283,7 +283,7 @@ resumeS3' uuid S3Pv = do
   void . liftIO $ Xl.resumeFromSleep uuid
   info $ "PM: Successfully resumed " ++ show uuid ++ " from S3"
 resumeS3' uuid S3Restart = do
-  liftRpc $ rebootVm uuid
+  a <- rebootVm uuid
   info $ "PM: Restarted " ++ show uuid ++ " after S3"
 
 resumeS3' uuid S3Snapshot =