arbtt 0.9.0.13 → 0.10
raw patch · 24 files changed
+591/−426 lines, 24 filesdep +attoparsecdep +conduitdep +conduit-extradep ~X11dep ~basedep ~containersbinary-added
Dependencies added: attoparsec, conduit, conduit-extra, exceptions, mtl
Dependency ranges changed: X11, base, containers, tasty, terminal-progress-bar
Files
- README.md +33/−14
- arbtt.cabal +22/−15
- categorize.cfg +9/−3
- doc/arbtt.xml +110/−23
- src/Capture/X11.hs +7/−1
- src/Categorize.hs +131/−127
- src/DumpFormat.hs +21/−3
- src/Graphics/X11/XScreenSaver.hsc +0/−187
- src/LockFile.hs +25/−0
- src/Stats.hs +1/−1
- src/capture-main.hs +3/−19
- src/dump-main.hs +2/−2
- src/import-main.hs +106/−8
- src/recover-main.hs +2/−2
- src/stats-main.hs +2/−2
- tests/categorize.cfg +3/−0
- tests/condition_bindings.cfg +9/−0
- tests/condition_bindings_stats.out +6/−0
- tests/small_dump_json.out +4/−0
- tests/small_import_json.in +5/−0
- tests/small_import_json.out binary
- tests/small_import_json_list.in +8/−0
- tests/small_import_json_list.out binary
- tests/test.hs +82/−19
README.md view
@@ -22,10 +22,34 @@ $ 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.+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 use macOS, you can use `launchd` for this.+ Create a .plist file like the following+ (with the path changed to match where arbtt-capture is located in your system):+ + ```xml+ <?xml version="1.0" encoding="UTF-8"?>+ <!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">+ <plist version="1.0">+ <dict>+ <key>Label</key>+ <string>com.foo.arbtt</string>+ <key>Program</key>+ <string>/path/to/arbtt-capture</string>+ <key>RunAtLoad</key>+ <true/>+ <key>KeepAlive</key>+ <true/>+ </dict>+ </plist>+ ```+ and place it in `~/LaunchAgents/com.foo.arbtt.plist`.+ (You can replace "foo" with anything, such as your username)+ This will ensure `arbtt-capture` is started whenever you log in. 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.@@ -37,21 +61,16 @@ 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/)+[online version of the User’s Guide](http://arbtt.nomeata.de/doc/users_guide/index.html) 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+latest source at the git repository at+<https://github.com/nomeata/arbtt> or+<https://bitbucket.org/nomeata/arbtt>. User and Developer discussion happens on the arbtt mailing list: arbtt@lists.nomeata.de@@ -59,7 +78,7 @@ http://lists.nomeata.de/mailman/listinfo/arbtt The issue tracker is hosted on bitbucket:- https://bitbucket.org/nomeata/arbtt/issues+ <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.)
arbtt.cabal view
@@ -1,5 +1,5 @@ name: arbtt-version: 0.9.0.13+version: 0.10 license: GPL license-file: LICENSE category: Desktop@@ -40,8 +40,8 @@ main-is: capture-main.hs hs-source-dirs: src build-depends:- base >= 4.7 && < 4.10,- filepath, directory, transformers, utf8-string,+ base >= 4.7 && < 4.11,+ filepath, directory, transformers, utf8-string, strict, containers, aeson >= 0.6 && < 1.3, binary >= 0.5, bytestring, deepseq@@ -60,6 +60,7 @@ TimeLog UpgradeLog1 LeftFold+ LockFile ghc-options: -rtsopts @@ -85,20 +86,18 @@ Graphics.OSX.Window System.Locale.SetLocale else- extra-libraries: Xss other-modules: Capture.X11- Graphics.X11.XScreenSaver System.Locale.SetLocale build-depends:- X11 > 1.4.4+ X11 > 1.6.1 default-language: Haskell98 executable arbtt-stats main-is: stats-main.hs hs-source-dirs: src build-depends:- base >= 4.7 && < 4.10,+ base >= 4.7 && < 4.11, parsec == 3.*, containers == 0.5.*, pcre-light,@@ -108,7 +107,8 @@ aeson >= 0.6 && < 1.3, array == 0.4.* || == 0.5.*, terminal-progress-bar,- bytestring-progress+ bytestring-progress,+ mtl if !os(windows) build-depends: unix@@ -144,7 +144,7 @@ main-is: dump-main.hs hs-source-dirs: src build-depends:- base >= 4.7 && < 4.10,+ base >= 4.7 && < 4.11, parsec == 3.*, containers == 0.5.*, aeson >= 0.6 && < 1.3,@@ -181,10 +181,15 @@ main-is: import-main.hs hs-source-dirs: src build-depends:- base >= 4.7 && < 4.10,+ base >= 4.7 && < 4.11, parsec == 3.*, containers == 0.5.*, binary >= 0.5,+ aeson >= 0.6 && < 1.3,+ conduit == 1.2.*,+ conduit-extra == 1.2.*,+ exceptions == 0.8.*,+ attoparsec == 0.13.*, deepseq, bytestring, utf8-string, strict, transformers, directory, filepath @@ -202,6 +207,7 @@ Data.Binary.StringRef CommonStartup TimeLog+ LockFile ghc-options: -rtsopts if os(windows) cpp-options: -DWIN32@@ -214,7 +220,7 @@ main-is: recover-main.hs hs-source-dirs: src build-depends:- base >= 4.7 && < 4.10,+ base >= 4.7 && < 4.11, containers == 0.5.*, binary >= 0.5, deepseq, bytestring, utf8-string,@@ -259,8 +265,8 @@ Text.Regex.PCRE.Light.Text TimeLog Build-depends:- base >= 4.7 && < 4.10- , tasty >= 0.7 && < 0.12+ base >= 4.7 && < 4.11+ , tasty >= 0.7 && < 0.13 , tasty-golden >= 2.2.0.2 && < 2.4 , tasty-hunit >= 0.2 && < 0.11 , process-extras >= 0.2 && < 0.8@@ -273,6 +279,7 @@ , containers == 0.5.* , pcre-light , transformers+ , mtl if !os(windows) build-depends: unix@@ -284,5 +291,5 @@ default-language: Haskell98 source-repository head- type: darcs- location: http://darcs.nomeata.de/arbtt+ type: git+ location: https://github.com/nomeata/arbtt
categorize.cfg view
@@ -20,9 +20,10 @@ -- A rule that matches on a list of strings current window $program == ["Navigator","galeon"] ==> tag Web, -current window $program == "sun-awt-X11-XFramePeer" &&-current window $title == "I3P"- ==> tag Program:I3P,+-- Use condition bindings to reduce duplication+condition isJava = current window $program ==+ ["sun-awt-X11-XFramePeer", "sun-awt-X11-XDialogPeer", "sun-awt-X11-XWindowPeer"]+in $isJava && current window $title == "I3P" ==> tag Program:I3P, current window $program == "sun-awt-X11-XDialogPeer" && current window $title == " " &&@@ -125,4 +126,9 @@ month $date == 1 ==> tag month:January, month $date == 2 ==> tag month:February, year $date == 2010 ==> tag year:2010,++-- “$now” evaluates to the current time+day of month $now == day of month $date ==> tag current-day,+month $now == month $date ==> tag current-month,+year $now == year $date ==> tag current-year, -}
doc/arbtt.xml view
@@ -33,11 +33,23 @@ <contrib>Contributor</contrib> <email>muharem@linux.com</email> </author>+ <author id="hauck">+ <firstname>Markus</firstname>+ <surname>Hauck</surname>+ <contrib>Contributor</contrib>+ <email>markus1189@gmail.com</email>+ </author>+ <author id="thomasz">+ <firstname>Thomasz</firstname>+ <surname>Miąsko</surname>+ <contrib>Contributor</contrib>+ <email>tomasz.miasko@gmail.com</email>+ </author> <author id="waldir"> <firstname>Waldir</firstname> <surname>Pimenta</surname> <contrib>Documentation writer</contrib>- <email>waldir@email.com</email>+ <email>waldyrious@gmail.com</email> </author> <author id="gwern"> <firstname>Gwern</firstname>@@ -265,7 +277,7 @@ </para> <para>- The variable <literal>$date</literal> referes to the date and time of the+ The variable <literal>$date</literal> refers to the date and time of the recorded sample. It can be compared with date literals in the form YYYY-MM-DD (which stand for midnight, so <programlisting>$date == 2001-01-01</programlisting> will not do what you want, but@@ -318,6 +330,20 @@ parentheses. </para> + <para>+ You can define short-hand names for conditions using+ <literal>condition</literal>:+ <programlisting>+ condition arbtt = current window $title =~ m/arbtt/ in {+ $arbtt && $time < 14:00 ==> tag arbtt-morning,+ $arbtt && $time > 14:00 ==> tag arbtt-afternoon+ }+ </programlisting>+ Everything that is a valid condition is assignable and you can+ reference bound variables in rules by prefixing them with a+ dollar (<literal>$</literal>).+ </para>+ </sect2> <sect2>@@ -368,6 +394,7 @@ <rhs> <quote>tag</quote> <nonterminal def="#g-tag"/> </rhs>+ <rhs><nonterminal def="#g-condition"/></rhs> </production> <production id="g-cond">@@ -402,6 +429,7 @@ <nonterminal def="#g-date"/> </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> </production> <production id="g-string">@@ -414,7 +442,8 @@ </production> <production id="g-listofstring">- <lhs>ListOfString</lhs>+ <lhs>+ ListOfString</lhs> <rhs> <quote>"</quote> string literal <quote>"</quote> </rhs> <rhs> <quote>"</quote> string literal <quote>"</quote> , <nonterminal def="#g-listofstring"/> </rhs> </production>@@ -432,7 +461,7 @@ <production id="g-date"> <lhs>Date</lhs> <rhs> <quote>$date</quote> </rhs>- <!-- <rhs> <quote>$now</quote> </rhs> -->+ <rhs> <quote>$now</quote> </rhs> </production> <production id="g-timediff">@@ -463,12 +492,18 @@ <rhs> <quote>"</quote> <nonterminal def="#g-regex"/> <quote>"</quote> , <nonterminal def="#g-listofregex"/> </rhs> </production> - <production id="g-cmpop">- <lhs>CmpOp</lhs>- <rhs><quote><=</quote> | <quote><</quote> | <quote>==</quote>- | <quote>></quote> | <quote>>=</quote></rhs>- </production>+ <production id="g-cmpop">+ <lhs>CmpOp</lhs>+ <rhs><quote><=</quote> | <quote><</quote> |+ <quote>==</quote> | <quote>!=</quote>+ | <quote>></quote> | <quote>>=</quote></rhs>+ </production> + <production id="g-condition">+ <lhs>ConditionBinding</lhs>+ <rhs><quote>condition</quote> Literal <quote>=</quote> <nonterminal def="#g-cond"/> <quote>in</quote> <nonterminal def="#g-rule"/></rhs>+ </production>+ </productionset> </figure> <para>@@ -1016,11 +1051,11 @@ <sect1 id="contributed"> <title>Contributed tools</title> <para>- Due to the export facilities of arbtt (as explained in <xref- linkend="external-processing"/>), tools analyzing arbtt’s data can be- developed independently. This section lists those that we are aware of. If- you create a tool of your own, or find one somewhere, please tell us on the- mailing list (see <xref linkend="copyright"/>).+ Due to the import and export facilities of arbtt (as explained in <xref+ linkend="external-processing"/>), tools producing and analyzing arbtt’s+ data can be developed independently. This section lists those that we are+ aware of. If you create a tool of your own, or find one somewhere, please+ tell us on the mailing list (see <xref linkend="copyright"/>). </para> <sect2> <title>arbtt-graph</title>@@ -1032,6 +1067,15 @@ You can find his tool on <ulink url="https://github.com/rejuvyesh/arbtt-graph">https://github.com/rejuvyesh/arbtt-graph</ulink>. </para> </sect2>+ <sect2>+ <title>arbtt-capture for GNOME Shell</title>+ <para>+ An arbtt-capture implemented as a GNOME Shell extension. Its main value+ proposition is compatibility with Wayland (but it is compatible with+ traditional X Window System as well). You can find it on+ <ulink url="https://github.com/tmiasko/arbtt-capture">https://github.com/tmiasko/arbtt-capture</ulink>.+ </para>+ </sect2> </sect1> <sect1 id="references"> <title>Program references</title>@@ -1068,6 +1112,10 @@ various textual formats. Its command line reference is given in <xref linkend="arbtt-dump"/>.</para> + <para>The textual form can be imported back using+ <command>arbtt-import</command>. Its command line reference is given in+ <xref linkend="arbtt-import"/>.</para>+ <para>If <command>arbtt-capture</command> crashes it might be that the log file is not readable any more. In some cases, this can be fixed using the (relatively raw) <command>arbtt-recover</command> tool. Its command line@@ -1528,7 +1576,7 @@ </refsect1> </refentry> - <refentry>+ <refentry id="arbtt-import"> <refnamediv> <refname>arbtt-import</refname> <refpurpose>imports dumped arbtt data samples</refpurpose>@@ -1543,15 +1591,19 @@ <refsect1><title>Description</title> <para>- <command>arbtt-import</command> expects the output of- <command>arbtt-dump</command> on the standard input and saves them as the- logfile or the specified file.+ <command>arbtt-import</command> reads data from standard input and adds+ the entries to the logfile. It supports the <literal>Show</literal>+ format as well as the <literal>JSON</literal> format, and can be used in+ a streaming fashion (i.e. it will write entries as they are read from+ standard input). </para>+ <para>- This program would completely override the existing file, therefore it+ By default, this program completely overrides the existing file, therefore it will refuse to work if the log file already exists. If you want to overwrite a file, please delete it before running- <command>arbtt-import</command>.+ <command>arbtt-import</command>. If you want to extend an existing file,+ use the <option>--append</option> option. </para> </refsect1> @@ -1569,12 +1621,22 @@ <term><option>--version</option></term> <listitem><simpara>shows the version number, and exists.</simpara></listitem> </varlistentry>- <varlistentry>+ <varlistentry> <term><option>-f</option> <replaceable>FILE</replaceable></term> <term><option>--logfile</option> <replaceable>FILE</replaceable></term> <listitem><simpara>logfile to use instead of <filename>~/.arbtt/capture.log</filename></simpara></listitem>- </varlistentry>- </variablelist>+ </varlistentry>+ <varlistentry>+ <term><option>-a</option></term>+ <term><option>--append</option></term>+ <listitem><simpara>append the log file, if it already exists</simpara></listitem>+ </varlistentry>+ <varlistentry>+ <term><option>-t</option> <replaceable>FORMAT</replaceable></term>+ <term><option>--format</option> <replaceable>FORMAT</replaceable></term>+ <listitem><simpara>format to use, where <replaceable>FORMAT</replaceable> is one of <literal>show</literal> (the default) or <literal>JSON</literal>. The JSON format can either be a list of records (as dumped by <xref linkend="arbtt-dump"/>), or just one record after another (useful in streaming mode).</simpara></listitem>+ </varlistentry>+ </variablelist> </refsect1> <refsect1><title>Files</title> <variablelist>@@ -1716,6 +1778,31 @@ <para> The version history with changes relevant for the user is documented here. </para>++ <sect2 id="release-notes-0.10">+ <title>Version 0.10</title>+ <itemizedlist>+ <listitem>+ <para>+ Markus Hauck contributed the <literal>!=</literal> operator, the+ <quote>$now</quote> variable and the <literal>condition</literal>+ construct (as well as other code cleanup).+ </para>+ </listitem>+ <listitem>+ <para>+ The development repository migrated from darcs to git.+ </para>+ </listitem>+ <listitem>+ <para>+ The command <xref linkend="arbtt-import"/> now supports reading JSON+ records, and can be used to append to an exising log file in a+ steaming fasion.+ </para>+ </listitem>+ </itemizedlist>+ </sect2> <sect2 id="release-notes-0.9"> <title>Version 0.9</title>
src/Capture/X11.hs view
@@ -78,12 +78,18 @@ getProgramName :: Display -> Window -> IO String getProgramName dpy = fmap resName . getClassHint dpy +-- Returns a parent of a window or zero.+getParent :: Display -> Window -> IO Window+getParent dpy w = do+ (_, parent, _) <- queryTree dpy w `catchIOError` (const $ return (0,0,[]))+ return parent+ -- | Follows the tree of windows up until the condition is met or the root -- window is reached. followTreeUntil :: Display -> (Window -> Bool) -> Window -> IO Window followTreeUntil dpy cond = go where go w | cond w = return w- | otherwise = do (r,p,_) <- queryTree dpy w+ | otherwise = do p <- getParent dpy w if p == 0 then return w else go p
src/Categorize.hs view
@@ -1,51 +1,50 @@-{-# LANGUAGE Rank2Types, CPP #-}+{-# LANGUAGE Rank2Types, CPP, FlexibleContexts #-} module Categorize where import Data import qualified Text.Regex.PCRE.Light.Text as RE-import qualified Data.Map as M import qualified Data.MyText as T import Data.MyText (Text)+import Control.Applicative (empty, (<*)) import Control.Monad-import Control.Monad.Instances-import Control.Monad.Trans.Reader+import Control.Monad.Instances()+import Control.Monad.Trans.Reader hiding (local)+import Control.Monad.Reader.Class (local) import Control.Monad.Trans.Class import Data.Functor.Identity --import Text.Parsec-import Text.Parsec.Char-import Text.Parsec.Token-import Text.Parsec.Combinator-import Text.Parsec.Language-import Text.Parsec.ExprFail-import System.IO-import System.Exit-import Control.Applicative ((<*>),(<$>))+import Control.Applicative ((<$>)) import Control.DeepSeq+import Data.Char import Data.List+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map import Data.Maybe-import Data.Char-import Data.Time.Clock-import Data.Time.LocalTime import Data.Time.Calendar (toGregorian, fromGregorian) import Data.Time.Calendar.WeekDate (toWeekDate)+import Data.Time.Clock import Data.Time.Format (formatTime)+import Data.Time.LocalTime+import System.Exit+import System.IO+import Text.Show.Functions+import Text.Parsec+import Text.Parsec.ExprFail+import Text.Parsec.Token #if MIN_VERSION_time(1,5,0) import Data.Time.Format(defaultTimeLocale, iso8601DateFormat) #else import System.Locale (defaultTimeLocale, iso8601DateFormat) #endif import Debug.Trace-import Control.Arrow (second) import Text.Printf type Categorizer = TimeLog CaptureData -> TimeLog (Ctx, ActivityData) type Rule = Ctx -> ActivityData--type Parser = ParsecT String () (ReaderT TimeZone Identity)+type Environment = Map String Cond +type Parser = ParsecT String () (ReaderT (TimeZone, Environment) Identity) data Ctx = Ctx { cNow :: TimeLogEntry CaptureData@@ -54,11 +53,11 @@ , cSubsts :: [Text] , cCurrentTime :: UTCTime , cTimeZone :: TimeZone- }- deriving (Show)+ , conditionBindings :: Map String Cond+ } deriving Show instance NFData Ctx where- rnf (Ctx a b c d e f) = a `deepseq` b `deepseq` c `deepseq` e `deepseq` e `deepseq` f `deepseq` ()+ rnf (Ctx a b c d e f g) = a `deepseq` b `deepseq` c `deepseq` d `deepseq` e `deepseq` f `deepseq` g `deepseq` () type Cond = CtxFun [Text] @@ -76,31 +75,44 @@ newtype Cmp = Cmp (forall a. Ord a => a -> a -> Bool) +data DateVar = DvDate | DvNow++data TimeVar = TvTime | TvSampleAge++data NumVar = NvIdle++runParserStack :: Stream s (ReaderT r Identity) t+ => r+ -> ParsecT s () (ReaderT r Identity) a+ -> SourceName+ -> s+ -> Either ParseError a+runParserStack env p filename =+ runIdentity . flip runReaderT env . runParserT p () filename+ readCategorizer :: FilePath -> IO Categorizer-readCategorizer filename = do- h <- openFile filename ReadMode+readCategorizer filename = withFile filename ReadMode $ \h -> do hSetEncoding h utf8 content <- hGetContents h time <- getCurrentTime tz <- getCurrentTimeZone- case flip runReader tz $- runParserT (between (return ()) eof parseRules) () filename content of+ case runParserStack (tz, Map.empty) (between (return ()) eof parseRules) filename content of Left err -> do putStrLn "Parser error:" print err exitFailure- Right cat -> return $+ Right cat -> return (map (fmap (mkSecond (postpare . cat))) . prepare time tz) -applyCond :: String -> TimeZone -> TimeLogEntry (Ctx, ActivityData) -> Bool-applyCond s tz = - case flip runReader tz $ runParserT (do {c <- parseCond; eof ; return c}) () "commad line parameter" s of+applyCond :: String -> TimeZone -> Environment -> TimeLogEntry (Ctx, ActivityData) -> Bool+applyCond s tz env =+ case runParserStack (tz, env) (parseCond <* eof) "command line parameter" s of Left err -> error (show err) Right c -> isJust . c . fst . tlData prepare :: UTCTime -> TimeZone -> TimeLog CaptureData -> TimeLog Ctx prepare time tz = map go- where go now = now {tlData = Ctx now (findActive (cWindows (tlData now))) Nothing [] time tz }+ where go now = now {tlData = Ctx now (findActive (cWindows (tlData now))) Nothing [] time tz Map.empty } -- | Here, we filter out tags appearing twice, and make sure that only one of -- each category survives@@ -109,23 +121,32 @@ where go (Activity (Just c1) _) (Activity (Just c2) _) = c1 == c2 go a1 a2 = a1 == a2 -lang :: GenTokenParser String () (ReaderT TimeZone Identity)-lang = makeTokenParser $ LanguageDef+lang :: GenTokenParser String () (ReaderT (TimeZone, Environment) Identity)+lang = makeTokenParser LanguageDef { commentStart = "{-" , commentEnd = "-}" , commentLine = "--" , nestedComments = True , identStart = letter- , identLetter = alphaNum <|> oneOf "_'"- , opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"- , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"+ , identLetter = alphaNum <|> oneOf "_'"+ , opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"+ , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" , reservedOpNames= []- , reservedNames = []+ , reservedNames = [ "title"+ , "program"+ , "active"+ , "idle"+ , "time"+ , "sampleage"+ , "date"+ , "now"+ , "desktop"+ ] , caseSensitive = True } parseRules :: Parser Rule-parseRules = do +parseRules = do whiteSpace lang a <- option id (reserved lang "aliases" >> parens lang parseAliasSpecs) rb <- parseRulesBody@@ -147,17 +168,29 @@ return (s1,s2) parseRulesBody :: Parser Rule-parseRulesBody = do +parseRulesBody = do x <- parseRule- choice [ do comma lang+ choice [ do _ <- comma lang xs <- parseRule `sepEndBy1` comma lang return (matchAny (x:xs))- , do semi lang+ , do _ <- semi lang xs <- parseRule `sepEndBy1` semi lang return (matchFirst (x:xs)) , return x ] +withBinding :: String -> Cond -> Parser a -> Parser a+withBinding k v = local (\(tz,env) -> (tz, Map.insert k v env))++parseConditionBinding :: Parser Rule+parseConditionBinding = do+ _ <- reserved lang "condition"+ varname <- identifier lang+ _ <- reservedOp lang "="+ cond <- parseCond+ _ <- reserved lang "in"+ withBinding varname cond parseRule+ parseRule :: Parser Rule parseRule = choice [ braces lang parseRules@@ -174,13 +207,14 @@ return (ifThenElse cond rule1 rule2) , do reserved lang "tag" parseSetTag+ , parseConditionBinding ] parseCond :: Parser Cond parseCond = do cp <- parseCondExpr case cp of CondCond c -> return c- cp -> fail $ printf "Expression of type %s" (cpType cp)+ _ -> fail $ printf "Expression of type %s" (cpType cp) parseCondExpr :: Parser CondPrim parseCondExpr = buildExpressionParser [@@ -190,7 +224,7 @@ , Prefix (reserved lang "month" >> return evalMonth) , Prefix (reserved lang "year" >> return evalYear) , Prefix (reserved lang "format" >> return formatDate) ],- [ Infix (reservedOp lang "=~" >> return checkRegex) AssocNone + [ Infix (reservedOp lang "=~" >> return checkRegex) AssocNone , Infix (checkCmp <$> parseCmp) AssocNone ], [ Prefix (reserved lang "current window" >> return checkCurrentwindow)@@ -242,8 +276,7 @@ (cpType cp1) (cpType cp2) checkNot :: CondPrim -> Erring CondPrim-checkNot (CondCond getCnd) = Right $ CondCond $ do- liftM (maybe (Just []) (const Nothing)) getCnd+checkNot (CondCond getCnd) = Right . CondCond $ fmap (maybe (Just []) (const Nothing)) getCnd checkNot cp = Left $ printf "Cannot apply ! to an expression of type %s" (cpType cp)@@ -279,7 +312,7 @@ (cpType cp1) (cpType cp2) checkCurrentwindow :: CondPrim -> Erring CondPrim-checkCurrentwindow (CondCond cond) = Right $ CondCond $ \ctx -> +checkCurrentwindow (CondCond cond) = Right $ CondCond $ \ctx -> cond (ctx { cWindowInScope = cCurrentWindow ctx }) checkCurrentwindow cp = Left $ printf "Cannot apply current window to an expression of type %s"@@ -293,15 +326,20 @@ printf "Cannot apply current window to an expression of type %s" (cpType cp) +fst3 :: (a,b,c) -> a fst3 (a,_,_) = a++snd3 :: (a,b,c) -> b snd3 (_,b,_) = b++trd3 :: (a,b,c) -> c trd3 (_,_,c) = c -- Day of week is an integer in [1..7]. evalDayOfWeek :: CondPrim -> Erring CondPrim evalDayOfWeek (CondDate df) = Right $ CondInteger $ \ctx -> let tz = cTimeZone ctx in- (toInteger . trd3 . toWeekDate . localDay . utcToLocalTime tz) `liftM` df ctx+ (toInteger . trd3 . toWeekDate . localDay . utcToLocalTime tz) `fmap` df ctx evalDayOfWeek cp = Left $ printf "Cannot apply day of week to an expression of type %s, only to $date." (cpType cp)@@ -310,7 +348,7 @@ evalDayOfMonth :: CondPrim -> Erring CondPrim evalDayOfMonth (CondDate df) = Right $ CondInteger $ \ctx -> let tz = cTimeZone ctx in- (toInteger . trd3 . toGregorian . localDay . utcToLocalTime tz) `liftM` df ctx+ (toInteger . trd3 . toGregorian . localDay . utcToLocalTime tz) `fmap` df ctx evalDayOfMonth cp = Left $ printf "Cannot apply day of month to an expression of type %s, only to $date." (cpType cp)@@ -319,7 +357,7 @@ evalMonth :: CondPrim -> Erring CondPrim evalMonth (CondDate df) = Right $ CondInteger $ \ctx -> let tz = cTimeZone ctx in- (toInteger . snd3 . toGregorian . localDay . utcToLocalTime tz) `liftM` df ctx+ (toInteger . snd3 . toGregorian . localDay . utcToLocalTime tz) `fmap` df ctx evalMonth cp = Left $ printf "Cannot apply month to an expression of type %s, only to $date." (cpType cp)@@ -327,7 +365,7 @@ evalYear :: CondPrim -> Erring CondPrim evalYear (CondDate df) = Right $ CondInteger $ \ctx -> let tz = cTimeZone ctx in- (fst3 . toGregorian . localDay . utcToLocalTime tz) `liftM` df ctx+ (fst3 . toGregorian . localDay . utcToLocalTime tz) `fmap` df ctx evalYear cp = Left $ printf "Cannot apply year to an expression of type %s, only to $date." (cpType cp)@@ -336,7 +374,7 @@ formatDate :: CondPrim -> Erring CondPrim formatDate (CondDate df) = Right $ CondString $ \ctx -> let tz = cTimeZone ctx- local = utcToLocalTime tz `liftM` df ctx+ local = utcToLocalTime tz `fmap` df ctx in T.pack . formatTime defaultTimeLocale (iso8601DateFormat Nothing) <$> local formatDate cp = Left $ printf "Cannot format an expression of type %s, only $date." (cpType cp)@@ -347,6 +385,7 @@ (">", Cmp (>)), ("==",Cmp (==)), ("=", Cmp (==)),+ ("!=",Cmp (/=)), ("<", Cmp (<)), ("<=",Cmp (<=))] @@ -361,28 +400,24 @@ return $ CondRegexList (const (Just list)) ) <?> "list of regular expressions" ])- , char '$' >> choice + , char '$' >> choice [ do backref <- read <$> many1 digit return $ CondString (getBackref backref)- , do varname <- identifier lang - choice - [ do guard $ varname == "title"- return $ CondString (getVar "title")- , do guard $ varname == "program"- return $ CondString (getVar "program")- , do guard $ varname == "active"- return $ CondCond checkActive- , do guard $ varname == "idle"- return $ CondInteger (getNumVar "idle")- , do guard $ varname == "time"- return $ CondTime (getTimeVar "time")- , do guard $ varname == "sampleage"- return $ CondTime (getTimeVar "sampleage")- , do guard $ varname == "date"- return $ CondDate (getDateVar "date")- , do guard $ varname == "desktop"- return $ CondString (getVar "desktop")- ]+ , choice [ reserved lang "title" >> return (CondString (getVar "title"))+ , reserved lang "program" >> return (CondString (getVar "program"))+ , reserved lang "active" >> return (CondCond checkActive)+ , reserved lang "idle" >> return (CondInteger (getNumVar NvIdle))+ , reserved lang "time" >> return (CondTime (getTimeVar TvTime))+ , reserved lang "sampleage" >> return (CondTime (getTimeVar TvSampleAge))+ , reserved lang "date" >> return (CondDate (getDateVar DvDate))+ , reserved lang "now" >> return (CondDate (getDateVar DvNow))+ , reserved lang "desktop" >> return (CondString (getVar "desktop"))+ , do varname <- identifier lang+ inEnvironment <- (lift (asks (Map.lookup varname . snd)))+ case inEnvironment of+ Nothing -> fail ("Reference to unbound variable: '" ++ varname ++ "'")+ Just cond -> return (CondCond cond)+ ] ] <?> "variable" , do regex <- parseRegex <?> "regular expression" return $ CondRegex (const (Just regex))@@ -395,63 +430,32 @@ , do num <- natural lang <?> "number" return $ CondInteger (const (Just num)) ]-{-- choice- [ do reservedOp lang "=~"- regex <- parseRegex- return $ checkRegex varname (RE.compile regex [])- , do reservedOp lang "==" <|> reservedOp lang "="- str <- stringLiteral lang- return $ checkEq varname str- , do reservedOp lang "/=" <|> reservedOp lang "!="- str <- stringLiteral lang- return $ checkNot (checkEq varname str)- ]- , do guard $ varname == "idle"- op <- parseCmp- num <- natural lang- return $ checkNumCmp op varname num- , do guard $ varname `elem` ["time","sampleage"]- op <- parseCmp - time <- parseTime- return $ checkTimeCmp op varname time- , do guard $ varname == "active"- return checkActive- ]- , do reserved lang "current window"- cond <- parseCond- return $ checkCurrentwindow cond- , do reserved lang "any window"- cond <- parseCond- return $ checkAnyWindow cond- ]--} parseRegex :: Parser RE.Regex parseRegex = fmap (flip RE.compile [] . T.pack) $ lexeme lang $ choice [ between (char '/') (char '/') (many1 (noneOf "/"))- , do char 'm'+ , do _ <- char 'm' c <- anyChar str <- many1 (noneOf [c])- char c+ _ <- char c return str ]- + -- | Parses a day-of-time specification (hh:mm) parseTime :: Parser NominalDiffTime parseTime = fmap fromIntegral $ lexeme lang $ do hour <- read <$> many1 digit- char ':'+ _ <- char ':' minute <- read <$> count 2 digit return $ (hour * 60 + minute) * 60 parseDate :: Parser UTCTime parseDate = lexeme lang $ do- tz <- lift ask+ tz <- lift (asks fst) year <- read <$> count 4 digit- char '-'+ _ <- char '-' month <- read <$> count 2 digit- char '-'+ _ <- char '-' day <- read <$> count 2 digit time <- option 0 parseTime let date = LocalTime (fromGregorian year month day) (TimeOfDay 0 0 0)@@ -460,7 +464,7 @@ parseSetTag :: Parser Rule parseSetTag = lexeme lang $ do- firstPart <- parseTagPart + firstPart <- parseTagPart choice [ do char ':' secondPart <- parseTagPart return $ do cat <- firstPart@@ -476,7 +480,7 @@ ] replaceForbidden :: Maybe Text -> Maybe Text-replaceForbidden = liftM $ T.map go+replaceForbidden = fmap $ T.map go where go c | isAlphaNum c = c | c `elem` "-_" = c@@ -498,20 +502,20 @@ ifThenElse :: Cond -> Rule -> Rule -> Rule ifThenElse cond r1 r2 = do res <- cond- case res of + case res of Just substs -> r1 . setSubsts substs Nothing -> r2 where setSubsts :: [Text] -> Ctx -> Ctx setSubsts substs ctx = ctx { cSubsts = substs }- + matchAny :: [Rule] -> Rule matchAny rules = concat <$> sequence rules matchFirst :: [Rule] -> Rule matchFirst rules = takeFirst <$> sequence rules where takeFirst [] = [] takeFirst ([]:xs) = takeFirst xs- takeFirst (x:xs) = x+ takeFirst (x:_) = x getBackref :: Integer -> CtxFun Text@@ -528,27 +532,27 @@ 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+getVar "desktop" ctx = return $ cDesktop (tlData (cNow ctx))+getVar v _ = error $ "Unknown variable " ++ v -getNumVar :: String -> CtxFun Integer-getNumVar "idle" ctx = Just $ cLastActivity (tlData (cNow ctx)) `div` 1000+getNumVar :: NumVar -> CtxFun Integer+getNumVar NvIdle ctx = Just $ cLastActivity (tlData (cNow ctx)) `div` 1000 -getTimeVar :: String -> CtxFun NominalDiffTime-getTimeVar "time" ctx = Just $+getTimeVar :: TimeVar -> CtxFun NominalDiffTime+getTimeVar TvTime ctx = Just $ let utc = tlTime . cNow $ ctx tz = cTimeZone ctx local = utcToLocalTime tz utc midnightUTC = localTimeToUTC tz $ local { localTimeOfDay = midnight } in utc `diffUTCTime` midnightUTC-getTimeVar "sampleage" ctx = Just $ cCurrentTime ctx `diffUTCTime` tlTime (cNow ctx)+getTimeVar TvSampleAge ctx = Just $ cCurrentTime ctx `diffUTCTime` tlTime (cNow ctx) -getDateVar :: String -> CtxFun UTCTime-getDateVar "date" ctx = Just $ tlTime (cNow ctx)+getDateVar :: DateVar -> CtxFun UTCTime+getDateVar DvDate = Just . tlTime . cNow+getDateVar DvNow = Just . cCurrentTime findActive :: [(Bool, t, t1)] -> Maybe (Bool, t, t1)-findActive = find (\(a,_,_) -> a) +findActive = find (\(a,_,_) -> a) checkActive :: Cond checkActive ctx = do (a,_,_) <- cWindowInScope ctx@@ -560,7 +564,7 @@ justIf :: a -> Bool -> Maybe a justIf x True = Just x-justIf x False = Nothing+justIf _ False = Nothing mkSecond :: (a -> b) -> a -> (a, b) mkSecond f a = (a, f a)
src/DumpFormat.hs view
@@ -7,7 +7,7 @@ , dumpSamples ) where -import Data.MyText (unpack, null, Text)+import Data.MyText (unpack, null, pack, Text) import Data.Aeson import qualified Data.ByteString.Lazy as LBS import Data.Time@@ -17,6 +17,8 @@ import System.Locale (defaultTimeLocale) #endif import Data.Char+import Data.Foldable (toList)+import Control.Applicative ((<$>), (<|>), (<*>), pure) import Data import Text.Printf@@ -26,20 +28,36 @@ data DumpFormat = DFShow | DFHuman- | DFJSON + | DFJSON deriving (Show, Eq) instance ToJSON Text where toJSON = toJSON . unpack+instance FromJSON Text where+ parseJSON x = pack <$> parseJSON x 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),+ "windows" .= map (\(a,t,p) -> object ["active" .= a, "title" .= t, "program" .= p]) (cWindows tlData), "desktop" .= cDesktop tlData ]++instance FromJSON (TimeLogEntry CaptureData) where+ parseJSON = withObject "TimeLogEntry" $ \v -> do+ tlTime <- v .: "date"+ tlRate <- v .: "rate"+ cLastActivity <- v .: "inactive"+ cWindows <- (v .: "windows") >>=+ withArray "windows" (mapM (withObject "window" $ \v ->+ (,,) <$> v .: "active" <*> v .: "title" <*> v .: "program"+ ) . toList)+ cDesktop <- v .: "desktop"+ let tlData = CaptureData {..}+ let entry = TimeLogEntry {..}+ pure entry readDumpFormat :: String -> Maybe DumpFormat readDumpFormat arg =
− src/Graphics/X11/XScreenSaver.hsc
@@ -1,187 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}------------------------------------------------------------------------ |--- Module : Graphics.X11.XScreenSaver--- Copyright : (c) Joachim Breitner--- License : GPL2------ Maintainer: Joachim Breitner <mail@joachim-breitner.de>--- Stability : provisional--- Portability: portable------------------------------------------------------------------------------ Interface to XScreenSaver API-----module Graphics.X11.XScreenSaver (- getXIdleTime,- XScreenSaverState(..),- XScreenSaverKind(..),- XScreenSaverInfo(..),- xScreenSaverQueryExtension,- xScreenSaverQueryVersion,- xScreenSaverQueryInfo,- compiledWithXScreenSaver- ) where--import Foreign-import Foreign.C.Types-import Graphics.X11.Xlib-import Control.Monad--data XScreenSaverState = ScreenSaverOff | ScreenSaverOn | ScreenSaverDisabled deriving Show-data XScreenSaverKind = ScreenSaverBlanked | ScreenSaverInternal | ScreenSaverExternal deriving Show---- | Representation of the XScreenSaverInfo struct.-data XScreenSaverInfo = XScreenSaverInfo- { xssi_window :: !Window,- xssi_state :: !XScreenSaverState,--- ^ The state field specified whether or not the screen saver is currently--- active and how the til-or-since value should be interpreted:------ ['ScreenSaverOff'] The screen is not currently being saved; til-or-since specifies the--- number of milliseconds until the screen saver is expected to activate.------ ['ScreenSaverOn'] The screen is currently being saved; til-or-since specifies the number--- of milliseconds since the screen saver activated.------ ['ScreenSaverDisabled'] The screen saver is currently disabled; til-or-since is zero.- xssi_kind :: !XScreenSaverKind,--- ^ The kind field specifies the mechanism that either is currently being used--- or would have been were the screen being saved:------ ['ScreenSaverBlanked'] The video signal to the display monitor was disabled.------ ['ScreenSaverInternal'] A server-dependent, built-in screen saver image was displayed;--- either no client had set the screen saver window attributes or a different--- client had the server grabbed when the screen saver activated. ------ ['ScreenSaverExternal'] The screen saver window was mapped with attributes set by a client--- using the ScreenSaverSetAttributes request. - xssi_til_or_since :: !CULong,- xssi_idle :: !CULong,--- ^ The idle field specifies the number of milliseconds since the last input--- was received from the user on any of the input devices.- xssi_event_mask :: !CULong--- ^ The event-mask field specifies which, if any, screen saver events this--- client has requested using ScreenSaverSelectInput.- } deriving (Show)---- | Simple wrapper around 'xScreenSaverQueryInfo' if you are only interested in--- the idle time, in milliseconds. Returns 0 if the XScreenSaver extension is--- not available-getXIdleTime :: Display -> IO Int-getXIdleTime dpy = maybe 0 (fromIntegral . xssi_idle) `fmap` xScreenSaverQueryInfo dpy---- We have XScreenSaver, so the library will actually work-compiledWithXScreenSaver :: Bool-compiledWithXScreenSaver = True---- for XFree() (already included from scrnsaver.h, but I don't know if I can count on that.)-#include <X11/Xlib.h>-#include <X11/extensions/scrnsaver.h>--xScreenSaverState2CInt :: XScreenSaverState -> CInt-xScreenSaverState2CInt ScreenSaverOn = #const ScreenSaverOn-xScreenSaverState2CInt ScreenSaverOff = #const ScreenSaverOff-xScreenSaverState2CInt ScreenSaverDisabled = #const ScreenSaverDisabled--cInt2XScreenSaverState :: CInt -> XScreenSaverState-cInt2XScreenSaverState (#const ScreenSaverOn) = ScreenSaverOn-cInt2XScreenSaverState (#const ScreenSaverOff) = ScreenSaverOff-cInt2XScreenSaverState (#const ScreenSaverDisabled) = ScreenSaverDisabled-cInt2XScreenSaverState _ = error "Unknown state in xScreenSaverQueryInfo"--instance Storable XScreenSaverState where- sizeOf _ = sizeOf (undefined :: CInt)- alignment _ = alignment (undefined :: CInt)- poke p xsss = poke (castPtr p) (xScreenSaverState2CInt xsss)- peek p = cInt2XScreenSaverState `fmap` peek (castPtr p)- --xScreenSaverKind2CInt :: XScreenSaverKind -> CInt-xScreenSaverKind2CInt ScreenSaverBlanked = #const ScreenSaverBlanked-xScreenSaverKind2CInt ScreenSaverInternal = #const ScreenSaverInternal-xScreenSaverKind2CInt ScreenSaverExternal = #const ScreenSaverExternal--cInt2XScreenSaverKind :: CInt -> XScreenSaverKind-cInt2XScreenSaverKind (#const ScreenSaverBlanked) = ScreenSaverBlanked-cInt2XScreenSaverKind (#const ScreenSaverInternal) = ScreenSaverInternal-cInt2XScreenSaverKind (#const ScreenSaverExternal) = ScreenSaverExternal-cInt2XScreenSaverKind _ = error "Unknown kind in xScreenSaverQueryInfo"--instance Storable XScreenSaverKind where- sizeOf _ = sizeOf (undefined :: CInt)- alignment _ = alignment (undefined :: CInt)- poke p xsss = poke (castPtr p) (xScreenSaverKind2CInt xsss)- peek p = cInt2XScreenSaverKind `fmap` peek (castPtr p)- --instance Storable XScreenSaverInfo where- sizeOf _ = #{size XScreenSaverInfo}- -- FIXME: Is this right?- alignment _ = alignment (undefined :: CInt)-- poke p xssi = do- #{poke XScreenSaverInfo, window } p $ xssi_window xssi- #{poke XScreenSaverInfo, state } p $ xssi_state xssi- #{poke XScreenSaverInfo, kind } p $ xssi_kind xssi- #{poke XScreenSaverInfo, til_or_since } p $ xssi_til_or_since xssi- #{poke XScreenSaverInfo, idle } p $ xssi_idle xssi- #{poke XScreenSaverInfo, eventMask } p $ xssi_event_mask xssi-- peek p = return XScreenSaverInfo- `ap` (#{peek XScreenSaverInfo, window} p)- `ap` (#{peek XScreenSaverInfo, state} p)- `ap` (#{peek XScreenSaverInfo, kind} p)- `ap` (#{peek XScreenSaverInfo, til_or_since} p)- `ap` (#{peek XScreenSaverInfo, idle} p)- `ap` (#{peek XScreenSaverInfo, eventMask} p)---xScreenSaverQueryExtension :: Display -> IO (Maybe (CInt, CInt))-xScreenSaverQueryExtension dpy = wrapPtr2 (cXScreenSaverQueryExtension dpy) go- where go False _ _ = Nothing- go True eventbase errorbase = Just (fromIntegral eventbase, fromIntegral errorbase)--xScreenSaverQueryVersion :: Display -> IO (Maybe (CInt, CInt))-xScreenSaverQueryVersion dpy = wrapPtr2 (cXScreenSaverQueryVersion dpy) go- where go False _ _ = Nothing- go True major minor = Just (fromIntegral major, fromIntegral minor)--wrapPtr2 :: (Storable a, Storable b) => (Ptr a -> Ptr b -> IO c) -> (c -> a -> b -> d) -> IO d-wrapPtr2 cfun f =- withPool $ \pool -> do aptr <- pooledMalloc pool- bptr <- pooledMalloc pool- ret <- cfun aptr bptr- a <- peek aptr- b <- peek bptr- return (f ret a b)---- | xScreenSaverQueryInfo returns information about the current state of the--- screen server. If the xScreenSaver extension is not available, it returns Nothing-xScreenSaverQueryInfo :: Display -> IO (Maybe XScreenSaverInfo)-xScreenSaverQueryInfo dpy = do- p <- cXScreenSaverAllocInfo- if p == nullPtr then return Nothing else do- s <- cXScreenSaverQueryInfo dpy (defaultRootWindow dpy) p- if s == 0 then return Nothing else do- xssi <- peek p- cXFree p- return (Just xssi)--foreign import ccall "XScreenSaverQueryExtension"- cXScreenSaverQueryExtension :: Display -> Ptr CInt -> Ptr CInt -> IO Bool--foreign import ccall "XScreenSaverQueryVersion"- cXScreenSaverQueryVersion :: Display -> Ptr CInt -> Ptr CInt -> IO Bool--foreign import ccall "XScreenSaverAllocInfo"- cXScreenSaverAllocInfo :: IO (Ptr XScreenSaverInfo)--foreign import ccall "XScreenSaverQueryInfo"- cXScreenSaverQueryInfo :: Display -> Drawable -> Ptr XScreenSaverInfo -> IO Status--foreign import ccall "XFree"- cXFree :: Ptr a -> IO CInt
+ src/LockFile.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE CPP #-}+module LockFile where++import System.Exit+import System.IO+import System.IO.Error++#ifdef WIN32+import System.Win32.Mutex+#else+import System.Posix.IO+#endif++-- | This is very raw, someone ought to improve this+lockFile filename =+#ifdef WIN32+ do success <- claimMutex filename+ unless success $ do+ hPutStrLn stderr ("arbtt [Error]: Could not aquire lock for " ++ filename ++"!")+ exitFailure+#else+ flip catchIOError (\e -> hPutStrLn stderr ("arbtt [Error]: Could not aquire lock for " ++ filename ++"!") >> exitFailure) $ do+ fd <- openFd (filename ++ ".lck") WriteOnly (Just 0o644) defaultFileFlags+ setLock fd (WriteLock, AbsoluteSeek, 0, 0)+#endif
src/Stats.hs view
@@ -102,7 +102,7 @@ all (\flag -> case flag of Exclude act -> excludeTag act tl Only act -> onlyTag act tl- GeneralCond s-> applyCond s (cTimeZone (fst (tlData tl))) tl) filters+ GeneralCond s-> applyCond s (cTimeZone (fst (tlData tl))) M.empty tl) filters filterActivity :: [ActivityFilter] -> ActivityData -> ActivityData filterActivity fs = filter (applyActivityFilter fs)
src/capture-main.hs view
@@ -7,11 +7,6 @@ import System.FilePath import System.IO import System.IO.Error-#ifdef WIN32-import System.Win32.Mutex-#else-import System.Posix.IO-#endif import System.Exit import System.Console.GetOpt import System.Environment@@ -24,6 +19,7 @@ import UpgradeLog1 import CommonStartup import DumpFormat+import LockFile import Paths_arbtt (version) @@ -48,13 +44,13 @@ options = [ Option "h?" ["help"] (NoArg $ \_ -> do- hPutStr stderr (usageInfo header options)+ putStr (usageInfo header options) exitSuccess ) "show this help" , Option "V" ["version"] (NoArg $ \_ -> do- hPutStrLn stderr versionStr+ putStrLn versionStr exitSuccess ) "show the version number"@@ -69,18 +65,6 @@ "dump one sample to standard out, instead of modifying the log file" ] --- | This is very raw, someone ought to improve this-lockFile filename = do-#ifdef WIN32- success <- claimMutex filename- unless success $ do- hPutStrLn stderr ("arbtt [Error]: Could not aquire lock for " ++ filename ++"!")- exitFailure-#else- flip catchIOError (\e -> hPutStrLn stderr ("arbtt [Error]: Could not aquire lock for " ++ filename ++"!") >> exitFailure) $ do- fd <- openFd (filename ++ ".lck") WriteOnly (Just 0o644) defaultFileFlags- setLock fd (WriteLock, AbsoluteSeek, 0, 0)-#endif main = do commonStartup
src/dump-main.hs view
@@ -40,13 +40,13 @@ options = [ Option "h?" ["help"] (NoArg $ \_ -> do- hPutStr stderr (usageInfo header options)+ putStr (usageInfo header options) exitSuccess ) "show this help" , Option "V" ["version"] (NoArg $ \_ -> do- hPutStrLn stderr versionStr+ putStrLn versionStr exitSuccess ) "show the version number"
src/import-main.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE CPP #-} module Main where+ import System.Directory import System.FilePath import System.Console.GetOpt@@ -10,19 +12,35 @@ import Data.Maybe import Control.Monad import Control.Applicative+import Data.Conduit.Attoparsec+import Data.Conduit+import Data.Aeson (parseJSON, json)+import Data.Aeson.Types (parseEither)+import Data.Binary.StringRef+import Data.Attoparsec.ByteString.Char8 (skipSpace, option)+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Conduit.List as C+import qualified Data.Conduit.Binary as C import TimeLog import Data import CommonStartup+import DumpFormat+import LockFile import Paths_arbtt (version) data Options = Options { optLogFile :: String+ , optFormat :: DumpFormat+ , optAppend :: Bool } defaultOptions dir = Options { optLogFile = dir </> "capture.log"+ , optAppend = False+ , optFormat = DFShow } versionStr = "arbtt-import " ++ showVersion version@@ -32,21 +50,67 @@ options = [ Option "h?" ["help"] (NoArg $ \_ -> do- hPutStr stderr (usageInfo header options)+ putStr (usageInfo header options) exitSuccess ) "show this help" , Option "V" ["version"] (NoArg $ \_ -> do- hPutStrLn stderr versionStr+ putStrLn versionStr exitSuccess ) "show the version number" , Option "f" ["logfile"] (ReqArg (\arg opt -> return opt { optLogFile = arg }) "FILE") "use this file instead of ~/.arbtt/capture.log"+ , Option "a" ["append"]+ (NoArg (\opt -> return opt { optAppend = True } ))+ "append to the logfile, instead of overriding it"+ , Option "t" ["format"]+ (ReqArg (\arg opt ->+ case readDumpFormat arg of+ Just DFHuman -> do+ hPutStrLn stderr "The “Human” format cannot imported."+ hPutStr stderr (usageInfo header options)+ exitFailure+ Just fm -> return $ opt { optFormat = fm}+ Nothing -> do+ hPutStrLn stderr ("Invalid format \"" ++ arg ++ "\".")+ hPutStr stderr (usageInfo header options)+ exitFailure+ ) "FORMAT")+ "output format, one of Show (default) or JSON " ] +parseConduit :: DumpFormat -> Conduit BS.ByteString IO [TimeLogEntry CaptureData]+parseConduit DFHuman = error "Cannot read back human format"+parseConduit DFShow = C.lines =$= C.map ( (:[]) . read . BS.unpack)+parseConduit DFJSON =+ conduitParser (ignoreWhiteSpace json)+ =$= C.map snd+ =$= C.catMaybes+ =$= tlConduit+ where+ tlConduit = C.mapM $ \ v ->+ case parseEither oneOrMany v of+ Left e -> do+ hPutStrLn stderr ("Cannot parse log entry: " ++ e)+ exitFailure+ Right x -> pure x++ oneOrMany v = parseJSON v+ <|> ((:[]) <$> parseJSON v)++ ignoreWhiteSpace p = skipSpace *> option Nothing (Just <$> p)++binaryConduit :: ListOfStringable a =>+ Conduit [(TimeLogEntry a, Maybe a)] IO (Flush BS.ByteString)+binaryConduit = C.map (map go) =$= C.concatMap chunk+ where+ go (x,prev) = BSL.toStrict $ ls_encode strs x+ where strs = maybe [] listOfStrings prev+ chunk xs = map Chunk xs ++ [Flush]+ main = do commonStartup args <- getArgs@@ -58,12 +122,46 @@ dir <- getAppUserDataDirectory "arbtt" flags <- foldl (>>=) (return (defaultOptions dir)) actions- ++ lockFile (optLogFile flags)+ ex <- doesFileExist (optLogFile flags)- if ex- then do+ when (ex && not (optAppend flags)) $ do putStrLn $ "File at " ++ (optLogFile flags) ++ " does already exist. Please delete this" putStrLn $ "file before running arbtt-import."- else do- captures <- map read . lines <$> getContents :: IO (TimeLog CaptureData)- writeTimeLog (optLogFile flags) captures+ exitFailure+ createTimeLog False (optLogFile flags)++ h <- openBinaryFile (optLogFile flags) AppendMode+ runConduit $ C.sourceHandle stdin+ =$= parseConduit (optFormat flags)+ =$= stutterList+ =$= binaryConduit+ =$= C.sinkHandleFlush h+ hClose h+++stutter :: Monad m => Conduit (TimeLogEntry a) m (TimeLogEntry a, Maybe a)+stutter =+ loop Nothing+ where+ loop prev = do+ mx <- await+ case mx of+ Nothing -> return ()+ Just x -> do+ yield (x, prev)+ loop (Just (tlData x))++stutterList :: Monad m => Conduit [TimeLogEntry a] m [(TimeLogEntry a, Maybe a)]+stutterList =+ loop Nothing+ where+ loop prev = do+ mx <- await+ case mx of+ Nothing -> return ()+ Just xs -> do+ let xs' = zip xs (prev : map (Just . tlData) xs)+ yield xs'+ loop (Just (tlData (last xs)))
src/recover-main.hs view
@@ -34,13 +34,13 @@ options = [ Option "h?" ["help"] (NoArg $ \_ -> do- hPutStr stderr (usageInfo header options)+ putStr (usageInfo header options) exitSuccess ) "show this help" , Option "V" ["version"] (NoArg $ \_ -> do- hPutStrLn stderr versionStr+ putStrLn versionStr exitSuccess ) "show the version number"
src/stats-main.hs view
@@ -57,13 +57,13 @@ options = [ Option "h?" ["help"] (NoArg $ \_ -> do- hPutStr stderr (usageInfo header options)+ putStr (usageInfo header options) exitSuccess ) "show this help" , Option "V" ["version"] (NoArg $ \_ -> do- hPutStrLn stderr versionStr+ putStrLn versionStr exitSuccess ) "show the version number"
tests/categorize.cfg view
@@ -23,3 +23,6 @@ -- This tag always refers to the last 24h $sampleage <= 24:00 ==> tag last-day, +let night = $time >= 2:00 && $time < 8:00,++current window $program == "emacs" && $night ==> tag night-coding
+ tests/condition_bindings.cfg view
@@ -0,0 +1,9 @@+condition arbtt = current window $title =~ m/arbtt/ in {+ $arbtt && $time < 14:00 ==> tag arbtt-morning,+ $arbtt && $time > 14:00 ==> tag arbtt-afternoon+},++condition failing = current window $title == "does not exist" in {+ tag default-tag+}+
+ tests/condition_bindings_stats.out view
@@ -0,0 +1,6 @@+Total time per tag+==================+____________Tag_|___Time_|_Percentage_+ default-tag | 3m00s | 100.00+arbtt-afternoon | 2m00s | 66.67+ arbtt-morning | 1m00s | 33.33
+ tests/small_dump_json.out view
@@ -0,0 +1,4 @@+[+{"desktop":"","inactive":2909,"date":"2010-03-20T13:59:15.075576Z","windows":[{"active":false,"program":"gvim","title":"stats-main.hs (~/darcs/arbtt/src) - GVIM"},{"active":false,"program":"urxvt","title":"`ghci' mrtrac@curie:~ "},{"active":false,"program":"urxvt","title":"`irssi' mrtrac@curie:~ "},{"active":true,"program":"urxvt","title":"mrtrac@curie:~/darcs/arbtt "},{"active":false,"program":"urxvt","title":"`mutt' mrtrac@curie:~ "},{"active":false,"program":"Navigator","title":"HackageDB: network-bytestring-0.1.2.1 - Vimperator"}],"rate":60000},+{"desktop":"","inactive":557,"date":"2010-03-20T14:00:15.157669Z","windows":[{"active":false,"program":"gvim","title":"stats-main.hs (~/darcs/arbtt/src) - GVIM"},{"active":false,"program":"urxvt","title":"`ghci' mrtrac@curie:~ "},{"active":false,"program":"urxvt","title":"`irssi' mrtrac@curie:~ "},{"active":true,"program":"urxvt","title":"mrtrac@curie:~/darcs/arbtt "},{"active":false,"program":"urxvt","title":"`mutt' mrtrac@curie:~ "},{"active":false,"program":"Navigator","title":"HackageDB: network-bytestring-0.1.2.1 - Vimperator"}],"rate":60000},+{"desktop":"","inactive":58004,"date":"2010-03-20T14:01:15.220521Z","windows":[{"active":false,"program":"gvim","title":"stats-main.hs (~/darcs/arbtt/src) - GVIM"},{"active":false,"program":"urxvt","title":"`ghci' mrtrac@curie:~ "},{"active":false,"program":"urxvt","title":"`irssi' mrtrac@curie:~ "},{"active":true,"program":"urxvt","title":"mrtrac@curie:~/darcs/arbtt "},{"active":false,"program":"urxvt","title":"`mutt' mrtrac@curie:~ "},{"active":false,"program":"Navigator","title":"HackageDB: network-bytestring-0.1.2.1 - Vimperator"}],"rate":60000}]
+ tests/small_import_json.in view
@@ -0,0 +1,5 @@+{"desktop":"","inactive":2909,"date":"2010-03-20T13:59:15.075576Z","windows":[{"active":false,"program":"gvim","title":"stats-main.hs (~/darcs/arbtt/src) - GVIM"},{"active":false,"program":"urxvt","title":"`ghci' mrtrac@curie:~ "},{"active":false,"program":"urxvt","title":"`irssi' mrtrac@curie:~ "},{"active":true,"program":"urxvt","title":"mrtrac@curie:~/darcs/arbtt "},{"active":false,"program":"urxvt","title":"`mutt' mrtrac@curie:~ "},{"active":false,"program":"Navigator","title":"HackageDB: network-bytestring-0.1.2.1 - Vimperator"}],"rate":60000}+++{"desktop":"","inactive":557,"date":"2010-03-20T14:00:15.157669Z","windows":[{"active":false,"program":"gvim","title":"stats-main.hs (~/darcs/arbtt/src) - GVIM"},{"active":false,"program":"urxvt","title":"`ghci' mrtrac@curie:~ "},{"active":false,"program":"urxvt","title":"`irssi' mrtrac@curie:~ "},{"active":true,"program":"urxvt","title":"mrtrac@curie:~/darcs/arbtt "},{"active":false,"program":"urxvt","title":"`mutt' mrtrac@curie:~ "},{"active":false,"program":"Navigator","title":"HackageDB: network-bytestring-0.1.2.1 - Vimperator"}],"rate":60000}+{"desktop":"","inactive":58004,"date":"2010-03-20T14:01:15.220521Z","windows":[{"active":false,"program":"gvim","title":"stats-main.hs (~/darcs/arbtt/src) - GVIM"},{"active":false,"program":"urxvt","title":"`ghci' mrtrac@curie:~ "},{"active":false,"program":"urxvt","title":"`irssi' mrtrac@curie:~ "},{"active":true,"program":"urxvt","title":"mrtrac@curie:~/darcs/arbtt "},{"active":false,"program":"urxvt","title":"`mutt' mrtrac@curie:~ "},{"active":false,"program":"Navigator","title":"HackageDB: network-bytestring-0.1.2.1 - Vimperator"}],"rate":60000}
+ tests/small_import_json.out view
binary file changed (absent → 546 bytes)
+ tests/small_import_json_list.in view
@@ -0,0 +1,8 @@++[+{"desktop":"","inactive":2909,"date":"2010-03-20T13:59:15.075576Z","windows":[{"active":false,"program":"gvim","title":"stats-main.hs (~/darcs/arbtt/src) - GVIM"},{"active":false,"program":"urxvt","title":"`ghci' mrtrac@curie:~ "},{"active":false,"program":"urxvt","title":"`irssi' mrtrac@curie:~ "},{"active":true,"program":"urxvt","title":"mrtrac@curie:~/darcs/arbtt "},{"active":false,"program":"urxvt","title":"`mutt' mrtrac@curie:~ "},{"active":false,"program":"Navigator","title":"HackageDB: network-bytestring-0.1.2.1 - Vimperator"}],"rate":60000},+++{"desktop":"","inactive":557,"date":"2010-03-20T14:00:15.157669Z","windows":[{"active":false,"program":"gvim","title":"stats-main.hs (~/darcs/arbtt/src) - GVIM"},{"active":false,"program":"urxvt","title":"`ghci' mrtrac@curie:~ "},{"active":false,"program":"urxvt","title":"`irssi' mrtrac@curie:~ "},{"active":true,"program":"urxvt","title":"mrtrac@curie:~/darcs/arbtt "},{"active":false,"program":"urxvt","title":"`mutt' mrtrac@curie:~ "},{"active":false,"program":"Navigator","title":"HackageDB: network-bytestring-0.1.2.1 - Vimperator"}],"rate":60000},+{"desktop":"","inactive":58004,"date":"2010-03-20T14:01:15.220521Z","windows":[{"active":false,"program":"gvim","title":"stats-main.hs (~/darcs/arbtt/src) - GVIM"},{"active":false,"program":"urxvt","title":"`ghci' mrtrac@curie:~ "},{"active":false,"program":"urxvt","title":"`irssi' mrtrac@curie:~ "},{"active":true,"program":"urxvt","title":"mrtrac@curie:~/darcs/arbtt "},{"active":false,"program":"urxvt","title":"`mutt' mrtrac@curie:~ "},{"active":false,"program":"Navigator","title":"HackageDB: network-bytestring-0.1.2.1 - Vimperator"}],"rate":60000}+]
+ tests/small_import_json_list.out view
binary file changed (absent → 546 bytes)
tests/test.hs view
@@ -1,22 +1,30 @@-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, FlexibleContexts #-} -import Test.Tasty hiding (defaultMain)-import Test.Tasty.Golden.Manage-import Test.Tasty.Golden-import Test.Tasty.HUnit-import System.Process.ByteString.Lazy+import Control.Exception+import Control.Monad+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict import qualified Data.ByteString.Lazy as B-import Control.Monad-import Control.Exception-import Data.Typeable-import System.Exit-import System.Environment-import Data.Maybe+import Data.Functor.Identity+import qualified Data.Map as Map+import Data.Maybe+import Data.Time.LocalTime (getCurrentTimeZone)+import Data.Typeable+import System.Environment+import System.Directory+import System.Exit+import System.IO.Error+import System.Process.ByteString.Lazy+import Test.Tasty hiding (defaultMain)+import Test.Tasty.Golden+import Test.Tasty.Golden.Manage+import Test.Tasty.HUnit+import Text.Parsec -import Categorize-import TimeLog-import Data-import Data.Time.Clock+import Categorize+import TimeLog+import Data+import Data.Time.Clock main = do setEnv "TZ" "UTC" -- to make tests reproducible@@ -24,7 +32,7 @@ defaultMain (tests distDir) tests :: FilePath -> TestTree-tests distDir = testGroup "Tests" [goldenTests distDir, regressionTests]+tests distDir = testGroup "Tests" [goldenTests distDir, regressionTests, parserTests] regressionTests :: TestTree regressionTests = testGroup "Regression tests"@@ -58,9 +66,23 @@ "tests/small_dump.out" $ run (distDir ++ "/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 $+ "tests/small_import.out" "tests/small_import.out.actual" $ void $ do+ tryIOError $ removeFile "tests/small_import.out.actual" B.readFile "tests/small_import.in" >>=- run (distDir ++ "/build/arbtt-import/arbtt-import") ["-f","tests/small_import.out.actual"]+ run (distDir ++ "/build/arbtt-import/arbtt-import") ["-f","tests/small_import.out.actual"]+ , goldenVsString "dump small JSON"+ "tests/small_dump_json.out" $+ run (distDir ++ "/build/arbtt-dump/arbtt-dump") ["-f","tests/small.log", "-t", "JSON"] B.empty+ , goldenVsFile "import small JSON"+ "tests/small_import_json.out" "tests/small_import_json.out.actual" $ void $ do+ tryIOError $ removeFile "tests/small_import_json.out.actual"+ B.readFile "tests/small_import_json.in" >>=+ run (distDir ++ "/build/arbtt-import/arbtt-import") ["-f","tests/small_import_json.out.actual", "-t", "JSON"]+ , goldenVsFile "import small JSON (list)"+ "tests/small_import_json_list.out" "tests/small_import_json_list.out.actual" $ void $ do+ tryIOError $ removeFile "tests/small_import_json_list.out.actual"+ B.readFile "tests/small_import_json_list.in" >>=+ run (distDir ++ "/build/arbtt-import/arbtt-import") ["-f","tests/small_import_json_list.out.actual", "-t", "JSON"] , goldenVsFile "recover small" "tests/small_borked_recover.out" "tests/small_borked_recover.out.actual" $ void $ run (distDir ++ "/build/arbtt-recover/arbtt-recover") ["-i","tests/small_borked_recover.out", "-o", "tests/small_borked_recover.out.actual"] B.empty@@ -76,9 +98,42 @@ , goldenVsString "stats gap handling" "tests/gap-handling.out" $ run (distDir ++ "/build/arbtt-stats/arbtt-stats") ["--logfile", "tests/gap-handling.log", "--categorize", "tests/gap-handling.cfg", "--intervals", "Program:"] B.empty+ , goldenVsString "condition binding stats"+ "tests/condition_bindings_stats.out" $+ run (distDir ++ "/build/arbtt-stats/arbtt-stats") ["--logfile", "tests/small.log", "--categorize", "tests/condition_bindings.cfg"] B.empty ] +testParser env parser input = do+ tz <- getCurrentTimeZone+ return . runIdentity . flip runReaderT (tz, env) . runParserT parser () "" $ input +parserTests :: TestTree+parserTests = testGroup "Parser tests"+ [ testCase "Parse condition bindings" $ do+ result <- testParser Map.empty parseConditionBinding ("condition foo = " ++ condText ++ " in 1 == 1 ==> tag foo")+ assertRight result+ , testCase "Trying to bind reserved identifiers" $ do+ result <- testParser Map.empty parseConditionBinding ("condition title = " ++ condText)+ assertLeft result+ , testCase "Reference bound condition identifiers" $ do+ Right cond <- testParser Map.empty parseCond condText+ result <- testParser (Map.fromList [("foo", cond)]) parseRule ("$foo ==> tag sometag")+ assertRight result+ , testCase "Parse condition binding usage in rule" $ do+ result <- testParser Map.empty parseRules ("condition foo = " ++ condText ++ " in " ++ ruleText)+ assertRight result+ , testCase "Reference unbound condition identifier" $ do+ result <- testParser Map.empty parseRule ("$foo ==> tag sometag")+ assertLeft result+ , testCase "Variables are only accessible within the condition assignment body" $ do+ result <- testParser Map.empty parseRules ("condition foo = " ++ condText ++ " in "+ ++ ruleText ++ ", "+ ++ ruleText)+ assertLeft result+ ]+ where condText = "current window $title == \"test\""+ ruleText = "$foo ==> tag sometag"+ run :: FilePath -> [FilePath] -> B.ByteString -> IO B.ByteString run cmd args stdin = do (ex,stdout,stderr) <- readProcessWithExitCode cmd args stdin@@ -94,3 +149,11 @@ instance Exception StderrException instance Exception ExitCodeException++assertRight :: Show a => Either a b -> Assertion+assertRight (Left r) = assertFailure $ "expected a Right\n but got a Left with: " ++ show r+assertRight _ = return ()++assertLeft :: Show b => Either a b -> Assertion+assertLeft (Right r) = assertFailure $ "expected a Left\n but got a Right with: " ++ show r+assertLeft _ = return ()