arbtt 0.2.0 → 0.3.0
raw patch · 8 files changed
+218/−28 lines, 8 filesdep +binarydep +bytestringnew-component:exe:arbtt-dump
Dependencies added: binary, bytestring
Files
- README +6/−0
- arbtt.cabal +12/−2
- categorize.cfg +0/−11
- src/Data.hs +46/−7
- src/TimeLog.hs +38/−7
- src/UpgradeLog1.hs +61/−0
- src/capture-main.hs +3/−1
- src/dump-main.hs +52/−0
README view
@@ -129,6 +129,12 @@ # Generate statistics about the last hour arbtt-stats -f '$sampleage < 1:00' +Data Dump+=========++If you need to inspect the recorded sample, for example to think about+interesting things to match, use arbtt-dump.+ Development ===========
arbtt.cabal view
@@ -1,5 +1,5 @@ name: arbtt-version: 0.2.0+version: 0.3.0 license: GPL license-file: LICENSE category: Desktop@@ -29,12 +29,13 @@ hs-source-dirs: src build-depends: base == 4.*, filepath, directory, mtl, time, unix,- X11 > 1.4.4+ X11 > 1.4.4, bytestring, binary extra-libraries: Xss other-modules: Data Capture TimeLog+ UpgradeLog1 Graphics.X11.XScreenSaver executable arbtt-stats@@ -47,6 +48,15 @@ Categorize TimeLog Stats++executable arbtt-dump+ main-is: dump-main.hs+ hs-source-dirs: src+ build-depends:+ base == 4.*, parsec == 2.*, containers, setlocale+ other-modules:+ Data+ TimeLog source-repository head type: darcs
categorize.cfg view
@@ -28,14 +28,3 @@ -- Out of curiosity: what percentage of my time am I actually coding Haskell? current window ($program == "gvim" && $title =~ /^[^ ]+\.hs \(/ ) ==> tag Editing-Haskell,---- To be able to match on the time of day, I introduce tags for that as well-$time >= 2:00 && $time < 8:00 ==> tag time-of-day:night,-$time >= 8:00 && $time < 12:00 ==> tag time-of-day:morning,-$time >= 12:00 && $time < 14:00 ==> tag time-of-day:lunchtime,-$time >= 14:00 && $time < 18:00 ==> tag time-of-day:afternoon,-$time >= 18:00 && $time < 22:00 ==> tag time-of-day:evening,-$time >= 22:00 || $time < 2:00 ==> tag time-of-day:late-evening,---- This tag always refers to the last 24h-$sampleage <= 24:00 ==> tag last-day,
src/Data.hs view
@@ -2,8 +2,14 @@ import Data.Time import Text.ParserCombinators.ReadPrec (readP_to_Prec)-import Text.ParserCombinators.ReadP+import Text.ParserCombinators.ReadP hiding (get)+import qualified Text.ParserCombinators.ReadP as ReadP import Text.Read (readPrec)+import Data.Binary+import Data.Binary.Put+import Data.Binary.Get+import Control.Applicative+import Control.Monad type TimeLog a = [TimeLogEntry a] @@ -11,7 +17,7 @@ { tlTime :: UTCTime , tlRate :: Integer -- ^ in milli-seconds , tlData :: a }- deriving (Show, Read)+ deriving (Show) instance Functor TimeLogEntry where fmap f tl = tl { tlData = f (tlData tl) }@@ -21,7 +27,7 @@ -- ^ Active window, window title, programm name , cLastActivity :: Integer -- ^ in milli-seconds }- deriving (Show, Read)+ deriving (Show) type ActivityData = [Activity] @@ -31,10 +37,9 @@ } deriving (Ord, Eq) --- < An activity with special meaning: ignored by default (i.e. for idle times)+-- | An activity with special meaning: ignored by default (i.e. for idle times) inactiveActivity = Activity Nothing "inactive" - instance Show Activity where show (Activity mbC t) = maybe "" (++":") mbC ++ t @@ -42,9 +47,9 @@ readPrec = readP_to_Prec $ \_ -> (do cat <- munch1 (/= ':') char ':'- tag <- many1 get+ tag <- many1 ReadP.get return $ Activity (Just cat) tag)- <++ (Activity Nothing `fmap` many1 get)+ <++ (Activity Nothing `fmap` many1 ReadP.get) type Category = String @@ -52,3 +57,37 @@ isCategory cat (Activity (Just cat') _) = cat == cat' isCategory _ _ = False ++-- Data.Binary instances++instance Binary a => Binary (TimeLogEntry a) where+ put tle = do+ -- A version tag+ putWord8 1+ put (tlTime tle)+ put (tlRate tle)+ put (tlData tle)+ get = do+ v <- getWord8+ when (v /= 1) $ error $ "Wrong TimeLogEntry version tag " ++ show v+ TimeLogEntry <$> get <*> get <*> get++instance Binary UTCTime where+ put (UTCTime (ModifiedJulianDay d) t) = do+ put d+ put (toRational t)+ get = do+ d <- get+ t <- get+ return $ UTCTime (ModifiedJulianDay d) (fromRational t)++instance Binary CaptureData where+ put cd = do+ -- A version tag+ putWord8 1+ put (cWindows cd)+ put (cLastActivity cd)+ get = do+ v <- getWord8+ when (v /= 1) $ error $ "Wrong TimeLogEntry version tag " ++ show v+ CaptureData <$> get <*> get
src/TimeLog.hs view
@@ -1,25 +1,56 @@ module TimeLog where +import Data+ import Control.Applicative import System.IO-import Data import Control.Concurrent import Control.Monad import Data.Time+import Data.Binary+import Data.Binary.Get+import Data.Function+import Data.Char+import System.Directory +import qualified Data.ByteString.Lazy as BS++magic = BS.pack $ map (fromIntegral.ord) $ "arbtt-timelog-v1\n"+ -- | Runs the given action each delay milliseconds and appends the TimeLog to the -- given file.-runLogger :: (Show a) => FilePath -> Integer -> IO a -> IO ()+runLogger :: Binary a => FilePath -> Integer -> IO a -> IO () runLogger filename delay action = forever $ do entry <- action date <- getCurrentTime+ createTimeLog False filename appendTimeLog filename (TimeLogEntry date delay entry) threadDelay (fromIntegral delay * 1000) +createTimeLog :: Bool -> FilePath -> IO ()+createTimeLog force filename = do+ ex <- doesFileExist filename+ when (not ex || force) $ BS.writeFile filename magic -appendTimeLog :: Show a => FilePath -> TimeLogEntry a -> IO ()--- Double show to ensure it is one string on one line-appendTimeLog filename tl = appendFile filename $ (++"\n") $ show $ show $ tl+appendTimeLog :: Binary a => FilePath -> TimeLogEntry a -> IO ()+appendTimeLog filename tle = BS.appendFile filename $ encode $ tle -readTimeLog :: Read a => FilePath -> IO (TimeLog a)-readTimeLog filename = (map (read.read) . lines) <$> (openFile filename ReadMode >>= hGetContents)+writeTimeLog :: Binary a => FilePath -> TimeLog a -> IO ()+writeTimeLog filename tl = do createTimeLog True filename+ mapM_ (appendTimeLog filename) tl++readTimeLog :: Binary a => FilePath -> IO (TimeLog a)+readTimeLog filename = do+ content <- BS.readFile filename+ return $ runGet start content+ where start = do+ startString <- getLazyByteString (BS.length magic)+ if startString == magic+ then go+ else error $+ "Timelog starts with unknown marker " +++ show (map (chr.fromIntegral) (BS.unpack startString))+ go = do v <- get+ m <- isEmpty+ if m then return [v]+ else (v :) <$> go
+ src/UpgradeLog1.hs view
@@ -0,0 +1,61 @@+module UpgradeLog1 (upgradeLogFile1) where++import qualified Data.ByteString.Char8 as BS+import System.IO+import Data.Time+import Control.Applicative+import Control.Monad+import System.Directory++import TimeLog (writeTimeLog)+import qualified Data as D++-- | A copy of the data definitions as they were on 2009-10-03, to be able to+-- change them in the main code later, and still be able to read old log files.++type TimeLog a = [TimeLogEntry a]++data TimeLogEntry a = TimeLogEntry+ { tlTime :: UTCTime+ , tlRate :: Integer -- ^ in milli-seconds+ , tlData :: a }+ deriving (Show, Read)++instance Functor TimeLogEntry where+ fmap f tl = tl { tlData = f (tlData tl) }++data CaptureData = CaptureData+ { cWindows :: [ (Bool, String, String) ]+ -- ^ Active window, window title, programm name+ , cLastActivity :: Integer -- ^ in milli-seconds+ }+ deriving (Show, Read)++readTimeLog :: Read a => FilePath -> IO (TimeLog a)+readTimeLog filename = (map (read.read) . lines) <$> (openFile filename ReadMode >>= hGetContents)++magicStart = BS.pack "\"TimeLogEntry"++upgradeLogFile1 captureFile = do+ ex <- doesFileExist captureFile+ when ex $ do+ h <- openFile captureFile ReadMode + start <- BS.hGet h (BS.length magicStart)+ hClose h+ when (start == magicStart) $ do+ putStrLn $ "Detected old text file format. Creating backup at " +++ oldFile ++ " and converting to new format..."+ renameFile captureFile oldFile+ captures <- readTimeLog oldFile+ writeTimeLog captureFile (upgrade captures)+ putStrLn $ "done."++ where oldFile = captureFile ++ ".old"++upgrade :: TimeLog CaptureData -> D.TimeLog D.CaptureData+upgrade = map $ \(TimeLogEntry a b c) -> D.TimeLogEntry a b (upgradeCD c)++upgradeCD :: CaptureData -> D.CaptureData+upgradeCD (CaptureData a b) = D.CaptureData a b++
src/capture-main.hs view
@@ -17,6 +17,7 @@ import Capture import TimeLog+import UpgradeLog1 import Paths_arbtt (version) @@ -47,7 +48,7 @@ -- | This is very raw, someone ought to improve this lockFile filename = flip catch (\e -> hPutStrLn stderr ("arbtt [Error]: Could not aquire lock for " ++ filename ++"!") >> exitFailure) $ do- fd <- openFd (filename ++ ".lck") WriteOnly (Just 0644) defaultFileFlags+ fd <- openFd (filename ++ ".lck") WriteOnly (Just 0o644) defaultFileFlags setLock fd (WriteLock, AbsoluteSeek, 0, 0) main = do@@ -76,4 +77,5 @@ createDirectoryIfMissing False dir let captureFile = dir </> "capture.log" lockFile captureFile+ upgradeLogFile1 captureFile runLogger captureFile (sampleRate * 1000) captureData
+ src/dump-main.hs view
@@ -0,0 +1,52 @@+module Main where+import System.Directory+import System.FilePath+import System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO+import qualified Data.Map as M+import Data.Version (showVersion)++import TimeLog+import Data++import Paths_arbtt (version)++data Flag = Help | Version+ deriving Eq++versionStr = "arbtt-dump " ++ showVersion version+header = "Usage: arbtt-dump [OPTIONS...]"++options :: [OptDescr Flag]+options =+ [ Option "h?" ["help"]+ (NoArg Help)+ "show this help"+ , Option ['V'] ["version"]+ (NoArg Version)+ "show the version number"+ ]+++main = do+ args <- getArgs+ case getOpt Permute options args of+ (o,[],[]) | Help `notElem` o && Version `notElem` o -> return ()+ (o,_,_) | Version `elem` o -> do+ hPutStrLn stderr versionStr+ exitSuccess+ (o,_,_) | Help `elem` o -> do+ hPutStr stderr (usageInfo header options)+ exitSuccess+ (_,_,errs) -> do+ hPutStr stderr (concat errs ++ usageInfo header options)+ exitFailure++ dir <- getAppUserDataDirectory "arbtt"+++ let captureFilename = dir </> "capture.log"+ captures <- readTimeLog captureFilename :: IO (TimeLog CaptureData)+ mapM_ print captures