diff --git a/src/System/Taffybar/Context.hs b/src/System/Taffybar/Context.hs index e650e00b..d8c0774a 100644 --- a/src/System/Taffybar/Context.hs +++ b/src/System/Taffybar/Context.hs @@ -43,6 +43,7 @@ import System.Taffybar.Compat.GtkLibs import System.Taffybar.Information.SafeX11 import System.Taffybar.Information.X11DesktopInfo import System.Taffybar.TransparentWindow +import System.Taffybar.Util import System.Taffybar.Widget.Util import Text.Printf import Unsafe.Coerce @@ -87,6 +88,10 @@ data TaffybarConfig = TaffybarConfig , errorMsg :: Maybe String } +appendHook :: TaffyIO () -> TaffybarConfig -> TaffybarConfig +appendHook hook config = config + { startupHook = startupHook config >> hook } + defaultTaffybarConfig :: TaffybarConfig defaultTaffybarConfig = TaffybarConfig { dbusClientParam = Nothing @@ -302,11 +307,6 @@ putState getValue = do (return . (contextStateMap,)) (currentValue >>= fromValue) -liftReader :: - Monad m => (m1 a -> m b) -> ReaderT r m1 a -> ReaderT r m b -liftReader modifier action = - ask >>= lift . modifier . runReaderT action - taffyFork :: ReaderT r IO () -> ReaderT r IO () taffyFork = void . liftReader forkIO diff --git a/src/System/Taffybar/DBus.hs b/src/System/Taffybar/DBus.hs index b05e0761..0eb96174 100644 --- a/src/System/Taffybar/DBus.hs +++ b/src/System/Taffybar/DBus.hs @@ -12,10 +12,6 @@ import System.Log.DBus.Server import System.Taffybar.Context import System.Taffybar.DBus.Toggle -appendHook :: TaffyIO () -> TaffybarConfig -> TaffybarConfig -appendHook hook config = config - { startupHook = startupHook config >> hook } - startTaffyLogServer :: TaffyIO () startTaffyLogServer = asks sessionDBusClient >>= lift . startLogServer diff --git a/src/System/Taffybar/DBus/Client/Params.hs b/src/System/Taffybar/DBus/Client/Params.hs index 54df22c1..ca3ccb29 100644 --- a/src/System/Taffybar/DBus/Client/Params.hs +++ b/src/System/Taffybar/DBus/Client/Params.hs @@ -22,6 +22,9 @@ uPowerBaseObjectPath = "/org/freedesktop/UPower" uPowerBusName :: BusName uPowerBusName = "org.freedesktop.UPower" +uPowerDeviceInterfaceName :: InterfaceName +uPowerDeviceInterfaceName = "org.freedesktop.UPower.Device" + uPowerGenerationParams :: GenerationParams uPowerGenerationParams = defaultGenerationParams { genTakeSignalErrorHandler = True diff --git a/src/System/Taffybar/DBus/Toggle.hs b/src/System/Taffybar/DBus/Toggle.hs index c04aedaf..80639ab3 100644 --- a/src/System/Taffybar/DBus/Toggle.hs +++ b/src/System/Taffybar/DBus/Toggle.hs @@ -13,9 +13,7 @@ -- of taffybar on each monitor while it is running. ----------------------------------------------------------------------------- -module System.Taffybar.DBus.Toggle - ( handleDBusToggles - ) where +module System.Taffybar.DBus.Toggle ( handleDBusToggles ) where import Control.Applicative import qualified Control.Concurrent.MVar as MV @@ -80,7 +78,8 @@ getMonitorNumber monitor = do (Just g1, Just g2) -> Gdk.rectangleEqual g1 g2 _ -> return False equalsMonitor _ = return False - snd . fromMaybe (Nothing, 0) . listToMaybe <$> filterM equalsMonitor (zip monitors [0..]) + snd . fromMaybe (Nothing, 0) . listToMaybe <$> + filterM equalsMonitor (zip monitors [0..]) taffybarTogglePath :: ObjectPath taffybarTogglePath = "/taffybar/toggle" @@ -102,7 +101,8 @@ toggleBarConfigGetter getConfigs = do TogglesMVar enabledVar <- getTogglesVar numToEnabled <- lift $ MV.readMVar enabledVar let isEnabled monNumber = fromMaybe True $ M.lookup monNumber numToEnabled - isConfigEnabled = isEnabled . fromIntegral . fromMaybe 0 . strutMonitor . strutConfig + isConfigEnabled = + isEnabled . fromIntegral . fromMaybe 0 . strutMonitor . strutConfig return $ filter isConfigEnabled barConfigs exportTogglesInterface :: TaffyIO () diff --git a/src/System/Taffybar/Hooks.hs b/src/System/Taffybar/Hooks.hs index a5f8ef3c..a7f85999 100644 --- a/src/System/Taffybar/Hooks.hs +++ b/src/System/Taffybar/Hooks.hs @@ -1,6 +1,7 @@ module System.Taffybar.Hooks ( module System.Taffybar.DBus , module System.Taffybar.Hooks + , refreshBatteriesOnPropChange ) where import Control.Concurrent @@ -8,6 +9,7 @@ import Control.Monad.Trans import System.Taffybar.Context import System.Taffybar.DBus import System.Taffybar.Information.Network +import System.Taffybar.Information.Battery newtype NetworkInfoChan = NetworkInfoChan (Chan [(String, (Rational, Rational))]) @@ -19,3 +21,6 @@ buildInfoChan interval = do getNetworkChan :: TaffyIO NetworkInfoChan getNetworkChan = getStateDefault $ lift $ buildInfoChan 2.0 + +withBatteryRefresh :: TaffybarConfig -> TaffybarConfig +withBatteryRefresh = appendHook refreshBatteriesOnPropChange diff --git a/src/System/Taffybar/Information/Battery.hs b/src/System/Taffybar/Information/Battery.hs index c523ebdc..fd365087 100644 --- a/src/System/Taffybar/Information/Battery.hs +++ b/src/System/Taffybar/Information/Battery.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -- | This is a simple library to query the Linux UPower daemon (via DBus) for -- battery information. -module System.Taffybar.Information.Battery ( +module System.Taffybar.Information.Battery + ( -- * Types BatteryInfo(..) , BatteryState(..) @@ -89,8 +90,8 @@ dummyMethodError = methodError (Serial 1) $ errorName_ "org.ClientTypeMismatch" getBatteryInfo :: ObjectPath -> TaffyIO (Either MethodError BatteryInfo) getBatteryInfo battPath = asks systemDBusClient >>= \client -> lift $ runExceptT $ do reply <- ExceptT $ getAllProperties client $ - (methodCall battPath "org.freedesktop.UPower.Device" "Fakte") - { methodCallDestination = Just "org.freedesktop.UPower" } + (methodCall battPath uPowerDeviceInterfaceName "FakeMethod") + { methodCallDestination = Just uPowerBusName } dict <- ExceptT $ return $ maybeToEither dummyMethodError $ listToMaybe (methodReturnBody reply) >>= fromVariant return $ infoMapToBatteryInfo dict @@ -167,6 +168,13 @@ updateBatteryInfo chan var path = swapMVar var info >> writeChan chan info warnOfFailure = batteryLogF WARNING "Failed to update battery info %s" +registerForAnyUPowerPropertiesChanged signalHandler = do + client <- asks systemDBusClient + lift $ DBus.registerForPropertiesChanged + client + matchAny { matchInterface = Just uPowerDeviceInterfaceName } + signalHandler + -- | Monitor the DisplayDevice for changes, writing a new "BatteryInfo" object -- to returned "MVar" and "Chan" objects monitorDisplayBattery :: TaffyIO (Chan BatteryInfo, MVar BatteryInfo) @@ -176,7 +184,6 @@ monitorDisplayBattery = do infoVar <- lift $ newMVar $ infoMapToBatteryInfo M.empty chan <- lift newChan taffyFork $ do - lift $ batteryLog DEBUG "Started battery monitor thread" ctx <- ask let warnOfFailedGetDevice err = batteryLogF WARNING "Failure getting DisplayBattery: %s" err >> @@ -188,18 +195,31 @@ monitorDisplayBattery = do do batteryLogF DEBUG "Battery changed properties: %s" changedProps runReaderT doUpdate ctx - let propMatcher = matchAny { matchPath = Just displayPath } - _ <- lift $ DBus.registerForPropertiesChanged client propMatcher signalCallback + let propMatcher = matchAny { matchInterface = Just uPowerDeviceInterfaceName } + _ <- registerForAnyUPowerPropertiesChanged signalCallback doUpdate return () return (chan, infoVar) --- | Request a refresh of all upower batteries. This is only needed if UPower's +-- | Call "refreshAllBatteries" whenever the BatteryInfo for the DisplayDevice +-- is updated. This handles cases where there is a race between the signal that +-- something is updated and the update actually being visible. See +-- https://github.com/taffybar/taffybar/issues/330 for more details. +refreshBatteriesOnPropChange :: TaffyIO () +refreshBatteriesOnPropChange = ask >>= \ctx -> + let updateIfRealChange _ _ changedProps _ = + flip runReaderT ctx $ + when (any ((/= "UpdateTime") . fst) $ M.toList changedProps) $ + lift (threadDelay 1000000) >> refreshAllBatteries + in void $ registerForAnyUPowerPropertiesChanged updateIfRealChange + +-- | Request a refresh of all UPower batteries. This is only needed if UPower's -- refresh mechanism is not working properly. refreshAllBatteries :: TaffyIO () refreshAllBatteries = do client <- asks systemDBusClient - eerror <- runExceptT $ (ExceptT getBatteryPaths) >>= liftIO . mapM (refresh client) + let doRefresh path = batteryLogF DEBUG "Refreshing battery: %s" path >> refresh client path + eerror <- runExceptT $ (ExceptT getBatteryPaths) >>= liftIO . mapM doRefresh let logRefreshError = batteryLogF ERROR "Failed to refresh battery: %s" logGetPathsError = batteryLogF ERROR "Failed to get battery paths %s" diff --git a/src/System/Taffybar/Util.hs b/src/System/Taffybar/Util.hs index 59ee2710..86813f9e 100644 --- a/src/System/Taffybar/Util.hs +++ b/src/System/Taffybar/Util.hs @@ -24,6 +24,11 @@ import System.Log.Logger import qualified System.Process as P import Text.Printf +liftReader :: + Monad m => (m1 a -> m b) -> ReaderT r m1 a -> ReaderT r m b +liftReader modifier action = + ask >>= lift . modifier . runReaderT action + logPrintF :: (MonadIO m, Show t) => String -> Priority -> String -> t -> m () diff --git a/src/System/Taffybar/Widget/Layout.hs b/src/System/Taffybar/Widget/Layout.hs index dd6ba606..ac3fc3c0 100644 --- a/src/System/Taffybar/Widget/Layout.hs +++ b/src/System/Taffybar/Widget/Layout.hs @@ -14,21 +14,22 @@ -- to switch to the first one (as configured in @xmonad.hs@) ----------------------------------------------------------------------------- -module System.Taffybar.Widget.Layout ( +module System.Taffybar.Widget.Layout + ( -- * Usage -- $usage LayoutConfig(..) , defaultLayoutConfig , layoutNew -) where + ) where -import Control.Monad.Trans -import Control.Monad.Reader +import Control.Monad.Reader import qualified Graphics.UI.Gtk as Gtk import qualified Graphics.UI.Gtk.Abstract.Widget as W -import System.Taffybar.Information.X11DesktopInfo -import System.Taffybar.Widget.Util -import System.Taffybar.Context +import System.Taffybar.Context +import System.Taffybar.Information.X11DesktopInfo +import System.Taffybar.Util +import System.Taffybar.Widget.Util -- $usage --