ENH make ethernet plugin asynchronous

This commit is contained in:
Nathan Dwarshuis 2021-11-25 00:12:00 -05:00
parent 0522766f38
commit 5eb7a573ec
9 changed files with 80 additions and 87 deletions

View File

@ -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

View File

@ -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
}

View File

@ -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)
callMethod client bus path iface mem =
callMethod' client (methodCall path iface mem)
{ methodCallDestination = Just bus }
return $ bimap methodErrorMessage methodReturnBody reply
dbusDepSatisfied :: Client -> DBusDep -> IO (Maybe String)
dbusDepSatisfied client (Bus bus) = do

View File

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

View File

@ -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

View File

@ -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
-> ([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) c
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"

View File

@ -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
getDevice client iface = either (const Nothing) (fromVariant <=< listToMaybe)
<$> callMethod' client mc
where
mc = (methodCall nmPath nmInterface getByIP)
{ methodCallBody = [toVariant iface]
, methodCallDestination = Just nmBus
}
return $ case reply of
Left _ -> Nothing
Right b -> case methodReturnBody b of
[objectPath] -> fromVariant objectPath
_ -> Nothing
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)

View File

@ -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

View File

@ -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