153 lines
4.2 KiB
Haskell
153 lines
4.2 KiB
Haskell
{-# 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.Dependency
|
|
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 :: Maybe SesClient -> SometimesIO
|
|
exportScreensaver ses =
|
|
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
|
|
where
|
|
cmd cl =
|
|
let cl' = toClient cl
|
|
in withRunInIO $ \run ->
|
|
export
|
|
cl'
|
|
ssPath
|
|
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 :: Maybe SesClient -> SometimesX
|
|
callToggle =
|
|
sometimesEndpoint
|
|
"screensaver toggle"
|
|
"dbus switch"
|
|
[]
|
|
xmonadBusName
|
|
ssPath
|
|
interface
|
|
memToggle
|
|
|
|
callQuery :: MonadUnliftIO m => SesClient -> m (Maybe SSState)
|
|
callQuery ses = do
|
|
reply <- callMethod ses xmonadBusName ssPath interface memQuery
|
|
return $ either (const Nothing) bodyGetCurrentState reply
|
|
|
|
matchSignal :: MonadUnliftIO m => (Maybe SSState -> m ()) -> SesClient -> m ()
|
|
matchSignal cb ses =
|
|
void $
|
|
addMatchCallback
|
|
ruleCurrentState
|
|
(cb . bodyGetCurrentState)
|
|
ses
|
|
|
|
ssSignalDep :: DBusDependency_ SesClient
|
|
ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState
|