{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Information.Battery
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
--
-- This module provides functions for querying battery information using the
-- UPower dbus, as well as a broadcast "TChan" system for allowing multiple
-- readers to receive 'BatteryState' updates without duplicating requests.
-----------------------------------------------------------------------------
module System.Taffybar.Information.Battery
  ( BatteryInfo(..)
  , BatteryState(..)
  , BatteryTechnology(..)
  , BatteryType(..)
  , module System.Taffybar.Information.Battery
  ) where

import           Control.Concurrent
import           Control.Concurrent.STM.TChan
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.STM (atomically)
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Except
import           Control.Monad.Trans.Reader
import           DBus
import           DBus.Client
import           DBus.Internal.Types (Serial(..))
import qualified DBus.TH as DBus
import           Data.Int
import           Data.List
import           Data.Map ( Map )
import qualified Data.Map as M
import           Data.Maybe
import           Data.Text ( Text )
import           Data.Word
import           System.Log.Logger
import           System.Taffybar.Context
import           System.Taffybar.DBus.Client.Params
import           System.Taffybar.DBus.Client.UPower
import           System.Taffybar.DBus.Client.UPowerDevice
import           System.Taffybar.Util

batteryLogPath :: String
batteryLogPath :: String
batteryLogPath = String
"System.Taffybar.Information.Battery"

batteryLog
  :: MonadIO m
  => Priority -> String -> m ()
batteryLog :: forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
batteryLog Priority
priority = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (String -> IO ()) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Priority -> String -> IO ()
logM String
batteryLogPath Priority
priority

batteryLogF
  :: (MonadIO m, Show t)
  => Priority -> String -> t -> m ()
batteryLogF :: forall (m :: * -> *) t.
(MonadIO m, Show t) =>
Priority -> String -> t -> m ()
batteryLogF = String -> Priority -> String -> t -> m ()
forall (m :: * -> *) t.
(MonadIO m, Show t) =>
String -> Priority -> String -> t -> m ()
logPrintF String
batteryLogPath

-- | The DBus path prefix where UPower enumerates its objects.
uPowerDevicesPath :: ObjectPath
uPowerDevicesPath :: ObjectPath
uPowerDevicesPath = String -> ObjectPath
objectPath_ (ObjectPath -> String
formatObjectPath ObjectPath
uPowerBaseObjectPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/devices")

-- | The prefix of name of battery devices path. UPower generates the object
-- path as "battery" + "_" + basename of the sysfs object.
batteryPrefix :: String
batteryPrefix :: String
batteryPrefix = ObjectPath -> String
formatObjectPath ObjectPath
uPowerDevicesPath String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/battery_"

-- | Determine if a power source is a battery.
isBattery :: ObjectPath -> Bool
isBattery :: ObjectPath -> Bool
isBattery = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
batteryPrefix (String -> Bool) -> (ObjectPath -> String) -> ObjectPath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectPath -> String
formatObjectPath

-- | A helper to read the variant contents of a dict with a default
-- value.
readDict :: (IsVariant a) => Map Text Variant -> Text -> a -> a
readDict :: forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
key a
dflt = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
dflt (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ do
  variant <- Text -> Map Text Variant -> Maybe Variant
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key Map Text Variant
dict
  fromVariant variant

-- | Read the variant contents of a dict which is of an unknown integral type.
readDictIntegral :: Map Text Variant -> Text -> Int32 -> Int
readDictIntegral :: Map Text Variant -> Text -> Int32 -> Int
readDictIntegral Map Text Variant
dict Text
key Int32
dflt = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
dflt) (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ do
  v <- Text -> Map Text Variant -> Maybe Variant
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key Map Text Variant
dict
  case variantType v of
    Type
TypeWord8   -> Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Variant -> Word8
forall a. (Num a, IsVariant a) => Variant -> a
f Variant
v :: Word8)
    Type
TypeWord16  -> Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Variant -> Word16
forall a. (Num a, IsVariant a) => Variant -> a
f Variant
v :: Word16)
    Type
TypeWord32  -> Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Variant -> Word32
forall a. (Num a, IsVariant a) => Variant -> a
f Variant
v :: Word32)
    Type
TypeWord64  -> Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Variant -> Word64
forall a. (Num a, IsVariant a) => Variant -> a
f Variant
v :: Word64)
    Type
TypeInt16   -> Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Variant -> Int16
forall a. (Num a, IsVariant a) => Variant -> a
f Variant
v :: Int16)
    Type
TypeInt32   -> Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Variant -> Int32
forall a. (Num a, IsVariant a) => Variant -> a
f Variant
v :: Int32)
    Type
TypeInt64   -> Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Variant -> Int64
forall a. (Num a, IsVariant a) => Variant -> a
f Variant
v :: Int64)
    Type
_           -> Maybe Int
forall a. Maybe a
Nothing
  where
    f :: (Num a, IsVariant a) => Variant -> a
    f :: forall a. (Num a, IsVariant a) => Variant -> a
f = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (Int32 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
dflt) (Maybe a -> a) -> (Variant -> Maybe a) -> Variant -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Variant -> Maybe a
forall a. IsVariant a => Variant -> Maybe a
fromVariant

-- XXX: Remove this once it is exposed in haskell-dbus
dummyMethodError :: MethodError
dummyMethodError :: MethodError
dummyMethodError = Serial -> ErrorName -> MethodError
methodError (Word32 -> Serial
Serial Word32
1) (ErrorName -> MethodError) -> ErrorName -> MethodError
forall a b. (a -> b) -> a -> b
$ String -> ErrorName
errorName_ String
"org.ClientTypeMismatch"

-- | Query the UPower daemon about information on a specific battery.
-- If some fields are not actually present, they may have bogus values
-- here.  Don't bet anything critical on it.
getBatteryInfo :: ObjectPath -> TaffyIO (Either MethodError BatteryInfo)
getBatteryInfo :: ObjectPath -> TaffyIO (Either MethodError BatteryInfo)
getBatteryInfo ObjectPath
battPath = (Context -> Client) -> ReaderT Context IO Client
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Context -> Client
systemDBusClient ReaderT Context IO Client
-> (Client -> TaffyIO (Either MethodError BatteryInfo))
-> TaffyIO (Either MethodError BatteryInfo)
forall a b.
ReaderT Context IO a
-> (a -> ReaderT Context IO b) -> ReaderT Context IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Client
client -> IO (Either MethodError BatteryInfo)
-> TaffyIO (Either MethodError BatteryInfo)
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either MethodError BatteryInfo)
 -> TaffyIO (Either MethodError BatteryInfo))
-> IO (Either MethodError BatteryInfo)
-> TaffyIO (Either MethodError BatteryInfo)
forall a b. (a -> b) -> a -> b
$ ExceptT MethodError IO BatteryInfo
-> IO (Either MethodError BatteryInfo)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT MethodError IO BatteryInfo
 -> IO (Either MethodError BatteryInfo))
-> ExceptT MethodError IO BatteryInfo
-> IO (Either MethodError BatteryInfo)
forall a b. (a -> b) -> a -> b
$ do
  reply <- IO (Either MethodError MethodReturn)
-> ExceptT MethodError IO MethodReturn
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either MethodError MethodReturn)
 -> ExceptT MethodError IO MethodReturn)
-> IO (Either MethodError MethodReturn)
-> ExceptT MethodError IO MethodReturn
forall a b. (a -> b) -> a -> b
$ Client -> MethodCall -> IO (Either MethodError MethodReturn)
getAllProperties Client
client (MethodCall -> IO (Either MethodError MethodReturn))
-> MethodCall -> IO (Either MethodError MethodReturn)
forall a b. (a -> b) -> a -> b
$
           (ObjectPath -> InterfaceName -> MemberName -> MethodCall
methodCall ObjectPath
battPath InterfaceName
uPowerDeviceInterfaceName MemberName
"FakeMethod")
           { methodCallDestination = Just uPowerBusName }
  dict <- ExceptT $ return $ maybeToEither dummyMethodError $
         listToMaybe (methodReturnBody reply) >>= fromVariant
  return $ infoMapToBatteryInfo dict

infoMapToBatteryInfo :: Map Text Variant -> BatteryInfo
infoMapToBatteryInfo :: Map Text Variant -> BatteryInfo
infoMapToBatteryInfo Map Text Variant
dict =
    BatteryInfo
      { batteryNativePath :: String
batteryNativePath = Map Text Variant -> Text -> String -> String
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"NativePath" String
""
      , batteryVendor :: String
batteryVendor = Map Text Variant -> Text -> String -> String
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"Vendor" String
""
      , batteryModel :: String
batteryModel = Map Text Variant -> Text -> String -> String
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"Model" String
""
      , batterySerial :: String
batterySerial = Map Text Variant -> Text -> String -> String
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"Serial" String
""
      , batteryType :: BatteryType
batteryType = Int -> BatteryType
forall a. Enum a => Int -> a
toEnum (Int -> BatteryType) -> Int -> BatteryType
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Map Text Variant -> Text -> Int32 -> Int
readDictIntegral Map Text Variant
dict Text
"Type" Int32
0
      , batteryPowerSupply :: Bool
batteryPowerSupply = Map Text Variant -> Text -> Bool -> Bool
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"PowerSupply" Bool
False
      , batteryHasHistory :: Bool
batteryHasHistory = Map Text Variant -> Text -> Bool -> Bool
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"HasHistory" Bool
False
      , batteryHasStatistics :: Bool
batteryHasStatistics = Map Text Variant -> Text -> Bool -> Bool
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"HasStatistics" Bool
False
      , batteryOnline :: Bool
batteryOnline = Map Text Variant -> Text -> Bool -> Bool
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"Online" Bool
False
      , batteryEnergy :: Double
batteryEnergy = Map Text Variant -> Text -> Double -> Double
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"Energy" Double
0.0
      , batteryEnergyEmpty :: Double
batteryEnergyEmpty = Map Text Variant -> Text -> Double -> Double
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"EnergyEmpty" Double
0.0
      , batteryEnergyFull :: Double
batteryEnergyFull = Map Text Variant -> Text -> Double -> Double
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"EnergyFull" Double
0.0
      , batteryEnergyFullDesign :: Double
batteryEnergyFullDesign = Map Text Variant -> Text -> Double -> Double
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"EnergyFullDesign" Double
0.0
      , batteryEnergyRate :: Double
batteryEnergyRate = Map Text Variant -> Text -> Double -> Double
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"EnergyRate" Double
0.0
      , batteryVoltage :: Double
batteryVoltage = Map Text Variant -> Text -> Double -> Double
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"Voltage" Double
0.0
      , batteryTimeToEmpty :: Int64
batteryTimeToEmpty = Map Text Variant -> Text -> Int64 -> Int64
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"TimeToEmpty" Int64
0
      , batteryTimeToFull :: Int64
batteryTimeToFull = Map Text Variant -> Text -> Int64 -> Int64
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"TimeToFull" Int64
0
      , batteryPercentage :: Double
batteryPercentage = Map Text Variant -> Text -> Double -> Double
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"Percentage" Double
0.0
      , batteryIsPresent :: Bool
batteryIsPresent = Map Text Variant -> Text -> Bool -> Bool
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"IsPresent" Bool
False
      , batteryState :: BatteryState
batteryState = Int -> BatteryState
forall a. Enum a => Int -> a
toEnum (Int -> BatteryState) -> Int -> BatteryState
forall a b. (a -> b) -> a -> b
$ Map Text Variant -> Text -> Int32 -> Int
readDictIntegral Map Text Variant
dict Text
"State" Int32
0
      , batteryIsRechargeable :: Bool
batteryIsRechargeable = Map Text Variant -> Text -> Bool -> Bool
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"IsRechargable" Bool
True
      , batteryCapacity :: Double
batteryCapacity = Map Text Variant -> Text -> Double -> Double
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"Capacity" Double
0.0
      , batteryTechnology :: BatteryTechnology
batteryTechnology =
          Int -> BatteryTechnology
forall a. Enum a => Int -> a
toEnum (Int -> BatteryTechnology) -> Int -> BatteryTechnology
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Map Text Variant -> Text -> Int32 -> Int
readDictIntegral Map Text Variant
dict Text
"Technology" Int32
0
      , batteryUpdateTime :: Word64
batteryUpdateTime = Map Text Variant -> Text -> Word64 -> Word64
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"UpdateTime" Word64
0
      , batteryLuminosity :: Double
batteryLuminosity = Map Text Variant -> Text -> Double -> Double
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"Luminosity" Double
0.0
      , batteryTemperature :: Double
batteryTemperature = Map Text Variant -> Text -> Double -> Double
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"Temperature" Double
0.0
      , batteryWarningLevel :: Word32
batteryWarningLevel = Map Text Variant -> Text -> Word32 -> Word32
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"WarningLevel" Word32
0
      , batteryBatteryLevel :: Word32
batteryBatteryLevel = Map Text Variant -> Text -> Word32 -> Word32
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"BatteryLevel" Word32
0
      , batteryIconName :: String
batteryIconName = Map Text Variant -> Text -> String -> String
forall a. IsVariant a => Map Text Variant -> Text -> a -> a
readDict Map Text Variant
dict Text
"IconName" String
""
      }

getBatteryPaths :: TaffyIO (Either MethodError [ObjectPath])
getBatteryPaths :: TaffyIO (Either MethodError [ObjectPath])
getBatteryPaths = do
  client <- (Context -> Client) -> ReaderT Context IO Client
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Context -> Client
systemDBusClient
  liftIO $ runExceptT $ do
    paths <- ExceptT $ enumerateDevices client
    return $ filter isBattery paths

newtype DisplayBatteryChanVar =
  DisplayBatteryChanVar (TChan BatteryInfo, MVar BatteryInfo)

getDisplayBatteryInfo :: TaffyIO BatteryInfo
getDisplayBatteryInfo :: TaffyIO BatteryInfo
getDisplayBatteryInfo = do
  DisplayBatteryChanVar (_, theVar) <- TaffyIO DisplayBatteryChanVar
getDisplayBatteryChanVar
  lift $ readMVar theVar

defaultMonitorDisplayBatteryProperties :: [String]
defaultMonitorDisplayBatteryProperties :: [String]
defaultMonitorDisplayBatteryProperties = [ String
"IconName", String
"State", String
"Percentage" ]

-- | Start the monitoring of the display battery, and setup the associated
-- channel and mvar for the current state.
setupDisplayBatteryChanVar :: [String] -> TaffyIO DisplayBatteryChanVar
setupDisplayBatteryChanVar :: [String] -> TaffyIO DisplayBatteryChanVar
setupDisplayBatteryChanVar [String]
properties = TaffyIO DisplayBatteryChanVar -> TaffyIO DisplayBatteryChanVar
forall t. Typeable t => Taffy IO t -> Taffy IO t
getStateDefault (TaffyIO DisplayBatteryChanVar -> TaffyIO DisplayBatteryChanVar)
-> TaffyIO DisplayBatteryChanVar -> TaffyIO DisplayBatteryChanVar
forall a b. (a -> b) -> a -> b
$
  (TChan BatteryInfo, MVar BatteryInfo) -> DisplayBatteryChanVar
DisplayBatteryChanVar ((TChan BatteryInfo, MVar BatteryInfo) -> DisplayBatteryChanVar)
-> ReaderT Context IO (TChan BatteryInfo, MVar BatteryInfo)
-> TaffyIO DisplayBatteryChanVar
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
-> ReaderT Context IO (TChan BatteryInfo, MVar BatteryInfo)
monitorDisplayBattery [String]
properties

getDisplayBatteryChanVar :: TaffyIO DisplayBatteryChanVar
getDisplayBatteryChanVar :: TaffyIO DisplayBatteryChanVar
getDisplayBatteryChanVar =
  [String] -> TaffyIO DisplayBatteryChanVar
setupDisplayBatteryChanVar [String]
defaultMonitorDisplayBatteryProperties

getDisplayBatteryChan :: TaffyIO (TChan BatteryInfo)
getDisplayBatteryChan :: TaffyIO (TChan BatteryInfo)
getDisplayBatteryChan = do
  DisplayBatteryChanVar (chan, _) <- TaffyIO DisplayBatteryChanVar
getDisplayBatteryChanVar
  return chan

updateBatteryInfo
  :: TChan BatteryInfo
  -> MVar BatteryInfo
  -> ObjectPath
  -> TaffyIO ()
updateBatteryInfo :: TChan BatteryInfo -> MVar BatteryInfo -> ObjectPath -> TaffyIO ()
updateBatteryInfo TChan BatteryInfo
chan MVar BatteryInfo
var ObjectPath
path =
  ObjectPath -> TaffyIO (Either MethodError BatteryInfo)
getBatteryInfo ObjectPath
path TaffyIO (Either MethodError BatteryInfo)
-> (Either MethodError BatteryInfo -> TaffyIO ()) -> TaffyIO ()
forall a b.
ReaderT Context IO a
-> (a -> ReaderT Context IO b) -> ReaderT Context IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> TaffyIO ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> TaffyIO ())
-> (Either MethodError BatteryInfo -> IO ())
-> Either MethodError BatteryInfo
-> TaffyIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MethodError -> IO ())
-> (BatteryInfo -> IO ())
-> Either MethodError BatteryInfo
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either MethodError -> IO ()
warnOfFailure BatteryInfo -> IO ()
doWrites
  where
    doWrites :: BatteryInfo -> IO ()
doWrites BatteryInfo
info =
        Priority -> String -> BatteryInfo -> IO ()
forall (m :: * -> *) t.
(MonadIO m, Show t) =>
Priority -> String -> t -> m ()
batteryLogF Priority
DEBUG String
"Writing info %s" BatteryInfo
info IO () -> IO BatteryInfo -> IO BatteryInfo
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
        MVar BatteryInfo -> BatteryInfo -> IO BatteryInfo
forall a. MVar a -> a -> IO a
swapMVar MVar BatteryInfo
var BatteryInfo
info IO BatteryInfo -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan BatteryInfo -> BatteryInfo -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan BatteryInfo
chan BatteryInfo
info)
    warnOfFailure :: MethodError -> IO ()
warnOfFailure = Priority -> String -> MethodError -> IO ()
forall (m :: * -> *) t.
(MonadIO m, Show t) =>
Priority -> String -> t -> m ()
batteryLogF Priority
WARNING String
"Failed to update battery info %s"

registerForAnyUPowerPropertiesChanged
  :: (Signal -> String -> Map String Variant -> [String] -> IO ())
  -> ReaderT Context IO SignalHandler
registerForAnyUPowerPropertiesChanged :: (Signal -> String -> Map String Variant -> [String] -> IO ())
-> ReaderT Context IO SignalHandler
registerForAnyUPowerPropertiesChanged = [String]
-> (Signal -> String -> Map String Variant -> [String] -> IO ())
-> ReaderT Context IO SignalHandler
registerForUPowerPropertyChanges []

registerForUPowerPropertyChanges
  :: [String]
  -> (Signal -> String -> Map String Variant -> [String] -> IO ())
  -> ReaderT Context IO SignalHandler
registerForUPowerPropertyChanges :: [String]
-> (Signal -> String -> Map String Variant -> [String] -> IO ())
-> ReaderT Context IO SignalHandler
registerForUPowerPropertyChanges [String]
properties Signal -> String -> Map String Variant -> [String] -> IO ()
signalHandler = do
  client <- (Context -> Client) -> ReaderT Context IO Client
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Context -> Client
systemDBusClient
  lift $ DBus.registerForPropertiesChanged
      client
      matchAny { matchInterface = Just uPowerDeviceInterfaceName
               , matchPathNamespace = Just uPowerDevicesPath }
      handleIfPropertyMatches
  where handleIfPropertyMatches :: Signal -> String -> Map String Variant -> [String] -> IO ()
handleIfPropertyMatches Signal
rawSignal String
n Map String Variant
propertiesMap [String]
l =
          let propertyPresent :: String -> Bool
propertyPresent String
prop = String -> Map String Variant -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member String
prop Map String Variant
propertiesMap
          in Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any String -> Bool
propertyPresent [String]
properties Bool -> Bool -> Bool
|| [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
properties) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
             Signal -> String -> Map String Variant -> [String] -> IO ()
signalHandler Signal
rawSignal String
n Map String Variant
propertiesMap [String]
l

-- | Monitor the DisplayDevice for changes, writing a new "BatteryInfo" object
-- to returned "MVar" and "Chan" objects
monitorDisplayBattery ::
  [String] -> TaffyIO (TChan BatteryInfo, MVar BatteryInfo)
monitorDisplayBattery :: [String]
-> ReaderT Context IO (TChan BatteryInfo, MVar BatteryInfo)
monitorDisplayBattery [String]
propertiesToMonitor = do
  IO () -> TaffyIO ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> TaffyIO ()) -> IO () -> TaffyIO ()
forall a b. (a -> b) -> a -> b
$ Priority -> String -> IO ()
forall (m :: * -> *). MonadIO m => Priority -> String -> m ()
batteryLog Priority
DEBUG String
"Starting Battery Monitor"
  client <- (Context -> Client) -> ReaderT Context IO Client
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Context -> Client
systemDBusClient
  infoVar <- lift $ newMVar $ infoMapToBatteryInfo M.empty
  chan <- liftIO newBroadcastTChanIO
  taffyFork $ do
    ctx <- ask
    let warnOfFailedGetDevice t
err =
          Priority -> String -> t -> m ()
forall (m :: * -> *) t.
(MonadIO m, Show t) =>
Priority -> String -> t -> m ()
batteryLogF Priority
WARNING String
"Failure getting DisplayBattery: %s" t
err m () -> m b -> m b
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
          b -> m b
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
"/org/freedesktop/UPower/devices/DisplayDevice"
    displayPath <- lift $ getDisplayDevice client >>=
                   either warnOfFailedGetDevice return
    let doUpdate = TChan BatteryInfo -> MVar BatteryInfo -> ObjectPath -> TaffyIO ()
updateBatteryInfo TChan BatteryInfo
chan MVar BatteryInfo
infoVar ObjectPath
displayPath
        signalCallback Signal
_ String
_ Map String Variant
changedProps [String]
_ =
          do
            Priority -> String -> Map String Variant -> IO ()
forall (m :: * -> *) t.
(MonadIO m, Show t) =>
Priority -> String -> t -> m ()
batteryLogF Priority
DEBUG String
"Battery changed properties: %s" Map String Variant
changedProps
            TaffyIO () -> Context -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT TaffyIO ()
doUpdate Context
ctx
    _ <- registerForUPowerPropertyChanges propertiesToMonitor signalCallback
    doUpdate

  return (chan, infoVar)

-- | 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 :: TaffyIO ()
refreshBatteriesOnPropChange = ReaderT Context IO Context
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask ReaderT Context IO Context -> (Context -> TaffyIO ()) -> TaffyIO ()
forall a b.
ReaderT Context IO a
-> (a -> ReaderT Context IO b) -> ReaderT Context IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Context
ctx ->
  let updateIfRealChange :: Signal -> String -> Map String Variant -> [String] -> IO ()
updateIfRealChange Signal
_ String
_ Map String Variant
changedProps [String]
_ =
        (TaffyIO () -> Context -> IO ()) -> Context -> TaffyIO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip TaffyIO () -> Context -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Context
ctx (TaffyIO () -> IO ()) -> TaffyIO () -> IO ()
forall a b. (a -> b) -> a -> b
$
             Bool -> TaffyIO () -> TaffyIO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (((String, Variant) -> Bool) -> [(String, Variant)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
"UpdateTime", String
"Voltage"]) (String -> Bool)
-> ((String, Variant) -> String) -> (String, Variant) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Variant) -> String
forall a b. (a, b) -> a
fst) ([(String, Variant)] -> Bool) -> [(String, Variant)] -> Bool
forall a b. (a -> b) -> a -> b
$
                       Map String Variant -> [(String, Variant)]
forall k a. Map k a -> [(k, a)]
M.toList Map String Variant
changedProps) (TaffyIO () -> TaffyIO ()) -> TaffyIO () -> TaffyIO ()
forall a b. (a -> b) -> a -> b
$
                  IO () -> TaffyIO ()
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Int -> IO ()
threadDelay Int
1000000) TaffyIO () -> TaffyIO () -> TaffyIO ()
forall a b.
ReaderT Context IO a
-> ReaderT Context IO b -> ReaderT Context IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TaffyIO ()
refreshAllBatteries
  in ReaderT Context IO SignalHandler -> TaffyIO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReaderT Context IO SignalHandler -> TaffyIO ())
-> ReaderT Context IO SignalHandler -> TaffyIO ()
forall a b. (a -> b) -> a -> b
$ (Signal -> String -> Map String Variant -> [String] -> IO ())
-> ReaderT Context IO SignalHandler
registerForAnyUPowerPropertiesChanged Signal -> String -> Map String Variant -> [String] -> IO ()
updateIfRealChange

-- | Request a refresh of all UPower batteries. This is only needed if UPower's
-- refresh mechanism is not working properly.
refreshAllBatteries :: TaffyIO ()
refreshAllBatteries :: TaffyIO ()
refreshAllBatteries = do
  client <- (Context -> Client) -> ReaderT Context IO Client
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Context -> Client
systemDBusClient
  let doRefresh ObjectPath
path =
        Priority -> String -> ObjectPath -> IO ()
forall (m :: * -> *) t.
(MonadIO m, Show t) =>
Priority -> String -> t -> m ()
batteryLogF Priority
DEBUG String
"Refreshing battery: %s" ObjectPath
path IO () -> IO (Either MethodError ()) -> IO (Either MethodError ())
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Client -> ObjectPath -> IO (Either MethodError ())
refresh Client
client ObjectPath
path
  eerror <- runExceptT $ ExceptT getBatteryPaths >>= liftIO . mapM doRefresh

  -- NB. The Refresh() method is only available if the UPower daemon
  -- was started in debug mode. So ignore any errors about the method
  -- not being implemented.
  let logRefreshError MethodError
e = Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (MethodError -> ErrorName
methodErrorName MethodError
e ErrorName -> ErrorName -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorName
errorUnknownMethod) (f () -> f ()) -> f () -> f ()
forall a b. (a -> b) -> a -> b
$
        Priority -> String -> MethodError -> f ()
forall (m :: * -> *) t.
(MonadIO m, Show t) =>
Priority -> String -> t -> m ()
batteryLogF Priority
ERROR String
"Failed to refresh battery: %s" MethodError
e
      logGetPathsError = Priority -> String -> MethodError -> TaffyIO ()
forall (m :: * -> *) t.
(MonadIO m, Show t) =>
Priority -> String -> t -> m ()
batteryLogF Priority
ERROR String
"Failed to get battery paths %s"

  void $ either logGetPathsError (mapM_ $ either logRefreshError return) eerror