78 lines
2.5 KiB
Haskell
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
|