ENH make screensaver commands respond to events

bin/xmobar.hs

@@ -119,7 +119,7 @@ config confDir = defaultConfig
 
       , 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
       ]

bin/xmonad.hs

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

lib/DBus/Common.hs

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

lib/DBus/IntelBacklight.hs

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

lib/DBus/Internal.hs

@@ -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

lib/DBus/Screensaver.hs

@@ -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

lib/Xmobar/Plugins/Screensaver.hs

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

my-xmonad.cabal

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