diff --git a/bin/xmobar.hs b/bin/xmobar.hs index 653d2ee..4a8cf32 100644 --- a/bin/xmobar.hs +++ b/bin/xmobar.hs @@ -120,7 +120,7 @@ ethernetCmd :: String -> CmdSpec ethernetCmd iface = CmdSpec { csAlias = iface , csRunnable = Run - $ Device (iface, "\xf0e8", T.fgColor, T.backdropFgColor) 5 + $ Device (iface, "\xf0e8", 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 diff --git a/lib/XMonad/Internal/Concurrent/Removable.hs b/lib/XMonad/Internal/Concurrent/Removable.hs index 9c566ad..4789956 100644 --- a/lib/XMonad/Internal/Concurrent/Removable.hs +++ b/lib/XMonad/Internal/Concurrent/Removable.hs @@ -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 } diff --git a/lib/XMonad/Internal/Dependency.hs b/lib/XMonad/Internal/Dependency.hs index 6bd52c6..5671375 100644 --- a/lib/XMonad/Internal/Dependency.hs +++ b/lib/XMonad/Internal/Dependency.hs @@ -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) - { methodCallDestination = Just bus } - return $ bimap methodErrorMessage methodReturnBody reply +callMethod client bus path iface mem = + callMethod' client (methodCall path iface mem) + { methodCallDestination = Just bus } dbusDepSatisfied :: Client -> DBusDep -> IO (Maybe String) dbusDepSatisfied client (Bus bus) = do diff --git a/lib/Xmobar/Plugins/BacklightCommon.hs b/lib/Xmobar/Plugins/BacklightCommon.hs index 892d7ed..3306d9c 100644 --- a/lib/Xmobar/Plugins/BacklightCommon.hs +++ b/lib/Xmobar/Plugins/BacklightCommon.hs @@ -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) ++ "%" diff --git a/lib/Xmobar/Plugins/Bluetooth.hs b/lib/Xmobar/Plugins/Bluetooth.hs index cf08f5c..cb0b2a9 100644 --- a/lib/Xmobar/Plugins/Bluetooth.hs +++ b/lib/Xmobar/Plugins/Bluetooth.hs @@ -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 + diff --git a/lib/Xmobar/Plugins/Common.hs b/lib/Xmobar/Plugins/Common.hs index b79da01..7272f4d 100644 --- a/lib/Xmobar/Plugins/Common.hs +++ b/lib/Xmobar/Plugins/Common.hs @@ -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 - procMatch $ maybe Failure Match $ fromVariant =<< listToMaybe reply - addMatchCallback rule (procMatch . fromSignal) 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) 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" diff --git a/lib/Xmobar/Plugins/Device.hs b/lib/Xmobar/Plugins/Device.hs index 9ac4d5f..7ba7385 100644 --- a/lib/Xmobar/Plugins/Device.hs +++ b/lib/Xmobar/Plugins/Device.hs @@ -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 - } - return $ case reply of - Left _ -> Nothing - Right b -> case methodReturnBody b of - [objectPath] -> fromVariant objectPath - _ -> Nothing +getDevice client iface = either (const Nothing) (fromVariant <=< listToMaybe) + <$> callMethod' client mc + where + mc = (methodCall nmPath nmInterface getByIP) + { methodCallBody = [toVariant iface] + , methodCallDestination = Just nmBus + } -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) diff --git a/lib/Xmobar/Plugins/Screensaver.hs b/lib/Xmobar/Plugins/Screensaver.hs index 2a679c3..cd921d1 100644 --- a/lib/Xmobar/Plugins/Screensaver.hs +++ b/lib/Xmobar/Plugins/Screensaver.hs @@ -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 diff --git a/lib/Xmobar/Plugins/VPN.hs b/lib/Xmobar/Plugins/VPN.hs index 2b3304b..494709e 100644 --- a/lib/Xmobar/Plugins/VPN.hs +++ b/lib/Xmobar/Plugins/VPN.hs @@ -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