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