xmonad-config/bin/vbox-start.hs

{-# 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.Environment
import System.Process (Pid)
import Text.XML.Light
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 _ = liftIO $ putStrLn "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