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           Text.XML.Light

import           System.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 _ = 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 Int)
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