ADD vbox-start binary

bin/vbox-start.hs

@@ -0,0 +1,77 @@
+{-# 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           Control.Exception
+
+import           Data.List
+
+import           Text.Read
+import           Text.XML.Light
+
+import           System.Environment
+import           System.Exit
+
+import           XMonad.Internal.Concurrent.VirtualBox
+import           XMonad.Internal.Process
+
+main :: IO ()
+main = runAndWait =<< getArgs
+
+runAndWait :: [String] -> IO ()
+runAndWait [n] = either putStrLn runConfig =<< vmInstanceConfig n
+  where
+    runConfig c = maybe err runID =<< vmMachineID c
+    runID i = do
+      vmLaunch i
+      p <- vmPID i
+      waitUntilExit p
+    err = putStrLn "Could not get machine ID"
+
+runAndWait _ = putStrLn "Usage: vbox-start VBOXNAME"
+
+vmLaunch :: String -> IO ()
+vmLaunch i = do
+  (rc, _, _) <- readCreateProcessWithExitCode' cmd ""
+  case rc of
+    ExitSuccess -> return ()
+    _           -> putStrLn $ "Failed to start VM: " ++ i
+  where
+    cmd = proc "VBoxManage" ["startvm", i]
+
+vmPID :: String -> IO (Maybe Int)
+vmPID vid = do
+  (rc, out, _) <- readCreateProcessWithExitCode' cmd ""
+  return $ case rc of
+    ExitSuccess -> readMaybe out
+    _           -> Nothing
+  where
+    cmd = proc "pgrep" ["-f", "VirtualBoxVM.*" ++ vid]
+
+vmMachineID :: FilePath -> IO (Maybe String)
+vmMachineID iPath = do
+  (s :: Either IOException String) <- try $ readFile iPath
+  return $ case s of
+    (Left _)  -> Nothing
+    (Right x) -> findMachineID =<< parseXMLDoc x
+  where
+    findMachineID e = stripPrefix "{"
+      =<< (fmap reverse . stripPrefix "}" . reverse)
+      =<< findAttr (blank_name { qName = "uuid" })
+      =<< findChild (qual e "Machine") e
+

bin/xmonad.hs

@@ -262,6 +262,7 @@ gimpDynamicWorkspace = sometimesIO_ "gimp workspace" "gimp" tree dw
       <&&> className =? c
     c = "Gimp-2.10" -- TODO I don't feel like changing the version long term
 
+-- TODO don't hardcode the VM name/title/shortcut
 vmDynamicWorkspace :: Sometimes DynWorkspace
 vmDynamicWorkspace = Sometimes "virtualbox workspace" xpfVirtualBox
   [Subfeature root "windows 8 VM"]

lib/XMonad/Internal/Command/Desktop.hs

@@ -286,6 +286,7 @@ runToggleEthernet = Sometimes "ethernet toggle" xpfEthernet
 runRestart :: X ()
 runRestart = restart "xmonad" True
 
+-- TODO only recompile the VM binary if we have virtualbox enabled
 runRecompile :: X ()
 runRecompile = do
   -- assume that the conf directory contains a valid stack project

lib/XMonad/Internal/Concurrent/VirtualBox.hs

@@ -4,6 +4,8 @@
 
 module XMonad.Internal.Concurrent.VirtualBox
   ( vmExists
+  , vmInstanceConfig
+  , qual
   ) where
 
 import           Control.Exception
@@ -13,18 +15,23 @@ import           Data.Internal.Dependency
 import           Text.XML.Light
 
 import           System.Directory
+import           System.FilePath
 
 import           XMonad.Internal.Shell
 
 vmExists :: String -> IO (Maybe Msg)
-vmExists vm = do
-  d <- vmDirectory
-  either (return . Just . Msg Error) findVMDir d
+vmExists vm = either (const Nothing) (Just . Msg Error) <$> vmInstanceConfig vm
+
+vmInstanceConfig :: String -> IO (Either String FilePath)
+vmInstanceConfig vmName = do
+  either (return . Right) findInstance =<< vmDirectory
   where
-    findVMDir vd = do
-      vs <- listDirectory vd
-      return $ if vm `elem` vs then Nothing
-        else Just $ Msg Error $ "could not find " ++ singleQuote vm
+    path = vmName </> (vmName ++ ".vbox")
+    findInstance dir = do
+      res <- findFile [dir] path
+      return $ case res of
+        Just p  -> Right p
+        Nothing -> Left $ "could not find VM instance: " ++ singleQuote vmName
 
 vmDirectory :: IO (Either String String)
 vmDirectory = do
@@ -38,6 +45,8 @@ vmDirectory = do
     findDir e = findAttr (unqual "defaultMachineFolder")
       =<< findChild (qual e "SystemProperties")
       =<< findChild (qual e "Global") e
+
+qual :: Element -> String -> QName
 qual e n = (elName e) { qName = n }
 
 vmConfig :: IO FilePath

my-xmonad.cabal

@@ -89,3 +89,15 @@ executable xmobar
                  , unix >= 2.7.2.2
     default-language: Haskell2010
     ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures -threaded
+
+executable vbox-start
+    main-is: bin/vbox-start.hs
+    build-depends: base
+                 , my-xmonad
+                 , process >= 1.6.5.0
+                 , filepath >= 1.4.2.1
+                 , directory >= 1.3.3.0
+                 , unix >= 2.7.2.2
+                 , xml >= 1.3.14
+    default-language: Haskell2010
+    ghc-options: -Wall -Werror -Wpartial-fields -fno-warn-missing-signatures -threaded