Inhibitor.hs

{-# LANGUAGE OverloadedStrings #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      : System.Taffybar.Information.Inhibitor
-- Copyright   : (c) Ivan A. Malison
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Ivan A. Malison
-- Stability   : unstable
-- Portability : unportable
--
-- This module provides functions for managing idle/sleep inhibitors using the
-- systemd-logind DBus interface. The inhibitor is acquired by calling the
-- Inhibit method on org.freedesktop.login1.Manager, which returns a file
-- descriptor. The lock is held as long as the fd is open.
module System.Taffybar.Information.Inhibitor
  ( -- * Types
    InhibitType (..),
    InhibitorState (..),
    InhibitorContext (..),

    -- * Inhibitor Management
    getInhibitorContext,
    getInhibitorState,
    toggleInhibitor,
    getInhibitorChan,

    -- * Utilities
    inhibitTypeToString,
    inhibitTypesFromStrings,
  )
where

import Control.Concurrent
import Control.Concurrent.STM.TChan
import Control.Monad.IO.Class
import Control.Monad.STM (atomically)
import Control.Monad.Trans.Reader
import DBus
import DBus.Client
import Data.List (intercalate)
import qualified Data.Text as T
import System.Log.Logger
import System.Posix.IO (closeFd)
import System.Posix.Types (Fd)
import System.Taffybar.Context

-- | Types of inhibitors supported by systemd-logind
data InhibitType
  = InhibitIdle
  | InhibitShutdown
  | InhibitSleep
  | InhibitHandlePowerKey
  | InhibitHandleSuspendKey
  | InhibitHandleHibernateKey
  | InhibitHandleLidSwitch
  deriving (Eq, Show, Ord, Enum, Bounded)

-- | Current state of the inhibitor
data InhibitorState = InhibitorState
  { inhibitorActive :: Bool,
    inhibitorTypes :: [InhibitType]
  }
  deriving (Eq, Show)

-- | Context for managing an inhibitor, stored in taffybar's state
data InhibitorContext = InhibitorContext
  { inhibitorChan :: TChan InhibitorState,
    inhibitorStateVar :: MVar InhibitorState,
    inhibitorFdVar :: MVar (Maybe Fd),
    inhibitorConfig :: [InhibitType]
  }

inhibitorLogPath :: String
inhibitorLogPath = "System.Taffybar.Information.Inhibitor"

inhibitorLog :: (MonadIO m) => Priority -> String -> m ()
inhibitorLog priority = liftIO . logM inhibitorLogPath priority

-- | Convert an InhibitType to its string representation for DBus
inhibitTypeToString :: InhibitType -> String
inhibitTypeToString InhibitIdle = "idle"
inhibitTypeToString InhibitShutdown = "shutdown"
inhibitTypeToString InhibitSleep = "sleep"
inhibitTypeToString InhibitHandlePowerKey = "handle-power-key"
inhibitTypeToString InhibitHandleSuspendKey = "handle-suspend-key"
inhibitTypeToString InhibitHandleHibernateKey = "handle-hibernate-key"
inhibitTypeToString InhibitHandleLidSwitch = "handle-lid-switch"

-- | Parse a string to an InhibitType
inhibitTypeFromString :: String -> Maybe InhibitType
inhibitTypeFromString "idle" = Just InhibitIdle
inhibitTypeFromString "shutdown" = Just InhibitShutdown
inhibitTypeFromString "sleep" = Just InhibitSleep
inhibitTypeFromString "handle-power-key" = Just InhibitHandlePowerKey
inhibitTypeFromString "handle-suspend-key" = Just InhibitHandleSuspendKey
inhibitTypeFromString "handle-hibernate-key" = Just InhibitHandleHibernateKey
inhibitTypeFromString "handle-lid-switch" = Just InhibitHandleLidSwitch
inhibitTypeFromString _ = Nothing

-- | Parse a list of strings to InhibitTypes, ignoring invalid ones
inhibitTypesFromStrings :: [String] -> [InhibitType]
inhibitTypesFromStrings = foldr go []
  where
    go s acc = case inhibitTypeFromString s of
      Just t -> t : acc
      Nothing -> acc

-- | Convert a list of InhibitTypes to the colon-separated format for DBus
inhibitTypesToDBusString :: [InhibitType] -> String
inhibitTypesToDBusString = intercalate ":" . map inhibitTypeToString

-- | The DBus destination for systemd-logind
login1BusName :: BusName
login1BusName = "org.freedesktop.login1"

-- | The DBus object path for the login1 manager
login1ObjectPath :: ObjectPath
login1ObjectPath = "/org/freedesktop/login1"

-- | The DBus interface for the login1 manager
login1Interface :: InterfaceName
login1Interface = "org.freedesktop.login1.Manager"

-- | Acquire an inhibitor lock via DBus
-- The Inhibit method takes (what, who, why, mode) and returns a file descriptor
acquireInhibitor :: Client -> [InhibitType] -> IO (Either MethodError Fd)
acquireInhibitor client types = do
  let what = inhibitTypesToDBusString types
      who = "taffybar"
      why = "User requested inhibition"
      mode = "block" :: String
  inhibitorLog DEBUG $ "Acquiring inhibitor for: " ++ what
  reply <-
    call
      client
      (methodCall login1ObjectPath login1Interface "Inhibit")
        { methodCallDestination = Just login1BusName,
          methodCallBody =
            [ toVariant (T.pack what),
              toVariant (T.pack who),
              toVariant (T.pack why),
              toVariant (T.pack mode)
            ]
        }
  case reply of
    Left err -> do
      inhibitorLog WARNING $ "Failed to acquire inhibitor: " ++ show err
      return $ Left err
    Right ret -> do
      case methodReturnBody ret of
        [v] -> case fromVariant v :: Maybe Fd of
          Just fd -> do
            inhibitorLog DEBUG $ "Acquired inhibitor fd: " ++ show fd
            return $ Right fd
          Nothing -> do
            inhibitorLog WARNING "Invalid fd type in response"
            return $
              Left $
                methodError (methodReturnSerial ret) $
                  errorName_ "org.taffybar.InvalidResponse"
        _ -> do
          inhibitorLog WARNING "Unexpected response format"
          return $
            Left $
              methodError (methodReturnSerial ret) $
                errorName_ "org.taffybar.InvalidResponse"

-- | Release an inhibitor by closing its file descriptor
releaseInhibitor :: Fd -> IO ()
releaseInhibitor fd = do
  inhibitorLog DEBUG $ "Releasing inhibitor fd: " ++ show fd
  closeFd fd

-- | Get or create the InhibitorContext for the given inhibit types
getInhibitorContext :: [InhibitType] -> TaffyIO InhibitorContext
getInhibitorContext types = getStateDefault $ do
  inhibitorLog DEBUG "Initializing InhibitorContext"
  chan <- liftIO newBroadcastTChanIO
  stateVar <-
    liftIO $
      newMVar
        InhibitorState
          { inhibitorActive = False,
            inhibitorTypes = types
          }
  fdVar <- liftIO $ newMVar Nothing
  return
    InhibitorContext
      { inhibitorChan = chan,
        inhibitorStateVar = stateVar,
        inhibitorFdVar = fdVar,
        inhibitorConfig = types
      }

-- | Get the current inhibitor state
getInhibitorState :: [InhibitType] -> TaffyIO InhibitorState
getInhibitorState types = do
  ctx <- getInhibitorContext types
  liftIO $ readMVar (inhibitorStateVar ctx)

-- | Get the broadcast channel for inhibitor state changes
getInhibitorChan :: [InhibitType] -> TaffyIO (TChan InhibitorState)
getInhibitorChan types = do
  ctx <- getInhibitorContext types
  return $ inhibitorChan ctx

-- | Toggle the inhibitor on or off
toggleInhibitor :: [InhibitType] -> TaffyIO ()
toggleInhibitor types = do
  ctx <- getInhibitorContext types
  client <- asks systemDBusClient
  liftIO $ modifyMVar_ (inhibitorFdVar ctx) $ \maybeFd -> do
    case maybeFd of
      Just fd -> do
        -- Currently active, release it
        releaseInhibitor fd
        let newState =
              InhibitorState
                { inhibitorActive = False,
                  inhibitorTypes = types
                }
        _ <- swapMVar (inhibitorStateVar ctx) newState
        atomically $ writeTChan (inhibitorChan ctx) newState
        inhibitorLog DEBUG "Inhibitor deactivated"
        return Nothing
      Nothing -> do
        -- Currently inactive, acquire it
        result <- acquireInhibitor client types
        case result of
          Right fd -> do
            let newState =
                  InhibitorState
                    { inhibitorActive = True,
                      inhibitorTypes = types
                    }
            _ <- swapMVar (inhibitorStateVar ctx) newState
            atomically $ writeTChan (inhibitorChan ctx) newState
            inhibitorLog DEBUG "Inhibitor activated"
            return (Just fd)
          Left _ -> do
            inhibitorLog WARNING "Failed to acquire inhibitor"
            return Nothing