ENH make client calls safe in plugins

This commit is contained in:
Nathan Dwarshuis 2021-11-23 18:28:38 -05:00
parent db42b83d48
commit 78dd1ee5b7
13 changed files with 93 additions and 78 deletions

View File

@ -12,6 +12,7 @@ module Main (main) where
-- * A custom Locks plugin from my own forked repo -- * A custom Locks plugin from my own forked repo
import Control.Monad (unless) import Control.Monad (unless)
import Data.Either import Data.Either
import Data.List import Data.List
import Data.Maybe import Data.Maybe
@ -42,12 +43,9 @@ import XMonad.Internal.Command.Power (hasBattery)
import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Control import XMonad.Internal.DBus.Control
import XMonad.Internal.Shell
-- import XMonad.Internal.DBus.Common (xmonadBus)
-- import XMonad.Internal.DBus.Control (pathExists)
import XMonad.Internal.DBus.Screensaver (ssSignalDep) import XMonad.Internal.DBus.Screensaver (ssSignalDep)
import XMonad.Internal.Dependency import XMonad.Internal.Dependency
-- import XMonad.Internal.Shell (fmtCmd) import XMonad.Internal.Shell
import qualified XMonad.Internal.Theme as T import qualified XMonad.Internal.Theme as T
import Xmobar import Xmobar
@ -223,13 +221,14 @@ dateCmd = CmdSpec
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | command runtime checks and setup -- | command runtime checks and setup
--
-- some commands depend on the presence of interfaces that can only be -- some commands depend on the presence of interfaces that can only be
-- determined at runtime; define these checks here -- determined at runtime; define these checks here
--
-- in the case of network interfaces, assume that the system uses systemd in -- in the case of network interfaces, assume that the system uses systemd in
-- which case ethernet interfaces always start with "en" and wireless -- which case ethernet interfaces always start with "en" and wireless
-- interfaces always start with "wl" -- interfaces always start with "wl"
isWireless :: String -> Bool isWireless :: String -> Bool
isWireless ('w':'l':_) = True isWireless ('w':'l':_) = True
isWireless _ = False isWireless _ = False
@ -288,11 +287,12 @@ getWireless = Feature
getEthernet :: Maybe Client -> BarFeature getEthernet :: Maybe Client -> BarFeature
getEthernet client = Feature getEthernet client = Feature
{ ftrDepTree = DBusTree (Double (\i _ -> ethernetCmd i) (readInterface isEthernet)) client [dep] [] { ftrDepTree = DBusTree action client [dep] []
, ftrName = "ethernet status indicator" , ftrName = "ethernet status indicator"
, ftrWarning = Default , ftrWarning = Default
} }
where where
action = Double (\i _ -> ethernetCmd i) (readInterface isEthernet)
dep = Endpoint devBus devPath devInterface $ Method_ devGetByIP dep = Endpoint devBus devPath devInterface $ Method_ devGetByIP
getBattery :: BarFeature getBattery :: BarFeature
@ -316,12 +316,10 @@ getVPN client = Feature
getBt :: Maybe Client -> BarFeature getBt :: Maybe Client -> BarFeature
getBt client = Feature getBt client = Feature
{ ftrDepTree = DBusTree (Single (const btCmd)) client [ep] [] { ftrDepTree = DBusTree (Single (const btCmd)) client [btDep] []
, ftrName = "bluetooth status indicator" , ftrName = "bluetooth status indicator"
, ftrWarning = Default , ftrWarning = Default
} }
where
ep = Endpoint btBus btPath btInterface $ Property_ btPowered
getAlsa :: BarFeature getAlsa :: BarFeature
getAlsa = Feature getAlsa = Feature

View File

@ -126,5 +126,5 @@ clevoKeyboardControls = brightnessControls clevoKeyboardConfig
callGetBrightnessCK :: Client -> IO (Maybe Brightness) callGetBrightnessCK :: Client -> IO (Maybe Brightness)
callGetBrightnessCK = callGetBrightness clevoKeyboardConfig callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
matchSignalCK :: (Maybe Brightness -> IO ()) -> IO SignalHandler matchSignalCK :: (Maybe Brightness -> IO ()) -> Client -> IO ()
matchSignalCK = matchSignal clevoKeyboardConfig matchSignalCK = matchSignal clevoKeyboardConfig

View File

@ -71,12 +71,9 @@ signalDep :: BrightnessConfig a b -> DBusDep
signalDep BrightnessConfig { bcPath = p, bcInterface = i } = signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
Endpoint xmonadBusName p i $ Signal_ memCur Endpoint xmonadBusName p i $ Signal_ memCur
matchSignal :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> IO SignalHandler matchSignal :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> Client -> IO ()
matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb = do matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
client <- connectSession addMatchCallback brMatcher (cb . bodyGetBrightness)
-- this connections must remain active
-- TODO does this need to be cleaned up during shutdown??
addMatch client brMatcher $ cb . bodyGetBrightness . signalBody
where where
brMatcher = matchAny brMatcher = matchAny
{ matchPath = Just p { matchPath = Just p

View File

@ -108,5 +108,5 @@ intelBacklightControls = brightnessControls intelBacklightConfig
callGetBrightnessIB :: Client -> IO (Maybe Brightness) callGetBrightnessIB :: Client -> IO (Maybe Brightness)
callGetBrightnessIB = callGetBrightness intelBacklightConfig callGetBrightnessIB = callGetBrightness intelBacklightConfig
matchSignalIB :: (Maybe Brightness -> IO ()) -> IO SignalHandler matchSignalIB :: (Maybe Brightness -> IO ()) -> Client -> IO ()
matchSignalIB = matchSignal intelBacklightConfig matchSignalIB = matchSignal intelBacklightConfig

View File

@ -3,9 +3,15 @@
module XMonad.Internal.DBus.Common module XMonad.Internal.DBus.Common
( addMatchCallback ( addMatchCallback
, getDBusClient
, withDBusClient
, withDBusClient_
, xmonadBusName , xmonadBusName
) where ) where
import Control.Exception
import Control.Monad
import DBus import DBus
import DBus.Client import DBus.Client
@ -13,7 +19,25 @@ xmonadBusName :: BusName
xmonadBusName = busName_ "org.xmonad" xmonadBusName = busName_ "org.xmonad"
-- | Bind a callback to a signal match rule -- | Bind a callback to a signal match rule
addMatchCallback :: MatchRule -> ([Variant] -> IO ()) -> IO SignalHandler addMatchCallback :: MatchRule -> ([Variant] -> IO ()) -> Client -> IO ()
addMatchCallback rule cb = do addMatchCallback rule cb client = void $ addMatch client rule $ cb . signalBody
client <- connectSession
addMatch client rule $ cb . signalBody getDBusClient :: Bool -> IO (Maybe Client)
getDBusClient sys = do
res <- try $ if sys then connectSystem else connectSession
case res of
Left e -> putStrLn (clientErrorMessage e) >> return Nothing
Right c -> return $ Just c
withDBusClient :: Bool -> (Client -> a) -> IO (Maybe a)
withDBusClient sys f = do
client <- getDBusClient sys
let r = f <$> client
mapM_ disconnect client
return r
withDBusClient_ :: Bool -> (Client -> IO ()) -> IO ()
withDBusClient_ sys f = do
client <- getDBusClient sys
mapM_ f client
mapM_ disconnect client

View File

@ -7,12 +7,13 @@ module XMonad.Internal.DBus.Control
( Client ( Client
, startXMonadService , startXMonadService
, getDBusClient , getDBusClient
, withDBusClient
, withDBusClient_
, stopXMonadService , stopXMonadService
, pathExists , pathExists
, disconnect , disconnect
) where ) where
import Control.Exception
import Control.Monad (forM_, void) import Control.Monad (forM_, void)
import Data.Either import Data.Either
@ -46,12 +47,6 @@ stopXMonadService client = do
void $ releaseName client xmonadBusName void $ releaseName client xmonadBusName
disconnect client disconnect client
getDBusClient :: Bool -> IO (Maybe Client)
getDBusClient sys = do
res <- try $ if sys then connectSystem else connectSession
case res of
Left e -> putStrLn (clientErrorMessage e) >> return Nothing
Right c -> return $ Just c
requestXMonadName :: Client -> IO () requestXMonadName :: Client -> IO ()
requestXMonadName client = do requestXMonadName client = do

View File

@ -129,7 +129,7 @@ callQuery client = do
reply <- callMethod client xmonadBusName ssPath interface memQuery reply <- callMethod client xmonadBusName ssPath interface memQuery
return $ either (const Nothing) bodyGetCurrentState reply return $ either (const Nothing) bodyGetCurrentState reply
matchSignal :: (Maybe SSState -> IO ()) -> IO SignalHandler matchSignal :: (Maybe SSState -> IO ()) -> Client -> IO ()
matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
ssSignalDep :: DBusDep ssSignalDep :: DBusDep

View File

@ -0,0 +1,25 @@
--------------------------------------------------------------------------------
-- | Common backlight plugin bits
--
-- Use the custom DBus interface exported by the XMonad process so I can react
-- to signals spawned by commands
module Xmobar.Plugins.BacklightCommon (startBacklight) where
import Control.Concurrent
import Control.Monad
import DBus.Client
import XMonad.Internal.DBus.Control
startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> Client -> IO ())
-> (Client -> IO (Maybe a)) -> String -> (String -> IO ()) -> IO ()
startBacklight matchSignal callGetBrightness icon cb = do
withDBusClient_ False $ \c -> do
matchSignal (cb . formatBrightness) c
cb . formatBrightness =<< callGetBrightness c
forever (threadDelay 5000000)
where
formatBrightness = maybe "N/A" $
\b -> icon ++ show (round b :: Integer) ++ "%"

View File

@ -9,24 +9,24 @@
module Xmobar.Plugins.Bluetooth module Xmobar.Plugins.Bluetooth
( Bluetooth(..) ( Bluetooth(..)
, btAlias , btAlias
, btBus , btDep
, btPath
, btPowered
, btInterface
) where ) where
import DBus import DBus
import DBus.Client import DBus.Client
import XMonad.Hooks.DynamicLog (xmobarColor) import XMonad.Hooks.DynamicLog (xmobarColor)
import XMonad.Internal.Dependency
import Xmobar import Xmobar
data Bluetooth = Bluetooth (String, String, String) Int data Bluetooth = Bluetooth (String, String, String) Int
deriving (Read, Show) deriving (Read, Show)
callGetPowered :: Client -> IO (Either MethodError Variant) -- TODO match property signal here
callGetPowered client = callGetPowered :: Client -> IO (Maybe Variant)
getProperty client (methodCall btPath btInterface $ memberName_ btPowered) callGetPowered client = either (const Nothing) Just
<$> getProperty client (methodCall btPath btInterface $ memberName_ btPowered)
{ methodCallDestination = Just btBus } { methodCallDestination = Just btBus }
btInterface :: InterfaceName btInterface :: InterfaceName
@ -47,6 +47,9 @@ btPath = "/org/bluez/hci0"
btAlias :: String btAlias :: String
btAlias = "bluetooth" btAlias = "bluetooth"
btDep :: DBusDep
btDep = Endpoint btBus btPath btInterface $ Property_ btPowered
instance Exec Bluetooth where instance Exec Bluetooth where
alias (Bluetooth _ _) = btAlias alias (Bluetooth _ _) = btAlias
rate (Bluetooth _ r) = r rate (Bluetooth _ r) = r
@ -54,12 +57,8 @@ instance Exec Bluetooth where
client <- connectSystem client <- connectSystem
reply <- callGetPowered client reply <- callGetPowered client
disconnect client disconnect client
return $ fmtState $ procReply reply return $ fmtState $ fromVariant =<< reply
where where
procReply = \case
-- TODO handle errors?
Right r -> fromVariant r
Left _ -> Nothing
fmtState = \case fmtState = \case
Just s -> xmobarColor (if s then colorOn else colorOff) "" text Just s -> xmobarColor (if s then colorOn else colorOff) "" text
Nothing -> "N/A" Nothing -> "N/A"

View File

@ -1,5 +1,3 @@
{-# LANGUAGE LambdaCase #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Clevo Keyboard plugin -- | Clevo Keyboard plugin
-- --
@ -11,13 +9,10 @@ module Xmobar.Plugins.ClevoKeyboard
, ckAlias , ckAlias
) where ) where
import Control.Concurrent
import Control.Monad
import DBus.Client
import Xmobar import Xmobar
import Xmobar.Plugins.BacklightCommon
import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.ClevoKeyboard
newtype ClevoKeyboard = ClevoKeyboard String deriving (Read, Show) newtype ClevoKeyboard = ClevoKeyboard String deriving (Read, Show)
@ -28,12 +23,4 @@ ckAlias = "clevokeyboard"
instance Exec ClevoKeyboard where instance Exec ClevoKeyboard where
alias (ClevoKeyboard _) = ckAlias alias (ClevoKeyboard _) = ckAlias
start (ClevoKeyboard icon) cb = do start (ClevoKeyboard icon) cb = do
_ <- matchSignalCK $ cb . formatBrightness startBacklight matchSignalCK callGetBrightnessCK icon cb
-- TODO this could fail, and also should try to reuse client objects when
-- possible
cb . formatBrightness =<< callGetBrightnessCK =<< connectSession
forever (threadDelay 5000000)
where
formatBrightness = \case
Just b -> icon ++ show (round b :: Integer) ++ "%"
Nothing -> "N/A"

View File

@ -1,5 +1,3 @@
{-# LANGUAGE LambdaCase #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Intel backlight plugin -- | Intel backlight plugin
-- --
@ -11,13 +9,10 @@ module Xmobar.Plugins.IntelBacklight
, blAlias , blAlias
) where ) where
import Control.Concurrent
import Control.Monad
import DBus.Client
import Xmobar import Xmobar
import Xmobar.Plugins.BacklightCommon
import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight
newtype IntelBacklight = IntelBacklight String deriving (Read, Show) newtype IntelBacklight = IntelBacklight String deriving (Read, Show)
@ -27,11 +22,5 @@ blAlias = "intelbacklight"
instance Exec IntelBacklight where instance Exec IntelBacklight where
alias (IntelBacklight _) = blAlias alias (IntelBacklight _) = blAlias
start (IntelBacklight icon) cb = do start (IntelBacklight icon) cb =
_ <- matchSignalIB $ cb . formatBrightness startBacklight matchSignalIB callGetBrightnessIB icon cb
cb . formatBrightness =<< callGetBrightnessIB =<< connectSession
forever (threadDelay 5000000)
where
formatBrightness = \case
Just b -> icon ++ show (round b :: Integer) ++ "%"
Nothing -> "N/A"

View File

@ -14,11 +14,10 @@ module Xmobar.Plugins.Screensaver
import Control.Concurrent import Control.Concurrent
import Control.Monad import Control.Monad
import DBus.Client
import Xmobar import Xmobar
import XMonad.Hooks.DynamicLog (xmobarColor) import XMonad.Hooks.DynamicLog (xmobarColor)
import XMonad.Internal.DBus.Control
import XMonad.Internal.DBus.Screensaver import XMonad.Internal.DBus.Screensaver
newtype Screensaver = Screensaver (String, String, String) deriving (Read, Show) newtype Screensaver = Screensaver (String, String, String) deriving (Read, Show)
@ -29,8 +28,9 @@ ssAlias = "screensaver"
instance Exec Screensaver where instance Exec Screensaver where
alias (Screensaver _) = ssAlias alias (Screensaver _) = ssAlias
start (Screensaver (text, colorOn, colorOff)) cb = do start (Screensaver (text, colorOn, colorOff)) cb = do
_ <- matchSignal $ cb . fmtState withDBusClient_ False $ \c -> do
cb . fmtState =<< callQuery =<< connectSession matchSignal (cb . fmtState) c
cb . fmtState =<< callQuery c
forever (threadDelay 5000000) forever (threadDelay 5000000)
where where
fmtState = \case fmtState = \case

View File

@ -24,6 +24,7 @@ library
, XMonad.Internal.DBus.Control , XMonad.Internal.DBus.Control
, XMonad.Internal.DBus.Screensaver , XMonad.Internal.DBus.Screensaver
, XMonad.Internal.Process , XMonad.Internal.Process
, Xmobar.Plugins.BacklightCommon
, Xmobar.Plugins.Bluetooth , Xmobar.Plugins.Bluetooth
, Xmobar.Plugins.ClevoKeyboard , Xmobar.Plugins.ClevoKeyboard
, Xmobar.Plugins.Device , Xmobar.Plugins.Device