ENH make client calls safe in plugins

bin/xmobar.hs

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

lib/XMonad/Internal/DBus/Brightness/ClevoKeyboard.hs

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

lib/XMonad/Internal/DBus/Brightness/Common.hs

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

lib/XMonad/Internal/DBus/Brightness/IntelBacklight.hs

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

lib/XMonad/Internal/DBus/Common.hs

@@ -3,9 +3,15 @@
 
 module XMonad.Internal.DBus.Common
   ( addMatchCallback
+  , getDBusClient
+  , withDBusClient
+  , withDBusClient_
   , xmonadBusName
   ) where
 
+import           Control.Exception
+import           Control.Monad
+
 import           DBus
 import           DBus.Client
 
@@ -13,7 +19,25 @@ xmonadBusName :: BusName
 xmonadBusName = busName_ "org.xmonad"
 
 -- | Bind a callback to a signal match rule
-addMatchCallback :: MatchRule -> ([Variant] -> IO ()) -> IO SignalHandler
-addMatchCallback rule cb = do
-  client <- connectSession
-  addMatch client rule $ cb . signalBody
+addMatchCallback :: MatchRule -> ([Variant] -> IO ()) -> Client -> IO ()
+addMatchCallback rule cb client = void $ 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

lib/XMonad/Internal/DBus/Control.hs

@@ -7,12 +7,13 @@ module XMonad.Internal.DBus.Control
   ( Client
   , startXMonadService
   , getDBusClient
+  , withDBusClient
+  , withDBusClient_
   , stopXMonadService
   , pathExists
   , disconnect
   ) where
 
-import           Control.Exception
 import           Control.Monad                                  (forM_, void)
 
 import           Data.Either
@@ -46,12 +47,6 @@ stopXMonadService client = do
   void $ releaseName client xmonadBusName
   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 = do

lib/XMonad/Internal/DBus/Screensaver.hs

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

lib/Xmobar/Plugins/BacklightCommon.hs

@@ -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) ++ "%"

lib/Xmobar/Plugins/Bluetooth.hs

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

lib/Xmobar/Plugins/ClevoKeyboard.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE LambdaCase #-}
-
 --------------------------------------------------------------------------------
 -- | Clevo Keyboard plugin
 --
@@ -11,13 +9,10 @@ module Xmobar.Plugins.ClevoKeyboard
   , ckAlias
   ) where
 
-import           Control.Concurrent
-import           Control.Monad
-
-import           DBus.Client
-
 import           Xmobar
 
+import           Xmobar.Plugins.BacklightCommon
+
 import           XMonad.Internal.DBus.Brightness.ClevoKeyboard
 
 newtype ClevoKeyboard = ClevoKeyboard String deriving (Read, Show)
@@ -28,12 +23,4 @@ ckAlias = "clevokeyboard"
 instance Exec ClevoKeyboard where
   alias (ClevoKeyboard _) = ckAlias
   start (ClevoKeyboard icon) cb = do
-    _ <- matchSignalCK $ cb . formatBrightness
-    -- 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"
+     startBacklight matchSignalCK callGetBrightnessCK icon cb

lib/Xmobar/Plugins/IntelBacklight.hs

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

lib/Xmobar/Plugins/Screensaver.hs

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

my-xmonad.cabal

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