Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Record screen saver/locker status for inactivity tagging #40

Draft
wants to merge 3 commits into
base: master
Choose a base branch
from
Draft
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 2 additions & 1 deletion arbtt.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
3 changes: 3 additions & 0 deletions categorize.cfg
Original file line number Diff line number Diff line change
Expand Up @@ -17,6 +17,9 @@ aliases (
-- causes this sample to be ignored by default.
$idle > 60 ==> tag inactive,

-- TODO
$screensaver ==> tag inactive,

-- A rule that matches on a list of strings
current window $program == ["Navigator","galeon"] ==> tag Web,

Expand Down
5 changes: 5 additions & 0 deletions doc/arbtt.xml
Original file line number Diff line number Diff line change
Expand Up @@ -232,6 +232,10 @@
<command>arbtt-stats</command>, as can be seen in <xref linkend="catex"/>.
</para>

<para>
The variable <literal>$screensaver</literal> …
</para>

<para>
When applying the rules, the categorizer has a notion of
the <emphasis>window in scope</emphasis>, and the variables
Expand Down Expand Up @@ -425,6 +429,7 @@
<nonterminal def="#g-timediff"/> </rhs>
<rhs> <nonterminal def="#g-date"/> <nonterminal def="#g-cmpop"/>
<nonterminal def="#g-date"/> </rhs>
<rhs> <quote>$screensaver</quote> </rhs>
<rhs> <quote>current window</quote> <nonterminal def="#g-cond"/> </rhs>
<rhs> <quote>any window</quote> <nonterminal def="#g-cond"/> </rhs>
<rhs> <quote>$</quote> Literal </rhs>
Expand Down
3 changes: 2 additions & 1 deletion src/Capture/OSX.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
3 changes: 2 additions & 1 deletion src/Capture/Win32.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
53 changes: 50 additions & 3 deletions src/Capture/X11.hs
Original file line number Diff line number Diff line change
@@ -1,20 +1,26 @@
{-# 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.String
import Data.Time.Clock
import System.Environment
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
Expand Down Expand Up @@ -59,9 +65,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
Expand Down Expand Up @@ -138,3 +146,42 @@ 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.
Comment on lines +152 to +154
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Ah, too bad. I was hoping this simple interface sufficies, and we’d not have to worry about dbus dependencies, error handling, and the cost of doing dbus calls on each sample :-/

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yeah, it's quite disappointing. Doing 5 dbus calls on each sample to discard 4 of them is bad. Caching which one works and which one just returns errors would be possible, but the code will get considerably more complex. :-(

Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Maybe submit patches to the screensavers to set the X11 screen saver satus correctly? :-)

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 = do
xdgSessionId <- lookupEnv "XDG_SESSION_ID"
-- When running as systemd user unit, …/session/self doesn't work so we
-- try $XDG_SESSION_ID and fall back to …/session/auto if not set, which
-- acts like self if run directly from a session, or the user's display
-- session otherwise.
let session = fromMaybe "auto" xdgSessionId
bracket D.connectSystem D.disconnect (getLockedHint session)
`catch` (return . const False . D.clientErrorMessage)
where
dest = "org.freedesktop.login1"
object session = fromString $ "/org/freedesktop/login1/session/" <> session
interface = "org.freedesktop.login1.Session"
property = "LockedHint"
methodCall obj = (D.methodCall obj interface property){ D.methodCallDestination = Just dest }
getLockedHint session c = fmap (fromRight False) $ D.getPropertyValue c $ methodCall $ object session
7 changes: 7 additions & 0 deletions src/Categorize.hs
Original file line number Diff line number Diff line change
Expand Up @@ -79,6 +79,8 @@ data TimeVar = TvTime | TvSampleAge

data NumVar = NvIdle

data BoolVar = BvScreenSaver

runParserStack :: Stream s (ReaderT r Identity) t
=> r
-> ParsecT s () (ReaderT r Identity) a
Expand Down Expand Up @@ -144,6 +146,7 @@ lang = makeTokenParser LanguageDef
, "date"
, "now"
, "desktop"
, "screensaver"
]
, caseSensitive = True
}
Expand Down Expand Up @@ -417,6 +420,7 @@ parseCondPrim = choice
, reserved lang "date" >> return (CondDate (getDateVar DvDate))
, reserved lang "now" >> return (CondDate (getDateVar DvNow))
, reserved lang "desktop" >> return (CondString (getVar "desktop"))
, reserved lang "screensaver" >> return (CondCond (checkBoolVar BvScreenSaver))
, do varname <- identifier lang
inEnvironment <- (lift (asks (Map.lookup varname . snd)))
case inEnvironment of
Expand Down Expand Up @@ -553,6 +557,9 @@ getDateVar :: DateVar -> CtxFun UTCTime
getDateVar DvDate = Just . tlTime . cNow
getDateVar DvNow = Just . zonedTimeToUTC . cCurrentTime

checkBoolVar :: BoolVar -> Cond
checkBoolVar BvScreenSaver ctx = [] <$ guard (cScreenSaver (tlData (cNow ctx)))

checkActive, checkHidden :: Cond
checkActive ctx = [] <$ (guard =<< wActive <$> cWindowInScope ctx)
checkHidden ctx = [] <$ (guard =<< wHidden <$> cWindowInScope ctx)
Expand Down
14 changes: 9 additions & 5 deletions src/Data.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)

Expand Down Expand Up @@ -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 4
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."

Expand Down
15 changes: 9 additions & 6 deletions src/DumpFormat.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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))

Expand Down
2 changes: 1 addition & 1 deletion src/UpgradeLog1.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)


6 changes: 3 additions & 3 deletions tests/test.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 ()
Expand All @@ -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 ()
Expand Down