Record screen saver/locker status (X11)

Tracking inactivity via idle time is unsuitable if one wants to account
for activities such as watching movies or reading difficult texts.
As media players usually keep the screen saver/locker from triggering,
tracking inactivity that way might be more accurate, as long as the
screen saver trigger is set to low enough duration or the user
diligently locks their screen when walking away.

Currently implemented for X11 only, and even that implementation
supports only a few desktop environments.

Relates: nomeata#39

arbtt.cabal

@@ -93,7 +93,8 @@ executable arbtt-capture
                 Capture.X11
                 System.Locale.SetLocale
             build-depends:
-                X11 >= 1.9
+                X11 >= 1.9,
+                dbus >= 1.0
     default-language: Haskell98
 
 executable arbtt-stats

src/Capture/OSX.hs

@@ -20,5 +20,6 @@ captureData = do
                       | (h, t, p) <- titles]
 
         it <- fromIntegral `fmap` getIdleTime
+        -- TODO: screen saver/locker
 
-        return $ CaptureData winData it (T.pack "")
+        return $ CaptureData winData it (T.pack "") False

src/Capture/Win32.hs

@@ -24,5 +24,6 @@ captureData = do
                       | (h, t, p) <- titles]
 
         it <- fromIntegral `fmap` getIdleTime
+        -- TODO: screen saver/locker
 
-        return $ CaptureData winData it (T.pack "")
+        return $ CaptureData winData it (T.pack "") False

src/Capture/X11.hs

@@ -1,20 +1,24 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 module Capture.X11 where
 
 import Data
 import Graphics.X11
 import Graphics.X11.Xlib.Extras
 import Control.Monad
-import Control.Exception (bracket)
+import Control.Exception (catch, bracket)
 import System.IO.Error (catchIOError)
 import Control.Applicative
+import Data.Either
 import Data.Maybe
 import Data.Time.Clock
 import System.IO
 import qualified Data.MyText as T
 
 import System.Locale.SetLocale
-import Graphics.X11.XScreenSaver (getXIdleTime, compiledWithXScreenSaver)
+import Graphics.X11.XScreenSaver
+import qualified DBus as D
+import qualified DBus.Client as D
 
 setupCapture :: IO ()
 setupCapture = do
@@ -59,9 +63,11 @@ captureData = do
             return WindowData{..}
 
         it <- fromIntegral `fmap` getXIdleTime dpy
+        ss <- isScreenSaverActive dpy
+        sl <- isSessionLocked
 
         closeDisplay dpy
-        return $ CaptureData winData it (T.pack current_desktop)
+        return $ CaptureData winData it (T.pack current_desktop) (ss || sl)
 
 getWindowTitle :: Display -> Window -> IO String
 getWindowTitle dpy =  myFetchName dpy
@@ -138,3 +144,37 @@ isHidden dpy w = flip catchIOError (\_ -> return False) $ do
     a <- internAtom dpy "WM_STATE" False
     Just (state:_) <- getWindowProperty32 dpy a w
     return $ fromIntegral state /= normalState
+
+-- | Check active screen saver using the X11 Screen Saver extension.
+--
+-- This most likely only works with the simple built-in screen saver
+-- configured using @xset s@. Screen savers/lockers such as xscreensaver,
+-- xsecurelock, i3lock, etc. work differently.
+isScreenSaverActive :: Display -> IO Bool
+isScreenSaverActive dpy = do
+    info <- xScreenSaverQueryInfo dpy
+    return $ case info of
+        Just XScreenSaverInfo{xssi_state = ScreenSaverOn} -> True
+        _ -> False
+
+-- TODO: https://unix.stackexchange.com/questions/197032/detect-if-screensaver-is-active
+
+-- | Check whether the current systemd-logind session is marked as locked.
+--
+-- Note that many minimalist screen savers/lockers do not communicate with
+-- systemd-logind, so this often doesn't work either.
+--
+-- TODO: describe this better
+-- dbus-send --system --print-reply --dest=org.freedesktop.login1 /org/freedesktop/login1/session/self "org.freedesktop.login1.Session.SetLockedHint" boolean:false
+isSessionLocked :: IO Bool
+isSessionLocked = bracket D.connectSystem D.disconnect getLockedHint
+    `catch` (return . const False . D.clientErrorMessage)
+  where
+    dest = "org.freedesktop.login1"
+    -- …/session/auto is the caller's own session if they have one,
+    -- otherwise their user's display session
+    object = "/org/freedesktop/login1/session/auto"
+    interface = "org.freedesktop.login1.Session"
+    property = "LockedHint"
+    methodCall = (D.methodCall object interface property){ D.methodCallDestination = Just dest }
+    getLockedHint c = fmap (fromRight False) $ D.getPropertyValue c methodCall

src/Data.hs

@@ -35,6 +35,7 @@ data CaptureData = CaptureData
         , cLastActivity :: Integer -- ^ in milli-seconds
         , cDesktop :: Text
                 -- ^ Current desktop name
+        , cScreenSaver :: Bool -- ^ Screen saver or locker active?
         }
   deriving (Show, Read, Generic, NFData)
 
@@ -118,19 +119,22 @@ instance StringReferencingBinary CaptureData where
 -- 2 Using ListOfStringable
 -- 3 Add cDesktop
 -- 4 WindowData instead of 3-tuple; CompactNum
+-- 5 Add cScreenSaver
  ls_put strs cd = do
         -- A version tag
         putWord8 5
         ls_put strs (cWindows cd)
         ls_put strs (cLastActivity cd)
         ls_put strs (cDesktop cd)
+        ls_put strs (cScreenSaver cd)
  ls_get strs = do
         v <- getWord8
         case v of
-         1 -> CaptureData <$> (map fromWDv0 . fromIntLenW <$> get) <*> get <*> pure ""
-         2 -> CaptureData <$> (map fromWDv0 . fromIntLenW <$> ls_get strs) <*> ls_get strs <*> pure ""
-         3 -> CaptureData <$> (map fromWDv0 . fromIntLenW <$> ls_get strs) <*> ls_get strs <*> (fromIntLen <$> ls_get strs)
-         4 -> CaptureData <$> ls_get strs <*> ls_get strs <*> ls_get strs
+         1 -> CaptureData <$> (map fromWDv0 . fromIntLenW <$> get) <*> get <*> pure "" <*> pure False
+         2 -> CaptureData <$> (map fromWDv0 . fromIntLenW <$> ls_get strs) <*> ls_get strs <*> pure "" <*> pure False
+         3 -> CaptureData <$> (map fromWDv0 . fromIntLenW <$> ls_get strs) <*> ls_get strs <*> (fromIntLen <$> ls_get strs) <*> pure False
+         4 -> CaptureData <$> ls_get strs <*> ls_get strs <*> ls_get strs <*> pure False
+         5 -> CaptureData <$> ls_get strs <*> ls_get strs <*> ls_get strs <*> ls_get strs
          _ -> error $ "Unsupported CaptureData version tag " ++ show v ++ "\n" ++
                       "You can try to recover your data using arbtt-recover."
 

src/DumpFormat.hs

@@ -42,7 +42,8 @@ instance ToJSON (TimeLogEntry CaptureData) where
         "rate" .= tlRate,
         "inactive" .= cLastActivity tlData,
         "windows" .= cWindows tlData,
-        "desktop" .= cDesktop tlData
+        "desktop" .= cDesktop tlData,
+        "screensaver" .= cScreenSaver tlData
         ]
 
 instance FromJSON (TimeLogEntry CaptureData) where
@@ -52,6 +53,7 @@ instance FromJSON (TimeLogEntry CaptureData) where
         cLastActivity <- v .: "inactive"
         cWindows  <- v .: "windows"
         cDesktop <- v .: "desktop"
+        cScreenSaver <- v .: "screensaver" .!= False
         let tlData = CaptureData {..}
         let entry = TimeLogEntry {..}
         pure entry
@@ -86,7 +88,7 @@ dumpActivity :: TimeLog (CaptureData, ActivityData) -> IO ()
 dumpActivity = mapM_ go
  where
     go tle = do
-        dumpHeader (tlTime tle) (cLastActivity cd)
+        dumpHeader (tlTime tle) (cLastActivity cd) (cScreenSaver cd)
         dumpDesktop (cDesktop cd)
         mapM_ dumpWindow (cWindows cd)
         dumpTags ad
@@ -97,12 +99,13 @@ dumpTags :: ActivityData -> IO ()
 dumpTags = mapM_ go
   where go act = printf "    %s\n" (show act)
 
-dumpHeader :: UTCTime -> Integer -> IO ()
-dumpHeader time lastActivity = do
+dumpHeader :: UTCTime -> Integer -> Bool -> IO ()
+dumpHeader time lastActivity screenSaver = do
     tz <- getCurrentTimeZone
-    printf "%s (%dms inactive):\n"
+    printf "%s (%dms inactive%s):\n"
         (formatTime defaultTimeLocale "%F %X" (utcToLocalTime tz time))
         lastActivity
+        (if screenSaver then ", screen saver/locker active" else [])
 
 dumpWindow :: WindowData -> IO ()
 dumpWindow WindowData{..} = do
@@ -122,7 +125,7 @@ dumpDesktop d
 
 dumpSample :: TimeLogEntry CaptureData -> IO ()
 dumpSample tle = do
-    dumpHeader (tlTime tle) (cLastActivity (tlData tle))
+    dumpHeader (tlTime tle) (cLastActivity (tlData tle)) (cScreenSaver (tlData tle))
     dumpDesktop (cDesktop (tlData tle))
     mapM_ dumpWindow (cWindows (tlData tle))
 

src/UpgradeLog1.hs

@@ -57,7 +57,7 @@ upgrade :: TimeLog CaptureData -> D.TimeLog D.CaptureData
 upgrade = map $ \(TimeLogEntry a b c) -> D.TimeLogEntry a b (upgradeCD c)
 
 upgradeCD :: CaptureData -> D.CaptureData
-upgradeCD (CaptureData a b) = D.CaptureData (map upgrageWD a) b (T.pack "")
+upgradeCD (CaptureData a b) = D.CaptureData (map upgrageWD a) b (T.pack "") False
  where upgrageWD (b, s1, s2) = D.fromWDv0 (b, T.pack s1, T.pack s1)
 
 

tests/test.hs

@@ -38,14 +38,14 @@ regressionTests = testGroup "Regression tests"
     [ testCase "Issue #4" $ do
         cat <- readCategorizer "tests/issue4.cfg"
         let wd = WindowData{ wActive = True, wHidden = False, wTitle = "aa", wProgram = "program", wDesktop = "" }
-        let sample = TimeLogEntry undefined 0 (CaptureData [wd] 0 "")
+        let sample = TimeLogEntry undefined 0 (CaptureData [wd] 0 "" False)
         let [TimeLogEntry _ _ (_,acts)] = cat [sample]
         [Activity (Just "Cat") "aa"] @=? acts
         return ()
     , testCase "Issue #5" $ do
         cat <- readCategorizer "tests/issue5.cfg"
         let wd = WindowData{ wActive = True, wHidden = False, wTitle = "aa", wProgram = "program", wDesktop = "" }
-        let sample = TimeLogEntry undefined 0 (CaptureData [wd] 0 "")
+        let sample = TimeLogEntry undefined 0 (CaptureData [wd] 0 "" False)
         let [TimeLogEntry _ _ (_,acts)] = cat [sample]
         [Activity Nothing "A2"] @=? acts
         return ()
@@ -55,7 +55,7 @@ regressionTests = testGroup "Regression tests"
         let backThen = (-60*60*101) `addUTCTime` now
 
         let wd = WindowData{ wActive = True, wHidden = False, wTitle = "aa", wProgram = "program", wDesktop = "" }
-        let sample = TimeLogEntry backThen 0 (CaptureData [wd] 0 "")
+        let sample = TimeLogEntry backThen 0 (CaptureData [wd] 0 "" False)
         let [TimeLogEntry _ _ (_,acts)] = cat [sample]
         [Activity Nothing "old"] @=? acts
         return ()