From 82c6ac1509f2bd74ed29b33da6cced13826bfb71 Mon Sep 17 00:00:00 2001
From: Benjamin Koch <snowball@c3pb.de>
Date: Wed, 16 Dec 2020 20:53:04 +0100
Subject: [PATCH] Add block qubesCount
---
src/QBar/Blocks.hs | 1 +
src/QBar/Blocks/Qubes.hs | 10 +++++++++-
src/QBar/Cli.hs | 3 ++-
src/QBar/Qubes/AdminAPI.hs | 4 ++++
4 files changed, 16 insertions(+), 2 deletions(-)
diff --git a/src/QBar/Blocks.hs b/src/QBar/Blocks.hs
index b1c15ff..60f9a70 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 6a0e79a..aff5b6a 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 4a7a04a..af1d19e 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 3ac551a..bd1a458 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)
--
GitLab