148 lines
4.3 KiB
Haskell
148 lines
4.3 KiB
Haskell
--------------------------------------------------------------------------------
|
|
-- | DBus module for X11 screensave/DPMS control
|
|
|
|
module XMonad.Internal.DBus.Screensaver
|
|
( exportScreensaver
|
|
, callToggle
|
|
, callQuery
|
|
, matchSignal
|
|
, ssSignalDep
|
|
) where
|
|
|
|
import Control.Monad (void)
|
|
|
|
import DBus
|
|
import DBus.Client
|
|
import qualified DBus.Introspection as I
|
|
|
|
import Graphics.X11.XScreenSaver
|
|
import Graphics.X11.Xlib.Display
|
|
|
|
import XMonad.Internal.DBus.Common
|
|
import XMonad.Internal.Dependency
|
|
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
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Exported haskell API
|
|
|
|
exportScreensaver :: Maybe Client -> FeatureIO
|
|
exportScreensaver client = Feature
|
|
{ ftrMaybeAction = DBusBus_ cmd xmonadBusName client [Executable ssExecutable]
|
|
, ftrName = "screensaver interface"
|
|
, ftrWarning = Default
|
|
}
|
|
where
|
|
cmd cl = export cl ssPath defaultInterface
|
|
{ interfaceName = interface
|
|
, interfaceMethods =
|
|
[ autoMethod memToggle $ emitState cl =<< toggle
|
|
, autoMethod memQuery query
|
|
]
|
|
, interfaceSignals = [sig]
|
|
}
|
|
sig = I.Signal
|
|
{ I.signalName = memState
|
|
, I.signalArgs =
|
|
[
|
|
I.SignalArg
|
|
{ I.signalArgName = "enabled"
|
|
, I.signalArgType = TypeBoolean
|
|
}
|
|
]
|
|
}
|
|
|
|
callToggle :: Maybe Client -> FeatureIO
|
|
callToggle client =
|
|
(featureEndpoint xmonadBusName ssPath interface memToggle client)
|
|
{ ftrName = "screensaver toggle" }
|
|
-- callToggle client = Feature
|
|
-- { ftrMaybeAction = cmd
|
|
-- , ftrName = "screensaver toggle"
|
|
-- , ftrWarning = Default
|
|
-- , ftrChildren = [xDbusDep ssPath interface $ Method_ memToggle]
|
|
-- }
|
|
-- where
|
|
-- cmd = void $ callMethod client xmonadBusName ssPath interface memToggle
|
|
|
|
callQuery :: Client -> IO (Maybe SSState)
|
|
callQuery client = do
|
|
reply <- callMethod client xmonadBusName ssPath interface memQuery
|
|
return $ either (const Nothing) bodyGetCurrentState reply
|
|
|
|
matchSignal :: (Maybe SSState -> IO ()) -> IO SignalHandler
|
|
matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
|
|
|
|
-- ssSignalDep :: Dependency
|
|
ssSignalDep :: Endpoint
|
|
-- ssSignalDep = DBusEndpoint xmonadBus $ Endpoint ssPath interface
|
|
-- $ Signal_ memState
|
|
ssSignalDep = Endpoint ssPath interface $ Signal_ memState
|