Battery.hs

{-# 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 = "System.Taffybar.Information.Battery"

batteryLog
  :: MonadIO m
  => Priority -> String -> m ()
batteryLog priority = liftIO . logM batteryLogPath priority

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

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

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

-- | Determine if a power source is a battery.
isBattery :: ObjectPath -> Bool
isBattery = isPrefixOf batteryPrefix . 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 dict key dflt = fromMaybe dflt $ do
  variant <- M.lookup key 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 dict key dflt = fromMaybe (fromIntegral dflt) $ do
  v <- M.lookup key dict
  case variantType v of
    TypeWord8   -> return $ fromIntegral (f v :: Word8)
    TypeWord16  -> return $ fromIntegral (f v :: Word16)
    TypeWord32  -> return $ fromIntegral (f v :: Word32)
    TypeWord64  -> return $ fromIntegral (f v :: Word64)
    TypeInt16   -> return $ fromIntegral (f v :: Int16)
    TypeInt32   -> return $ fromIntegral (f v :: Int32)
    TypeInt64   -> return $ fromIntegral (f v :: Int64)
    _           -> Nothing
  where
    f :: (Num a, IsVariant a) => Variant -> a
    f = fromMaybe (fromIntegral dflt) . fromVariant

-- XXX: Remove this once it is exposed in haskell-dbus
dummyMethodError :: MethodError
dummyMethodError = methodError (Serial 1) $ errorName_ "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 battPath = asks systemDBusClient >>= \client -> lift $ runExceptT $ do
  reply <- ExceptT $ getAllProperties client $
           (methodCall battPath uPowerDeviceInterfaceName "FakeMethod")
           { methodCallDestination = Just uPowerBusName }
  dict <- ExceptT $ return $ maybeToEither dummyMethodError $
         listToMaybe (methodReturnBody reply) >>= fromVariant
  return $ infoMapToBatteryInfo dict

infoMapToBatteryInfo :: Map Text Variant -> BatteryInfo
infoMapToBatteryInfo dict =
    BatteryInfo
      { batteryNativePath = readDict dict "NativePath" ""
      , batteryVendor = readDict dict "Vendor" ""
      , batteryModel = readDict dict "Model" ""
      , batterySerial = readDict dict "Serial" ""
      , batteryType = toEnum $ fromIntegral $ readDictIntegral dict "Type" 0
      , batteryPowerSupply = readDict dict "PowerSupply" False
      , batteryHasHistory = readDict dict "HasHistory" False
      , batteryHasStatistics = readDict dict "HasStatistics" False
      , batteryOnline = readDict dict "Online" False
      , batteryEnergy = readDict dict "Energy" 0.0
      , batteryEnergyEmpty = readDict dict "EnergyEmpty" 0.0
      , batteryEnergyFull = readDict dict "EnergyFull" 0.0
      , batteryEnergyFullDesign = readDict dict "EnergyFullDesign" 0.0
      , batteryEnergyRate = readDict dict "EnergyRate" 0.0
      , batteryVoltage = readDict dict "Voltage" 0.0
      , batteryTimeToEmpty = readDict dict "TimeToEmpty" 0
      , batteryTimeToFull = readDict dict "TimeToFull" 0
      , batteryPercentage = readDict dict "Percentage" 0.0
      , batteryIsPresent = readDict dict "IsPresent" False
      , batteryState = toEnum $ readDictIntegral dict "State" 0
      , batteryIsRechargeable = readDict dict "IsRechargable" True
      , batteryCapacity = readDict dict "Capacity" 0.0
      , batteryTechnology =
          toEnum $ fromIntegral $ readDictIntegral dict "Technology" 0
      , batteryUpdateTime = readDict dict "UpdateTime" 0
      , batteryLuminosity = readDict dict "Luminosity" 0.0
      , batteryTemperature = readDict dict "Temperature" 0.0
      , batteryWarningLevel = readDict dict "WarningLevel" 0
      , batteryBatteryLevel = readDict dict "BatteryLevel" 0
      , batteryIconName = readDict dict "IconName" ""
      }

getBatteryPaths :: TaffyIO (Either MethodError [ObjectPath])
getBatteryPaths = do
  client <- asks systemDBusClient
  liftIO $ runExceptT $ do
    paths <- ExceptT $ enumerateDevices client
    return $ filter isBattery paths

newtype DisplayBatteryChanVar =
  DisplayBatteryChanVar (TChan BatteryInfo, MVar BatteryInfo)

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

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

-- | Start the monitoring of the display battery, and setup the associated
-- channel and mvar for the current state.
setupDisplayBatteryChanVar :: [String] -> TaffyIO DisplayBatteryChanVar
setupDisplayBatteryChanVar properties = getStateDefault $
  DisplayBatteryChanVar <$> monitorDisplayBattery properties

getDisplayBatteryChanVar :: TaffyIO DisplayBatteryChanVar
getDisplayBatteryChanVar =
  setupDisplayBatteryChanVar defaultMonitorDisplayBatteryProperties

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

updateBatteryInfo
  :: TChan BatteryInfo
  -> MVar BatteryInfo
  -> ObjectPath
  -> TaffyIO ()
updateBatteryInfo chan var path =
  getBatteryInfo path >>= lift . either warnOfFailure doWrites
  where
    doWrites info =
        batteryLogF DEBUG "Writing info %s" info >>
        swapMVar var info >> void (atomically $ writeTChan chan info)
    warnOfFailure = batteryLogF WARNING "Failed to update battery info %s"

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

registerForUPowerPropertyChanges
  :: [String]
  -> (Signal -> String -> Map String Variant -> [String] -> IO ())
  -> ReaderT Context IO SignalHandler
registerForUPowerPropertyChanges properties signalHandler = do
  client <- asks systemDBusClient
  lift $ DBus.registerForPropertiesChanged
      client
      matchAny { matchInterface = Just uPowerDeviceInterfaceName
               , matchPathNamespace = Just uPowerDevicesPath }
      handleIfPropertyMatches
  where handleIfPropertyMatches rawSignal n propertiesMap l =
          let propertyPresent prop = M.member prop propertiesMap
          in when (any propertyPresent properties || null properties) $
             signalHandler rawSignal n propertiesMap 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 propertiesToMonitor = do
  lift $ batteryLog DEBUG "Starting Battery Monitor"
  client <- asks systemDBusClient
  infoVar <- lift $ newMVar $ infoMapToBatteryInfo M.empty
  chan <- liftIO newBroadcastTChanIO
  taffyFork $ do
    ctx <- ask
    let warnOfFailedGetDevice err =
          batteryLogF WARNING "Failure getting DisplayBattery: %s" err >>
          return "/org/freedesktop/UPower/devices/DisplayDevice"
    displayPath <- lift $ getDisplayDevice client >>=
                   either warnOfFailedGetDevice return
    let doUpdate = updateBatteryInfo chan infoVar displayPath
        signalCallback _ _ changedProps _ =
          do
            batteryLogF DEBUG "Battery changed properties: %s" changedProps
            runReaderT doUpdate 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 = ask >>= \ctx ->
  let updateIfRealChange _ _ changedProps _ =
        flip runReaderT ctx $
             when (any ((`notElem` ["UpdateTime", "Voltage"]) . 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
  let doRefresh path =
        batteryLogF DEBUG "Refreshing battery: %s" path >> refresh client 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 e = unless (methodErrorName e == errorUnknownMethod) $
        batteryLogF ERROR "Failed to refresh battery: %s" e
      logGetPathsError = batteryLogF ERROR "Failed to get battery paths %s"

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