ENH make vpn plugin listen to property changed signal

bin/xmobar.hs

@@ -43,7 +43,6 @@ import           XMonad.Internal.Command.Power                  (hasBattery)
 import           XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import           XMonad.Internal.DBus.Brightness.IntelBacklight
 import           XMonad.Internal.DBus.Common
--- import           XMonad.Internal.DBus.Control
 import           XMonad.Internal.DBus.Screensaver               (ssSignalDep)
 import           XMonad.Internal.Dependency
 import           XMonad.Internal.Shell
@@ -155,8 +154,7 @@ batteryCmd =  CmdSpec
 vpnCmd :: CmdSpec
 vpnCmd = CmdSpec
   { csAlias = vpnAlias
-  , csRunnable = Run
-    $ VPN ("<fn=2>\xf023</fn>", T.fgColor, T.backdropFgColor) 5
+  , csRunnable = Run $ VPN ("<fn=2>\xf023</fn>", T.fgColor, T.backdropFgColor)
   }
 
 btCmd :: CmdSpec
@@ -307,12 +305,11 @@ type BarFeature = Feature CmdSpec
 
 getVPN :: Maybe Client -> BarFeature
 getVPN client = Feature
-  { ftrDepTree = DBusTree (Single (const vpnCmd)) client [ep] [dp]
+  { ftrDepTree = DBusTree (Single (const vpnCmd)) client [vpnDep] [dp]
   , ftrName = "VPN status indicator"
   , ftrWarning = Default
   }
   where
-    ep = Endpoint vpnBus vpnPath vpnInterface $ Property_ vpnConnType
     dp = IOTest vpnPresent
 
 getBt :: Maybe Client -> BarFeature

lib/Xmobar/Plugins/Bluetooth.hs

@@ -14,10 +14,10 @@ import           Data.Maybe
 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
 
 newtype Bluetooth = Bluetooth (String, String, String) deriving (Read, Show)
 
@@ -54,10 +54,10 @@ instance Exec Bluetooth where
   start (Bluetooth (text, colorOn, colorOff)) cb = do
     withDBusClientConnection_ True $ \c -> do
       reply <- callGetPowered c
-      cb $ maybe "N/A" chooseColor $ fromVariant =<< listToMaybe reply
+      cb $ maybe "N/A" chooseColor' $ fromVariant =<< listToMaybe reply
       addMatchCallback (matchProperty btPath) (procMatch cb . matchPowered) c
     where
-      procMatch f (Match on) = f $ chooseColor on
+      procMatch f (Match on) = f $ chooseColor' on
       procMatch f Failure    = f "N/A"
       procMatch _ NoMatch    = return ()
-      chooseColor state = xmobarColor (if state then colorOn else colorOff) "" text
+      chooseColor' = chooseColor text colorOn colorOff

lib/Xmobar/Plugins/Common.hs

@@ -0,0 +1,10 @@
+
+module Xmobar.Plugins.Common
+  (chooseColor)
+  where
+
+import           XMonad.Hooks.DynamicLog (xmobarColor)
+
+chooseColor :: String -> String -> String -> Bool -> String
+chooseColor text colorOn colorOff state =
+  xmobarColor (if state then colorOn else colorOff) "" text

lib/Xmobar/Plugins/VPN.hs

@@ -1,6 +1,3 @@
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE OverloadedStrings #-}
-
 --------------------------------------------------------------------------------
 -- | VPN plugin
 --
@@ -9,34 +6,29 @@
 module Xmobar.Plugins.VPN
   ( VPN(..)
   , vpnAlias
-  , vpnBus
-  , vpnPath
-  , vpnInterface
-  , vpnConnType
+  , vpnDep
   ) where
 
+import           Data.Maybe
+
 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 VPN = VPN (String, String, String) Int
-    deriving (Read, Show)
-
-callConnectionType :: Client -> IO (Either MethodError Variant)
-callConnectionType client =
-  getProperty client (methodCall vpnPath vpnInterface $ memberName_ vpnConnType)
-    { methodCallDestination = Just vpnBus }
+newtype VPN = VPN (String, String, String) deriving (Read, Show)
 
 vpnBus :: BusName
-vpnBus = "org.freedesktop.NetworkManager"
+vpnBus = busName_ "org.freedesktop.NetworkManager"
 
 vpnPath :: ObjectPath
-vpnPath = "/org/freedesktop/NetworkManager"
+vpnPath = objectPath_ "/org/freedesktop/NetworkManager"
 
 vpnInterface :: InterfaceName
-vpnInterface = "org.freedesktop.NetworkManager"
+vpnInterface = interfaceName_ "org.freedesktop.NetworkManager"
 
 vpnConnType :: String
 vpnConnType = "PrimaryConnectionType"
@@ -44,18 +36,24 @@ vpnConnType = "PrimaryConnectionType"
 vpnAlias :: String
 vpnAlias = "vpn"
 
+vpnDep :: DBusDep
+vpnDep = Endpoint vpnBus vpnPath vpnInterface $ Property_ vpnConnType
+
+matchConnType :: [Variant] -> SignalMatch String
+matchConnType = matchPropertyChanged vpnInterface vpnConnType fromVariant
+
+callGetConnectionType :: Client -> IO [Variant]
+callGetConnectionType = callPropertyGet vpnBus vpnPath vpnInterface vpnConnType
+
 instance Exec VPN where
-  alias (VPN _ _) = vpnAlias
-  rate  (VPN _ r) = r
-  run   (VPN (text, colorOn, colorOff) _) = do
-    client <- connectSystem
-    reply <- callConnectionType client
-    disconnect client
-    return $ fmtState $ procReply reply
+  alias (VPN _) = vpnAlias
+  start (VPN (text, colorOn, colorOff)) cb = do
+    withDBusClientConnection_ True $ \c -> do
+      reply <- callGetConnectionType c
+      cb $ maybe "N/A" chooseColor' $ fromVariant =<< listToMaybe reply
+      addMatchCallback (matchProperty vpnPath) (procMatch cb . matchConnType) c
     where
-      procReply = \case
-        Right r -> (fromVariant r :: Maybe String)
-        Left _  -> Nothing
-      fmtState = \case
-        Just s -> xmobarColor (if s == "vpn" then colorOn else colorOff) "" text
-        Nothing -> "N/A"
+      procMatch f (Match t) = f $ chooseColor' t
+      procMatch f Failure   = f "N/A"
+      procMatch _ NoMatch   = return ()
+      chooseColor' = chooseColor text colorOn colorOff . ("vpn" ==)

my-xmonad.cabal

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