diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,95 +0,0 @@ -arbtt, the Automatic Rule-Based Time Tracker - -© 2009 Joachim Breitner - -The Automatic Rule-Based Time Tracker is a desktop daemon that runs in the -background and, every minute, records what windows are open on your -desktop, what their titles are, which one is active. The accompanied -statistics program lets you derive information from this log file, i.e. -what how much of your time have you been spending with e-Mail, or what -projects are your largest time wasters. The mapping from the raw window -titles to sensible „tags“ is done by a configuration file with an powerful -syntax. - -Installation -============ - -You can build and install this program as any other Cabalized program: - $ runhaskell Setup.hs configure - $ runhaskell Setup.hs build - $ runhaskell Setup.hs install - -You also need to make sure that arbtt-capture is started with your X -session. If you use GNOME or KDE, you can copy the file -"arbtt-capture.desktop" to ~/.config/autostart/. You might need to put the -full path to arbtt-capture in the Exec line there, if you did not do a -system wide installation. - -If you want to record samples at a different rate than one per minute, you -will have to pass the "--sample-rate" parameter to arbtt-capture. - -Documentation -============ - -Full documentation is now provided in the user manual in the doc/ -directory. If you have the docbook xsl toolchain installed, you can -generate the HTML documentation by entering "make" in that directory. -Otherwise, you can use the online version at -http://darcs.nomeata.de/arbtt/doc/users_guide/ -Beware that this will also reflect the latest version. - -Creating the Windows Installer -============================== - -The file setup.iss contains an installer script for Inno Setup and can be used -to create the windows installer for arbtt. It can be used under wine. To build -arbtt under Windows, you need to install the Haskell Platform. Because the -Haskell Platform ships an older version of the w32api package from mingw, you -also need to download w32api-3.14-mingw32-dev.tar.gz and copy at least the files -include/psapi.h and lib/libpsapi.a over the files installed by the Haskell -Platform. For the pcre-light package, you need to install the pcre library. -Unless you run a German version of Windows, you’ll need to adjust the path to -the pcre3.dll file in setup.iss. Install Inno Setup. Create the documentation -(make -C doc) and configure arbtt with the --with-ISCC-flag: -$ wine runhaskell Setup.hs configure --with-ISCC='C:\Programme\Inno Setup 5\ISCC.exe' -again adjusting the path if you do not have a German version of Windows. This -will put the version name into setup.iss and create the output file as -dist/arbtt-setup-.exe. - -Download links: - * http://hackage.haskell.org/platform/2009.2.0.2/HaskellPlatform-2009.2.0.2-setup.exe - * http://sourceforge.net/projects/mingw/files/MinGW%20API%20for%20MS-Windows/ - * http://gnuwin32.sourceforge.net/downlinks/pcre.php - * http://www.jrsoftware.org/download.php/is-unicode.exe - -Development -=========== - -You are very welcome to help the developement of arbtt. You can find the -latest source at the darcs repository at - http://darcs.nomeata.de/arbtt - -User and Developer discussion happens on the arbtt mailing list: - arbtt@lists.nomeata.de -To subscribe to the list, visit: - http://lists.nomeata.de/mailman/listinfo/arbtt - -Some of my plans or ideas include: - - * A graphical viewer that allows you to expore the tags in an appealing, - interactive way. Possibly based on the Charts haskell library. - * Looking forward and backwards in time when writing rules. (Information - is already passed to the categorizing function, but not exposed to the - syntax). - * $total_idle time, which is the maximum idle time until it is reset. This - would allow the user to catch the idle times more exactly. - * Rules based on day of time, to create tags for worktime, weekend, late - at night. (Partially done) - * Storing the current timezone in the tags, for the prevoius entry to be - more to be more useful. - * Storing the hostname, in case a user has several. - * Statistics based on time, to visualize trends. - * Possibly more data sources? - -Any help cleaning, documenting or testing the current code is appreciated -as well. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,112 @@ +arbtt, the Automatic Rule-Based Time Tracker +============================================ + +© 2009 Joachim Breitner + +The Automatic Rule-Based Time Tracker is a desktop daemon that runs in the +background and, every minute, records what windows are open on your +desktop, what their titles are, which one is active. The accompanied +statistics program lets you derive information from this log file, i.e. +what how much of your time have you been spending with e-Mail, or what +projects are your largest time wasters. The mapping from the raw window +titles to sensible „tags“ is done by a configuration file with an powerful +syntax. + +Installation +------------ + +You can build and install this program as any other Cabalized program: + + $ runhaskell Setup.hs configure + $ runhaskell Setup.hs build + $ runhaskell Setup.hs install + +You also need to make sure that arbtt-capture is started with your X +session. If you use GNOME or KDE, you can copy the file +`arbtt-capture.desktop` to `~/.config/autostart/`. You might need to put the +full path to arbtt-capture in the `Exec` line there, if you did not do a +system wide installation. + +If you want to record samples at a different rate than one per minute, you +will have to pass the `--sample-rate` parameter to arbtt-capture. + +Documentation +------------ + +Full documentation is now provided in the user manual in the doc/ +directory. If you have the docbook xsl toolchain installed, you can +generate the HTML documentation by entering "make" in that directory. +Otherwise, you can use the +[online version of the User’s Guide](http://darcs.nomeata.de/arbtt/doc/users_guide/) +Beware that this will also reflect the latest development version. + +Development +----------- + +You are very welcome to help the developement of arbtt. You can find the +latest source at the darcs repository at + http://darcs.nomeata.de/arbtt + +Git mirrors are available at + + * http://git.nomeata.de/?p=darcs-mirror-arbtt.git + * https://github.com/nomeata/darcs-mirror-arbtt + * https://bitbucket.org/nomeata/arbtt + +User and Developer discussion happens on the arbtt mailing list: + arbtt@lists.nomeata.de +To subscribe to the list, visit: + http://lists.nomeata.de/mailman/listinfo/arbtt + +The issue tracker is hosted on bitbucket: + https://bitbucket.org/nomeata/arbtt/issues +Why Bitbucket and not GitHub? Why not, and we need diversitiy even in the +cloud! (Don’t worry, you can use your GitHub account there.) + +Some of my plans or ideas include: + + * A graphical viewer that allows you to expore the tags in an appealing, + interactive way. Possibly based on the Charts haskell library. + * Looking forward and backwards in time when writing rules. (Information + is already passed to the categorizing function, but not exposed to the + syntax). + * `$total_idle` time, which is the maximum idle time until it is reset. This + would allow the user to catch the idle times more exactly. + * Rules based on time of day, to create tags for worktime, weekend, late + at night. (Partially done) + * Storing the current timezone in the tags, for the prevoius entry to be + more to be more useful. + * Storing the hostname, in case a user has several. + * Statistics based on time, to visualize trends. + * Possibly more data sources? + +Any help cleaning, documenting or testing the current code is appreciated +as well. + +Creating the Windows Installer +------------------------------ + +The file `setup.iss` contains an installer script for Inno Setup and can be used +to create the windows installer for arbtt. It can be used under wine. To build +arbtt under Windows, you need to install the Haskell Platform. Because the +Haskell Platform ships an older version of the w32api package from mingw, you +also need to download `w32api-3.14-mingw32-dev.tar.gz` and copy at least the files +`include/psapi.h` and `lib/libpsapi.a` over the files installed by the Haskell +Platform. For the `pcre-light` package, you need to install the `pcre` library. +Unless you run a German version of Windows, you’ll need to adjust the path to +the `pcre3.dll` file in `setup.iss`. Install `Inno Setup`. Create the documentation +(`make -C doc`) and configure arbtt with the `--with-ISCC-flag`: + + $ wine runhaskell Setup.hs configure --with-ISCC='C:\Programme\Inno Setup 5\ISCC.exe' + +again adjusting the path if you do not have a German version of Windows. This +will put the version name into `setup.iss` and create the output file as +`dist/arbtt-setup-.exe.` + +Download links: + + * http://hackage.haskell.org/platform/2009.2.0.2/HaskellPlatform-2009.2.0.2-setup.exe + * http://sourceforge.net/projects/mingw/files/MinGW%20API%20for%20MS-Windows/ + * http://gnuwin32.sourceforge.net/downlinks/pcre.php + * http://www.jrsoftware.org/download.php/is-unicode.exe + diff --git a/arbtt.cabal b/arbtt.cabal --- a/arbtt.cabal +++ b/arbtt.cabal @@ -1,9 +1,9 @@ name: arbtt -version: 0.7 +version: 0.8 license: GPL license-file: LICENSE category: Desktop -cabal-version: >= 1.6 +cabal-version: >= 1.10 build-type: Simple author: Joachim Breitner maintainer: Joachim Breitner @@ -15,26 +15,30 @@ later), and stores this. It is also a program that will, based on expressive rules you specify, derive what you were doing, and what for. . + The documentation, which includes the changelog, can also be found at + http://arbtt.nomeata.de/doc/users_guide/. + . WARNING: The log file might contain very sensitive private data. Make sure you understand the consequences of a full-time logger and be careful with this data. -homepage: http://www.joachim-breitner.de/projects#arbtt - +homepage: http://arbtt.nomeata.de/ extra-source-files: - categorize.cfg, arbtt-capture.desktop, README, + categorize.cfg, arbtt-capture.desktop, README.md, doc/arbtt.xml, doc/fptools.css, doc/Makefile, - setup.iss, modpath.iss + setup.iss, modpath.iss, + tests/*.log, tests/*.out, tests/*.in, tests/*.cfg executable arbtt-capture main-is: capture-main.hs hs-source-dirs: src build-depends: - base == 4.5.* || == 4.6.*, + base == 4.5.* || == 4.6.* || == 4.7.*, filepath, directory, transformers, time >= 1.4, utf8-string, - bytestring, binary, deepseq, strict, - terminal-progress-bar, - bytestring-progress + aeson == 0.6.* || == 0.7.*, + array == 0.4.* || == 0.5.*, + binary >= 0.5, + bytestring, deepseq, strict, old-locale other-modules: Data Data.MyText @@ -65,12 +69,22 @@ System.Locale.SetLocale build-depends: X11 > 1.4.4, unix + default-language: Haskell98 executable arbtt-stats main-is: stats-main.hs hs-source-dirs: src build-depends: - base == 4.*, parsec == 3.*, containers, pcre-light, old-locale + base == 4.5.* || == 4.6.* || == 4.7.*, + parsec == 3.*, + containers == 0.5.*, + pcre-light, old-locale, + binary >= 0.5, + deepseq, bytestring, utf8-string, time >= 1.4, strict, + transformers, unix, directory, filepath, + aeson == 0.6.* || == 0.7.*, + array == 0.4.* || == 0.5.*, + terminal-progress-bar, bytestring-progress other-modules: Data Data.MyText @@ -89,30 +103,47 @@ else other-modules: System.Locale.SetLocale + default-language: Haskell98 executable arbtt-dump main-is: dump-main.hs hs-source-dirs: src build-depends: - base == 4.*, parsec == 3.*, containers + base == 4.5.* || == 4.6.* || == 4.7.*, + parsec == 3.*, + containers == 0.5.*, + aeson == 0.6.* || == 0.7.*, + array == 0.4.* || == 0.5.*, + binary >= 0.5, + deepseq, bytestring, utf8-string, time >= 1.4, strict, + transformers, unix, directory, filepath, + old-locale other-modules: Data Data.MyText Data.Binary.StringRef CommonStartup TimeLog + DumpFormat + Data.List.TakeR ghc-options: -rtsopts if os(windows) cpp-options: -DWIN32 else other-modules: System.Locale.SetLocale + default-language: Haskell98 executable arbtt-import main-is: import-main.hs hs-source-dirs: src build-depends: - base == 4.*, parsec == 3.*, containers + base == 4.5.* || == 4.6.* || == 4.7.*, + parsec == 3.*, + containers == 0.5.*, + binary >= 0.5, + deepseq, bytestring, utf8-string, time >= 1.4, strict, + transformers, unix, directory, filepath other-modules: Data Data.MyText @@ -125,12 +156,17 @@ else other-modules: System.Locale.SetLocale + default-language: Haskell98 executable arbtt-recover main-is: recover-main.hs hs-source-dirs: src build-depends: - base == 4.*, parsec == 3.*, containers + base == 4.5.* || == 4.6.* || == 4.7.*, + parsec == 3.*, containers == 0.5.*, + binary >= 0.5, + deepseq, bytestring, utf8-string, time >= 1.4, strict, + transformers, unix, directory, filepath other-modules: Data Data.MyText @@ -143,6 +179,35 @@ else other-modules: System.Locale.SetLocale + default-language: Haskell98 + +test-suite test + Type: + exitcode-stdio-1.0 + Hs-source-dirs: + tests + src + Main-is: + test.hs + Build-depends: + base == 4.5.* || == 4.6.* || == 4.7.* + , tasty == 0.7.* + , tasty-golden == 2.2.0.2 + , tasty-hunit == 0.2.* || == 0.4.* + , HUnit == 1.2.* + , process-extras == 0.2.* + , deepseq + , binary >= 0.5 + , bytestring + , utf8-string + , time + , unix + , directory + , parsec == 3.* + , containers == 0.5.* + , pcre-light, old-locale + , transformers + default-language: Haskell98 source-repository head type: darcs diff --git a/categorize.cfg b/categorize.cfg --- a/categorize.cfg +++ b/categorize.cfg @@ -1,11 +1,15 @@ +-- Comments in this file use the Haskell syntax: +-- A "--" comments the rest of the line. +-- A set of {- ... -} comments out a group of lines. + -- This defines some aliases, to make the reports look nicer: aliases ( "sun-awt-X11-XFramePeer" -> "java", "sun-awt-X11-XDialogPeer" -> "java", "sun-awt-X11-XWindowPeer" -> "java", - "gramps.py" -> "gramps", + "gramps.py" -> "gramps", "___nforschung" -> "ahnenforschung", - "Pidgin" -> "pidgin" + "Pidgin" -> "pidgin" ) -- A rule that probably everybody wants. Being inactive for over a minute @@ -27,6 +31,9 @@ -- Simple rule that just tags the current program tag Program:$current.program, +-- Another simple rule, just tags the current desktop (a.k.a. workspace) +tag Desktop:$desktop, + -- I'd like to know what evolution folders I'm working in. But when sending a -- mail, the window title only contains the (not very helpful) subject. So I do -- not tag necessarily by the active window title, but the title that contains @@ -118,3 +125,5 @@ month $date == 2 ==> tag month:February, year $date == 2010 ==> tag year:2010, -} + +} diff --git a/doc/arbtt.xml b/doc/arbtt.xml --- a/doc/arbtt.xml +++ b/doc/arbtt.xml @@ -33,6 +33,12 @@ Contributor muharem@linux.com + + Waldir + Pimenta + Documentation writer + waldir@email.com + @@ -150,8 +156,8 @@ The semantics (informal) A data sample consists of the time of recording, the time passed since the - user’s last action and the list of windows. For each window this - information is available: + user’s last action, the name of the current workspace and the list of + windows. For each window this information is available: the window title the program name @@ -214,6 +220,11 @@ + The name of the current desktop (or workspace) is available as + $desktop. + + + For current window, the currently active window is in scope. If there is no such window, the condition is false. @@ -372,6 +383,8 @@ + + current window any window @@ -380,6 +393,7 @@ String $title $program + $desktop format " string literal " @@ -513,7 +527,7 @@ --> Because the data log file is binary, a tool names arbtt-dump can bee used to dump the data in - textual form. Its command line reference is given in . If arbtt-capture crashes it might be that the log @@ -597,7 +611,7 @@ TAG - TAB + TAG Ignore any data samples that have not been assigned this tag. To distinguish tags and categories, the latter have to be entered followed by a colon. Can be given more than once. @@ -714,6 +728,22 @@ + + PERIOD + This is not a report of its own, but causes the selected + report to be executed for each of the given PERIOD (which can be + day, month or year) where there exist selected samples. All the reports + will then be printed one after another or, in the case of CSV output, + with an additional column. + + Note that if this option is enabled, samples that are filtered out + are completely ignored (to avoid empty reports for periods with + only filtered samples). Therefore, the + report will print the numbers for + the samples selected also for the totals. + + + @@ -748,7 +778,7 @@ See also See the arbtt manual for more information and the arbtt hackage page for + url="http://hackage.haskell.org/package/arbtt">arbtt hackage page for newer versions of arbtt. @@ -804,6 +834,11 @@ FILE logfile to use instead of ~/.arbtt/capture.log + + + + dump one current sample instead of modifying the logfile + Files @@ -818,7 +853,7 @@ See also See the arbtt manual for more information and the arbtt hackage page for + url="http://hackage.haskell.org/package/arbtt">arbtt hackage page for newer versions of arbtt. @@ -869,8 +904,19 @@ FILE logfile to use instead of ~/.arbtt/capture.log + + FORMAT + FORMAT + dumping format to use, where FORMAT is one of human (the default), show or JSON. Case in-sensitive. + + + NUMBER + NUMBER + dump only the last NUMBER of samples. + + Files @@ -880,9 +926,66 @@ + Formats + Human + This format is intended for human inspection, but not for further + processing. Hence, it may change in new versions of arbtt without notice. + Example output: + 2013-06-20 14:53:50 (48ms inactive): + ( ) Navigator: arbtt-dump - Iceweasel + ( ) gnome-terminal-server: jojo@kirk:~/projekte/programming/arbtt/doc + (*) gvim: arbtt.xml + (~/projekte/programming/arbtt/doc) - GVIM2 + + The line with a star indicates the currently active window. + + + Show + This is the default serialization format of Haskell's + Show type class, one entry per line. This can be + useful if the data is to be processed by further Haskell code. Example + output, with indentation added manually: + TimeLogEntry + { tlTime = 2013-06-20 14:53:50.957763 UTC + , tlRate = 60000 + , tlData = CaptureData + { cWindows = + [ (False,"arbtt-dump - Iceweasel","Navigator") + , (False,"jojo@kirk:~/projekte/programming/arbtt/doc","gnome-terminal-server") + , (True,"arbtt.xml + (~/projekte/programming/arbtt/doc) - GVIM2","gvim") + ] + , cLastActivity = 48 + } + } + + + JSON + For interoperability, arbtt supports dumping its data to JSON, which can + easily be parsed by many different programming languages. Some level of + backward-compatibility will be provided, as far as possible. Default + output, again with indentation and spacing added manually: + [ ..., + { "windows": [ + { "program": "arbtt-dump - Iceweasel", + "title": "Navigator", + "active": false}, + { "program": "jojo@kirk:~/projekte/programming/arbtt/doc", + "title":" gnome-terminal-server", + "active": false}, + { "program": "arbtt.xml + (~/projekte/programming/arbtt/doc) - GVIM2", + "title": "gvim", + "active":true + }], + "inactive": 48, + "date": "2013-06-20T14:53:50.957Z", + "rate": 60000}, + ... +] + + + See also See the arbtt manual for more information and the arbtt hackage page for + url="http://hackage.haskell.org/package/arbtt">arbtt hackage page for newer versions of arbtt. @@ -946,7 +1049,7 @@ See also See the arbtt manual for more information and the arbtt hackage page for + url="http://hackage.haskell.org/package/arbtt">arbtt hackage page for newer versions of arbtt. @@ -972,11 +1075,11 @@ Description - arbtt-recover tries to readsthe data samples recorded - by , skipping over possible broken entries. A fixed log file is written to ~/.arbtt/capture.log.recovered. If the recovery was successful, you should stop arbtt-capture and move the file to ~/.arbtt/capture.log. + arbtt-recover tries to read the data samples recorded + by , skipping over possible broken entries. A fixed log file is written to ~/.arbtt/capture.log.recovered. If the recovery was successful, you should stop arbtt-capture and move the file to ~/.arbtt/capture.log. - As a sid effect, arbtt-recover applies the log compression method implemented in version 0.4.5 to the samples created by an earlier version. If you have a large logfile written by older versions, running arbtt-recover is recommended. + As a side effect, arbtt-recover applies the log compression method implemented in version 0.4.5 to the samples created by an earlier version. If you have a large logfile written by older versions, running arbtt-recover is recommended. @@ -1002,7 +1105,7 @@ - where to save the recovered file, instead of ~/.arbtt/capture.log + where to save the recovered file, instead of ~/.arbtt/capture.log.recovered @@ -1021,7 +1124,7 @@ See also See the arbtt manual for more information and the arbtt hackage page for + url="http://hackage.haskell.org/package/arbtt">arbtt hackage page for newer versions of arbtt. @@ -1073,8 +1176,55 @@ Release Notes - The version history with changes relevant for the user are documented here. + The version history with changes relevant for the user is documented here. + + + Version 0.8 (unreleased) + + + + arbtt-dump can now show the data in other formats + as well, as suggested by Waldir Pimenta (option + ). This includes a human-readale output and + JSON. + + + + New option of arbtt-dump. + + + arbtt-recover can handle larger datasets with a reasonable amount of memory. + + + When dumping samples with arbtt-stats or arbtt-dump (in human-readable mode), times are printed in the local time zone, as suggested by Oren Gampel. + + + arbtt-capture now supports the option for development and debugging purposes. + + + The name of the current desktop (or workspace) is also recorded, and available as $desktop (issue #1). + + + Two bugs in the parser were fixed (issue #4 and issue #5). + + + arbtt-stats can print reports split by time interval, using the option. + + + arbtt-stats can print the actual samples selected, with . + + + Support for GHC-7.8 was added, with help from Jayesh Kumar Gupta (issue #8). + + + Arbtt now has a proper testsuite integrated into Cabal, and an automated test infrastructure on Travis. + + + Waldir Pimenta contributed a new web page, hosted at arbtt.nomeata.de. + + + Version 0.7 diff --git a/src/Capture/Win32.hs b/src/Capture/Win32.hs --- a/src/Capture/Win32.hs +++ b/src/Capture/Win32.hs @@ -26,4 +26,4 @@ it <- fromIntegral `fmap` getIdleTime - return $ CaptureData winData it + return $ CaptureData winData it (T.pack "") diff --git a/src/Capture/X11.hs b/src/Capture/X11.hs --- a/src/Capture/X11.hs +++ b/src/Capture/X11.hs @@ -36,11 +36,27 @@ xSetErrorHandler let rwin = defaultRootWindow dpy + -- Desktops + current_desktop <- flip catchIOError (\_ -> return "") $ do + a <- internAtom dpy "_NET_CURRENT_DESKTOP" False + p <- getWindowProperty32 dpy a rwin + let desk_index = do {[d] <- p; return (fromIntegral d)} + + a <- internAtom dpy "_NET_DESKTOP_NAMES" False + tp <- getTextProperty dpy rwin a + names <- wcTextPropertyToTextList dpy tp + + return $ case desk_index of + Nothing -> "" + Just n -> if 0 <= n && n < length names + then names !! n + else show n + -- Windows a <- internAtom dpy "_NET_CLIENT_LIST" False p <- getWindowProperty32 dpy a rwin wins <- case p of - Just wins -> return (map fromIntegral wins) + Just wins -> filterM (isInteresting dpy) (map fromIntegral wins) Nothing -> return [] (fsubwin,_) <- getInputFocus dpy @@ -54,7 +70,7 @@ it <- fromIntegral `fmap` getXIdleTime dpy closeDisplay dpy - return $ CaptureData winData it + return $ CaptureData winData it (T.pack current_desktop) getWindowTitle :: Display -> Window -> IO String getWindowTitle dpy = myFetchName dpy @@ -70,6 +86,17 @@ | otherwise = do (r,p,_) <- queryTree dpy w if p == 0 then return w else go p + +-- | Ignore, for example, Desktop and Docks windows +isInteresting :: Display -> Window -> IO Bool +isInteresting d w = do + a <- internAtom d "_NET_WM_WINDOW_TYPE" False + dock <- internAtom d "_NET_WM_WINDOW_TYPE_DOCK" False + desk <- internAtom d "_NET_WM_WINDOW_TYPE_DESKTOP" False + mbr <- getWindowProperty32 d a w + case mbr of + Just [r] -> return $ fromIntegral r `notElem` [dock, desk] + _ -> return True -- | better than fetchName from X11, as it supports _NET_WM_NAME and unicode -- diff --git a/src/Categorize.hs b/src/Categorize.hs --- a/src/Categorize.hs +++ b/src/Categorize.hs @@ -143,10 +143,10 @@ parseRulesBody = do x <- parseRule choice [ do comma lang - xs <- sepEndBy1 parseRule (comma lang) + xs <- parseRule `sepEndBy1` comma lang return (matchAny (x:xs)) , do semi lang - xs <- many1 (semi lang >> parseRule) + xs <- parseRule `sepEndBy1` semi lang return (matchFirst (x:xs)) , return x ] @@ -355,7 +355,7 @@ ) "list of regular expressions" ]) , char '$' >> choice - [ do backref <- natural lang + [ do backref <- read <$> many1 digit return $ CondString (getBackref backref) , do varname <- identifier lang choice @@ -373,6 +373,8 @@ return $ CondTime (getTimeVar "sampleage") , do guard $ varname == "date" return $ CondDate (getDateVar "date") + , do guard $ varname == "desktop" + return $ CondString (getVar "desktop") ] ] "variable" , do regex <- parseRegex "regular expression" @@ -480,7 +482,7 @@ parseTagPart = do parts <- many1 (choice [ do char '$' (replaceForbidden . ) <$> choice - [ do num <- natural lang + [ do num <- read <$> many1 digit return $ getBackref num , do varname <- many1 (letter <|> oneOf ".") return $ getVar varname @@ -522,6 +524,8 @@ getVar "program" ctx = do (_,_,p) <- cWindowInScope ctx return p +getVar "desktop" ctx = do + return $ cDesktop (tlData (cNow ctx)) getVar v ctx = error $ "Unknown variable " ++ v getNumVar :: String -> CtxFun Integer diff --git a/src/Data.hs b/src/Data.hs --- a/src/Data.hs +++ b/src/Data.hs @@ -34,11 +34,13 @@ { cWindows :: [ (Bool, Text, Text) ] -- ^ Active window, window title, programm name , cLastActivity :: Integer -- ^ in milli-seconds + , cDesktop :: Text + -- ^ Current desktop name } deriving (Show, Read) instance NFData CaptureData where - rnf (CaptureData a b) = a `deepseq` b `deepseq` () + rnf (CaptureData a b c) = a `deepseq` b `deepseq` c `deepseq` () type ActivityData = [Activity] @@ -105,14 +107,16 @@ -- 2 Using ListOfStringable ls_put strs cd = do -- A version tag - putWord8 2 + putWord8 3 ls_put strs (cWindows cd) ls_put strs (cLastActivity cd) + ls_put strs (cDesktop cd) ls_get strs = do v <- getWord8 case v of - 1 -> CaptureData <$> get <*> get - 2 -> CaptureData <$> ls_get strs <*> ls_get strs + 1 -> CaptureData <$> get <*> get <*> pure "" + 2 -> CaptureData <$> ls_get strs <*> ls_get strs <*> pure "" + 3 -> CaptureData <$> ls_get strs <*> ls_get strs <*> ls_get strs _ -> error $ "Unsupported CaptureData version tag " ++ show v -- | 'getMany n' get 'n' elements in order, without blowing the stack. diff --git a/src/Data/List/TakeR.hs b/src/Data/List/TakeR.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/TakeR.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Data.List.TakeR where + +import Control.Monad.ST +import Debug.Trace +import Data.Array.MArray +import Data.Array.ST + +-- Efficient taking of last r values +takeR n l = go (drop n l) l + where + go [] r = r + go (x:xs) (y:ys) = go xs ys + +-- Much faster and better evaluation properties than: +{- +takeR :: forall a. Int -> [a] -> [a] +takeR n l | n <= 0 = [] +takeR n l = runST stAction + where + stAction :: forall s. ST s [a] + stAction = do + buffer <- newArray_ (0, n-1) + i <- go (buffer :: STArray s Int a) 0 l + let s = min i n + sequence $ [ readArray buffer (j `mod` n) | j <- [i-s..i-1] ] + go buffer i [] = return i + go buffer i (x:xs) = writeArray buffer (i `mod` n) x >> go buffer (i+1) xs +-} + + +-- Correctness asserted by +-- quickCheck (\n l -> n <= 100000 ==> takeR n l == reverse (take n (reverse (l::[Int]) ))) diff --git a/src/Data/MyText.hs b/src/Data/MyText.hs --- a/src/Data/MyText.hs +++ b/src/Data/MyText.hs @@ -7,7 +7,7 @@ import Data.Binary import Control.Applicative ((<$>)) import Control.Arrow (first) -import Prelude hiding (length, map) +import Prelude hiding (length, map, null) import qualified Prelude import GHC.Exts( IsString(..) ) import Control.DeepSeq @@ -31,8 +31,8 @@ -- The downside is that it quietly suceeds for broken input get = do n <- get :: Get Int - lbs <- lookAhead (getLazyByteString (4*fromIntegral n)) -- safe approximation - let bs = BS.concat $ LBS.toChunks $ lbs + r <- remaining + bs <- lookAhead (getByteString (min (fromIntegral r) (4*n))) -- safe approximation let utf8bs = BSU.take n bs unless (BSU.length utf8bs == n) $ fail $ "Coult not parse the expected " ++ show n ++ " utf8 characters." @@ -78,3 +78,6 @@ concat :: [Text] -> Text concat = Text . BS.concat . Prelude.map toBytestring + +null :: Text -> Bool +null = BS.null . toBytestring diff --git a/src/DumpFormat.hs b/src/DumpFormat.hs new file mode 100644 --- /dev/null +++ b/src/DumpFormat.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-} +module DumpFormat + ( DumpFormat(..) + , readDumpFormat + , dumpActivity + , dumpSample + , dumpSamples + ) where + +import Data.MyText (unpack, null, Text) +import Data.Aeson +import qualified Data.ByteString.Lazy as LBS +import Data.Time +import System.Locale +import Data.Char + +import Data +import Text.Printf +import Data.List hiding (null) +import Prelude hiding (null) + +data DumpFormat + = DFShow + | DFHuman + | DFJSON + deriving (Show, Eq) + +instance ToJSON Text where + toJSON = toJSON . unpack + +instance ToJSON (TimeLogEntry CaptureData) where + toJSON (TimeLogEntry {..}) = object [ + "date" .= tlTime, + "rate" .= tlRate, + "inactive" .= cLastActivity tlData, + "windows" .= map (\(a,p,t) -> object ["active" .= a, "program" .= p, "title" .= t]) (cWindows tlData), + "desktop" .= cDesktop tlData + ] + +readDumpFormat :: String -> Maybe DumpFormat +readDumpFormat arg = + case map toLower arg of + "human" -> return DFHuman + "show" -> return DFShow + "json" -> return DFJSON + _ -> Nothing + +dumpActivity :: TimeLog (CaptureData, TimeZone, ActivityData) -> IO () +dumpActivity = mapM_ go + where + go tle = do + dumpHeader tz (tlTime tle) (cLastActivity cd) + dumpDesktop (cDesktop cd) + mapM_ dumpWindow (cWindows cd) + dumpTags ad + where + (cd, tz, ad) = tlData tle + +dumpTags :: ActivityData -> IO () +dumpTags = mapM_ go + where go act = printf " %s\n" (show act) + +dumpHeader :: TimeZone -> UTCTime -> Integer -> IO () +dumpHeader tz time lastActivity = do + printf "%s (%dms inactive):\n" + (formatTime defaultTimeLocale "%F %X" (utcToLocalTime tz time)) + lastActivity + +dumpWindow :: (Bool, Text, Text) -> IO () +dumpWindow (active, title, program) = do + printf " %s %-15s %s\n" + (if active then ("(*)"::String) else "( )") + (unpack program ++ ":") + (unpack title) + +dumpDesktop :: Text -> IO () +dumpDesktop d + | null d = return () + | otherwise = printf " Current Desktop: %s\n" (unpack d) + +dumpSample :: TimeZone -> TimeLogEntry CaptureData -> IO () +dumpSample tz tle = do + dumpHeader tz (tlTime tle) (cLastActivity (tlData tle)) + dumpDesktop (cDesktop (tlData tle)) + mapM_ dumpWindow (cWindows (tlData tle)) + +dumpSamples :: TimeZone -> DumpFormat -> TimeLog CaptureData -> IO () +dumpSamples _ DFShow = mapM_ print + +dumpSamples tz DFHuman = mapM_ (dumpSample tz) + +dumpSamples _ DFJSON = enclose . sequence_ . intersperse (putStrLn ",") . map (LBS.putStr . encode) + where + enclose m = putStrLn "[" >> m >> putStrLn "]" diff --git a/src/LeftFold.hs b/src/LeftFold.hs --- a/src/LeftFold.hs +++ b/src/LeftFold.hs @@ -7,6 +7,8 @@ import Data.Monoid import Data.Strict ((:!:), Pair((:!:))) import qualified Data.Strict as S +import qualified Data.Map.Strict as M +import Data.Maybe data LeftFold x a = forall s. LeftFold { @@ -38,7 +40,7 @@ runLeftFold :: LeftFold x a -> [x] -> a runLeftFold (Pure x) _ = x -runLeftFold (LeftFold st1 p1 f1) xs = f1 (foldl' p1 st1 xs) +runLeftFold (LeftFold st1 p1 f1) xs = f1 $! foldl' p1 st1 xs monoidFold :: Monoid m => LeftFold m m monoidFold = leftFold mempty mappend @@ -47,9 +49,14 @@ mapElems (Pure x) _ = (Pure x) mapElems (LeftFold s p f) t = LeftFold s (\s x -> p s $! t x) f -filterWith :: (x -> Bool) -> LeftFold (Bool :!: x) a -> LeftFold x a -filterWith p f = f `mapElems` (\x -> (p x :!: x)) +filterElems :: (x -> Bool) -> LeftFold x a -> LeftFold x a +filterElems _ (Pure x) = (Pure x) +filterElems pred (LeftFold s p f) = LeftFold s (\s x -> if pred x then p s x else s) f +adjoin :: (x -> Bool) -> LeftFold (Bool :!: x) a -> LeftFold x a +adjoin p f = f `mapElems` (\x -> (p x :!: x)) + + onSelected :: LeftFold x a -> LeftFold (Bool :!: x) a onSelected (Pure x) = Pure x onSelected (LeftFold s p f) = LeftFold s (\s (b :!: x) -> if b then p s x else s) f @@ -99,6 +106,12 @@ finish (S.Nothing :!: S.Nothing) = fo so finish (S.Just si :!: S.Just so) = fo (po so (fi si)) finish (S.Just si :!: S.Nothing) = fo (po so (fi si)) + +multiplex :: Ord k => (a -> k) -> LeftFold a b -> LeftFold a (M.Map k b) +multiplex key (LeftFold si pi fi) = LeftFold M.empty go finish + where go m x = M.alter go' (key x) m + where go' mbOld = Just $ pi (fromMaybe si mbOld) x + finish = M.map fi lfLength :: LeftFold x Int lfLength = leftFold 0 (\c _ -> c + 1) diff --git a/src/Stats.hs b/src/Stats.hs --- a/src/Stats.hs +++ b/src/Stats.hs @@ -6,12 +6,14 @@ ReportResults(..), ActivityFilter(..), Filter(..), + Repeater(..), defaultFilter, defaultReportOptions, parseActivityMatcher, filterPredicate, prepareCalculations, - processReports, + processReport, + processRepeater, renderReport ) where @@ -26,12 +28,15 @@ import Data.Function (on) import System.Locale (defaultTimeLocale) import Control.Applicative -import Data.Strict ((:!:)) +import Data.Strict ((:!:), Pair(..)) +import qualified Data.Strict as Strict import Data.Traversable (sequenceA) +import Control.Arrow import Data import Categorize import LeftFold +import DumpFormat data Report = GeneralInfos @@ -40,6 +45,7 @@ | EachCategory | IntervalCategory Category | IntervalTag Activity + | DumpSamples deriving (Show, Eq) data Filter = Exclude ActivityMatcher | Only ActivityMatcher | GeneralCond String @@ -51,6 +57,9 @@ data ActivityFilter = ExcludeActivity ActivityMatcher | OnlyActivity ActivityMatcher deriving (Show, Eq) +data Repeater = ByDay | ByMonth | ByYear + deriving (Show, Eq) + -- Supported report output formats: text, comma-separated values and -- tab-separated values data ReportFormat = RFText | RFCSV | RFTSV @@ -78,7 +87,9 @@ | ListOfTimePercValues String [(String, String, Double)] | PieChartOfTimePercValues String [(String, String, Double)] | ListOfIntervals String [Interval] - | MultpleReportResults [ReportResults] + | MultipleReportResults [ReportResults] + | RepeatedReportResults String [(String, ReportResults)] + | DumpResult (TimeLog (CaptureData, TimeZone, ActivityData)) filterPredicate :: [Filter] -> TimeLogEntry (Ctx, ActivityData) -> Bool @@ -88,6 +99,9 @@ Only act -> onlyTag act tl GeneralCond s-> applyCond s (cTimeZone (fst (tlData tl))) tl) filters +filterActivity :: [ActivityFilter] -> ActivityData -> ActivityData +filterActivity fs = filter (applyActivityFilter fs) + applyActivityFilter :: [ActivityFilter] -> Activity -> Bool applyActivityFilter fs act = all go fs where go (ExcludeActivity matcher) = not (matchActivityMatcher matcher act) @@ -160,59 +174,88 @@ let go' m act = M.insertWith' (+) act (fromInteger (tlRate tl)/1000) m in foldl' go' m (snd (tlData tl))) id -processReports :: ReportOptions -> Calculations -> [Report] -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) [ReportResults] -processReports opts c = sequenceA . map (processReport opts c) +processRepeater :: Repeater -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults +processRepeater ByDay rep = + filterElems (\(b :!: _) -> b) $ + pure (RepeatedReportResults "Day" . map (\(d,rr) -> (showGregorian d, rr)) . M.toList) <*> + multiplex (utctDay . tlTime . Strict.snd) rep +processRepeater ByMonth rep = + filterElems (\(b :!: _) -> b) $ + pure (RepeatedReportResults "Month" . map (\((y,m),rr) -> (show y ++ "-" ++ show m, rr)) . M.toList) <*> + multiplex ((\(y,m,_) -> (y, m)). toGregorian . utctDay . tlTime . Strict.snd) rep +processRepeater ByYear rep = + filterElems (\(b :!: _) -> b) $ + pure (RepeatedReportResults "Year" . map (\(y,rr) -> (show y, rr)) . M.toList) <*> + multiplex ((\(y,_,_) -> y). toGregorian . utctDay . tlTime . Strict.snd) rep -processReport :: ReportOptions -> Calculations -> Report -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults -processReport opts ~(Calculations {..}) GeneralInfos = - pure (\n -> - ListOfFields "General Information" +processReport :: ReportOptions -> Report -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults +processReport opts GeneralInfos = + pure (\n firstDate lastDate ttr tts -> + let timeDiff = diffUTCTime lastDate firstDate + fractionRec = realToFrac ttr / (realToFrac timeDiff) :: Double + fractionSel = realToFrac tts / (realToFrac timeDiff) :: Double + fractionSelRec = realToFrac tts / realToFrac ttr :: Double + in ListOfFields "General Information" [ ("FirstRecord", show firstDate) , ("LastRecord", show lastDate) , ("Number of records", show n) - , ("Total time recorded", showTimeDiff totalTimeRec) - , ("Total time selected", showTimeDiff totalTimeSel) + , ("Total time recorded", showTimeDiff opts ttr) + , ("Total time selected", showTimeDiff opts tts) , ("Fraction of total time recorded", printf "%3.0f%%" (fractionRec * 100)) , ("Fraction of total time selected", printf "%3.0f%%" (fractionSel * 100)) , ("Fraction of recorded time selected", printf "%3.0f%%" (fractionSelRec * 100)) ]) <*> - onAll lfLength + onAll lfLength <*> + onAll calcFirstDate <*> + onAll calcLastDate <*> + onAll calcTotalTime <*> + onSelected calcTotalTime -processReport opts ~(Calculations {..}) TotalTime = - pure $ +processReport opts TotalTime = + onSelected $ + pure (\totalTimeSel sums -> ListOfTimePercValues "Total time per tag" . mapMaybe (\(tag,time) -> let perc = realToFrac time/realToFrac totalTimeSel pick = applyActivityFilter (roActivityFilter opts) tag in if pick && perc*100 >= roMinPercentage opts then Just $ ( show tag - , showTimeDiff time + , showTimeDiff opts time , perc) else Nothing ) . reverse . sortBy (comparing snd) $ M.toList $ - sums + sums) <*> + calcTotalTime <*> + calcSums -processReport opts c (Category cat) = pure (processCategoryReport opts c cat) +processReport opts (Category cat) = pure (\c -> processCategoryReport opts c cat) <*> + prepareCalculations -processReport opts c EachCategory = - pure (\cats -> MultpleReportResults $ map (processCategoryReport opts c) cats) <*> +processReport opts EachCategory = + pure (\c cats -> MultipleReportResults $ map (processCategoryReport opts c) cats) <*> + prepareCalculations <*> onSelected calcCategories -processReport opts c (IntervalCategory cat) = - processIntervalReport opts c ("Intervals for category " ++ show cat) (extractCat cat) +processReport opts (IntervalCategory cat) = + processIntervalReport opts ("Intervals for category " ++ show cat) (extractCat cat) where extractCat :: Category -> ActivityData -> Maybe String extractCat cat = fmap (unpack . activityName) . listToMaybe . filter ( (==Just cat) . activityCategory ) -processReport opts c (IntervalTag tag) = - processIntervalReport opts c ("Intervals for category " ++ show tag) (extractTag tag) +processReport opts (IntervalTag tag) = + processIntervalReport opts ("Intervals for category " ++ show tag) (extractTag tag) where extractTag :: Activity -> ActivityData -> Maybe String extractTag tag = fmap show . listToMaybe . filter ( (==tag) ) +processReport opts DumpSamples = + DumpResult <$> onSelected (mapElems toList $ fmap $ + \(cd,ad) -> (tlData (cNow cd), cTimeZone cd, filterActivity (roActivityFilter opts) ad) + ) + calcCategories :: LeftFold (TimeLogEntry (Ctx, ActivityData)) [Category] calcCategories = fmap S.toList $ leftFold S.empty $ \s tl -> foldl' go' s (snd (tlData tl)) @@ -232,7 +275,7 @@ pick = applyActivityFilter (roActivityFilter opts) tag in if pick && perc*100 >= roMinPercentage opts then Just ( show tag - , showTimeDiff time + , showTimeDiff opts time , perc) else Nothing ) @@ -241,7 +284,7 @@ ( if tooSmallTimes > 0 then [( printf "(%d entries omitted)" (M.size tooSmallSums) - , showTimeDiff tooSmallTimes + , showTimeDiff opts tooSmallTimes , realToFrac tooSmallTimes/realToFrac totalTimeSel )] else [] @@ -249,14 +292,14 @@ ++ (if uncategorizedTime > 0 then [( "(unmatched time)" - , showTimeDiff uncategorizedTime + , showTimeDiff opts uncategorizedTime , realToFrac uncategorizedTime/realToFrac totalTimeSel )] else [] ) -processIntervalReport :: ReportOptions -> Calculations -> String -> (ActivityData -> Maybe String) -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults -processIntervalReport _opts _c title extr = runOnIntervals go1 go2 +processIntervalReport :: ReportOptions -> String -> (ActivityData -> Maybe String) -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults +processIntervalReport opts title extr = runOnIntervals go1 go2 where go1 :: LeftFold (TimeLogEntry (Ctx, ActivityData)) [Interval] go1 = go3 `mapElems` fmap (extr . snd) @@ -269,7 +312,7 @@ ( str , showUtcTime (tlTime fe) , showUtcTime (tlTime le) - , showTimeDiff $ + , showTimeDiff opts $ tlTime le `diffUTCTime` tlTime fe + fromIntegral (tlRate fe)/1000 ) Nothing -> Nothing) <*> @@ -305,30 +348,36 @@ -} renderReport :: ReportOptions -> ReportResults -> IO () -renderReport opts (MultpleReportResults reports) = +renderReport opts (DumpResult samples) = + dumpActivity samples +renderReport opts (MultipleReportResults reports) = sequence_ . intersperse (putStrLn "") . map (renderReport opts) $ reports renderReport opts reportdata = putStr $ doRender opts reportdata doRender :: ReportOptions -> ReportResults -> String doRender opts reportdata = case roReportFormat opts of - RFText -> renderReportText reportdata - RFCSV -> renderReportCSV reportdata - RFTSV -> renderReportTSV reportdata + RFText -> renderReportText id reportdata + RFCSV -> renderWithDelimiter "," $ renderXSV reportdata + RFTSV -> renderWithDelimiter "\t" $ renderXSV reportdata -renderReportText (ListOfFields title dats) = - underline title ++ +renderReportText titleMod (ListOfFields title dats) = + underline (titleMod title) ++ (tabulate False $ map (\(f,v) -> [f,v]) dats) -renderReportText (ListOfTimePercValues title dats) = - underline title ++ (tabulate True $ listOfValues dats) +renderReportText titleMod (ListOfTimePercValues title dats) = + underline (titleMod title) ++ (tabulate True $ listOfValues dats) -renderReportText (PieChartOfTimePercValues title dats) = - underline title ++ (tabulate True $ piechartOfValues dats) +renderReportText titleMod (PieChartOfTimePercValues title dats) = + underline (titleMod title) ++ (tabulate True $ piechartOfValues dats) -renderReportText (ListOfIntervals title dats) = - underline title ++ (tabulate True $ listOfIntervals dats) +renderReportText titleMod (ListOfIntervals title dats) = + underline (titleMod title) ++ (tabulate True $ listOfIntervals dats) +renderReportText titleMod (RepeatedReportResults cat reps) = + intercalate "\n" $ map (\(v,rr) -> renderReportText (titleMod . mod v) rr) reps + where mod v s = s ++ " (" ++ cat ++ " " ++ v ++ ")" + listOfValues dats = ["Tag","Time","Percentage"] : map (\(f,t,p) -> [f,t,printf "%.2f" (p*100)]) dats @@ -343,38 +392,24 @@ -- The reporting of "General Information" is not supported for the -- comma-separated output format. -renderReportCSV (ListOfFields title dats) = - error ("\"" ++ title ++ "\"" ++ " not supported for comma-separated output format") - -renderReportCSV (ListOfTimePercValues _ dats) = - renderWithDelimiter "," (listOfValues dats) - -renderReportCSV (PieChartOfTimePercValues _ dats) = - renderWithDelimiter "," (piechartOfValues dats) - -renderReportCSV (ListOfIntervals title dats) = - renderWithDelimiter "," (listOfIntervals dats) +renderXSV (ListOfFields title dats) = + error ("\"" ++ title ++ "\"" ++ " not supported for this output format") --- The reporting of "General Information" is not supported for the --- TAB-separated output format. -renderReportTSV (ListOfFields title dats) = - error ("\"" ++ title ++ "\"" ++ " not supported for TAB-separated output format") +renderXSV (ListOfTimePercValues _ dats) = listOfValues dats -renderReportTSV (ListOfTimePercValues _ dats) = - renderWithDelimiter "\t" (listOfValues dats) +renderXSV (PieChartOfTimePercValues _ dats) = piechartOfValues dats -renderReportTSV (PieChartOfTimePercValues _ dats) = - renderWithDelimiter "\t" (piechartOfValues dats) +renderXSV (ListOfIntervals title dats) = listOfIntervals dats -renderReportTSV (ListOfIntervals title dats) = - renderWithDelimiter "\t" (listOfIntervals dats) +-- A bit code-smelly here. +renderXSV (RepeatedReportResults cat reps) = title : fields + where + title = cat : head (renderXSV (snd (head reps))) + fields = concatMap (\(v,rr) -> map (v:) (tail (renderXSV rr))) reps renderWithDelimiter :: String -> [[String]] -> String renderWithDelimiter delim datasource = - unlines $ map (injectDelimiter delim) datasource - -injectDelimiter :: [a] -> [[a]] -> [a] -injectDelimiter d = concat . intersperse d + unlines $ map (intercalate delim) datasource tabulate :: Bool -> [[String]] -> String tabulate titlerow rows = unlines $ addTitleRow $ map (intercalate " | " . zipWith (\l s -> take (l - length s) (repeat ' ') ++ s) colwidths) rows @@ -385,8 +420,12 @@ -- | titlerow = \(l:ls) -> l : (take (length l) (repeat '-')) : ls | otherwise = id -showTimeDiff :: NominalDiffTime -> String -showTimeDiff t = go False $ zip [days,hours,mins,secs] ["d","h","m","s"] +showTimeDiff :: ReportOptions -> NominalDiffTime -> String +showTimeDiff (ReportOptions { roReportFormat = RFText }) = showTimeDiffHuman +showTimeDiff _ = showTimeDiffMachine + +showTimeDiffHuman :: NominalDiffTime -> String +showTimeDiffHuman t = go False $ zip [days,hours,mins,secs] ["d","h","m","s"] where s = round t :: Integer days = s `div` (24*60*60) hours = (s `div` (60*60)) `mod` 24 @@ -398,6 +437,13 @@ go True ((a,u):vs) = printf "%02d%s" a u ++ go True vs go False ((a,u):vs) | a > 0 = printf "%2d%s" a u ++ go True vs | otherwise = go False vs + +showTimeDiffMachine :: NominalDiffTime -> String +showTimeDiffMachine t = printf "%d:%02d:%02d" hours mins secs + where s = round t :: Integer + hours = s `div` (60*60) + mins = (s `div` 60) `mod` 60 + secs = s `mod` 60 showUtcTime :: UTCTime -> String showUtcTime = formatTime defaultTimeLocale "%x %X" diff --git a/src/System/Locale/SetLocale.hsc b/src/System/Locale/SetLocale.hsc --- a/src/System/Locale/SetLocale.hsc +++ b/src/System/Locale/SetLocale.hsc @@ -1,4 +1,5 @@ {-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE DeriveDataTypeable #-} {- This file is copied from the setlocale-0.0.3 package. Its author is Lukas Mai @@ -26,10 +27,7 @@ | LC_MONETARY | LC_NUMERIC | LC_TIME - deriving (Eq, Ord, Read, Show, Enum, Bounded) - -instance Typeable Category where - typeOf _ = mkTyConApp (mkTyCon "System.Locale.SetLocale.Category") [] + deriving (Eq, Ord, Read, Show, Enum, Bounded, Typeable) #include diff --git a/src/TermSize.hsc b/src/TermSize.hsc --- a/src/TermSize.hsc +++ b/src/TermSize.hsc @@ -44,7 +44,7 @@ getTermSize = with (WinSize 0 0) $ \ws -> do throwErrnoIfMinus1 "ioctl" $ - ioctl (#const STDOUT_FILENO) (#const TIOCGWINSZ) ws + ioctl (#const STDERR_FILENO) (#const TIOCGWINSZ) ws WinSize row col <- peek ws return (fromIntegral row, fromIntegral col) #endif diff --git a/src/TimeLog.hs b/src/TimeLog.hs --- a/src/TimeLog.hs +++ b/src/TimeLog.hs @@ -17,21 +17,29 @@ import Prelude hiding (catch) import Control.DeepSeq import System.Posix.Files +import System.IO.Unsafe (unsafeInterleaveIO) import qualified Data.ByteString.Lazy as BS import Data.Maybe magic = BS.pack $ map (fromIntegral.ord) "arbtt-timelog-v1\n" +mkTimeLogEntry :: Integer -> a -> IO (TimeLogEntry a) +mkTimeLogEntry delay entry = do + date <- getCurrentTime + return $ TimeLogEntry date delay entry + + -- | Runs the given action each delay milliseconds and appends the TimeLog to the -- given file. runLogger :: ListOfStringable a => FilePath -> Integer -> IO a -> IO () runLogger filename delay action = flip fix Nothing $ \loop prev -> do entry <- action - date <- getCurrentTime + tle <- mkTimeLogEntry delay entry + createTimeLog False filename setFileMode filename (ownerReadMode `unionFileModes` ownerWriteMode) - appendTimeLog filename prev (TimeLogEntry date delay entry) + appendTimeLog filename prev tle threadDelay (fromIntegral delay * 1000) loop (Just entry) @@ -53,6 +61,7 @@ return (Just (tlData v)) -- | This might be very bad style, and it hogs memory, but it might help in some situations... +-- Use of unsafeInterleaveIO should be replaced by conduit, pipe or something the like recoverTimeLog :: ListOfStringable a => FilePath -> IO (TimeLog a) recoverTimeLog filename = do content <- BS.readFile filename @@ -64,18 +73,20 @@ show (map (chr.fromIntegral) (BS.unpack startString)) else do putStrLn $ "Found header, continuing... (" ++ show (BS.length rest) ++ " bytes to go)" go Nothing rest off + go prev input off = do - mb <- tryGet prev False input off + mb <- tryGet prev input off off flip (maybe (return [])) mb $ \(v,rest,off') -> if BS.null rest then return [v] - else (v :) <$> go (Just (tlData v)) rest off' - tryGet prev retrying input off = catch ( + else (v:) <$> (unsafeInterleaveIO $ go (Just (tlData v)) rest off') + + tryGet prev input off orig_off = catch ( do -- putStrLn $ "Trying value at offset " ++ show off let (v,rest,off') = runGetState (ls_get strs) input off evaluate rest - when retrying $ - putStrLn $ "Succesfully read value at position " ++ show off + when (off /= orig_off) $ + putStrLn $ "Skipped from " ++ show orig_off ++ ", succesful read at position " ++ show off ++ ", lost " ++ show (off - orig_off) ++ " bytes." return (Just (v,rest,off')) ) ( \e -> do @@ -84,8 +95,7 @@ if BS.length input <= 1 then do putStrLn $ "End of file reached" return Nothing - else do putStrLn $ "Trying at position " ++ show (off+1) ++ "." - tryGet prev True (BS.tail input) (off+1) + else do tryGet prev (BS.tail input) (off+1) orig_off ) where strs = maybe [] listOfStrings prev diff --git a/src/UpgradeLog1.hs b/src/UpgradeLog1.hs --- a/src/UpgradeLog1.hs +++ b/src/UpgradeLog1.hs @@ -57,6 +57,6 @@ upgrade = map $ \(TimeLogEntry a b c) -> D.TimeLogEntry a b (upgradeCD c) upgradeCD :: CaptureData -> D.CaptureData -upgradeCD (CaptureData a b) = D.CaptureData (map (\(b,s1,s2) -> (b, T.pack s1, T.pack s2)) a) b +upgradeCD (CaptureData a b) = D.CaptureData (map (\(b,s1,s2) -> (b, T.pack s1, T.pack s2)) a) b (T.pack "") diff --git a/src/capture-main.hs b/src/capture-main.hs --- a/src/capture-main.hs +++ b/src/capture-main.hs @@ -17,11 +17,13 @@ import System.Environment import Data.Maybe import Data.Version (showVersion) +import Data.Time.LocalTime import Capture import TimeLog import UpgradeLog1 import CommonStartup +import DumpFormat import Paths_arbtt (version) @@ -29,12 +31,14 @@ data Options = Options { optSampleRate :: Integer , optLogFile :: String + , optDump :: Bool } defaultOptions :: FilePath -> Options defaultOptions dir = Options { optSampleRate = 60 , optLogFile = dir "capture.log" + , optDump = False } versionStr = "arbtt-capture " ++ showVersion version @@ -60,6 +64,9 @@ , Option "r" ["sample-rate"] (ReqArg (\arg opt -> return opt { optSampleRate = read arg }) "RATE") "set the sample rate in seconds (default: 60)" + , Option "d" ["dump"] + (NoArg (\opt -> return opt { optDump = True })) + "dump one sample to standard out, instead of modifying the log file" ] -- | This is very raw, someone ought to improve this @@ -88,8 +95,13 @@ dir <- getAppUserDataDirectory "arbtt" flags <- foldl (>>=) (return (defaultOptions dir)) actions - createDirectoryIfMissing False dir - lockFile (optLogFile flags) - upgradeLogFile1 (optLogFile flags) - setupCapture - runLogger (optLogFile flags) (optSampleRate flags * 1000) captureData + if optDump flags then do + setupCapture + tz <- getCurrentTimeZone + captureData >>= mkTimeLogEntry (optSampleRate flags * 1000) >>= dumpSample tz + else do + createDirectoryIfMissing False dir + lockFile (optLogFile flags) + upgradeLogFile1 (optLogFile flags) + setupCapture + runLogger (optLogFile flags) (optSampleRate flags * 1000) captureData diff --git a/src/dump-main.hs b/src/dump-main.hs --- a/src/dump-main.hs +++ b/src/dump-main.hs @@ -9,19 +9,27 @@ import Data.Version (showVersion) import Data.Maybe import Control.Monad +import Data.Char +import Data.List.TakeR +import Data.Time.LocalTime import TimeLog import Data import CommonStartup +import DumpFormat import Paths_arbtt (version) data Options = Options { optLogFile :: String + , optFormat :: DumpFormat + , optLast :: Maybe Int } defaultOptions dir = Options { optLogFile = dir "capture.log" + , optFormat = DFHuman + , optLast = Nothing } @@ -45,6 +53,24 @@ , Option "f" ["logfile"] (ReqArg (\arg opt -> return opt { optLogFile = arg }) "FILE") "use this file instead of ~/.arbtt/capture.log" + , Option "t" ["format"] + (ReqArg (\arg opt -> + case readDumpFormat arg of + Just fm -> return $ opt { optFormat = fm} + Nothing -> do + hPutStrLn stderr ("Invalid format \"" ++ arg ++ "\".") + hPutStr stderr (usageInfo header options) + exitFailure) "FORMAT") + "output format, one of Human (default), Show or JSON " + , Option "l" ["last"] + (ReqArg (\arg opt -> + case reads arg of + [(n, "")] | n >= 0 -> return $ opt { optLast = Just n } + _ -> do + hPutStrLn stderr ("Invalid number \"" ++ arg ++ "\".") + hPutStr stderr (usageInfo header options) + exitFailure) "NUMBER") + "only dump the last NUMBER of samples." ] main = do @@ -60,4 +86,10 @@ flags <- foldl (>>=) (return (defaultOptions dir)) actions captures <- readTimeLog (optLogFile flags) :: IO (TimeLog CaptureData) - mapM_ print captures + + captures <- case optLast flags of + Nothing -> return captures + Just n -> return $ takeR n captures + + tz <- getCurrentTimeZone + dumpSamples tz (optFormat flags) captures diff --git a/src/recover-main.hs b/src/recover-main.hs --- a/src/recover-main.hs +++ b/src/recover-main.hs @@ -66,3 +66,4 @@ captures <- recoverTimeLog (optInFile flags) :: IO (TimeLog CaptureData) writeTimeLog (optOutFile flags) captures + putStrLn $ "Wrote data recovered from " ++ optInFile flags ++ " to " ++ optOutFile flags diff --git a/src/stats-main.hs b/src/stats-main.hs --- a/src/stats-main.hs +++ b/src/stats-main.hs @@ -6,7 +6,7 @@ import System.Exit import System.IO import Control.Monad -import qualified Data.MyText as T +import Data.Maybe import Data.Char (toLower) import Text.Printf import Data.Version (showVersion) @@ -17,18 +17,21 @@ import System.Posix.Files import System.ProgressBar import TermSize +import qualified Data.MyText as T import TimeLog import Categorize import Stats import CommonStartup import LeftFold +import DumpFormat import Paths_arbtt (version) data Options = Options { optReports :: [Report] , optFilters :: [Filter] + , optRepeater :: [Repeater] , optAlsoInactive :: Bool , optReportOptions :: ReportOptions , optLogFile :: String @@ -39,6 +42,7 @@ defaultOptions dir = Options { optReports = [] , optFilters = [] + , optRepeater = [] , optAlsoInactive = False , optReportOptions = defaultReportOptions , optLogFile = dir "capture.log" @@ -120,21 +124,35 @@ reports = report : optReports opt in return opt { optReports = reports }) "TAG") "list intervals of tag or category TAG" + , Option "" ["dump-samples"] + (NoArg (\opt -> let reports = DumpSamples : optReports opt + in return opt { optReports = reports })) + "Dump the raw samples and tags." , Option "" ["output-format"] (ReqArg (\arg opt -> let ro = (optReportOptions opt) { roReportFormat = readReportFormat arg } in return opt { optReportOptions = ro }) "FORMAT") "one of: text, csv (comma-separated values), tsv (TAB-separated values) (default: Text)" + , Option "" ["for-each"] + (ReqArg (\arg opt -> let repeater = readRepeater arg : optRepeater opt + in return opt { optRepeater = repeater }) "PERIOD") + "one of: day, month, year" ] +readRepeater :: String -> Repeater +readRepeater arg = + case map toLower arg of + "day" -> ByDay + "month" -> ByMonth + "year" -> ByYear + _ -> error ("Unsupported parameter to --for-each: '" ++ arg ++ "'") + readReportFormat :: String -> ReportFormat readReportFormat arg = - case (tolower arg) of + case map toLower arg of "text" -> RFText "csv" -> RFCSV "tsv" -> RFTSV _ -> error ("Unsupported report output format: '" ++ arg ++ "'") - where - tolower = map toLower main :: IO () main = do @@ -158,18 +176,22 @@ timelog <- BS.readFile (optLogFile flags) size <- fileSize <$> getFileStatus (optLogFile flags) + isTerm <- hIsTerminalDevice stderr - hSetBuffering stderr NoBuffering - trackedTimelog <- trackProgressWithChunkSize (fromIntegral size `div` 100) (\_ b -> do - (_height, width) <- getTermSize - hPutChar stderr '\r' - hPutStr stderr $ - mkProgressBar (msg "Processing data") percentage (fromIntegral width) (fromIntegral b) (fromIntegral size) - when (fromIntegral b >= fromIntegral size) $ do - hPutChar stderr '\r' - hPutStr stderr (replicate width ' ') + trackedTimelog <- case isTerm of + True -> do + hSetBuffering stderr NoBuffering + trackProgressWithChunkSize (fromIntegral size `div` 100) (\_ b -> do + (_height, width) <- getTermSize hPutChar stderr '\r' - ) timelog + hPutStr stderr $ + mkProgressBar (msg "Processing data") percentage (fromIntegral width) (fromIntegral b) (fromIntegral size) + when (fromIntegral b >= fromIntegral size) $ do + hPutChar stderr '\r' + hPutStr stderr (replicate width ' ') + hPutChar stderr '\r' + ) timelog + False -> return timelog let captures = parseTimeLog trackedTimelog let allTags = categorizer captures @@ -178,19 +200,24 @@ exitFailure let filters = (if optAlsoInactive flags then id else (defaultFilter:)) $ optFilters flags - let reps = case optReports flags of {[] -> [TotalTime]; reps -> reverse reps } + let rep = case optReports flags of + [] -> TotalTime + [x] -> x + _ -> error "Please specify exactly one report to generate" + let repeater = foldr (.) id $ map processRepeater (optRepeater flags) + -- These are defined here, but of course only evaluated when any report -- refers to them. Some are needed by more than one report, which is then -- advantageous. let opts = optReportOptions flags - let (c,results) = runLeftFold (filterPredicate filters `filterWith` - (pure (,) <*> prepareCalculations <*> processReports opts c reps)) allTags + let fold = filterPredicate filters `adjoin` repeater (processReport opts rep) + let result = runLeftFold fold allTags - -- Force the results a bit, to ensure the progress bar to be shown before the titel - c `seq` return () + -- Force the results a bit, to ensure the progress bar to be shown before the title + result `seq` return () - renderReport opts (MultpleReportResults results) + renderReport opts result {- import Data.Accessor diff --git a/tests/categorize.cfg b/tests/categorize.cfg new file mode 100644 --- /dev/null +++ b/tests/categorize.cfg @@ -0,0 +1,25 @@ +-- This defines some aliases, to make the reports look nicer: +aliases ( + "sun-awt-X11-XFramePeer" -> "java", + "sun-awt-X11-XDialogPeer" -> "java", + "sun-awt-X11-XWindowPeer" -> "java", + ) + +-- A rule that probably everybody wants. Being inactive for over a minute +-- causes this sample to be ignored by default. +$idle > 60 ==> tag inactive, + +-- Simple rule that just tags the current program +tag Program:$current.program, + +-- To be able to match on the time of day, I introduce tags for that as well +$time >= 2:00 && $time < 8:00 ==> tag time-of-day:night, +$time >= 8:00 && $time < 12:00 ==> tag time-of-day:morning, +$time >= 12:00 && $time < 14:00 ==> tag time-of-day:lunchtime, +$time >= 14:00 && $time < 18:00 ==> tag time-of-day:afternoon, +$time >= 18:00 && $time < 22:00 ==> tag time-of-day:evening, +$time >= 22:00 || $time < 2:00 ==> tag time-of-day:late-evening, + +-- This tag always refers to the last 24h +$sampleage <= 24:00 ==> tag last-day, + diff --git a/tests/issue4.cfg b/tests/issue4.cfg new file mode 100644 --- /dev/null +++ b/tests/issue4.cfg @@ -0,0 +1,5 @@ +-- Firefox +current window $program == "program" ==> +if current window $title =~ /^(aaa)/ then tag Cat:$1 else +if current window $title =~ /^(aa)/ then tag Cat:$1 else +if current window $title =~ /^(a)/ then tag Cat:$1 else tag None diff --git a/tests/issue5.cfg b/tests/issue5.cfg new file mode 100644 --- /dev/null +++ b/tests/issue5.cfg @@ -0,0 +1,3 @@ +current window $title =~ /^aaa/ ==> tag A3; +current window $title =~ /^aa/ ==> tag A2; +current window $title =~ /^a/ ==> tag A1 diff --git a/tests/small.cfg b/tests/small.cfg new file mode 100644 --- /dev/null +++ b/tests/small.cfg @@ -0,0 +1,4 @@ +current window $title =~ m/arbtt/ ==> tag arbtt, + +$time < 14:00 ==> tag before_14 + diff --git a/tests/small.log b/tests/small.log new file mode 100644 Binary files /dev/null and b/tests/small.log differ diff --git a/tests/small_borked.log b/tests/small_borked.log new file mode 100644 Binary files /dev/null and b/tests/small_borked.log differ diff --git a/tests/small_borked_recover.out b/tests/small_borked_recover.out new file mode 100644 Binary files /dev/null and b/tests/small_borked_recover.out differ diff --git a/tests/small_dump.out b/tests/small_dump.out new file mode 100644 --- /dev/null +++ b/tests/small_dump.out @@ -0,0 +1,3 @@ +TimeLogEntry {tlTime = 2010-03-20 13:59:15.075576 UTC, tlRate = 60000, tlData = CaptureData {cWindows = [(False,"stats-main.hs (~/darcs/arbtt/src) - GVIM","gvim"),(False,"`ghci' mrtrac@curie:~ ","urxvt"),(False,"`irssi' mrtrac@curie:~ ","urxvt"),(True,"mrtrac@curie:~/darcs/arbtt ","urxvt"),(False,"`mutt' mrtrac@curie:~ ","urxvt"),(False,"HackageDB: network-bytestring-0.1.2.1 - Vimperator","Navigator")], cLastActivity = 2909, cDesktop = ""}} +TimeLogEntry {tlTime = 2010-03-20 14:00:15.157669 UTC, tlRate = 60000, tlData = CaptureData {cWindows = [(False,"stats-main.hs (~/darcs/arbtt/src) - GVIM","gvim"),(False,"`ghci' mrtrac@curie:~ ","urxvt"),(False,"`irssi' mrtrac@curie:~ ","urxvt"),(True,"mrtrac@curie:~/darcs/arbtt ","urxvt"),(False,"`mutt' mrtrac@curie:~ ","urxvt"),(False,"HackageDB: network-bytestring-0.1.2.1 - Vimperator","Navigator")], cLastActivity = 557, cDesktop = ""}} +TimeLogEntry {tlTime = 2010-03-20 14:01:15.220521 UTC, tlRate = 60000, tlData = CaptureData {cWindows = [(False,"stats-main.hs (~/darcs/arbtt/src) - GVIM","gvim"),(False,"`ghci' mrtrac@curie:~ ","urxvt"),(False,"`irssi' mrtrac@curie:~ ","urxvt"),(True,"mrtrac@curie:~/darcs/arbtt ","urxvt"),(False,"`mutt' mrtrac@curie:~ ","urxvt"),(False,"HackageDB: network-bytestring-0.1.2.1 - Vimperator","Navigator")], cLastActivity = 58004, cDesktop = ""}} diff --git a/tests/small_import.in b/tests/small_import.in new file mode 100644 --- /dev/null +++ b/tests/small_import.in @@ -0,0 +1,3 @@ +TimeLogEntry {tlTime = 2010-03-20 13:59:15.075576 UTC, tlRate = 60000, tlData = CaptureData {cWindows = [(False,"stats-main.hs (~/darcs/arbtt/src) - GVIM","gvim"),(False,"`ghci' mrtrac@curie:~ ","urxvt"),(False,"`irssi' mrtrac@curie:~ ","urxvt"),(True,"mrtrac@curie:~/darcs/arbtt ","urxvt"),(False,"`mutt' mrtrac@curie:~ ","urxvt"),(False,"HackageDB: network-bytestring-0.1.2.1 - Vimperator","Navigator")], cLastActivity = 2909, cDesktop = ""}} +TimeLogEntry {tlTime = 2010-03-20 14:00:15.157669 UTC, tlRate = 60000, tlData = CaptureData {cWindows = [(False,"stats-main.hs (~/darcs/arbtt/src) - GVIM","gvim"),(False,"`ghci' mrtrac@curie:~ ","urxvt"),(False,"`irssi' mrtrac@curie:~ ","urxvt"),(True,"mrtrac@curie:~/darcs/arbtt ","urxvt"),(False,"`mutt' mrtrac@curie:~ ","urxvt"),(False,"HackageDB: network-bytestring-0.1.2.1 - Vimperator","Navigator")], cLastActivity = 557, cDesktop = ""}} +TimeLogEntry {tlTime = 2010-03-20 14:01:15.220521 UTC, tlRate = 60000, tlData = CaptureData {cWindows = [(False,"stats-main.hs (~/darcs/arbtt/src) - GVIM","gvim"),(False,"`ghci' mrtrac@curie:~ ","urxvt"),(False,"`irssi' mrtrac@curie:~ ","urxvt"),(True,"mrtrac@curie:~/darcs/arbtt ","urxvt"),(False,"`mutt' mrtrac@curie:~ ","urxvt"),(False,"HackageDB: network-bytestring-0.1.2.1 - Vimperator","Navigator")], cLastActivity = 58004, cDesktop = ""}} diff --git a/tests/small_import.out b/tests/small_import.out new file mode 100644 Binary files /dev/null and b/tests/small_import.out differ diff --git a/tests/small_stats.out b/tests/small_stats.out new file mode 100644 --- /dev/null +++ b/tests/small_stats.out @@ -0,0 +1,5 @@ +Total time per tag +================== +______Tag_|___Time_|_Percentage_ + arbtt | 3m00s | 100.00 +before_14 | 1m00s | 33.33 diff --git a/tests/small_stats_csv.out b/tests/small_stats_csv.out new file mode 100644 --- /dev/null +++ b/tests/small_stats_csv.out @@ -0,0 +1,3 @@ +Tag,Time,Percentage +arbtt,0:03:00,100.00 +before_14,0:01:00,33.33 diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} + +import Test.Tasty hiding (defaultMain) +import Test.Tasty.Golden.Manage +import Test.Tasty.Golden +import Test.Tasty.HUnit +import Test.HUnit +import System.Process.ByteString.Lazy +import qualified Data.ByteString.Lazy as B +import Control.Monad +import Control.Exception +import Data.Typeable +import System.Exit +import System.Posix.Env + +import Categorize +import TimeLog +import Data + +main = do + putEnv "TZ=UTC" -- to make tests reproducible + defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [goldenTests, regressionTests] + +regressionTests :: TestTree +regressionTests = testGroup "Regression tests" + [ testCase "Issue #4" $ do + cat <- readCategorizer "tests/issue4.cfg" + let sample = TimeLogEntry undefined 0 (CaptureData [(True, "aa", "program")] 0 "") + let [TimeLogEntry _ _ (_,acts)] = cat [sample] + [Activity (Just "Cat") "aa"] @=? acts + return () + , testCase "Issue #5" $ do + cat <- readCategorizer "tests/issue5.cfg" + let sample = TimeLogEntry undefined 0 (CaptureData [(True, "aa", "program")] 0 "") + let [TimeLogEntry _ _ (_,acts)] = cat [sample] + [Activity Nothing "A2"] @=? acts + return () + ] + + +goldenTests :: TestTree +goldenTests = testGroup "Golden tests" + [ goldenVsString "dump small" + "tests/small_dump.out" $ + run "dist/build/arbtt-dump/arbtt-dump" ["-f","tests/small.log", "-t", "Show"] B.empty + , goldenVsFile "import small" + "tests/small_import.out" "tests/small_import.out.actual" $ void $ + B.readFile "tests/small_import.in" >>= + run "dist/build/arbtt-import/arbtt-import" ["-f","tests/small_import.out.actual"] + , goldenVsFile "recover small" + "tests/small_borked_recover.out" "tests/small_borked_recover.out.actual" $ void $ + run "dist/build/arbtt-recover/arbtt-recover" ["-i","tests/small_borked_recover.out", "-o", "tests/small_borked_recover.out.actual"] B.empty + , goldenVsString "stats small" + "tests/small_stats.out" $ + run "dist/build/arbtt-stats/arbtt-stats" ["--logfile", "tests/small.log", "--categorize", "tests/small.cfg"] B.empty + , goldenVsString "stats small csv" + "tests/small_stats_csv.out" $ + run "dist/build/arbtt-stats/arbtt-stats" ["--logfile", "tests/small.log", "--categorize", "tests/small.cfg", "--output-format", "csv"] B.empty + , goldenVsString "stats small unicode" + "tests/unicode_stats.out" $ + run "dist/build/arbtt-stats/arbtt-stats" ["--logfile", "tests/unicode.log", "--categorize", "tests/unicode.cfg"] B.empty + ] + + +run :: FilePath -> [FilePath] -> B.ByteString -> IO B.ByteString +run cmd args stdin = do + (ex,stdout,stderr) <- readProcessWithExitCode cmd args stdin + unless (B.null stderr) $ throwIO $ StderrException stderr + case ex of + ExitSuccess -> return stdout + ExitFailure r -> throwIO $ ExitCodeException r + +data StderrException = StderrException B.ByteString + deriving (Show, Typeable) +data ExitCodeException = ExitCodeException Int + deriving (Show, Typeable) + +instance Exception StderrException +instance Exception ExitCodeException diff --git a/tests/unicode.cfg b/tests/unicode.cfg new file mode 100644 --- /dev/null +++ b/tests/unicode.cfg @@ -0,0 +1,3 @@ +any window $title =~ /aäα/ ==> tag ok, +any window $title =~ /aäƱ/ ==> tag notok, + diff --git a/tests/unicode.log b/tests/unicode.log new file mode 100644 Binary files /dev/null and b/tests/unicode.log differ diff --git a/tests/unicode_stats.out b/tests/unicode_stats.out new file mode 100644 --- /dev/null +++ b/tests/unicode_stats.out @@ -0,0 +1,4 @@ +Total time per tag +================== +Tag_|___Time_|_Percentage_ + ok | 1m00s | 100.00