ENH make screensaver commands respond to events

This commit is contained in:
Nathan Dwarshuis 2020-03-20 20:10:15 -04:00
parent 3f5d3b8d8b
commit 6ae7ca5df1
8 changed files with 168 additions and 36 deletions

View File

@ -119,7 +119,7 @@ config confDir = defaultConfig
, Run $ Date "%Y-%m-%d %H:%M" "date" 10 , Run $ Date "%Y-%m-%d %H:%M" "date" 10
, Run $ Screensaver ("<fn=1>\xf254</fn>", T.fgColor, T.fgColor) 10 , Run $ Screensaver ("<fn=1>\xf254</fn>", T.fgColor, T.backdropFgColor)
, Run UnsafeStdinReader , Run UnsafeStdinReader
] ]

View File

@ -11,6 +11,7 @@ import Shell
import DBus.Common import DBus.Common
import DBus.IntelBacklight import DBus.IntelBacklight
import DBus.Screensaver
import qualified Theme as T import qualified Theme as T
@ -536,11 +537,8 @@ runMaxBacklight = io $ void callMaxBrightness
showWorkspace :: WorkspaceId -> X () showWorkspace :: WorkspaceId -> X ()
showWorkspace tag = windows $ W.view tag showWorkspace tag = windows $ W.view tag
enableDPMS :: X () toggleDPMS :: X ()
enableDPMS = spawnCmd "xset" ["s", "on", "+dpms"] toggleDPMS = io $ void callToggle
disableDPMS :: X ()
disableDPMS = spawnCmd "xset" ["s", "off", "-dpms"]
-- keybindings -- keybindings
@ -658,8 +656,7 @@ myKeys hs client c =
, ("M-,", addName "backlight down" runDecBacklight) , ("M-,", addName "backlight down" runDecBacklight)
, ("M-M1-,", addName "backlight min" runMinBacklight) , ("M-M1-,", addName "backlight min" runMinBacklight)
, ("M-M1-.", addName "backlight max" runMaxBacklight) , ("M-M1-.", addName "backlight max" runMaxBacklight)
, ("M-M1-=", addName "enable screensaver" enableDPMS) , ("M-M1-=", addName "toggle screensaver" toggleDPMS)
, ("M-M1--", addName "disable screensaver" disableDPMS)
, ("M-<F2>", addName "restart xmonad" $ runCleanup hs client >> runRestart) , ("M-<F2>", addName "restart xmonad" $ runCleanup hs client >> runRestart)
, ("M-S-<F2>", addName "recompile xmonad" runRecompile) , ("M-S-<F2>", addName "recompile xmonad" runRecompile)
, ("M-<End>", addName "power menu" myPowerPrompt) , ("M-<End>", addName "power menu" myPowerPrompt)

View File

@ -3,6 +3,7 @@
module DBus.Common where module DBus.Common where
import DBus.IntelBacklight import DBus.IntelBacklight
import DBus.Screensaver
import DBus.Client import DBus.Client
@ -17,6 +18,7 @@ startXMonadService = do
else do else do
putStrLn "Started xmonad dbus client" putStrLn "Started xmonad dbus client"
exportIntelBacklight client exportIntelBacklight client
exportScreensaver client
return client return client
stopXMonadService :: Client -> IO () stopXMonadService :: Client -> IO ()

View File

@ -1,4 +1,3 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -208,8 +207,4 @@ callGetBrightness = do
matchSignal :: (Maybe Brightness -> IO ()) -> IO SignalHandler matchSignal :: (Maybe Brightness -> IO ()) -> IO SignalHandler
matchSignal cb = do matchSignal cb = do
client <- connectSession client <- connectSession
addMatch client brMatcher $ cb . pullBrightness . signalBody addMatch client brMatcher $ cb . signalBrightness . signalBody
where
pullBrightness = \case
[b] -> fromVariant b :: Maybe Brightness
_ -> Nothing

37
lib/DBus/Internal.hs Normal file
View File

@ -0,0 +1,37 @@
{-# LANGUAGE OverloadedStrings #-}
module DBus.Internal where
import Control.Monad (forM_)
import DBus
import DBus.Client
callMethod' :: Client -> MethodCall -> IO (Maybe [Variant])
callMethod' client mc = do
-- TODO handle clienterrors here
reply <- call client mc { methodCallDestination = Just "org.xmonad" }
return $ case reply of
Left _ -> Nothing
Right ret -> Just $ methodReturnBody ret
callMethod :: MethodCall -> ([Variant] -> Maybe a) -> IO (Maybe a)
callMethod mc procBody = do
client <- connectSession
body <- callMethod' client mc
return $ body >>= procBody
callMethodEmit :: MethodCall
-> ([Variant] -> Maybe a)
-> ([Variant] -> Signal)
-> IO (Maybe a)
callMethodEmit mc procBody bodyToSignal = do
client <- connectSession
body <- callMethod' client mc
forM_ body $ emit client . bodyToSignal
return $ body >>= procBody
addMatchCallback :: MatchRule -> ([Variant] -> IO ()) -> IO SignalHandler
addMatchCallback rule cb = do
client <- connectSession
addMatch client rule $ cb . signalBody

104
lib/DBus/Screensaver.hs Normal file
View File

@ -0,0 +1,104 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- | DBus module for X11 screensave/DPMS control
module DBus.Screensaver where
import DBus
import DBus.Client
import DBus.Internal
import Graphics.X11.Xlib.Display
import Graphics.X11.XScreenSaver
import Shell
import XMonad
--------------------------------------------------------------------------------
-- | Low-level functions
type SSState = Bool -- true is enabled
toggle :: IO SSState
toggle = do
st <- query
-- TODO figure out how not to do this with shell commands
spawn $ fmtCmd "xset" $ "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
print xssi
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 two methods to enable/disable the screensaver. These methods will
-- emit signals with the state when called. Define another method to get the
-- current state.
ssPath :: ObjectPath
ssPath = "/screensaver"
ssInterface :: InterfaceName
ssInterface = "org.xmonad.Screensaver"
ssState :: MemberName
ssState = "State"
ssToggle :: MemberName
ssToggle = "Toggle"
ssQuery :: MemberName
ssQuery = "Query"
ssSignal :: Signal
ssSignal = signal ssPath ssInterface ssState
ssMatcher :: MatchRule
ssMatcher = matchAny
{ matchPath = Just ssPath
, matchInterface = Just ssInterface
, matchMember = Just ssState
}
exportScreensaver :: Client -> IO ()
exportScreensaver client =
export client ssPath defaultInterface
{ interfaceName = ssInterface
, interfaceMethods =
[ autoMethod ssToggle toggle
, autoMethod ssQuery query
]
}
callToggle :: IO (Maybe SSState)
callToggle = callMethodEmit mc bodyState sig
where
mc = methodCall ssPath ssInterface ssToggle
sig b = ssSignal { signalBody = b }
bodyState :: [Variant] -> Maybe SSState
bodyState [b] = fromVariant b :: Maybe SSState
bodyState _ = Nothing
callQuery :: IO (Maybe SSState)
callQuery = callMethod mc bodyState
where
mc = methodCall ssPath ssInterface ssQuery
matchSignal :: (Maybe SSState -> IO ()) -> IO SignalHandler
matchSignal cb = addMatchCallback ssMatcher $ cb . bodyState

View File

@ -1,31 +1,26 @@
{-# LANGUAGE LambdaCase #-}
module Xmobar.Plugins.Screensaver where module Xmobar.Plugins.Screensaver where
import Graphics.X11.Xlib.Display import Control.Concurrent
import Graphics.X11.XScreenSaver import Control.Monad
import DBus.Screensaver
import Xmobar import Xmobar
data Screensaver = Screensaver (String, String, String) Int data Screensaver = Screensaver (String, String, String)
deriving (Read, Show) deriving (Read, Show)
instance Exec Screensaver where instance Exec Screensaver where
alias (Screensaver _ _) = "screensaver" alias (Screensaver _) = "screensaver"
run (Screensaver opts _) = run' opts start (Screensaver (text, colorOn, colorOff)) cb = do
rate (Screensaver _ r) = r _ <- matchSignal $ cb . fmtState
cb . fmtState =<< callQuery
-- TODO make this respond to events rather than polling forever (threadDelay 5000)
run' :: (String, String, String) -> IO String
run' (text, colorOn, colorOff) = do
dpy <- openDisplay ""
xssi <- xScreenSaverQueryInfo dpy
closeDisplay dpy
return $ case xssi of
Just x -> wrapColor text
$ case xssi_state x of
ScreenSaverDisabled -> colorOff
_ -> colorOn
Nothing -> "N/A"
where where
-- TODO not DRY fmtState = \case
Just s -> wrapColor text $ if s then colorOn else colorOff
Nothing -> "N/A"
wrapColor s c = "<fc=" ++ c ++ ">" ++ s ++ "</fc>" wrapColor s c = "<fc=" ++ c ++ ">" ++ s ++ "</fc>"

View File

@ -12,6 +12,8 @@ library
, Shell , Shell
, DBus.Common , DBus.Common
, DBus.IntelBacklight , DBus.IntelBacklight
, DBus.Internal
, DBus.Screensaver
, Xmobar.Plugins.Screensaver , Xmobar.Plugins.Screensaver
, Xmobar.Plugins.IntelBacklight , Xmobar.Plugins.IntelBacklight
build-depends: base build-depends: base