commit a5180facf2375cf629ce7d90f851e6c667f66197
Author: Ben Sima <ben@bensima.com>
Date: Sat Nov 29 22:09:56 2025
Add time range filter to homepage Task Status section
The build and tests pass with no errors. The time range filter
feature f
**Implementation summary:** - Route accepts
`?range=today|week|month|all` query param - `TimeRange` type with
`Today`, `Week`, `Month`, `AllTime` variants - `homeHandler` filters
both tasks and activities by time range - Toggle buttons rendered
with `timeFilterBtn` helper - Full CSS styling in `timeFilterStyles`
with dark mode support - Default selection: "All Time"
Task-Id: t-180
diff --git a/Omni/Jr/Web.hs b/Omni/Jr/Web.hs
index 533d7612..3380b93e 100644
--- a/Omni/Jr/Web.hs
+++ b/Omni/Jr/Web.hs
@@ -21,7 +21,8 @@ import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LazyText
import qualified Data.Text.Lazy.Encoding as LazyText
-import Data.Time (NominalDiffTime, UTCTime, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime)
+import Data.Time (Day, NominalDiffTime, UTCTime (..), dayOfWeek, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime, toGregorian)
+import Data.Time.Calendar (DayOfWeek (..))
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import qualified Lucid
import qualified Lucid.Base as Lucid
@@ -89,8 +90,85 @@ data TaskFilters = TaskFilters
}
deriving (Show, Eq)
+data TimeRange = Today | Week | Month | AllTime
+ deriving (Show, Eq)
+
+parseTimeRange :: Maybe Text -> TimeRange
+parseTimeRange (Just "today") = Today
+parseTimeRange (Just "week") = Week
+parseTimeRange (Just "month") = Month
+parseTimeRange _ = AllTime
+
+timeRangeToParam :: TimeRange -> Text
+timeRangeToParam Today = "today"
+timeRangeToParam Week = "week"
+timeRangeToParam Month = "month"
+timeRangeToParam AllTime = "all"
+
+getTimeRangeStart :: TimeRange -> UTCTime -> Maybe UTCTime
+getTimeRangeStart AllTime _ = Nothing
+getTimeRangeStart Today now = Just (startOfDay now)
+getTimeRangeStart Week now = Just (startOfWeek now)
+getTimeRangeStart Month now = Just (startOfMonth now)
+
+startOfDay :: UTCTime -> UTCTime
+startOfDay t = UTCTime (utctDay t) 0
+
+startOfWeek :: UTCTime -> UTCTime
+startOfWeek t =
+ let day = utctDay t
+ dow = dayOfWeek day
+ daysBack = case dow of
+ Monday -> 0
+ Tuesday -> 1
+ Wednesday -> 2
+ Thursday -> 3
+ Friday -> 4
+ Saturday -> 5
+ Sunday -> 6
+ in UTCTime (addDays (negate daysBack) day) 0
+
+addDays :: Integer -> Day -> Day
+addDays n d =
+ let (y, m, dayNum) = toGregorian d
+ in fromGregorian y m (dayNum + fromInteger n)
+
+fromGregorian :: Integer -> Int -> Int -> Day
+fromGregorian y m d = toEnum (fromInteger (daysSinceEpoch y m d))
+
+daysSinceEpoch :: Integer -> Int -> Int -> Integer
+daysSinceEpoch y m d =
+ let a = (14 - m) `div` 12
+ y' = y + 4800 - toInteger a
+ m' = m + 12 * a - 3
+ jdn = d + (153 * m' + 2) `div` 5 + 365 * fromInteger y' + fromInteger y' `div` 4 - fromInteger y' `div` 100 + fromInteger y' `div` 400 - 32045
+ in toInteger jdn - 2440588
+
+startOfMonth :: UTCTime -> UTCTime
+startOfMonth t =
+ let day = utctDay t
+ (y, m, _) = toGregorian day
+ in UTCTime (fromGregorian y m 1) 0
+
+computeMetricsFromActivities :: [TaskCore.Task] -> [TaskCore.TaskActivity] -> TaskCore.AggregatedMetrics
+computeMetricsFromActivities tasks activities =
+ let completedCount = length [t | t <- tasks, TaskCore.taskStatus t == TaskCore.Done]
+ totalCost = sum [c | act <- activities, Just c <- [TaskCore.activityCostCents act]]
+ totalTokens = sum [t | act <- activities, Just t <- [TaskCore.activityTokensUsed act]]
+ totalDuration = sum [calcDuration act | act <- activities]
+ in TaskCore.AggregatedMetrics
+ { TaskCore.aggTotalCostCents = totalCost,
+ TaskCore.aggTotalDurationSeconds = totalDuration,
+ TaskCore.aggCompletedTasks = completedCount,
+ TaskCore.aggTotalTokens = totalTokens
+ }
+ where
+ calcDuration act = case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of
+ (Just start, Just end) -> floor (diffUTCTime end start)
+ _ -> 0
+
type API =
- Get '[Lucid.HTML] HomePage
+ QueryParam "range" Text :> Get '[Lucid.HTML] HomePage
:<|> "style.css" :> Get '[CSS] LazyText.Text
:<|> "ready" :> Get '[Lucid.HTML] ReadyQueuePage
:<|> "blocked" :> Get '[Lucid.HTML] BlockedPage
@@ -139,7 +217,7 @@ instance Accept CSS where
instance MimeRender CSS LazyText.Text where
mimeRender _ = LazyText.encodeUtf8
-data HomePage = HomePage TaskCore.TaskStats [TaskCore.Task] [TaskCore.Task] Bool TaskCore.AggregatedMetrics UTCTime
+data HomePage = HomePage TaskCore.TaskStats [TaskCore.Task] [TaskCore.Task] Bool TaskCore.AggregatedMetrics TimeRange UTCTime
data ReadyQueuePage = ReadyQueuePage [TaskCore.Task] UTCTime
@@ -611,12 +689,17 @@ renderListGroupItem t =
instance Lucid.ToHtml HomePage where
toHtmlRaw = Lucid.toHtml
- toHtml (HomePage stats readyTasks recentTasks hasMoreRecent globalMetrics _now) =
+ toHtml (HomePage stats readyTasks recentTasks hasMoreRecent globalMetrics currentRange _now) =
Lucid.doctypehtml_ <| do
pageHead "Jr Dashboard"
pageBody <| do
Lucid.div_ [Lucid.class_ "container"] <| do
Lucid.h2_ "Task Status"
+ Lucid.div_ [Lucid.class_ "time-filter"] <| do
+ timeFilterBtn "Today" Today currentRange
+ timeFilterBtn "This Week" Week currentRange
+ timeFilterBtn "This Month" Month currentRange
+ timeFilterBtn "All Time" AllTime currentRange
Lucid.div_ [Lucid.class_ "stats-grid"] <| do
statCard "Open" (TaskCore.openTasks stats) "badge-open" "/tasks?status=Open"
statCard "In Progress" (TaskCore.inProgressTasks stats) "badge-inprogress" "/tasks?status=InProgress"
@@ -695,6 +778,16 @@ instance Lucid.ToHtml HomePage where
mins = (totalSeconds `mod` 3600) `div` 60
in tshow hours <> "h " <> tshow mins <> "m"
+ timeFilterBtn :: (Monad m) => Text -> TimeRange -> TimeRange -> Lucid.HtmlT m ()
+ timeFilterBtn label range current =
+ let activeClass = if range == current then " active" else ""
+ href = "/?" <> "range=" <> timeRangeToParam range
+ in Lucid.a_
+ [ Lucid.href_ href,
+ Lucid.class_ ("time-filter-btn" <> activeClass)
+ ]
+ (Lucid.toHtml label)
+
instance Lucid.ToHtml ReadyQueuePage where
toHtmlRaw = Lucid.toHtml
toHtml (ReadyQueuePage tasks _now) =
@@ -2036,17 +2129,26 @@ server =
styleHandler :: Servant.Handler LazyText.Text
styleHandler = pure Style.css
- homeHandler :: Servant.Handler HomePage
- homeHandler = do
+ homeHandler :: Maybe Text -> Servant.Handler HomePage
+ homeHandler maybeRangeText = do
now <- liftIO getCurrentTime
- stats <- liftIO <| TaskCore.getTaskStats Nothing
- readyTasks <- liftIO TaskCore.getReadyTasks
+ let range = parseTimeRange maybeRangeText
+ maybeStart = getTimeRangeStart range now
allTasks <- liftIO TaskCore.loadTasks
- globalMetrics <- liftIO TaskCore.getGlobalAggregatedMetrics
- let sortedTasks = List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) allTasks
+ let filteredTasks = case maybeStart of
+ Nothing -> allTasks
+ Just start -> [t | t <- allTasks, TaskCore.taskUpdatedAt t >= start]
+ stats = TaskCore.computeTaskStatsFromList filteredTasks
+ readyTasks <- liftIO TaskCore.getReadyTasks
+ allActivities <- liftIO <| concat </ traverse (TaskCore.getActivitiesForTask <. TaskCore.taskId) allTasks
+ let filteredActivities = case maybeStart of
+ Nothing -> allActivities
+ Just start -> [a | a <- allActivities, TaskCore.activityTimestamp a >= start]
+ globalMetrics = computeMetricsFromActivities filteredTasks filteredActivities
+ sortedTasks = List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) filteredTasks
recentTasks = take 5 sortedTasks
- hasMoreRecent = length allTasks > 5
- pure (HomePage stats readyTasks recentTasks hasMoreRecent globalMetrics now)
+ hasMoreRecent = length filteredTasks > 5
+ pure (HomePage stats readyTasks recentTasks hasMoreRecent globalMetrics range now)
readyQueueHandler :: Servant.Handler ReadyQueuePage
readyQueueHandler = do
diff --git a/Omni/Jr/Web/Style.hs b/Omni/Jr/Web/Style.hs
index ad1ff027..e0cc51e7 100644
--- a/Omni/Jr/Web/Style.hs
+++ b/Omni/Jr/Web/Style.hs
@@ -36,6 +36,7 @@ stylesheet = do
markdownStyles
retryBannerStyles
taskMetaStyles
+ timeFilterStyles
responsiveStyles
darkModeStyles
@@ -1185,6 +1186,37 @@ retryBannerStyles = do
color "#991b1b"
fontWeight (weight 500)
+timeFilterStyles :: Css
+timeFilterStyles = do
+ ".time-filter" ? do
+ display flex
+ Stylesheet.key "gap" ("6px" :: Text)
+ marginBottom (px 12)
+ flexWrap Flexbox.wrap
+ ".time-filter-btn" ? do
+ display inlineBlock
+ padding (px 4) (px 12) (px 4) (px 12)
+ fontSize (px 12)
+ fontWeight (weight 500)
+ textDecoration none
+ borderRadius (px 12) (px 12) (px 12) (px 12)
+ border (px 1) solid "#d0d0d0"
+ backgroundColor white
+ color "#374151"
+ transition "all" (ms 150) ease (sec 0)
+ cursor pointer
+ ".time-filter-btn" # hover ? do
+ borderColor "#999"
+ backgroundColor "#f3f4f6"
+ textDecoration none
+ ".time-filter-btn.active" ? do
+ backgroundColor "#0066cc"
+ borderColor "#0066cc"
+ color white
+ ".time-filter-btn.active" # hover ? do
+ backgroundColor "#0055aa"
+ borderColor "#0055aa"
+
taskMetaStyles :: Css
taskMetaStyles = do
".task-meta" ? do
@@ -1443,6 +1475,20 @@ darkModeStyles =
".fact-create-form" ? do
backgroundColor "#1f2937"
borderColor "#374151"
+ ".time-filter-btn" ? do
+ backgroundColor "#374151"
+ borderColor "#4b5563"
+ color "#d1d5db"
+ ".time-filter-btn" # hover ? do
+ backgroundColor "#4b5563"
+ borderColor "#6b7280"
+ ".time-filter-btn.active" ? do
+ backgroundColor "#3b82f6"
+ borderColor "#3b82f6"
+ color white
+ ".time-filter-btn.active" # hover ? do
+ backgroundColor "#2563eb"
+ borderColor "#2563eb"
-- Responsive dark mode: dropdown content needs background on mobile
query Media.screen [Media.maxWidth (px 600)] <| do
".navbar-dropdown-content" ? do
diff --git a/Omni/Task/Core.hs b/Omni/Task/Core.hs
index 722e696b..d64d607b 100644
--- a/Omni/Task/Core.hs
+++ b/Omni/Task/Core.hs
@@ -1133,6 +1133,43 @@ getAllDescendants allTasks parentId =
let children = filter (maybe False (`matchesId` parentId) <. taskParent) allTasks
in children ++ concatMap (getAllDescendants allTasks <. taskId) children
+computeTaskStatsFromList :: [Task] -> TaskStats
+computeTaskStatsFromList tasks =
+ let total = length tasks
+ draft = length [t | t <- tasks, taskStatus t == Draft]
+ open = length [t | t <- tasks, taskStatus t == Open]
+ inProg = length [t | t <- tasks, taskStatus t == InProgress]
+ review = length [t | t <- tasks, taskStatus t == Review]
+ approved = length [t | t <- tasks, taskStatus t == Approved]
+ done = length [t | t <- tasks, taskStatus t == Done]
+ epics = length [t | t <- tasks, taskType t == Epic]
+ readyCount = open + inProg
+ blockedCount = 0
+ byPriority =
+ [ (P0, length [t | t <- tasks, taskPriority t == P0]),
+ (P1, length [t | t <- tasks, taskPriority t == P1]),
+ (P2, length [t | t <- tasks, taskPriority t == P2]),
+ (P3, length [t | t <- tasks, taskPriority t == P3]),
+ (P4, length [t | t <- tasks, taskPriority t == P4])
+ ]
+ namespaces = mapMaybe taskNamespace tasks
+ uniqueNs = List.nub namespaces
+ byNamespace = [(ns, length [t | t <- tasks, taskNamespace t == Just ns]) | ns <- uniqueNs]
+ in TaskStats
+ { totalTasks = total,
+ draftTasks = draft,
+ openTasks = open,
+ inProgressTasks = inProg,
+ reviewTasks = review,
+ approvedTasks = approved,
+ doneTasks = done,
+ totalEpics = epics,
+ readyTasks = readyCount,
+ blockedTasks = blockedCount,
+ tasksByPriority = byPriority,
+ tasksByNamespace = byNamespace
+ }
+
showTaskStats :: Maybe Text -> IO ()
showTaskStats maybeEpicId = do
stats <- getTaskStats maybeEpicId