diff --git a/src/QBar/Blocks.hs b/src/QBar/Blocks.hs index b1c15ff8c487a7a5a4f0c1366b3e29edb0107320..60f9a7013d1f4295d9a9fb79cd9be9d4348a65ec 100644 --- a/src/QBar/Blocks.hs +++ b/src/QBar/Blocks.hs @@ -6,6 +6,7 @@ module QBar.Blocks QBar.Blocks.NetworkManager.networkManagerBlock, QBar.Blocks.Qubes.diskUsageQubesBlock, QBar.Blocks.Qubes.qubesMonitorPropertyBlock, + QBar.Blocks.Qubes.qubesVMCountBlock, QBar.Blocks.Script.scriptBlock, QBar.Blocks.Script.pollScriptBlock, ) diff --git a/src/QBar/Blocks/Qubes.hs b/src/QBar/Blocks/Qubes.hs index 6a0e79a70e14f959fa9da8d6bb796728379b5575..aff5b6a0666b77945ff0046a9aa74b3fa06b76c2 100644 --- a/src/QBar/Blocks/Qubes.hs +++ b/src/QBar/Blocks/Qubes.hs @@ -3,11 +3,12 @@ module QBar.Blocks.Qubes where import QBar.BlockHelper import QBar.BlockOutput import QBar.Core -import QBar.Qubes.AdminAPI (qubesUsageOfDefaultPool, qubesMonitorProperty, qubesGetProperty, qubesEvents, QubesPropertyInfo (..)) +import QBar.Qubes.AdminAPI (qubesUsageOfDefaultPool, qubesMonitorProperty, qubesGetProperty, qubesEvents, QubesPropertyInfo (..), qubesListVMsP, QubesVMState (..), vmState) import Control.Concurrent.Async import Control.Monad.Reader (runReaderT) import qualified Data.ByteString.Lazy as BL +import qualified Data.Map as M import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) @@ -81,3 +82,10 @@ qubesMonitorPropertyBlock name = pipeBlockWithEvents (qubesMonitorProperty qubes handle = handle' <=< either (const $ liftIO $ qubesGetProperty name) return handle' QubesPropertyInfo {propValue, propIsDefault} = return $ Just $ mkBlockOutput $ normalText $ decode propValue <> (if propIsDefault then " (D)" else "") decode = decodeUtf8With lenientDecode + +qubesVMCountBlock :: Block +qubesVMCountBlock = qubesListVMsP >-> P.map countVMs >> exitBlock where + countVMs = wrap . format . M.size . M.filterWithKey isRunningVM + isRunningVM name x = vmState x == VMRunning && name /= "dom0" + format n = mkBlockOutput $ normalText $ T.pack (show n) <> " Qube" <> (if n /= 1 then "s" else "") + wrap x = (Just (x, Nothing), DefaultUpdate) diff --git a/src/QBar/Cli.hs b/src/QBar/Cli.hs index 4a7a04aa12533b9a9054c1f45435284ddf381ac7..af1d19ea6fdb95ac31546538c18b4623e3a3bac9 100644 --- a/src/QBar/Cli.hs +++ b/src/QBar/Cli.hs @@ -95,7 +95,8 @@ blockParser = command "networkmanager" (info (pure $ addBlock networkManagerBlock) (progDesc "Load the network-manager block.")) <> command "script" (info scriptBlockParser (progDesc "Display the output of an external script as a block.")) <> command "diskQubesPool" (info (pure $ addBlock diskUsageQubesBlock) (progDesc "Load a block that shows free space in Qubes' default pool.")) <> - command "qubesProperty" (info qubesPropertyBlockParser (progDesc "Display the current value of a Qubes property.")) + command "qubesProperty" (info qubesPropertyBlockParser (progDesc "Display the current value of a Qubes property.")) <> + command "qubesCount" (info (pure $ addBlock qubesVMCountBlock) (progDesc "Display the number of running Qubes (VMs).")) ) diskUsageBlockParser :: Parser (BarIO ()) diff --git a/src/QBar/Qubes/AdminAPI.hs b/src/QBar/Qubes/AdminAPI.hs index 3ac551a48b7ff7a80bede71a8a2042448dc43796..bd1a458a44d66833b4661f63bb7aad9bec50e21b 100644 --- a/src/QBar/Qubes/AdminAPI.hs +++ b/src/QBar/Qubes/AdminAPI.hs @@ -257,6 +257,10 @@ qubesListVMs = parse <$> qubesAdminCallLines "admin.vm.List" [] tryReadProp :: Read a => BL.ByteString -> Maybe a tryReadProp name = readMaybe . BLC.unpack =<< getProp name +qubesListVMsP :: forall m. (P.MonadSafe m, MonadIO m, MonadFail m) + => Producer (Map.Map BL.ByteString QubesVMInfo) m () +qubesListVMsP = liftIO qubesListVMs >>= yield >> qubesEvents >-> P.mapM (const $ liftIO qubesListVMs) + data QubesPropertyInfo = QubesPropertyInfo { propIsDefault :: Bool, propType :: BL.ByteString, propValue :: BL.ByteString } deriving (Eq, Ord, Show, Read)