xmonad-config/bin/vbox-start.hs

80 lines
2.5 KiB
Haskell

{-# 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 qualified RIO.Text as T
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 . T.unpack) runConfig =<< vmInstanceConfig (T.pack 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