Add hack to fix UPower buggyness

Fixes #330

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
 

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

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

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 ()

src/System/Taffybar/Hooks.hs

@@ -1,13 +1,15 @@
 module System.Taffybar.Hooks
   ( module System.Taffybar.DBus
   , module System.Taffybar.Hooks
+  , refreshBatteriesOnPropChange
   ) where
 
 import Control.Concurrent
 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

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"
 

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 ()

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