diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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
+
+
+
+
+ Label
+ com.foo.arbtt
+ Program
+ /path/to/arbtt-capture
+ RunAtLoad
+
+ KeepAlive
+
+
+
+ ```
+ 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
+ or
+.
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
+
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.)
diff --git a/arbtt.cabal b/arbtt.cabal
--- a/arbtt.cabal
+++ b/arbtt.cabal
@@ -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
diff --git a/categorize.cfg b/categorize.cfg
--- a/categorize.cfg
+++ b/categorize.cfg
@@ -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,
-}
diff --git a/doc/arbtt.xml b/doc/arbtt.xml
--- a/doc/arbtt.xml
+++ b/doc/arbtt.xml
@@ -33,11 +33,23 @@
Contributor
muharem@linux.com
+
+ Markus
+ Hauck
+ Contributor
+ markus1189@gmail.com
+
+
+ Thomasz
+ Miąsko
+ Contributor
+ tomasz.miasko@gmail.com
+
Waldir
Pimenta
Documentation writer
- waldir@email.com
+ waldyrious@gmail.com
Gwern
@@ -265,7 +277,7 @@
- The variable $date referes to the date and time of the
+ The variable $date 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 $date ==
2001-01-01 will not do what you want, but
@@ -318,6 +330,20 @@
parentheses.
+
+ You can define short-hand names for conditions using
+ condition:
+
+ condition arbtt = current window $title =~ m/arbtt/ in {
+ $arbtt && $time < 14:00 ==> tag arbtt-morning,
+ $arbtt && $time > 14:00 ==> tag arbtt-afternoon
+ }
+
+ Everything that is a valid condition is assignable and you can
+ reference bound variables in rules by prefixing them with a
+ dollar ($).
+
+
@@ -368,6 +394,7 @@
tag
+
@@ -402,6 +429,7 @@
current window
any window
+ $
Literal
@@ -414,7 +442,8 @@
- ListOfString
+
+ ListOfString
"
string literal "
"
string literal "
,
@@ -432,7 +461,7 @@
Date
$date
-
+ $now
@@ -463,12 +492,18 @@
"
"
,
-
- CmpOp
- <=
| <
| ==
- | >
| >=
-
+
+ CmpOp
+ <=
| <
|
+ ==
| !=
+ | >
| >=
+
+
+ ConditionBinding
+ condition
Literal =
in
+
+
@@ -1016,11 +1051,11 @@
Contributed tools
- Due to the export facilities of arbtt (as explained in ), 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 ).
+ Due to the import and export facilities of arbtt (as explained in ), 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 ).
arbtt-graph
@@ -1032,6 +1067,15 @@
You can find his tool on https://github.com/rejuvyesh/arbtt-graph.
+
+ arbtt-capture for GNOME Shell
+
+ 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
+ https://github.com/tmiasko/arbtt-capture.
+
+
Program references
@@ -1068,6 +1112,10 @@
various textual formats. Its command line reference is given in .
+ The textual form can be imported back using
+ arbtt-import. Its command line reference is given in
+ .
+
If arbtt-capture crashes it might be that the log
file is not readable any more. In some cases, this can be fixed using the
(relatively raw) arbtt-recover tool. Its command line
@@ -1528,7 +1576,7 @@
-
+
arbtt-import
imports dumped arbtt data samples
@@ -1543,15 +1591,19 @@
Description
- arbtt-import expects the output of
- arbtt-dump on the standard input and saves them as the
- logfile or the specified file.
+ arbtt-import reads data from standard input and adds
+ the entries to the logfile. It supports the Show
+ format as well as the JSON format, and can be used in
+ a streaming fashion (i.e. it will write entries as they are read from
+ standard input).
+
- 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
- arbtt-import.
+ arbtt-import. If you want to extend an existing file,
+ use the option.
@@ -1569,12 +1621,22 @@
shows the version number, and exists.
-
+
FILE
FILE
logfile to use instead of ~/.arbtt/capture.log
-
-
+
+
+
+
+ append the log file, if it already exists
+
+
+ FORMAT
+ FORMAT
+ format to use, where FORMAT is one of show (the default) or JSON. The JSON format can either be a list of records (as dumped by ), or just one record after another (useful in streaming mode).
+
+
Files
@@ -1716,6 +1778,31 @@
The version history with changes relevant for the user is documented here.
+
+
+ Version 0.10
+
+
+
+ Markus Hauck contributed the != operator, the
+ $now
variable and the condition
+ construct (as well as other code cleanup).
+
+
+
+
+ The development repository migrated from darcs to git.
+
+
+
+
+ The command now supports reading JSON
+ records, and can be used to append to an exising log file in a
+ steaming fasion.
+
+
+
+
Version 0.9
diff --git a/src/Capture/X11.hs b/src/Capture/X11.hs
--- a/src/Capture/X11.hs
+++ b/src/Capture/X11.hs
@@ -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
diff --git a/src/Categorize.hs b/src/Categorize.hs
--- a/src/Categorize.hs
+++ b/src/Categorize.hs
@@ -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)
diff --git a/src/DumpFormat.hs b/src/DumpFormat.hs
--- a/src/DumpFormat.hs
+++ b/src/DumpFormat.hs
@@ -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 =
diff --git a/src/Graphics/X11/XScreenSaver.hsc b/src/Graphics/X11/XScreenSaver.hsc
deleted file mode 100644
--- a/src/Graphics/X11/XScreenSaver.hsc
+++ /dev/null
@@ -1,187 +0,0 @@
-{-# LANGUAGE ForeignFunctionInterface #-}
---------------------------------------------------------------------
--- |
--- Module : Graphics.X11.XScreenSaver
--- Copyright : (c) Joachim Breitner
--- License : GPL2
---
--- Maintainer: Joachim Breitner
--- 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
-#include
-
-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
diff --git a/src/LockFile.hs b/src/LockFile.hs
new file mode 100644
--- /dev/null
+++ b/src/LockFile.hs
@@ -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
diff --git a/src/Stats.hs b/src/Stats.hs
--- a/src/Stats.hs
+++ b/src/Stats.hs
@@ -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)
diff --git a/src/capture-main.hs b/src/capture-main.hs
--- a/src/capture-main.hs
+++ b/src/capture-main.hs
@@ -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
diff --git a/src/dump-main.hs b/src/dump-main.hs
--- a/src/dump-main.hs
+++ b/src/dump-main.hs
@@ -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"
diff --git a/src/import-main.hs b/src/import-main.hs
--- a/src/import-main.hs
+++ b/src/import-main.hs
@@ -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)))
diff --git a/src/recover-main.hs b/src/recover-main.hs
--- a/src/recover-main.hs
+++ b/src/recover-main.hs
@@ -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"
diff --git a/src/stats-main.hs b/src/stats-main.hs
--- a/src/stats-main.hs
+++ b/src/stats-main.hs
@@ -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"
diff --git a/tests/categorize.cfg b/tests/categorize.cfg
--- a/tests/categorize.cfg
+++ b/tests/categorize.cfg
@@ -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
diff --git a/tests/condition_bindings.cfg b/tests/condition_bindings.cfg
new file mode 100644
--- /dev/null
+++ b/tests/condition_bindings.cfg
@@ -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
+}
+
diff --git a/tests/condition_bindings_stats.out b/tests/condition_bindings_stats.out
new file mode 100644
--- /dev/null
+++ b/tests/condition_bindings_stats.out
@@ -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
diff --git a/tests/small_dump_json.out b/tests/small_dump_json.out
new file mode 100644
--- /dev/null
+++ b/tests/small_dump_json.out
@@ -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}]
diff --git a/tests/small_import_json.in b/tests/small_import_json.in
new file mode 100644
--- /dev/null
+++ b/tests/small_import_json.in
@@ -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}
diff --git a/tests/small_import_json.out b/tests/small_import_json.out
new file mode 100644
Binary files /dev/null and b/tests/small_import_json.out differ
diff --git a/tests/small_import_json_list.in b/tests/small_import_json_list.in
new file mode 100644
--- /dev/null
+++ b/tests/small_import_json_list.in
@@ -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}
+]
diff --git a/tests/small_import_json_list.out b/tests/small_import_json_list.out
new file mode 100644
Binary files /dev/null and b/tests/small_import_json_list.out differ
diff --git a/tests/test.hs b/tests/test.hs
--- a/tests/test.hs
+++ b/tests/test.hs
@@ -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 ()