ADD vbox-start binary

This commit is contained in:
Nathan Dwarshuis 2022-08-30 00:21:21 -04:00
parent 825c7fbe45
commit 2d70507a1e
5 changed files with 108 additions and 8 deletions

77
bin/vbox-start.hs Normal file
View File

@ -0,0 +1,77 @@
{-# LANGUAGE ScopedTypeVariables #-}
--------------------------------------------------------------------------------
-- | Start a VirtualBox instance with a sentinel wrapper process.
--
-- The only reason why this is needed is because I want to manage virtualboxes
-- in their own dynamic workspaces, which are currently set up to correspond to
-- one process. The problem with Virtualbox is that the VBoxManage command
-- spawns a new VM and then exits, which means the process that was originally
-- attached to the dynamic workspace only exists for a few seconds when the VM
-- is starting.
--
-- Solution: Run VBoxManage in a wrapper binary that launches the VM and sleeps
-- until its PID exits. By monitoring this wrapper, the dynamic workspace only
-- has one process to track and will maintain the workspace throughout the
-- lifetime of the VM.
module Main (main) where
import Control.Exception
import Data.List
import Text.Read
import Text.XML.Light
import System.Environment
import System.Exit
import XMonad.Internal.Concurrent.VirtualBox
import XMonad.Internal.Process
main :: IO ()
main = runAndWait =<< getArgs
runAndWait :: [String] -> IO ()
runAndWait [n] = either putStrLn runConfig =<< vmInstanceConfig n
where
runConfig c = maybe err runID =<< vmMachineID c
runID i = do
vmLaunch i
p <- vmPID i
waitUntilExit p
err = putStrLn "Could not get machine ID"
runAndWait _ = putStrLn "Usage: vbox-start VBOXNAME"
vmLaunch :: String -> IO ()
vmLaunch i = do
(rc, _, _) <- readCreateProcessWithExitCode' cmd ""
case rc of
ExitSuccess -> return ()
_ -> putStrLn $ "Failed to start VM: " ++ i
where
cmd = proc "VBoxManage" ["startvm", i]
vmPID :: String -> IO (Maybe Int)
vmPID vid = do
(rc, out, _) <- readCreateProcessWithExitCode' cmd ""
return $ case rc of
ExitSuccess -> readMaybe out
_ -> Nothing
where
cmd = proc "pgrep" ["-f", "VirtualBoxVM.*" ++ vid]
vmMachineID :: FilePath -> IO (Maybe String)
vmMachineID iPath = do
(s :: Either IOException String) <- try $ readFile iPath
return $ case s of
(Left _) -> Nothing
(Right x) -> findMachineID =<< parseXMLDoc x
where
findMachineID e = stripPrefix "{"
=<< (fmap reverse . stripPrefix "}" . reverse)
=<< findAttr (blank_name { qName = "uuid" })
=<< findChild (qual e "Machine") e

View File

@ -262,6 +262,7 @@ gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
<&&> className =? c <&&> className =? c
c = "Gimp-2.10" -- TODO I don't feel like changing the version long term c = "Gimp-2.10" -- TODO I don't feel like changing the version long term
-- TODO don't hardcode the VM name/title/shortcut
vmDynamicWorkspace :: Sometimes DynWorkspace vmDynamicWorkspace :: Sometimes DynWorkspace
vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox
[Subfeature root "windows 8 VM"] [Subfeature root "windows 8 VM"]

View File

@ -286,6 +286,7 @@ runToggleEthernet = Sometimes "ethernet toggle" xpfEthernet
runRestart :: X () runRestart :: X ()
runRestart = restart "xmonad" True runRestart = restart "xmonad" True
-- TODO only recompile the VM binary if we have virtualbox enabled
runRecompile :: X () runRecompile :: X ()
runRecompile = do runRecompile = do
-- assume that the conf directory contains a valid stack project -- assume that the conf directory contains a valid stack project

View File

@ -4,6 +4,8 @@
module XMonad.Internal.Concurrent.VirtualBox module XMonad.Internal.Concurrent.VirtualBox
( vmExists ( vmExists
, vmInstanceConfig
, qual
) where ) where
import Control.Exception import Control.Exception
@ -13,18 +15,23 @@ import Data.Internal.Dependency
import Text.XML.Light import Text.XML.Light
import System.Directory import System.Directory
import System.FilePath
import XMonad.Internal.Shell import XMonad.Internal.Shell
vmExists :: String -> IO (Maybe Msg) vmExists :: String -> IO (Maybe Msg)
vmExists vm = do vmExists vm = either (const Nothing) (Just . Msg Error) <$> vmInstanceConfig vm
d <- vmDirectory
either (return . Just . Msg Error) findVMDir d vmInstanceConfig :: String -> IO (Either String FilePath)
vmInstanceConfig vmName = do
either (return . Right) findInstance =<< vmDirectory
where where
findVMDir vd = do path = vmName </> (vmName ++ ".vbox")
vs <- listDirectory vd findInstance dir = do
return $ if vm `elem` vs then Nothing res <- findFile [dir] path
else Just $ Msg Error $ "could not find " ++ singleQuote vm return $ case res of
Just p -> Right p
Nothing -> Left $ "could not find VM instance: " ++ singleQuote vmName
vmDirectory :: IO (Either String String) vmDirectory :: IO (Either String String)
vmDirectory = do vmDirectory = do
@ -38,6 +45,8 @@ vmDirectory = do
findDir e = findAttr (unqual "defaultMachineFolder") findDir e = findAttr (unqual "defaultMachineFolder")
=<< findChild (qual e "SystemProperties") =<< findChild (qual e "SystemProperties")
=<< findChild (qual e "Global") e =<< findChild (qual e "Global") e
qual :: Element -> String -> QName
qual e n = (elName e) { qName = n } qual e n = (elName e) { qName = n }
vmConfig :: IO FilePath vmConfig :: IO FilePath

View File

@ -89,3 +89,15 @@ executable xmobar
, unix >= 2.7.2.2 , unix >= 2.7.2.2
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures -threaded ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures -threaded
executable vbox-start
main-is: bin/vbox-start.hs
build-depends: base
, my-xmonad
, process >= 1.6.5.0
, filepath >= 1.4.2.1
, directory >= 1.3.3.0
, unix >= 2.7.2.2
, xml >= 1.3.14
default-language: Haskell2010
ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures -threaded