xmonad-config/lib/XMonad/Internal/DBus/Screensaver.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

--------------------------------------------------------------------------------
-- DBus module for X11 screensave/DPMS control

module XMonad.Internal.DBus.Screensaver
  ( exportScreensaver
  , callToggle
  , callQuery
  , matchSignal
  , ssSignalDep
  )
where

import DBus
import DBus.Client
import qualified DBus.Introspection as I
import Data.Internal.DBus
import Data.Internal.XIO
import Graphics.X11.XScreenSaver
import RIO
import XMonad.Internal.DBus.Common
import XMonad.Internal.IO
import XMonad.Internal.Shell

--------------------------------------------------------------------------------
-- Low-level functions

type SSState = Bool -- true is enabled

ssExecutable :: FilePath
ssExecutable = "xset"

toggle :: MonadUnliftIO m => m SSState
toggle = do
  st <- query
  let args = if st then ["off", "-dpms"] else ["on", "+dpms"]
  -- this needs to be done with shell commands, because as far as I know there
  -- are no Haskell bindings for DPMSDisable/Enable (from libxext)
  rc <- runProcess (proc ssExecutable $ "s" : args)
  return $ if rc == ExitSuccess then not st else st

query :: MonadUnliftIO m => m SSState
query = do
  xssi <- withOpenDisplay (liftIO . xScreenSaverQueryInfo)
  return $ case xssi of
    Just XScreenSaverInfo {xssi_state = ScreenSaverDisabled} -> False
    Just XScreenSaverInfo {xssi_state = _} -> True
    -- TODO handle errors better (at least log them?)
    Nothing -> False

--------------------------------------------------------------------------------
-- DBus Interface
--
-- Define a methods to toggle the screensaver. This methods will emit signal
-- with the new state when called. Define another method to get the current
-- state.

ssPath :: ObjectPath
ssPath = objectPath_ "/screensaver"

interface :: InterfaceName
interface = interfaceName_ "org.xmonad.Screensaver"

memState :: MemberName
memState = memberName_ "State"

memToggle :: MemberName
memToggle = memberName_ "Toggle"

memQuery :: MemberName
memQuery = memberName_ "Query"

sigCurrentState :: Signal
sigCurrentState = signal ssPath interface memState

ruleCurrentState :: MatchRule
ruleCurrentState =
  matchAny
    { matchPath = Just ssPath
    , matchInterface = Just interface
    , matchMember = Just memState
    }

emitState :: MonadUnliftIO m => Client -> SSState -> m ()
emitState client sss =
  liftIO $ emit client $ sigCurrentState {signalBody = [toVariant sss]}

bodyGetCurrentState :: [Variant] -> Maybe SSState
bodyGetCurrentState [b] = fromVariant b :: Maybe SSState
bodyGetCurrentState _ = Nothing

--------------------------------------------------------------------------------
-- Exported haskell API

exportScreensaver
  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
  => Maybe SesClient
  -> Sometimes (m (), m ())
exportScreensaver ses =
  sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
  where
    cmd = exportPair ssPath $ \cl_ -> do
      liftIO $ withRunInIO $ \run ->
        return $
          defaultInterface
            { interfaceName = interface
            , interfaceMethods =
                [ autoMethod memToggle $ run $ emitState cl_ =<< toggle
                , autoMethod memQuery (run query)
                ]
            , interfaceSignals = [sig]
            }
    sig =
      I.Signal
        { I.signalName = memState
        , I.signalArgs =
            [ I.SignalArg
                { I.signalArgName = "enabled"
                , I.signalArgType = TypeBoolean
                }
            ]
        }
    bus = Bus [] xmonadBusName
    ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable

callToggle
  :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
  => Maybe SesClient
  -> Sometimes (m ())
callToggle =
  sometimesEndpoint
    "screensaver toggle"
    "dbus switch"
    []
    xmonadBusName
    ssPath
    interface
    memToggle

callQuery
  :: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m)
  => m (Maybe SSState)
callQuery = do
  reply <- callMethod xmonadBusName ssPath interface memQuery
  return $ either (const Nothing) bodyGetCurrentState reply

matchSignal
  :: ( HasLogFunc (env SesClient)
     , HasClient env
     , MonadReader (env SesClient) m
     , MonadUnliftIO m
     )
  => (Maybe SSState -> m ())
  -> m ()
matchSignal cb =
  void $
    addMatchCallback
      ruleCurrentState
      (cb . bodyGetCurrentState)

ssSignalDep :: DBusDependency_ SesClient
ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState