diff --git a/README b/README --- a/README +++ b/README @@ -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 =========== diff --git a/arbtt.cabal b/arbtt.cabal --- a/arbtt.cabal +++ b/arbtt.cabal @@ -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 diff --git a/categorize.cfg b/categorize.cfg --- a/categorize.cfg +++ b/categorize.cfg @@ -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, diff --git a/src/Data.hs b/src/Data.hs --- a/src/Data.hs +++ b/src/Data.hs @@ -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 diff --git a/src/TimeLog.hs b/src/TimeLog.hs --- a/src/TimeLog.hs +++ b/src/TimeLog.hs @@ -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 diff --git a/src/UpgradeLog1.hs b/src/UpgradeLog1.hs new file mode 100644 --- /dev/null +++ b/src/UpgradeLog1.hs @@ -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 + + diff --git a/src/capture-main.hs b/src/capture-main.hs --- a/src/capture-main.hs +++ b/src/capture-main.hs @@ -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 diff --git a/src/dump-main.hs b/src/dump-main.hs new file mode 100644 --- /dev/null +++ b/src/dump-main.hs @@ -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