From 2bcc086ab791c75e08b29e2445abf1a9852b60f1 Mon Sep 17 00:00:00 2001
From: Benjamin Koch <snowball@c3pb.de>
Date: Wed, 16 Dec 2020 21:08:31 +0100
Subject: [PATCH] Add animation on click to qubesCount
---
src/QBar/Blocks/Qubes.hs | 11 +++++------
1 file changed, 5 insertions(+), 6 deletions(-)
diff --git a/src/QBar/Blocks/Qubes.hs b/src/QBar/Blocks/Qubes.hs
index aff5b6a..50e67ac 100644
--- a/src/QBar/Blocks/Qubes.hs
+++ b/src/QBar/Blocks/Qubes.hs
@@ -3,7 +3,7 @@ module QBar.Blocks.Qubes where
import QBar.BlockHelper
import QBar.BlockOutput
import QBar.Core
-import QBar.Qubes.AdminAPI (qubesUsageOfDefaultPool, qubesMonitorProperty, qubesGetProperty, qubesEvents, QubesPropertyInfo (..), qubesListVMsP, QubesVMState (..), vmState)
+import QBar.Qubes.AdminAPI (qubesUsageOfDefaultPool, qubesMonitorProperty, qubesGetProperty, qubesEvents, QubesPropertyInfo (..), qubesListVMs, qubesListVMsP, QubesVMState (..), vmState)
import Control.Concurrent.Async
import Control.Monad.Reader (runReaderT)
@@ -79,13 +79,12 @@ pipeBlockWithEvents prod block = do
qubesMonitorPropertyBlock :: BL.ByteString -> Block
qubesMonitorPropertyBlock name = pipeBlockWithEvents (qubesMonitorProperty qubesEvents name >> exitBlock) handle
where
- handle = handle' <=< either (const $ liftIO $ qubesGetProperty name) return
- handle' QubesPropertyInfo {propValue, propIsDefault} = return $ Just $ mkBlockOutput $ normalText $ decode propValue <> (if propIsDefault then " (D)" else "")
+ handle = fmap handle' . either (const $ liftIO $ qubesGetProperty name) return
+ handle' QubesPropertyInfo {propValue, propIsDefault} = 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
+qubesVMCountBlock = pipeBlockWithEvents (qubesListVMsP >> exitBlock) $ fmap countVMs . either (const $ liftIO $ qubesListVMs) return where
+ countVMs = Just . 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)
--
GitLab