ENH make vpn plugin listen to property changed signal
This commit is contained in:
parent
0fe36fcccb
commit
d2268da188
|
@ -43,7 +43,6 @@ 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.Common
|
import XMonad.Internal.DBus.Common
|
||||||
-- import XMonad.Internal.DBus.Control
|
|
||||||
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
|
import XMonad.Internal.DBus.Screensaver (ssSignalDep)
|
||||||
import XMonad.Internal.Dependency
|
import XMonad.Internal.Dependency
|
||||||
import XMonad.Internal.Shell
|
import XMonad.Internal.Shell
|
||||||
|
@ -155,8 +154,7 @@ batteryCmd = CmdSpec
|
||||||
vpnCmd :: CmdSpec
|
vpnCmd :: CmdSpec
|
||||||
vpnCmd = CmdSpec
|
vpnCmd = CmdSpec
|
||||||
{ csAlias = vpnAlias
|
{ csAlias = vpnAlias
|
||||||
, csRunnable = Run
|
, csRunnable = Run $ VPN ("<fn=2>\xf023</fn>", T.fgColor, T.backdropFgColor)
|
||||||
$ VPN ("<fn=2>\xf023</fn>", T.fgColor, T.backdropFgColor) 5
|
|
||||||
}
|
}
|
||||||
|
|
||||||
btCmd :: CmdSpec
|
btCmd :: CmdSpec
|
||||||
|
@ -307,12 +305,11 @@ type BarFeature = Feature CmdSpec
|
||||||
|
|
||||||
getVPN :: Maybe Client -> BarFeature
|
getVPN :: Maybe Client -> BarFeature
|
||||||
getVPN client = Feature
|
getVPN client = Feature
|
||||||
{ ftrDepTree = DBusTree (Single (const vpnCmd)) client [ep] [dp]
|
{ ftrDepTree = DBusTree (Single (const vpnCmd)) client [vpnDep] [dp]
|
||||||
, ftrName = "VPN status indicator"
|
, ftrName = "VPN status indicator"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
ep = Endpoint vpnBus vpnPath vpnInterface $ Property_ vpnConnType
|
|
||||||
dp = IOTest vpnPresent
|
dp = IOTest vpnPresent
|
||||||
|
|
||||||
getBt :: Maybe Client -> BarFeature
|
getBt :: Maybe Client -> BarFeature
|
||||||
|
|
|
@ -14,10 +14,10 @@ import Data.Maybe
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
|
||||||
import XMonad.Hooks.DynamicLog (xmobarColor)
|
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
import XMonad.Internal.Dependency
|
import XMonad.Internal.Dependency
|
||||||
import Xmobar
|
import Xmobar
|
||||||
|
import Xmobar.Plugins.Common
|
||||||
|
|
||||||
newtype Bluetooth = Bluetooth (String, String, String) deriving (Read, Show)
|
newtype Bluetooth = Bluetooth (String, String, String) deriving (Read, Show)
|
||||||
|
|
||||||
|
@ -54,10 +54,10 @@ instance Exec Bluetooth where
|
||||||
start (Bluetooth (text, colorOn, colorOff)) cb = do
|
start (Bluetooth (text, colorOn, colorOff)) cb = do
|
||||||
withDBusClientConnection_ True $ \c -> do
|
withDBusClientConnection_ True $ \c -> do
|
||||||
reply <- callGetPowered c
|
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
|
addMatchCallback (matchProperty btPath) (procMatch cb . matchPowered) c
|
||||||
where
|
where
|
||||||
procMatch f (Match on) = f $ chooseColor on
|
procMatch f (Match on) = f $ chooseColor' on
|
||||||
procMatch f Failure = f "N/A"
|
procMatch f Failure = f "N/A"
|
||||||
procMatch _ NoMatch = return ()
|
procMatch _ NoMatch = return ()
|
||||||
chooseColor state = xmobarColor (if state then colorOn else colorOff) "" text
|
chooseColor' = chooseColor text colorOn colorOff
|
||||||
|
|
|
@ -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
|
|
@ -1,6 +1,3 @@
|
||||||
{-# LANGUAGE LambdaCase #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | VPN plugin
|
-- | VPN plugin
|
||||||
--
|
--
|
||||||
|
@ -9,34 +6,29 @@
|
||||||
module Xmobar.Plugins.VPN
|
module Xmobar.Plugins.VPN
|
||||||
( VPN(..)
|
( VPN(..)
|
||||||
, vpnAlias
|
, vpnAlias
|
||||||
, vpnBus
|
, vpnDep
|
||||||
, vpnPath
|
|
||||||
, vpnInterface
|
|
||||||
, vpnConnType
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Data.Maybe
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
|
||||||
import XMonad.Hooks.DynamicLog (xmobarColor)
|
import XMonad.Internal.DBus.Common
|
||||||
|
import XMonad.Internal.Dependency
|
||||||
import Xmobar
|
import Xmobar
|
||||||
|
import Xmobar.Plugins.Common
|
||||||
|
|
||||||
data VPN = VPN (String, String, String) Int
|
newtype VPN = VPN (String, String, String) deriving (Read, Show)
|
||||||
deriving (Read, Show)
|
|
||||||
|
|
||||||
callConnectionType :: Client -> IO (Either MethodError Variant)
|
|
||||||
callConnectionType client =
|
|
||||||
getProperty client (methodCall vpnPath vpnInterface $ memberName_ vpnConnType)
|
|
||||||
{ methodCallDestination = Just vpnBus }
|
|
||||||
|
|
||||||
vpnBus :: BusName
|
vpnBus :: BusName
|
||||||
vpnBus = "org.freedesktop.NetworkManager"
|
vpnBus = busName_ "org.freedesktop.NetworkManager"
|
||||||
|
|
||||||
vpnPath :: ObjectPath
|
vpnPath :: ObjectPath
|
||||||
vpnPath = "/org/freedesktop/NetworkManager"
|
vpnPath = objectPath_ "/org/freedesktop/NetworkManager"
|
||||||
|
|
||||||
vpnInterface :: InterfaceName
|
vpnInterface :: InterfaceName
|
||||||
vpnInterface = "org.freedesktop.NetworkManager"
|
vpnInterface = interfaceName_ "org.freedesktop.NetworkManager"
|
||||||
|
|
||||||
vpnConnType :: String
|
vpnConnType :: String
|
||||||
vpnConnType = "PrimaryConnectionType"
|
vpnConnType = "PrimaryConnectionType"
|
||||||
|
@ -44,18 +36,24 @@ vpnConnType = "PrimaryConnectionType"
|
||||||
vpnAlias :: String
|
vpnAlias :: String
|
||||||
vpnAlias = "vpn"
|
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
|
instance Exec VPN where
|
||||||
alias (VPN _ _) = vpnAlias
|
alias (VPN _) = vpnAlias
|
||||||
rate (VPN _ r) = r
|
start (VPN (text, colorOn, colorOff)) cb = do
|
||||||
run (VPN (text, colorOn, colorOff) _) = do
|
withDBusClientConnection_ True $ \c -> do
|
||||||
client <- connectSystem
|
reply <- callGetConnectionType c
|
||||||
reply <- callConnectionType client
|
cb $ maybe "N/A" chooseColor' $ fromVariant =<< listToMaybe reply
|
||||||
disconnect client
|
addMatchCallback (matchProperty vpnPath) (procMatch cb . matchConnType) c
|
||||||
return $ fmtState $ procReply reply
|
|
||||||
where
|
where
|
||||||
procReply = \case
|
procMatch f (Match t) = f $ chooseColor' t
|
||||||
Right r -> (fromVariant r :: Maybe String)
|
procMatch f Failure = f "N/A"
|
||||||
Left _ -> Nothing
|
procMatch _ NoMatch = return ()
|
||||||
fmtState = \case
|
chooseColor' = chooseColor text colorOn colorOff . ("vpn" ==)
|
||||||
Just s -> xmobarColor (if s == "vpn" then colorOn else colorOff) "" text
|
|
||||||
Nothing -> "N/A"
|
|
||||||
|
|
|
@ -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.Common
|
||||||
, Xmobar.Plugins.BacklightCommon
|
, Xmobar.Plugins.BacklightCommon
|
||||||
, Xmobar.Plugins.Bluetooth
|
, Xmobar.Plugins.Bluetooth
|
||||||
, Xmobar.Plugins.ClevoKeyboard
|
, Xmobar.Plugins.ClevoKeyboard
|
||||||
|
|
Loading…
Reference in New Issue