ENH make screensaver commands respond to events
This commit is contained in:
parent
3f5d3b8d8b
commit
6ae7ca5df1
|
@ -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
|
||||||
]
|
]
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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 ()
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
|
@ -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
|
|
@ -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
|
|
@ -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>"
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue