diff --git a/hoggl.cabal b/hoggl.cabal --- a/hoggl.cabal +++ b/hoggl.cabal @@ -3,7 +3,7 @@ description: Toggl is a simple tool for time tracking. This package provides a library for accessing the Toggl API from Haskell, and an example executable that uses the library. -version: 0.2.0.0 +version: 0.2.0.1 license: BSD3 license-file: LICENSE author: Markus Hauck @@ -27,7 +27,7 @@ , either , formatting , hashable - , http-client < 0.6 + , http-client , http-client-tls , mtl , servant >= 0.9 @@ -45,6 +45,7 @@ hs-source-dirs: main build-depends: base >= 4 && < 5 , either + , formatting , hoggl , http-client , http-client-tls diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE OverloadedStrings #-} module Main where @@ -11,8 +12,11 @@ import qualified Data.Text.IO as T import Data.Time.Calendar (Day, fromGregorian, toGregorian) import Data.Time.Calendar.WeekDate (toWeekDate, fromWeekDate) -import Data.Time.Clock (UTCTime(..), getCurrentTime, addUTCTime) +import Data.Time.Clock (UTCTime(..), getCurrentTime) import Data.Time.Format (formatTime, defaultTimeLocale, parseTimeM) +import Formatting (sformat, (%)) +import qualified Formatting as F +import qualified Formatting.Time as F import GHC.IO.Handle.FD (stderr) import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) @@ -33,9 +37,9 @@ <> header "hoggl - the Haskell Toggl client.") run :: HoggleArgs -> IO () -run (HoggleArgs auth _ _ TimeToday) = do +run (HoggleArgs auth _ TimeToday) = do manager <- newManager tlsManagerSettings - let clientEnv = ClientEnv manager togglBaseUrl + let clientEnv = mkClientEnv manager togglBaseUrl e <- runClientM (timeEntriesToday auth) clientEnv case e of Left _ -> die "There was an error." @@ -43,31 +47,31 @@ ds <- traverse calcDuration ts T.putStrLn (pretty (sum ds)) -run (HoggleArgs auth _ _ TimeWeek) = do +run (HoggleArgs auth _ TimeWeek) = do day <- utctDay <$> getCurrentTime let (year,weekNr,dow) = toWeekDate day doReport auth (fromWeekDate year weekNr 1) (fromWeekDate year weekNr dow) -run (HoggleArgs auth _ _ TimeMonth) = do +run (HoggleArgs auth _ TimeMonth) = do day <- utctDay <$> getCurrentTime let (year,month,dom) = toGregorian day doReport auth (fromGregorian year month 1) (fromGregorian year month dom) -run (HoggleArgs auth _ _ StartTimer) = do +run (HoggleArgs auth _ StartTimer) = do e <- tryStartDefault auth case e of Left _ -> die "Failed to start timer." Right _ -> return () -run (HoggleArgs auth _ _ StopTimer) = do +run (HoggleArgs auth _ StopTimer) = do e <- tryStopRunning auth case e of Left _ -> die "Failed to stop timer." Right _ -> return () -run (HoggleArgs auth _ _ Info) = do +run (HoggleArgs auth _ Info) = do manager <- newManager tlsManagerSettings - let clientEnv = ClientEnv manager togglBaseUrl + let clientEnv = mkClientEnv manager togglBaseUrl e <- runClientM (listWorkspaces auth) clientEnv case e of Left _ -> die "Failed to get workspaces." @@ -75,22 +79,19 @@ putStrLn "Workspaces:" for_ ws (putStrLn . ("- " <>) . workspacePretty) -run (HoggleArgs auth lastDow workHours HowLong) = do +run (HoggleArgs auth workHours HowLong) = do manager <- newManager tlsManagerSettings - let clientEnv = ClientEnv manager togglBaseUrl - start <- startOfCurrentWeek + let clientEnv = mkClientEnv manager togglBaseUrl + start <- utctDay <$> getCurrentTime eCurLogged <- runClientM (timeEntriesFromTillNow auth start) clientEnv case eCurLogged of Left _ -> die "Failed to get time entries." Right ts -> do worked <- sum <$> traverse calcDuration ts - req <- requiredTime lastDow workHours - let diff = fromIntegral req - worked - endTime <- addUTCTime diff <$> getCurrentTime - let fendTime = formatTime defaultTimeLocale "%R" endTime - T.putStrLn $ pretty diff <> T.pack (", average reached at " <> fendTime) + let diff = (fromIntegral workHours * 60 * 60) - worked + T.putStrLn (sformat ("Target of " % F.int % " hours reached: " % F.diff True) workHours diff) -run (HoggleArgs auth _ _ (Report rSince rUntil)) = do +run (HoggleArgs auth _ (Report rSince rUntil)) = do tSince <- parseTimeM True defaultTimeLocale dateFormat rSince tUntil <- case rUntil of Just rUntil' -> parseTimeM True defaultTimeLocale dateFormat rUntil' @@ -100,7 +101,7 @@ doReport :: Token -> Day -> Day -> IO () doReport auth tSince tUntil = do manager <- newManager tlsManagerSettings - let clientEnv = ClientEnv manager togglBaseUrl + let clientEnv = mkClientEnv manager togglBaseUrl eResult <- runClientM (do ws <- listWorkspaces auth when (length ws /= 1) (liftIO $ die "Ambiguous workspace") @@ -119,10 +120,10 @@ T.putStrLn (T.pack (formatTime defaultTimeLocale dateFormat (unpack (teStart (head tesPerDay)))) <> ": " <> pretty (sum durations)) - T.putStrLn ("Total: " <> pretty (fromIntegral (drTotalGrand report))) + T.putStrLn ("Total: " <> pretty @Double (fromIntegral (drTotalGrand report))) where unpack (ISO6801 x) = x -data HoggleArgs = HoggleArgs Token Integer Integer HoggleCmd +data HoggleArgs = HoggleArgs Token Integer HoggleCmd data HoggleCmd = TimeToday | TimeWeek | TimeMonth @@ -137,19 +138,11 @@ token :: Parser Token token = Api <$> strOption (long "token" <> help "API Token") -lastDowOpt :: Parser Integer -lastDowOpt = option auto (long "last-dow" - <> short 'l' - <> value 5 - <> showDefault - <> help "Last work day of week (1 = Monday)") - workHoursOpt :: Parser Integer -workHoursOpt = option auto (long "work-yours" - <> short 'h' +workHoursOpt = option auto (long "hours" <> value 8 <> showDefault - <> help "Number of hours to work per day in avg.") + <> help "Number of hours to work per day.") todayCmd :: Mod CommandFields HoggleCmd todayCmd = command "today" (info (pure TimeToday) (progDesc "List today's time.")) @@ -167,7 +160,7 @@ stopTimerCmd = command "stop" (info (pure StopTimer) (progDesc "Stop the current timer.")) howLongCmd :: Mod CommandFields HoggleCmd -howLongCmd = command "howlong" (info (pure HowLong) (progDesc "How long until 8h per day reached.")) +howLongCmd = command "howlong" (info (pure HowLong) (progDesc "How long until 8h reached.")) reportCmd :: Mod CommandFields HoggleCmd reportCmd = command "report" (info (Report <$> strArgument (metavar "SINCE") @@ -180,7 +173,6 @@ hoggleArgsParser :: Parser HoggleArgs hoggleArgsParser = HoggleArgs <$> token - <*> lastDowOpt <*> workHoursOpt <*> subparser (todayCmd <> weekCmd @@ -191,26 +183,8 @@ <> reportCmd <> infoCmd) -startOfCurrentWeek :: IO Day -startOfCurrentWeek = do - today <- utctDay <$> getCurrentTime - let (year,weekNr,_) = toWeekDate today - monday = fromWeekDate year weekNr 1 - return monday - die :: String -> IO () die msg = hPutStrLn stderr msg >> exitFailure - -requiredTime :: Integer -> Integer -> IO Integer -requiredTime lastDow hoursPerDay = dowToSecondsNeeded - . min lastDow - . fromIntegral - . thrd - . toWeekDate - . utctDay - <$> getCurrentTime - where thrd (_,_,x) = x - dowToSecondsNeeded dow = dow * hoursPerDay * 60 * 60 dateFormat :: String dateFormat = "%Y-%m-%d" diff --git a/src/Network/Hoggl.hs b/src/Network/Hoggl.hs --- a/src/Network/Hoggl.hs +++ b/src/Network/Hoggl.hs @@ -55,8 +55,8 @@ currentTimeEntry :: Token -> ClientM (Maybe TimeEntry) currentTimeEntry token = (Just <$> currentTimeEntry' (Just token)) `catchError` handler where - handler :: ServantError -> ClientM (Maybe TimeEntry) - handler DecodeFailure {responseBody = "{\"data\":null}"} = return Nothing + handler :: ClientError -> ClientM (Maybe TimeEntry) + handler (DecodeFailure "{\"data\":null}" _) = return Nothing handler e = throwError e stopTimer :: Token -> TimeEntryId -> ClientM TimeEntry @@ -127,16 +127,16 @@ prettyCurrent :: Token -> IO () prettyCurrent authorization = do - manager <- newManager tlsManagerSettings - etimer <- runClientM (currentTimeEntry authorization) $ ClientEnv manager togglBaseUrl + nmanager <- newManager tlsManagerSettings + etimer <- runClientM (currentTimeEntry authorization) $ mkClientEnv nmanager togglBaseUrl case etimer of Right (Just timer) -> calcDuration timer >>= T.putStrLn . pretty _ -> return () tryStartDefault :: Token -> IO (Either HogglError TimeEntry) tryStartDefault authorization = do - manager <- newManager tlsManagerSettings - let clientEnv = ClientEnv manager togglBaseUrl + nmanager <- newManager tlsManagerSettings + let clientEnv = mkClientEnv nmanager togglBaseUrl currentTimer <- runClientM (currentTimeEntry authorization) clientEnv case currentTimer of Right Nothing -> @@ -146,8 +146,8 @@ tryStopRunning :: Token -> IO (Either HogglError TimeEntry) tryStopRunning authorization = do - manager <- newManager tlsManagerSettings - let clientEnv = ClientEnv manager togglBaseUrl + nmanager <- newManager tlsManagerSettings + let clientEnv = mkClientEnv nmanager togglBaseUrl currentTimer <- runClientM (currentTimeEntry authorization) clientEnv case currentTimer of Right (Just TimeEntry {teId = tid}) -> diff --git a/src/Network/Hoggl/Types.hs b/src/Network/Hoggl/Types.hs --- a/src/Network/Hoggl/Types.hs +++ b/src/Network/Hoggl/Types.hs @@ -23,6 +23,7 @@ import Codec.Binary.Base64.String (encode) import Control.Applicative ((<|>)) import Control.Monad (mzero) +import Control.Monad.Fail import Data.Aeson (FromJSON(..), Value (..), (.:), (.:?), ToJSON(..), object, (.=), (.!=)) import Data.Aeson.Types (Parser) import qualified Data.HashMap.Strict as H @@ -58,7 +59,7 @@ parseJSON (String s) = ISO6801 <$> parseTimeStamp s parseJSON _ = mzero -parseTimeStamp :: Monad m => Text -> m UTCTime +parseTimeStamp :: (MonadFail m, Monad m) => Text -> m UTCTime parseTimeStamp ts = parseTimeM True defaultTimeLocale @@ -80,7 +81,7 @@ toUrlPiece (Api token) = toUrlPiece $ "Basic " ++ encode (token ++ ":api_token") toUrlPiece (UserPass user pass) = toUrlPiece $ "Basic " ++ encode (user ++ ":" ++ pass) -data HogglError = ServantError ServantError | HogglError String deriving Show +data HogglError = ServantError ClientError | HogglError String deriving Show data TimeEntryStart = TES { tesDescription :: Maybe Text , tesTags :: [Text] @@ -102,6 +103,7 @@ ,teStop :: Maybe ISO6801 ,teDuration :: NominalDiffTime ,teDescription :: Maybe Text + ,teTags :: Maybe [Text] }deriving (Show,Eq) instance FromJSON TimeEntry where @@ -114,6 +116,7 @@ <*> (d .: "stop" <|> d.:?? "end") <*> (convert <$> ((d .: "duration") <|> ((`div` 1000) <$> (d .: "dur")))) <*> d .:? "description" + <*> d .:? "tags" p _ = mzero convert :: Integer -> NominalDiffTime convert = fromIntegral