From d2268da188cce82f82423bb713600dc311f0d52c Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Wed, 24 Nov 2021 00:43:58 -0500 Subject: [PATCH] ENH make vpn plugin listen to property changed signal --- bin/xmobar.hs | 7 ++-- lib/Xmobar/Plugins/Bluetooth.hs | 8 ++--- lib/Xmobar/Plugins/Common.hs | 10 ++++++ lib/Xmobar/Plugins/VPN.hs | 60 ++++++++++++++++----------------- my-xmonad.cabal | 1 + 5 files changed, 46 insertions(+), 40 deletions(-) create mode 100644 lib/Xmobar/Plugins/Common.hs diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 2af40c9..653d2ee 100644 --- a/bin/xmobar.hs +++ b/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 ("\xf023", T.fgColor, T.backdropFgColor) 5 + , csRunnable = Run $ VPN ("\xf023", 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 diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index d9c54b5..cf08f5c 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/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 diff --git a/lib/Xmobar/Plugins/Common.hs b/lib/Xmobar/Plugins/Common.hs new file mode 100644 index 0000000..85f1538 --- /dev/null +++ b/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 diff --git a/lib/Xmobar/Plugins/VPN.hs b/lib/Xmobar/Plugins/VPN.hs index f5a5dbe..1907ab4 100644 --- a/lib/Xmobar/Plugins/VPN.hs +++ b/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" ==) diff --git a/my-xmonad.cabal b/my-xmonad.cabal index 0015084..f66fbe8 100644 --- a/my-xmonad.cabal +++ b/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