Add support for the VS Code status bar

fixes mujx#50

sql/get_time_today.sql

@@ -0,0 +1,23 @@
+SELECT
+    coalesce(CAST(SUM(total_seconds) AS bigint), 0) as total_time
+FROM (
+    SELECT
+        time_sent,
+        CAST(extract(epoch FROM previous_diff) AS int8) AS total_seconds
+    FROM (
+        SELECT
+            time_sent,
+            (time_sent - (lag(time_sent) OVER (ORDER BY time_sent))) AS previous_diff
+        FROM
+            heartbeats
+        WHERE
+            sender = $1 AND time_sent >= (current_date + interval '0' day) AND time_sent < (current_date + interval '1' day)
+        ORDER BY
+            time_sent) inner_table
+    WHERE
+        extract(epoch FROM previous_diff) <= (15 * 60)
+    GROUP BY
+        time_sent,
+        previous_diff
+    ORDER BY
+        time_sent) as result

src/Haka/Database.hs

@@ -137,6 +137,9 @@ class (Monad m, MonadThrow m) => Db m where
   -- | Get total time between the given time ranges.
   getTotalTimeBetween :: HqPool.Pool -> V.Vector (Text, Text, UTCTime, UTCTime) -> m [Int64]
 
+  -- | Get total coding time of the current day.
+  getTotalTimeToday :: HqPool.Pool -> Text -> m Int64
+
   -- | Update token metadata set by the user.
   updateTokenMetadata :: HqPool.Pool -> Text -> TokenMetadata -> m ()
 
@@ -243,6 +246,9 @@ instance Db IO where
     -- We return in reverse order because we insert with descending but we sort in ascending.
     res <- HqPool.use pool (Sessions.getTotalTimeBetween ranges)
     either (throw . SessionException) (pure . reverse) res
+  getTotalTimeToday pool user = do
+    res <- HqPool.use pool (Sessions.getTotalTimeToday user)
+    either (throw . SessionException) pure res
   updateTokenMetadata pool user metadata = do
     res <- HqPool.use pool (Sessions.updateTokenMetadata user metadata)
     either (throw . SessionException) pure res

src/Haka/Db/Sessions.hs

@@ -206,3 +206,6 @@ getLeaderboards t0 t1 = statement (t0, t1) Statements.getLeaderboards
 
 getTotalTimeBetween :: V.Vector (Text, Text, UTCTime, UTCTime) -> Session [Int64]
 getTotalTimeBetween times = statement times Statements.getTotalTimeBetween
+
+getTotalTimeToday :: Text -> Session Int64
+getTotalTimeToday user = statement user Statements.getTotalTimeToday

src/Haka/Db/Statements.hs

@@ -680,3 +680,13 @@ getTotalTimeBetween = Statement query params result True
           (vectorEncoder E.text)
           (vectorEncoder E.timestamptz)
           (vectorEncoder E.timestamptz)
+
+getTotalTimeToday :: Statement Text Int64
+getTotalTimeToday = Statement query params result True
+  where
+    result :: D.Result Int64
+    result = D.singleRow (D.column (D.nonNullable D.int8))
+    params :: E.Params Text
+    params = E.param (E.nonNullable E.text)
+    query :: ByteString
+    query = $(embedFile "sql/get_time_today.sql")

src/Haka/Handlers/Badges.hs

@@ -14,12 +14,12 @@ import Haka.App (AppCtx (..), AppM, ServerSettings (..))
 import qualified Haka.Database as Db
 import qualified Haka.Errors as Err
 import Haka.Types (ApiToken (..), BadgeRow (..))
+import Haka.Utils (compoundDuration)
 import Network.HTTP.Client
 import Network.HTTP.Client.TLS
 import Network.HTTP.Media ((//))
 import qualified Relude.Unsafe as Unsafe
 import Servant
-import Text.Printf (printf)
 
 -- SVG MIME type.
 data SVG
@@ -109,22 +109,3 @@ badgeSvgHandler badgeId daysParam = do
   response <- liftIO $ httpLbs request manager
 
   return $ toStrict $ responseBody response
-
-reduceBy :: Integral a => a -> [a] -> [a]
-n `reduceBy` xs = n' : ys where (n', ys) = mapAccumR quotRem n xs
-
-durLabs :: [(Int64, Text)]
-durLabs = [(0, "wk"), (7, "day"), (24, "hrs"), (60, "min"), (60, "sec")]
-
-computeDurations :: Int64 -> [(Int64, Text)]
-computeDurations t =
-  let ds = t `reduceBy` map fst (Unsafe.tail durLabs)
-   in filter ((/= 0) . fst) $ zip ds (map snd durLabs)
-
-compoundDuration :: Maybe Int64 -> Text
-compoundDuration Nothing = "no data"
-compoundDuration (Just v) =
-  let durations = computeDurations v
-   in if not (null durations)
-        then unwords $ map (toText . \(n, s) -> printf "%d %s" n s :: String) $ Unsafe.init durations
-        else "no data"

src/Haka/Handlers/Stats.hs

@@ -19,13 +19,13 @@ import qualified Haka.Database as Db
 import Haka.Errors (missingAuthError)
 import qualified Haka.Errors as Err
 import Haka.Types (ApiToken (..), StatRow (..), TimelineRow (..))
-import Haka.Utils (defaultLimit)
+import Haka.Utils (compoundDuration, defaultLimit)
 import Katip
 import PostgreSQL.Binary.Data (Scientific)
 import qualified Relude.Unsafe as Unsafe
 import Servant
 
-data DayTextValue = DayTextValue
+newtype DayTextValue = DayTextValue
   { tText :: Text
   }
   deriving (Show, Generic)
@@ -36,7 +36,7 @@ data DayGrandTotal = DayGrandTotal
   }
   deriving (Show, Generic)
 
-data StatusBarPayload = StatusBarPayload
+newtype StatusBarPayload = StatusBarPayload
   { tData :: DayGrandTotal
   }
   deriving (Show, Generic)
@@ -227,22 +227,35 @@ timelineStatsHandler t0Param t1Param timeLimit (Just token) = do
 
 todayTimeHandler :: Maybe ApiToken -> AppM StatusBarPayload
 todayTimeHandler Nothing = throw missingAuthError
-todayTimeHandler (Just token) = do
+todayTimeHandler (Just apiTkn) = do
   let ctx = sl "day" ("today" :: Text)
 
-  logF ctx "stats" DebugS "requesting statusbar activity for today"
-
-  return $
-    StatusBarPayload
-      { tData =
-          DayGrandTotal
-            { tCategories = [],
-              tGrand_total =
-                DayTextValue
-                  { tText = "2 hours 19 minutes"
-                  }
-            }
-      }
+  logF ctx "statusbar" DebugS "requesting today's statusbar activity"
+
+  dbPool <- asks pool
+
+  userRes <- try $ liftIO $ Db.getUser dbPool apiTkn
+
+  user <- either Err.logError pure userRes
+
+  case user of
+    Nothing -> throw Err.invalidTokenError
+    Just user' -> do
+      res <- try $ liftIO $ Db.getTotalTimeToday dbPool user'
+
+      totalTime <- either Err.logError pure res
+
+      return $
+        StatusBarPayload
+          { tData =
+              DayGrandTotal
+                { tCategories = [],
+                  tGrand_total =
+                    DayTextValue
+                      { tText = compoundDuration (Just totalTime)
+                      }
+                }
+          }
 
 statsHandler ::
   Maybe UTCTime ->

src/Haka/Utils.hs

@@ -18,6 +18,7 @@ module Haka.Utils
     removeAYear,
     addAWeek,
     addAMonth,
+    compoundDuration,
   )
 where
 
@@ -33,6 +34,7 @@ import Hasql.Pool (UsageError (..))
 import qualified Hasql.Session as S
 import qualified Relude.Unsafe as Unsafe
 import System.IO (hFlush, hGetEcho, hSetEcho, putChar)
+import Text.Printf (printf)
 import Web.Cookie
 
 defaultLimit :: Int64
@@ -170,3 +172,22 @@ removeAMonth t = UTCTime {utctDay = addDays (-30) (utctDay t), utctDayTime = 0}
 removeAYear t = UTCTime {utctDay = addDays (-365) (utctDay t), utctDayTime = 0}
 addAWeek t = UTCTime {utctDay = addDays 7 (utctDay t), utctDayTime = 0}
 addAMonth t = UTCTime {utctDay = addDays 30 (utctDay t), utctDayTime = 0}
+
+reduceBy :: Integral a => a -> [a] -> [a]
+n `reduceBy` xs = n' : ys where (n', ys) = mapAccumR quotRem n xs
+
+durLabs :: [(Int64, Text)]
+durLabs = [(0, "wk"), (7, "day"), (24, "hrs"), (60, "min"), (60, "sec")]
+
+computeDurations :: Int64 -> [(Int64, Text)]
+computeDurations t =
+  let ds = t `reduceBy` map fst (Unsafe.tail durLabs)
+   in filter ((/= 0) . fst) $ zip ds (map snd durLabs)
+
+compoundDuration :: Maybe Int64 -> Text
+compoundDuration Nothing = "no data"
+compoundDuration (Just v) =
+  let durations = computeDurations v
+   in if not (null durations)
+        then unwords $ map (toText . \(n, s) -> printf "%d %s" n s :: String) $ Unsafe.init durations
+        else "no data"