dev-resources.site

for different kinds of informations.

Hacking Watson with Haskell - Part 3

Published at

8/17/2024

Program

This blog post is a Literate Haskell program that attempts to start/stop Watson timer. We will build on top of the previous blog posts (part 1, part 2). If you haven't read them, I recommend you to read them first.

Let's start with the language extensions:

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

We will use aeson package like in the previous post, in addition to the libraries coming with the GHC. Also, we will use directory and uuid packages. Finally, we will use the infamous optparse-applicative library. Let's declare our imports:

import Control.Applicative ((<**>))
import Control.Monad (join)
import Data.Aeson qualified as Aeson
import Data.Text qualified as T
import Data.Time qualified as Time
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import Data.UUID qualified as UUID
import Data.UUID.V4 qualified as UUID
import Options.Applicative qualified as OA
import System.Directory (XdgDirectory (..), doesFileExist, getXdgDirectory)
import System.Environment (getArgs)

First of all, we will hardcode filepaths to the Watson JSON files:

getFileFrames :: IO FilePath
getFileFrames =
  getXdgDirectory XdgConfig "watson/frames"


getFileState :: IO FilePath
getFileState =
  getXdgDirectory XdgConfig "watson/state"

Our program represents time as UTCTime although Watson uses epoch time. These are our conversion functions:

fromEpoch :: Int -> Time.UTCTime
fromEpoch =
  posixSecondsToUTCTime . fromIntegral


toEpoch :: Time.UTCTime -> Int
toEpoch =
  floor . utcTimeToPOSIXSeconds

Working with Frames

Let's improve our Frame data type and how we read/write it:

data Frame = Frame
  { frameId :: !T.Text
  , frameSince :: !Time.UTCTime
  , frameUntil :: !Time.UTCTime
  , frameProject :: !T.Text
  , frameTags :: ![T.Text]
  , frameUpdatedAt :: !Time.UTCTime
  }
  deriving (Show, Eq)


instance Aeson.FromJSON Frame where
  parseJSON v = do
    arr <- Aeson.parseJSON v
    case arr of
      [fSince, fUntil, fProj, fId, fTags, fUpdated] -> do
        frameId <- Aeson.parseJSON fId
        frameSince <- fromEpoch <$> Aeson.parseJSON fSince
        frameUntil <- fromEpoch <$> Aeson.parseJSON fUntil
        frameProject <- Aeson.parseJSON fProj
        frameTags <- Aeson.parseJSON fTags
        frameUpdatedAt <- fromEpoch <$> Aeson.parseJSON fUpdated
        pure $ Frame {..}
      _ -> fail "Frame: expected an array of 6 elements"


instance Aeson.ToJSON Frame where
  toJSON Frame {..} =
    Aeson.toJSON
      [ Aeson.toJSON (toEpoch frameSince)
      , Aeson.toJSON (toEpoch frameUntil)
      , Aeson.toJSON frameProject
      , Aeson.toJSON frameId
      , Aeson.toJSON frameTags
      , Aeson.toJSON (toEpoch frameUpdatedAt)
      ]


readFrames :: FilePath -> IO (Either String [Frame])
readFrames fp = do
  frames <- Aeson.eitherDecodeFileStrict fp
  pure $ case frames of
    Left err -> Left ("Failed to parse frames: " <> err)
    Right fs -> Right fs


writeFrames :: FilePath -> [Frame] -> IO ()
writeFrames =
  Aeson.encodeFile

Working with State

Let's improve our State data type and how we read/write it:

data CurrentState
  = CurrentStatePending
  | CurrentStateRunning
      { currentStateRunningSince :: !Time.UTCTime
      , currentStateRunningProject :: !T.Text
      , currentStateRunningTags :: ![T.Text]
      }
  deriving (Show, Eq)


instance Aeson.FromJSON CurrentState where
  parseJSON = Aeson.withObject "CurrentState" $ \o -> do
    if null o
      then pure CurrentStatePending
      else
        CurrentStateRunning
          <$> (fromEpoch <$> o Aeson..: "start")
          <*> o Aeson..: "project"
          <*> o Aeson..: "tags"


instance Aeson.ToJSON CurrentState where
  toJSON CurrentStatePending =
    Aeson.object []
  toJSON CurrentStateRunning {..} =
    Aeson.object
      [ "start" Aeson..= toEpoch currentStateRunningSince
      , "project" Aeson..= currentStateRunningProject
      , "tags" Aeson..= currentStateRunningTags
      ]


readState :: FilePath -> IO (Maybe CurrentState)
readState fp = do
  exists <- doesFileExist fp
  if exists
    then do
      mState <- Aeson.eitherDecodeFileStrict fp
      pure $ case mState of
        Left _ -> Nothing
        Right state -> Just state
    else pure $ Just CurrentStatePending


writeState :: FilePath -> CurrentState -> IO ()
writeState =
  Aeson.encodeFile

Main Program

Our main program is a CLI program powered by optparse-applicative. It will offer two subcommands to start and stop the timer. Let's define our options:

opts :: OA.Parser (IO ())
opts =
  OA.subparser
    ( OA.command "start" (OA.info (startCommand <**> OA.helper) OA.idm)
        <> OA.command "stop" (OA.info (stopCommand <**> OA.helper) OA.idm)
    )


startCommand :: OA.Parser (IO ())
startCommand =
  start
    <$> OA.strOption (OA.long "project" <> OA.short 'p' <> OA.metavar "PROJECT")
    <*> OA.many (OA.strOption (OA.long "tag" <> OA.short 't' <> OA.metavar "TAG"))


stopCommand :: OA.Parser (IO ())
stopCommand = do
  pure stop

Good. Now, let's define the start function. It should be easy: If there is no timer running (or state file exists), we will start the timer. Otherwise, we will print an error message:

start :: T.Text -> [T.Text] -> IO ()
start project tags = do
  fState <- getFileState
  mState <- readState fState
  case mState of
    Just CurrentStateRunning {} ->
      putStrLn "Already running"
    _ -> do
      putStrLn "Starting..."
      now <- Time.getCurrentTime
      writeState fState $ CurrentStateRunning now project tags

The stop function is just a bit more involved. We will read the state file and if the timer is running, we will stop it. We will also write the frame to the frames file. If the timer is not running, we will print an error message:

stop :: IO ()
stop = do
  fState <- getFileState
  mState <- readState fState
  case mState of
    Just CurrentStateRunning {..} -> do
      putStrLn "Stopping..."
      now <- Time.getCurrentTime
      fFrames <- getFileFrames
      frames <- readFrames fFrames
      case frames of
        Left err -> putStrLn err
        Right fs -> do
          frameId <- T.replace "-" "" . UUID.toText <$> UUID.nextRandom
          let frame =
                Frame
                  { frameSince = currentStateRunningSince
                  , frameUntil = now
                  , frameProject = currentStateRunningProject
                  , frameTags = currentStateRunningTags
                  , frameUpdatedAt = now
                  , ..
                  }
          writeFrames fFrames (fs <> [frame])
          writeState fState CurrentStatePending
    _ -> putStrLn "Not running..."

Now, we can define our main function:

main :: IO ()
main = do
  join $ OA.execParser (OA.info (opts <**> OA.helper) OA.idm)

Wrap-Up

In just 3 blog posts, we managed to read/write Watson JSON files and start/stop the timer.

From a functionality point of view, we are missing a lot of features. This is what Watson offers:

$ watson --help
Usage: watson [OPTIONS] COMMAND [ARGS]...

  Watson is a tool aimed at helping you monitoring your time.

  You just have to tell Watson when you start working on your project with the
  `start` command, and you can stop the timer when you're done with the `stop`
  command.

Options:
  --version             Show the version and exit.
  --color / --no-color  (Don't) color output.
  --help                Show this message and exit.

Commands:
  add        Add time to a project with tag(s) that was not tracked live.
  aggregate  Display a report of the time spent on each project...
  cancel     Cancel the last call to the start command.
  config     Get and set configuration options.
  edit       Edit a frame.
  frames     Display the list of all frame IDs.
  help       Display help information
  log        Display each recorded session during the given timespan.
  merge      Perform a merge of the existing frames with a conflicting...
  projects   Display the list of all the existing projects.
  remove     Remove a frame.
  rename     Rename a project or tag.
  report     Display a report of the time spent on each project.
  restart    Restart monitoring time for a previously stopped project.
  start      Start monitoring time for the given project.
  status     Display when the current project was started and the time...
  stop       Stop monitoring time for the current project.
  sync       Get the frames from the server and push the new ones.
  tags       Display the list of all the tags.

And this is what we have:

$ runhaskell -pgmLmarkdown-unlit content/posts/2024-08-17_hacking-watson-part-3.lhs --help
Usage: 2024-08-17_hacking-watson-part-3.lhs COMMAND

Available options:
  -h,--help                Show this help text

Available commands:
  start
  stop

Also, our start and stop functions do not perform any validation or offer options such as --no-gap or --at.

From a Good Haskell point of view, we are missing a lot of things. For example, we are not dealing with errors properly. We could have defined an error data type and use it with MonadError to make sure that we cover possible error cases and propagate them properly.

I know someone who is willing to learn Haskell. Maybe I can convince him to work on this project.

lifehack Article's

30 articles in total