From f4a9fceacd46697a625283eaa08302794f11f662 Mon Sep 17 00:00:00 2001
From: Jens Nolte <git@queezle.net>
Date: Fri, 2 Apr 2021 00:35:39 +0200
Subject: [PATCH] Add 'squeekboard' block
---
src/QBar/Blocks.hs | 2 +
src/QBar/Blocks/Squeekboard.hs | 77 ++++++++++++++++++++++++++++++++++
src/QBar/Cli.hs | 10 ++++-
src/QBar/Theme.hs | 2 +-
4 files changed, 88 insertions(+), 3 deletions(-)
create mode 100644 src/QBar/Blocks/Squeekboard.hs
diff --git a/src/QBar/Blocks.hs b/src/QBar/Blocks.hs
index 60f9a70..1dccb3a 100644
--- a/src/QBar/Blocks.hs
+++ b/src/QBar/Blocks.hs
@@ -9,6 +9,7 @@ module QBar.Blocks
QBar.Blocks.Qubes.qubesVMCountBlock,
QBar.Blocks.Script.scriptBlock,
QBar.Blocks.Script.pollScriptBlock,
+ QBar.Blocks.Squeekboard.squeekboardBlock,
)
where
@@ -19,3 +20,4 @@ import qualified QBar.Blocks.DiskUsage
import qualified QBar.Blocks.NetworkManager
import qualified QBar.Blocks.Qubes
import qualified QBar.Blocks.Script
+import qualified QBar.Blocks.Squeekboard
diff --git a/src/QBar/Blocks/Squeekboard.hs b/src/QBar/Blocks/Squeekboard.hs
new file mode 100644
index 0000000..d32a589
--- /dev/null
+++ b/src/QBar/Blocks/Squeekboard.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE FlexibleContexts #-}
+
+module QBar.Blocks.Squeekboard where
+
+import Control.Monad.Except (MonadError)
+import Data.Either (isRight)
+import qualified DBus
+import qualified DBus.Client as DBus
+import DBus.Internal.Message (signalBody)
+import Pipes.Core
+import QBar.BlockHelper
+import QBar.BlockOutput
+import QBar.Blocks.NetworkManager (getDBusProperty, runExceptT_)
+import QBar.Core
+
+squeekboardBlock :: Bool -> Block
+squeekboardBlock autoHide = runSignalBlockConfiguration $ SignalBlockConfiguration {
+ aquire,
+ release,
+ signalThread = Nothing,
+ signalBlock = networkManagerBlock',
+ interval = Nothing
+}
+ where
+ aquire :: (() -> IO ()) -> BarIO DBus.Client
+ aquire trigger = liftIO $ do
+ client <- DBus.connectSession
+ let matchRule = DBus.matchAny {
+ DBus.matchPath = Just "/sm/puri/OSK0",
+ DBus.matchInterface = Just "org.freedesktop.DBus.Properties",
+ DBus.matchMember = Just "PropertiesChanged"
+ }
+ void . DBus.addMatch client matchRule $ dbusSignalHandler trigger
+ let matchRule2 = DBus.matchAny {
+ DBus.matchSender = Just "org.freedesktop.DBus",
+ DBus.matchPath = Just "/org/freedesktop/DBus",
+ DBus.matchInterface = Just "org.freedesktop.DBus",
+ DBus.matchMember = Just "NameOwnerChanged"
+ }
+ void . DBus.addMatch client matchRule2 $ \signal -> when (nameOwnerChangedIsPuriOSK0 (signalBody signal)) $ dbusSignalHandler trigger signal
+ return client
+ nameOwnerChangedIsPuriOSK0 :: [DBus.Variant] -> Bool
+ nameOwnerChangedIsPuriOSK0 (path:_) = path == DBus.toVariant ("sm.puri.OSK0" :: String)
+ nameOwnerChangedIsPuriOSK0 _ = False
+ release :: DBus.Client -> BarIO ()
+ release = liftIO . DBus.disconnect
+ networkManagerBlock' :: DBus.Client -> SignalBlock ()
+ networkManagerBlock' client = (liftBarIO . networkManagerBlock'' client) >=> respond >=> networkManagerBlock' client
+ networkManagerBlock'' :: DBus.Client -> Signal () -> BarIO (Maybe BlockOutput)
+ networkManagerBlock'' client (EventSignal Click{button=1}) = do
+ mCurrent <- runExceptT_ (getVisible client)
+ case mCurrent of
+ (Just current) -> void $ setVisible client (not current)
+ Nothing -> return ()
+ networkManagerBlock''' client
+ networkManagerBlock'' client _ = networkManagerBlock''' client
+ networkManagerBlock''' :: DBus.Client -> BarIO (Maybe BlockOutput)
+ networkManagerBlock''' client = blockOutput <$> runExceptT_ (getVisible client)
+ blockOutput :: Maybe Bool -> Maybe BlockOutput
+ blockOutput (Just isEnabled) = Just (mkBlockOutput (mkText isEnabled normalImportant "⌨\xFE0E osk"))
+ blockOutput Nothing = if autoHide then Nothing else Just (mkBlockOutput $ mkText False errorImportant "⌨\xFE0E n/a")
+ dbusSignalHandler :: (() -> IO ()) -> DBus.Signal -> IO ()
+ dbusSignalHandler trigger _signal = trigger ()
+
+getVisible :: (MonadError () m, MonadIO m) => DBus.Client -> m Bool
+getVisible client = do
+ getDBusProperty
+ client
+ "sm.puri.OSK0"
+ "/sm/puri/OSK0"
+ "sm.puri.OSK0"
+ "Visible"
+
+setVisible :: (MonadIO m) => DBus.Client -> Bool -> m Bool
+setVisible client value = do
+ let methodCall = ((DBus.methodCall "/sm/puri/OSK0" "sm.puri.OSK0" "SetVisible") {DBus.methodCallDestination = Just "sm.puri.OSK0", DBus.methodCallBody = [DBus.toVariant value]})
+ isRight <$> liftIO (DBus.call client methodCall)
diff --git a/src/QBar/Cli.hs b/src/QBar/Cli.hs
index c1febf9..618c2b5 100644
--- a/src/QBar/Cli.hs
+++ b/src/QBar/Cli.hs
@@ -98,10 +98,11 @@ blockParser =
hidden <>
command "date" (info (pure $ addBlock dateBlock) (progDesc "Load the date and time block.")) <>
command "cpu" (info (pure $ addBlock $ cpuUsageBlock 1) (progDesc "Load the cpu usage block.")) <>
- command "battery" (info (pure $ addBlock $ batteryBlock) (progDesc "Load the battery block.")) <>
+ command "battery" (info (pure $ addBlock batteryBlock) (progDesc "Load the battery block.")) <>
command "disk" (info diskUsageBlockParser (progDesc "Load the disk usage block.")) <>
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 "squeekboard" (info squeekboardParser (progDesc "Toggles the visibility of the 'squeekboard' on-screen-keyboard when clicked (squeekboard must be running).")) <>
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 "qubesCount" (info (pure $ addBlock qubesVMCountBlock) (progDesc "Display the number of running Qubes (VMs)."))
@@ -122,12 +123,17 @@ scriptBlockParser = helper <*> do
long "interval" <>
short 'i' <>
metavar "SECONDS" <>
- (help $ "Interval to use for --poll mode (default: " <> humanReadableInterval defaultInterval <> ")")
+ help ("Interval to use for --poll mode (default: " <> humanReadableInterval defaultInterval <> ")")
))
clickEvents <- switch $ long "events" <> short 'e' <> help "Send click events to stdin of the script"
script <- strArgument (metavar "SCRIPT" <> help "The script that will be executed with a shell.")
return $ (if poll then addBlock . pollScriptBlock pollInterval else addBlock . scriptBlock clickEvents) script
+squeekboardParser :: Parser (BarIO ())
+squeekboardParser = do
+ autoHide <- switch $ long "auto-hide" <> short 'q' <> help "Hide the block (instead of showing an error) when squeekboard is not running."
+ return $ addBlock (squeekboardBlock autoHide)
+
qubesPropertyBlockParser :: Parser (BarIO ())
qubesPropertyBlockParser = do
name <- strArgument (metavar "NAME" <> help "The NAME of the property.")
diff --git a/src/QBar/Theme.hs b/src/QBar/Theme.hs
index ba9dbc2..e864808 100644
--- a/src/QBar/Theme.hs
+++ b/src/QBar/Theme.hs
@@ -138,7 +138,7 @@ rainbowTheme = AnimatedTheme rainbowThemePipe
rainbowThemePipe :: AnimatedTheme
rainbowThemePipe = do
time <- liftIO $ fromRational . toRational <$> getPOSIXTime
- yield =<< rainbowThemePipe' time <$> await
+ yield . rainbowThemePipe' time =<< await
rainbowThemePipe
rainbowThemePipe' :: Double -> StaticTheme
rainbowThemePipe' time blocks = reverse $ evalState (mapM rainbowBlock $ reverse blocks) 0
--
GitLab