TimeTracker.hs

{-# LANGUAGE DeriveGeneric, TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable #-}

module TimeTracker where

import Control.Monad
import qualified Control.Exception as E
import Control.Concurrent
import Control.Concurrent.STM
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import qualified Data.HashMap.Strict as H
import qualified Data.Text as T
import qualified Data.Vector as V
import Data.Maybe
import Data.Int
import Data.Typeable
import Data.Time
import System.Environment (getEnv)
import System.Directory (doesFileExist)
import System.FilePath ((</>))
import System.IO
import Data.Binary as Binary
import Data.Binary.Get (isEmpty)
import GHC.Generics (Generic)

import XMonad
import qualified XMonad.Util.ExtensibleState as XS
import qualified XMonad.StackSet as W
import XMonad.Prompt.Input
import Themes

data TEvent = TEvent {
       eTimestamp :: UTCTime
     , eTask :: String
     , eWindowTitle :: String
     , eWindowClass :: String
     , eWorkspace :: String
     }
   | Quit
   deriving (Eq, Show, Generic, Typeable)

instance Binary UTCTime where
 put (UTCTime (ModifiedJulianDay d) t) = do
        Binary.put d
        Binary.put (toRational t)
 get = do
        d <- Binary.get
        t <- Binary.get
        return $ UTCTime (ModifiedJulianDay d) ({-# SCC diffTimeFromRational #-} fromRational t)

instance Binary TEvent

data Tracker = Tracker {
      trackerChan :: TChan TEvent,
      trackerTask :: String
    }
    | NoTracker
    deriving (Typeable)

instance ExtensionClass Tracker where
  initialValue = NoTracker

defaultTrackerLog :: IO FilePath
defaultTrackerLog = do
  home <- getEnv "HOME"
  return $ home </> ".xmonad" </> "tracker.dat"

trackerInit :: FilePath -> X ()
trackerInit path = do
  chan <- io $ atomically $ newTChan
  file <- io $ openFile path AppendMode
  io $ forkIO $ writer chan file
  let tracker = Tracker chan "Startup"
  XS.put tracker

writer :: TChan TEvent -> Handle -> IO ()
writer chan file = go
  where
    go = do
      ev <- atomically $ readTChan chan
      case ev of
        Quit -> hClose file
        _ -> do
             BL.hPut file $ encode ev
             hFlush file
             go

trackerHook :: X ()
trackerHook = do
  tracker <- XS.get
  let chan = trackerChan tracker
  withWindowSet $ \ss -> do
    whenJust (W.peek ss) $ \window -> do
      time <- io $ getCurrentTime
      cls <- runQuery className window
      winTitle <- runQuery title window
      let event = TEvent {
                    eTimestamp = time,
                    eTask = trackerTask tracker,
                    eWindowTitle = winTitle,
                    eWindowClass = cls,
                    eWorkspace = W.currentTag ss }
      io $ atomically $ writeTChan chan event

trackerSetTask :: String -> X ()
trackerSetTask task = do
  tracker <- XS.get
  XS.put $ tracker {trackerTask = task}

promptTrackerTask :: X ()
promptTrackerTask = do
  x <- inputPrompt myXPConfig "Task"
  whenJust x $ \task -> do
    trackerSetTask task

readEvents :: Binary.Get [TEvent]
readEvents = do
  empty <- isEmpty
  if empty
    then return []
    else do
         ev <- Binary.get
         rest <- readEvents
         return (ev : rest)

tracker-dump.hs

module Main where

import Control.Monad
import qualified Data.ByteString.Lazy as BL
import Data.Binary
import Data.Binary.Get
import System.Environment (getArgs)
import System.IO

import TimeTracker

main :: IO ()
main = do
  args <- getArgs
  filename <- case args of  
                [] -> return "tracker.dat"
                [name] -> return name
                _ -> fail $ "Synopsis: tracker-dump [filename.dat]"
  dat <- BL.readFile filename
  let events = runGet readEvents dat
  forM_ events $ \ev -> print ev
    

xmonad.hs

import XMonad
import XMonad.Util.EZConfig (additionalKeysP)

-- import XMonad.Config.Gnome
import XMonad.Config.Kde (kde4Config)

import XMonad.Actions.GroupNavigation (historyHook)

-- Import hooks to support EWMH and other compatibility hooks
import XMonad.Hooks.EwmhDesktops (ewmh)
import XMonad.Hooks.SetWMName    (setWMName)
import XMonad.Hooks.Minimize     (minimizeEventHook)
import XMonad.Util.Replace

-- My local modules (from ~/.xmonad/lib/)
import AppGroups     (apps2keys)
import KeyBindings   (myMouseBindings, myKeys, addKeys)
import Layouts       (myLayout)
import MyManageHooks
import Themes
import CommonFunctions (unmapEventHook)
import GroupsSetup   (appsConfig)
import Pidgin
import Remote
import Store
import TimeTracker

------------------------------------------------------------------------
-- General settings
--
baseConfig = kde4Config
baseManageHook = manageHook baseConfig
baseLogHook = logHook baseConfig

main =  do
  replace
  xmonad $ ewmh $ baseConfig {
        terminal           = myTerminal,
        focusFollowsMouse  = False,
        borderWidth        = myBorderWidth,
        modMask            = mod4Mask,
        workspaces         = myWorkspaces,
        normalBorderColor  = inactiveDecoColor,
        focusedBorderColor = myFocusedBorderColor,
 
      -- key bindings
        keys               = myKeys,
        mouseBindings      = myMouseBindings,
 
      -- hooks, layouts
        layoutHook         = myLayout,
        handleEventHook    = unmapEventHook <+> minimizeEventHook,
--         handleXinputHook   = xinputHandler,
        manageHook         = useStoredProps <+> baseManageHook <+> pidginMoveByGroup pidginConfig <+> myManageHook,
        startupHook        = do
                                pidginConnect
                                trackerInit =<< (io defaultTrackerLog)
                                readStoredProps ,
        logHook            = do
                                baseLogHook
--                                 updatePointer (TowardsCentre 0.5 0.5)
                                historyHook
                                setWMName "LG3D"
                                trackerHook
--         focusNewWindow     = myFocusHook
    } `additionalKeysP` (addKeys ++ apps2keys appsConfig)