56 lines
1.7 KiB
Haskell
56 lines
1.7 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | VirtualBox-specific functions
|
|
|
|
module XMonad.Internal.Concurrent.VirtualBox
|
|
( vmExists
|
|
, vmInstanceConfig
|
|
, qual
|
|
) where
|
|
|
|
import Data.Internal.Dependency
|
|
|
|
import RIO hiding (try)
|
|
import RIO.Directory
|
|
import RIO.FilePath
|
|
import qualified RIO.Text as T
|
|
|
|
import Text.XML.Light
|
|
|
|
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 <- tryIO $ 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"
|