PowerProfiles.hs

{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
-- |
-- Module      : System.Taffybar.Information.PowerProfiles
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
--
-- This module provides information about the current power profile using
-- the power-profiles-daemon DBus API (net.hadess.PowerProfiles).
-----------------------------------------------------------------------------
module System.Taffybar.Information.PowerProfiles
  ( PowerProfile(..)
  , PowerProfileInfo(..)
  , getPowerProfileInfo
  , getPowerProfileInfoFromClient
  , getPowerProfileInfoChan
  , getPowerProfileInfoState
  , cycleProfile
  , setProfile
  , powerProfileToString
  , stringToPowerProfile
  ) where

import           Control.Concurrent.MVar
import           Control.Concurrent.STM.TChan
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.Map (Map)
import qualified Data.Map as M
import           Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import           Data.Text (Text)
import           System.Log.Logger
import           System.Taffybar.Context
import           System.Taffybar.Util (logPrintF, maybeToEither)

-- | Power profile modes supported by power-profiles-daemon.
data PowerProfile
  = PowerSaver
  | Balanced
  | Performance
  deriving (Eq, Show, Ord, Enum, Bounded)

-- | Information about the current power profile state.
data PowerProfileInfo = PowerProfileInfo
  { currentProfile :: PowerProfile
  , availableProfiles :: [PowerProfile]
  , performanceDegraded :: Maybe Text
  } deriving (Eq, Show)

-- | The DBus bus name for power-profiles-daemon.
powerProfilesBusName :: BusName
powerProfilesBusName = "net.hadess.PowerProfiles"

-- | The DBus object path for power-profiles-daemon.
powerProfilesObjectPath :: ObjectPath
powerProfilesObjectPath = "/net/hadess/PowerProfiles"

-- | The DBus interface name for power-profiles-daemon.
powerProfilesInterfaceName :: InterfaceName
powerProfilesInterfaceName = "net.hadess.PowerProfiles"

powerProfilesLogPath :: String
powerProfilesLogPath = "System.Taffybar.Information.PowerProfiles"

powerProfilesLogF :: (MonadIO m, Show t) => Priority -> String -> t -> m ()
powerProfilesLogF = logPrintF powerProfilesLogPath

-- | Convert a PowerProfile to its DBus string representation.
powerProfileToString :: PowerProfile -> Text
powerProfileToString PowerSaver = "power-saver"
powerProfileToString Balanced = "balanced"
powerProfileToString Performance = "performance"

-- | Parse a DBus string to a PowerProfile.
stringToPowerProfile :: Text -> Maybe PowerProfile
stringToPowerProfile "power-saver" = Just PowerSaver
stringToPowerProfile "balanced" = Just Balanced
stringToPowerProfile "performance" = Just Performance
stringToPowerProfile _ = Nothing

-- | Default info when power-profiles-daemon is unavailable.
unknownProfileInfo :: PowerProfileInfo
unknownProfileInfo = PowerProfileInfo
  { currentProfile = Balanced
  , availableProfiles = []
  , performanceDegraded = Nothing
  }

-- XXX: Remove this once it is exposed in haskell-dbus
dummyMethodError :: MethodError
dummyMethodError = methodError (Serial 1) $ errorName_ "org.ClientTypeMismatch"

readDictMaybe :: IsVariant a => Map Text Variant -> Text -> Maybe a
readDictMaybe dict key = M.lookup key dict >>= fromVariant

getProperties
  :: Client
  -> IO (Either MethodError (Map Text Variant))
getProperties client = runExceptT $ do
  reply <- ExceptT $ getAllProperties client $
    (methodCall powerProfilesObjectPath powerProfilesInterfaceName "FakeMethod")
      { methodCallDestination = Just powerProfilesBusName }
  ExceptT $ return $ maybeToEither dummyMethodError $
    listToMaybe (methodReturnBody reply) >>= fromVariant

-- | Get current power profile info using the system DBus client from Context.
getPowerProfileInfo :: TaffyIO PowerProfileInfo
getPowerProfileInfo = asks systemDBusClient >>= liftIO . getPowerProfileInfoFromClient

-- | Get current power profile info from a DBus client.
getPowerProfileInfoFromClient :: Client -> IO PowerProfileInfo
getPowerProfileInfoFromClient client = do
  propsResult <- getProperties client
  case propsResult of
    Left err -> do
      powerProfilesLogF WARNING "Failed to read power profiles properties: %s" err
      return unknownProfileInfo
    Right props -> do
      let activeProfileStr = readDictMaybe props "ActiveProfile" :: Maybe Text
          profilesArray = readDictMaybe props "Profiles" :: Maybe [Map Text Variant]
          degraded = readDictMaybe props "PerformanceDegraded" :: Maybe Text

          -- Parse available profiles from the array of dicts
          parseProfile :: Map Text Variant -> Maybe PowerProfile
          parseProfile m = do
            name <- readDictMaybe m "Profile"
            stringToPowerProfile name

          availableProfs = maybe [] (mapMaybe parseProfile) profilesArray
          currentProf = fromMaybe Balanced (activeProfileStr >>= stringToPowerProfile)

      return PowerProfileInfo
        { currentProfile = currentProf
        , availableProfiles = availableProfs
        , performanceDegraded = if degraded == Just "" then Nothing else degraded
        }

-- | Set the active power profile.
setProfile :: Client -> PowerProfile -> IO (Either MethodError ())
setProfile client profile = do
  let profileStr = powerProfileToString profile
  result <- setProperty client
    (methodCall powerProfilesObjectPath powerProfilesInterfaceName "ActiveProfile")
      { methodCallDestination = Just powerProfilesBusName }
    (toVariant profileStr)
  return $ case result of
    Left err -> Left err
    Right _ -> Right ()

-- | Cycle to the next power profile.
-- Order: power-saver -> balanced -> performance -> power-saver
cycleProfile :: Client -> PowerProfileInfo -> IO (Either MethodError ())
cycleProfile client info =
  let current = currentProfile info
      -- Find next profile in cycle
      nextProfile = case current of
        PowerSaver -> Balanced
        Balanced -> Performance
        Performance -> PowerSaver
  in setProfile client nextProfile

-- State management for monitoring

newtype PowerProfileInfoChanVar =
  PowerProfileInfoChanVar (TChan PowerProfileInfo, MVar PowerProfileInfo)

-- | Get the current power profile info state.
getPowerProfileInfoState :: TaffyIO PowerProfileInfo
getPowerProfileInfoState = do
  PowerProfileInfoChanVar (_, theVar) <- getPowerProfileInfoChanVar
  lift $ readMVar theVar

-- | Get a broadcast channel for power profile info updates.
getPowerProfileInfoChan :: TaffyIO (TChan PowerProfileInfo)
getPowerProfileInfoChan = do
  PowerProfileInfoChanVar (chan, _) <- getPowerProfileInfoChanVar
  return chan

getPowerProfileInfoChanVar :: TaffyIO PowerProfileInfoChanVar
getPowerProfileInfoChanVar =
  getStateDefault $ PowerProfileInfoChanVar <$> monitorPowerProfileInfo

monitorPowerProfileInfo :: TaffyIO (TChan PowerProfileInfo, MVar PowerProfileInfo)
monitorPowerProfileInfo = do
  infoVar <- lift $ newMVar unknownProfileInfo
  chan <- liftIO newBroadcastTChanIO
  taffyFork $ do
    ctx <- ask
    let updateInfo = updatePowerProfileInfo chan infoVar
        signalCallback _ _ _ _ = runReaderT updateInfo ctx
    _ <- registerForPowerProfilesPropertiesChanged signalCallback
    updateInfo
  return (chan, infoVar)

registerForPowerProfilesPropertiesChanged
  :: (Signal -> String -> Map String Variant -> [String] -> IO ())
  -> ReaderT Context IO SignalHandler
registerForPowerProfilesPropertiesChanged signalHandler = do
  client <- asks systemDBusClient
  lift $ DBus.registerForPropertiesChanged
    client
    matchAny { matchInterface = Just powerProfilesInterfaceName
             , matchPath = Just powerProfilesObjectPath
             }
    signalHandler

updatePowerProfileInfo
  :: TChan PowerProfileInfo
  -> MVar PowerProfileInfo
  -> TaffyIO ()
updatePowerProfileInfo chan var = do
  info <- getPowerProfileInfo
  lift $ do
    _ <- swapMVar var info
    atomically $ writeTChan chan info