diff --git a/bin/vbox-start.hs b/bin/vbox-start.hs index 0204f4a..59cc599 100644 --- a/bin/vbox-start.hs +++ b/bin/vbox-start.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------------------- @@ -17,63 +18,63 @@ module Main (main) where -import Control.Exception - -import Data.List +import qualified Data.ByteString.Lazy.UTF8 as BU +import RIO +import RIO.Process import qualified RIO.Text as T -import Text.Read import Text.XML.Light import System.Environment -import System.Exit import XMonad.Internal.Concurrent.VirtualBox -import XMonad.Internal.Process +import XMonad.Internal.Process (waitUntilExit) main :: IO () -main = runAndWait =<< getArgs +main = do + args <- getArgs + runSimpleApp $ + runAndWait args -runAndWait :: [String] -> IO () -runAndWait [n] = either (putStrLn . T.unpack) runConfig =<< vmInstanceConfig (T.pack n) +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 - waitUntilExit p - err = putStrLn "Could not get machine ID" + liftIO $ waitUntilExit p + err = logError "Could not get machine ID" -runAndWait _ = putStrLn "Usage: vbox-start VBOXNAME" +runAndWait _ = liftIO $ putStrLn "Usage: vbox-start VBOXNAME" -vmLaunch :: String -> IO () +vmLaunch :: T.Text -> RIO SimpleApp () vmLaunch i = do - (rc, _, _) <- readCreateProcessWithExitCode' cmd "" + rc <- proc "VBoxManage" ["startvm", T.unpack i] runProcess case rc of ExitSuccess -> return () - _ -> putStrLn $ "Failed to start VM: " ++ i - where - cmd = proc "VBoxManage" ["startvm", i] + _ -> logError $ "Failed to start VM: " + <> displayBytesUtf8 (encodeUtf8 i) -vmPID :: String -> IO (Maybe Int) +vmPID :: T.Text -> RIO SimpleApp (Maybe Int) vmPID vid = do - (rc, out, _) <- readCreateProcessWithExitCode' cmd "" + (rc, out) <- proc "pgrep" ["-f", "VirtualBoxVM.*" ++ T.unpack vid] readProcessStdout return $ case rc of - ExitSuccess -> readMaybe $ T.unpack out + ExitSuccess -> readMaybe $ BU.toString out _ -> Nothing - where - cmd = proc "pgrep" ["-f", "VirtualBoxVM.*" ++ vid] -vmMachineID :: FilePath -> IO (Maybe String) +vmMachineID :: FilePath -> RIO SimpleApp (Maybe T.Text) vmMachineID iPath = do - (s :: Either IOException String) <- try $ readFile iPath - return $ case s of - (Left _) -> Nothing - (Right x) -> findMachineID =<< parseXMLDoc x + res <- tryAny $ readFileUtf8 iPath + case res of + Right contents -> return $ findMachineID contents + Left e -> logError (displayShow e) >> return Nothing where - findMachineID e = stripPrefix "{" - =<< (fmap reverse . stripPrefix "}" . reverse) - =<< findAttr (blank_name { qName = "uuid" }) - =<< findChild (qual e "Machine") e - + findMachineID c = T.stripSuffix "}" + =<< T.stripPrefix "{" + =<< (fmap T.pack . findAttr (blank_name { qName = "uuid" })) + =<< (\e -> findChild (qual e "Machine") e) + =<< parseXMLDoc c diff --git a/package.yaml b/package.yaml index 322a600..4d2ae55 100644 --- a/package.yaml +++ b/package.yaml @@ -40,6 +40,7 @@ dependencies: - hashable >= 1.3.5.0 - xml >= 1.3.14 - lifted-base >= 0.2.3.12 + - utf8-string >= 1.0.2 library: source-dirs: lib/