From 893ca6c18323d84129e78429604f7789d688bfb3 Mon Sep 17 00:00:00 2001
From: Benjamin Koch <snowball@c3pb.de>
Date: Wed, 16 Dec 2020 03:54:18 +0100
Subject: [PATCH] Refactor pipeBlockWithEvents: use BarIO and ExitBlock for
producer
---
src/QBar/Blocks/Qubes.hs | 18 ++++++++++--------
1 file changed, 10 insertions(+), 8 deletions(-)
diff --git a/src/QBar/Blocks/Qubes.hs b/src/QBar/Blocks/Qubes.hs
index a88cd67..6a0e79a 100644
--- a/src/QBar/Blocks/Qubes.hs
+++ b/src/QBar/Blocks/Qubes.hs
@@ -5,6 +5,8 @@ import QBar.BlockOutput
import QBar.Core
import QBar.Qubes.AdminAPI (qubesUsageOfDefaultPool, qubesMonitorProperty, qubesGetProperty, qubesEvents, QubesPropertyInfo (..))
+import Control.Concurrent.Async
+import Control.Monad.Reader (runReaderT)
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text.Lazy as T
import Data.Text.Lazy.Encoding (decodeUtf8With)
@@ -43,20 +45,20 @@ diskUsageQubesBlock = runPollBlock $ forever $ do
((unit, factor) : _) -> T.pack (show $ size `div` factor) <> unit
_ -> T.pack (show size) <> " bytes"
-pipeBlockWithEvents :: forall a. Producer a (P.SafeT IO) () -> (Either BlockEvent a -> BarIO (Maybe BlockOutput)) -> Block
+pipeBlockWithEvents :: forall a. Producer a BarIO ExitBlock -> (Either BlockEvent a -> BarIO (Maybe BlockOutput)) -> Block
pipeBlockWithEvents prod block = do
+ bar <- askBar
(output, input) <- liftIO $ spawn $ newest 1
- forkSafeEffect $ prod >-> P.map Right >-> toOutput output
- toExitBlock $ fromInput input >-> forever (update output)
+ exitValue <- forkBarEffect bar $ prod >-> P.map Right >-> forever (toOutput output)
+ fromInput input >-> forever (update output)
+ liftIO $ wait exitValue
where
- forkSafeEffect :: MonadIO m => Effect (P.SafeT IO) () -> m ()
- forkSafeEffect = void . liftIO . forkIO . P.runSafeT . runEffect
+ forkBarEffect :: MonadIO m => Bar -> Effect BarIO b -> m (Async b)
+ forkBarEffect bar = liftIO . async . flip runReaderT bar . P.runSafeT . runEffect
forkEffect :: MonadIO m => Effect IO () -> m ()
forkEffect = void . liftIO . forkIO . runEffect
- toExitBlock = fmap (const ExitBlock)
-
update :: Output (Either (BlockOutput, BlockEvent) a) -> Pipe (Either (BlockOutput, BlockEvent) a) (BlockState, BlockUpdateReason) BarIO ()
update output = await >>= \case
Right prop -> update' $ Right prop
@@ -74,7 +76,7 @@ pipeBlockWithEvents prod block = do
forkEffect $ yield (Left (blockOutput, event)) >-> toOutput output
qubesMonitorPropertyBlock :: BL.ByteString -> Block
-qubesMonitorPropertyBlock name = pipeBlockWithEvents (qubesMonitorProperty qubesEvents name) handle
+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 "")
--
GitLab