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

139 lines
4.0 KiB
Haskell
Raw Normal View History

--------------------------------------------------------------------------------
-- | 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
) where
2021-11-11 00:11:15 -05:00
import Control.Monad (void)
2022-07-09 17:44:14 -04:00
import Data.Internal.DBus
import Data.Internal.Dependency
2020-03-25 18:35:04 -04:00
import DBus
import DBus.Client
import qualified DBus.Introspection as I
2020-03-25 18:35:04 -04:00
import Graphics.X11.XScreenSaver
2021-06-19 00:54:01 -04:00
import Graphics.X11.Xlib.Display
2020-04-01 20:17:47 -04:00
import XMonad.Internal.DBus.Common
import XMonad.Internal.Process
--------------------------------------------------------------------------------
-- | Low-level functions
type SSState = Bool -- true is enabled
ssExecutable :: String
ssExecutable = "xset"
toggle :: IO SSState
toggle = do
st <- query
-- TODO figure out how not to do this with shell commands
void $ createProcess' $ proc ssExecutable $ "s" : args st
-- TODO this assumes the command succeeds
return $ not st
where
args s = if s then ["off", "-dpms"] else ["on", "+dpms"]
query :: IO SSState
query = do
dpy <- openDisplay ""
xssi <- xScreenSaverQueryInfo dpy
closeDisplay dpy
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 :: Client -> SSState -> IO ()
emitState client sss = emit client $ sigCurrentState { signalBody = [toVariant sss] }
bodyGetCurrentState :: [Variant] -> Maybe SSState
bodyGetCurrentState [b] = fromVariant b :: Maybe SSState
bodyGetCurrentState _ = Nothing
2020-04-01 20:17:47 -04:00
--------------------------------------------------------------------------------
-- | Exported haskell API
2022-07-09 17:08:10 -04:00
exportScreensaver :: Maybe SesClient -> SometimesIO
exportScreensaver ses =
sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
2021-11-11 00:11:15 -05:00
where
2022-07-09 17:08:10 -04:00
cmd cl = let cl' = toClient cl in
export cl' ssPath defaultInterface
2021-11-11 00:11:15 -05:00
{ interfaceName = interface
, interfaceMethods =
2022-07-09 17:08:10 -04:00
[ autoMethod memToggle $ emitState cl' =<< toggle
2021-11-11 00:11:15 -05:00
, autoMethod memQuery query
]
, interfaceSignals = [sig]
}
sig = I.Signal
{ I.signalName = memState
, I.signalArgs =
[
I.SignalArg
{ I.signalArgName = "enabled"
, I.signalArgType = TypeBoolean
}
]
2021-11-11 00:11:15 -05:00
}
bus = Bus [] xmonadBusName
ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
2021-11-11 00:11:15 -05:00
2022-07-09 17:08:10 -04:00
callToggle :: Maybe SesClient -> SometimesIO
callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" []
xmonadBusName ssPath interface memToggle
2022-07-09 17:44:14 -04:00
callQuery :: SesClient -> IO (Maybe SSState)
callQuery ses = do
reply <- callMethod ses xmonadBusName ssPath interface memQuery
2021-11-21 16:58:01 -05:00
return $ either (const Nothing) bodyGetCurrentState reply
2022-07-09 17:08:10 -04:00
matchSignal :: (Maybe SSState -> IO ()) -> SesClient -> IO ()
matchSignal cb ses = void $ addMatchCallback ruleCurrentState
2022-07-09 17:44:14 -04:00
(cb . bodyGetCurrentState) ses
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