Add block qubesCount

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,
   )

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)

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 ())

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)