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

165 lines
4.5 KiB
Haskell
Raw Normal View History

2023-01-03 22:18:55 -05:00
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- DBus module for X11 screensave/DPMS control
2020-04-01 20:17:47 -04:00
module XMonad.Internal.DBus.Screensaver
( exportScreensaver
, callToggle
, callQuery
, matchSignal
, ssSignalDep
2022-12-30 14:58:23 -05:00
)
where
import DBus
import DBus.Client
import qualified DBus.Introspection as I
import Data.Internal.DBus
2023-01-01 18:33:02 -05:00
import Data.Internal.XIO
2022-12-30 14:58:23 -05:00
import Graphics.X11.XScreenSaver
import RIO
import XMonad.Internal.DBus.Common
2022-12-31 20:19:09 -05:00
import XMonad.Internal.IO
2022-12-30 14:58:23 -05:00
import XMonad.Internal.Shell
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Low-level functions
type SSState = Bool -- true is enabled
2022-12-29 00:06:55 -05:00
ssExecutable :: FilePath
ssExecutable = "xset"
2022-12-31 20:19:09 -05:00
toggle :: MonadUnliftIO m => m SSState
toggle = do
st <- query
2022-12-29 00:06:55 -05:00
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)
2022-12-29 00:06:55 -05:00
return $ if rc == ExitSuccess then not st else st
2022-12-31 20:19:09 -05:00
query :: MonadUnliftIO m => m SSState
query = do
2022-12-31 20:19:09 -05:00
xssi <- withOpenDisplay (liftIO . xScreenSaverQueryInfo)
return $ case xssi of
2022-12-30 14:58:23 -05:00
Just XScreenSaverInfo {xssi_state = ScreenSaverDisabled} -> False
Just XScreenSaverInfo {xssi_state = _} -> True
-- TODO handle errors better (at least log them?)
2022-12-30 14:58:23 -05:00
Nothing -> False
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- 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
2022-12-30 14:58:23 -05:00
ruleCurrentState =
matchAny
{ matchPath = Just ssPath
, matchInterface = Just interface
, matchMember = Just memState
}
2022-12-31 20:23:27 -05:00
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
2022-12-30 14:58:23 -05:00
bodyGetCurrentState _ = Nothing
2020-04-01 20:17:47 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Exported haskell API
2023-01-01 13:07:10 -05:00
exportScreensaver
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Maybe SesClient
-> Sometimes (m (), m ())
2022-07-09 17:08:10 -04:00
exportScreensaver ses =
2023-01-01 13:26:09 -05:00
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
2021-11-11 00:11:15 -05:00
where
2023-01-01 13:26:09 -05:00
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]
}
2022-12-30 14:58:23 -05:00
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
2021-11-11 00:11:15 -05:00
2023-01-03 22:18:55 -05:00
callToggle
:: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
=> Maybe SesClient
-> Sometimes (m ())
2022-12-30 14:58:23 -05:00
callToggle =
sometimesEndpoint
"screensaver toggle"
"dbus switch"
[]
xmonadBusName
ssPath
interface
memToggle
2023-01-03 22:18:55 -05:00
callQuery
:: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m)
=> m (Maybe SSState)
callQuery = do
reply <- callMethod xmonadBusName ssPath interface memQuery
2021-11-21 16:58:01 -05:00
return $ either (const Nothing) bodyGetCurrentState reply
2023-01-03 22:18:55 -05:00
matchSignal
:: ( HasLogFunc (env SesClient)
, HasClient env
, MonadReader (env SesClient) m
, MonadUnliftIO m
)
=> (Maybe SSState -> m ())
-> m ()
matchSignal cb =
2022-12-30 14:58:23 -05:00
void $
addMatchCallback
ruleCurrentState
(cb . bodyGetCurrentState)
2021-11-21 00:53:45 -05:00
2022-07-09 17:08:10 -04:00
ssSignalDep :: DBusDependency_ SesClient
ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState