xmonad-config/bin/vbox-start.hs

78 lines
2.5 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# 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 qualified Data.ByteString.Lazy.UTF8 as BU
import RIO
import RIO.Process
import qualified RIO.Text as T
import System.Process (Pid)
import Text.XML.Light
import UnliftIO.Environment
import XMonad.Internal.Concurrent.VirtualBox
import XMonad.Internal.IO
main :: IO ()
main = do
args <- getArgs
runSimpleApp $
runAndWait args
runAndWait :: [String] -> RIO SimpleApp ()
runAndWait [n] = do
c <- liftIO $ vmInstanceConfig (T.pack n)
either (logError . displayBytesUtf8 . encodeUtf8) runConfig c
where
runConfig c = maybe err runID =<< vmMachineID c
runID i = do
vmLaunch i
p <- vmPID i
liftIO $ mapM_ waitUntilExit p
err = logError "Could not get machine ID"
runAndWait _ = logInfo "Usage: vbox-start VBOXNAME"
vmLaunch :: T.Text -> RIO SimpleApp ()
vmLaunch i = do
rc <- proc "VBoxManage" ["startvm", T.unpack i] runProcess
case rc of
ExitSuccess -> return ()
_ ->
logError $
"Failed to start VM: "
<> displayBytesUtf8 (encodeUtf8 i)
vmPID :: T.Text -> RIO SimpleApp (Maybe Pid)
vmPID vid = do
(rc, out) <- proc "pgrep" ["-f", "VirtualBoxVM.*" ++ T.unpack vid] readProcessStdout
return $ case rc of
ExitSuccess -> readMaybe $ BU.toString out
_ -> Nothing
vmMachineID :: FilePath -> RIO SimpleApp (Maybe T.Text)
vmMachineID iPath = do
res <- tryAny $ readFileUtf8 iPath
case res of
Right contents -> return $ findMachineID contents
Left e -> logError (displayShow e) >> return Nothing
where
findMachineID c =
T.stripSuffix "}"
=<< T.stripPrefix "{"
=<< (fmap T.pack . findAttr (blank_name {qName = "uuid"}))
=<< (\e -> findChild (qual e "Machine") e)
=<< parseXMLDoc c