From 815cbe972450a1726eb8cf352101e7e043277756 Mon Sep 17 00:00:00 2001
From: Benjamin Koch <snowball@c3pb.de>
Date: Wed, 16 Dec 2020 02:47:23 +0100
Subject: [PATCH] Update Qubes property on click
---
src/QBar/Blocks/Qubes.hs | 33 +++++++++++++++++++++++++--------
1 file changed, 25 insertions(+), 8 deletions(-)
diff --git a/src/QBar/Blocks/Qubes.hs b/src/QBar/Blocks/Qubes.hs
index 908b21b..bb9220a 100644
--- a/src/QBar/Blocks/Qubes.hs
+++ b/src/QBar/Blocks/Qubes.hs
@@ -3,13 +3,15 @@ module QBar.Blocks.Qubes where
import QBar.BlockHelper
import QBar.BlockOutput
import QBar.Core
-import QBar.Qubes.AdminAPI (qubesUsageOfDefaultPool, qubesMonitorProperty, qubesEvents, QubesPropertyInfo (..))
+import QBar.Qubes.AdminAPI (qubesUsageOfDefaultPool, qubesMonitorProperty, qubesGetProperty, qubesEvents, QubesPropertyInfo (..))
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text.Lazy as T
import Data.Text.Lazy.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
-import Pipes
+import Pipes as P
+import Pipes.Concurrent as P
+import qualified Pipes.Safe as P
diskIcon :: T.Text
diskIcon = "💾\xFE0E"
@@ -26,7 +28,9 @@ diskUsageQubesBlock = runPollBlock $ forever $ do
createBlockOutput :: Int -> BlockOutput
createBlockOutput free =
mkBlockOutput $ chooseColor free $ formatSize free
- chooseColor _free = normalText --TODO
+ chooseColor free = if free < 40 * 1024*1024*1024
+ then activeText
+ else normalText
sizeUnits = [
("T", 1024*1024*1024*1024),
("G", 1024*1024*1024),
@@ -39,10 +43,23 @@ diskUsageQubesBlock = runPollBlock $ forever $ do
_ -> T.pack (show size) <> " bytes"
qubesMonitorPropertyBlock :: BL.ByteString -> Block
-qubesMonitorPropertyBlock name = fmap (const ExitBlock) (qubesMonitorProperty qubesEvents name) >-> forever update
+qubesMonitorPropertyBlock name = do
+ (output, input) <- liftIO $ spawn $ newest 1
+ forkSafeEffect $ qubesMonitorProperty qubesEvents name >-> toOutput output
+ toExitBlock $ fromInput input >-> forever (update output)
where
- update = do
- QubesPropertyInfo {propValue, propIsDefault} <- await
- pushBlockUpdate' handleClick $ mkBlockOutput $ normalText $ decode propValue <> (if propIsDefault then " (D)" else "")
- handleClick _ = return () --TODO
+ forkSafeEffect :: MonadIO m => Effect (P.SafeT IO) () -> m ()
+ forkSafeEffect = void . liftIO . forkIO . P.runSafeT . runEffect
+
+ forkEffect :: MonadIO m => Effect IO () -> m ()
+ forkEffect = void . liftIO . forkIO . runEffect
+
+ toExitBlock = fmap (const ExitBlock)
+
decode = decodeUtf8With lenientDecode
+
+ update output = do
+ QubesPropertyInfo {propValue, propIsDefault} <- await
+ trace ("update: " <> show propValue) $ pushBlockUpdate' handleClick $ mkBlockOutput $ normalText $ decode propValue <> (if propIsDefault then " (D)" else "")
+ where
+ handleClick _ = forkEffect $ (liftIO (qubesGetProperty name) >>= yield) >-> toOutput output
--
GitLab