commit a4754527ea4244e7933be86471324d9ae65a87e2
Author: Ben Sima <ben@bensima.com>
Date: Fri Nov 28 02:33:03 2025
Remove Jr Dashboard header from homepage
The build and tests pass. The "Jr Dashboard" header has been removed
fro
Task-Id: t-154.6
diff --git a/Omni/Jr/Web.hs b/Omni/Jr/Web.hs
index 465c0210..505bacac 100644
--- a/Omni/Jr/Web.hs
+++ b/Omni/Jr/Web.hs
@@ -21,7 +21,7 @@ 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 (UTCTime, defaultTimeLocale, diffUTCTime, formatTime)
+import Data.Time (NominalDiffTime, UTCTime, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime)
import qualified Lucid
import qualified Lucid.Base as Lucid
import qualified Network.Wai.Handler.Warp as Warp
@@ -40,6 +40,36 @@ type PostRedirect = Verb 'POST 303 '[Lucid.HTML] (Headers '[Header "Location" Te
defaultPort :: Warp.Port
defaultPort = 8080
+formatRelativeTime :: UTCTime -> UTCTime -> Text
+formatRelativeTime now timestamp =
+ let delta = diffUTCTime now timestamp
+ in relativeText delta
+
+relativeText :: NominalDiffTime -> Text
+relativeText delta
+ | delta < 60 = "just now"
+ | delta < 3600 = tshow (round (delta / 60) :: Int) <> " minutes ago"
+ | delta < 7200 = "1 hour ago"
+ | delta < 86400 = tshow (round (delta / 3600) :: Int) <> " hours ago"
+ | delta < 172800 = "yesterday"
+ | delta < 604800 = tshow (round (delta / 86400) :: Int) <> " days ago"
+ | delta < 1209600 = "1 week ago"
+ | delta < 2592000 = tshow (round (delta / 604800) :: Int) <> " weeks ago"
+ | delta < 5184000 = "1 month ago"
+ | delta < 31536000 = tshow (round (delta / 2592000) :: Int) <> " months ago"
+ | otherwise = tshow (round (delta / 31536000) :: Int) <> " years ago"
+
+formatExactTimestamp :: UTCTime -> Text
+formatExactTimestamp = Text.pack <. formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S UTC"
+
+renderRelativeTimestamp :: (Monad m) => UTCTime -> UTCTime -> Lucid.HtmlT m ()
+renderRelativeTimestamp now timestamp =
+ Lucid.span_
+ [ Lucid.class_ "relative-time",
+ Lucid.title_ (formatExactTimestamp timestamp)
+ ]
+ (Lucid.toHtml (formatRelativeTime now timestamp))
+
data TaskFilters = TaskFilters
{ filterStatus :: Maybe TaskCore.Status,
filterPriority :: Maybe TaskCore.Priority,
@@ -95,18 +125,18 @@ instance Accept CSS where
instance MimeRender CSS LazyText.Text where
mimeRender _ = LazyText.encodeUtf8
-data HomePage = HomePage TaskCore.TaskStats [TaskCore.Task] [TaskCore.Task] Bool
+data HomePage = HomePage TaskCore.TaskStats [TaskCore.Task] [TaskCore.Task] Bool UTCTime
-newtype ReadyQueuePage = ReadyQueuePage [TaskCore.Task]
+data ReadyQueuePage = ReadyQueuePage [TaskCore.Task] UTCTime
-newtype BlockedPage = BlockedPage [TaskCore.Task]
+data BlockedPage = BlockedPage [TaskCore.Task] UTCTime
-newtype InterventionPage = InterventionPage [TaskCore.Task]
+data InterventionPage = InterventionPage [TaskCore.Task] UTCTime
-data TaskListPage = TaskListPage [TaskCore.Task] TaskFilters
+data TaskListPage = TaskListPage [TaskCore.Task] TaskFilters UTCTime
data TaskDetailPage
- = TaskDetailFound TaskCore.Task [TaskCore.Task] [TaskCore.TaskActivity] (Maybe TaskCore.RetryContext) [GitCommit]
+ = TaskDetailFound TaskCore.Task [TaskCore.Task] [TaskCore.TaskActivity] (Maybe TaskCore.RetryContext) [GitCommit] UTCTime
| TaskDetailNotFound Text
data GitCommit = GitCommit
@@ -137,7 +167,7 @@ data StatsPage = StatsPage TaskCore.TaskStats (Maybe Text)
newtype KBPage = KBPage [TaskCore.Fact]
data FactDetailPage
- = FactDetailFound TaskCore.Fact
+ = FactDetailFound TaskCore.Fact UTCTime
| FactDetailNotFound Int
data FactEditForm = FactEditForm Text Text Text
@@ -161,7 +191,7 @@ instance FromForm FactCreateForm where
data EpicsPage = EpicsPage [TaskCore.Task] [TaskCore.Task]
-data RecentActivityPartial = RecentActivityPartial [TaskCore.Task] Int Bool
+data RecentActivityPartial = RecentActivityPartial [TaskCore.Task] Int Bool UTCTime
newtype ReadyCountPartial = ReadyCountPartial Int
@@ -169,7 +199,7 @@ data StatusBadgePartial = StatusBadgePartial TaskCore.Status Text
newtype TaskListPartial = TaskListPartial [TaskCore.Task]
-data TaskMetricsPartial = TaskMetricsPartial Text [TaskCore.TaskActivity] (Maybe TaskCore.RetryContext)
+data TaskMetricsPartial = TaskMetricsPartial Text [TaskCore.TaskActivity] (Maybe TaskCore.RetryContext) UTCTime
newtype RejectForm = RejectForm (Maybe Text)
@@ -479,14 +509,12 @@ renderListGroupItem t =
instance Lucid.ToHtml HomePage where
toHtmlRaw = Lucid.toHtml
- toHtml (HomePage stats readyTasks recentTasks hasMoreRecent) =
+ toHtml (HomePage stats readyTasks recentTasks hasMoreRecent _now) =
Lucid.doctypehtml_ <| do
pageHead "Jr Dashboard"
Lucid.body_ <| do
navbar
Lucid.div_ [Lucid.class_ "container"] <| do
- Lucid.h1_ "Jr Dashboard"
-
Lucid.h2_ "Task Status"
multiColorProgressBar stats
Lucid.div_ [Lucid.class_ "stats-grid"] <| do
@@ -541,7 +569,7 @@ instance Lucid.ToHtml HomePage where
instance Lucid.ToHtml ReadyQueuePage where
toHtmlRaw = Lucid.toHtml
- toHtml (ReadyQueuePage tasks) =
+ toHtml (ReadyQueuePage tasks _now) =
Lucid.doctypehtml_ <| do
pageHead "Ready Queue - Jr"
Lucid.body_ <| do
@@ -554,7 +582,7 @@ instance Lucid.ToHtml ReadyQueuePage where
instance Lucid.ToHtml BlockedPage where
toHtmlRaw = Lucid.toHtml
- toHtml (BlockedPage tasks) =
+ toHtml (BlockedPage tasks _now) =
Lucid.doctypehtml_ <| do
pageHead "Blocked Tasks - Jr"
Lucid.body_ <| do
@@ -568,7 +596,7 @@ instance Lucid.ToHtml BlockedPage where
instance Lucid.ToHtml InterventionPage where
toHtmlRaw = Lucid.toHtml
- toHtml (InterventionPage tasks) =
+ toHtml (InterventionPage tasks _now) =
Lucid.doctypehtml_ <| do
pageHead "Needs Intervention - Jr"
Lucid.body_ <| do
@@ -688,7 +716,7 @@ instance Lucid.ToHtml FactDetailPage where
Lucid.h1_ "Fact Not Found"
Lucid.p_ [Lucid.class_ "error-msg"] (Lucid.toHtml ("Fact with ID " <> tshow fid <> " not found."))
Lucid.a_ [Lucid.href_ "/kb", Lucid.class_ "btn btn-secondary"] "Back to Knowledge Base"
- toHtml (FactDetailFound fact) =
+ toHtml (FactDetailFound fact now) =
Lucid.doctypehtml_ <| do
pageHead "Fact Detail - Jr"
Lucid.body_ <| do
@@ -703,7 +731,7 @@ instance Lucid.ToHtml FactDetailPage where
Lucid.span_ [Lucid.class_ "meta-label"] "Confidence:"
confidenceBadgeDetail (TaskCore.factConfidence fact)
Lucid.span_ [Lucid.class_ "meta-label"] "Created:"
- Lucid.span_ [Lucid.class_ "meta-value"] (Lucid.toHtml (formatTimestamp (TaskCore.factCreatedAt fact)))
+ Lucid.span_ [Lucid.class_ "meta-value"] (renderRelativeTimestamp now (TaskCore.factCreatedAt fact))
Lucid.div_ [Lucid.class_ "detail-section"] <| do
Lucid.h2_ "Content"
@@ -770,9 +798,6 @@ instance Lucid.ToHtml FactDetailPage where
Lucid.div_ [Lucid.class_ "back-link"] <| do
Lucid.a_ [Lucid.href_ "/kb"] "← Back to Knowledge Base"
where
- formatTimestamp :: UTCTime -> Text
- formatTimestamp = Text.pack <. formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S"
-
confidenceBadgeDetail :: (Monad m) => Double -> Lucid.HtmlT m ()
confidenceBadgeDetail conf =
let pct = floor (conf * 100) :: Int
@@ -837,7 +862,7 @@ getDescendants allTasks parentId =
instance Lucid.ToHtml TaskListPage where
toHtmlRaw = Lucid.toHtml
- toHtml (TaskListPage tasks filters) =
+ toHtml (TaskListPage tasks filters _now) =
Lucid.doctypehtml_ <| do
pageHead "Tasks - Jr"
Lucid.body_ <| do
@@ -928,7 +953,7 @@ instance Lucid.ToHtml TaskDetailPage where
"The task "
Lucid.code_ (Lucid.toHtml tid)
" could not be found."
- toHtml (TaskDetailFound task allTasks activities maybeRetry commits) =
+ toHtml (TaskDetailFound task allTasks activities maybeRetry commits now) =
Lucid.doctypehtml_ <| do
pageHead (TaskCore.taskId task <> " - Jr")
Lucid.body_ <| do
@@ -973,11 +998,11 @@ instance Lucid.ToHtml TaskDetailPage where
Lucid.div_ [Lucid.class_ "detail-row"] <| do
Lucid.span_ [Lucid.class_ "detail-label"] "Created:"
- Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.taskCreatedAt task)))
+ Lucid.span_ [Lucid.class_ "detail-value"] (renderRelativeTimestamp now (TaskCore.taskCreatedAt task))
Lucid.div_ [Lucid.class_ "detail-row"] <| do
Lucid.span_ [Lucid.class_ "detail-label"] "Updated:"
- Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.taskUpdatedAt task)))
+ Lucid.span_ [Lucid.class_ "detail-value"] (renderRelativeTimestamp now (TaskCore.taskUpdatedAt task))
let deps = TaskCore.taskDependencies task
unless (null deps) <| do
@@ -1098,7 +1123,7 @@ instance Lucid.ToHtml TaskDetailPage where
Lucid.div_ [Lucid.class_ "activity-content"] <| do
Lucid.div_ [Lucid.class_ "activity-header"] <| do
Lucid.span_ [Lucid.class_ "activity-stage"] (Lucid.toHtml (tshow (TaskCore.activityStage act)))
- Lucid.span_ [Lucid.class_ "activity-time"] (Lucid.toHtml (formatTimestamp (TaskCore.activityTimestamp act)))
+ Lucid.span_ [Lucid.class_ "activity-time"] (renderRelativeTimestamp now (TaskCore.activityTimestamp act))
case TaskCore.activityMessage act of
Nothing -> pure ()
Just msg -> Lucid.p_ [Lucid.class_ "activity-message"] (Lucid.toHtml msg)
@@ -1127,9 +1152,6 @@ instance Lucid.ToHtml TaskDetailPage where
TaskCore.Completed -> "✓"
TaskCore.Failed -> "✗"
- formatTimestamp :: UTCTime -> Text
- formatTimestamp = Text.pack <. formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S"
-
renderExecutionDetails :: (Monad m) => Text -> [TaskCore.TaskActivity] -> Maybe TaskCore.RetryContext -> Lucid.HtmlT m ()
renderExecutionDetails _ acts retryCtx =
case findRunningAct acts of
@@ -1151,7 +1173,7 @@ instance Lucid.ToHtml TaskDetailPage where
(Just start, Nothing) ->
Lucid.div_ [Lucid.class_ "metric-row"] <| do
Lucid.span_ [Lucid.class_ "metric-label"] "Started:"
- Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatTimestamp start))
+ Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp now start)
_ -> pure ()
case TaskCore.activityCostCents act of
@@ -1170,7 +1192,7 @@ instance Lucid.ToHtml TaskDetailPage where
Lucid.div_ [Lucid.class_ "metric-row"] <| do
Lucid.span_ [Lucid.class_ "metric-label"] "Last Activity:"
- Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatTimestamp (TaskCore.activityTimestamp act)))
+ Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp now (TaskCore.activityTimestamp act))
where
findRunningAct = List.find (\a -> TaskCore.activityStage a == TaskCore.Running)
@@ -1470,7 +1492,7 @@ instance Lucid.ToHtml StatsPage where
instance Lucid.ToHtml RecentActivityPartial where
toHtmlRaw = Lucid.toHtml
- toHtml (RecentActivityPartial recentTasks nextOffset hasMore) =
+ toHtml (RecentActivityPartial recentTasks nextOffset hasMore _now) =
if null recentTasks
then Lucid.p_ [Lucid.class_ "empty-msg"] "No recent tasks."
else do
@@ -1505,7 +1527,7 @@ instance Lucid.ToHtml TaskListPartial where
instance Lucid.ToHtml TaskMetricsPartial where
toHtmlRaw = Lucid.toHtml
- toHtml (TaskMetricsPartial _tid activities maybeRetry) =
+ toHtml (TaskMetricsPartial _tid activities maybeRetry now) =
Lucid.div_ [Lucid.class_ "execution-details"] <| do
case findRunningActivity activities of
Nothing -> Lucid.p_ [Lucid.class_ "empty-msg"] "No worker execution data available."
@@ -1525,7 +1547,7 @@ instance Lucid.ToHtml TaskMetricsPartial where
(Just start, Nothing) ->
Lucid.div_ [Lucid.class_ "metric-row"] <| do
Lucid.span_ [Lucid.class_ "metric-label"] "Started:"
- Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatTimestamp start))
+ Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp now start)
_ -> pure ()
case TaskCore.activityCostCents act of
@@ -1551,13 +1573,10 @@ instance Lucid.ToHtml TaskMetricsPartial where
Lucid.div_ [Lucid.class_ "metric-row"] <| do
Lucid.span_ [Lucid.class_ "metric-label"] "Last Activity:"
- Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatTimestamp (TaskCore.activityTimestamp act)))
+ Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp now (TaskCore.activityTimestamp act))
where
findRunningActivity = List.find (\a -> TaskCore.activityStage a == TaskCore.Running)
- formatTimestamp :: UTCTime -> Text
- formatTimestamp = Text.pack <. formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S"
-
formatDuration :: UTCTime -> UTCTime -> Text
formatDuration start end =
let diffSecs = floor (diffUTCTime end start) :: Int
@@ -1720,31 +1739,35 @@ server =
homeHandler :: Servant.Handler HomePage
homeHandler = do
+ now <- liftIO getCurrentTime
stats <- liftIO <| TaskCore.getTaskStats Nothing
readyTasks <- liftIO TaskCore.getReadyTasks
allTasks <- liftIO TaskCore.loadTasks
let sortedTasks = List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) allTasks
recentTasks = take 5 sortedTasks
hasMoreRecent = length allTasks > 5
- pure (HomePage stats readyTasks recentTasks hasMoreRecent)
+ pure (HomePage stats readyTasks recentTasks hasMoreRecent now)
readyQueueHandler :: Servant.Handler ReadyQueuePage
readyQueueHandler = do
+ now <- liftIO getCurrentTime
readyTasks <- liftIO TaskCore.getReadyTasks
let sortedTasks = List.sortBy (compare `on` TaskCore.taskPriority) readyTasks
- pure (ReadyQueuePage sortedTasks)
+ pure (ReadyQueuePage sortedTasks now)
blockedHandler :: Servant.Handler BlockedPage
blockedHandler = do
+ now <- liftIO getCurrentTime
blockedTasks <- liftIO TaskCore.getBlockedTasks
let sortedTasks = List.sortBy (compare `on` TaskCore.taskPriority) blockedTasks
- pure (BlockedPage sortedTasks)
+ pure (BlockedPage sortedTasks now)
interventionHandler :: Servant.Handler InterventionPage
interventionHandler = do
+ now <- liftIO getCurrentTime
interventionTasks <- liftIO TaskCore.getInterventionTasks
let sortedTasks = List.sortBy (compare `on` TaskCore.taskPriority) interventionTasks
- pure (InterventionPage sortedTasks)
+ pure (InterventionPage sortedTasks now)
statsHandler :: Maybe Text -> Servant.Handler StatsPage
statsHandler maybeEpic = do
@@ -1754,13 +1777,14 @@ server =
taskListHandler :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Servant.Handler TaskListPage
taskListHandler maybeStatusText maybePriorityText maybeNamespace maybeTypeText = do
+ now <- liftIO getCurrentTime
allTasks <- liftIO TaskCore.loadTasks
let maybeStatus = parseStatus =<< emptyToNothing maybeStatusText
maybePriority = parsePriority =<< emptyToNothing maybePriorityText
maybeType = parseTaskType =<< emptyToNothing maybeTypeText
filters = TaskFilters maybeStatus maybePriority (emptyToNothing maybeNamespace) maybeType
filteredTasks = applyFilters filters allTasks
- pure (TaskListPage filteredTasks filters)
+ pure (TaskListPage filteredTasks filters now)
kbHandler :: Servant.Handler KBPage
kbHandler = do
@@ -1776,10 +1800,11 @@ server =
factDetailHandler :: Int -> Servant.Handler FactDetailPage
factDetailHandler fid = do
+ now <- liftIO getCurrentTime
maybeFact <- liftIO (Fact.getFact fid)
case maybeFact of
Nothing -> pure (FactDetailNotFound fid)
- Just fact -> pure (FactDetailFound fact)
+ Just fact -> pure (FactDetailFound fact now)
factEditHandler :: Int -> FactEditForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
factEditHandler fid (FactEditForm content filesText confText) = do
@@ -1842,6 +1867,7 @@ server =
taskDetailHandler :: Text -> Servant.Handler TaskDetailPage
taskDetailHandler tid = do
+ now <- liftIO getCurrentTime
tasks <- liftIO TaskCore.loadTasks
case TaskCore.findTask tid tasks of
Nothing -> pure (TaskDetailNotFound tid)
@@ -1849,7 +1875,7 @@ server =
activities <- liftIO (TaskCore.getActivitiesForTask tid)
retryCtx <- liftIO (TaskCore.getRetryContext tid)
commits <- liftIO (getCommitsForTask tid)
- pure (TaskDetailFound task tasks activities retryCtx commits)
+ pure (TaskDetailFound task tasks activities retryCtx commits now)
taskStatusHandler :: Text -> StatusForm -> Servant.Handler StatusBadgePartial
taskStatusHandler tid (StatusForm newStatus) = do
@@ -1919,6 +1945,7 @@ server =
recentActivityHandler :: Maybe Int -> Servant.Handler RecentActivityPartial
recentActivityHandler maybeOffset = do
+ now <- liftIO getCurrentTime
allTasks <- liftIO TaskCore.loadTasks
let offset = fromMaybe 0 maybeOffset
pageSize = 5
@@ -1926,7 +1953,7 @@ server =
pageTasks = take pageSize <| drop offset sortedTasks
hasMore = length sortedTasks > offset + pageSize
nextOffset = offset + pageSize
- pure (RecentActivityPartial pageTasks nextOffset hasMore)
+ pure (RecentActivityPartial pageTasks nextOffset hasMore now)
readyCountHandler :: Servant.Handler ReadyCountPartial
readyCountHandler = do
@@ -1945,9 +1972,10 @@ server =
taskMetricsPartialHandler :: Text -> Servant.Handler TaskMetricsPartial
taskMetricsPartialHandler tid = do
+ now <- liftIO getCurrentTime
activities <- liftIO (TaskCore.getActivitiesForTask tid)
maybeRetry <- liftIO (TaskCore.getRetryContext tid)
- pure (TaskMetricsPartial tid activities maybeRetry)
+ pure (TaskMetricsPartial tid activities maybeRetry now)
getReviewInfo :: Text -> IO ReviewInfo
getReviewInfo tid = do