xmonad-config/lib/XMonad/Internal/Concurrent/VirtualBox.hs

{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

--------------------------------------------------------------------------------
-- | VirtualBox-specific functions

module XMonad.Internal.Concurrent.VirtualBox
  ( vmExists
  , vmInstanceConfig
  , qual
  ) where

import           Control.Exception

import           Data.Internal.Dependency

import           Text.XML.Light

import           RIO                      hiding (try)
import           RIO.FilePath
import qualified RIO.Text                 as T

import           System.Directory

import           XMonad.Internal.Shell

vmExists :: T.Text -> IO (Maybe Msg)
vmExists vm = either (Just . Msg LevelError) (const Nothing) <$> vmInstanceConfig vm

vmInstanceConfig :: T.Text -> IO (Either T.Text FilePath)
vmInstanceConfig vmName = do
  either (return . Right) findInstance =<< vmDirectory
  where
    path = T.unpack vmName </> addExtension (T.unpack vmName) "vbox"
    findInstance dir = do
      res <- findFile [dir] path
      return $ case res of
        Just p  -> Right p
        Nothing -> Left $ T.append "could not find VM instance: " $ singleQuote vmName

vmDirectory :: IO (Either String String)
vmDirectory = do
  p <- vmConfig
  (s :: Either IOException String) <- try $ readFile p
  return $ case s of
    (Left _) -> Left "could not read VirtualBox config file"
    (Right x) -> maybe (Left "Could not parse VirtualBox config file") Right
                 $ findDir =<< parseXMLDoc x
  where
    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
vmConfig = getXdgDirectory XdgConfig "VirtualBox/VirtualBox.xml"