ENH make ethernet plugin asynchronous
This commit is contained in:
parent
0522766f38
commit
5eb7a573ec
|
@ -120,7 +120,7 @@ ethernetCmd :: String -> CmdSpec
|
||||||
ethernetCmd iface = CmdSpec
|
ethernetCmd iface = CmdSpec
|
||||||
{ csAlias = iface
|
{ csAlias = iface
|
||||||
, csRunnable = Run
|
, 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
|
batteryCmd :: CmdSpec
|
||||||
|
@ -286,13 +286,12 @@ getWireless = Feature
|
||||||
|
|
||||||
getEthernet :: Maybe Client -> BarFeature
|
getEthernet :: Maybe Client -> BarFeature
|
||||||
getEthernet client = Feature
|
getEthernet client = Feature
|
||||||
{ ftrDepTree = DBusTree action client [dep] []
|
{ ftrDepTree = DBusTree action client [devDep] []
|
||||||
, ftrName = "ethernet status indicator"
|
, ftrName = "ethernet status indicator"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
action = Double (\i _ -> ethernetCmd i) (readInterface isEthernet)
|
action = Double (\i _ -> ethernetCmd i) (readInterface isEthernet)
|
||||||
dep = Endpoint devBus devPath devInterface $ Method_ devGetByIP
|
|
||||||
|
|
||||||
getBattery :: BarFeature
|
getBattery :: BarFeature
|
||||||
getBattery = Feature
|
getBattery = Feature
|
||||||
|
|
|
@ -6,7 +6,6 @@
|
||||||
|
|
||||||
module XMonad.Internal.Concurrent.Removable (runRemovableMon) where
|
module XMonad.Internal.Concurrent.Removable (runRemovableMon) where
|
||||||
|
|
||||||
import Control.Concurrent
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
|
||||||
import Data.Map.Lazy (Map, member)
|
import Data.Map.Lazy (Map, member)
|
||||||
|
@ -14,7 +13,6 @@ import Data.Map.Lazy (Map, member)
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
|
||||||
-- import XMonad.Internal.DBus.Control (pathExists)
|
|
||||||
import XMonad.Internal.Command.Desktop
|
import XMonad.Internal.Command.Desktop
|
||||||
import XMonad.Internal.Dependency
|
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
|
-- 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
|
-- 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.
|
-- enable the udisks2 service at boot; however this is not default behavior.
|
||||||
listenDevices :: IO ()
|
listenDevices :: Client -> IO ()
|
||||||
listenDevices = do
|
listenDevices client = do
|
||||||
client <- connectSystem
|
void $ addMatch' memAdded driveInsertedSound addedHasDrive
|
||||||
_ <- addMatch' client memAdded driveInsertedSound addedHasDrive
|
void $ addMatch' memRemoved driveRemovedSound removedHasDrive
|
||||||
_ <- addMatch' client memRemoved driveRemovedSound removedHasDrive
|
|
||||||
forever (threadDelay 5000000)
|
|
||||||
where
|
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
|
$ playSoundMaybe p . f . signalBody
|
||||||
|
|
||||||
runRemovableMon :: Maybe Client -> FeatureIO
|
runRemovableMon :: Maybe Client -> FeatureIO
|
||||||
runRemovableMon client = Feature
|
runRemovableMon client = Feature
|
||||||
{ ftrDepTree = DBusTree (Single (const listenDevices)) client [addedDep, removedDep] []
|
{ ftrDepTree = DBusTree (Single listenDevices) client [addedDep, removedDep] []
|
||||||
, ftrName = "removeable device monitor"
|
, ftrName = "removeable device monitor"
|
||||||
, ftrWarning = Default
|
, ftrWarning = Default
|
||||||
}
|
}
|
||||||
|
|
|
@ -35,6 +35,7 @@ module XMonad.Internal.Dependency
|
||||||
, executeFeatureWith
|
, executeFeatureWith
|
||||||
, executeFeatureWith_
|
, executeFeatureWith_
|
||||||
, callMethod
|
, callMethod
|
||||||
|
, callMethod'
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Monad.IO.Class
|
import Control.Monad.IO.Class
|
||||||
|
@ -320,12 +321,14 @@ introspectMethod :: MemberName
|
||||||
introspectMethod = memberName_ "Introspect"
|
introspectMethod = memberName_ "Introspect"
|
||||||
|
|
||||||
-- TODO this belongs somewhere else, IDK where tho for now
|
-- 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
|
callMethod :: Client -> BusName -> ObjectPath -> InterfaceName -> MemberName
|
||||||
-> IO (Either String [Variant])
|
-> IO (Either String [Variant])
|
||||||
callMethod client bus path iface mem = do
|
callMethod client bus path iface mem =
|
||||||
reply <- call client (methodCall path iface mem)
|
callMethod' client (methodCall path iface mem)
|
||||||
{ methodCallDestination = Just bus }
|
{ methodCallDestination = Just bus }
|
||||||
return $ bimap methodErrorMessage methodReturnBody reply
|
|
||||||
|
|
||||||
dbusDepSatisfied :: Client -> DBusDep -> IO (Maybe String)
|
dbusDepSatisfied :: Client -> DBusDep -> IO (Maybe String)
|
||||||
dbusDepSatisfied client (Bus bus) = do
|
dbusDepSatisfied client (Bus bus) = do
|
||||||
|
|
|
@ -6,20 +6,17 @@
|
||||||
|
|
||||||
module Xmobar.Plugins.BacklightCommon (startBacklight) where
|
module Xmobar.Plugins.BacklightCommon (startBacklight) where
|
||||||
|
|
||||||
import Control.Concurrent
|
|
||||||
import Control.Monad
|
|
||||||
|
|
||||||
import DBus.Client
|
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 ())
|
startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> Client -> IO ())
|
||||||
-> (Client -> IO (Maybe a)) -> String -> (String -> IO ()) -> IO ()
|
-> (Client -> IO (Maybe a)) -> String -> (String -> IO ()) -> IO ()
|
||||||
startBacklight matchSignal callGetBrightness icon cb = do
|
startBacklight matchSignal callGetBrightness icon cb = do
|
||||||
withDBusClient_ False $ \c -> do
|
withDBusClientConnection_ False $ \c -> do
|
||||||
matchSignal (cb . formatBrightness) c
|
matchSignal (cb . formatBrightness) c
|
||||||
cb . formatBrightness =<< callGetBrightness c
|
cb . formatBrightness =<< callGetBrightness c
|
||||||
forever (threadDelay 5000000)
|
|
||||||
where
|
where
|
||||||
formatBrightness = maybe "N/A" $
|
formatBrightness = maybe na $
|
||||||
\b -> icon ++ show (round b :: Integer) ++ "%"
|
\b -> icon ++ show (round b :: Integer) ++ "%"
|
||||||
|
|
|
@ -9,8 +9,6 @@ module Xmobar.Plugins.Bluetooth
|
||||||
, btDep
|
, btDep
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Maybe
|
|
||||||
|
|
||||||
import DBus
|
import DBus
|
||||||
import DBus.Client
|
import DBus.Client
|
||||||
|
|
||||||
|
@ -53,11 +51,8 @@ instance Exec Bluetooth where
|
||||||
alias (Bluetooth _) = btAlias
|
alias (Bluetooth _) = btAlias
|
||||||
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
|
startListener rule callGetPowered matchPowered chooseColor' cb c
|
||||||
cb $ maybe "N/A" chooseColor' $ fromVariant =<< listToMaybe reply
|
|
||||||
addMatchCallback (matchProperty btPath) (procMatch cb . matchPowered) c
|
|
||||||
where
|
where
|
||||||
procMatch f (Match on) = f $ chooseColor' on
|
rule = matchProperty btPath
|
||||||
procMatch f Failure = f "N/A"
|
|
||||||
procMatch _ NoMatch = return ()
|
|
||||||
chooseColor' = chooseColor text colorOn colorOff
|
chooseColor' = chooseColor text colorOn colorOff
|
||||||
|
|
||||||
|
|
|
@ -2,6 +2,7 @@
|
||||||
module Xmobar.Plugins.Common
|
module Xmobar.Plugins.Common
|
||||||
( chooseColor
|
( chooseColor
|
||||||
, startListener
|
, startListener
|
||||||
|
, na
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -14,17 +15,20 @@ import XMonad.Hooks.DynamicLog (xmobarColor)
|
||||||
import XMonad.Internal.DBus.Common
|
import XMonad.Internal.DBus.Common
|
||||||
|
|
||||||
startListener :: IsVariant a => MatchRule -> (Client -> IO [Variant])
|
startListener :: IsVariant a => MatchRule -> (Client -> IO [Variant])
|
||||||
-> ([Variant] -> SignalMatch a) -> (a -> String) -> (String -> IO ()) -> IO ()
|
-> ([Variant] -> SignalMatch a) -> (a -> String) -> (String -> IO ())
|
||||||
startListener rule getProp fromSignal toColor cb = do
|
-> Client -> IO ()
|
||||||
withDBusClientConnection_ True $ \c -> do
|
startListener rule getProp fromSignal toColor cb client = do
|
||||||
reply <- getProp c
|
reply <- getProp client
|
||||||
procMatch $ maybe Failure Match $ fromVariant =<< listToMaybe reply
|
procMatch $ maybe Failure Match $ fromVariant =<< listToMaybe reply
|
||||||
addMatchCallback rule (procMatch . fromSignal) c
|
addMatchCallback rule (procMatch . fromSignal) client
|
||||||
where
|
where
|
||||||
procMatch (Match t) = cb $ toColor t
|
procMatch (Match t) = cb $ toColor t
|
||||||
procMatch Failure = cb "N/A"
|
procMatch Failure = cb na
|
||||||
procMatch NoMatch = return ()
|
procMatch NoMatch = return ()
|
||||||
|
|
||||||
chooseColor :: String -> String -> String -> Bool -> String
|
chooseColor :: String -> String -> String -> Bool -> String
|
||||||
chooseColor text colorOn colorOff state =
|
chooseColor text colorOn colorOff state =
|
||||||
xmobarColor (if state then colorOn else colorOff) "" text
|
xmobarColor (if state then colorOn else colorOff) "" text
|
||||||
|
|
||||||
|
na :: String
|
||||||
|
na = "N/A"
|
||||||
|
|
|
@ -1,74 +1,72 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
|
|
||||||
module Xmobar.Plugins.Device
|
module Xmobar.Plugins.Device
|
||||||
( Device(..)
|
( Device(..)
|
||||||
, devBus
|
, devDep
|
||||||
, devPath
|
|
||||||
, devInterface
|
|
||||||
, devGetByIP
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
-- TOOD this name can be more general
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- | Ethernet plugin
|
-- | Devince plugin
|
||||||
--
|
--
|
||||||
-- Display different text depending on whether or not the interface has
|
-- Display different text depending on whether or not the interface has
|
||||||
-- connectivity
|
-- connectivity
|
||||||
|
|
||||||
|
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
|
|
||||||
|
import Data.Maybe
|
||||||
import Data.Word
|
import Data.Word
|
||||||
|
|
||||||
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 Device = Device (String, String, String, String) Int
|
newtype Device = Device (String, String, String, String) deriving (Read, Show)
|
||||||
deriving (Read, Show)
|
|
||||||
|
|
||||||
devBus :: BusName
|
nmBus :: BusName
|
||||||
devBus = "org.freedesktop.NetworkManager"
|
nmBus = busName_ "org.freedesktop.NetworkManager"
|
||||||
|
|
||||||
devPath :: ObjectPath
|
nmPath :: ObjectPath
|
||||||
devPath = "/org/freedesktop/NetworkManager"
|
nmPath = objectPath_ "/org/freedesktop/NetworkManager"
|
||||||
|
|
||||||
devInterface :: InterfaceName
|
nmInterface :: InterfaceName
|
||||||
devInterface = "org.freedesktop.NetworkManager"
|
nmInterface = interfaceName_ "org.freedesktop.NetworkManager"
|
||||||
|
|
||||||
devGetByIP :: MemberName
|
nmDeviceInterface :: InterfaceName
|
||||||
devGetByIP = "GetDeviceByIpIface"
|
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 -> String -> IO (Maybe ObjectPath)
|
||||||
getDevice client iface = do
|
getDevice client iface = either (const Nothing) (fromVariant <=< listToMaybe)
|
||||||
let mc = methodCall devPath devInterface devGetByIP
|
<$> callMethod' client mc
|
||||||
reply <- call client $ mc { methodCallBody = [toVariant iface]
|
where
|
||||||
, methodCallDestination = Just devBus
|
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 :: ObjectPath -> Client -> IO [Variant]
|
||||||
getDeviceConnected client objectPath = do
|
getDeviceConnected path = callPropertyGet nmBus path nmDeviceInterface devSignal
|
||||||
let mc = methodCall objectPath
|
|
||||||
"org.freedesktop.NetworkManager.Device"
|
matchStatus :: [Variant] -> SignalMatch Word32
|
||||||
"Ip4Connectivity"
|
matchStatus = matchPropertyChanged nmDeviceInterface devSignal fromVariant
|
||||||
either (const Nothing) (fmap ((> 1) :: Word32 -> Bool) . fromVariant)
|
|
||||||
<$> getProperty client mc { methodCallDestination = Just devBus }
|
|
||||||
|
|
||||||
instance Exec Device where
|
instance Exec Device where
|
||||||
alias (Device (iface, _, _, _) _) = iface
|
alias (Device (iface, _, _, _)) = iface
|
||||||
rate (Device _ r) = r
|
start (Device (iface, text, colorOn, colorOff)) cb = do
|
||||||
run (Device (iface, text, colorOn, colorOff) _) = do
|
withDBusClientConnection_ True $ \c -> do
|
||||||
client <- connectSystem
|
path <- getDevice c iface
|
||||||
dev <- getDevice client iface
|
maybe (cb na) (listener c) path
|
||||||
state <- join <$> mapM (getDeviceConnected client) dev
|
|
||||||
disconnect client
|
|
||||||
return $ maybe "N/A" fmt state
|
|
||||||
where
|
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)
|
||||||
|
|
|
@ -27,5 +27,5 @@ instance Exec Screensaver where
|
||||||
matchSignal (cb . fmtState) c
|
matchSignal (cb . fmtState) c
|
||||||
cb . fmtState =<< callQuery c
|
cb . fmtState =<< callQuery c
|
||||||
where
|
where
|
||||||
fmtState = maybe "N/A" $ chooseColor text colorOn colorOff
|
fmtState = maybe na $ chooseColor text colorOn colorOff
|
||||||
|
|
||||||
|
|
|
@ -39,7 +39,8 @@ vpnDep = Endpoint vpnBus vpnPath vpnInterface $ Property_ vpnConnType
|
||||||
instance Exec VPN where
|
instance Exec VPN where
|
||||||
alias (VPN _) = vpnAlias
|
alias (VPN _) = vpnAlias
|
||||||
start (VPN (text, colorOn, colorOff)) cb =
|
start (VPN (text, colorOn, colorOff)) cb =
|
||||||
startListener rule getProp fromSignal chooseColor' cb
|
withDBusClientConnection_ True
|
||||||
|
$ startListener rule getProp fromSignal chooseColor' cb
|
||||||
where
|
where
|
||||||
rule = matchProperty vpnPath
|
rule = matchProperty vpnPath
|
||||||
getProp = callPropertyGet vpnBus vpnPath vpnInterface vpnConnType
|
getProp = callPropertyGet vpnBus vpnPath vpnInterface vpnConnType
|
||||||
|
|
Loading…
Reference in New Issue