xmonad-config/bin/vbox-start.hs

75 lines
2.4 KiB
Haskell
Raw Normal View History

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