ENH make ethernet plugin asynchronous

bin/xmobar.hs

@@ -120,7 +120,7 @@ ethernetCmd :: String -> CmdSpec
 ethernetCmd iface = CmdSpec
   { csAlias = iface
   , csRunnable = Run
-    $ Device (iface, "<fn=2>\xf0e8</fn>", T.fgColor, T.backdropFgColor) 5
+    $ Device (iface, "<fn=2>\xf0e8</fn>", T.fgColor, T.backdropFgColor)
   }
 
 batteryCmd :: CmdSpec
@@ -286,13 +286,12 @@ getWireless = Feature
 
 getEthernet :: Maybe Client -> BarFeature
 getEthernet client = Feature
-  { ftrDepTree = DBusTree action client [dep] []
+  { ftrDepTree = DBusTree action client [devDep] []
   , ftrName = "ethernet status indicator"
   , ftrWarning = Default
   }
   where
     action = Double (\i _ -> ethernetCmd i) (readInterface isEthernet)
-    dep = Endpoint devBus devPath devInterface $ Method_ devGetByIP
 
 getBattery :: BarFeature
 getBattery = Feature

lib/XMonad/Internal/Concurrent/Removable.hs

@@ -6,7 +6,6 @@
 
 module XMonad.Internal.Concurrent.Removable (runRemovableMon) where
 
-import           Control.Concurrent
 import           Control.Monad
 
 import           Data.Map.Lazy                   (Map, member)
@@ -14,7 +13,6 @@ import           Data.Map.Lazy                   (Map, member)
 import           DBus
 import           DBus.Client
 
--- import           XMonad.Internal.DBus.Control (pathExists)
 import           XMonad.Internal.Command.Desktop
 import           XMonad.Internal.Dependency
 
@@ -74,19 +72,17 @@ playSoundMaybe p b = when b $ playSound p
 -- If it not already, we won't see any signals from the dbus until it is
 -- started (it will work after it is started however). It seems safe to simply
 -- enable the udisks2 service at boot; however this is not default behavior.
-listenDevices :: IO ()
-listenDevices = do
-  client <- connectSystem
-  _ <- addMatch' client memAdded driveInsertedSound addedHasDrive
-  _ <- addMatch' client memRemoved driveRemovedSound removedHasDrive
-  forever (threadDelay 5000000)
+listenDevices :: Client -> IO ()
+listenDevices client = do
+  void $ addMatch' memAdded driveInsertedSound addedHasDrive
+  void $ addMatch' memRemoved driveRemovedSound removedHasDrive
   where
-    addMatch' client m p f = addMatch client ruleUdisks { matchMember = Just m }
+    addMatch' m p f = addMatch client ruleUdisks { matchMember = Just m }
       $ playSoundMaybe p . f . signalBody
 
 runRemovableMon :: Maybe Client -> FeatureIO
 runRemovableMon client = Feature
-  { ftrDepTree = DBusTree (Single (const listenDevices)) client [addedDep, removedDep] []
+  { ftrDepTree = DBusTree (Single listenDevices) client [addedDep, removedDep] []
   , ftrName = "removeable device monitor"
   , ftrWarning = Default
   }

lib/XMonad/Internal/Dependency.hs

@@ -35,6 +35,7 @@ module XMonad.Internal.Dependency
   , executeFeatureWith
   , executeFeatureWith_
   , callMethod
+  , callMethod'
   ) where
 
 import           Control.Monad.IO.Class
@@ -320,12 +321,14 @@ introspectMethod :: MemberName
 introspectMethod = memberName_ "Introspect"
 
 -- TODO this belongs somewhere else, IDK where tho for now
+callMethod' :: Client -> MethodCall -> IO (Either String [Variant])
+callMethod' cl = fmap (bimap methodErrorMessage methodReturnBody) . call cl
+
 callMethod :: Client -> BusName -> ObjectPath -> InterfaceName -> MemberName
   -> IO (Either String [Variant])
-callMethod client bus path iface mem = do
-  reply <- call client (methodCall path iface mem)
-           { methodCallDestination = Just bus }
-  return $ bimap methodErrorMessage methodReturnBody reply
+callMethod client bus path iface mem =
+  callMethod' client (methodCall path iface mem)
+  { methodCallDestination = Just bus }
 
 dbusDepSatisfied :: Client -> DBusDep -> IO (Maybe String)
 dbusDepSatisfied client (Bus bus) = do

lib/Xmobar/Plugins/BacklightCommon.hs

@@ -6,20 +6,17 @@
 
 module Xmobar.Plugins.BacklightCommon (startBacklight) where
 
-import           Control.Concurrent
-import           Control.Monad
-
 import           DBus.Client
 
-import           XMonad.Internal.DBus.Control
+import           XMonad.Internal.DBus.Common
+import           Xmobar.Plugins.Common
 
 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
+    withDBusClientConnection_ False $ \c -> do
       matchSignal (cb . formatBrightness) c
       cb . formatBrightness =<< callGetBrightness c
-    forever (threadDelay 5000000)
     where
-      formatBrightness = maybe "N/A" $
+      formatBrightness = maybe na $
         \b -> icon ++ show (round b :: Integer) ++ "%"

lib/Xmobar/Plugins/Bluetooth.hs

@@ -9,8 +9,6 @@ module Xmobar.Plugins.Bluetooth
   , btDep
   ) where
 
-import           Data.Maybe
-
 import           DBus
 import           DBus.Client
 
@@ -53,11 +51,8 @@ instance Exec Bluetooth where
   alias (Bluetooth _) = btAlias
   start (Bluetooth (text, colorOn, colorOff)) cb = do
     withDBusClientConnection_ True $ \c -> do
-      reply <- callGetPowered c
-      cb $ maybe "N/A" chooseColor' $ fromVariant =<< listToMaybe reply
-      addMatchCallback (matchProperty btPath) (procMatch cb . matchPowered) c
+      startListener rule callGetPowered matchPowered chooseColor' cb c
     where
-      procMatch f (Match on) = f $ chooseColor' on
-      procMatch f Failure    = f "N/A"
-      procMatch _ NoMatch    = return ()
+      rule = matchProperty btPath
       chooseColor' = chooseColor text colorOn colorOff
+

lib/Xmobar/Plugins/Common.hs

@@ -2,6 +2,7 @@
 module Xmobar.Plugins.Common
   ( chooseColor
   , startListener
+  , na
   )
   where
 
@@ -14,17 +15,20 @@ import           XMonad.Hooks.DynamicLog     (xmobarColor)
 import           XMonad.Internal.DBus.Common
 
 startListener :: IsVariant a => MatchRule -> (Client -> IO [Variant])
-  -> ([Variant] -> SignalMatch a) -> (a -> String) -> (String -> IO ()) -> IO ()
-startListener rule getProp fromSignal toColor cb = do
-  withDBusClientConnection_ True $ \c -> do
-    reply <- getProp c
-    procMatch $ maybe Failure Match $ fromVariant =<< listToMaybe reply
-    addMatchCallback rule (procMatch . fromSignal) c
+  -> ([Variant] -> SignalMatch a) -> (a -> String) -> (String -> IO ())
+  -> Client -> IO ()
+startListener rule getProp fromSignal toColor cb client = do
+  reply <- getProp client
+  procMatch $ maybe Failure Match $ fromVariant =<< listToMaybe reply
+  addMatchCallback rule (procMatch . fromSignal) client
   where
     procMatch (Match t) = cb $ toColor t
-    procMatch Failure   = cb "N/A"
+    procMatch Failure   = cb na
     procMatch NoMatch   = return ()
 
 chooseColor :: String -> String -> String -> Bool -> String
 chooseColor text colorOn colorOff state =
   xmobarColor (if state then colorOn else colorOff) "" text
+
+na :: String
+na = "N/A"

lib/Xmobar/Plugins/Device.hs

@@ -1,74 +1,72 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Xmobar.Plugins.Device
   ( Device(..)
-  , devBus
-  , devPath
-  , devInterface
-  , devGetByIP
+  , devDep
   ) where
 
--- TOOD this name can be more general
 --------------------------------------------------------------------------------
--- | Ethernet plugin
+-- | Devince plugin
 --
 -- Display different text depending on whether or not the interface has
 -- connectivity
 
-
 import           Control.Monad
 
+import           Data.Maybe
 import           Data.Word
 
 import           DBus
 import           DBus.Client
 
-import           XMonad.Hooks.DynamicLog (xmobarColor)
+import           XMonad.Internal.DBus.Common
+import           XMonad.Internal.Dependency
 import           Xmobar
+import           Xmobar.Plugins.Common
 
-data Device = Device (String, String, String, String) Int
-    deriving (Read, Show)
+newtype Device = Device (String, String, String, String) deriving (Read, Show)
 
-devBus :: BusName
-devBus = "org.freedesktop.NetworkManager"
+nmBus :: BusName
+nmBus = busName_ "org.freedesktop.NetworkManager"
 
-devPath :: ObjectPath
-devPath = "/org/freedesktop/NetworkManager"
+nmPath :: ObjectPath
+nmPath = objectPath_ "/org/freedesktop/NetworkManager"
 
-devInterface :: InterfaceName
-devInterface = "org.freedesktop.NetworkManager"
+nmInterface :: InterfaceName
+nmInterface = interfaceName_ "org.freedesktop.NetworkManager"
 
-devGetByIP :: MemberName
-devGetByIP = "GetDeviceByIpIface"
+nmDeviceInterface :: InterfaceName
+nmDeviceInterface = interfaceName_ "org.freedesktop.NetworkManager.Device"
+
+getByIP :: MemberName
+getByIP = memberName_ "GetDeviceByIpIface"
+
+devSignal :: String
+devSignal = "Ip4Connectivity"
+
+devDep :: DBusDep
+devDep = Endpoint nmBus nmPath nmInterface $ Method_ getByIP
 
 getDevice :: Client -> String -> IO (Maybe ObjectPath)
-getDevice client iface = do
-  let mc = methodCall devPath devInterface devGetByIP
-  reply <- call client $ mc { methodCallBody = [toVariant iface]
-                            , methodCallDestination = Just devBus
-                            }
-  return $ case reply of
-    Left _  -> Nothing
-    Right b -> case methodReturnBody b of
-      [objectPath] -> fromVariant objectPath
-      _            -> Nothing
+getDevice client iface = either (const Nothing) (fromVariant <=< listToMaybe)
+  <$> callMethod' client mc
+  where
+    mc = (methodCall nmPath nmInterface getByIP)
+      { methodCallBody = [toVariant iface]
+      , methodCallDestination = Just nmBus
+      }
 
-getDeviceConnected :: Client -> ObjectPath -> IO (Maybe Bool)
-getDeviceConnected client objectPath = do
-  let mc = methodCall objectPath
-           "org.freedesktop.NetworkManager.Device"
-           "Ip4Connectivity"
-  either (const Nothing) (fmap ((> 1) :: Word32 -> Bool) . fromVariant)
-    <$> getProperty client mc { methodCallDestination = Just devBus }
+getDeviceConnected :: ObjectPath -> Client -> IO [Variant]
+getDeviceConnected path = callPropertyGet nmBus path nmDeviceInterface devSignal
+
+matchStatus :: [Variant] -> SignalMatch Word32
+matchStatus = matchPropertyChanged nmDeviceInterface devSignal fromVariant
 
 instance Exec Device where
-  alias (Device (iface, _, _, _) _) = iface
-  rate  (Device _ r) = r
-  run   (Device (iface, text, colorOn, colorOff) _) = do
-    client <- connectSystem
-    dev <- getDevice client iface
-    state <- join <$> mapM (getDeviceConnected client) dev
-    disconnect client
-    return $ maybe "N/A" fmt state
+  alias (Device (iface, _, _, _)) = iface
+  start (Device (iface, text, colorOn, colorOff)) cb = do
+    withDBusClientConnection_ True $ \c -> do
+      path <- getDevice c iface
+      maybe (cb na) (listener c) path
     where
-      fmt s = xmobarColor (if s then colorOn else colorOff) "" text
+      listener client path = startListener (matchProperty path)
+        (getDeviceConnected path) matchStatus chooseColor' cb client
+      chooseColor' = chooseColor text colorOn colorOff . (> 1)

lib/Xmobar/Plugins/Screensaver.hs

@@ -27,5 +27,5 @@ instance Exec Screensaver where
       matchSignal (cb . fmtState) c
       cb . fmtState =<< callQuery c
     where
-      fmtState = maybe "N/A" $ chooseColor text colorOn colorOff
+      fmtState = maybe na $ chooseColor text colorOn colorOff
 

lib/Xmobar/Plugins/VPN.hs

@@ -39,7 +39,8 @@ vpnDep = Endpoint vpnBus vpnPath vpnInterface $ Property_ vpnConnType
 instance Exec VPN where
   alias (VPN _) = vpnAlias
   start (VPN (text, colorOn, colorOff)) cb =
-    startListener rule getProp fromSignal chooseColor' cb
+    withDBusClientConnection_ True
+    $ startListener rule getProp fromSignal chooseColor' cb
     where
       rule = matchProperty vpnPath
       getProp = callPropertyGet vpnBus vpnPath vpnInterface vpnConnType