commit dbbad7cff74411b39db6d619a2a1ad6512aad634
Author: Ben Sima <ben@bensima.com>
Date: Mon Dec 1 18:44:47 2025
Refactor Web.hs into smaller modules
Split 3231-line Web.hs into focused submodules:
- Types.hs (346 lines): Data types, forms, API definition
- Components.hs (1464 lines): Reusable UI components
- Pages.hs (866 lines): Full page ToHtml instances
- Partials.hs (247 lines): HTMX partial ToHtml instances
- Handlers.hs (642 lines): Servant handler implementations
- Web.hs (39 lines): Main module with run function
Reduces main file by 99%, preventing agent token bloat.
Task-Id: t-226
Amp-Thread-ID: https://ampcode.com/threads/T-355fae3a-03e9-4bdb-a1c7-6132576bf601
Co-authored-by: Amp <amp@ampcode.com>
diff --git a/Omni/Jr/Web.hs b/Omni/Jr/Web.hs
index 2a10cb58..761428ec 100644
--- a/Omni/Jr/Web.hs
+++ b/Omni/Jr/Web.hs
@@ -1,3231 +1,39 @@
-{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoImplicitPrelude #-}
+-- | Jr Web UI - Main module that re-exports the API and provides the run function.
+--
+-- The web interface is split into submodules:
+-- - Types: Data types for pages, partials, and forms
+-- - Components: Reusable UI components and helpers
+-- - Pages: Full page ToHtml instances
+-- - Partials: HTMX partial ToHtml instances
+-- - Handlers: Servant handler implementations
+-- - Style: CSS styling
+--
-- : dep warp
-- : dep servant-server
-- : dep lucid
-- : dep servant-lucid
--- : dep http-api-data
--- : dep process
--- : dep clay
module Omni.Jr.Web
( run,
defaultPort,
+ -- Re-exports for external use
+ API,
+ server,
)
where
import Alpha
-import qualified Control.Concurrent as Concurrent
-import qualified Data.Aeson as Aeson
-import qualified Data.Aeson.KeyMap as KeyMap
-import qualified Data.ByteString.Lazy as LBS
-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 (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
import qualified Network.Wai.Handler.Warp as Warp
-import Numeric (showFFloat)
-import qualified Omni.Fact as Fact
-import qualified Omni.Jr.Web.Style as Style
-import qualified Omni.Task.Core as TaskCore
-import Servant
-import qualified Servant.HTML.Lucid as Lucid
-import qualified Servant.Types.SourceT as Source
-import qualified System.Exit as Exit
-import qualified System.Process as Process
-import Web.FormUrlEncoded (FromForm (..), lookupUnique, parseUnique)
-
-type PostRedirect = Verb 'POST 303 '[Lucid.HTML] (Headers '[Header "Location" Text] NoContent)
+import Omni.Jr.Web.Handlers (api, server)
+import Omni.Jr.Web.Types (API)
+import Servant (serve)
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))
-
-metaSep :: (Monad m) => Lucid.HtmlT m ()
-metaSep = Lucid.span_ [Lucid.class_ "meta-sep"] "·"
-
-data TaskFilters = TaskFilters
- { filterStatus :: Maybe TaskCore.Status,
- filterPriority :: Maybe TaskCore.Priority,
- filterNamespace :: Maybe Text,
- filterType :: Maybe TaskCore.TaskType
- }
- deriving (Show, Eq)
-
-data TimeRange = Today | Week | Month | AllTime
- deriving (Show, Eq)
-
-data SortOrder
- = SortNewest
- | SortOldest
- | SortUpdated
- | SortPriorityHigh
- | SortPriorityLow
- deriving (Show, Eq)
-
-parseSortOrder :: Maybe Text -> SortOrder
-parseSortOrder (Just "oldest") = SortOldest
-parseSortOrder (Just "updated") = SortUpdated
-parseSortOrder (Just "priority-high") = SortPriorityHigh
-parseSortOrder (Just "priority-low") = SortPriorityLow
-parseSortOrder _ = SortNewest
-
-sortOrderToParam :: SortOrder -> Text
-sortOrderToParam SortNewest = "newest"
-sortOrderToParam SortOldest = "oldest"
-sortOrderToParam SortUpdated = "updated"
-sortOrderToParam SortPriorityHigh = "priority-high"
-sortOrderToParam SortPriorityLow = "priority-low"
-
-sortOrderLabel :: SortOrder -> Text
-sortOrderLabel SortNewest = "Newest First"
-sortOrderLabel SortOldest = "Oldest First"
-sortOrderLabel SortUpdated = "Recently Updated"
-sortOrderLabel SortPriorityHigh = "Priority (High to Low)"
-sortOrderLabel SortPriorityLow = "Priority (Low to High)"
-
-sortTasks :: SortOrder -> [TaskCore.Task] -> [TaskCore.Task]
-sortTasks SortNewest = List.sortBy (comparing (Down <. TaskCore.taskCreatedAt))
-sortTasks SortOldest = List.sortBy (comparing TaskCore.taskCreatedAt)
-sortTasks SortUpdated = List.sortBy (comparing (Down <. TaskCore.taskUpdatedAt))
-sortTasks SortPriorityHigh = List.sortBy (comparing TaskCore.taskPriority)
-sortTasks SortPriorityLow = List.sortBy (comparing (Down <. TaskCore.taskPriority))
-
-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 =
- QueryParam "range" Text :> Get '[Lucid.HTML] HomePage
- :<|> "style.css" :> Get '[CSS] LazyText.Text
- :<|> "ready" :> QueryParam "sort" Text :> Get '[Lucid.HTML] ReadyQueuePage
- :<|> "blocked" :> QueryParam "sort" Text :> Get '[Lucid.HTML] BlockedPage
- :<|> "intervention" :> QueryParam "sort" Text :> Get '[Lucid.HTML] InterventionPage
- :<|> "stats" :> QueryParam "epic" Text :> Get '[Lucid.HTML] StatsPage
- :<|> "tasks"
- :> QueryParam "status" Text
- :> QueryParam "priority" Text
- :> QueryParam "namespace" Text
- :> QueryParam "type" Text
- :> QueryParam "sort" Text
- :> Get '[Lucid.HTML] TaskListPage
- :<|> "kb" :> Get '[Lucid.HTML] KBPage
- :<|> "kb" :> "create" :> ReqBody '[FormUrlEncoded] FactCreateForm :> PostRedirect
- :<|> "kb" :> Capture "id" Int :> Get '[Lucid.HTML] FactDetailPage
- :<|> "kb" :> Capture "id" Int :> "edit" :> ReqBody '[FormUrlEncoded] FactEditForm :> PostRedirect
- :<|> "kb" :> Capture "id" Int :> "delete" :> PostRedirect
- :<|> "epics" :> QueryParam "sort" Text :> Get '[Lucid.HTML] EpicsPage
- :<|> "tasks" :> Capture "id" Text :> Get '[Lucid.HTML] TaskDetailPage
- :<|> "tasks" :> Capture "id" Text :> "status" :> ReqBody '[FormUrlEncoded] StatusForm :> Post '[Lucid.HTML] StatusBadgePartial
- :<|> "tasks" :> Capture "id" Text :> "priority" :> ReqBody '[FormUrlEncoded] PriorityForm :> Post '[Lucid.HTML] PriorityBadgePartial
- :<|> "tasks" :> Capture "id" Text :> "description" :> "view" :> Get '[Lucid.HTML] DescriptionViewPartial
- :<|> "tasks" :> Capture "id" Text :> "description" :> "edit" :> Get '[Lucid.HTML] DescriptionEditPartial
- :<|> "tasks" :> Capture "id" Text :> "description" :> ReqBody '[FormUrlEncoded] DescriptionForm :> Post '[Lucid.HTML] DescriptionViewPartial
- :<|> "tasks" :> Capture "id" Text :> "notes" :> ReqBody '[FormUrlEncoded] NotesForm :> PostRedirect
- :<|> "tasks" :> Capture "id" Text :> "comment" :> ReqBody '[FormUrlEncoded] CommentForm :> PostRedirect
- :<|> "tasks" :> Capture "id" Text :> "review" :> Get '[Lucid.HTML] TaskReviewPage
- :<|> "tasks" :> Capture "id" Text :> "diff" :> Capture "commit" Text :> Get '[Lucid.HTML] TaskDiffPage
- :<|> "tasks" :> Capture "id" Text :> "accept" :> PostRedirect
- :<|> "tasks" :> Capture "id" Text :> "reject" :> ReqBody '[FormUrlEncoded] RejectForm :> PostRedirect
- :<|> "tasks" :> Capture "id" Text :> "reset-retries" :> PostRedirect
- :<|> "partials" :> "recent-activity-new" :> QueryParam "since" Int :> Get '[Lucid.HTML] RecentActivityNewPartial
- :<|> "partials" :> "recent-activity-more" :> QueryParam "offset" Int :> Get '[Lucid.HTML] RecentActivityMorePartial
- :<|> "partials" :> "ready-count" :> Get '[Lucid.HTML] ReadyCountPartial
- :<|> "partials"
- :> "task-list"
- :> QueryParam "status" Text
- :> QueryParam "priority" Text
- :> QueryParam "namespace" Text
- :> QueryParam "type" Text
- :> QueryParam "sort" Text
- :> Get '[Lucid.HTML] TaskListPartial
- :<|> "partials" :> "task" :> Capture "id" Text :> "metrics" :> Get '[Lucid.HTML] TaskMetricsPartial
- :<|> "partials" :> "task" :> Capture "id" Text :> "events" :> QueryParam "since" Int :> Get '[Lucid.HTML] AgentEventsPartial
- :<|> "tasks" :> Capture "id" Text :> "events" :> "stream" :> StreamGet NoFraming SSE (SourceIO ByteString)
-
-data CSS
-
-instance Accept CSS where
- contentType _ = "text/css"
-
-instance MimeRender CSS LazyText.Text where
- mimeRender _ = LazyText.encodeUtf8
-
-data SSE
-
-instance Accept SSE where
- contentType _ = "text/event-stream"
-
-instance MimeRender SSE ByteString where
- mimeRender _ = LBS.fromStrict
-
-data HomePage = HomePage TaskCore.TaskStats [TaskCore.Task] [TaskCore.Task] Bool TaskCore.AggregatedMetrics TimeRange UTCTime
-
-data ReadyQueuePage = ReadyQueuePage [TaskCore.Task] SortOrder UTCTime
-
-data BlockedPage = BlockedPage [(TaskCore.Task, Int)] SortOrder UTCTime
-
-data InterventionPage = InterventionPage TaskCore.HumanActionItems SortOrder UTCTime
-
-data TaskListPage = TaskListPage [TaskCore.Task] TaskFilters SortOrder UTCTime
-
-data TaskDetailPage
- = TaskDetailFound TaskCore.Task [TaskCore.Task] [TaskCore.TaskActivity] (Maybe TaskCore.RetryContext) [GitCommit] (Maybe TaskCore.AggregatedMetrics) [TaskCore.StoredEvent] UTCTime
- | TaskDetailNotFound Text
-
-data GitCommit = GitCommit
- { commitHash :: Text,
- commitShortHash :: Text,
- commitSummary :: Text,
- commitAuthor :: Text,
- commitRelativeDate :: Text,
- commitFilesChanged :: Int
- }
- deriving (Show, Eq)
-
-data TaskReviewPage
- = ReviewPageFound TaskCore.Task ReviewInfo
- | ReviewPageNotFound Text
-
-data ReviewInfo
- = ReviewNoCommit
- | ReviewMergeConflict Text [Text]
- | ReviewReady Text Text
-
-data TaskDiffPage
- = DiffPageFound Text Text Text
- | DiffPageNotFound Text Text
-
-data StatsPage = StatsPage TaskCore.TaskStats (Maybe Text)
-
-newtype KBPage = KBPage [TaskCore.Fact]
-
-data FactDetailPage
- = FactDetailFound TaskCore.Fact UTCTime
- | FactDetailNotFound Int
-
-data FactEditForm = FactEditForm Text Text Text
-
-instance FromForm FactEditForm where
- fromForm form = do
- content <- parseUnique "content" form
- let files = fromRight "" (lookupUnique "files" form)
- let confidence = fromRight "0.8" (lookupUnique "confidence" form)
- Right (FactEditForm content files confidence)
-
-data FactCreateForm = FactCreateForm Text Text Text Text
-
-instance FromForm FactCreateForm where
- fromForm form = do
- project <- parseUnique "project" form
- content <- parseUnique "content" form
- let files = fromRight "" (lookupUnique "files" form)
- let confidence = fromRight "0.8" (lookupUnique "confidence" form)
- Right (FactCreateForm project content files confidence)
-
-data EpicsPage = EpicsPage [TaskCore.Task] [TaskCore.Task] SortOrder
-
-data RecentActivityNewPartial = RecentActivityNewPartial [TaskCore.Task] (Maybe Int)
-
-data RecentActivityMorePartial = RecentActivityMorePartial [TaskCore.Task] Int Bool
-
-newtype ReadyCountPartial = ReadyCountPartial Int
-
-data StatusBadgePartial = StatusBadgePartial TaskCore.Status Text
-
-data PriorityBadgePartial = PriorityBadgePartial TaskCore.Priority Text
-
-newtype TaskListPartial = TaskListPartial [TaskCore.Task]
-
-data TaskMetricsPartial = TaskMetricsPartial Text [TaskCore.TaskActivity] (Maybe TaskCore.RetryContext) UTCTime
-
-data AgentEventsPartial = AgentEventsPartial [TaskCore.StoredEvent] Bool UTCTime
-
-data DescriptionViewPartial = DescriptionViewPartial Text Text Bool
-
-data DescriptionEditPartial = DescriptionEditPartial Text Text Bool
-
-newtype RejectForm = RejectForm (Maybe Text)
-
-instance FromForm RejectForm where
- fromForm form = Right (RejectForm (either (const Nothing) Just (lookupUnique "notes" form)))
-
-newtype StatusForm = StatusForm TaskCore.Status
-
-instance FromForm StatusForm where
- fromForm form = do
- statusText <- parseUnique "status" form
- case readMaybe (Text.unpack statusText) of
- Just s -> Right (StatusForm s)
- Nothing -> Left "Invalid status"
-
-newtype PriorityForm = PriorityForm TaskCore.Priority
-
-instance FromForm PriorityForm where
- fromForm form = do
- priorityText <- parseUnique "priority" form
- case readMaybe (Text.unpack priorityText) of
- Just p -> Right (PriorityForm p)
- Nothing -> Left "Invalid priority"
-
-newtype DescriptionForm = DescriptionForm Text
-
-instance FromForm DescriptionForm where
- fromForm form = do
- desc <- parseUnique "description" form
- Right (DescriptionForm desc)
-
-newtype NotesForm = NotesForm Text
-
-instance FromForm NotesForm where
- fromForm form = do
- notes <- parseUnique "notes" form
- Right (NotesForm notes)
-
-newtype CommentForm = CommentForm Text
-
-instance FromForm CommentForm where
- fromForm form = do
- commentText <- parseUnique "comment" form
- Right (CommentForm commentText)
-
-pageHead :: (Monad m) => Text -> Lucid.HtmlT m ()
-pageHead title =
- Lucid.head_ <| do
- Lucid.title_ (Lucid.toHtml title)
- Lucid.meta_ [Lucid.charset_ "utf-8"]
- Lucid.meta_
- [ Lucid.name_ "viewport",
- Lucid.content_ "width=device-width, initial-scale=1"
- ]
- Lucid.link_ [Lucid.rel_ "stylesheet", Lucid.href_ "/style.css"]
- Lucid.script_
- [ Lucid.src_ "https://unpkg.com/htmx.org@2.0.4",
- Lucid.integrity_ "sha384-HGfztofotfshcF7+8n44JQL2oJmowVChPTg48S+jvZoztPfvwD79OC/LTtG6dMp+",
- Lucid.crossorigin_ "anonymous"
- ]
- ("" :: Text)
- Lucid.script_ [] statusDropdownJs
- Lucid.script_ [] priorityDropdownJs
- Lucid.script_ [] navbarDropdownJs
- Lucid.script_ [] liveToggleJs
-
-navbarDropdownJs :: Text
-navbarDropdownJs =
- Text.unlines
- [ "document.addEventListener('DOMContentLoaded', function() {",
- " document.querySelectorAll('.navbar-dropdown-btn').forEach(function(btn) {",
- " btn.addEventListener('click', function(e) {",
- " e.preventDefault();",
- " var dropdown = btn.closest('.navbar-dropdown');",
- " var isOpen = dropdown.classList.contains('open');",
- " document.querySelectorAll('.navbar-dropdown.open').forEach(function(d) {",
- " d.classList.remove('open');",
- " });",
- " if (!isOpen) {",
- " dropdown.classList.add('open');",
- " }",
- " });",
- " });",
- " document.addEventListener('click', function(e) {",
- " if (!e.target.closest('.navbar-dropdown')) {",
- " document.querySelectorAll('.navbar-dropdown.open').forEach(function(d) {",
- " d.classList.remove('open');",
- " });",
- " }",
- " });",
- "});"
- ]
-
-statusDropdownJs :: Text
-statusDropdownJs =
- Text.unlines
- [ "function toggleStatusDropdown(el) {",
- " var container = el.parentElement;",
- " var isOpen = container.classList.toggle('open');",
- " el.setAttribute('aria-expanded', isOpen);",
- " if (isOpen) {",
- " var firstItem = container.querySelector('[role=\"menuitem\"]');",
- " if (firstItem) firstItem.focus();",
- " }",
- "}",
- "",
- "function closeStatusDropdown(container) {",
- " container.classList.remove('open');",
- " var badge = container.querySelector('[role=\"button\"]');",
- " if (badge) {",
- " badge.setAttribute('aria-expanded', 'false');",
- " badge.focus();",
- " }",
- "}",
- "",
- "function handleStatusKeydown(event, el) {",
- " if (event.key === 'Enter' || event.key === ' ') {",
- " event.preventDefault();",
- " toggleStatusDropdown(el);",
- " } else if (event.key === 'Escape') {",
- " closeStatusDropdown(el.parentElement);",
- " } else if (event.key === 'ArrowDown') {",
- " event.preventDefault();",
- " var container = el.parentElement;",
- " if (!container.classList.contains('open')) {",
- " toggleStatusDropdown(el);",
- " } else {",
- " var firstItem = container.querySelector('[role=\"menuitem\"]');",
- " if (firstItem) firstItem.focus();",
- " }",
- " }",
- "}",
- "",
- "function handleMenuItemKeydown(event) {",
- " var container = event.target.closest('.status-badge-dropdown');",
- " var items = container.querySelectorAll('[role=\"menuitem\"]');",
- " var currentIndex = Array.from(items).indexOf(event.target);",
- " ",
- " if (event.key === 'ArrowDown') {",
- " event.preventDefault();",
- " var next = (currentIndex + 1) % items.length;",
- " items[next].focus();",
- " } else if (event.key === 'ArrowUp') {",
- " event.preventDefault();",
- " var prev = (currentIndex - 1 + items.length) % items.length;",
- " items[prev].focus();",
- " } else if (event.key === 'Escape') {",
- " event.preventDefault();",
- " closeStatusDropdown(container);",
- " } else if (event.key === 'Tab') {",
- " closeStatusDropdown(container);",
- " }",
- "}",
- "",
- "document.addEventListener('click', function(e) {",
- " var dropdowns = document.querySelectorAll('.status-badge-dropdown.open');",
- " dropdowns.forEach(function(d) {",
- " if (!d.contains(e.target)) {",
- " closeStatusDropdown(d);",
- " }",
- " });",
- "});"
- ]
-
-priorityDropdownJs :: Text
-priorityDropdownJs =
- Text.unlines
- [ "function togglePriorityDropdown(el) {",
- " var container = el.parentElement;",
- " var isOpen = container.classList.toggle('open');",
- " el.setAttribute('aria-expanded', isOpen);",
- " if (isOpen) {",
- " var firstItem = container.querySelector('[role=\"menuitem\"]');",
- " if (firstItem) firstItem.focus();",
- " }",
- "}",
- "",
- "function closePriorityDropdown(container) {",
- " container.classList.remove('open');",
- " var badge = container.querySelector('[role=\"button\"]');",
- " if (badge) {",
- " badge.setAttribute('aria-expanded', 'false');",
- " badge.focus();",
- " }",
- "}",
- "",
- "function handlePriorityKeydown(event, el) {",
- " if (event.key === 'Enter' || event.key === ' ') {",
- " event.preventDefault();",
- " togglePriorityDropdown(el);",
- " } else if (event.key === 'Escape') {",
- " closePriorityDropdown(el.parentElement);",
- " } else if (event.key === 'ArrowDown') {",
- " event.preventDefault();",
- " var container = el.parentElement;",
- " if (!container.classList.contains('open')) {",
- " togglePriorityDropdown(el);",
- " } else {",
- " var firstItem = container.querySelector('[role=\"menuitem\"]');",
- " if (firstItem) firstItem.focus();",
- " }",
- " }",
- "}",
- "",
- "function handlePriorityMenuItemKeydown(event) {",
- " var container = event.target.closest('.priority-badge-dropdown');",
- " var items = container.querySelectorAll('[role=\"menuitem\"]');",
- " var currentIndex = Array.from(items).indexOf(event.target);",
- " ",
- " if (event.key === 'ArrowDown') {",
- " event.preventDefault();",
- " var next = (currentIndex + 1) % items.length;",
- " items[next].focus();",
- " } else if (event.key === 'ArrowUp') {",
- " event.preventDefault();",
- " var prev = (currentIndex - 1 + items.length) % items.length;",
- " items[prev].focus();",
- " } else if (event.key === 'Escape') {",
- " event.preventDefault();",
- " closePriorityDropdown(container);",
- " } else if (event.key === 'Tab') {",
- " closePriorityDropdown(container);",
- " }",
- "}",
- "",
- "document.addEventListener('click', function(e) {",
- " var dropdowns = document.querySelectorAll('.priority-badge-dropdown.open');",
- " dropdowns.forEach(function(d) {",
- " if (!d.contains(e.target)) {",
- " closePriorityDropdown(d);",
- " }",
- " });",
- "});"
- ]
-
-pageBody :: (Monad m) => Lucid.HtmlT m () -> Lucid.HtmlT m ()
-pageBody content =
- Lucid.body_ [Lucid.makeAttribute "hx-boost" "true"] <| do
- navbar
- content
-
-data Breadcrumb = Breadcrumb
- { _crumbLabel :: Text,
- _crumbHref :: Maybe Text
- }
-
-type Breadcrumbs = [Breadcrumb]
-
-pageBodyWithCrumbs :: (Monad m) => Breadcrumbs -> Lucid.HtmlT m () -> Lucid.HtmlT m ()
-pageBodyWithCrumbs crumbs content =
- Lucid.body_ [Lucid.makeAttribute "hx-boost" "true"] <| do
- navbar
- unless (null crumbs) <| do
- Lucid.div_ [Lucid.class_ "breadcrumb-container"] <| do
- Lucid.div_ [Lucid.class_ "container"] <| renderBreadcrumbs crumbs
- content
-
-renderBreadcrumbs :: (Monad m) => Breadcrumbs -> Lucid.HtmlT m ()
-renderBreadcrumbs [] = pure ()
-renderBreadcrumbs crumbs =
- Lucid.nav_ [Lucid.class_ "breadcrumbs", Lucid.makeAttribute "aria-label" "Breadcrumb"] <| do
- Lucid.ol_ [Lucid.class_ "breadcrumb-list"] <| do
- traverse_ renderCrumb (zip [0 ..] crumbs)
- where
- renderCrumb :: (Monad m') => (Int, Breadcrumb) -> Lucid.HtmlT m' ()
- renderCrumb (idx, Breadcrumb label mHref) = do
- Lucid.li_ [Lucid.class_ "breadcrumb-item"] <| do
- when (idx > 0) <| Lucid.span_ [Lucid.class_ "breadcrumb-sep"] ">"
- case mHref of
- Just href -> Lucid.a_ [Lucid.href_ href] (Lucid.toHtml label)
- Nothing -> Lucid.span_ [Lucid.class_ "breadcrumb-current"] (Lucid.toHtml label)
-
-getAncestors :: [TaskCore.Task] -> TaskCore.Task -> [TaskCore.Task]
-getAncestors allTasks task =
- case TaskCore.taskParent task of
- Nothing -> [task]
- Just pid -> case TaskCore.findTask pid allTasks of
- Nothing -> [task]
- Just parent -> getAncestors allTasks parent ++ [task]
-
-taskBreadcrumbs :: [TaskCore.Task] -> TaskCore.Task -> Breadcrumbs
-taskBreadcrumbs allTasks task =
- let ancestors = getAncestors allTasks task
- taskCrumbs = [Breadcrumb (TaskCore.taskId t) (Just ("/tasks/" <> TaskCore.taskId t)) | t <- List.init ancestors]
- currentCrumb = Breadcrumb (TaskCore.taskId task) Nothing
- in [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks")]
- ++ taskCrumbs
- ++ [currentCrumb]
-
-navbar :: (Monad m) => Lucid.HtmlT m ()
-navbar =
- Lucid.nav_ [Lucid.class_ "navbar"] <| do
- Lucid.a_ [Lucid.href_ "/", Lucid.class_ "navbar-brand"] "Junior"
- Lucid.input_
- [ Lucid.type_ "checkbox",
- Lucid.id_ "navbar-toggle",
- Lucid.class_ "navbar-toggle-checkbox"
- ]
- Lucid.label_
- [ Lucid.for_ "navbar-toggle",
- Lucid.class_ "navbar-hamburger"
- ]
- <| do
- Lucid.span_ [Lucid.class_ "hamburger-line"] ""
- Lucid.span_ [Lucid.class_ "hamburger-line"] ""
- Lucid.span_ [Lucid.class_ "hamburger-line"] ""
- Lucid.div_ [Lucid.class_ "navbar-links"] <| do
- Lucid.a_ [Lucid.href_ "/", Lucid.class_ "navbar-link"] "Dashboard"
- Lucid.div_ [Lucid.class_ "navbar-dropdown"] <| do
- Lucid.button_ [Lucid.class_ "navbar-dropdown-btn"] "Tasks ▾"
- Lucid.div_ [Lucid.class_ "navbar-dropdown-content"] <| do
- Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "navbar-dropdown-item"] "Ready"
- Lucid.a_ [Lucid.href_ "/blocked", Lucid.class_ "navbar-dropdown-item"] "Blocked"
- Lucid.a_ [Lucid.href_ "/intervention", Lucid.class_ "navbar-dropdown-item"] "Human Action"
- Lucid.a_ [Lucid.href_ "/tasks", Lucid.class_ "navbar-dropdown-item"] "All"
- Lucid.div_ [Lucid.class_ "navbar-dropdown"] <| do
- Lucid.button_ [Lucid.class_ "navbar-dropdown-btn"] "Plans ▾"
- Lucid.div_ [Lucid.class_ "navbar-dropdown-content"] <| do
- Lucid.a_ [Lucid.href_ "/epics", Lucid.class_ "navbar-dropdown-item"] "Epics"
- Lucid.a_ [Lucid.href_ "/kb", Lucid.class_ "navbar-dropdown-item"] "KB"
- Lucid.a_ [Lucid.href_ "/stats", Lucid.class_ "navbar-link"] "Stats"
-
-statusBadge :: (Monad m) => TaskCore.Status -> Lucid.HtmlT m ()
-statusBadge status =
- let (cls, label) = case status of
- TaskCore.Draft -> ("badge badge-draft", "Draft")
- TaskCore.Open -> ("badge badge-open", "Open")
- TaskCore.InProgress -> ("badge badge-inprogress", "In Progress")
- TaskCore.Review -> ("badge badge-review", "Review")
- TaskCore.Approved -> ("badge badge-approved", "Approved")
- TaskCore.Done -> ("badge badge-done", "Done")
- TaskCore.NeedsHelp -> ("badge badge-needshelp", "Needs Help")
- in Lucid.span_ [Lucid.class_ cls] label
-
-complexityBadge :: (Monad m) => Int -> Lucid.HtmlT m ()
-complexityBadge complexity =
- let cls = "badge badge-complexity badge-complexity-" <> tshow complexity
- label = "ℂ " <> tshow complexity
- in Lucid.span_ [Lucid.class_ cls, Lucid.title_ "Task Complexity (1-5)"] (Lucid.toHtml label)
-
-sortDropdown :: (Monad m) => Text -> SortOrder -> Lucid.HtmlT m ()
-sortDropdown basePath currentSort =
- Lucid.div_ [Lucid.class_ "sort-dropdown"] <| do
- Lucid.span_ [Lucid.class_ "sort-label"] "Sort:"
- Lucid.div_ [Lucid.class_ "sort-dropdown-wrapper navbar-dropdown"] <| do
- Lucid.button_ [Lucid.class_ "sort-dropdown-btn navbar-dropdown-btn"]
- <| Lucid.toHtml (sortOrderLabel currentSort <> " ▾")
- Lucid.div_ [Lucid.class_ "sort-dropdown-content navbar-dropdown-content"] <| do
- sortOption basePath SortNewest currentSort
- sortOption basePath SortOldest currentSort
- sortOption basePath SortUpdated currentSort
- sortOption basePath SortPriorityHigh currentSort
- sortOption basePath SortPriorityLow currentSort
-
-sortOption :: (Monad m) => Text -> SortOrder -> SortOrder -> Lucid.HtmlT m ()
-sortOption basePath option currentSort =
- let cls = "sort-dropdown-item navbar-dropdown-item" <> if option == currentSort then " active" else ""
- href = basePath <> "?sort=" <> sortOrderToParam option
- in Lucid.a_ [Lucid.href_ href, Lucid.class_ cls] (Lucid.toHtml (sortOrderLabel option))
-
-multiColorProgressBar :: (Monad m) => TaskCore.TaskStats -> Lucid.HtmlT m ()
-multiColorProgressBar stats =
- let total = TaskCore.totalTasks stats
- doneCount = TaskCore.doneTasks stats
- inProgressCount = TaskCore.inProgressTasks stats
- openCount = TaskCore.openTasks stats + TaskCore.reviewTasks stats + TaskCore.approvedTasks stats
- donePct = if total == 0 then 0 else (doneCount * 100) `div` total
- inProgressPct = if total == 0 then 0 else (inProgressCount * 100) `div` total
- openPct = if total == 0 then 0 else (openCount * 100) `div` total
- in Lucid.div_ [Lucid.class_ "multi-progress-container"] <| do
- Lucid.div_ [Lucid.class_ "multi-progress-bar"] <| do
- when (donePct > 0)
- <| Lucid.div_
- [ Lucid.class_ "multi-progress-segment progress-done",
- Lucid.style_ ("width: " <> tshow donePct <> "%"),
- Lucid.title_ (tshow doneCount <> " done")
- ]
- ""
- when (inProgressPct > 0)
- <| Lucid.div_
- [ Lucid.class_ "multi-progress-segment progress-inprogress",
- Lucid.style_ ("width: " <> tshow inProgressPct <> "%"),
- Lucid.title_ (tshow inProgressCount <> " in progress")
- ]
- ""
- when (openPct > 0)
- <| Lucid.div_
- [ Lucid.class_ "multi-progress-segment progress-open",
- Lucid.style_ ("width: " <> tshow openPct <> "%"),
- Lucid.title_ (tshow openCount <> " open")
- ]
- ""
- Lucid.div_ [Lucid.class_ "progress-legend"] <| do
- Lucid.span_ [Lucid.class_ "legend-item"] <| do
- Lucid.span_ [Lucid.class_ "legend-dot legend-done"] ""
- Lucid.toHtml ("Done " <> tshow doneCount)
- Lucid.span_ [Lucid.class_ "legend-item"] <| do
- Lucid.span_ [Lucid.class_ "legend-dot legend-inprogress"] ""
- Lucid.toHtml ("In Progress " <> tshow inProgressCount)
- Lucid.span_ [Lucid.class_ "legend-item"] <| do
- Lucid.span_ [Lucid.class_ "legend-dot legend-open"] ""
- Lucid.toHtml ("Open " <> tshow openCount)
-
-statusBadgeWithForm :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m ()
-statusBadgeWithForm status tid =
- Lucid.div_
- [ Lucid.id_ "status-badge-container",
- Lucid.class_ "status-badge-dropdown"
- ]
- <| do
- clickableBadge status tid
- statusDropdownOptions status tid
-
-clickableBadge :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m ()
-clickableBadge status _tid =
- let (cls, label) = case status of
- TaskCore.Draft -> ("badge badge-draft status-badge-clickable", "Draft" :: Text)
- TaskCore.Open -> ("badge badge-open status-badge-clickable", "Open")
- TaskCore.InProgress -> ("badge badge-inprogress status-badge-clickable", "In Progress")
- TaskCore.Review -> ("badge badge-review status-badge-clickable", "Review")
- TaskCore.Approved -> ("badge badge-approved status-badge-clickable", "Approved")
- TaskCore.Done -> ("badge badge-done status-badge-clickable", "Done")
- TaskCore.NeedsHelp -> ("badge badge-needshelp status-badge-clickable", "Needs Help")
- in Lucid.span_
- [ Lucid.class_ cls,
- Lucid.tabindex_ "0",
- Lucid.role_ "button",
- Lucid.makeAttribute "aria-haspopup" "true",
- Lucid.makeAttribute "aria-expanded" "false",
- Lucid.makeAttribute "onclick" "toggleStatusDropdown(this)",
- Lucid.makeAttribute "onkeydown" "handleStatusKeydown(event, this)"
- ]
- <| do
- Lucid.toHtml label
- Lucid.span_ [Lucid.class_ "dropdown-arrow", Lucid.makeAttribute "aria-hidden" "true"] " ▾"
-
-statusDropdownOptions :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m ()
-statusDropdownOptions currentStatus tid =
- Lucid.div_
- [ Lucid.class_ "status-dropdown-menu",
- Lucid.role_ "menu",
- Lucid.makeAttribute "aria-label" "Change task status"
- ]
- <| do
- statusOption TaskCore.Draft currentStatus tid
- statusOption TaskCore.Open currentStatus tid
- statusOption TaskCore.InProgress currentStatus tid
- statusOption TaskCore.Review currentStatus tid
- statusOption TaskCore.Approved currentStatus tid
- statusOption TaskCore.Done currentStatus tid
- statusOption TaskCore.NeedsHelp currentStatus tid
-
-statusOption :: (Monad m) => TaskCore.Status -> TaskCore.Status -> Text -> Lucid.HtmlT m ()
-statusOption opt currentStatus tid =
- let (cls, label) = case opt of
- TaskCore.Draft -> ("badge badge-draft", "Draft" :: Text)
- TaskCore.Open -> ("badge badge-open", "Open")
- TaskCore.InProgress -> ("badge badge-inprogress", "In Progress")
- TaskCore.Review -> ("badge badge-review", "Review")
- TaskCore.Approved -> ("badge badge-approved", "Approved")
- TaskCore.Done -> ("badge badge-done", "Done")
- TaskCore.NeedsHelp -> ("badge badge-needshelp", "Needs Help")
- isSelected = opt == currentStatus
- optClass = cls <> " status-dropdown-option" <> if isSelected then " selected" else ""
- in Lucid.form_
- [ Lucid.class_ "status-option-form",
- Lucid.role_ "none",
- Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/status"),
- Lucid.makeAttribute "hx-target" "#status-badge-container",
- Lucid.makeAttribute "hx-swap" "outerHTML"
- ]
- <| do
- Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "status", Lucid.value_ (tshow opt)]
- Lucid.button_
- [ Lucid.type_ "submit",
- Lucid.class_ optClass,
- Lucid.role_ "menuitem",
- Lucid.tabindex_ "-1",
- Lucid.makeAttribute "onkeydown" "handleMenuItemKeydown(event)"
- ]
- (Lucid.toHtml label)
-
-priorityBadgeWithForm :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m ()
-priorityBadgeWithForm priority tid =
- Lucid.div_
- [ Lucid.id_ "priority-badge-container",
- Lucid.class_ "priority-badge-dropdown"
- ]
- <| do
- clickablePriorityBadge priority tid
- priorityDropdownOptions priority tid
-
-clickablePriorityBadge :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m ()
-clickablePriorityBadge priority _tid =
- let (cls, label) = case priority of
- TaskCore.P0 -> ("badge badge-p0 priority-badge-clickable", "P0 Critical" :: Text)
- TaskCore.P1 -> ("badge badge-p1 priority-badge-clickable", "P1 High")
- TaskCore.P2 -> ("badge badge-p2 priority-badge-clickable", "P2 Normal")
- TaskCore.P3 -> ("badge badge-p3 priority-badge-clickable", "P3 Low")
- TaskCore.P4 -> ("badge badge-p4 priority-badge-clickable", "P4 Defer")
- in Lucid.span_
- [ Lucid.class_ cls,
- Lucid.tabindex_ "0",
- Lucid.role_ "button",
- Lucid.makeAttribute "aria-haspopup" "true",
- Lucid.makeAttribute "aria-expanded" "false",
- Lucid.makeAttribute "onclick" "togglePriorityDropdown(this)",
- Lucid.makeAttribute "onkeydown" "handlePriorityKeydown(event, this)"
- ]
- <| do
- Lucid.toHtml label
- Lucid.span_ [Lucid.class_ "dropdown-arrow", Lucid.makeAttribute "aria-hidden" "true"] " ▾"
-
-priorityDropdownOptions :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m ()
-priorityDropdownOptions currentPriority tid =
- Lucid.div_
- [ Lucid.class_ "priority-dropdown-menu",
- Lucid.role_ "menu",
- Lucid.makeAttribute "aria-label" "Change task priority"
- ]
- <| do
- priorityOption TaskCore.P0 currentPriority tid
- priorityOption TaskCore.P1 currentPriority tid
- priorityOption TaskCore.P2 currentPriority tid
- priorityOption TaskCore.P3 currentPriority tid
- priorityOption TaskCore.P4 currentPriority tid
-
-priorityOption :: (Monad m) => TaskCore.Priority -> TaskCore.Priority -> Text -> Lucid.HtmlT m ()
-priorityOption opt currentPriority tid =
- let (cls, label) = case opt of
- TaskCore.P0 -> ("badge badge-p0", "P0 Critical" :: Text)
- TaskCore.P1 -> ("badge badge-p1", "P1 High")
- TaskCore.P2 -> ("badge badge-p2", "P2 Normal")
- TaskCore.P3 -> ("badge badge-p3", "P3 Low")
- TaskCore.P4 -> ("badge badge-p4", "P4 Defer")
- isSelected = opt == currentPriority
- optClass = cls <> " priority-dropdown-option" <> if isSelected then " selected" else ""
- in Lucid.form_
- [ Lucid.class_ "priority-option-form",
- Lucid.role_ "none",
- Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/priority"),
- Lucid.makeAttribute "hx-target" "#priority-badge-container",
- Lucid.makeAttribute "hx-swap" "outerHTML"
- ]
- <| do
- Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "priority", Lucid.value_ (tshow opt)]
- Lucid.button_
- [ Lucid.type_ "submit",
- Lucid.class_ optClass,
- Lucid.role_ "menuitem",
- Lucid.tabindex_ "-1",
- Lucid.makeAttribute "onkeydown" "handlePriorityMenuItemKeydown(event)"
- ]
- (Lucid.toHtml label)
-
-renderTaskCard :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m ()
-renderTaskCard t =
- Lucid.a_
- [ Lucid.class_ "task-card task-card-link",
- Lucid.href_ ("/tasks/" <> TaskCore.taskId t)
- ]
- <| do
- Lucid.div_ [Lucid.class_ "task-header"] <| do
- Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (TaskCore.taskId t))
- statusBadge (TaskCore.taskStatus t)
- Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t)))
- Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t))
-
-renderBlockedTaskCard :: (Monad m) => (TaskCore.Task, Int) -> Lucid.HtmlT m ()
-renderBlockedTaskCard (t, impact) =
- Lucid.a_
- [ Lucid.class_ "task-card task-card-link",
- Lucid.href_ ("/tasks/" <> TaskCore.taskId t)
- ]
- <| do
- Lucid.div_ [Lucid.class_ "task-header"] <| do
- Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (TaskCore.taskId t))
- statusBadge (TaskCore.taskStatus t)
- Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t)))
- when (impact > 0)
- <| Lucid.span_ [Lucid.class_ "blocking-impact"] (Lucid.toHtml ("Blocks " <> tshow impact))
- Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t))
-
-renderListGroupItem :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m ()
-renderListGroupItem t =
- Lucid.a_
- [ Lucid.class_ "list-group-item",
- Lucid.href_ ("/tasks/" <> TaskCore.taskId t),
- Lucid.makeAttribute "hx-boost" "true",
- Lucid.makeAttribute "hx-target" "body",
- Lucid.makeAttribute "hx-swap" "innerHTML"
- ]
- <| do
- Lucid.div_ [Lucid.class_ "list-group-item-content"] <| do
- Lucid.span_ [Lucid.class_ "list-group-item-id"] (Lucid.toHtml (TaskCore.taskId t))
- Lucid.span_ [Lucid.class_ "list-group-item-title"] (Lucid.toHtml (TaskCore.taskTitle t))
- Lucid.div_ [Lucid.class_ "list-group-item-meta"] <| do
- statusBadge (TaskCore.taskStatus t)
- Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t)))
-
-instance Lucid.ToHtml HomePage where
- toHtmlRaw = Lucid.toHtml
- 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"
- statCard "Review" (TaskCore.reviewTasks stats) "badge-review" "/tasks?status=Review"
- statCard "Approved" (TaskCore.approvedTasks stats) "badge-approved" "/tasks?status=Approved"
- statCard "Done" (TaskCore.doneTasks stats) "badge-done" "/tasks?status=Done"
- metricCard "Cost" (formatCost (TaskCore.aggTotalCostCents globalMetrics))
- metricCard "Duration" (formatDuration (TaskCore.aggTotalDurationSeconds globalMetrics))
-
- Lucid.h2_ <| do
- "Ready Queue "
- Lucid.span_
- [ Lucid.class_ "ready-count",
- Lucid.makeAttribute "hx-get" "/partials/ready-count",
- Lucid.makeAttribute "hx-trigger" "every 5s"
- ]
- <| do
- Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "ready-link"]
- <| Lucid.toHtml ("(" <> tshow (length readyTasks) <> " tasks)")
- if null readyTasks
- then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks ready for work."
- else
- Lucid.div_ [Lucid.class_ "list-group"]
- <| traverse_ renderListGroupItem (take 5 readyTasks)
-
- Lucid.h2_ "Recent Activity"
- let newestTimestamp = maybe 0 taskToUnixTs (head recentTasks)
- Lucid.div_
- [ Lucid.class_ "recent-activity",
- Lucid.id_ "recent-activity",
- Lucid.makeAttribute "data-newest-ts" (tshow newestTimestamp),
- Lucid.makeAttribute "hx-get" "/partials/recent-activity-new",
- Lucid.makeAttribute "hx-trigger" "every 10s",
- Lucid.makeAttribute "hx-vals" "js:{since: document.getElementById('recent-activity')?.dataset?.newestTs || 0}",
- Lucid.makeAttribute "hx-target" "#activity-list",
- Lucid.makeAttribute "hx-swap" "afterbegin"
- ]
- <| do
- Lucid.div_ [Lucid.id_ "activity-list", Lucid.class_ "list-group"]
- <| traverse_ renderListGroupItem recentTasks
- when hasMoreRecent
- <| Lucid.button_
- [ Lucid.id_ "activity-load-more",
- Lucid.class_ "btn btn-secondary load-more-btn",
- Lucid.makeAttribute "hx-get" "/partials/recent-activity-more?offset=5",
- Lucid.makeAttribute "hx-target" "#activity-list",
- Lucid.makeAttribute "hx-swap" "beforeend"
- ]
- "Load More"
- where
- statCard :: (Monad m) => Text -> Int -> Text -> Text -> Lucid.HtmlT m ()
- statCard label count badgeClass href =
- Lucid.a_ [Lucid.href_ href, Lucid.class_ ("stat-card " <> badgeClass)] <| do
- Lucid.div_ [Lucid.class_ "stat-count"] (Lucid.toHtml (tshow count))
- Lucid.div_ [Lucid.class_ "stat-label"] (Lucid.toHtml label)
-
- metricCard :: (Monad m) => Text -> Text -> Lucid.HtmlT m ()
- metricCard label value =
- Lucid.div_ [Lucid.class_ "stat-card badge-neutral"] <| do
- Lucid.div_ [Lucid.class_ "stat-count"] (Lucid.toHtml value)
- Lucid.div_ [Lucid.class_ "stat-label"] (Lucid.toHtml label)
-
- formatCost :: Int -> Text
- formatCost cents =
- let dollars = fromIntegral cents / 100.0 :: Double
- in Text.pack ("$" <> showFFloat (Just 2) dollars "")
-
- formatDuration :: Int -> Text
- formatDuration totalSeconds
- | totalSeconds < 60 = tshow totalSeconds <> "s"
- | totalSeconds < 3600 =
- let mins = totalSeconds `div` 60
- in tshow mins <> "m"
- | otherwise =
- let hours = totalSeconds `div` 3600
- 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 currentSort _now) =
- let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Ready Queue" Nothing]
- in Lucid.doctypehtml_ <| do
- pageHead "Ready Queue - Jr"
- pageBodyWithCrumbs crumbs <| do
- Lucid.div_ [Lucid.class_ "container"] <| do
- Lucid.div_ [Lucid.class_ "page-header-row"] <| do
- Lucid.h1_ <| Lucid.toHtml ("Ready Queue (" <> tshow (length tasks) <> " tasks)")
- sortDropdown "/ready" currentSort
- if null tasks
- then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks are ready for work."
- else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard tasks
-
-instance Lucid.ToHtml BlockedPage where
- toHtmlRaw = Lucid.toHtml
- toHtml (BlockedPage tasksWithImpact currentSort _now) =
- let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Blocked" Nothing]
- in Lucid.doctypehtml_ <| do
- pageHead "Blocked Tasks - Jr"
- pageBodyWithCrumbs crumbs <| do
- Lucid.div_ [Lucid.class_ "container"] <| do
- Lucid.div_ [Lucid.class_ "page-header-row"] <| do
- Lucid.h1_ <| Lucid.toHtml ("Blocked Tasks (" <> tshow (length tasksWithImpact) <> " tasks)")
- sortDropdown "/blocked" currentSort
- Lucid.p_ [Lucid.class_ "info-msg"] "Tasks with unmet blocking dependencies, sorted by blocking impact."
- if null tasksWithImpact
- then Lucid.p_ [Lucid.class_ "empty-msg"] "No blocked tasks."
- else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderBlockedTaskCard tasksWithImpact
-
-instance Lucid.ToHtml InterventionPage where
- toHtmlRaw = Lucid.toHtml
- toHtml (InterventionPage actionItems currentSort _now) =
- let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Needs Human Action" Nothing]
- failed = TaskCore.failedTasks actionItems
- epicsReady = TaskCore.epicsInReview actionItems
- needsHelp = TaskCore.tasksNeedingHelp actionItems
- totalCount = length failed + length epicsReady + length needsHelp
- in Lucid.doctypehtml_ <| do
- pageHead "Needs Human Action - Jr"
- pageBodyWithCrumbs crumbs <| do
- Lucid.div_ [Lucid.class_ "container"] <| do
- Lucid.div_ [Lucid.class_ "page-header-row"] <| do
- Lucid.h1_ <| Lucid.toHtml ("Needs Human Action (" <> tshow totalCount <> " items)")
- sortDropdown "/intervention" currentSort
- if totalCount == 0
- then Lucid.p_ [Lucid.class_ "empty-msg"] "No items need human action."
- else do
- unless (null failed) <| do
- Lucid.h2_ [Lucid.class_ "section-header"] <| Lucid.toHtml ("Failed Tasks (" <> tshow (length failed) <> ")")
- Lucid.p_ [Lucid.class_ "info-msg"] "Tasks that have failed 3+ times and need human help."
- Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard (sortTasks currentSort failed)
- unless (null epicsReady) <| do
- Lucid.h2_ [Lucid.class_ "section-header"] <| Lucid.toHtml ("Epics Ready for Review (" <> tshow (length epicsReady) <> ")")
- Lucid.p_ [Lucid.class_ "info-msg"] "Epics with all children completed. Verify before closing."
- Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderEpicReviewCard epicsReady
- unless (null needsHelp) <| do
- Lucid.h2_ [Lucid.class_ "section-header"] <| Lucid.toHtml ("Needs Help (" <> tshow (length needsHelp) <> ")")
- Lucid.p_ [Lucid.class_ "info-msg"] "Tasks where Jr needs human guidance or decisions."
- Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard (sortTasks currentSort needsHelp)
-
-renderEpicReviewCard :: (Monad m) => TaskCore.EpicForReview -> Lucid.HtmlT m ()
-renderEpicReviewCard epicReview = do
- let task = TaskCore.epicTask epicReview
- total = TaskCore.epicTotal epicReview
- completed = TaskCore.epicCompleted epicReview
- progressText = tshow completed <> "/" <> tshow total <> " subtasks done"
- Lucid.div_ [Lucid.class_ "task-card"] <| do
- Lucid.div_ [Lucid.class_ "task-card-header"] <| do
- Lucid.div_ [Lucid.class_ "task-title-row"] <| do
- Lucid.a_
- [Lucid.href_ ("/tasks/" <> TaskCore.taskId task), Lucid.class_ "task-link"]
- <| Lucid.toHtml (TaskCore.taskTitle task)
- Lucid.span_ [Lucid.class_ "badge badge-epic"] "Epic"
- Lucid.span_ [Lucid.class_ "task-id"] <| Lucid.toHtml (TaskCore.taskId task)
- Lucid.div_ [Lucid.class_ "task-card-body"] <| do
- Lucid.div_ [Lucid.class_ "progress-info"] <| do
- Lucid.span_ [Lucid.class_ "badge badge-success"] <| Lucid.toHtml progressText
- Lucid.div_ [Lucid.class_ "epic-actions"] <| do
- Lucid.form_
- [ Lucid.method_ "POST",
- Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/status"),
- Lucid.class_ "inline-form"
- ]
- <| do
- Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "status", Lucid.value_ "done"]
- Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-success btn-sm"] "Approve & Close"
-
-instance Lucid.ToHtml KBPage where
- toHtmlRaw = Lucid.toHtml
- toHtml (KBPage facts) =
- let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Knowledge Base" Nothing]
- in Lucid.doctypehtml_ <| do
- pageHead "Knowledge Base - Jr"
- pageBodyWithCrumbs crumbs <| do
- Lucid.div_ [Lucid.class_ "container"] <| do
- Lucid.h1_ "Knowledge Base"
- Lucid.p_ [Lucid.class_ "info-msg"] "Facts learned during task execution."
-
- Lucid.details_ [Lucid.class_ "create-fact-section"] <| do
- Lucid.summary_ [Lucid.class_ "btn btn-primary create-fact-toggle"] "Create New Fact"
- Lucid.form_
- [ Lucid.method_ "POST",
- Lucid.action_ "/kb/create",
- Lucid.class_ "fact-create-form"
- ]
- <| do
- Lucid.div_ [Lucid.class_ "form-group"] <| do
- Lucid.label_ [Lucid.for_ "project"] "Project:"
- Lucid.input_
- [ Lucid.type_ "text",
- Lucid.name_ "project",
- Lucid.id_ "project",
- Lucid.class_ "form-input",
- Lucid.required_ "required",
- Lucid.placeholder_ "e.g., Omni/Jr"
- ]
- Lucid.div_ [Lucid.class_ "form-group"] <| do
- Lucid.label_ [Lucid.for_ "content"] "Fact Content:"
- Lucid.textarea_
- [ Lucid.name_ "content",
- Lucid.id_ "content",
- Lucid.class_ "form-textarea",
- Lucid.rows_ "4",
- Lucid.required_ "required",
- Lucid.placeholder_ "Describe the fact or knowledge..."
- ]
- ""
- Lucid.div_ [Lucid.class_ "form-group"] <| do
- Lucid.label_ [Lucid.for_ "files"] "Related Files (comma-separated):"
- Lucid.input_
- [ Lucid.type_ "text",
- Lucid.name_ "files",
- Lucid.id_ "files",
- Lucid.class_ "form-input",
- Lucid.placeholder_ "path/to/file1.hs, path/to/file2.hs"
- ]
- Lucid.div_ [Lucid.class_ "form-group"] <| do
- Lucid.label_ [Lucid.for_ "confidence"] "Confidence (0.0 - 1.0):"
- Lucid.input_
- [ Lucid.type_ "number",
- Lucid.name_ "confidence",
- Lucid.id_ "confidence",
- Lucid.class_ "form-input",
- Lucid.step_ "0.1",
- Lucid.min_ "0",
- Lucid.max_ "1",
- Lucid.value_ "0.8"
- ]
- Lucid.div_ [Lucid.class_ "form-actions"] <| do
- Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Create Fact"
-
- if null facts
- then Lucid.p_ [Lucid.class_ "empty-msg"] "No facts recorded yet."
- else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderFactCard facts
- where
- renderFactCard :: (Monad m) => TaskCore.Fact -> Lucid.HtmlT m ()
- renderFactCard f =
- let factUrl = "/kb/" <> maybe "-" tshow (TaskCore.factId f)
- in Lucid.a_
- [ Lucid.class_ "task-card task-card-link",
- Lucid.href_ factUrl
- ]
- <| do
- Lucid.div_ [Lucid.class_ "task-header"] <| do
- Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (maybe "-" tshow (TaskCore.factId f)))
- confidenceBadge (TaskCore.factConfidence f)
- Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (TaskCore.factProject f))
- Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (Text.take 80 (TaskCore.factContent f) <> if Text.length (TaskCore.factContent f) > 80 then "..." else ""))
- unless (null (TaskCore.factRelatedFiles f)) <| do
- Lucid.p_ [Lucid.class_ "kb-files"] <| do
- Lucid.span_ [Lucid.class_ "files-label"] "Files: "
- Lucid.toHtml (Text.intercalate ", " (take 3 (TaskCore.factRelatedFiles f)))
- when (length (TaskCore.factRelatedFiles f) > 3) <| do
- Lucid.toHtml (" +" <> tshow (length (TaskCore.factRelatedFiles f) - 3) <> " more")
-
- confidenceBadge :: (Monad m) => Double -> Lucid.HtmlT m ()
- confidenceBadge conf =
- let pct = floor (conf * 100) :: Int
- cls
- | conf >= 0.8 = "badge badge-done"
- | conf >= 0.5 = "badge badge-inprogress"
- | otherwise = "badge badge-open"
- in Lucid.span_ [Lucid.class_ cls] (Lucid.toHtml (tshow pct <> "%"))
-
-instance Lucid.ToHtml FactDetailPage where
- toHtmlRaw = Lucid.toHtml
- toHtml (FactDetailNotFound fid) =
- let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Knowledge Base" (Just "/kb"), Breadcrumb ("Fact #" <> tshow fid) Nothing]
- in Lucid.doctypehtml_ <| do
- pageHead "Fact Not Found - Jr"
- pageBodyWithCrumbs crumbs <| do
- Lucid.div_ [Lucid.class_ "container"] <| do
- 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 now) =
- let fid' = maybe "-" tshow (TaskCore.factId fact)
- crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Knowledge Base" (Just "/kb"), Breadcrumb ("Fact #" <> fid') Nothing]
- in Lucid.doctypehtml_ <| do
- pageHead "Fact Detail - Jr"
- pageBodyWithCrumbs crumbs <| do
- Lucid.div_ [Lucid.class_ "container"] <| do
- Lucid.div_ [Lucid.class_ "task-detail-header"] <| do
- Lucid.h1_ <| do
- Lucid.span_ [Lucid.class_ "detail-id"] (Lucid.toHtml ("Fact #" <> maybe "-" tshow (TaskCore.factId fact)))
- Lucid.div_ [Lucid.class_ "task-meta-row"] <| do
- Lucid.span_ [Lucid.class_ "meta-label"] "Project:"
- Lucid.span_ [Lucid.class_ "meta-value"] (Lucid.toHtml (TaskCore.factProject fact))
- Lucid.span_ [Lucid.class_ "meta-label"] "Confidence:"
- confidenceBadgeDetail (TaskCore.factConfidence fact)
- Lucid.span_ [Lucid.class_ "meta-label"] "Created:"
- Lucid.span_ [Lucid.class_ "meta-value"] (renderRelativeTimestamp now (TaskCore.factCreatedAt fact))
-
- Lucid.div_ [Lucid.class_ "detail-section"] <| do
- Lucid.h2_ "Content"
- Lucid.form_
- [ Lucid.method_ "POST",
- Lucid.action_ ("/kb/" <> maybe "-" tshow (TaskCore.factId fact) <> "/edit"),
- Lucid.class_ "fact-edit-form"
- ]
- <| do
- Lucid.div_ [Lucid.class_ "form-group"] <| do
- Lucid.label_ [Lucid.for_ "content"] "Fact Content:"
- Lucid.textarea_
- [ Lucid.name_ "content",
- Lucid.id_ "content",
- Lucid.class_ "form-textarea",
- Lucid.rows_ "6"
- ]
- (Lucid.toHtml (TaskCore.factContent fact))
-
- Lucid.div_ [Lucid.class_ "form-group"] <| do
- Lucid.label_ [Lucid.for_ "files"] "Related Files (comma-separated):"
- Lucid.input_
- [ Lucid.type_ "text",
- Lucid.name_ "files",
- Lucid.id_ "files",
- Lucid.class_ "form-input",
- Lucid.value_ (Text.intercalate ", " (TaskCore.factRelatedFiles fact))
- ]
-
- Lucid.div_ [Lucid.class_ "form-group"] <| do
- Lucid.label_ [Lucid.for_ "confidence"] "Confidence (0.0 - 1.0):"
- Lucid.input_
- [ Lucid.type_ "number",
- Lucid.name_ "confidence",
- Lucid.id_ "confidence",
- Lucid.class_ "form-input",
- Lucid.step_ "0.1",
- Lucid.min_ "0",
- Lucid.max_ "1",
- Lucid.value_ (tshow (TaskCore.factConfidence fact))
- ]
-
- Lucid.div_ [Lucid.class_ "form-actions"] <| do
- Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Save Changes"
-
- case TaskCore.factSourceTask fact of
- Nothing -> pure ()
- Just tid -> do
- Lucid.div_ [Lucid.class_ "detail-section"] <| do
- Lucid.h2_ "Source Task"
- Lucid.a_ [Lucid.href_ ("/tasks/" <> tid), Lucid.class_ "task-link"] (Lucid.toHtml tid)
-
- Lucid.div_ [Lucid.class_ "detail-section danger-zone"] <| do
- Lucid.h2_ "Danger Zone"
- Lucid.form_
- [ Lucid.method_ "POST",
- Lucid.action_ ("/kb/" <> maybe "-" tshow (TaskCore.factId fact) <> "/delete"),
- Lucid.class_ "delete-form",
- Lucid.makeAttribute "onsubmit" "return confirm('Are you sure you want to delete this fact?');"
- ]
- <| do
- Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-danger"] "Delete Fact"
-
- Lucid.div_ [Lucid.class_ "back-link"] <| do
- Lucid.a_ [Lucid.href_ "/kb"] "← Back to Knowledge Base"
- where
- confidenceBadgeDetail :: (Monad m) => Double -> Lucid.HtmlT m ()
- confidenceBadgeDetail conf =
- let pct = floor (conf * 100) :: Int
- cls
- | conf >= 0.8 = "badge badge-done"
- | conf >= 0.5 = "badge badge-inprogress"
- | otherwise = "badge badge-open"
- in Lucid.span_ [Lucid.class_ cls] (Lucid.toHtml (tshow pct <> "%"))
-
-instance Lucid.ToHtml EpicsPage where
- toHtmlRaw = Lucid.toHtml
- toHtml (EpicsPage epics allTasks currentSort) =
- let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Epics" Nothing]
- in Lucid.doctypehtml_ <| do
- pageHead "Epics - Jr"
- pageBodyWithCrumbs crumbs <| do
- Lucid.div_ [Lucid.class_ "container"] <| do
- Lucid.div_ [Lucid.class_ "page-header-row"] <| do
- Lucid.h1_ <| Lucid.toHtml ("Epics (" <> tshow (length epics) <> ")")
- sortDropdown "/epics" currentSort
- Lucid.p_ [Lucid.class_ "info-msg"] "All epics (large, multi-task projects)."
- if null epics
- then Lucid.p_ [Lucid.class_ "empty-msg"] "No epics found."
- else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ (renderEpicCardWithStats allTasks) epics
-
-epicProgressBar :: (Monad m) => Int -> Int -> Int -> Int -> Lucid.HtmlT m ()
-epicProgressBar doneCount inProgressCount openCount totalCount =
- let donePct = if totalCount == 0 then 0 else (doneCount * 100) `div` totalCount
- inProgressPct = if totalCount == 0 then 0 else (inProgressCount * 100) `div` totalCount
- openPct = if totalCount == 0 then 0 else (openCount * 100) `div` totalCount
- in Lucid.div_ [Lucid.class_ "multi-progress-container epic-progress"] <| do
- Lucid.div_ [Lucid.class_ "multi-progress-bar"] <| do
- when (donePct > 0)
- <| Lucid.div_
- [ Lucid.class_ "multi-progress-segment progress-done",
- Lucid.style_ ("width: " <> tshow donePct <> "%"),
- Lucid.title_ (tshow doneCount <> " done")
- ]
- ""
- when (inProgressPct > 0)
- <| Lucid.div_
- [ Lucid.class_ "multi-progress-segment progress-inprogress",
- Lucid.style_ ("width: " <> tshow inProgressPct <> "%"),
- Lucid.title_ (tshow inProgressCount <> " in progress")
- ]
- ""
- when (openPct > 0)
- <| Lucid.div_
- [ Lucid.class_ "multi-progress-segment progress-open",
- Lucid.style_ ("width: " <> tshow openPct <> "%"),
- Lucid.title_ (tshow openCount <> " open")
- ]
- ""
- Lucid.div_ [Lucid.class_ "progress-legend"] <| do
- Lucid.span_ [Lucid.class_ "legend-item"] <| do
- Lucid.span_ [Lucid.class_ "legend-dot legend-done"] ""
- Lucid.toHtml (tshow doneCount)
- Lucid.span_ [Lucid.class_ "legend-item"] <| do
- Lucid.span_ [Lucid.class_ "legend-dot legend-inprogress"] ""
- Lucid.toHtml (tshow inProgressCount)
- Lucid.span_ [Lucid.class_ "legend-item"] <| do
- Lucid.span_ [Lucid.class_ "legend-dot legend-open"] ""
- Lucid.toHtml (tshow openCount)
-
-renderEpicCardWithStats :: (Monad m) => [TaskCore.Task] -> TaskCore.Task -> Lucid.HtmlT m ()
-renderEpicCardWithStats allTasks t =
- let children = getDescendants allTasks (TaskCore.taskId t)
- openCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Open]
- inProgressCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.InProgress]
- reviewCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Review]
- doneCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Done]
- totalCount = length children
- openAndReview = openCount + reviewCount
- in Lucid.a_
- [ Lucid.class_ "task-card task-card-link",
- Lucid.href_ ("/tasks/" <> TaskCore.taskId t)
- ]
- <| do
- Lucid.div_ [Lucid.class_ "task-header"] <| do
- Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (TaskCore.taskId t))
- statusBadge (TaskCore.taskStatus t)
- Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t)))
- Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t))
- when (totalCount > 0) <| epicProgressBar doneCount inProgressCount openAndReview totalCount
- unless (Text.null (TaskCore.taskDescription t))
- <| Lucid.p_ [Lucid.class_ "kb-preview"] (Lucid.toHtml (Text.take 200 (TaskCore.taskDescription t) <> "..."))
-
-getDescendants :: [TaskCore.Task] -> Text -> [TaskCore.Task]
-getDescendants allTasks parentId =
- let children = [c | c <- allTasks, maybe False (TaskCore.matchesId parentId) (TaskCore.taskParent c)]
- in children ++ concatMap (getDescendants allTasks <. TaskCore.taskId) children
-
-instance Lucid.ToHtml TaskListPage where
- toHtmlRaw = Lucid.toHtml
- toHtml (TaskListPage tasks filters currentSort _now) =
- let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" Nothing]
- in Lucid.doctypehtml_ <| do
- pageHead "Tasks - Jr"
- pageBodyWithCrumbs crumbs <| do
- Lucid.div_ [Lucid.class_ "container"] <| do
- Lucid.div_ [Lucid.class_ "page-header-row"] <| do
- Lucid.h1_ <| Lucid.toHtml ("Tasks (" <> tshow (length tasks) <> ")")
- sortDropdown "/tasks" currentSort
-
- Lucid.div_ [Lucid.class_ "filter-form"] <| do
- Lucid.form_
- [ Lucid.method_ "GET",
- Lucid.action_ "/tasks",
- Lucid.makeAttribute "hx-get" "/partials/task-list",
- Lucid.makeAttribute "hx-target" "#task-list",
- Lucid.makeAttribute "hx-push-url" "/tasks",
- Lucid.makeAttribute "hx-trigger" "submit, change from:select"
- ]
- <| do
- Lucid.div_ [Lucid.class_ "filter-row"] <| do
- Lucid.div_ [Lucid.class_ "filter-group"] <| do
- Lucid.label_ [Lucid.for_ "status"] "Status:"
- Lucid.select_ [Lucid.name_ "status", Lucid.id_ "status", Lucid.class_ "filter-select"] <| do
- Lucid.option_ ([Lucid.value_ ""] <> maybeSelected Nothing (filterStatus filters)) "All"
- statusFilterOption TaskCore.Open (filterStatus filters)
- statusFilterOption TaskCore.InProgress (filterStatus filters)
- statusFilterOption TaskCore.Review (filterStatus filters)
- statusFilterOption TaskCore.Approved (filterStatus filters)
- statusFilterOption TaskCore.Done (filterStatus filters)
-
- Lucid.div_ [Lucid.class_ "filter-group"] <| do
- Lucid.label_ [Lucid.for_ "priority"] "Priority:"
- Lucid.select_ [Lucid.name_ "priority", Lucid.id_ "priority", Lucid.class_ "filter-select"] <| do
- Lucid.option_ ([Lucid.value_ ""] <> maybeSelected Nothing (filterPriority filters)) "All"
- priorityFilterOption TaskCore.P0 (filterPriority filters)
- priorityFilterOption TaskCore.P1 (filterPriority filters)
- priorityFilterOption TaskCore.P2 (filterPriority filters)
- priorityFilterOption TaskCore.P3 (filterPriority filters)
- priorityFilterOption TaskCore.P4 (filterPriority filters)
-
- Lucid.div_ [Lucid.class_ "filter-group"] <| do
- Lucid.label_ [Lucid.for_ "namespace"] "Namespace:"
- Lucid.input_
- [ Lucid.type_ "text",
- Lucid.name_ "namespace",
- Lucid.id_ "namespace",
- Lucid.class_ "filter-input",
- Lucid.placeholder_ "e.g. Omni/Jr",
- Lucid.value_ (fromMaybe "" (filterNamespace filters))
- ]
-
- Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "filter-btn"] "Filter"
- Lucid.a_
- [ Lucid.href_ "/tasks",
- Lucid.class_ "clear-btn",
- Lucid.makeAttribute "hx-get" "/partials/task-list",
- Lucid.makeAttribute "hx-target" "#task-list",
- Lucid.makeAttribute "hx-push-url" "/tasks"
- ]
- "Clear"
-
- Lucid.div_ [Lucid.id_ "task-list"] <| do
- if null tasks
- then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks match the current filters."
- else Lucid.div_ [Lucid.class_ "list-group"] <| traverse_ renderListGroupItem tasks
- where
- maybeSelected :: (Eq a) => Maybe a -> Maybe a -> [Lucid.Attribute]
- maybeSelected opt current = [Lucid.selected_ "selected" | opt == current]
-
- statusFilterOption :: (Monad m) => TaskCore.Status -> Maybe TaskCore.Status -> Lucid.HtmlT m ()
- statusFilterOption s current =
- let attrs = [Lucid.value_ (tshow s)] <> [Lucid.selected_ "selected" | Just s == current]
- in Lucid.option_ attrs (Lucid.toHtml (tshow s))
-
- priorityFilterOption :: (Monad m) => TaskCore.Priority -> Maybe TaskCore.Priority -> Lucid.HtmlT m ()
- priorityFilterOption p current =
- let attrs = [Lucid.value_ (tshow p)] <> [Lucid.selected_ "selected" | Just p == current]
- in Lucid.option_ attrs (Lucid.toHtml (tshow p))
-
-instance Lucid.ToHtml TaskDetailPage where
- toHtmlRaw = Lucid.toHtml
- toHtml (TaskDetailNotFound tid) =
- let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid Nothing]
- in Lucid.doctypehtml_ <| do
- pageHead "Task Not Found - Jr"
- pageBodyWithCrumbs crumbs <| do
- Lucid.div_ [Lucid.class_ "container"] <| do
- Lucid.h1_ "Task Not Found"
- Lucid.p_ <| do
- "The task "
- Lucid.code_ (Lucid.toHtml tid)
- " could not be found."
- toHtml (TaskDetailFound task allTasks _activities maybeRetry commits maybeAggMetrics agentEvents now) =
- let crumbs = taskBreadcrumbs allTasks task
- in Lucid.doctypehtml_ <| do
- pageHead (TaskCore.taskId task <> " - Jr")
- pageBodyWithCrumbs crumbs <| do
- Lucid.div_ [Lucid.class_ "container"] <| do
- Lucid.h1_ <| Lucid.toHtml (TaskCore.taskTitle task)
-
- renderRetryContextBanner (TaskCore.taskId task) maybeRetry
-
- Lucid.div_ [Lucid.class_ "task-detail"] <| do
- Lucid.div_ [Lucid.class_ "task-meta"] <| do
- Lucid.div_ [Lucid.class_ "task-meta-primary"] <| do
- Lucid.code_ [Lucid.class_ "task-meta-id"] (Lucid.toHtml (TaskCore.taskId task))
- metaSep
- Lucid.span_ [Lucid.class_ "task-meta-type"] (Lucid.toHtml (tshow (TaskCore.taskType task)))
- metaSep
- statusBadgeWithForm (TaskCore.taskStatus task) (TaskCore.taskId task)
- metaSep
- priorityBadgeWithForm (TaskCore.taskPriority task) (TaskCore.taskId task)
- case TaskCore.taskComplexity task of
- Nothing -> pure ()
- Just c -> do
- metaSep
- complexityBadge c
- case TaskCore.taskNamespace task of
- Nothing -> pure ()
- Just ns -> do
- metaSep
- Lucid.span_ [Lucid.class_ "task-meta-ns"] (Lucid.toHtml ns)
-
- Lucid.div_ [Lucid.class_ "task-meta-secondary"] <| do
- case TaskCore.taskParent task of
- Nothing -> pure ()
- Just pid -> do
- Lucid.span_ [Lucid.class_ "task-meta-label"] "Parent:"
- Lucid.a_ [Lucid.href_ ("/tasks/" <> pid), Lucid.class_ "task-link"] (Lucid.toHtml pid)
- metaSep
- Lucid.span_ [Lucid.class_ "task-meta-label"] "Created"
- renderRelativeTimestamp now (TaskCore.taskCreatedAt task)
- metaSep
- Lucid.span_ [Lucid.class_ "task-meta-label"] "Updated"
- renderRelativeTimestamp now (TaskCore.taskUpdatedAt task)
-
- let deps = TaskCore.taskDependencies task
- unless (null deps) <| do
- Lucid.div_ [Lucid.class_ "detail-section"] <| do
- Lucid.h3_ "Dependencies"
- Lucid.ul_ [Lucid.class_ "dep-list"] <| do
- traverse_ renderDependency deps
-
- when (TaskCore.taskType task == TaskCore.Epic) <| do
- for_ maybeAggMetrics (renderAggregatedMetrics allTasks task)
-
- Lucid.div_ [Lucid.class_ "detail-section"] <| do
- Lucid.toHtml (DescriptionViewPartial (TaskCore.taskId task) (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic))
-
- let children = filter (maybe False (TaskCore.matchesId (TaskCore.taskId task)) <. TaskCore.taskParent) allTasks
- unless (null children) <| do
- Lucid.div_ [Lucid.class_ "detail-section"] <| do
- Lucid.h3_ "Child Tasks"
- Lucid.ul_ [Lucid.class_ "child-list"] <| do
- traverse_ renderChild children
-
- unless (null commits) <| do
- Lucid.div_ [Lucid.class_ "detail-section"] <| do
- Lucid.h3_ "Git Commits"
- Lucid.div_ [Lucid.class_ "commit-list"] <| do
- traverse_ (renderCommit (TaskCore.taskId task)) commits
-
- when (TaskCore.taskStatus task == TaskCore.Review) <| do
- Lucid.div_ [Lucid.class_ "review-link-section"] <| do
- Lucid.a_
- [ Lucid.href_ ("/tasks/" <> TaskCore.taskId task <> "/review"),
- Lucid.class_ "review-link-btn"
- ]
- "Review This Task"
-
- renderUnifiedTimeline (TaskCore.taskId task) (TaskCore.taskComments task) agentEvents (TaskCore.taskStatus task) now
- where
- renderDependency :: (Monad m) => TaskCore.Dependency -> Lucid.HtmlT m ()
- renderDependency dep =
- Lucid.li_ <| do
- Lucid.a_ [Lucid.href_ ("/tasks/" <> TaskCore.depId dep), Lucid.class_ "task-link"] (Lucid.toHtml (TaskCore.depId dep))
- Lucid.span_ [Lucid.class_ "dep-type"] <| Lucid.toHtml (" [" <> tshow (TaskCore.depType dep) <> "]")
-
- renderChild :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m ()
- renderChild child =
- Lucid.li_ <| do
- Lucid.a_ [Lucid.href_ ("/tasks/" <> TaskCore.taskId child), Lucid.class_ "task-link"] (Lucid.toHtml (TaskCore.taskId child))
- Lucid.span_ [Lucid.class_ "child-title"] <| Lucid.toHtml (" - " <> TaskCore.taskTitle child)
- Lucid.span_ [Lucid.class_ "child-status"] <| Lucid.toHtml (" [" <> tshow (TaskCore.taskStatus child) <> "]")
-
- renderCommit :: (Monad m) => Text -> GitCommit -> Lucid.HtmlT m ()
- renderCommit tid c =
- Lucid.div_ [Lucid.class_ "commit-item"] <| do
- Lucid.div_ [Lucid.class_ "commit-header"] <| do
- Lucid.a_
- [ Lucid.href_ ("/tasks/" <> tid <> "/diff/" <> commitHash c),
- Lucid.class_ "commit-hash"
- ]
- (Lucid.toHtml (commitShortHash c))
- Lucid.span_ [Lucid.class_ "commit-summary"] (Lucid.toHtml (commitSummary c))
- Lucid.div_ [Lucid.class_ "commit-meta"] <| do
- Lucid.span_ [Lucid.class_ "commit-author"] (Lucid.toHtml (commitAuthor c))
- Lucid.span_ [Lucid.class_ "commit-date"] (Lucid.toHtml (commitRelativeDate c))
- Lucid.span_ [Lucid.class_ "commit-files"] (Lucid.toHtml (tshow (commitFilesChanged c) <> " files"))
-
-renderAggregatedMetrics :: (Monad m) => [TaskCore.Task] -> TaskCore.Task -> TaskCore.AggregatedMetrics -> Lucid.HtmlT m ()
-renderAggregatedMetrics allTasks task metrics =
- let descendants = getDescendants allTasks (TaskCore.taskId task)
- totalCount = length descendants
- costCents = TaskCore.aggTotalCostCents metrics
- durationSecs = TaskCore.aggTotalDurationSeconds metrics
- completedCount = TaskCore.aggCompletedTasks metrics
- tokensUsed = TaskCore.aggTotalTokens metrics
- in Lucid.div_ [Lucid.class_ "detail-section aggregated-metrics"] <| do
- Lucid.h3_ "Execution Summary"
- Lucid.div_ [Lucid.class_ "metrics-grid"] <| do
- Lucid.div_ [Lucid.class_ "metric-card"] <| do
- Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (tshow completedCount <> "/" <> tshow totalCount))
- Lucid.div_ [Lucid.class_ "metric-label"] "Tasks Completed"
- Lucid.div_ [Lucid.class_ "metric-card"] <| do
- Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCost costCents))
- Lucid.div_ [Lucid.class_ "metric-label"] "Total Cost"
- Lucid.div_ [Lucid.class_ "metric-card"] <| do
- Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDuration durationSecs))
- Lucid.div_ [Lucid.class_ "metric-label"] "Total Time"
- when (tokensUsed > 0) <| do
- Lucid.div_ [Lucid.class_ "metric-card"] <| do
- Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatTokens tokensUsed))
- Lucid.div_ [Lucid.class_ "metric-label"] "Tokens Used"
- where
- formatCost :: Int -> Text
- formatCost cents =
- let dollars = fromIntegral cents / 100.0 :: Double
- in "$" <> Text.pack (showFFloat (Just 2) dollars "")
-
- formatDuration :: Int -> Text
- formatDuration secs
- | secs < 60 = tshow secs <> "s"
- | secs < 3600 =
- let mins = secs `div` 60
- remSecs = secs `mod` 60
- in tshow mins <> "m " <> tshow remSecs <> "s"
- | otherwise =
- let hrs = secs `div` 3600
- mins = (secs `mod` 3600) `div` 60
- in tshow hrs <> "h " <> tshow mins <> "m"
-
- formatTokens :: Int -> Text
- formatTokens t
- | t < 1000 = tshow t
- | t < 1000000 = Text.pack (showFFloat (Just 1) (fromIntegral t / 1000.0 :: Double) "") <> "K"
- | otherwise = Text.pack (showFFloat (Just 2) (fromIntegral t / 1000000.0 :: Double) "") <> "M"
-
-renderRetryContextBanner :: (Monad m) => Text -> Maybe TaskCore.RetryContext -> Lucid.HtmlT m ()
-renderRetryContextBanner _ Nothing = pure ()
-renderRetryContextBanner tid (Just ctx) =
- Lucid.div_ [Lucid.class_ bannerClass] <| do
- Lucid.div_ [Lucid.class_ "retry-banner-header"] <| do
- Lucid.span_ [Lucid.class_ "retry-icon"] retryIcon
- Lucid.span_ [Lucid.class_ "retry-attempt"] (Lucid.toHtml attemptText)
- when maxRetriesExceeded
- <| Lucid.span_ [Lucid.class_ "retry-warning-badge"] "Needs Human Intervention"
-
- Lucid.div_ [Lucid.class_ "retry-banner-details"] <| do
- Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do
- Lucid.span_ [Lucid.class_ "retry-label"] "Failure Reason:"
- Lucid.span_ [Lucid.class_ "retry-value"] (Lucid.toHtml (summarizeReason (TaskCore.retryReason ctx)))
-
- let commit = TaskCore.retryOriginalCommit ctx
- unless (Text.null commit) <| do
- Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do
- Lucid.span_ [Lucid.class_ "retry-label"] "Original Commit:"
- Lucid.code_ [Lucid.class_ "retry-commit"] (Lucid.toHtml (Text.take 8 commit))
-
- let conflicts = TaskCore.retryConflictFiles ctx
- unless (null conflicts) <| do
- Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do
- Lucid.span_ [Lucid.class_ "retry-label"] "Conflict Files:"
- Lucid.ul_ [Lucid.class_ "retry-conflict-list"]
- <| traverse_ (Lucid.li_ <. Lucid.toHtml) conflicts
-
- when maxRetriesExceeded <| do
- Lucid.div_
- [Lucid.class_ "retry-warning-message"]
- "This task has exceeded the maximum number of retries. A human must review the failure and either fix the issue manually or reset the retry count."
-
- Lucid.p_ [Lucid.class_ "retry-hint"] "Use comments below to provide guidance for retry."
-
- Lucid.div_ [Lucid.class_ "retry-reset-section"] <| do
- Lucid.h4_ "Reset Retries"
- Lucid.p_ [Lucid.class_ "notes-help"] "Clear retry context and give task a fresh start:"
- Lucid.form_ [Lucid.method_ "POST", Lucid.action_ ("/tasks/" <> tid <> "/reset-retries")] <| do
- Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "reset-btn"] "Reset Retries"
- where
- attempt = TaskCore.retryAttempt ctx
- maxRetriesExceeded = attempt >= 3
- bannerClass = if maxRetriesExceeded then "retry-banner retry-banner-critical" else "retry-banner retry-banner-warning"
- retryIcon = if maxRetriesExceeded then "⚠" else "↻"
- attemptText = "Attempt " <> tshow attempt <> " of 3"
-
- summarizeReason :: Text -> Text
- summarizeReason reason
- | "rejected:" `Text.isPrefixOf` reason = "Rejected: " <> Text.strip (Text.drop 9 reason)
- | "Test failure:" `Text.isPrefixOf` reason = "Test failure (see details below)"
- | "MERGE CONFLICT" `Text.isPrefixOf` reason = "Merge conflict with concurrent changes"
- | otherwise = Text.take 100 reason <> if Text.length reason > 100 then "..." else ""
-
-instance Lucid.ToHtml TaskReviewPage where
- toHtmlRaw = Lucid.toHtml
- toHtml (ReviewPageNotFound tid) =
- let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb "Review" Nothing]
- in Lucid.doctypehtml_ <| do
- pageHead "Task Not Found - Jr Review"
- pageBodyWithCrumbs crumbs <| do
- Lucid.div_ [Lucid.class_ "container"] <| do
- Lucid.h1_ "Task Not Found"
- Lucid.p_ <| do
- "The task "
- Lucid.code_ (Lucid.toHtml tid)
- " could not be found."
- toHtml (ReviewPageFound task reviewInfo) =
- let tid = TaskCore.taskId task
- crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb "Review" Nothing]
- in Lucid.doctypehtml_ <| do
- pageHead ("Review: " <> TaskCore.taskId task <> " - Jr")
- pageBodyWithCrumbs crumbs <| do
- Lucid.div_ [Lucid.class_ "container"] <| do
- Lucid.h1_ "Review Task"
-
- Lucid.div_ [Lucid.class_ "task-summary"] <| do
- Lucid.div_ [Lucid.class_ "detail-row"] <| do
- Lucid.span_ [Lucid.class_ "detail-label"] "ID:"
- Lucid.code_ [Lucid.class_ "detail-value"] (Lucid.toHtml (TaskCore.taskId task))
- Lucid.div_ [Lucid.class_ "detail-row"] <| do
- Lucid.span_ [Lucid.class_ "detail-label"] "Title:"
- Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (TaskCore.taskTitle task))
- Lucid.div_ [Lucid.class_ "detail-row"] <| do
- Lucid.span_ [Lucid.class_ "detail-label"] "Status:"
- Lucid.span_ [Lucid.class_ "detail-value"] <| statusBadge (TaskCore.taskStatus task)
-
- case reviewInfo of
- ReviewNoCommit ->
- Lucid.div_ [Lucid.class_ "no-commit-msg"] <| do
- Lucid.h3_ "No Commit Found"
- Lucid.p_ "No commit with this task ID was found in the git history."
- Lucid.p_ "The worker may not have completed yet, or the commit message doesn't include the task ID."
- ReviewMergeConflict commitSha conflictFiles ->
- Lucid.div_ [Lucid.class_ "conflict-warning"] <| do
- Lucid.h3_ "Merge Conflict Detected"
- Lucid.p_ <| do
- "Commit "
- Lucid.code_ (Lucid.toHtml (Text.take 8 commitSha))
- " cannot be cleanly merged."
- Lucid.p_ "Conflicting files:"
- Lucid.ul_ <| traverse_ (Lucid.li_ <. Lucid.toHtml) conflictFiles
- ReviewReady commitSha diffText -> do
- Lucid.div_ [Lucid.class_ "diff-section"] <| do
- Lucid.h3_ <| do
- "Commit: "
- Lucid.code_ (Lucid.toHtml (Text.take 8 commitSha))
- Lucid.pre_ [Lucid.class_ "diff-block"] (Lucid.toHtml diffText)
-
- Lucid.div_ [Lucid.class_ "review-actions"] <| do
- Lucid.form_
- [ Lucid.method_ "POST",
- Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/accept"),
- Lucid.class_ "inline-form"
- ]
- <| do
- Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "accept-btn"] "Accept"
-
- Lucid.form_
- [ Lucid.method_ "POST",
- Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/reject"),
- Lucid.class_ "reject-form"
- ]
- <| do
- Lucid.textarea_
- [ Lucid.name_ "notes",
- Lucid.class_ "reject-notes",
- Lucid.placeholder_ "Rejection notes (optional)"
- ]
- ""
- Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "reject-btn"] "Reject"
-
-instance Lucid.ToHtml TaskDiffPage where
- toHtmlRaw = Lucid.toHtml
- toHtml (DiffPageNotFound tid commitHash') =
- let shortHash = Text.take 8 commitHash'
- crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb ("Diff " <> shortHash) Nothing]
- in Lucid.doctypehtml_ <| do
- pageHead "Commit Not Found - Jr"
- pageBodyWithCrumbs crumbs <| do
- Lucid.div_ [Lucid.class_ "container"] <| do
- Lucid.h1_ "Commit Not Found"
- Lucid.p_ <| do
- "Could not find commit "
- Lucid.code_ (Lucid.toHtml commitHash')
- Lucid.a_ [Lucid.href_ ("/tasks/" <> tid), Lucid.class_ "back-link"] "← Back to task"
- toHtml (DiffPageFound tid commitHash' diffOutput) =
- let shortHash = Text.take 8 commitHash'
- crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb ("Diff " <> shortHash) Nothing]
- in Lucid.doctypehtml_ <| do
- pageHead ("Diff " <> shortHash <> " - Jr")
- pageBodyWithCrumbs crumbs <| do
- Lucid.div_ [Lucid.class_ "container"] <| do
- Lucid.div_ [Lucid.class_ "diff-header"] <| do
- Lucid.a_ [Lucid.href_ ("/tasks/" <> tid), Lucid.class_ "back-link"] "← Back to task"
- Lucid.h1_ <| do
- "Commit "
- Lucid.code_ (Lucid.toHtml shortHash)
- Lucid.pre_ [Lucid.class_ "diff-block"] (Lucid.toHtml diffOutput)
-
-instance Lucid.ToHtml StatsPage where
- toHtmlRaw = Lucid.toHtml
- toHtml (StatsPage stats maybeEpic) =
- let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Stats" Nothing]
- in Lucid.doctypehtml_ <| do
- pageHead "Task Statistics - Jr"
- pageBodyWithCrumbs crumbs <| do
- Lucid.div_ [Lucid.class_ "container"] <| do
- Lucid.h1_ <| case maybeEpic of
- Nothing -> "Task Statistics"
- Just epicId -> Lucid.toHtml ("Statistics for Epic: " <> epicId)
-
- Lucid.form_ [Lucid.method_ "GET", Lucid.action_ "/stats", Lucid.class_ "filter-form"] <| do
- Lucid.div_ [Lucid.class_ "filter-row"] <| do
- Lucid.div_ [Lucid.class_ "filter-group"] <| do
- Lucid.label_ [Lucid.for_ "epic"] "Epic:"
- Lucid.input_
- [ Lucid.type_ "text",
- Lucid.name_ "epic",
- Lucid.id_ "epic",
- Lucid.class_ "filter-input",
- Lucid.placeholder_ "Epic ID (optional)",
- Lucid.value_ (fromMaybe "" maybeEpic)
- ]
- Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "filter-btn"] "Filter"
- Lucid.a_ [Lucid.href_ "/stats", Lucid.class_ "clear-btn"] "Clear"
-
- Lucid.h2_ "By Status"
- multiColorProgressBar stats
- Lucid.div_ [Lucid.class_ "stats-grid"] <| do
- statCard "Open" (TaskCore.openTasks stats) (TaskCore.totalTasks stats)
- statCard "In Progress" (TaskCore.inProgressTasks stats) (TaskCore.totalTasks stats)
- statCard "Review" (TaskCore.reviewTasks stats) (TaskCore.totalTasks stats)
- statCard "Approved" (TaskCore.approvedTasks stats) (TaskCore.totalTasks stats)
- statCard "Done" (TaskCore.doneTasks stats) (TaskCore.totalTasks stats)
-
- Lucid.h2_ "By Priority"
- Lucid.div_ [Lucid.class_ "stats-section"] <| do
- traverse_ (uncurry renderPriorityRow) (TaskCore.tasksByPriority stats)
-
- Lucid.h2_ "By Namespace"
- Lucid.div_ [Lucid.class_ "stats-section"] <| do
- if null (TaskCore.tasksByNamespace stats)
- then Lucid.p_ [Lucid.class_ "empty-msg"] "No namespaces found."
- else traverse_ (uncurry (renderNamespaceRow (TaskCore.totalTasks stats))) (TaskCore.tasksByNamespace stats)
-
- Lucid.h2_ "Summary"
- Lucid.div_ [Lucid.class_ "summary-section"] <| do
- Lucid.div_ [Lucid.class_ "detail-row"] <| do
- Lucid.span_ [Lucid.class_ "detail-label"] "Total Tasks:"
- Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.totalTasks stats)))
- Lucid.div_ [Lucid.class_ "detail-row"] <| do
- Lucid.span_ [Lucid.class_ "detail-label"] "Epics:"
- Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.totalEpics stats)))
- Lucid.div_ [Lucid.class_ "detail-row"] <| do
- Lucid.span_ [Lucid.class_ "detail-label"] "Ready:"
- Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.readyTasks stats)))
- Lucid.div_ [Lucid.class_ "detail-row"] <| do
- Lucid.span_ [Lucid.class_ "detail-label"] "Blocked:"
- Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.blockedTasks stats)))
- where
- statCard :: (Monad m) => Text -> Int -> Int -> Lucid.HtmlT m ()
- statCard label count total =
- let pct = if total == 0 then 0 else (count * 100) `div` total
- in Lucid.div_ [Lucid.class_ "stat-card"] <| do
- Lucid.div_ [Lucid.class_ "stat-count"] (Lucid.toHtml (tshow count))
- Lucid.div_ [Lucid.class_ "stat-label"] (Lucid.toHtml label)
- Lucid.div_ [Lucid.class_ "progress-bar"] <| do
- Lucid.div_
- [ Lucid.class_ "progress-fill",
- Lucid.style_ ("width: " <> tshow pct <> "%")
- ]
- ""
-
- renderPriorityRow :: (Monad m) => TaskCore.Priority -> Int -> Lucid.HtmlT m ()
- renderPriorityRow priority count =
- let total = TaskCore.totalTasks stats
- pct = if total == 0 then 0 else (count * 100) `div` total
- in Lucid.div_ [Lucid.class_ "stats-row"] <| do
- Lucid.span_ [Lucid.class_ "stats-label"] (Lucid.toHtml (tshow priority))
- Lucid.div_ [Lucid.class_ "stats-bar-container"] <| do
- Lucid.div_ [Lucid.class_ "progress-bar"] <| do
- Lucid.div_
- [ Lucid.class_ "progress-fill",
- Lucid.style_ ("width: " <> tshow pct <> "%")
- ]
- ""
- Lucid.span_ [Lucid.class_ "stats-count"] (Lucid.toHtml (tshow count))
-
- renderNamespaceRow :: (Monad m) => Int -> Text -> Int -> Lucid.HtmlT m ()
- renderNamespaceRow total ns count =
- let pct = if total == 0 then 0 else (count * 100) `div` total
- in Lucid.div_ [Lucid.class_ "stats-row"] <| do
- Lucid.span_ [Lucid.class_ "stats-label"] (Lucid.toHtml ns)
- Lucid.div_ [Lucid.class_ "stats-bar-container"] <| do
- Lucid.div_ [Lucid.class_ "progress-bar"] <| do
- Lucid.div_
- [ Lucid.class_ "progress-fill",
- Lucid.style_ ("width: " <> tshow pct <> "%")
- ]
- ""
- Lucid.span_ [Lucid.class_ "stats-count"] (Lucid.toHtml (tshow count))
-
-instance Lucid.ToHtml RecentActivityNewPartial where
- toHtmlRaw = Lucid.toHtml
- toHtml (RecentActivityNewPartial tasks maybeNewestTs) = do
- traverse_ renderListGroupItem tasks
- case maybeNewestTs of
- Nothing -> pure ()
- Just ts ->
- Lucid.div_
- [ Lucid.id_ "recent-activity",
- Lucid.makeAttribute "data-newest-ts" (tshow ts),
- Lucid.makeAttribute "hx-swap-oob" "attributes:#recent-activity data-newest-ts"
- ]
- ""
-
-instance Lucid.ToHtml RecentActivityMorePartial where
- toHtmlRaw = Lucid.toHtml
- toHtml (RecentActivityMorePartial tasks nextOffset hasMore) = do
- traverse_ renderListGroupItem tasks
- if hasMore
- then
- Lucid.button_
- [ Lucid.id_ "activity-load-more",
- Lucid.class_ "btn btn-secondary load-more-btn",
- Lucid.makeAttribute "hx-get" ("/partials/recent-activity-more?offset=" <> tshow nextOffset),
- Lucid.makeAttribute "hx-target" "#activity-list",
- Lucid.makeAttribute "hx-swap" "beforeend",
- Lucid.makeAttribute "hx-swap-oob" "true"
- ]
- "Load More"
- else Lucid.span_ [Lucid.id_ "activity-load-more", Lucid.makeAttribute "hx-swap-oob" "true"] ""
-
-instance Lucid.ToHtml ReadyCountPartial where
- toHtmlRaw = Lucid.toHtml
- toHtml (ReadyCountPartial count) =
- Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "ready-link"]
- <| Lucid.toHtml ("(" <> tshow count <> " tasks)")
-
-instance Lucid.ToHtml StatusBadgePartial where
- toHtmlRaw = Lucid.toHtml
- toHtml (StatusBadgePartial status tid) =
- statusBadgeWithForm status tid
-
-instance Lucid.ToHtml PriorityBadgePartial where
- toHtmlRaw = Lucid.toHtml
- toHtml (PriorityBadgePartial priority tid) =
- priorityBadgeWithForm priority tid
-
-instance Lucid.ToHtml TaskListPartial where
- toHtmlRaw = Lucid.toHtml
- toHtml (TaskListPartial tasks) =
- if null tasks
- then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks match the current filters."
- else Lucid.div_ [Lucid.class_ "list-group"] <| traverse_ renderListGroupItem tasks
-
-instance Lucid.ToHtml TaskMetricsPartial where
- toHtmlRaw = Lucid.toHtml
- toHtml (TaskMetricsPartial _tid activities maybeRetry now) =
- let runningActs = filter (\a -> TaskCore.activityStage a == TaskCore.Running) activities
- in if null runningActs
- then Lucid.p_ [Lucid.class_ "empty-msg"] "No worker execution data available."
- else
- Lucid.div_ [Lucid.class_ "execution-details"] <| do
- let totalCost = sum [c | act <- runningActs, Just c <- [TaskCore.activityCostCents act]]
- totalDuration = sum [calcDurSecs act | act <- runningActs]
- attemptCount = length runningActs
-
- case maybeRetry of
- Nothing -> pure ()
- Just ctx ->
- Lucid.div_ [Lucid.class_ "metric-row"] <| do
- Lucid.span_ [Lucid.class_ "metric-label"] "Retry Attempt:"
- Lucid.span_ [Lucid.class_ "metric-value retry-count"] (Lucid.toHtml (tshow (TaskCore.retryAttempt ctx) <> "/3"))
-
- when (attemptCount > 1) <| do
- Lucid.div_ [Lucid.class_ "metric-row"] <| do
- Lucid.span_ [Lucid.class_ "metric-label"] "Total Attempts:"
- Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (tshow attemptCount))
- Lucid.div_ [Lucid.class_ "metric-row"] <| do
- Lucid.span_ [Lucid.class_ "metric-label"] "Total Duration:"
- Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDurSecs totalDuration))
- when (totalCost > 0)
- <| Lucid.div_ [Lucid.class_ "metric-row"]
- <| do
- Lucid.span_ [Lucid.class_ "metric-label"] "Total Cost:"
- Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCost totalCost))
- Lucid.hr_ [Lucid.class_ "attempts-divider"]
-
- traverse_ (renderAttempt attemptCount now) (zip [1 ..] (reverse runningActs))
- where
- calcDurSecs :: TaskCore.TaskActivity -> Int
- calcDurSecs act = case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of
- (Just start, Just end) -> floor (diffUTCTime end start)
- _ -> 0
-
- formatDurSecs :: Int -> Text
- formatDurSecs secs
- | secs < 60 = tshow secs <> "s"
- | secs < 3600 = tshow (secs `div` 60) <> "m " <> tshow (secs `mod` 60) <> "s"
- | otherwise = tshow (secs `div` 3600) <> "h " <> tshow ((secs `mod` 3600) `div` 60) <> "m"
-
- renderAttempt :: (Monad m) => Int -> UTCTime -> (Int, TaskCore.TaskActivity) -> Lucid.HtmlT m ()
- renderAttempt totalAttempts currentTime (attemptNum, act) = do
- when (totalAttempts > 1)
- <| Lucid.div_ [Lucid.class_ "attempt-header"] (Lucid.toHtml ("Attempt " <> tshow attemptNum :: Text))
- case TaskCore.activityThreadUrl act of
- Nothing -> pure ()
- Just url ->
- Lucid.div_ [Lucid.class_ "metric-row"] <| do
- Lucid.span_ [Lucid.class_ "metric-label"] "Session:"
- Lucid.a_ [Lucid.href_ url, Lucid.target_ "_blank", Lucid.class_ "amp-thread-btn"] "View in Amp ↗"
-
- case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of
- (Just start, Just end) ->
- Lucid.div_ [Lucid.class_ "metric-row"] <| do
- Lucid.span_ [Lucid.class_ "metric-label"] "Duration:"
- Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDuration start end))
- (Just start, Nothing) ->
- Lucid.div_ [Lucid.class_ "metric-row"] <| do
- Lucid.span_ [Lucid.class_ "metric-label"] "Started:"
- Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp currentTime start)
- _ -> pure ()
-
- case TaskCore.activityCostCents act of
- Nothing -> pure ()
- Just cents ->
- Lucid.div_ [Lucid.class_ "metric-row"] <| do
- Lucid.span_ [Lucid.class_ "metric-label"] "Cost:"
- Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCost cents))
-
- Lucid.div_ [Lucid.class_ "metric-row"] <| do
- Lucid.span_ [Lucid.class_ "metric-label"] "Timestamp:"
- Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp currentTime (TaskCore.activityTimestamp act))
-
- formatDuration :: UTCTime -> UTCTime -> Text
- formatDuration start end =
- let diffSecs = floor (diffUTCTime end start) :: Int
- mins = diffSecs `div` 60
- secs = diffSecs `mod` 60
- in if mins > 0
- then tshow mins <> "m " <> tshow secs <> "s"
- else tshow secs <> "s"
-
- formatCost :: Int -> Text
- formatCost cents =
- let dollars = fromIntegral cents / 100.0 :: Double
- in "$" <> Text.pack (showFFloat (Just 2) dollars "")
-
-instance Lucid.ToHtml DescriptionViewPartial where
- toHtmlRaw = Lucid.toHtml
- toHtml (DescriptionViewPartial tid desc isEpic) =
- Lucid.div_ [Lucid.id_ "description-block", Lucid.class_ "description-block"] <| do
- Lucid.div_ [Lucid.class_ "description-header"] <| do
- Lucid.h3_ (if isEpic then "Design" else "Description")
- Lucid.a_
- [ Lucid.href_ "#",
- Lucid.class_ "edit-link",
- Lucid.makeAttribute "hx-get" ("/tasks/" <> tid <> "/description/edit"),
- Lucid.makeAttribute "hx-target" "#description-block",
- Lucid.makeAttribute "hx-swap" "outerHTML"
- ]
- "Edit"
- if Text.null desc
- then Lucid.p_ [Lucid.class_ "empty-msg"] (if isEpic then "No design document yet." else "No description yet.")
- else Lucid.div_ [Lucid.class_ "markdown-content"] (renderMarkdown desc)
-
-instance Lucid.ToHtml DescriptionEditPartial where
- toHtmlRaw = Lucid.toHtml
- toHtml (DescriptionEditPartial tid desc isEpic) =
- Lucid.div_ [Lucid.id_ "description-block", Lucid.class_ "description-block editing"] <| do
- Lucid.div_ [Lucid.class_ "description-header"] <| do
- Lucid.h3_ (if isEpic then "Design" else "Description")
- Lucid.button_
- [ Lucid.type_ "button",
- Lucid.class_ "cancel-link",
- Lucid.makeAttribute "hx-get" ("/tasks/" <> tid <> "/description/view"),
- Lucid.makeAttribute "hx-target" "#description-block",
- Lucid.makeAttribute "hx-swap" "outerHTML",
- Lucid.makeAttribute "hx-confirm" "Discard changes?"
- ]
- "Cancel"
- Lucid.form_
- [ Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/description"),
- Lucid.makeAttribute "hx-target" "#description-block",
- Lucid.makeAttribute "hx-swap" "outerHTML"
- ]
- <| do
- Lucid.textarea_
- [ Lucid.name_ "description",
- Lucid.class_ "description-textarea",
- Lucid.rows_ (if isEpic then "15" else "10"),
- Lucid.placeholder_ (if isEpic then "Enter design in Markdown..." else "Enter description...")
- ]
- (Lucid.toHtml desc)
- Lucid.div_ [Lucid.class_ "form-actions"] <| do
- Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Save"
-
--- | Simple markdown renderer for epic descriptions
--- Supports: headers (#, ##, ###), lists (- or *), code blocks (```), inline code (`)
-renderMarkdown :: (Monad m) => Text -> Lucid.HtmlT m ()
-renderMarkdown input = renderBlocks (parseBlocks (Text.lines input))
-
-data MarkdownBlock
- = MdHeader Int Text
- | MdParagraph [Text]
- | MdCodeBlock [Text]
- | MdList [Text]
- deriving (Show, Eq)
-
-parseBlocks :: [Text] -> [MarkdownBlock]
-parseBlocks [] = []
-parseBlocks lns = case lns of
- (l : rest)
- | "```" `Text.isPrefixOf` l ->
- let (codeLines, afterCode) = List.span (not <. Text.isPrefixOf "```") rest
- remaining = List.drop 1 afterCode
- in MdCodeBlock codeLines : parseBlocks remaining
- | "### " `Text.isPrefixOf` l ->
- MdHeader 3 (Text.drop 4 l) : parseBlocks rest
- | "## " `Text.isPrefixOf` l ->
- MdHeader 2 (Text.drop 3 l) : parseBlocks rest
- | "# " `Text.isPrefixOf` l ->
- MdHeader 1 (Text.drop 2 l) : parseBlocks rest
- | isListItem l ->
- let (listLines, afterList) = List.span isListItem lns
- in MdList (map stripListPrefix listLines) : parseBlocks afterList
- | Text.null (Text.strip l) ->
- parseBlocks rest
- | otherwise ->
- let (paraLines, afterPara) = List.span isParagraphLine lns
- in MdParagraph paraLines : parseBlocks afterPara
- where
- isListItem t =
- let stripped = Text.stripStart t
- in "- " `Text.isPrefixOf` stripped || "* " `Text.isPrefixOf` stripped
- stripListPrefix t =
- let stripped = Text.stripStart t
- in Text.drop 2 stripped
- isParagraphLine t =
- not (Text.null (Text.strip t))
- && not ("```" `Text.isPrefixOf` t)
- && not ("#" `Text.isPrefixOf` t)
- && not (isListItem t)
-
-renderBlocks :: (Monad m) => [MarkdownBlock] -> Lucid.HtmlT m ()
-renderBlocks = traverse_ renderBlock
-
-renderBlock :: (Monad m) => MarkdownBlock -> Lucid.HtmlT m ()
-renderBlock block = case block of
- MdHeader 1 txt -> Lucid.h2_ [Lucid.class_ "md-h1"] (renderInline txt)
- MdHeader 2 txt -> Lucid.h3_ [Lucid.class_ "md-h2"] (renderInline txt)
- MdHeader 3 txt -> Lucid.h4_ [Lucid.class_ "md-h3"] (renderInline txt)
- MdHeader _ txt -> Lucid.h4_ (renderInline txt)
- MdParagraph lns -> Lucid.p_ [Lucid.class_ "md-para"] (renderInline (Text.unlines lns))
- MdCodeBlock lns -> Lucid.pre_ [Lucid.class_ "md-code"] (Lucid.code_ (Lucid.toHtml (Text.unlines lns)))
- MdList items -> Lucid.ul_ [Lucid.class_ "md-list"] (traverse_ renderListItem items)
-
-renderListItem :: (Monad m) => Text -> Lucid.HtmlT m ()
-renderListItem txt = Lucid.li_ (renderInline txt)
-
--- | Render inline markdown (backtick code, bold, italic)
-renderInline :: (Monad m) => Text -> Lucid.HtmlT m ()
-renderInline txt = renderInlineParts (parseInline txt)
-
-data InlinePart = PlainText Text | InlineCode Text | BoldText Text
- deriving (Show, Eq)
-
-parseInline :: Text -> [InlinePart]
-parseInline t
- | Text.null t = []
- | otherwise = case Text.breakOn "`" t of
- (before, rest)
- | Text.null rest -> parseBold before
- | otherwise ->
- let afterTick = Text.drop 1 rest
- in case Text.breakOn "`" afterTick of
- (code, rest2)
- | Text.null rest2 ->
- parseBold before ++ [PlainText ("`" <> afterTick)]
- | otherwise ->
- parseBold before ++ [InlineCode code] ++ parseInline (Text.drop 1 rest2)
-
-parseBold :: Text -> [InlinePart]
-parseBold t
- | Text.null t = []
- | otherwise = case Text.breakOn "**" t of
- (before, rest)
- | Text.null rest -> [PlainText before | not (Text.null before)]
- | otherwise ->
- let afterBold = Text.drop 2 rest
- in case Text.breakOn "**" afterBold of
- (boldText, rest2)
- | Text.null rest2 ->
- [PlainText before | not (Text.null before)] ++ [PlainText ("**" <> afterBold)]
- | otherwise ->
- [PlainText before | not (Text.null before)]
- ++ [BoldText boldText]
- ++ parseBold (Text.drop 2 rest2)
-
-renderInlineParts :: (Monad m) => [InlinePart] -> Lucid.HtmlT m ()
-renderInlineParts = traverse_ renderInlinePart
-
-renderInlinePart :: (Monad m) => InlinePart -> Lucid.HtmlT m ()
-renderInlinePart part = case part of
- PlainText txt -> Lucid.toHtml txt
- InlineCode txt -> Lucid.code_ [Lucid.class_ "md-inline-code"] (Lucid.toHtml txt)
- BoldText txt -> Lucid.strong_ (Lucid.toHtml txt)
-
--- | Comment form for adding new comments
-commentForm :: (Monad m) => Text -> Lucid.HtmlT m ()
-commentForm tid =
- Lucid.form_
- [ Lucid.method_ "POST",
- Lucid.action_ ("/tasks/" <> tid <> "/comment"),
- Lucid.class_ "comment-form"
- ]
- <| do
- Lucid.textarea_
- [ Lucid.name_ "comment",
- Lucid.placeholder_ "Add a comment...",
- Lucid.rows_ "3",
- Lucid.class_ "comment-textarea"
- ]
- ""
- Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Post Comment"
-
--- | Render the LIVE toggle button
-renderLiveToggle :: (Monad m) => Lucid.HtmlT m ()
-renderLiveToggle =
- Lucid.button_
- [ Lucid.class_ "timeline-live-toggle",
- Lucid.id_ "live-toggle",
- Lucid.makeAttribute "onclick" "toggleLiveUpdates()",
- Lucid.title_ "Click to pause/resume live updates"
- ]
- " LIVE"
-
--- | Render the autoscroll toggle button
-renderAutoscrollToggle :: (Monad m) => Lucid.HtmlT m ()
-renderAutoscrollToggle =
- Lucid.button_
- [ Lucid.class_ "timeline-autoscroll-toggle",
- Lucid.id_ "autoscroll-toggle",
- Lucid.makeAttribute "onclick" "toggleAutoscroll()",
- Lucid.title_ "Toggle automatic scrolling to newest events"
- ]
- " ⬇ Auto-scroll"
-
--- | JavaScript for toggling live updates and autoscroll
-liveToggleJs :: Text
-liveToggleJs =
- Text.unlines
- [ "var liveUpdatesEnabled = true;",
- "var autoscrollEnabled = true;",
- "",
- "function toggleLiveUpdates() {",
- " liveUpdatesEnabled = !liveUpdatesEnabled;",
- " var btn = document.getElementById('live-toggle');",
- " if (btn) {",
- " btn.classList.toggle('timeline-live-paused', !liveUpdatesEnabled);",
- " }",
- "}",
- "",
- "function toggleAutoscroll() {",
- " autoscrollEnabled = !autoscrollEnabled;",
- " var btn = document.getElementById('autoscroll-toggle');",
- " if (btn) {",
- " btn.classList.toggle('timeline-autoscroll-disabled', !autoscrollEnabled);",
- " }",
- "}",
- "",
- "document.body.addEventListener('htmx:beforeRequest', function(evt) {",
- " var timeline = document.getElementById('unified-timeline');",
- " if (timeline && timeline.contains(evt.target) && !liveUpdatesEnabled) {",
- " evt.preventDefault();",
- " }",
- "});",
- "",
- "document.body.addEventListener('htmx:afterSettle', function(evt) {",
- " if (autoscrollEnabled) {",
- " var log = document.querySelector('.timeline-events');",
- " if (log) {",
- " log.scrollTop = log.scrollHeight;",
- " }",
- " }",
- "});"
- ]
-
--- | Aggregate cost and token data from events (Cost event type)
-aggregateCostMetrics :: [TaskCore.StoredEvent] -> (Int, Int)
-aggregateCostMetrics events =
- let costEvents = filter (\e -> TaskCore.storedEventType e == "Cost") events
- aggregateOne (totalCents, totalTokens) event =
- case Aeson.decode (LBS.fromStrict (str (TaskCore.storedEventContent event))) of
- Just (Aeson.Object obj) ->
- let cents = case KeyMap.lookup "cents" obj of
- Just (Aeson.Number n) -> floor n
- _ -> 0
- tokens = case KeyMap.lookup "tokens" obj of
- Just (Aeson.Number n) -> floor n
- _ -> 0
- in (totalCents + cents, totalTokens + tokens)
- _ -> (totalCents, totalTokens)
- in foldl' aggregateOne (0, 0) costEvents
-
--- | Format cost in dollars
-formatCostHeader :: Int -> Text
-formatCostHeader cents =
- let dollars = fromIntegral cents / 100.0 :: Double
- in "$" <> Text.pack (showFFloat (Just 2) dollars "")
-
--- | Format tokens with K/M suffixes
-formatTokensHeader :: Int -> Text
-formatTokensHeader t
- | t < 1000 = tshow t
- | t < 1000000 = Text.pack (showFFloat (Just 1) (fromIntegral t / 1000.0 :: Double) "") <> "K"
- | otherwise = Text.pack (showFFloat (Just 2) (fromIntegral t / 1000000.0 :: Double) "") <> "M"
-
--- | Unified timeline view combining comments, status changes, and agent events
-renderUnifiedTimeline :: (Monad m) => Text -> [TaskCore.Comment] -> [TaskCore.StoredEvent] -> TaskCore.Status -> UTCTime -> Lucid.HtmlT m ()
-renderUnifiedTimeline tid legacyComments events status now = do
- let isInProgress = status == TaskCore.InProgress
- pollAttrs =
- if isInProgress
- then
- [ Lucid.makeAttribute "hx-get" ("/partials/task/" <> tid <> "/events"),
- Lucid.makeAttribute "hx-trigger" "every 3s",
- Lucid.makeAttribute "hx-swap" "innerHTML",
- Lucid.makeAttribute "hx-on::before-request" "var log = this.querySelector('.timeline-events'); if(log) this.dataset.scroll = log.scrollTop",
- Lucid.makeAttribute "hx-on::after-swap" "var log = this.querySelector('.timeline-events'); if(log && this.dataset.scroll) log.scrollTop = this.dataset.scroll"
- ]
- else []
- -- Count non-Cost events for the display
- nonCostEvents = filter (\e -> TaskCore.storedEventType e /= "Cost") events
- eventCount = length nonCostEvents + length legacyComments
- (totalCents, totalTokens) = aggregateCostMetrics events
- Lucid.div_ ([Lucid.class_ "unified-timeline-section", Lucid.id_ "unified-timeline"] <> pollAttrs) <| do
- Lucid.h3_ <| do
- Lucid.toHtml ("Timeline (" <> tshow eventCount <> ")")
- when (totalCents > 0 || totalTokens > 0) <| do
- Lucid.span_ [Lucid.class_ "timeline-cost-summary"] <| do
- metaSep
- when (totalCents > 0) <| Lucid.toHtml (formatCostHeader totalCents)
- when (totalCents > 0 && totalTokens > 0) <| metaSep
- when (totalTokens > 0) <| Lucid.toHtml (formatTokensHeader totalTokens <> " tokens")
- when isInProgress <| do
- renderLiveToggle
- renderAutoscrollToggle
-
- if null nonCostEvents && null legacyComments
- then Lucid.p_ [Lucid.class_ "empty-msg"] "No activity yet."
- else do
- Lucid.div_ [Lucid.class_ "timeline-events"] <| do
- traverse_ (renderTimelineEvent now) nonCostEvents
- when isInProgress <| timelineScrollScript
-
- commentForm tid
-
--- | Render a single timeline event with icon, actor label, and timestamp
-renderTimelineEvent :: (Monad m) => UTCTime -> TaskCore.StoredEvent -> Lucid.HtmlT m ()
-renderTimelineEvent now event =
- let eventType = TaskCore.storedEventType event
- content = TaskCore.storedEventContent event
- timestamp = TaskCore.storedEventTimestamp event
- actor = TaskCore.storedEventActor event
- eventId = TaskCore.storedEventId event
- (icon, label) = eventTypeIconAndLabel eventType
- in Lucid.div_
- [ Lucid.class_ ("timeline-event timeline-event-" <> eventType),
- Lucid.makeAttribute "data-event-id" (tshow eventId)
- ]
- <| do
- case eventType of
- "comment" -> renderCommentTimelineEvent content actor timestamp now
- "status_change" -> renderStatusChangeEvent content actor timestamp now
- "claim" -> renderActivityEvent icon label content actor timestamp now
- "running" -> renderActivityEvent icon label content actor timestamp now
- "reviewing" -> renderActivityEvent icon label content actor timestamp now
- "retrying" -> renderActivityEvent icon label content actor timestamp now
- "complete" -> renderActivityEvent icon label content actor timestamp now
- "error" -> renderErrorTimelineEvent content actor timestamp now
- "Assistant" -> renderAssistantTimelineEvent content actor timestamp now
- "ToolCall" -> renderToolCallTimelineEvent content actor timestamp now
- "ToolResult" -> renderToolResultTimelineEvent content actor timestamp now
- "Cost" -> pure () -- Cost events are hidden; cost data shown in timeline header
- "Checkpoint" -> renderCheckpointEvent content actor timestamp now
- "Guardrail" -> renderGuardrailEvent content actor timestamp now
- _ -> renderGenericEvent eventType content actor timestamp now
-
--- | Get icon and label for event type
-eventTypeIconAndLabel :: Text -> (Text, Text)
-eventTypeIconAndLabel "comment" = ("💬", "Comment")
-eventTypeIconAndLabel "status_change" = ("🔄", "Status")
-eventTypeIconAndLabel "claim" = ("🤖", "Claimed")
-eventTypeIconAndLabel "running" = ("▶️", "Running")
-eventTypeIconAndLabel "reviewing" = ("👀", "Reviewing")
-eventTypeIconAndLabel "retrying" = ("🔁", "Retrying")
-eventTypeIconAndLabel "complete" = ("✅", "Complete")
-eventTypeIconAndLabel "error" = ("❌", "Error")
-eventTypeIconAndLabel "Assistant" = ("💭", "Thought")
-eventTypeIconAndLabel "ToolCall" = ("🔧", "Tool")
-eventTypeIconAndLabel "ToolResult" = ("📄", "Result")
-eventTypeIconAndLabel "Cost" = ("💰", "Cost")
-eventTypeIconAndLabel "Checkpoint" = ("📍", "Checkpoint")
-eventTypeIconAndLabel "Guardrail" = ("⚠️", "Guardrail")
-eventTypeIconAndLabel t = ("📝", t)
-
--- | Render actor label
-renderActorLabel :: (Monad m) => TaskCore.CommentAuthor -> Lucid.HtmlT m ()
-renderActorLabel actor =
- let (cls, label) :: (Text, Text) = case actor of
- TaskCore.Human -> ("actor-human", "human")
- TaskCore.Junior -> ("actor-junior", "junior")
- TaskCore.System -> ("actor-system", "system")
- in Lucid.span_ [Lucid.class_ ("actor-label " <> cls)] (Lucid.toHtml ("[" <> label <> "]"))
-
--- | Render comment event
-renderCommentTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
-renderCommentTimelineEvent content actor timestamp now =
- Lucid.div_ [Lucid.class_ "timeline-comment"] <| do
- Lucid.div_ [Lucid.class_ "event-header"] <| do
- Lucid.span_ [Lucid.class_ "event-icon"] "💬"
- renderActorLabel actor
- renderRelativeTimestamp now timestamp
- Lucid.div_ [Lucid.class_ "event-content comment-bubble markdown-content"] <| do
- renderMarkdown content
-
--- | Render status change event
-renderStatusChangeEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
-renderStatusChangeEvent content actor timestamp now =
- Lucid.div_ [Lucid.class_ "timeline-status-change"] <| do
- Lucid.span_ [Lucid.class_ "event-icon"] "🔄"
- renderActorLabel actor
- Lucid.span_ [Lucid.class_ "status-change-text"] (Lucid.toHtml (parseStatusChange content))
- renderRelativeTimestamp now timestamp
-
--- | Parse status change JSON
-parseStatusChange :: Text -> Text
-parseStatusChange content =
- case Aeson.decode (LBS.fromStrict (str content)) of
- Just (Aeson.Object obj) ->
- let fromStatus = case KeyMap.lookup "from" obj of
- Just (Aeson.String s) -> s
- _ -> "?"
- toStatus = case KeyMap.lookup "to" obj of
- Just (Aeson.String s) -> s
- _ -> "?"
- in fromStatus <> " → " <> toStatus
- _ -> content
-
--- | Render activity event (claim, running, etc.)
-renderActivityEvent :: (Monad m) => Text -> Text -> Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
-renderActivityEvent icon label content actor timestamp now =
- Lucid.div_ [Lucid.class_ "timeline-activity"] <| do
- Lucid.span_ [Lucid.class_ "event-icon"] (Lucid.toHtml icon)
- Lucid.span_ [Lucid.class_ "event-label"] (Lucid.toHtml label)
- renderActorLabel actor
- unless (Text.null content) <| Lucid.span_ [Lucid.class_ "activity-detail"] (Lucid.toHtml content)
- renderRelativeTimestamp now timestamp
-
--- | Render error event
-renderErrorTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
-renderErrorTimelineEvent content actor timestamp now =
- Lucid.div_ [Lucid.class_ "timeline-error"] <| do
- Lucid.div_ [Lucid.class_ "event-header"] <| do
- Lucid.span_ [Lucid.class_ "event-icon"] "❌"
- Lucid.span_ [Lucid.class_ "event-label"] "Error"
- renderActorLabel actor
- renderRelativeTimestamp now timestamp
- Lucid.div_ [Lucid.class_ "event-content error-message"] (Lucid.toHtml content)
-
--- | Render assistant thought event
-renderAssistantTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
-renderAssistantTimelineEvent content _actor timestamp now =
- Lucid.div_ [Lucid.class_ "timeline-thought"] <| do
- Lucid.div_ [Lucid.class_ "event-header"] <| do
- Lucid.span_ [Lucid.class_ "event-icon"] "💭"
- Lucid.span_ [Lucid.class_ "event-label"] "Thought"
- renderActorLabel TaskCore.Junior
- renderRelativeTimestamp now timestamp
- Lucid.div_ [Lucid.class_ "event-content thought-bubble markdown-content"] <| do
- let truncated = Text.take 2000 content
- isTruncated = Text.length content > 2000
- renderMarkdown truncated
- when isTruncated <| Lucid.span_ [Lucid.class_ "event-truncated"] "..."
-
--- | Render tool call event
-renderToolCallTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
-renderToolCallTimelineEvent content _actor timestamp now =
- let (toolName, args) = parseToolCallContent content
- summary = formatToolCallSummary toolName args
- in Lucid.details_ [Lucid.class_ "timeline-tool-call"] <| do
- Lucid.summary_ <| do
- Lucid.span_ [Lucid.class_ "event-icon"] "🔧"
- Lucid.span_ [Lucid.class_ "tool-name"] (Lucid.toHtml toolName)
- Lucid.span_ [Lucid.class_ "tool-summary"] (Lucid.toHtml summary)
- renderRelativeTimestamp now timestamp
- Lucid.div_ [Lucid.class_ "event-content tool-args"] <| do
- renderCollapsibleOutput args
-
--- | Render tool result event (collapsed by default)
-renderToolResultTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
-renderToolResultTimelineEvent content _actor timestamp now =
- let lineCount = length (Text.lines content)
- in Lucid.details_ [Lucid.class_ "timeline-tool-result"] <| do
- Lucid.summary_ <| do
- Lucid.span_ [Lucid.class_ "event-icon"] "📄"
- Lucid.span_ [Lucid.class_ "event-label"] "Result"
- when (lineCount > 1)
- <| Lucid.span_ [Lucid.class_ "line-count"] (Lucid.toHtml (tshow lineCount <> " lines"))
- renderRelativeTimestamp now timestamp
- Lucid.pre_ [Lucid.class_ "event-content tool-output"] (renderDecodedToolResult content)
-
--- | Render checkpoint event
-renderCheckpointEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
-renderCheckpointEvent content actor timestamp now =
- Lucid.div_ [Lucid.class_ "timeline-checkpoint"] <| do
- Lucid.div_ [Lucid.class_ "event-header"] <| do
- Lucid.span_ [Lucid.class_ "event-icon"] "📍"
- Lucid.span_ [Lucid.class_ "event-label"] "Checkpoint"
- renderActorLabel actor
- renderRelativeTimestamp now timestamp
- Lucid.div_ [Lucid.class_ "event-content checkpoint-content"] (Lucid.toHtml content)
-
--- | Render guardrail event
-renderGuardrailEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
-renderGuardrailEvent content actor timestamp now =
- Lucid.div_ [Lucid.class_ "timeline-guardrail"] <| do
- Lucid.div_ [Lucid.class_ "event-header"] <| do
- Lucid.span_ [Lucid.class_ "event-icon"] "⚠️"
- Lucid.span_ [Lucid.class_ "event-label"] "Guardrail"
- renderActorLabel actor
- renderRelativeTimestamp now timestamp
- Lucid.div_ [Lucid.class_ "event-content guardrail-content"] (Lucid.toHtml content)
-
--- | Render generic/unknown event
-renderGenericEvent :: (Monad m) => Text -> Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
-renderGenericEvent eventType content actor timestamp now =
- Lucid.div_ [Lucid.class_ "timeline-generic"] <| do
- Lucid.div_ [Lucid.class_ "event-header"] <| do
- Lucid.span_ [Lucid.class_ "event-icon"] "📝"
- Lucid.span_ [Lucid.class_ "event-label"] (Lucid.toHtml eventType)
- renderActorLabel actor
- renderRelativeTimestamp now timestamp
- unless (Text.null content) <| Lucid.div_ [Lucid.class_ "event-content"] (Lucid.toHtml content)
-
-parseToolCallContent :: Text -> (Text, Text)
-parseToolCallContent content =
- case Text.breakOn ":" content of
- (name, rest)
- | Text.null rest -> (content, "")
- | otherwise -> (Text.strip name, Text.strip (Text.drop 1 rest))
-
-formatToolCallSummary :: Text -> Text -> Text
-formatToolCallSummary toolName argsJson =
- case Aeson.decode (LBS.fromStrict (str argsJson)) of
- Just (Aeson.Object obj) ->
- let keyArg = case toolName of
- "run_bash" -> KeyMap.lookup "command" obj
- "read_file" -> KeyMap.lookup "path" obj
- "edit_file" -> KeyMap.lookup "path" obj
- "write_file" -> KeyMap.lookup "path" obj
- "search_codebase" -> KeyMap.lookup "pattern" obj
- "glob_files" -> KeyMap.lookup "pattern" obj
- "list_directory" -> KeyMap.lookup "path" obj
- _ -> Nothing
- in case keyArg of
- Just (Aeson.String s) -> "`" <> Text.take 100 s <> "`"
- _ -> Text.take 80 argsJson
- _ -> Text.take 80 argsJson
-
-renderCollapsibleOutput :: (Monad m) => Text -> Lucid.HtmlT m ()
-renderCollapsibleOutput content =
- let lineCount = length (Text.lines content)
- in if lineCount > 20
- then
- Lucid.details_ [Lucid.class_ "output-collapsible"] <| do
- Lucid.summary_ (Lucid.toHtml (tshow lineCount <> " lines"))
- Lucid.pre_ [Lucid.class_ "tool-output-pre"] (Lucid.toHtml content)
- else Lucid.pre_ [Lucid.class_ "tool-output-pre"] (Lucid.toHtml content)
-
--- | Decode JSON tool result and render in a user-friendly way
-renderDecodedToolResult :: (Monad m) => Text -> Lucid.HtmlT m ()
-renderDecodedToolResult content =
- case Aeson.decode (LBS.fromStrict (str content)) of
- Just (Aeson.Object obj) ->
- case KeyMap.lookup "output" obj of
- Just (Aeson.String output) -> Lucid.toHtml output
- _ -> Lucid.toHtml content -- Fallback to raw if no output field
- _ -> Lucid.toHtml content -- Fallback to raw if not JSON
-
-timelineScrollScript :: (Monad m) => Lucid.HtmlT m ()
-timelineScrollScript =
- Lucid.script_
- [ Lucid.type_ "text/javascript"
- ]
- ( Text.unlines
- [ "(function() {",
- " var log = document.querySelector('.timeline-events');",
- " if (log) {",
- " var isNearBottom = log.scrollHeight - log.scrollTop - log.clientHeight < 100;",
- " if (isNearBottom) {",
- " log.scrollTop = log.scrollHeight;",
- " }",
- " }",
- "})();"
- ]
- )
-
-instance Lucid.ToHtml AgentEventsPartial where
- toHtmlRaw = Lucid.toHtml
- toHtml (AgentEventsPartial events isInProgress now) = do
- Lucid.h3_ <| do
- Lucid.toHtml ("Timeline (" <> tshow (length events) <> ")")
- when isInProgress <| Lucid.span_ [Lucid.class_ "timeline-live"] " LIVE"
- if null events
- then Lucid.p_ [Lucid.class_ "empty-msg"] "No activity yet."
- else do
- Lucid.div_ [Lucid.class_ "timeline-events"] <| do
- traverse_ (renderTimelineEvent now) events
- timelineScrollScript
-
--- | Stream agent events as SSE
-streamAgentEvents :: Text -> Text -> IO (SourceIO ByteString)
-streamAgentEvents tid sid = do
- -- Get existing events first
- existingEvents <- TaskCore.getEventsForSession sid
- let lastId = if null existingEvents then 0 else maximum (map TaskCore.storedEventId existingEvents)
-
- -- Convert existing events to SSE format
- let existingSSE = map eventToSSE existingEvents
-
- -- Create a streaming source that sends existing events, then polls for new ones
- pure <| Source.fromStepT <| streamEventsStep tid sid lastId existingSSE True
-
--- | Step function for streaming events
-streamEventsStep :: Text -> Text -> Int -> [ByteString] -> Bool -> Source.StepT IO ByteString
-streamEventsStep tid sid lastId buffer sendExisting = case (sendExisting, buffer) of
- -- Send buffered existing events first
- (True, b : bs) -> Source.Yield b (streamEventsStep tid sid lastId bs True)
- (True, []) -> streamEventsStep tid sid lastId [] False
- -- Poll for new events
- (False, _) ->
- Source.Effect <| do
- -- Check if task is still in progress
- tasks <- TaskCore.loadTasks
- let isComplete = case TaskCore.findTask tid tasks of
- Nothing -> True
- Just task -> TaskCore.taskStatus task /= TaskCore.InProgress
-
- if isComplete
- then do
- -- Send complete event and stop
- let completeSSE = formatSSE "complete" "{}"
- pure <| Source.Yield completeSSE Source.Stop
- else do
- -- Poll for new events
- Concurrent.threadDelay 500000 -- 500ms
- newEvents <- TaskCore.getEventsSince sid lastId
- if null newEvents
- then pure <| streamEventsStep tid sid lastId [] False
- else do
- let newLastId = maximum (map TaskCore.storedEventId newEvents)
- let newSSE = map eventToSSE newEvents
- case newSSE of
- (e : es) -> pure <| Source.Yield e (streamEventsStep tid sid newLastId es False)
- [] -> pure <| streamEventsStep tid sid newLastId [] False
-
--- | Convert a StoredEvent to SSE format
-eventToSSE :: TaskCore.StoredEvent -> ByteString
-eventToSSE event =
- let eventType = Text.toLower (TaskCore.storedEventType event)
- content = TaskCore.storedEventContent event
- jsonData = case eventType of
- "assistant" -> Aeson.object ["content" Aeson..= content]
- "toolcall" ->
- let (tool, args) = parseToolCallContent content
- in Aeson.object ["tool" Aeson..= tool, "args" Aeson..= Aeson.object ["data" Aeson..= args]]
- "toolresult" ->
- Aeson.object ["tool" Aeson..= ("unknown" :: Text), "success" Aeson..= True, "output" Aeson..= content]
- "cost" -> Aeson.object ["cost" Aeson..= content]
- "error" -> Aeson.object ["error" Aeson..= content]
- "complete" -> Aeson.object []
- _ -> Aeson.object ["content" Aeson..= content]
- in formatSSE eventType (str (Aeson.encode jsonData))
-
--- | Format an SSE message
-formatSSE :: Text -> ByteString -> ByteString
-formatSSE eventType jsonData =
- str
- <| "event: "
- <> eventType
- <> "\n"
- <> "data: "
- <> str jsonData
- <> "\n\n"
-
-api :: Proxy API
-api = Proxy
-
-server :: Server API
-server =
- homeHandler
- :<|> styleHandler
- :<|> readyQueueHandler
- :<|> blockedHandler
- :<|> interventionHandler
- :<|> statsHandler
- :<|> taskListHandler
- :<|> kbHandler
- :<|> factCreateHandler
- :<|> factDetailHandler
- :<|> factEditHandler
- :<|> factDeleteHandler
- :<|> epicsHandler
- :<|> taskDetailHandler
- :<|> taskStatusHandler
- :<|> taskPriorityHandler
- :<|> descriptionViewHandler
- :<|> descriptionEditHandler
- :<|> descriptionPostHandler
- :<|> taskNotesHandler
- :<|> taskCommentHandler
- :<|> taskReviewHandler
- :<|> taskDiffHandler
- :<|> taskAcceptHandler
- :<|> taskRejectHandler
- :<|> taskResetRetriesHandler
- :<|> recentActivityNewHandler
- :<|> recentActivityMoreHandler
- :<|> readyCountHandler
- :<|> taskListPartialHandler
- :<|> taskMetricsPartialHandler
- :<|> agentEventsPartialHandler
- :<|> taskEventsStreamHandler
- where
- styleHandler :: Servant.Handler LazyText.Text
- styleHandler = pure Style.css
-
- homeHandler :: Maybe Text -> Servant.Handler HomePage
- homeHandler maybeRangeText = do
- now <- liftIO getCurrentTime
- let range = parseTimeRange maybeRangeText
- maybeStart = getTimeRangeStart range now
- allTasks <- liftIO TaskCore.loadTasks
- 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 filteredTasks > 5
- pure (HomePage stats readyTasks recentTasks hasMoreRecent globalMetrics range now)
-
- readyQueueHandler :: Maybe Text -> Servant.Handler ReadyQueuePage
- readyQueueHandler maybeSortText = do
- now <- liftIO getCurrentTime
- readyTasks <- liftIO TaskCore.getReadyTasks
- let sortOrder = parseSortOrder maybeSortText
- sortedTasks = sortTasks sortOrder readyTasks
- pure (ReadyQueuePage sortedTasks sortOrder now)
-
- blockedHandler :: Maybe Text -> Servant.Handler BlockedPage
- blockedHandler maybeSortText = do
- now <- liftIO getCurrentTime
- blockedTasks <- liftIO TaskCore.getBlockedTasks
- allTasks <- liftIO TaskCore.loadTasks
- let sortOrder = parseSortOrder maybeSortText
- tasksWithImpact = [(t, TaskCore.getBlockingImpact allTasks t) | t <- blockedTasks]
- sorted = List.sortBy (comparing (Down <. snd)) tasksWithImpact
- pure (BlockedPage sorted sortOrder now)
-
- interventionHandler :: Maybe Text -> Servant.Handler InterventionPage
- interventionHandler maybeSortText = do
- now <- liftIO getCurrentTime
- actionItems <- liftIO TaskCore.getHumanActionItems
- let sortOrder = parseSortOrder maybeSortText
- pure (InterventionPage actionItems sortOrder now)
-
- statsHandler :: Maybe Text -> Servant.Handler StatsPage
- statsHandler maybeEpic = do
- let epicId = emptyToNothing maybeEpic
- stats <- liftIO <| TaskCore.getTaskStats epicId
- pure (StatsPage stats epicId)
-
- taskListHandler :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Servant.Handler TaskListPage
- taskListHandler maybeStatusText maybePriorityText maybeNamespace maybeTypeText maybeSortText = 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
- sortOrder = parseSortOrder maybeSortText
- filteredTasks = sortTasks sortOrder (applyFilters filters allTasks)
- pure (TaskListPage filteredTasks filters sortOrder now)
-
- kbHandler :: Servant.Handler KBPage
- kbHandler = do
- facts <- liftIO Fact.getAllFacts
- pure (KBPage facts)
-
- factCreateHandler :: FactCreateForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
- factCreateHandler (FactCreateForm project content filesText confText) = do
- let files = filter (not <. Text.null) (Text.splitOn "," (Text.strip filesText))
- confidence = fromMaybe 0.8 (readMaybe (Text.unpack confText))
- fid <- liftIO (Fact.createFact project content files Nothing confidence)
- pure <| addHeader ("/kb/" <> tshow fid) NoContent
-
- 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 now)
-
- factEditHandler :: Int -> FactEditForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
- factEditHandler fid (FactEditForm content filesText confText) = do
- let files = filter (not <. Text.null) (Text.splitOn "," (Text.strip filesText))
- confidence = fromMaybe 0.8 (readMaybe (Text.unpack confText))
- liftIO (Fact.updateFact fid content files confidence)
- pure <| addHeader ("/kb/" <> tshow fid) NoContent
-
- factDeleteHandler :: Int -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
- factDeleteHandler fid = do
- liftIO (Fact.deleteFact fid)
- pure <| addHeader "/kb" NoContent
-
- epicsHandler :: Maybe Text -> Servant.Handler EpicsPage
- epicsHandler maybeSortText = do
- allTasks <- liftIO TaskCore.loadTasks
- let epicTasks = filter (\t -> TaskCore.taskType t == TaskCore.Epic) allTasks
- sortOrder = parseSortOrder maybeSortText
- sortedEpics = sortTasks sortOrder epicTasks
- pure (EpicsPage sortedEpics allTasks sortOrder)
-
- parseStatus :: Text -> Maybe TaskCore.Status
- parseStatus = readMaybe <. Text.unpack
-
- parsePriority :: Text -> Maybe TaskCore.Priority
- parsePriority = readMaybe <. Text.unpack
-
- parseTaskType :: Text -> Maybe TaskCore.TaskType
- parseTaskType = readMaybe <. Text.unpack
-
- emptyToNothing :: Maybe Text -> Maybe Text
- emptyToNothing (Just t) | Text.null (Text.strip t) = Nothing
- emptyToNothing x = x
-
- applyFilters :: TaskFilters -> [TaskCore.Task] -> [TaskCore.Task]
- applyFilters filters = filter matchesAllFilters
- where
- matchesAllFilters task =
- matchesStatus task
- && matchesPriority task
- && matchesNamespace task
- && matchesType task
-
- matchesStatus task = case filterStatus filters of
- Nothing -> True
- Just s -> TaskCore.taskStatus task == s
-
- matchesPriority task = case filterPriority filters of
- Nothing -> True
- Just p -> TaskCore.taskPriority task == p
-
- matchesNamespace task = case filterNamespace filters of
- Nothing -> True
- Just ns -> case TaskCore.taskNamespace task of
- Nothing -> False
- Just taskNs -> ns `Text.isPrefixOf` taskNs
-
- matchesType task = case filterType filters of
- Nothing -> True
- Just t -> TaskCore.taskType task == t
-
- 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)
- Just task -> do
- activities <- liftIO (TaskCore.getActivitiesForTask tid)
- retryCtx <- liftIO (TaskCore.getRetryContext tid)
- commits <- liftIO (getCommitsForTask tid)
- aggMetrics <-
- if TaskCore.taskType task == TaskCore.Epic
- then Just </ liftIO (TaskCore.getAggregatedMetrics tid)
- else pure Nothing
- agentEvents <- liftIO (TaskCore.getAllEventsForTask tid)
- pure (TaskDetailFound task tasks activities retryCtx commits aggMetrics agentEvents now)
-
- taskStatusHandler :: Text -> StatusForm -> Servant.Handler StatusBadgePartial
- taskStatusHandler tid (StatusForm newStatus) = do
- liftIO <| TaskCore.updateTaskStatusWithActor tid newStatus [] TaskCore.Human
- pure (StatusBadgePartial newStatus tid)
-
- taskPriorityHandler :: Text -> PriorityForm -> Servant.Handler PriorityBadgePartial
- taskPriorityHandler tid (PriorityForm newPriority) = do
- _ <- liftIO <| TaskCore.editTask tid (\t -> t {TaskCore.taskPriority = newPriority})
- pure (PriorityBadgePartial newPriority tid)
-
- descriptionViewHandler :: Text -> Servant.Handler DescriptionViewPartial
- descriptionViewHandler tid = do
- tasks <- liftIO TaskCore.loadTasks
- case TaskCore.findTask tid tasks of
- Nothing -> throwError err404
- Just task -> pure (DescriptionViewPartial tid (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic))
-
- descriptionEditHandler :: Text -> Servant.Handler DescriptionEditPartial
- descriptionEditHandler tid = do
- tasks <- liftIO TaskCore.loadTasks
- case TaskCore.findTask tid tasks of
- Nothing -> throwError err404
- Just task -> pure (DescriptionEditPartial tid (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic))
-
- descriptionPostHandler :: Text -> DescriptionForm -> Servant.Handler DescriptionViewPartial
- descriptionPostHandler tid (DescriptionForm desc) = do
- let descText = Text.strip desc
- _ <- liftIO <| TaskCore.editTask tid (\t -> t {TaskCore.taskDescription = descText})
- tasks <- liftIO TaskCore.loadTasks
- case TaskCore.findTask tid tasks of
- Nothing -> throwError err404
- Just task -> pure (DescriptionViewPartial tid (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic))
-
- taskNotesHandler :: Text -> NotesForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
- taskNotesHandler tid (NotesForm notes) = do
- liftIO <| TaskCore.updateRetryNotes tid notes
- pure <| addHeader ("/tasks/" <> tid) NoContent
-
- taskCommentHandler :: Text -> CommentForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
- taskCommentHandler tid (CommentForm commentText) = do
- _ <- liftIO (TaskCore.addComment tid commentText TaskCore.Human)
- pure <| addHeader ("/tasks/" <> tid) NoContent
-
- taskReviewHandler :: Text -> Servant.Handler TaskReviewPage
- taskReviewHandler tid = do
- tasks <- liftIO TaskCore.loadTasks
- case TaskCore.findTask tid tasks of
- Nothing -> pure (ReviewPageNotFound tid)
- Just task -> do
- reviewInfo <- liftIO <| getReviewInfo tid
- pure (ReviewPageFound task reviewInfo)
-
- taskDiffHandler :: Text -> Text -> Servant.Handler TaskDiffPage
- taskDiffHandler tid commitSha = do
- diffOutput <- liftIO <| getDiffForCommit commitSha
- case diffOutput of
- Nothing -> pure (DiffPageNotFound tid commitSha)
- Just output -> pure (DiffPageFound tid commitSha output)
-
- taskAcceptHandler :: Text -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
- taskAcceptHandler tid = do
- liftIO <| do
- TaskCore.clearRetryContext tid
- TaskCore.updateTaskStatusWithActor tid TaskCore.Done [] TaskCore.Human
- pure <| addHeader ("/tasks/" <> tid) NoContent
-
- taskRejectHandler :: Text -> RejectForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
- taskRejectHandler tid (RejectForm maybeNotes) = do
- liftIO <| do
- maybeCommit <- findCommitForTask tid
- let commitSha = fromMaybe "" maybeCommit
- maybeCtx <- TaskCore.getRetryContext tid
- let attempt = maybe 1 (\ctx -> TaskCore.retryAttempt ctx + 1) maybeCtx
- let currentReason = "attempt " <> tshow attempt <> ": rejected: " <> fromMaybe "(no notes)" maybeNotes
- let accumulatedReason = case maybeCtx of
- Nothing -> currentReason
- Just ctx -> TaskCore.retryReason ctx <> "\n" <> currentReason
- TaskCore.setRetryContext
- TaskCore.RetryContext
- { TaskCore.retryTaskId = tid,
- TaskCore.retryOriginalCommit = commitSha,
- TaskCore.retryConflictFiles = [],
- TaskCore.retryAttempt = attempt,
- TaskCore.retryReason = accumulatedReason,
- TaskCore.retryNotes = maybeCtx +> TaskCore.retryNotes
- }
- TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.Human
- pure <| addHeader ("/tasks/" <> tid) NoContent
-
- taskResetRetriesHandler :: Text -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
- taskResetRetriesHandler tid = do
- liftIO <| do
- TaskCore.clearRetryContext tid
- TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.Human
- pure <| addHeader ("/tasks/" <> tid) NoContent
-
- recentActivityNewHandler :: Maybe Int -> Servant.Handler RecentActivityNewPartial
- recentActivityNewHandler maybeSince = do
- allTasks <- liftIO TaskCore.loadTasks
- let sinceTime = maybe (posixSecondsToUTCTime 0) (posixSecondsToUTCTime <. fromIntegral) maybeSince
- sortedTasks = List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) allTasks
- newTasks = filter (\t -> TaskCore.taskUpdatedAt t > sinceTime) sortedTasks
- newestTs = maybe maybeSince (Just <. taskToUnixTs) (head newTasks)
- pure (RecentActivityNewPartial newTasks newestTs)
-
- recentActivityMoreHandler :: Maybe Int -> Servant.Handler RecentActivityMorePartial
- recentActivityMoreHandler maybeOffset = do
- allTasks <- liftIO TaskCore.loadTasks
- let offset = fromMaybe 0 maybeOffset
- pageSize = 5
- sortedTasks = List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) allTasks
- pageTasks = take pageSize <| drop offset sortedTasks
- hasMore = length sortedTasks > offset + pageSize
- nextOffset = offset + pageSize
- pure (RecentActivityMorePartial pageTasks nextOffset hasMore)
-
- readyCountHandler :: Servant.Handler ReadyCountPartial
- readyCountHandler = do
- readyTasks <- liftIO TaskCore.getReadyTasks
- pure (ReadyCountPartial (length readyTasks))
-
- taskListPartialHandler :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Servant.Handler TaskListPartial
- taskListPartialHandler maybeStatusText maybePriorityText maybeNamespace maybeTypeText maybeSortText = do
- allTasks <- liftIO TaskCore.loadTasks
- let maybeStatus = parseStatus =<< emptyToNothing maybeStatusText
- maybePriority = parsePriority =<< emptyToNothing maybePriorityText
- maybeType = parseTaskType =<< emptyToNothing maybeTypeText
- filters = TaskFilters maybeStatus maybePriority (emptyToNothing maybeNamespace) maybeType
- sortOrder = parseSortOrder maybeSortText
- filteredTasks = sortTasks sortOrder (applyFilters filters allTasks)
- pure (TaskListPartial filteredTasks)
-
- 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 now)
-
- agentEventsPartialHandler :: Text -> Maybe Int -> Servant.Handler AgentEventsPartial
- agentEventsPartialHandler tid _maybeSince = do
- now <- liftIO getCurrentTime
- events <- liftIO (TaskCore.getAllEventsForTask tid)
- tasks <- liftIO TaskCore.loadTasks
- let isInProgress = case TaskCore.findTask tid tasks of
- Nothing -> False
- Just task -> TaskCore.taskStatus task == TaskCore.InProgress
- pure (AgentEventsPartial events isInProgress now)
-
- taskEventsStreamHandler :: Text -> Servant.Handler (SourceIO ByteString)
- taskEventsStreamHandler tid = do
- maybeSession <- liftIO (TaskCore.getLatestSessionForTask tid)
- case maybeSession of
- Nothing -> pure (Source.source [])
- Just sid -> liftIO (streamAgentEvents tid sid)
-
-taskToUnixTs :: TaskCore.Task -> Int
-taskToUnixTs t = ceiling (utcTimeToPOSIXSeconds (TaskCore.taskUpdatedAt t))
-
-getReviewInfo :: Text -> IO ReviewInfo
-getReviewInfo tid = do
- maybeCommit <- findCommitForTask tid
- case maybeCommit of
- Nothing -> pure ReviewNoCommit
- Just commitSha -> do
- conflictResult <- checkMergeConflict (Text.unpack commitSha)
- case conflictResult of
- Just conflictFiles -> pure (ReviewMergeConflict commitSha conflictFiles)
- Nothing -> do
- (_, diffOut, _) <-
- Process.readProcessWithExitCode
- "git"
- ["show", Text.unpack commitSha]
- ""
- pure (ReviewReady commitSha (Text.pack diffOut))
-
-getDiffForCommit :: Text -> IO (Maybe Text)
-getDiffForCommit commitSha = do
- (code, diffOut, _) <-
- Process.readProcessWithExitCode
- "git"
- ["show", Text.unpack commitSha]
- ""
- case code of
- Exit.ExitSuccess -> pure (Just (Text.pack diffOut))
- Exit.ExitFailure _ -> pure Nothing
-
-findCommitForTask :: Text -> IO (Maybe Text)
-findCommitForTask tid = do
- let grepArg = "--grep=" <> Text.unpack tid
- (code, shaOut, _) <-
- Process.readProcessWithExitCode
- "git"
- ["log", "--pretty=format:%H", "-n", "1", grepArg]
- ""
- if code /= Exit.ExitSuccess || null shaOut
- then pure Nothing
- else case List.lines shaOut of
- (x : _) -> pure (Just (Text.pack x))
- [] -> pure Nothing
-
-getCommitsForTask :: Text -> IO [GitCommit]
-getCommitsForTask tid = do
- let grepArg = "--grep=Task-Id: " <> Text.unpack tid
- (code, out, _) <-
- Process.readProcessWithExitCode
- "git"
- ["log", "--pretty=format:%H|%h|%s|%an|%ar", grepArg]
- ""
- if code /= Exit.ExitSuccess || null out
- then pure []
- else do
- let commitLines = filter (not <. null) (List.lines out)
- traverse parseCommitLine commitLines
- where
- parseCommitLine :: String -> IO GitCommit
- parseCommitLine line =
- case Text.splitOn "|" (Text.pack line) of
- [sha, shortSha, summary, author, relDate] -> do
- filesCount <- getFilesChangedCount (Text.unpack sha)
- pure
- GitCommit
- { commitHash = sha,
- commitShortHash = shortSha,
- commitSummary = summary,
- commitAuthor = author,
- commitRelativeDate = relDate,
- commitFilesChanged = filesCount
- }
- _ ->
- pure
- GitCommit
- { commitHash = Text.pack line,
- commitShortHash = Text.take 7 (Text.pack line),
- commitSummary = "(parse error)",
- commitAuthor = "",
- commitRelativeDate = "",
- commitFilesChanged = 0
- }
-
- getFilesChangedCount :: String -> IO Int
- getFilesChangedCount sha = do
- (code', out', _) <-
- Process.readProcessWithExitCode
- "git"
- ["show", "--stat", "--format=", sha]
- ""
- pure
- <| if code' /= Exit.ExitSuccess
- then 0
- else
- let statLines = filter (not <. null) (List.lines out')
- in max 0 (length statLines - 1)
-
-checkMergeConflict :: String -> IO (Maybe [Text])
-checkMergeConflict commitSha = do
- (_, origHead, _) <- Process.readProcessWithExitCode "git" ["rev-parse", "HEAD"] ""
-
- (cpCode, _, cpErr) <-
- Process.readProcessWithExitCode
- "git"
- ["cherry-pick", "--no-commit", commitSha]
- ""
-
- _ <- Process.readProcessWithExitCode "git" ["cherry-pick", "--abort"] ""
- _ <- Process.readProcessWithExitCode "git" ["reset", "--hard", List.head (List.lines origHead)] ""
-
- case cpCode of
- Exit.ExitSuccess -> pure Nothing
- Exit.ExitFailure _ -> do
- let errLines = Text.lines (Text.pack cpErr)
- conflictLines = filter (Text.isPrefixOf "CONFLICT") errLines
- files = mapMaybe extractConflictFile conflictLines
- pure (Just (if null files then ["(unknown files)"] else files))
-
-extractConflictFile :: Text -> Maybe Text
-extractConflictFile line =
- case Text.breakOn "Merge conflict in " line of
- (_, rest)
- | not (Text.null rest) -> Just (Text.strip (Text.drop 18 rest))
- _ -> case Text.breakOn "in " line of
- (_, rest)
- | not (Text.null rest) -> Just (Text.strip (Text.drop 3 rest))
- _ -> Nothing
-
-app :: Application
-app = serve api server
-
run :: Warp.Port -> IO ()
run port = do
- TaskCore.initTaskDb
putText <| "Starting Jr web server on port " <> tshow port
- Warp.run port app
+ Warp.run port (serve api server)
diff --git a/Omni/Jr/Web/Components.hs b/Omni/Jr/Web/Components.hs
new file mode 100644
index 00000000..9c32cf20
--- /dev/null
+++ b/Omni/Jr/Web/Components.hs
@@ -0,0 +1,1464 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- : dep lucid
+-- : dep servant-lucid
+module Omni.Jr.Web.Components
+ ( -- * Time formatting
+ formatRelativeTime,
+ relativeText,
+ formatExactTimestamp,
+ renderRelativeTimestamp,
+
+ -- * Small components
+ metaSep,
+
+ -- * Page layout
+ pageHead,
+ pageBody,
+ pageBodyWithCrumbs,
+ navbar,
+
+ -- * JavaScript
+ navbarDropdownJs,
+ statusDropdownJs,
+ priorityDropdownJs,
+ liveToggleJs,
+
+ -- * Breadcrumbs
+ Breadcrumb (..),
+ Breadcrumbs,
+ renderBreadcrumbs,
+ getAncestors,
+ taskBreadcrumbs,
+
+ -- * Badges
+ statusBadge,
+ complexityBadge,
+ statusBadgeWithForm,
+ clickableBadge,
+ statusDropdownOptions,
+ statusOption,
+ priorityBadgeWithForm,
+ clickablePriorityBadge,
+ priorityDropdownOptions,
+ priorityOption,
+
+ -- * Sorting
+ SortOrder (..),
+ sortOrderToParam,
+ sortOrderLabel,
+ sortDropdown,
+ sortOption,
+
+ -- * Progress bars
+ multiColorProgressBar,
+ epicProgressBar,
+
+ -- * Task rendering
+ renderTaskCard,
+ renderBlockedTaskCard,
+ renderListGroupItem,
+ renderEpicReviewCard,
+ renderEpicCardWithStats,
+ getDescendants,
+
+ -- * Metrics
+ renderAggregatedMetrics,
+
+ -- * Retry context
+ renderRetryContextBanner,
+
+ -- * Markdown
+ MarkdownBlock (..),
+ InlinePart (..),
+ renderMarkdown,
+ parseBlocks,
+ renderBlocks,
+ renderBlock,
+ renderListItem,
+ renderInline,
+ parseInline,
+ parseBold,
+ renderInlineParts,
+ renderInlinePart,
+
+ -- * Comments
+ commentForm,
+
+ -- * Live toggles
+ renderLiveToggle,
+ renderAutoscrollToggle,
+
+ -- * Cost/Token metrics
+ aggregateCostMetrics,
+ formatCostHeader,
+ formatTokensHeader,
+
+ -- * Timeline
+ renderUnifiedTimeline,
+ renderTimelineEvent,
+ eventTypeIconAndLabel,
+ renderActorLabel,
+ renderCommentTimelineEvent,
+ renderStatusChangeEvent,
+ parseStatusChange,
+ renderActivityEvent,
+ renderErrorTimelineEvent,
+ renderAssistantTimelineEvent,
+ renderToolCallTimelineEvent,
+ renderToolResultTimelineEvent,
+ renderCheckpointEvent,
+ renderGuardrailEvent,
+ renderGenericEvent,
+ parseToolCallContent,
+ formatToolCallSummary,
+ renderCollapsibleOutput,
+ renderDecodedToolResult,
+ timelineScrollScript,
+ )
+where
+
+import Alpha
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.KeyMap as KeyMap
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.List as List
+import qualified Data.Text as Text
+import Data.Time (NominalDiffTime, UTCTime, defaultTimeLocale, diffUTCTime, formatTime)
+import qualified Lucid
+import qualified Lucid.Base as Lucid
+import Numeric (showFFloat)
+import qualified Omni.Task.Core as TaskCore
+
+-- * Time formatting
+
+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))
+
+-- * Small components
+
+metaSep :: (Monad m) => Lucid.HtmlT m ()
+metaSep = Lucid.span_ [Lucid.class_ "meta-sep"] "·"
+
+-- * Sort types
+
+data SortOrder
+ = SortNewest
+ | SortOldest
+ | SortUpdated
+ | SortPriorityHigh
+ | SortPriorityLow
+ deriving (Show, Eq)
+
+sortOrderToParam :: SortOrder -> Text
+sortOrderToParam SortNewest = "newest"
+sortOrderToParam SortOldest = "oldest"
+sortOrderToParam SortUpdated = "updated"
+sortOrderToParam SortPriorityHigh = "priority-high"
+sortOrderToParam SortPriorityLow = "priority-low"
+
+sortOrderLabel :: SortOrder -> Text
+sortOrderLabel SortNewest = "Newest First"
+sortOrderLabel SortOldest = "Oldest First"
+sortOrderLabel SortUpdated = "Recently Updated"
+sortOrderLabel SortPriorityHigh = "Priority (High to Low)"
+sortOrderLabel SortPriorityLow = "Priority (Low to High)"
+
+-- * Page layout
+
+pageHead :: (Monad m) => Text -> Lucid.HtmlT m ()
+pageHead title =
+ Lucid.head_ <| do
+ Lucid.title_ (Lucid.toHtml title)
+ Lucid.meta_ [Lucid.charset_ "utf-8"]
+ Lucid.meta_
+ [ Lucid.name_ "viewport",
+ Lucid.content_ "width=device-width, initial-scale=1"
+ ]
+ Lucid.link_ [Lucid.rel_ "stylesheet", Lucid.href_ "/style.css"]
+ Lucid.script_
+ [ Lucid.src_ "https://unpkg.com/htmx.org@2.0.4",
+ Lucid.integrity_ "sha384-HGfztofotfshcF7+8n44JQL2oJmowVChPTg48S+jvZoztPfvwD79OC/LTtG6dMp+",
+ Lucid.crossorigin_ "anonymous"
+ ]
+ ("" :: Text)
+ Lucid.script_ [] statusDropdownJs
+ Lucid.script_ [] priorityDropdownJs
+ Lucid.script_ [] navbarDropdownJs
+ Lucid.script_ [] liveToggleJs
+
+-- * JavaScript
+
+navbarDropdownJs :: Text
+navbarDropdownJs =
+ Text.unlines
+ [ "document.addEventListener('DOMContentLoaded', function() {",
+ " document.querySelectorAll('.navbar-dropdown-btn').forEach(function(btn) {",
+ " btn.addEventListener('click', function(e) {",
+ " e.preventDefault();",
+ " var dropdown = btn.closest('.navbar-dropdown');",
+ " var isOpen = dropdown.classList.contains('open');",
+ " document.querySelectorAll('.navbar-dropdown.open').forEach(function(d) {",
+ " d.classList.remove('open');",
+ " });",
+ " if (!isOpen) {",
+ " dropdown.classList.add('open');",
+ " }",
+ " });",
+ " });",
+ " document.addEventListener('click', function(e) {",
+ " if (!e.target.closest('.navbar-dropdown')) {",
+ " document.querySelectorAll('.navbar-dropdown.open').forEach(function(d) {",
+ " d.classList.remove('open');",
+ " });",
+ " }",
+ " });",
+ "});"
+ ]
+
+statusDropdownJs :: Text
+statusDropdownJs =
+ Text.unlines
+ [ "function toggleStatusDropdown(el) {",
+ " var container = el.parentElement;",
+ " var isOpen = container.classList.toggle('open');",
+ " el.setAttribute('aria-expanded', isOpen);",
+ " if (isOpen) {",
+ " var firstItem = container.querySelector('[role=\"menuitem\"]');",
+ " if (firstItem) firstItem.focus();",
+ " }",
+ "}",
+ "",
+ "function closeStatusDropdown(container) {",
+ " container.classList.remove('open');",
+ " var badge = container.querySelector('[role=\"button\"]');",
+ " if (badge) {",
+ " badge.setAttribute('aria-expanded', 'false');",
+ " badge.focus();",
+ " }",
+ "}",
+ "",
+ "function handleStatusKeydown(event, el) {",
+ " if (event.key === 'Enter' || event.key === ' ') {",
+ " event.preventDefault();",
+ " toggleStatusDropdown(el);",
+ " } else if (event.key === 'Escape') {",
+ " closeStatusDropdown(el.parentElement);",
+ " } else if (event.key === 'ArrowDown') {",
+ " event.preventDefault();",
+ " var container = el.parentElement;",
+ " if (!container.classList.contains('open')) {",
+ " toggleStatusDropdown(el);",
+ " } else {",
+ " var firstItem = container.querySelector('[role=\"menuitem\"]');",
+ " if (firstItem) firstItem.focus();",
+ " }",
+ " }",
+ "}",
+ "",
+ "function handleMenuItemKeydown(event) {",
+ " var container = event.target.closest('.status-badge-dropdown');",
+ " var items = container.querySelectorAll('[role=\"menuitem\"]');",
+ " var currentIndex = Array.from(items).indexOf(event.target);",
+ " ",
+ " if (event.key === 'ArrowDown') {",
+ " event.preventDefault();",
+ " var next = (currentIndex + 1) % items.length;",
+ " items[next].focus();",
+ " } else if (event.key === 'ArrowUp') {",
+ " event.preventDefault();",
+ " var prev = (currentIndex - 1 + items.length) % items.length;",
+ " items[prev].focus();",
+ " } else if (event.key === 'Escape') {",
+ " event.preventDefault();",
+ " closeStatusDropdown(container);",
+ " } else if (event.key === 'Tab') {",
+ " closeStatusDropdown(container);",
+ " }",
+ "}",
+ "",
+ "document.addEventListener('click', function(e) {",
+ " var dropdowns = document.querySelectorAll('.status-badge-dropdown.open');",
+ " dropdowns.forEach(function(d) {",
+ " if (!d.contains(e.target)) {",
+ " closeStatusDropdown(d);",
+ " }",
+ " });",
+ "});"
+ ]
+
+priorityDropdownJs :: Text
+priorityDropdownJs =
+ Text.unlines
+ [ "function togglePriorityDropdown(el) {",
+ " var container = el.parentElement;",
+ " var isOpen = container.classList.toggle('open');",
+ " el.setAttribute('aria-expanded', isOpen);",
+ " if (isOpen) {",
+ " var firstItem = container.querySelector('[role=\"menuitem\"]');",
+ " if (firstItem) firstItem.focus();",
+ " }",
+ "}",
+ "",
+ "function closePriorityDropdown(container) {",
+ " container.classList.remove('open');",
+ " var badge = container.querySelector('[role=\"button\"]');",
+ " if (badge) {",
+ " badge.setAttribute('aria-expanded', 'false');",
+ " badge.focus();",
+ " }",
+ "}",
+ "",
+ "function handlePriorityKeydown(event, el) {",
+ " if (event.key === 'Enter' || event.key === ' ') {",
+ " event.preventDefault();",
+ " togglePriorityDropdown(el);",
+ " } else if (event.key === 'Escape') {",
+ " closePriorityDropdown(el.parentElement);",
+ " } else if (event.key === 'ArrowDown') {",
+ " event.preventDefault();",
+ " var container = el.parentElement;",
+ " if (!container.classList.contains('open')) {",
+ " togglePriorityDropdown(el);",
+ " } else {",
+ " var firstItem = container.querySelector('[role=\"menuitem\"]');",
+ " if (firstItem) firstItem.focus();",
+ " }",
+ " }",
+ "}",
+ "",
+ "function handlePriorityMenuItemKeydown(event) {",
+ " var container = event.target.closest('.priority-badge-dropdown');",
+ " var items = container.querySelectorAll('[role=\"menuitem\"]');",
+ " var currentIndex = Array.from(items).indexOf(event.target);",
+ " ",
+ " if (event.key === 'ArrowDown') {",
+ " event.preventDefault();",
+ " var next = (currentIndex + 1) % items.length;",
+ " items[next].focus();",
+ " } else if (event.key === 'ArrowUp') {",
+ " event.preventDefault();",
+ " var prev = (currentIndex - 1 + items.length) % items.length;",
+ " items[prev].focus();",
+ " } else if (event.key === 'Escape') {",
+ " event.preventDefault();",
+ " closePriorityDropdown(container);",
+ " } else if (event.key === 'Tab') {",
+ " closePriorityDropdown(container);",
+ " }",
+ "}",
+ "",
+ "document.addEventListener('click', function(e) {",
+ " var dropdowns = document.querySelectorAll('.priority-badge-dropdown.open');",
+ " dropdowns.forEach(function(d) {",
+ " if (!d.contains(e.target)) {",
+ " closePriorityDropdown(d);",
+ " }",
+ " });",
+ "});"
+ ]
+
+liveToggleJs :: Text
+liveToggleJs =
+ Text.unlines
+ [ "var liveUpdatesEnabled = true;",
+ "var autoscrollEnabled = true;",
+ "",
+ "function toggleLiveUpdates() {",
+ " liveUpdatesEnabled = !liveUpdatesEnabled;",
+ " var btn = document.getElementById('live-toggle');",
+ " if (btn) {",
+ " btn.classList.toggle('timeline-live-paused', !liveUpdatesEnabled);",
+ " }",
+ "}",
+ "",
+ "function toggleAutoscroll() {",
+ " autoscrollEnabled = !autoscrollEnabled;",
+ " var btn = document.getElementById('autoscroll-toggle');",
+ " if (btn) {",
+ " btn.classList.toggle('timeline-autoscroll-disabled', !autoscrollEnabled);",
+ " }",
+ "}",
+ "",
+ "document.body.addEventListener('htmx:beforeRequest', function(evt) {",
+ " var timeline = document.getElementById('unified-timeline');",
+ " if (timeline && timeline.contains(evt.target) && !liveUpdatesEnabled) {",
+ " evt.preventDefault();",
+ " }",
+ "});",
+ "",
+ "document.body.addEventListener('htmx:afterSettle', function(evt) {",
+ " if (autoscrollEnabled) {",
+ " var log = document.querySelector('.timeline-events');",
+ " if (log) {",
+ " log.scrollTop = log.scrollHeight;",
+ " }",
+ " }",
+ "});"
+ ]
+
+pageBody :: (Monad m) => Lucid.HtmlT m () -> Lucid.HtmlT m ()
+pageBody content =
+ Lucid.body_ [Lucid.makeAttribute "hx-boost" "true"] <| do
+ navbar
+ content
+
+-- * Breadcrumbs
+
+data Breadcrumb = Breadcrumb
+ { _crumbLabel :: Text,
+ _crumbHref :: Maybe Text
+ }
+
+type Breadcrumbs = [Breadcrumb]
+
+pageBodyWithCrumbs :: (Monad m) => Breadcrumbs -> Lucid.HtmlT m () -> Lucid.HtmlT m ()
+pageBodyWithCrumbs crumbs content =
+ Lucid.body_ [Lucid.makeAttribute "hx-boost" "true"] <| do
+ navbar
+ unless (null crumbs) <| do
+ Lucid.div_ [Lucid.class_ "breadcrumb-container"] <| do
+ Lucid.div_ [Lucid.class_ "container"] <| renderBreadcrumbs crumbs
+ content
+
+renderBreadcrumbs :: (Monad m) => Breadcrumbs -> Lucid.HtmlT m ()
+renderBreadcrumbs [] = pure ()
+renderBreadcrumbs crumbs =
+ Lucid.nav_ [Lucid.class_ "breadcrumbs", Lucid.makeAttribute "aria-label" "Breadcrumb"] <| do
+ Lucid.ol_ [Lucid.class_ "breadcrumb-list"] <| do
+ traverse_ renderCrumb (zip [0 ..] crumbs)
+ where
+ renderCrumb :: (Monad m') => (Int, Breadcrumb) -> Lucid.HtmlT m' ()
+ renderCrumb (idx, Breadcrumb label mHref) = do
+ Lucid.li_ [Lucid.class_ "breadcrumb-item"] <| do
+ when (idx > 0) <| Lucid.span_ [Lucid.class_ "breadcrumb-sep"] ">"
+ case mHref of
+ Just href -> Lucid.a_ [Lucid.href_ href] (Lucid.toHtml label)
+ Nothing -> Lucid.span_ [Lucid.class_ "breadcrumb-current"] (Lucid.toHtml label)
+
+getAncestors :: [TaskCore.Task] -> TaskCore.Task -> [TaskCore.Task]
+getAncestors allTasks task =
+ case TaskCore.taskParent task of
+ Nothing -> [task]
+ Just pid -> case TaskCore.findTask pid allTasks of
+ Nothing -> [task]
+ Just parent -> getAncestors allTasks parent ++ [task]
+
+taskBreadcrumbs :: [TaskCore.Task] -> TaskCore.Task -> Breadcrumbs
+taskBreadcrumbs allTasks task =
+ let ancestors = getAncestors allTasks task
+ taskCrumbs = [Breadcrumb (TaskCore.taskId t) (Just ("/tasks/" <> TaskCore.taskId t)) | t <- List.init ancestors]
+ currentCrumb = Breadcrumb (TaskCore.taskId task) Nothing
+ in [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks")]
+ ++ taskCrumbs
+ ++ [currentCrumb]
+
+-- * Navbar
+
+navbar :: (Monad m) => Lucid.HtmlT m ()
+navbar =
+ Lucid.nav_ [Lucid.class_ "navbar"] <| do
+ Lucid.a_ [Lucid.href_ "/", Lucid.class_ "navbar-brand"] "Junior"
+ Lucid.input_
+ [ Lucid.type_ "checkbox",
+ Lucid.id_ "navbar-toggle",
+ Lucid.class_ "navbar-toggle-checkbox"
+ ]
+ Lucid.label_
+ [ Lucid.for_ "navbar-toggle",
+ Lucid.class_ "navbar-hamburger"
+ ]
+ <| do
+ Lucid.span_ [Lucid.class_ "hamburger-line"] ""
+ Lucid.span_ [Lucid.class_ "hamburger-line"] ""
+ Lucid.span_ [Lucid.class_ "hamburger-line"] ""
+ Lucid.div_ [Lucid.class_ "navbar-links"] <| do
+ Lucid.a_ [Lucid.href_ "/", Lucid.class_ "navbar-link"] "Dashboard"
+ Lucid.div_ [Lucid.class_ "navbar-dropdown"] <| do
+ Lucid.button_ [Lucid.class_ "navbar-dropdown-btn"] "Tasks ▾"
+ Lucid.div_ [Lucid.class_ "navbar-dropdown-content"] <| do
+ Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "navbar-dropdown-item"] "Ready"
+ Lucid.a_ [Lucid.href_ "/blocked", Lucid.class_ "navbar-dropdown-item"] "Blocked"
+ Lucid.a_ [Lucid.href_ "/intervention", Lucid.class_ "navbar-dropdown-item"] "Human Action"
+ Lucid.a_ [Lucid.href_ "/tasks", Lucid.class_ "navbar-dropdown-item"] "All"
+ Lucid.div_ [Lucid.class_ "navbar-dropdown"] <| do
+ Lucid.button_ [Lucid.class_ "navbar-dropdown-btn"] "Plans ▾"
+ Lucid.div_ [Lucid.class_ "navbar-dropdown-content"] <| do
+ Lucid.a_ [Lucid.href_ "/epics", Lucid.class_ "navbar-dropdown-item"] "Epics"
+ Lucid.a_ [Lucid.href_ "/kb", Lucid.class_ "navbar-dropdown-item"] "KB"
+ Lucid.a_ [Lucid.href_ "/stats", Lucid.class_ "navbar-link"] "Stats"
+
+-- * Badges
+
+statusBadge :: (Monad m) => TaskCore.Status -> Lucid.HtmlT m ()
+statusBadge status =
+ let (cls, label) = case status of
+ TaskCore.Draft -> ("badge badge-draft", "Draft")
+ TaskCore.Open -> ("badge badge-open", "Open")
+ TaskCore.InProgress -> ("badge badge-inprogress", "In Progress")
+ TaskCore.Review -> ("badge badge-review", "Review")
+ TaskCore.Approved -> ("badge badge-approved", "Approved")
+ TaskCore.Done -> ("badge badge-done", "Done")
+ TaskCore.NeedsHelp -> ("badge badge-needshelp", "Needs Help")
+ in Lucid.span_ [Lucid.class_ cls] label
+
+complexityBadge :: (Monad m) => Int -> Lucid.HtmlT m ()
+complexityBadge complexity =
+ let cls = "badge badge-complexity badge-complexity-" <> tshow complexity
+ label = "ℂ " <> tshow complexity
+ in Lucid.span_ [Lucid.class_ cls, Lucid.title_ "Task Complexity (1-5)"] (Lucid.toHtml label)
+
+-- * Sort dropdown
+
+sortDropdown :: (Monad m) => Text -> SortOrder -> Lucid.HtmlT m ()
+sortDropdown basePath currentSort =
+ Lucid.div_ [Lucid.class_ "sort-dropdown"] <| do
+ Lucid.span_ [Lucid.class_ "sort-label"] "Sort:"
+ Lucid.div_ [Lucid.class_ "sort-dropdown-wrapper navbar-dropdown"] <| do
+ Lucid.button_ [Lucid.class_ "sort-dropdown-btn navbar-dropdown-btn"]
+ <| Lucid.toHtml (sortOrderLabel currentSort <> " ▾")
+ Lucid.div_ [Lucid.class_ "sort-dropdown-content navbar-dropdown-content"] <| do
+ sortOption basePath SortNewest currentSort
+ sortOption basePath SortOldest currentSort
+ sortOption basePath SortUpdated currentSort
+ sortOption basePath SortPriorityHigh currentSort
+ sortOption basePath SortPriorityLow currentSort
+
+sortOption :: (Monad m) => Text -> SortOrder -> SortOrder -> Lucid.HtmlT m ()
+sortOption basePath option currentSort =
+ let cls = "sort-dropdown-item navbar-dropdown-item" <> if option == currentSort then " active" else ""
+ href = basePath <> "?sort=" <> sortOrderToParam option
+ in Lucid.a_ [Lucid.href_ href, Lucid.class_ cls] (Lucid.toHtml (sortOrderLabel option))
+
+-- * Progress bars
+
+multiColorProgressBar :: (Monad m) => TaskCore.TaskStats -> Lucid.HtmlT m ()
+multiColorProgressBar stats =
+ let total = TaskCore.totalTasks stats
+ doneCount = TaskCore.doneTasks stats
+ inProgressCount = TaskCore.inProgressTasks stats
+ openCount = TaskCore.openTasks stats + TaskCore.reviewTasks stats + TaskCore.approvedTasks stats
+ donePct = if total == 0 then 0 else (doneCount * 100) `div` total
+ inProgressPct = if total == 0 then 0 else (inProgressCount * 100) `div` total
+ openPct = if total == 0 then 0 else (openCount * 100) `div` total
+ in Lucid.div_ [Lucid.class_ "multi-progress-container"] <| do
+ Lucid.div_ [Lucid.class_ "multi-progress-bar"] <| do
+ when (donePct > 0)
+ <| Lucid.div_
+ [ Lucid.class_ "multi-progress-segment progress-done",
+ Lucid.style_ ("width: " <> tshow donePct <> "%"),
+ Lucid.title_ (tshow doneCount <> " done")
+ ]
+ ""
+ when (inProgressPct > 0)
+ <| Lucid.div_
+ [ Lucid.class_ "multi-progress-segment progress-inprogress",
+ Lucid.style_ ("width: " <> tshow inProgressPct <> "%"),
+ Lucid.title_ (tshow inProgressCount <> " in progress")
+ ]
+ ""
+ when (openPct > 0)
+ <| Lucid.div_
+ [ Lucid.class_ "multi-progress-segment progress-open",
+ Lucid.style_ ("width: " <> tshow openPct <> "%"),
+ Lucid.title_ (tshow openCount <> " open")
+ ]
+ ""
+ Lucid.div_ [Lucid.class_ "progress-legend"] <| do
+ Lucid.span_ [Lucid.class_ "legend-item"] <| do
+ Lucid.span_ [Lucid.class_ "legend-dot legend-done"] ""
+ Lucid.toHtml ("Done " <> tshow doneCount)
+ Lucid.span_ [Lucid.class_ "legend-item"] <| do
+ Lucid.span_ [Lucid.class_ "legend-dot legend-inprogress"] ""
+ Lucid.toHtml ("In Progress " <> tshow inProgressCount)
+ Lucid.span_ [Lucid.class_ "legend-item"] <| do
+ Lucid.span_ [Lucid.class_ "legend-dot legend-open"] ""
+ Lucid.toHtml ("Open " <> tshow openCount)
+
+epicProgressBar :: (Monad m) => Int -> Int -> Int -> Int -> Lucid.HtmlT m ()
+epicProgressBar doneCount inProgressCount openCount totalCount =
+ let donePct = if totalCount == 0 then 0 else (doneCount * 100) `div` totalCount
+ inProgressPct = if totalCount == 0 then 0 else (inProgressCount * 100) `div` totalCount
+ openPct = if totalCount == 0 then 0 else (openCount * 100) `div` totalCount
+ in Lucid.div_ [Lucid.class_ "multi-progress-container epic-progress"] <| do
+ Lucid.div_ [Lucid.class_ "multi-progress-bar"] <| do
+ when (donePct > 0)
+ <| Lucid.div_
+ [ Lucid.class_ "multi-progress-segment progress-done",
+ Lucid.style_ ("width: " <> tshow donePct <> "%"),
+ Lucid.title_ (tshow doneCount <> " done")
+ ]
+ ""
+ when (inProgressPct > 0)
+ <| Lucid.div_
+ [ Lucid.class_ "multi-progress-segment progress-inprogress",
+ Lucid.style_ ("width: " <> tshow inProgressPct <> "%"),
+ Lucid.title_ (tshow inProgressCount <> " in progress")
+ ]
+ ""
+ when (openPct > 0)
+ <| Lucid.div_
+ [ Lucid.class_ "multi-progress-segment progress-open",
+ Lucid.style_ ("width: " <> tshow openPct <> "%"),
+ Lucid.title_ (tshow openCount <> " open")
+ ]
+ ""
+ Lucid.div_ [Lucid.class_ "progress-legend"] <| do
+ Lucid.span_ [Lucid.class_ "legend-item"] <| do
+ Lucid.span_ [Lucid.class_ "legend-dot legend-done"] ""
+ Lucid.toHtml (tshow doneCount)
+ Lucid.span_ [Lucid.class_ "legend-item"] <| do
+ Lucid.span_ [Lucid.class_ "legend-dot legend-inprogress"] ""
+ Lucid.toHtml (tshow inProgressCount)
+ Lucid.span_ [Lucid.class_ "legend-item"] <| do
+ Lucid.span_ [Lucid.class_ "legend-dot legend-open"] ""
+ Lucid.toHtml (tshow openCount)
+
+-- * Status badge with form
+
+statusBadgeWithForm :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m ()
+statusBadgeWithForm status tid =
+ Lucid.div_
+ [ Lucid.id_ "status-badge-container",
+ Lucid.class_ "status-badge-dropdown"
+ ]
+ <| do
+ clickableBadge status tid
+ statusDropdownOptions status tid
+
+clickableBadge :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m ()
+clickableBadge status _tid =
+ let (cls, label) = case status of
+ TaskCore.Draft -> ("badge badge-draft status-badge-clickable", "Draft" :: Text)
+ TaskCore.Open -> ("badge badge-open status-badge-clickable", "Open")
+ TaskCore.InProgress -> ("badge badge-inprogress status-badge-clickable", "In Progress")
+ TaskCore.Review -> ("badge badge-review status-badge-clickable", "Review")
+ TaskCore.Approved -> ("badge badge-approved status-badge-clickable", "Approved")
+ TaskCore.Done -> ("badge badge-done status-badge-clickable", "Done")
+ TaskCore.NeedsHelp -> ("badge badge-needshelp status-badge-clickable", "Needs Help")
+ in Lucid.span_
+ [ Lucid.class_ cls,
+ Lucid.tabindex_ "0",
+ Lucid.role_ "button",
+ Lucid.makeAttribute "aria-haspopup" "true",
+ Lucid.makeAttribute "aria-expanded" "false",
+ Lucid.makeAttribute "onclick" "toggleStatusDropdown(this)",
+ Lucid.makeAttribute "onkeydown" "handleStatusKeydown(event, this)"
+ ]
+ <| do
+ Lucid.toHtml label
+ Lucid.span_ [Lucid.class_ "dropdown-arrow", Lucid.makeAttribute "aria-hidden" "true"] " ▾"
+
+statusDropdownOptions :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m ()
+statusDropdownOptions currentStatus tid =
+ Lucid.div_
+ [ Lucid.class_ "status-dropdown-menu",
+ Lucid.role_ "menu",
+ Lucid.makeAttribute "aria-label" "Change task status"
+ ]
+ <| do
+ statusOption TaskCore.Draft currentStatus tid
+ statusOption TaskCore.Open currentStatus tid
+ statusOption TaskCore.InProgress currentStatus tid
+ statusOption TaskCore.Review currentStatus tid
+ statusOption TaskCore.Approved currentStatus tid
+ statusOption TaskCore.Done currentStatus tid
+ statusOption TaskCore.NeedsHelp currentStatus tid
+
+statusOption :: (Monad m) => TaskCore.Status -> TaskCore.Status -> Text -> Lucid.HtmlT m ()
+statusOption opt currentStatus tid =
+ let (cls, label) = case opt of
+ TaskCore.Draft -> ("badge badge-draft", "Draft" :: Text)
+ TaskCore.Open -> ("badge badge-open", "Open")
+ TaskCore.InProgress -> ("badge badge-inprogress", "In Progress")
+ TaskCore.Review -> ("badge badge-review", "Review")
+ TaskCore.Approved -> ("badge badge-approved", "Approved")
+ TaskCore.Done -> ("badge badge-done", "Done")
+ TaskCore.NeedsHelp -> ("badge badge-needshelp", "Needs Help")
+ isSelected = opt == currentStatus
+ optClass = cls <> " status-dropdown-option" <> if isSelected then " selected" else ""
+ in Lucid.form_
+ [ Lucid.class_ "status-option-form",
+ Lucid.role_ "none",
+ Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/status"),
+ Lucid.makeAttribute "hx-target" "#status-badge-container",
+ Lucid.makeAttribute "hx-swap" "outerHTML"
+ ]
+ <| do
+ Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "status", Lucid.value_ (tshow opt)]
+ Lucid.button_
+ [ Lucid.type_ "submit",
+ Lucid.class_ optClass,
+ Lucid.role_ "menuitem",
+ Lucid.tabindex_ "-1",
+ Lucid.makeAttribute "onkeydown" "handleMenuItemKeydown(event)"
+ ]
+ (Lucid.toHtml label)
+
+-- * Priority badge with form
+
+priorityBadgeWithForm :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m ()
+priorityBadgeWithForm priority tid =
+ Lucid.div_
+ [ Lucid.id_ "priority-badge-container",
+ Lucid.class_ "priority-badge-dropdown"
+ ]
+ <| do
+ clickablePriorityBadge priority tid
+ priorityDropdownOptions priority tid
+
+clickablePriorityBadge :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m ()
+clickablePriorityBadge priority _tid =
+ let (cls, label) = case priority of
+ TaskCore.P0 -> ("badge badge-p0 priority-badge-clickable", "P0 Critical" :: Text)
+ TaskCore.P1 -> ("badge badge-p1 priority-badge-clickable", "P1 High")
+ TaskCore.P2 -> ("badge badge-p2 priority-badge-clickable", "P2 Normal")
+ TaskCore.P3 -> ("badge badge-p3 priority-badge-clickable", "P3 Low")
+ TaskCore.P4 -> ("badge badge-p4 priority-badge-clickable", "P4 Defer")
+ in Lucid.span_
+ [ Lucid.class_ cls,
+ Lucid.tabindex_ "0",
+ Lucid.role_ "button",
+ Lucid.makeAttribute "aria-haspopup" "true",
+ Lucid.makeAttribute "aria-expanded" "false",
+ Lucid.makeAttribute "onclick" "togglePriorityDropdown(this)",
+ Lucid.makeAttribute "onkeydown" "handlePriorityKeydown(event, this)"
+ ]
+ <| do
+ Lucid.toHtml label
+ Lucid.span_ [Lucid.class_ "dropdown-arrow", Lucid.makeAttribute "aria-hidden" "true"] " ▾"
+
+priorityDropdownOptions :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m ()
+priorityDropdownOptions currentPriority tid =
+ Lucid.div_
+ [ Lucid.class_ "priority-dropdown-menu",
+ Lucid.role_ "menu",
+ Lucid.makeAttribute "aria-label" "Change task priority"
+ ]
+ <| do
+ priorityOption TaskCore.P0 currentPriority tid
+ priorityOption TaskCore.P1 currentPriority tid
+ priorityOption TaskCore.P2 currentPriority tid
+ priorityOption TaskCore.P3 currentPriority tid
+ priorityOption TaskCore.P4 currentPriority tid
+
+priorityOption :: (Monad m) => TaskCore.Priority -> TaskCore.Priority -> Text -> Lucid.HtmlT m ()
+priorityOption opt currentPriority tid =
+ let (cls, label) = case opt of
+ TaskCore.P0 -> ("badge badge-p0", "P0 Critical" :: Text)
+ TaskCore.P1 -> ("badge badge-p1", "P1 High")
+ TaskCore.P2 -> ("badge badge-p2", "P2 Normal")
+ TaskCore.P3 -> ("badge badge-p3", "P3 Low")
+ TaskCore.P4 -> ("badge badge-p4", "P4 Defer")
+ isSelected = opt == currentPriority
+ optClass = cls <> " priority-dropdown-option" <> if isSelected then " selected" else ""
+ in Lucid.form_
+ [ Lucid.class_ "priority-option-form",
+ Lucid.role_ "none",
+ Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/priority"),
+ Lucid.makeAttribute "hx-target" "#priority-badge-container",
+ Lucid.makeAttribute "hx-swap" "outerHTML"
+ ]
+ <| do
+ Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "priority", Lucid.value_ (tshow opt)]
+ Lucid.button_
+ [ Lucid.type_ "submit",
+ Lucid.class_ optClass,
+ Lucid.role_ "menuitem",
+ Lucid.tabindex_ "-1",
+ Lucid.makeAttribute "onkeydown" "handlePriorityMenuItemKeydown(event)"
+ ]
+ (Lucid.toHtml label)
+
+-- * Task rendering
+
+renderTaskCard :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m ()
+renderTaskCard t =
+ Lucid.a_
+ [ Lucid.class_ "task-card task-card-link",
+ Lucid.href_ ("/tasks/" <> TaskCore.taskId t)
+ ]
+ <| do
+ Lucid.div_ [Lucid.class_ "task-header"] <| do
+ Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (TaskCore.taskId t))
+ statusBadge (TaskCore.taskStatus t)
+ Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t)))
+ Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t))
+
+renderBlockedTaskCard :: (Monad m) => (TaskCore.Task, Int) -> Lucid.HtmlT m ()
+renderBlockedTaskCard (t, impact) =
+ Lucid.a_
+ [ Lucid.class_ "task-card task-card-link",
+ Lucid.href_ ("/tasks/" <> TaskCore.taskId t)
+ ]
+ <| do
+ Lucid.div_ [Lucid.class_ "task-header"] <| do
+ Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (TaskCore.taskId t))
+ statusBadge (TaskCore.taskStatus t)
+ Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t)))
+ when (impact > 0)
+ <| Lucid.span_ [Lucid.class_ "blocking-impact"] (Lucid.toHtml ("Blocks " <> tshow impact))
+ Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t))
+
+renderListGroupItem :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m ()
+renderListGroupItem t =
+ Lucid.a_
+ [ Lucid.class_ "list-group-item",
+ Lucid.href_ ("/tasks/" <> TaskCore.taskId t),
+ Lucid.makeAttribute "hx-boost" "true",
+ Lucid.makeAttribute "hx-target" "body",
+ Lucid.makeAttribute "hx-swap" "innerHTML"
+ ]
+ <| do
+ Lucid.div_ [Lucid.class_ "list-group-item-content"] <| do
+ Lucid.span_ [Lucid.class_ "list-group-item-id"] (Lucid.toHtml (TaskCore.taskId t))
+ Lucid.span_ [Lucid.class_ "list-group-item-title"] (Lucid.toHtml (TaskCore.taskTitle t))
+ Lucid.div_ [Lucid.class_ "list-group-item-meta"] <| do
+ statusBadge (TaskCore.taskStatus t)
+ Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t)))
+
+renderEpicReviewCard :: (Monad m) => TaskCore.EpicForReview -> Lucid.HtmlT m ()
+renderEpicReviewCard epicReview = do
+ let task = TaskCore.epicTask epicReview
+ total = TaskCore.epicTotal epicReview
+ completed = TaskCore.epicCompleted epicReview
+ progressText = tshow completed <> "/" <> tshow total <> " subtasks done"
+ Lucid.div_ [Lucid.class_ "task-card"] <| do
+ Lucid.div_ [Lucid.class_ "task-card-header"] <| do
+ Lucid.div_ [Lucid.class_ "task-title-row"] <| do
+ Lucid.a_
+ [Lucid.href_ ("/tasks/" <> TaskCore.taskId task), Lucid.class_ "task-link"]
+ <| Lucid.toHtml (TaskCore.taskTitle task)
+ Lucid.span_ [Lucid.class_ "badge badge-epic"] "Epic"
+ Lucid.span_ [Lucid.class_ "task-id"] <| Lucid.toHtml (TaskCore.taskId task)
+ Lucid.div_ [Lucid.class_ "task-card-body"] <| do
+ Lucid.div_ [Lucid.class_ "progress-info"] <| do
+ Lucid.span_ [Lucid.class_ "badge badge-success"] <| Lucid.toHtml progressText
+ Lucid.div_ [Lucid.class_ "epic-actions"] <| do
+ Lucid.form_
+ [ Lucid.method_ "POST",
+ Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/status"),
+ Lucid.class_ "inline-form"
+ ]
+ <| do
+ Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "status", Lucid.value_ "done"]
+ Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-success btn-sm"] "Approve & Close"
+
+renderEpicCardWithStats :: (Monad m) => [TaskCore.Task] -> TaskCore.Task -> Lucid.HtmlT m ()
+renderEpicCardWithStats allTasks t =
+ let children = getDescendants allTasks (TaskCore.taskId t)
+ openCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Open]
+ inProgressCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.InProgress]
+ reviewCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Review]
+ doneCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Done]
+ totalCount = length children
+ openAndReview = openCount + reviewCount
+ in Lucid.a_
+ [ Lucid.class_ "task-card task-card-link",
+ Lucid.href_ ("/tasks/" <> TaskCore.taskId t)
+ ]
+ <| do
+ Lucid.div_ [Lucid.class_ "task-header"] <| do
+ Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (TaskCore.taskId t))
+ statusBadge (TaskCore.taskStatus t)
+ Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t)))
+ Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t))
+ when (totalCount > 0) <| epicProgressBar doneCount inProgressCount openAndReview totalCount
+ unless (Text.null (TaskCore.taskDescription t))
+ <| Lucid.p_ [Lucid.class_ "kb-preview"] (Lucid.toHtml (Text.take 200 (TaskCore.taskDescription t) <> "..."))
+
+getDescendants :: [TaskCore.Task] -> Text -> [TaskCore.Task]
+getDescendants allTasks parentId =
+ let children = [c | c <- allTasks, maybe False (TaskCore.matchesId parentId) (TaskCore.taskParent c)]
+ in children ++ concatMap (getDescendants allTasks <. TaskCore.taskId) children
+
+-- * Aggregated metrics
+
+renderAggregatedMetrics :: (Monad m) => [TaskCore.Task] -> TaskCore.Task -> TaskCore.AggregatedMetrics -> Lucid.HtmlT m ()
+renderAggregatedMetrics allTasks task metrics =
+ let descendants = getDescendants allTasks (TaskCore.taskId task)
+ totalCount = length descendants
+ costCents = TaskCore.aggTotalCostCents metrics
+ durationSecs = TaskCore.aggTotalDurationSeconds metrics
+ completedCount = TaskCore.aggCompletedTasks metrics
+ tokensUsed = TaskCore.aggTotalTokens metrics
+ in Lucid.div_ [Lucid.class_ "detail-section aggregated-metrics"] <| do
+ Lucid.h3_ "Execution Summary"
+ Lucid.div_ [Lucid.class_ "metrics-grid"] <| do
+ Lucid.div_ [Lucid.class_ "metric-card"] <| do
+ Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (tshow completedCount <> "/" <> tshow totalCount))
+ Lucid.div_ [Lucid.class_ "metric-label"] "Tasks Completed"
+ Lucid.div_ [Lucid.class_ "metric-card"] <| do
+ Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCostMetric costCents))
+ Lucid.div_ [Lucid.class_ "metric-label"] "Total Cost"
+ Lucid.div_ [Lucid.class_ "metric-card"] <| do
+ Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDurationMetric durationSecs))
+ Lucid.div_ [Lucid.class_ "metric-label"] "Total Time"
+ when (tokensUsed > 0) <| do
+ Lucid.div_ [Lucid.class_ "metric-card"] <| do
+ Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatTokensMetric tokensUsed))
+ Lucid.div_ [Lucid.class_ "metric-label"] "Tokens Used"
+ where
+ formatCostMetric :: Int -> Text
+ formatCostMetric cents =
+ let dollars = fromIntegral cents / 100.0 :: Double
+ in "$" <> Text.pack (showFFloat (Just 2) dollars "")
+
+ formatDurationMetric :: Int -> Text
+ formatDurationMetric secs
+ | secs < 60 = tshow secs <> "s"
+ | secs < 3600 =
+ let mins = secs `div` 60
+ remSecs = secs `mod` 60
+ in tshow mins <> "m " <> tshow remSecs <> "s"
+ | otherwise =
+ let hrs = secs `div` 3600
+ mins = (secs `mod` 3600) `div` 60
+ in tshow hrs <> "h " <> tshow mins <> "m"
+
+ formatTokensMetric :: Int -> Text
+ formatTokensMetric t
+ | t < 1000 = tshow t
+ | t < 1000000 = Text.pack (showFFloat (Just 1) (fromIntegral t / 1000.0 :: Double) "") <> "K"
+ | otherwise = Text.pack (showFFloat (Just 2) (fromIntegral t / 1000000.0 :: Double) "") <> "M"
+
+-- * Retry context banner
+
+renderRetryContextBanner :: (Monad m) => Text -> Maybe TaskCore.RetryContext -> Lucid.HtmlT m ()
+renderRetryContextBanner _ Nothing = pure ()
+renderRetryContextBanner tid (Just ctx) =
+ Lucid.div_ [Lucid.class_ bannerClass] <| do
+ Lucid.div_ [Lucid.class_ "retry-banner-header"] <| do
+ Lucid.span_ [Lucid.class_ "retry-icon"] retryIcon
+ Lucid.span_ [Lucid.class_ "retry-attempt"] (Lucid.toHtml attemptText)
+ when maxRetriesExceeded
+ <| Lucid.span_ [Lucid.class_ "retry-warning-badge"] "Needs Human Intervention"
+
+ Lucid.div_ [Lucid.class_ "retry-banner-details"] <| do
+ Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do
+ Lucid.span_ [Lucid.class_ "retry-label"] "Failure Reason:"
+ Lucid.span_ [Lucid.class_ "retry-value"] (Lucid.toHtml (summarizeReason (TaskCore.retryReason ctx)))
+
+ let commit = TaskCore.retryOriginalCommit ctx
+ unless (Text.null commit) <| do
+ Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do
+ Lucid.span_ [Lucid.class_ "retry-label"] "Original Commit:"
+ Lucid.code_ [Lucid.class_ "retry-commit"] (Lucid.toHtml (Text.take 8 commit))
+
+ let conflicts = TaskCore.retryConflictFiles ctx
+ unless (null conflicts) <| do
+ Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do
+ Lucid.span_ [Lucid.class_ "retry-label"] "Conflict Files:"
+ Lucid.ul_ [Lucid.class_ "retry-conflict-list"]
+ <| traverse_ (Lucid.li_ <. Lucid.toHtml) conflicts
+
+ when maxRetriesExceeded <| do
+ Lucid.div_
+ [Lucid.class_ "retry-warning-message"]
+ "This task has exceeded the maximum number of retries. A human must review the failure and either fix the issue manually or reset the retry count."
+
+ Lucid.p_ [Lucid.class_ "retry-hint"] "Use comments below to provide guidance for retry."
+
+ Lucid.div_ [Lucid.class_ "retry-reset-section"] <| do
+ Lucid.h4_ "Reset Retries"
+ Lucid.p_ [Lucid.class_ "notes-help"] "Clear retry context and give task a fresh start:"
+ Lucid.form_ [Lucid.method_ "POST", Lucid.action_ ("/tasks/" <> tid <> "/reset-retries")] <| do
+ Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "reset-btn"] "Reset Retries"
+ where
+ attempt = TaskCore.retryAttempt ctx
+ maxRetriesExceeded = attempt >= 3
+ bannerClass = if maxRetriesExceeded then "retry-banner retry-banner-critical" else "retry-banner retry-banner-warning"
+ retryIcon = if maxRetriesExceeded then "⚠" else "↻"
+ attemptText = "Attempt " <> tshow attempt <> " of 3"
+
+ summarizeReason :: Text -> Text
+ summarizeReason reason
+ | "rejected:" `Text.isPrefixOf` reason = "Rejected: " <> Text.strip (Text.drop 9 reason)
+ | "Test failure:" `Text.isPrefixOf` reason = "Test failure (see details below)"
+ | "MERGE CONFLICT" `Text.isPrefixOf` reason = "Merge conflict with concurrent changes"
+ | otherwise = Text.take 100 reason <> if Text.length reason > 100 then "..." else ""
+
+-- * Markdown rendering
+
+renderMarkdown :: (Monad m) => Text -> Lucid.HtmlT m ()
+renderMarkdown input = renderBlocks (parseBlocks (Text.lines input))
+
+data MarkdownBlock
+ = MdHeader Int Text
+ | MdParagraph [Text]
+ | MdCodeBlock [Text]
+ | MdList [Text]
+ deriving (Show, Eq)
+
+parseBlocks :: [Text] -> [MarkdownBlock]
+parseBlocks [] = []
+parseBlocks lns = case lns of
+ (l : rest)
+ | "```" `Text.isPrefixOf` l ->
+ let (codeLines, afterCode) = List.span (not <. Text.isPrefixOf "```") rest
+ remaining = List.drop 1 afterCode
+ in MdCodeBlock codeLines : parseBlocks remaining
+ | "### " `Text.isPrefixOf` l ->
+ MdHeader 3 (Text.drop 4 l) : parseBlocks rest
+ | "## " `Text.isPrefixOf` l ->
+ MdHeader 2 (Text.drop 3 l) : parseBlocks rest
+ | "# " `Text.isPrefixOf` l ->
+ MdHeader 1 (Text.drop 2 l) : parseBlocks rest
+ | isListItem l ->
+ let (listLines, afterList) = List.span isListItem lns
+ in MdList (map stripListPrefix listLines) : parseBlocks afterList
+ | Text.null (Text.strip l) ->
+ parseBlocks rest
+ | otherwise ->
+ let (paraLines, afterPara) = List.span isParagraphLine lns
+ in MdParagraph paraLines : parseBlocks afterPara
+ where
+ isListItem t =
+ let stripped = Text.stripStart t
+ in "- " `Text.isPrefixOf` stripped || "* " `Text.isPrefixOf` stripped
+ stripListPrefix t =
+ let stripped = Text.stripStart t
+ in Text.drop 2 stripped
+ isParagraphLine t =
+ not (Text.null (Text.strip t))
+ && not ("```" `Text.isPrefixOf` t)
+ && not ("#" `Text.isPrefixOf` t)
+ && not (isListItem t)
+
+renderBlocks :: (Monad m) => [MarkdownBlock] -> Lucid.HtmlT m ()
+renderBlocks = traverse_ renderBlock
+
+renderBlock :: (Monad m) => MarkdownBlock -> Lucid.HtmlT m ()
+renderBlock block = case block of
+ MdHeader 1 txt -> Lucid.h2_ [Lucid.class_ "md-h1"] (renderInline txt)
+ MdHeader 2 txt -> Lucid.h3_ [Lucid.class_ "md-h2"] (renderInline txt)
+ MdHeader 3 txt -> Lucid.h4_ [Lucid.class_ "md-h3"] (renderInline txt)
+ MdHeader _ txt -> Lucid.h4_ (renderInline txt)
+ MdParagraph lns -> Lucid.p_ [Lucid.class_ "md-para"] (renderInline (Text.unlines lns))
+ MdCodeBlock lns -> Lucid.pre_ [Lucid.class_ "md-code"] (Lucid.code_ (Lucid.toHtml (Text.unlines lns)))
+ MdList items -> Lucid.ul_ [Lucid.class_ "md-list"] (traverse_ renderListItem items)
+
+renderListItem :: (Monad m) => Text -> Lucid.HtmlT m ()
+renderListItem txt = Lucid.li_ (renderInline txt)
+
+renderInline :: (Monad m) => Text -> Lucid.HtmlT m ()
+renderInline txt = renderInlineParts (parseInline txt)
+
+data InlinePart = PlainText Text | InlineCode Text | BoldText Text
+ deriving (Show, Eq)
+
+parseInline :: Text -> [InlinePart]
+parseInline t
+ | Text.null t = []
+ | otherwise = case Text.breakOn "`" t of
+ (before, rest)
+ | Text.null rest -> parseBold before
+ | otherwise ->
+ let afterTick = Text.drop 1 rest
+ in case Text.breakOn "`" afterTick of
+ (code, rest2)
+ | Text.null rest2 ->
+ parseBold before ++ [PlainText ("`" <> afterTick)]
+ | otherwise ->
+ parseBold before ++ [InlineCode code] ++ parseInline (Text.drop 1 rest2)
+
+parseBold :: Text -> [InlinePart]
+parseBold t
+ | Text.null t = []
+ | otherwise = case Text.breakOn "**" t of
+ (before, rest)
+ | Text.null rest -> [PlainText before | not (Text.null before)]
+ | otherwise ->
+ let afterBold = Text.drop 2 rest
+ in case Text.breakOn "**" afterBold of
+ (boldText, rest2)
+ | Text.null rest2 ->
+ [PlainText before | not (Text.null before)] ++ [PlainText ("**" <> afterBold)]
+ | otherwise ->
+ [PlainText before | not (Text.null before)]
+ ++ [BoldText boldText]
+ ++ parseBold (Text.drop 2 rest2)
+
+renderInlineParts :: (Monad m) => [InlinePart] -> Lucid.HtmlT m ()
+renderInlineParts = traverse_ renderInlinePart
+
+renderInlinePart :: (Monad m) => InlinePart -> Lucid.HtmlT m ()
+renderInlinePart part = case part of
+ PlainText txt -> Lucid.toHtml txt
+ InlineCode txt -> Lucid.code_ [Lucid.class_ "md-inline-code"] (Lucid.toHtml txt)
+ BoldText txt -> Lucid.strong_ (Lucid.toHtml txt)
+
+-- * Comment form
+
+commentForm :: (Monad m) => Text -> Lucid.HtmlT m ()
+commentForm tid =
+ Lucid.form_
+ [ Lucid.method_ "POST",
+ Lucid.action_ ("/tasks/" <> tid <> "/comment"),
+ Lucid.class_ "comment-form"
+ ]
+ <| do
+ Lucid.textarea_
+ [ Lucid.name_ "comment",
+ Lucid.placeholder_ "Add a comment...",
+ Lucid.rows_ "3",
+ Lucid.class_ "comment-textarea"
+ ]
+ ""
+ Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Post Comment"
+
+-- * Live toggles
+
+renderLiveToggle :: (Monad m) => Lucid.HtmlT m ()
+renderLiveToggle =
+ Lucid.button_
+ [ Lucid.class_ "timeline-live-toggle",
+ Lucid.id_ "live-toggle",
+ Lucid.makeAttribute "onclick" "toggleLiveUpdates()",
+ Lucid.title_ "Click to pause/resume live updates"
+ ]
+ " LIVE"
+
+renderAutoscrollToggle :: (Monad m) => Lucid.HtmlT m ()
+renderAutoscrollToggle =
+ Lucid.button_
+ [ Lucid.class_ "timeline-autoscroll-toggle",
+ Lucid.id_ "autoscroll-toggle",
+ Lucid.makeAttribute "onclick" "toggleAutoscroll()",
+ Lucid.title_ "Toggle automatic scrolling to newest events"
+ ]
+ " ⬇ Auto-scroll"
+
+-- * Cost/Token metrics
+
+aggregateCostMetrics :: [TaskCore.StoredEvent] -> (Int, Int)
+aggregateCostMetrics events =
+ let costEvents = filter (\e -> TaskCore.storedEventType e == "Cost") events
+ aggregateOne (totalCents, totalTokens) event =
+ case Aeson.decode (LBS.fromStrict (str (TaskCore.storedEventContent event))) of
+ Just (Aeson.Object obj) ->
+ let cents = case KeyMap.lookup "cents" obj of
+ Just (Aeson.Number n) -> floor n
+ _ -> 0
+ tokens = case KeyMap.lookup "tokens" obj of
+ Just (Aeson.Number n) -> floor n
+ _ -> 0
+ in (totalCents + cents, totalTokens + tokens)
+ _ -> (totalCents, totalTokens)
+ in foldl' aggregateOne (0, 0) costEvents
+
+formatCostHeader :: Int -> Text
+formatCostHeader cents =
+ let dollars = fromIntegral cents / 100.0 :: Double
+ in "$" <> Text.pack (showFFloat (Just 2) dollars "")
+
+formatTokensHeader :: Int -> Text
+formatTokensHeader t
+ | t < 1000 = tshow t
+ | t < 1000000 = Text.pack (showFFloat (Just 1) (fromIntegral t / 1000.0 :: Double) "") <> "K"
+ | otherwise = Text.pack (showFFloat (Just 2) (fromIntegral t / 1000000.0 :: Double) "") <> "M"
+
+-- * Timeline
+
+renderUnifiedTimeline :: (Monad m) => Text -> [TaskCore.Comment] -> [TaskCore.StoredEvent] -> TaskCore.Status -> UTCTime -> Lucid.HtmlT m ()
+renderUnifiedTimeline tid legacyComments events status now = do
+ let isInProgress = status == TaskCore.InProgress
+ pollAttrs =
+ if isInProgress
+ then
+ [ Lucid.makeAttribute "hx-get" ("/partials/task/" <> tid <> "/events"),
+ Lucid.makeAttribute "hx-trigger" "every 3s",
+ Lucid.makeAttribute "hx-swap" "innerHTML",
+ Lucid.makeAttribute "hx-on::before-request" "var log = this.querySelector('.timeline-events'); if(log) this.dataset.scroll = log.scrollTop",
+ Lucid.makeAttribute "hx-on::after-swap" "var log = this.querySelector('.timeline-events'); if(log && this.dataset.scroll) log.scrollTop = this.dataset.scroll"
+ ]
+ else []
+ nonCostEvents = filter (\e -> TaskCore.storedEventType e /= "Cost") events
+ eventCount = length nonCostEvents + length legacyComments
+ (totalCents, totalTokens) = aggregateCostMetrics events
+ Lucid.div_ ([Lucid.class_ "unified-timeline-section", Lucid.id_ "unified-timeline"] <> pollAttrs) <| do
+ Lucid.h3_ <| do
+ Lucid.toHtml ("Timeline (" <> tshow eventCount <> ")")
+ when (totalCents > 0 || totalTokens > 0) <| do
+ Lucid.span_ [Lucid.class_ "timeline-cost-summary"] <| do
+ metaSep
+ when (totalCents > 0) <| Lucid.toHtml (formatCostHeader totalCents)
+ when (totalCents > 0 && totalTokens > 0) <| metaSep
+ when (totalTokens > 0) <| Lucid.toHtml (formatTokensHeader totalTokens <> " tokens")
+ when isInProgress <| do
+ renderLiveToggle
+ renderAutoscrollToggle
+
+ if null nonCostEvents && null legacyComments
+ then Lucid.p_ [Lucid.class_ "empty-msg"] "No activity yet."
+ else do
+ Lucid.div_ [Lucid.class_ "timeline-events"] <| do
+ traverse_ (renderTimelineEvent now) nonCostEvents
+ when isInProgress <| timelineScrollScript
+
+ commentForm tid
+
+renderTimelineEvent :: (Monad m) => UTCTime -> TaskCore.StoredEvent -> Lucid.HtmlT m ()
+renderTimelineEvent now event =
+ let eventType = TaskCore.storedEventType event
+ content = TaskCore.storedEventContent event
+ timestamp = TaskCore.storedEventTimestamp event
+ actor = TaskCore.storedEventActor event
+ eventId = TaskCore.storedEventId event
+ (icon, label) = eventTypeIconAndLabel eventType
+ in Lucid.div_
+ [ Lucid.class_ ("timeline-event timeline-event-" <> eventType),
+ Lucid.makeAttribute "data-event-id" (tshow eventId)
+ ]
+ <| do
+ case eventType of
+ "comment" -> renderCommentTimelineEvent content actor timestamp now
+ "status_change" -> renderStatusChangeEvent content actor timestamp now
+ "claim" -> renderActivityEvent icon label content actor timestamp now
+ "running" -> renderActivityEvent icon label content actor timestamp now
+ "reviewing" -> renderActivityEvent icon label content actor timestamp now
+ "retrying" -> renderActivityEvent icon label content actor timestamp now
+ "complete" -> renderActivityEvent icon label content actor timestamp now
+ "error" -> renderErrorTimelineEvent content actor timestamp now
+ "Assistant" -> renderAssistantTimelineEvent content actor timestamp now
+ "ToolCall" -> renderToolCallTimelineEvent content actor timestamp now
+ "ToolResult" -> renderToolResultTimelineEvent content actor timestamp now
+ "Cost" -> pure ()
+ "Checkpoint" -> renderCheckpointEvent content actor timestamp now
+ "Guardrail" -> renderGuardrailEvent content actor timestamp now
+ _ -> renderGenericEvent eventType content actor timestamp now
+
+eventTypeIconAndLabel :: Text -> (Text, Text)
+eventTypeIconAndLabel "comment" = ("💬", "Comment")
+eventTypeIconAndLabel "status_change" = ("🔄", "Status")
+eventTypeIconAndLabel "claim" = ("🤖", "Claimed")
+eventTypeIconAndLabel "running" = ("▶️", "Running")
+eventTypeIconAndLabel "reviewing" = ("👀", "Reviewing")
+eventTypeIconAndLabel "retrying" = ("🔁", "Retrying")
+eventTypeIconAndLabel "complete" = ("✅", "Complete")
+eventTypeIconAndLabel "error" = ("❌", "Error")
+eventTypeIconAndLabel "Assistant" = ("💭", "Thought")
+eventTypeIconAndLabel "ToolCall" = ("🔧", "Tool")
+eventTypeIconAndLabel "ToolResult" = ("📄", "Result")
+eventTypeIconAndLabel "Cost" = ("💰", "Cost")
+eventTypeIconAndLabel "Checkpoint" = ("📍", "Checkpoint")
+eventTypeIconAndLabel "Guardrail" = ("⚠️", "Guardrail")
+eventTypeIconAndLabel t = ("📝", t)
+
+renderActorLabel :: (Monad m) => TaskCore.CommentAuthor -> Lucid.HtmlT m ()
+renderActorLabel actor =
+ let (cls, label) :: (Text, Text) = case actor of
+ TaskCore.Human -> ("actor-human", "human")
+ TaskCore.Junior -> ("actor-junior", "junior")
+ TaskCore.System -> ("actor-system", "system")
+ in Lucid.span_ [Lucid.class_ ("actor-label " <> cls)] (Lucid.toHtml ("[" <> label <> "]"))
+
+renderCommentTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
+renderCommentTimelineEvent content actor timestamp now =
+ Lucid.div_ [Lucid.class_ "timeline-comment"] <| do
+ Lucid.div_ [Lucid.class_ "event-header"] <| do
+ Lucid.span_ [Lucid.class_ "event-icon"] "💬"
+ renderActorLabel actor
+ renderRelativeTimestamp now timestamp
+ Lucid.div_ [Lucid.class_ "event-content comment-bubble markdown-content"] <| do
+ renderMarkdown content
+
+renderStatusChangeEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
+renderStatusChangeEvent content actor timestamp now =
+ Lucid.div_ [Lucid.class_ "timeline-status-change"] <| do
+ Lucid.span_ [Lucid.class_ "event-icon"] "🔄"
+ renderActorLabel actor
+ Lucid.span_ [Lucid.class_ "status-change-text"] (Lucid.toHtml (parseStatusChange content))
+ renderRelativeTimestamp now timestamp
+
+parseStatusChange :: Text -> Text
+parseStatusChange content =
+ case Aeson.decode (LBS.fromStrict (str content)) of
+ Just (Aeson.Object obj) ->
+ let fromStatus = case KeyMap.lookup "from" obj of
+ Just (Aeson.String s) -> s
+ _ -> "?"
+ toStatus = case KeyMap.lookup "to" obj of
+ Just (Aeson.String s) -> s
+ _ -> "?"
+ in fromStatus <> " → " <> toStatus
+ _ -> content
+
+renderActivityEvent :: (Monad m) => Text -> Text -> Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
+renderActivityEvent icon label content actor timestamp now =
+ Lucid.div_ [Lucid.class_ "timeline-activity"] <| do
+ Lucid.span_ [Lucid.class_ "event-icon"] (Lucid.toHtml icon)
+ Lucid.span_ [Lucid.class_ "event-label"] (Lucid.toHtml label)
+ renderActorLabel actor
+ unless (Text.null content) <| Lucid.span_ [Lucid.class_ "activity-detail"] (Lucid.toHtml content)
+ renderRelativeTimestamp now timestamp
+
+renderErrorTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
+renderErrorTimelineEvent content actor timestamp now =
+ Lucid.div_ [Lucid.class_ "timeline-error"] <| do
+ Lucid.div_ [Lucid.class_ "event-header"] <| do
+ Lucid.span_ [Lucid.class_ "event-icon"] "❌"
+ Lucid.span_ [Lucid.class_ "event-label"] "Error"
+ renderActorLabel actor
+ renderRelativeTimestamp now timestamp
+ Lucid.div_ [Lucid.class_ "event-content error-message"] (Lucid.toHtml content)
+
+renderAssistantTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
+renderAssistantTimelineEvent content _actor timestamp now =
+ Lucid.div_ [Lucid.class_ "timeline-thought"] <| do
+ Lucid.div_ [Lucid.class_ "event-header"] <| do
+ Lucid.span_ [Lucid.class_ "event-icon"] "💭"
+ Lucid.span_ [Lucid.class_ "event-label"] "Thought"
+ renderActorLabel TaskCore.Junior
+ renderRelativeTimestamp now timestamp
+ Lucid.div_ [Lucid.class_ "event-content thought-bubble markdown-content"] <| do
+ let truncated = Text.take 2000 content
+ isTruncated = Text.length content > 2000
+ renderMarkdown truncated
+ when isTruncated <| Lucid.span_ [Lucid.class_ "event-truncated"] "..."
+
+renderToolCallTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
+renderToolCallTimelineEvent content _actor timestamp now =
+ let (toolName, args) = parseToolCallContent content
+ summary = formatToolCallSummary toolName args
+ in Lucid.details_ [Lucid.class_ "timeline-tool-call"] <| do
+ Lucid.summary_ <| do
+ Lucid.span_ [Lucid.class_ "event-icon"] "🔧"
+ Lucid.span_ [Lucid.class_ "tool-name"] (Lucid.toHtml toolName)
+ Lucid.span_ [Lucid.class_ "tool-summary"] (Lucid.toHtml summary)
+ renderRelativeTimestamp now timestamp
+ Lucid.div_ [Lucid.class_ "event-content tool-args"] <| do
+ renderCollapsibleOutput args
+
+renderToolResultTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
+renderToolResultTimelineEvent content _actor timestamp now =
+ let lineCount = length (Text.lines content)
+ in Lucid.details_ [Lucid.class_ "timeline-tool-result"] <| do
+ Lucid.summary_ <| do
+ Lucid.span_ [Lucid.class_ "event-icon"] "📄"
+ Lucid.span_ [Lucid.class_ "event-label"] "Result"
+ when (lineCount > 1)
+ <| Lucid.span_ [Lucid.class_ "line-count"] (Lucid.toHtml (tshow lineCount <> " lines"))
+ renderRelativeTimestamp now timestamp
+ Lucid.pre_ [Lucid.class_ "event-content tool-output"] (renderDecodedToolResult content)
+
+renderCheckpointEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
+renderCheckpointEvent content actor timestamp now =
+ Lucid.div_ [Lucid.class_ "timeline-checkpoint"] <| do
+ Lucid.div_ [Lucid.class_ "event-header"] <| do
+ Lucid.span_ [Lucid.class_ "event-icon"] "📍"
+ Lucid.span_ [Lucid.class_ "event-label"] "Checkpoint"
+ renderActorLabel actor
+ renderRelativeTimestamp now timestamp
+ Lucid.div_ [Lucid.class_ "event-content checkpoint-content"] (Lucid.toHtml content)
+
+renderGuardrailEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
+renderGuardrailEvent content actor timestamp now =
+ Lucid.div_ [Lucid.class_ "timeline-guardrail"] <| do
+ Lucid.div_ [Lucid.class_ "event-header"] <| do
+ Lucid.span_ [Lucid.class_ "event-icon"] "⚠️"
+ Lucid.span_ [Lucid.class_ "event-label"] "Guardrail"
+ renderActorLabel actor
+ renderRelativeTimestamp now timestamp
+ Lucid.div_ [Lucid.class_ "event-content guardrail-content"] (Lucid.toHtml content)
+
+renderGenericEvent :: (Monad m) => Text -> Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
+renderGenericEvent eventType content actor timestamp now =
+ Lucid.div_ [Lucid.class_ "timeline-generic"] <| do
+ Lucid.div_ [Lucid.class_ "event-header"] <| do
+ Lucid.span_ [Lucid.class_ "event-icon"] "📝"
+ Lucid.span_ [Lucid.class_ "event-label"] (Lucid.toHtml eventType)
+ renderActorLabel actor
+ renderRelativeTimestamp now timestamp
+ unless (Text.null content) <| Lucid.div_ [Lucid.class_ "event-content"] (Lucid.toHtml content)
+
+parseToolCallContent :: Text -> (Text, Text)
+parseToolCallContent content =
+ case Text.breakOn ":" content of
+ (name, rest)
+ | Text.null rest -> (content, "")
+ | otherwise -> (Text.strip name, Text.strip (Text.drop 1 rest))
+
+formatToolCallSummary :: Text -> Text -> Text
+formatToolCallSummary toolName argsJson =
+ case Aeson.decode (LBS.fromStrict (str argsJson)) of
+ Just (Aeson.Object obj) ->
+ let keyArg = case toolName of
+ "run_bash" -> KeyMap.lookup "command" obj
+ "read_file" -> KeyMap.lookup "path" obj
+ "edit_file" -> KeyMap.lookup "path" obj
+ "write_file" -> KeyMap.lookup "path" obj
+ "search_codebase" -> KeyMap.lookup "pattern" obj
+ "glob_files" -> KeyMap.lookup "pattern" obj
+ "list_directory" -> KeyMap.lookup "path" obj
+ _ -> Nothing
+ in case keyArg of
+ Just (Aeson.String s) -> "`" <> Text.take 100 s <> "`"
+ _ -> Text.take 80 argsJson
+ _ -> Text.take 80 argsJson
+
+renderCollapsibleOutput :: (Monad m) => Text -> Lucid.HtmlT m ()
+renderCollapsibleOutput content =
+ let lineCount = length (Text.lines content)
+ in if lineCount > 20
+ then
+ Lucid.details_ [Lucid.class_ "output-collapsible"] <| do
+ Lucid.summary_ (Lucid.toHtml (tshow lineCount <> " lines"))
+ Lucid.pre_ [Lucid.class_ "tool-output-pre"] (Lucid.toHtml content)
+ else Lucid.pre_ [Lucid.class_ "tool-output-pre"] (Lucid.toHtml content)
+
+renderDecodedToolResult :: (Monad m) => Text -> Lucid.HtmlT m ()
+renderDecodedToolResult content =
+ case Aeson.decode (LBS.fromStrict (str content)) of
+ Just (Aeson.Object obj) ->
+ case KeyMap.lookup "output" obj of
+ Just (Aeson.String output) -> Lucid.toHtml output
+ _ -> Lucid.toHtml content
+ _ -> Lucid.toHtml content
+
+timelineScrollScript :: (Monad m) => Lucid.HtmlT m ()
+timelineScrollScript =
+ Lucid.script_
+ [ Lucid.type_ "text/javascript"
+ ]
+ ( Text.unlines
+ [ "(function() {",
+ " var log = document.querySelector('.timeline-events');",
+ " if (log) {",
+ " var isNearBottom = log.scrollHeight - log.scrollTop - log.clientHeight < 100;",
+ " if (isNearBottom) {",
+ " log.scrollTop = log.scrollHeight;",
+ " }",
+ " }",
+ "})();"
+ ]
+ )
diff --git a/Omni/Jr/Web/Handlers.hs b/Omni/Jr/Web/Handlers.hs
new file mode 100644
index 00000000..463c9f7c
--- /dev/null
+++ b/Omni/Jr/Web/Handlers.hs
@@ -0,0 +1,642 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- : dep warp
+-- : dep servant-server
+-- : dep lucid
+-- : dep servant-lucid
+-- : dep process
+-- : dep aeson
+module Omni.Jr.Web.Handlers
+ ( server,
+ api,
+ streamAgentEvents,
+ )
+where
+
+import Alpha
+import qualified Control.Concurrent as Concurrent
+import qualified Data.Aeson as Aeson
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.List as List
+import qualified Data.Text as Text
+import qualified Data.Text.Lazy as LazyText
+import Data.Time (UTCTime, getCurrentTime)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
+import qualified Omni.Fact as Fact
+import qualified Omni.Jr.Web.Style as Style
+import Omni.Jr.Web.Types
+import qualified Omni.Task.Core as TaskCore
+import Servant
+import qualified Servant.HTML.Lucid as Lucid
+import qualified Servant.Types.SourceT as Source
+import qualified System.Exit as Exit
+import qualified System.Process as Process
+
+type PostRedirect = Verb 'POST 303 '[Lucid.HTML] (Headers '[Header "Location" Text] NoContent)
+
+type API =
+ QueryParam "range" Text :> Get '[Lucid.HTML] HomePage
+ :<|> "style.css" :> Get '[CSS] LazyText.Text
+ :<|> "ready" :> QueryParam "sort" Text :> Get '[Lucid.HTML] ReadyQueuePage
+ :<|> "blocked" :> QueryParam "sort" Text :> Get '[Lucid.HTML] BlockedPage
+ :<|> "intervention" :> QueryParam "sort" Text :> Get '[Lucid.HTML] InterventionPage
+ :<|> "stats" :> QueryParam "epic" Text :> Get '[Lucid.HTML] StatsPage
+ :<|> "tasks"
+ :> QueryParam "status" Text
+ :> QueryParam "priority" Text
+ :> QueryParam "namespace" Text
+ :> QueryParam "type" Text
+ :> QueryParam "sort" Text
+ :> Get '[Lucid.HTML] TaskListPage
+ :<|> "kb" :> Get '[Lucid.HTML] KBPage
+ :<|> "kb" :> "create" :> ReqBody '[FormUrlEncoded] FactCreateForm :> PostRedirect
+ :<|> "kb" :> Capture "id" Int :> Get '[Lucid.HTML] FactDetailPage
+ :<|> "kb" :> Capture "id" Int :> "edit" :> ReqBody '[FormUrlEncoded] FactEditForm :> PostRedirect
+ :<|> "kb" :> Capture "id" Int :> "delete" :> PostRedirect
+ :<|> "epics" :> QueryParam "sort" Text :> Get '[Lucid.HTML] EpicsPage
+ :<|> "tasks" :> Capture "id" Text :> Get '[Lucid.HTML] TaskDetailPage
+ :<|> "tasks" :> Capture "id" Text :> "status" :> ReqBody '[FormUrlEncoded] StatusForm :> Post '[Lucid.HTML] StatusBadgePartial
+ :<|> "tasks" :> Capture "id" Text :> "priority" :> ReqBody '[FormUrlEncoded] PriorityForm :> Post '[Lucid.HTML] PriorityBadgePartial
+ :<|> "tasks" :> Capture "id" Text :> "description" :> "view" :> Get '[Lucid.HTML] DescriptionViewPartial
+ :<|> "tasks" :> Capture "id" Text :> "description" :> "edit" :> Get '[Lucid.HTML] DescriptionEditPartial
+ :<|> "tasks" :> Capture "id" Text :> "description" :> ReqBody '[FormUrlEncoded] DescriptionForm :> Post '[Lucid.HTML] DescriptionViewPartial
+ :<|> "tasks" :> Capture "id" Text :> "notes" :> ReqBody '[FormUrlEncoded] NotesForm :> PostRedirect
+ :<|> "tasks" :> Capture "id" Text :> "comment" :> ReqBody '[FormUrlEncoded] CommentForm :> PostRedirect
+ :<|> "tasks" :> Capture "id" Text :> "review" :> Get '[Lucid.HTML] TaskReviewPage
+ :<|> "tasks" :> Capture "id" Text :> "diff" :> Capture "commit" Text :> Get '[Lucid.HTML] TaskDiffPage
+ :<|> "tasks" :> Capture "id" Text :> "accept" :> PostRedirect
+ :<|> "tasks" :> Capture "id" Text :> "reject" :> ReqBody '[FormUrlEncoded] RejectForm :> PostRedirect
+ :<|> "tasks" :> Capture "id" Text :> "reset-retries" :> PostRedirect
+ :<|> "partials" :> "recent-activity-new" :> QueryParam "since" Int :> Get '[Lucid.HTML] RecentActivityNewPartial
+ :<|> "partials" :> "recent-activity-more" :> QueryParam "offset" Int :> Get '[Lucid.HTML] RecentActivityMorePartial
+ :<|> "partials" :> "ready-count" :> Get '[Lucid.HTML] ReadyCountPartial
+ :<|> "partials"
+ :> "task-list"
+ :> QueryParam "status" Text
+ :> QueryParam "priority" Text
+ :> QueryParam "namespace" Text
+ :> QueryParam "type" Text
+ :> QueryParam "sort" Text
+ :> Get '[Lucid.HTML] TaskListPartial
+ :<|> "partials" :> "task" :> Capture "id" Text :> "metrics" :> Get '[Lucid.HTML] TaskMetricsPartial
+ :<|> "partials" :> "task" :> Capture "id" Text :> "events" :> QueryParam "since" Int :> Get '[Lucid.HTML] AgentEventsPartial
+ :<|> "tasks" :> Capture "id" Text :> "events" :> "stream" :> StreamGet NoFraming SSE (SourceIO ByteString)
+
+api :: Proxy API
+api = Proxy
+
+server :: Server API
+server =
+ homeHandler
+ :<|> styleHandler
+ :<|> readyQueueHandler
+ :<|> blockedHandler
+ :<|> interventionHandler
+ :<|> statsHandler
+ :<|> taskListHandler
+ :<|> kbHandler
+ :<|> factCreateHandler
+ :<|> factDetailHandler
+ :<|> factEditHandler
+ :<|> factDeleteHandler
+ :<|> epicsHandler
+ :<|> taskDetailHandler
+ :<|> taskStatusHandler
+ :<|> taskPriorityHandler
+ :<|> descriptionViewHandler
+ :<|> descriptionEditHandler
+ :<|> descriptionPostHandler
+ :<|> taskNotesHandler
+ :<|> taskCommentHandler
+ :<|> taskReviewHandler
+ :<|> taskDiffHandler
+ :<|> taskAcceptHandler
+ :<|> taskRejectHandler
+ :<|> taskResetRetriesHandler
+ :<|> recentActivityNewHandler
+ :<|> recentActivityMoreHandler
+ :<|> readyCountHandler
+ :<|> taskListPartialHandler
+ :<|> taskMetricsPartialHandler
+ :<|> agentEventsPartialHandler
+ :<|> taskEventsStreamHandler
+ where
+ styleHandler :: Servant.Handler LazyText.Text
+ styleHandler = pure Style.css
+
+ homeHandler :: Maybe Text -> Servant.Handler HomePage
+ homeHandler maybeRangeText = do
+ now <- liftIO getCurrentTime
+ let range = parseTimeRange maybeRangeText
+ maybeStart = getTimeRangeStart range now
+ allTasks <- liftIO TaskCore.loadTasks
+ 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 filteredTasks > 5
+ pure (HomePage stats readyTasks recentTasks hasMoreRecent globalMetrics range now)
+
+ readyQueueHandler :: Maybe Text -> Servant.Handler ReadyQueuePage
+ readyQueueHandler maybeSortText = do
+ now <- liftIO getCurrentTime
+ readyTasks <- liftIO TaskCore.getReadyTasks
+ let sortOrder = parseSortOrder maybeSortText
+ sortedTasks = sortTasks sortOrder readyTasks
+ pure (ReadyQueuePage sortedTasks sortOrder now)
+
+ blockedHandler :: Maybe Text -> Servant.Handler BlockedPage
+ blockedHandler maybeSortText = do
+ now <- liftIO getCurrentTime
+ blockedTasks <- liftIO TaskCore.getBlockedTasks
+ allTasks <- liftIO TaskCore.loadTasks
+ let sortOrder = parseSortOrder maybeSortText
+ tasksWithImpact = [(t, TaskCore.getBlockingImpact allTasks t) | t <- blockedTasks]
+ sorted = List.sortBy (comparing (Down <. snd)) tasksWithImpact
+ pure (BlockedPage sorted sortOrder now)
+
+ interventionHandler :: Maybe Text -> Servant.Handler InterventionPage
+ interventionHandler maybeSortText = do
+ now <- liftIO getCurrentTime
+ actionItems <- liftIO TaskCore.getHumanActionItems
+ let sortOrder = parseSortOrder maybeSortText
+ pure (InterventionPage actionItems sortOrder now)
+
+ statsHandler :: Maybe Text -> Servant.Handler StatsPage
+ statsHandler maybeEpic = do
+ let epicId = emptyToNothing maybeEpic
+ stats <- liftIO <| TaskCore.getTaskStats epicId
+ pure (StatsPage stats epicId)
+
+ taskListHandler :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Servant.Handler TaskListPage
+ taskListHandler maybeStatusText maybePriorityText maybeNamespace maybeTypeText maybeSortText = 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
+ sortOrder = parseSortOrder maybeSortText
+ filteredTasks = sortTasks sortOrder (applyFilters filters allTasks)
+ pure (TaskListPage filteredTasks filters sortOrder now)
+
+ kbHandler :: Servant.Handler KBPage
+ kbHandler = do
+ facts <- liftIO Fact.getAllFacts
+ pure (KBPage facts)
+
+ factCreateHandler :: FactCreateForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
+ factCreateHandler (FactCreateForm project content filesText confText) = do
+ let files = filter (not <. Text.null) (Text.splitOn "," (Text.strip filesText))
+ confidence = fromMaybe 0.8 (readMaybe (Text.unpack confText))
+ fid <- liftIO (Fact.createFact project content files Nothing confidence)
+ pure <| addHeader ("/kb/" <> tshow fid) NoContent
+
+ 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 now)
+
+ factEditHandler :: Int -> FactEditForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
+ factEditHandler fid (FactEditForm content filesText confText) = do
+ let files = filter (not <. Text.null) (Text.splitOn "," (Text.strip filesText))
+ confidence = fromMaybe 0.8 (readMaybe (Text.unpack confText))
+ liftIO (Fact.updateFact fid content files confidence)
+ pure <| addHeader ("/kb/" <> tshow fid) NoContent
+
+ factDeleteHandler :: Int -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
+ factDeleteHandler fid = do
+ liftIO (Fact.deleteFact fid)
+ pure <| addHeader "/kb" NoContent
+
+ epicsHandler :: Maybe Text -> Servant.Handler EpicsPage
+ epicsHandler maybeSortText = do
+ allTasks <- liftIO TaskCore.loadTasks
+ let epicTasks = filter (\t -> TaskCore.taskType t == TaskCore.Epic) allTasks
+ sortOrder = parseSortOrder maybeSortText
+ sortedEpics = sortTasks sortOrder epicTasks
+ pure (EpicsPage sortedEpics allTasks sortOrder)
+
+ parseStatus :: Text -> Maybe TaskCore.Status
+ parseStatus = readMaybe <. Text.unpack
+
+ parsePriority :: Text -> Maybe TaskCore.Priority
+ parsePriority = readMaybe <. Text.unpack
+
+ parseTaskType :: Text -> Maybe TaskCore.TaskType
+ parseTaskType = readMaybe <. Text.unpack
+
+ emptyToNothing :: Maybe Text -> Maybe Text
+ emptyToNothing (Just t) | Text.null (Text.strip t) = Nothing
+ emptyToNothing x = x
+
+ applyFilters :: TaskFilters -> [TaskCore.Task] -> [TaskCore.Task]
+ applyFilters filters = filter matchesAllFilters
+ where
+ matchesAllFilters task =
+ matchesStatus task
+ && matchesPriority task
+ && matchesNamespace task
+ && matchesType task
+
+ matchesStatus task = case filterStatus filters of
+ Nothing -> True
+ Just s -> TaskCore.taskStatus task == s
+
+ matchesPriority task = case filterPriority filters of
+ Nothing -> True
+ Just p -> TaskCore.taskPriority task == p
+
+ matchesNamespace task = case filterNamespace filters of
+ Nothing -> True
+ Just ns -> case TaskCore.taskNamespace task of
+ Nothing -> False
+ Just taskNs -> ns `Text.isPrefixOf` taskNs
+
+ matchesType task = case filterType filters of
+ Nothing -> True
+ Just t -> TaskCore.taskType task == t
+
+ 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)
+ Just task -> do
+ activities <- liftIO (TaskCore.getActivitiesForTask tid)
+ retryCtx <- liftIO (TaskCore.getRetryContext tid)
+ commits <- liftIO (getCommitsForTask tid)
+ aggMetrics <-
+ if TaskCore.taskType task == TaskCore.Epic
+ then Just </ liftIO (TaskCore.getAggregatedMetrics tid)
+ else pure Nothing
+ agentEvents <- liftIO (TaskCore.getAllEventsForTask tid)
+ pure (TaskDetailFound task tasks activities retryCtx commits aggMetrics agentEvents now)
+
+ taskStatusHandler :: Text -> StatusForm -> Servant.Handler StatusBadgePartial
+ taskStatusHandler tid (StatusForm newStatus) = do
+ liftIO <| TaskCore.updateTaskStatusWithActor tid newStatus [] TaskCore.Human
+ pure (StatusBadgePartial newStatus tid)
+
+ taskPriorityHandler :: Text -> PriorityForm -> Servant.Handler PriorityBadgePartial
+ taskPriorityHandler tid (PriorityForm newPriority) = do
+ _ <- liftIO <| TaskCore.editTask tid (\t -> t {TaskCore.taskPriority = newPriority})
+ pure (PriorityBadgePartial newPriority tid)
+
+ descriptionViewHandler :: Text -> Servant.Handler DescriptionViewPartial
+ descriptionViewHandler tid = do
+ tasks <- liftIO TaskCore.loadTasks
+ case TaskCore.findTask tid tasks of
+ Nothing -> throwError err404
+ Just task -> pure (DescriptionViewPartial tid (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic))
+
+ descriptionEditHandler :: Text -> Servant.Handler DescriptionEditPartial
+ descriptionEditHandler tid = do
+ tasks <- liftIO TaskCore.loadTasks
+ case TaskCore.findTask tid tasks of
+ Nothing -> throwError err404
+ Just task -> pure (DescriptionEditPartial tid (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic))
+
+ descriptionPostHandler :: Text -> DescriptionForm -> Servant.Handler DescriptionViewPartial
+ descriptionPostHandler tid (DescriptionForm desc) = do
+ let descText = Text.strip desc
+ _ <- liftIO <| TaskCore.editTask tid (\t -> t {TaskCore.taskDescription = descText})
+ tasks <- liftIO TaskCore.loadTasks
+ case TaskCore.findTask tid tasks of
+ Nothing -> throwError err404
+ Just task -> pure (DescriptionViewPartial tid (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic))
+
+ taskNotesHandler :: Text -> NotesForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
+ taskNotesHandler tid (NotesForm notes) = do
+ liftIO <| TaskCore.updateRetryNotes tid notes
+ pure <| addHeader ("/tasks/" <> tid) NoContent
+
+ taskCommentHandler :: Text -> CommentForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
+ taskCommentHandler tid (CommentForm commentText) = do
+ _ <- liftIO (TaskCore.addComment tid commentText TaskCore.Human)
+ pure <| addHeader ("/tasks/" <> tid) NoContent
+
+ taskReviewHandler :: Text -> Servant.Handler TaskReviewPage
+ taskReviewHandler tid = do
+ tasks <- liftIO TaskCore.loadTasks
+ case TaskCore.findTask tid tasks of
+ Nothing -> pure (ReviewPageNotFound tid)
+ Just task -> do
+ reviewInfo <- liftIO <| getReviewInfo tid
+ pure (ReviewPageFound task reviewInfo)
+
+ taskDiffHandler :: Text -> Text -> Servant.Handler TaskDiffPage
+ taskDiffHandler tid commitSha = do
+ diffOutput <- liftIO <| getDiffForCommit commitSha
+ case diffOutput of
+ Nothing -> pure (DiffPageNotFound tid commitSha)
+ Just output -> pure (DiffPageFound tid commitSha output)
+
+ taskAcceptHandler :: Text -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
+ taskAcceptHandler tid = do
+ liftIO <| do
+ TaskCore.clearRetryContext tid
+ TaskCore.updateTaskStatusWithActor tid TaskCore.Done [] TaskCore.Human
+ pure <| addHeader ("/tasks/" <> tid) NoContent
+
+ taskRejectHandler :: Text -> RejectForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
+ taskRejectHandler tid (RejectForm maybeNotes) = do
+ liftIO <| do
+ maybeCommit <- findCommitForTask tid
+ let commitSha = fromMaybe "" maybeCommit
+ maybeCtx <- TaskCore.getRetryContext tid
+ let attempt = maybe 1 (\ctx -> TaskCore.retryAttempt ctx + 1) maybeCtx
+ let currentReason = "attempt " <> tshow attempt <> ": rejected: " <> fromMaybe "(no notes)" maybeNotes
+ let accumulatedReason = case maybeCtx of
+ Nothing -> currentReason
+ Just ctx -> TaskCore.retryReason ctx <> "\n" <> currentReason
+ TaskCore.setRetryContext
+ TaskCore.RetryContext
+ { TaskCore.retryTaskId = tid,
+ TaskCore.retryOriginalCommit = commitSha,
+ TaskCore.retryConflictFiles = [],
+ TaskCore.retryAttempt = attempt,
+ TaskCore.retryReason = accumulatedReason,
+ TaskCore.retryNotes = maybeCtx +> TaskCore.retryNotes
+ }
+ TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.Human
+ pure <| addHeader ("/tasks/" <> tid) NoContent
+
+ taskResetRetriesHandler :: Text -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
+ taskResetRetriesHandler tid = do
+ liftIO <| do
+ TaskCore.clearRetryContext tid
+ TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.Human
+ pure <| addHeader ("/tasks/" <> tid) NoContent
+
+ recentActivityNewHandler :: Maybe Int -> Servant.Handler RecentActivityNewPartial
+ recentActivityNewHandler maybeSince = do
+ allTasks <- liftIO TaskCore.loadTasks
+ let sinceTime = maybe (posixSecondsToUTCTime 0) (posixSecondsToUTCTime <. fromIntegral) maybeSince
+ sortedTasks = List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) allTasks
+ newTasks = filter (\t -> TaskCore.taskUpdatedAt t > sinceTime) sortedTasks
+ newestTs = maybe maybeSince (Just <. taskToUnixTs) (head newTasks)
+ pure (RecentActivityNewPartial newTasks newestTs)
+
+ recentActivityMoreHandler :: Maybe Int -> Servant.Handler RecentActivityMorePartial
+ recentActivityMoreHandler maybeOffset = do
+ allTasks <- liftIO TaskCore.loadTasks
+ let offset = fromMaybe 0 maybeOffset
+ pageSize = 5
+ sortedTasks = List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) allTasks
+ pageTasks = take pageSize <| drop offset sortedTasks
+ hasMore = length sortedTasks > offset + pageSize
+ nextOffset = offset + pageSize
+ pure (RecentActivityMorePartial pageTasks nextOffset hasMore)
+
+ readyCountHandler :: Servant.Handler ReadyCountPartial
+ readyCountHandler = do
+ readyTasks <- liftIO TaskCore.getReadyTasks
+ pure (ReadyCountPartial (length readyTasks))
+
+ taskListPartialHandler :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Servant.Handler TaskListPartial
+ taskListPartialHandler maybeStatusText maybePriorityText maybeNamespace maybeTypeText maybeSortText = do
+ allTasks <- liftIO TaskCore.loadTasks
+ let maybeStatus = parseStatus =<< emptyToNothing maybeStatusText
+ maybePriority = parsePriority =<< emptyToNothing maybePriorityText
+ maybeType = parseTaskType =<< emptyToNothing maybeTypeText
+ filters = TaskFilters maybeStatus maybePriority (emptyToNothing maybeNamespace) maybeType
+ sortOrder = parseSortOrder maybeSortText
+ filteredTasks = sortTasks sortOrder (applyFilters filters allTasks)
+ pure (TaskListPartial filteredTasks)
+
+ 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 now)
+
+ agentEventsPartialHandler :: Text -> Maybe Int -> Servant.Handler AgentEventsPartial
+ agentEventsPartialHandler tid _maybeSince = do
+ now <- liftIO getCurrentTime
+ events <- liftIO (TaskCore.getAllEventsForTask tid)
+ tasks <- liftIO TaskCore.loadTasks
+ let isInProgress = case TaskCore.findTask tid tasks of
+ Nothing -> False
+ Just task -> TaskCore.taskStatus task == TaskCore.InProgress
+ pure (AgentEventsPartial events isInProgress now)
+
+ taskEventsStreamHandler :: Text -> Servant.Handler (SourceIO ByteString)
+ taskEventsStreamHandler tid = do
+ maybeSession <- liftIO (TaskCore.getLatestSessionForTask tid)
+ case maybeSession of
+ Nothing -> pure (Source.source [])
+ Just sid -> liftIO (streamAgentEvents tid sid)
+
+streamAgentEvents :: Text -> Text -> IO (SourceIO ByteString)
+streamAgentEvents tid sid = do
+ existingEvents <- TaskCore.getEventsForSession sid
+ let lastId = if null existingEvents then 0 else maximum (map TaskCore.storedEventId existingEvents)
+ let existingSSE = map eventToSSE existingEvents
+ pure <| Source.fromStepT <| streamEventsStep tid sid lastId existingSSE True
+
+streamEventsStep :: Text -> Text -> Int -> [ByteString] -> Bool -> Source.StepT IO ByteString
+streamEventsStep tid sid lastId buffer sendExisting = case (sendExisting, buffer) of
+ (True, b : bs) -> Source.Yield b (streamEventsStep tid sid lastId bs True)
+ (True, []) -> streamEventsStep tid sid lastId [] False
+ (False, _) ->
+ Source.Effect <| do
+ tasks <- TaskCore.loadTasks
+ let isComplete = case TaskCore.findTask tid tasks of
+ Nothing -> True
+ Just task -> TaskCore.taskStatus task /= TaskCore.InProgress
+
+ if isComplete
+ then do
+ let completeSSE = formatSSE "complete" "{}"
+ pure <| Source.Yield completeSSE Source.Stop
+ else do
+ Concurrent.threadDelay 500000
+ newEvents <- TaskCore.getEventsSince sid lastId
+ if null newEvents
+ then pure <| streamEventsStep tid sid lastId [] False
+ else do
+ let newLastId = maximum (map TaskCore.storedEventId newEvents)
+ let newSSE = map eventToSSE newEvents
+ case newSSE of
+ (e : es) -> pure <| Source.Yield e (streamEventsStep tid sid newLastId es False)
+ [] -> pure <| streamEventsStep tid sid newLastId [] False
+
+eventToSSE :: TaskCore.StoredEvent -> ByteString
+eventToSSE event =
+ let eventType = Text.toLower (TaskCore.storedEventType event)
+ content = TaskCore.storedEventContent event
+ jsonData = case eventType of
+ "assistant" -> Aeson.object ["content" Aeson..= content]
+ "toolcall" ->
+ let (tool, args) = parseToolCallContent content
+ in Aeson.object ["tool" Aeson..= tool, "args" Aeson..= Aeson.object ["data" Aeson..= args]]
+ "toolresult" ->
+ Aeson.object ["tool" Aeson..= ("unknown" :: Text), "success" Aeson..= True, "output" Aeson..= content]
+ "cost" -> Aeson.object ["cost" Aeson..= content]
+ "error" -> Aeson.object ["error" Aeson..= content]
+ "complete" -> Aeson.object []
+ _ -> Aeson.object ["content" Aeson..= content]
+ in formatSSE eventType (str (Aeson.encode jsonData))
+
+formatSSE :: Text -> ByteString -> ByteString
+formatSSE eventType jsonData =
+ str
+ <| "event: "
+ <> eventType
+ <> "\n"
+ <> "data: "
+ <> str jsonData
+ <> "\n\n"
+
+parseToolCallContent :: Text -> (Text, Text)
+parseToolCallContent content =
+ case Text.breakOn ":" content of
+ (name, rest)
+ | Text.null rest -> (content, "")
+ | otherwise -> (Text.strip name, Text.strip (Text.drop 1 rest))
+
+taskToUnixTs :: TaskCore.Task -> Int
+taskToUnixTs t = ceiling (utcTimeToPOSIXSeconds (TaskCore.taskUpdatedAt t))
+
+getReviewInfo :: Text -> IO ReviewInfo
+getReviewInfo tid = do
+ maybeCommit <- findCommitForTask tid
+ case maybeCommit of
+ Nothing -> pure ReviewNoCommit
+ Just commitSha -> do
+ conflictResult <- checkMergeConflict (Text.unpack commitSha)
+ case conflictResult of
+ Just conflictFiles -> pure (ReviewMergeConflict commitSha conflictFiles)
+ Nothing -> do
+ (_, diffOut, _) <-
+ Process.readProcessWithExitCode
+ "git"
+ ["show", Text.unpack commitSha]
+ ""
+ pure (ReviewReady commitSha (Text.pack diffOut))
+
+getDiffForCommit :: Text -> IO (Maybe Text)
+getDiffForCommit commitSha = do
+ (code, diffOut, _) <-
+ Process.readProcessWithExitCode
+ "git"
+ ["show", Text.unpack commitSha]
+ ""
+ case code of
+ Exit.ExitSuccess -> pure (Just (Text.pack diffOut))
+ Exit.ExitFailure _ -> pure Nothing
+
+findCommitForTask :: Text -> IO (Maybe Text)
+findCommitForTask tid = do
+ let grepArg = "--grep=" <> Text.unpack tid
+ (code, shaOut, _) <-
+ Process.readProcessWithExitCode
+ "git"
+ ["log", "--pretty=format:%H", "-n", "1", grepArg]
+ ""
+ if code /= Exit.ExitSuccess || null shaOut
+ then pure Nothing
+ else case List.lines shaOut of
+ (x : _) -> pure (Just (Text.pack x))
+ [] -> pure Nothing
+
+getCommitsForTask :: Text -> IO [GitCommit]
+getCommitsForTask tid = do
+ let grepArg = "--grep=Task-Id: " <> Text.unpack tid
+ (code, out, _) <-
+ Process.readProcessWithExitCode
+ "git"
+ ["log", "--pretty=format:%H|%h|%s|%an|%ar", grepArg]
+ ""
+ if code /= Exit.ExitSuccess || null out
+ then pure []
+ else do
+ let commitLines = filter (not <. null) (List.lines out)
+ traverse parseCommitLine commitLines
+ where
+ parseCommitLine :: String -> IO GitCommit
+ parseCommitLine line =
+ case Text.splitOn "|" (Text.pack line) of
+ [sha, shortSha, summary, author, relDate] -> do
+ filesCount <- getFilesChangedCount (Text.unpack sha)
+ pure
+ GitCommit
+ { commitHash = sha,
+ commitShortHash = shortSha,
+ commitSummary = summary,
+ commitAuthor = author,
+ commitRelativeDate = relDate,
+ commitFilesChanged = filesCount
+ }
+ _ ->
+ pure
+ GitCommit
+ { commitHash = Text.pack line,
+ commitShortHash = Text.take 7 (Text.pack line),
+ commitSummary = "(parse error)",
+ commitAuthor = "",
+ commitRelativeDate = "",
+ commitFilesChanged = 0
+ }
+
+ getFilesChangedCount :: String -> IO Int
+ getFilesChangedCount sha = do
+ (code', out', _) <-
+ Process.readProcessWithExitCode
+ "git"
+ ["show", "--stat", "--format=", sha]
+ ""
+ pure
+ <| if code' /= Exit.ExitSuccess
+ then 0
+ else
+ let statLines = filter (not <. null) (List.lines out')
+ in max 0 (length statLines - 1)
+
+checkMergeConflict :: String -> IO (Maybe [Text])
+checkMergeConflict commitSha = do
+ (_, origHead, _) <- Process.readProcessWithExitCode "git" ["rev-parse", "HEAD"] ""
+
+ (cpCode, _, cpErr) <-
+ Process.readProcessWithExitCode
+ "git"
+ ["cherry-pick", "--no-commit", commitSha]
+ ""
+
+ _ <- Process.readProcessWithExitCode "git" ["cherry-pick", "--abort"] ""
+ _ <- Process.readProcessWithExitCode "git" ["reset", "--hard", List.head (List.lines origHead)] ""
+
+ case cpCode of
+ Exit.ExitSuccess -> pure Nothing
+ Exit.ExitFailure _ -> do
+ let errLines = Text.lines (Text.pack cpErr)
+ conflictLines = filter (Text.isPrefixOf "CONFLICT") errLines
+ files = mapMaybe extractConflictFile conflictLines
+ pure (Just (if null files then ["(unknown files)"] else files))
+
+extractConflictFile :: Text -> Maybe Text
+extractConflictFile line =
+ case Text.breakOn "Merge conflict in " line of
+ (_, rest)
+ | not (Text.null rest) -> Just (Text.strip (Text.drop 18 rest))
+ _ -> case Text.breakOn "in " line of
+ (_, rest)
+ | not (Text.null rest) -> Just (Text.strip (Text.drop 3 rest))
+ _ -> Nothing
diff --git a/Omni/Jr/Web/Pages.hs b/Omni/Jr/Web/Pages.hs
new file mode 100644
index 00000000..8e335eaa
--- /dev/null
+++ b/Omni/Jr/Web/Pages.hs
@@ -0,0 +1,866 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- : dep lucid
+-- : dep servant-lucid
+module Omni.Jr.Web.Pages
+ ( -- * Re-export page types
+ module Omni.Jr.Web.Types,
+ )
+where
+
+import Alpha
+import Data.List (init)
+import qualified Data.Text as Text
+import Data.Time (UTCTime)
+import qualified Lucid
+import qualified Lucid.Base as Lucid
+import Numeric (showFFloat)
+import Omni.Jr.Web.Components
+ ( Breadcrumb (..),
+ SortOrder (..),
+ complexityBadge,
+ epicProgressBar,
+ getDescendants,
+ metaSep,
+ multiColorProgressBar,
+ pageBody,
+ pageBodyWithCrumbs,
+ pageHead,
+ priorityBadgeWithForm,
+ renderAggregatedMetrics,
+ renderBlockedTaskCard,
+ renderEpicCardWithStats,
+ renderEpicReviewCard,
+ renderListGroupItem,
+ renderRelativeTimestamp,
+ renderRetryContextBanner,
+ renderTaskCard,
+ renderUnifiedTimeline,
+ sortDropdown,
+ sortOrderToParam,
+ statusBadge,
+ statusBadgeWithForm,
+ taskBreadcrumbs,
+ )
+import Omni.Jr.Web.Types
+ ( BlockedPage (..),
+ DescriptionViewPartial (..),
+ EpicsPage (..),
+ FactDetailPage (..),
+ GitCommit (..),
+ HomePage (..),
+ InterventionPage (..),
+ KBPage (..),
+ ReadyQueuePage (..),
+ ReviewInfo (..),
+ StatsPage (..),
+ TaskDetailPage (..),
+ TaskDiffPage (..),
+ TaskFilters (..),
+ TaskListPage (..),
+ TaskReviewPage (..),
+ TimeRange (..),
+ filterNamespace,
+ filterPriority,
+ filterStatus,
+ sortTasks,
+ timeRangeToParam,
+ )
+import qualified Omni.Task.Core as TaskCore
+
+taskToUnixTs :: TaskCore.Task -> Int
+taskToUnixTs t =
+ let ts = TaskCore.taskUpdatedAt t
+ in floor (realToFrac (Data.Time.utctDayTime ts) :: Double)
+
+instance Lucid.ToHtml HomePage where
+ toHtmlRaw = Lucid.toHtml
+ 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"
+ statCard "Review" (TaskCore.reviewTasks stats) "badge-review" "/tasks?status=Review"
+ statCard "Approved" (TaskCore.approvedTasks stats) "badge-approved" "/tasks?status=Approved"
+ statCard "Done" (TaskCore.doneTasks stats) "badge-done" "/tasks?status=Done"
+ metricCard "Cost" (formatCost (TaskCore.aggTotalCostCents globalMetrics))
+ metricCard "Duration" (formatDuration (TaskCore.aggTotalDurationSeconds globalMetrics))
+
+ Lucid.h2_ <| do
+ "Ready Queue "
+ Lucid.span_
+ [ Lucid.class_ "ready-count",
+ Lucid.makeAttribute "hx-get" "/partials/ready-count",
+ Lucid.makeAttribute "hx-trigger" "every 5s"
+ ]
+ <| do
+ Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "ready-link"]
+ <| Lucid.toHtml ("(" <> tshow (length readyTasks) <> " tasks)")
+ if null readyTasks
+ then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks ready for work."
+ else
+ Lucid.div_ [Lucid.class_ "list-group"]
+ <| traverse_ renderListGroupItem (take 5 readyTasks)
+
+ Lucid.h2_ "Recent Activity"
+ let newestTimestamp = maybe 0 taskToUnixTs (head recentTasks)
+ Lucid.div_
+ [ Lucid.class_ "recent-activity",
+ Lucid.id_ "recent-activity",
+ Lucid.makeAttribute "data-newest-ts" (tshow newestTimestamp),
+ Lucid.makeAttribute "hx-get" "/partials/recent-activity-new",
+ Lucid.makeAttribute "hx-trigger" "every 10s",
+ Lucid.makeAttribute "hx-vals" "js:{since: document.getElementById('recent-activity')?.dataset?.newestTs || 0}",
+ Lucid.makeAttribute "hx-target" "#activity-list",
+ Lucid.makeAttribute "hx-swap" "afterbegin"
+ ]
+ <| do
+ Lucid.div_ [Lucid.id_ "activity-list", Lucid.class_ "list-group"]
+ <| traverse_ renderListGroupItem recentTasks
+ when hasMoreRecent
+ <| Lucid.button_
+ [ Lucid.id_ "activity-load-more",
+ Lucid.class_ "btn btn-secondary load-more-btn",
+ Lucid.makeAttribute "hx-get" "/partials/recent-activity-more?offset=5",
+ Lucid.makeAttribute "hx-target" "#activity-list",
+ Lucid.makeAttribute "hx-swap" "beforeend"
+ ]
+ "Load More"
+ where
+ statCard :: (Monad m) => Text -> Int -> Text -> Text -> Lucid.HtmlT m ()
+ statCard label count badgeClass href =
+ Lucid.a_ [Lucid.href_ href, Lucid.class_ ("stat-card " <> badgeClass)] <| do
+ Lucid.div_ [Lucid.class_ "stat-count"] (Lucid.toHtml (tshow count))
+ Lucid.div_ [Lucid.class_ "stat-label"] (Lucid.toHtml label)
+
+ metricCard :: (Monad m) => Text -> Text -> Lucid.HtmlT m ()
+ metricCard label value =
+ Lucid.div_ [Lucid.class_ "stat-card badge-neutral"] <| do
+ Lucid.div_ [Lucid.class_ "stat-count"] (Lucid.toHtml value)
+ Lucid.div_ [Lucid.class_ "stat-label"] (Lucid.toHtml label)
+
+ formatCost :: Int -> Text
+ formatCost cents =
+ let dollars = fromIntegral cents / 100.0 :: Double
+ in Text.pack ("$" <> showFFloat (Just 2) dollars "")
+
+ formatDuration :: Int -> Text
+ formatDuration totalSeconds
+ | totalSeconds < 60 = tshow totalSeconds <> "s"
+ | totalSeconds < 3600 =
+ let mins = totalSeconds `div` 60
+ in tshow mins <> "m"
+ | otherwise =
+ let hours = totalSeconds `div` 3600
+ 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 currentSort _now) =
+ let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Ready Queue" Nothing]
+ in Lucid.doctypehtml_ <| do
+ pageHead "Ready Queue - Jr"
+ pageBodyWithCrumbs crumbs <| do
+ Lucid.div_ [Lucid.class_ "container"] <| do
+ Lucid.div_ [Lucid.class_ "page-header-row"] <| do
+ Lucid.h1_ <| Lucid.toHtml ("Ready Queue (" <> tshow (length tasks) <> " tasks)")
+ sortDropdown "/ready" currentSort
+ if null tasks
+ then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks are ready for work."
+ else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard tasks
+
+instance Lucid.ToHtml BlockedPage where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (BlockedPage tasksWithImpact currentSort _now) =
+ let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Blocked" Nothing]
+ in Lucid.doctypehtml_ <| do
+ pageHead "Blocked Tasks - Jr"
+ pageBodyWithCrumbs crumbs <| do
+ Lucid.div_ [Lucid.class_ "container"] <| do
+ Lucid.div_ [Lucid.class_ "page-header-row"] <| do
+ Lucid.h1_ <| Lucid.toHtml ("Blocked Tasks (" <> tshow (length tasksWithImpact) <> " tasks)")
+ sortDropdown "/blocked" currentSort
+ Lucid.p_ [Lucid.class_ "info-msg"] "Tasks with unmet blocking dependencies, sorted by blocking impact."
+ if null tasksWithImpact
+ then Lucid.p_ [Lucid.class_ "empty-msg"] "No blocked tasks."
+ else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderBlockedTaskCard tasksWithImpact
+
+instance Lucid.ToHtml InterventionPage where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (InterventionPage actionItems currentSort _now) =
+ let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Needs Human Action" Nothing]
+ failed = TaskCore.failedTasks actionItems
+ epicsReady = TaskCore.epicsInReview actionItems
+ needsHelp = TaskCore.tasksNeedingHelp actionItems
+ totalCount = length failed + length epicsReady + length needsHelp
+ in Lucid.doctypehtml_ <| do
+ pageHead "Needs Human Action - Jr"
+ pageBodyWithCrumbs crumbs <| do
+ Lucid.div_ [Lucid.class_ "container"] <| do
+ Lucid.div_ [Lucid.class_ "page-header-row"] <| do
+ Lucid.h1_ <| Lucid.toHtml ("Needs Human Action (" <> tshow totalCount <> " items)")
+ sortDropdown "/intervention" currentSort
+ if totalCount == 0
+ then Lucid.p_ [Lucid.class_ "empty-msg"] "No items need human action."
+ else do
+ unless (null failed) <| do
+ Lucid.h2_ [Lucid.class_ "section-header"] <| Lucid.toHtml ("Failed Tasks (" <> tshow (length failed) <> ")")
+ Lucid.p_ [Lucid.class_ "info-msg"] "Tasks that have failed 3+ times and need human help."
+ Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard (sortTasks currentSort failed)
+ unless (null epicsReady) <| do
+ Lucid.h2_ [Lucid.class_ "section-header"] <| Lucid.toHtml ("Epics Ready for Review (" <> tshow (length epicsReady) <> ")")
+ Lucid.p_ [Lucid.class_ "info-msg"] "Epics with all children completed. Verify before closing."
+ Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderEpicReviewCard epicsReady
+ unless (null needsHelp) <| do
+ Lucid.h2_ [Lucid.class_ "section-header"] <| Lucid.toHtml ("Needs Help (" <> tshow (length needsHelp) <> ")")
+ Lucid.p_ [Lucid.class_ "info-msg"] "Tasks where Jr needs human guidance or decisions."
+ Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard (sortTasks currentSort needsHelp)
+
+instance Lucid.ToHtml KBPage where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (KBPage facts) =
+ let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Knowledge Base" Nothing]
+ in Lucid.doctypehtml_ <| do
+ pageHead "Knowledge Base - Jr"
+ pageBodyWithCrumbs crumbs <| do
+ Lucid.div_ [Lucid.class_ "container"] <| do
+ Lucid.h1_ "Knowledge Base"
+ Lucid.p_ [Lucid.class_ "info-msg"] "Facts learned during task execution."
+
+ Lucid.details_ [Lucid.class_ "create-fact-section"] <| do
+ Lucid.summary_ [Lucid.class_ "btn btn-primary create-fact-toggle"] "Create New Fact"
+ Lucid.form_
+ [ Lucid.method_ "POST",
+ Lucid.action_ "/kb/create",
+ Lucid.class_ "fact-create-form"
+ ]
+ <| do
+ Lucid.div_ [Lucid.class_ "form-group"] <| do
+ Lucid.label_ [Lucid.for_ "project"] "Project:"
+ Lucid.input_
+ [ Lucid.type_ "text",
+ Lucid.name_ "project",
+ Lucid.id_ "project",
+ Lucid.class_ "form-input",
+ Lucid.required_ "required",
+ Lucid.placeholder_ "e.g., Omni/Jr"
+ ]
+ Lucid.div_ [Lucid.class_ "form-group"] <| do
+ Lucid.label_ [Lucid.for_ "content"] "Fact Content:"
+ Lucid.textarea_
+ [ Lucid.name_ "content",
+ Lucid.id_ "content",
+ Lucid.class_ "form-textarea",
+ Lucid.rows_ "4",
+ Lucid.required_ "required",
+ Lucid.placeholder_ "Describe the fact or knowledge..."
+ ]
+ ""
+ Lucid.div_ [Lucid.class_ "form-group"] <| do
+ Lucid.label_ [Lucid.for_ "files"] "Related Files (comma-separated):"
+ Lucid.input_
+ [ Lucid.type_ "text",
+ Lucid.name_ "files",
+ Lucid.id_ "files",
+ Lucid.class_ "form-input",
+ Lucid.placeholder_ "path/to/file1.hs, path/to/file2.hs"
+ ]
+ Lucid.div_ [Lucid.class_ "form-group"] <| do
+ Lucid.label_ [Lucid.for_ "confidence"] "Confidence (0.0 - 1.0):"
+ Lucid.input_
+ [ Lucid.type_ "number",
+ Lucid.name_ "confidence",
+ Lucid.id_ "confidence",
+ Lucid.class_ "form-input",
+ Lucid.step_ "0.1",
+ Lucid.min_ "0",
+ Lucid.max_ "1",
+ Lucid.value_ "0.8"
+ ]
+ Lucid.div_ [Lucid.class_ "form-actions"] <| do
+ Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Create Fact"
+
+ if null facts
+ then Lucid.p_ [Lucid.class_ "empty-msg"] "No facts recorded yet."
+ else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderFactCard facts
+ where
+ renderFactCard :: (Monad m) => TaskCore.Fact -> Lucid.HtmlT m ()
+ renderFactCard f =
+ let factUrl = "/kb/" <> maybe "-" tshow (TaskCore.factId f)
+ in Lucid.a_
+ [ Lucid.class_ "task-card task-card-link",
+ Lucid.href_ factUrl
+ ]
+ <| do
+ Lucid.div_ [Lucid.class_ "task-header"] <| do
+ Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (maybe "-" tshow (TaskCore.factId f)))
+ confidenceBadge (TaskCore.factConfidence f)
+ Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (TaskCore.factProject f))
+ Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (Text.take 80 (TaskCore.factContent f) <> if Text.length (TaskCore.factContent f) > 80 then "..." else ""))
+ unless (null (TaskCore.factRelatedFiles f)) <| do
+ Lucid.p_ [Lucid.class_ "kb-files"] <| do
+ Lucid.span_ [Lucid.class_ "files-label"] "Files: "
+ Lucid.toHtml (Text.intercalate ", " (take 3 (TaskCore.factRelatedFiles f)))
+ when (length (TaskCore.factRelatedFiles f) > 3) <| do
+ Lucid.toHtml (" +" <> tshow (length (TaskCore.factRelatedFiles f) - 3) <> " more")
+
+ confidenceBadge :: (Monad m) => Double -> Lucid.HtmlT m ()
+ confidenceBadge conf =
+ let pct = floor (conf * 100) :: Int
+ cls
+ | conf >= 0.8 = "badge badge-done"
+ | conf >= 0.5 = "badge badge-inprogress"
+ | otherwise = "badge badge-open"
+ in Lucid.span_ [Lucid.class_ cls] (Lucid.toHtml (tshow pct <> "%"))
+
+instance Lucid.ToHtml FactDetailPage where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (FactDetailNotFound fid) =
+ let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Knowledge Base" (Just "/kb"), Breadcrumb ("Fact #" <> tshow fid) Nothing]
+ in Lucid.doctypehtml_ <| do
+ pageHead "Fact Not Found - Jr"
+ pageBodyWithCrumbs crumbs <| do
+ Lucid.div_ [Lucid.class_ "container"] <| do
+ 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 now) =
+ let fid' = maybe "-" tshow (TaskCore.factId fact)
+ crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Knowledge Base" (Just "/kb"), Breadcrumb ("Fact #" <> fid') Nothing]
+ in Lucid.doctypehtml_ <| do
+ pageHead "Fact Detail - Jr"
+ pageBodyWithCrumbs crumbs <| do
+ Lucid.div_ [Lucid.class_ "container"] <| do
+ Lucid.div_ [Lucid.class_ "task-detail-header"] <| do
+ Lucid.h1_ <| do
+ Lucid.span_ [Lucid.class_ "detail-id"] (Lucid.toHtml ("Fact #" <> maybe "-" tshow (TaskCore.factId fact)))
+ Lucid.div_ [Lucid.class_ "task-meta-row"] <| do
+ Lucid.span_ [Lucid.class_ "meta-label"] "Project:"
+ Lucid.span_ [Lucid.class_ "meta-value"] (Lucid.toHtml (TaskCore.factProject fact))
+ Lucid.span_ [Lucid.class_ "meta-label"] "Confidence:"
+ confidenceBadgeDetail (TaskCore.factConfidence fact)
+ Lucid.span_ [Lucid.class_ "meta-label"] "Created:"
+ Lucid.span_ [Lucid.class_ "meta-value"] (renderRelativeTimestamp now (TaskCore.factCreatedAt fact))
+
+ Lucid.div_ [Lucid.class_ "detail-section"] <| do
+ Lucid.h2_ "Content"
+ Lucid.form_
+ [ Lucid.method_ "POST",
+ Lucid.action_ ("/kb/" <> maybe "-" tshow (TaskCore.factId fact) <> "/edit"),
+ Lucid.class_ "fact-edit-form"
+ ]
+ <| do
+ Lucid.div_ [Lucid.class_ "form-group"] <| do
+ Lucid.label_ [Lucid.for_ "content"] "Fact Content:"
+ Lucid.textarea_
+ [ Lucid.name_ "content",
+ Lucid.id_ "content",
+ Lucid.class_ "form-textarea",
+ Lucid.rows_ "6"
+ ]
+ (Lucid.toHtml (TaskCore.factContent fact))
+
+ Lucid.div_ [Lucid.class_ "form-group"] <| do
+ Lucid.label_ [Lucid.for_ "files"] "Related Files (comma-separated):"
+ Lucid.input_
+ [ Lucid.type_ "text",
+ Lucid.name_ "files",
+ Lucid.id_ "files",
+ Lucid.class_ "form-input",
+ Lucid.value_ (Text.intercalate ", " (TaskCore.factRelatedFiles fact))
+ ]
+
+ Lucid.div_ [Lucid.class_ "form-group"] <| do
+ Lucid.label_ [Lucid.for_ "confidence"] "Confidence (0.0 - 1.0):"
+ Lucid.input_
+ [ Lucid.type_ "number",
+ Lucid.name_ "confidence",
+ Lucid.id_ "confidence",
+ Lucid.class_ "form-input",
+ Lucid.step_ "0.1",
+ Lucid.min_ "0",
+ Lucid.max_ "1",
+ Lucid.value_ (tshow (TaskCore.factConfidence fact))
+ ]
+
+ Lucid.div_ [Lucid.class_ "form-actions"] <| do
+ Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Save Changes"
+
+ case TaskCore.factSourceTask fact of
+ Nothing -> pure ()
+ Just tid -> do
+ Lucid.div_ [Lucid.class_ "detail-section"] <| do
+ Lucid.h2_ "Source Task"
+ Lucid.a_ [Lucid.href_ ("/tasks/" <> tid), Lucid.class_ "task-link"] (Lucid.toHtml tid)
+
+ Lucid.div_ [Lucid.class_ "detail-section danger-zone"] <| do
+ Lucid.h2_ "Danger Zone"
+ Lucid.form_
+ [ Lucid.method_ "POST",
+ Lucid.action_ ("/kb/" <> maybe "-" tshow (TaskCore.factId fact) <> "/delete"),
+ Lucid.class_ "delete-form",
+ Lucid.makeAttribute "onsubmit" "return confirm('Are you sure you want to delete this fact?');"
+ ]
+ <| do
+ Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-danger"] "Delete Fact"
+
+ Lucid.div_ [Lucid.class_ "back-link"] <| do
+ Lucid.a_ [Lucid.href_ "/kb"] "← Back to Knowledge Base"
+ where
+ confidenceBadgeDetail :: (Monad m) => Double -> Lucid.HtmlT m ()
+ confidenceBadgeDetail conf =
+ let pct = floor (conf * 100) :: Int
+ cls
+ | conf >= 0.8 = "badge badge-done"
+ | conf >= 0.5 = "badge badge-inprogress"
+ | otherwise = "badge badge-open"
+ in Lucid.span_ [Lucid.class_ cls] (Lucid.toHtml (tshow pct <> "%"))
+
+instance Lucid.ToHtml EpicsPage where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (EpicsPage epics allTasks currentSort) =
+ let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Epics" Nothing]
+ in Lucid.doctypehtml_ <| do
+ pageHead "Epics - Jr"
+ pageBodyWithCrumbs crumbs <| do
+ Lucid.div_ [Lucid.class_ "container"] <| do
+ Lucid.div_ [Lucid.class_ "page-header-row"] <| do
+ Lucid.h1_ <| Lucid.toHtml ("Epics (" <> tshow (length epics) <> ")")
+ sortDropdown "/epics" currentSort
+ Lucid.p_ [Lucid.class_ "info-msg"] "All epics (large, multi-task projects)."
+ if null epics
+ then Lucid.p_ [Lucid.class_ "empty-msg"] "No epics found."
+ else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ (renderEpicCardWithStats allTasks) epics
+
+instance Lucid.ToHtml TaskListPage where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (TaskListPage tasks filters currentSort _now) =
+ let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" Nothing]
+ in Lucid.doctypehtml_ <| do
+ pageHead "Tasks - Jr"
+ pageBodyWithCrumbs crumbs <| do
+ Lucid.div_ [Lucid.class_ "container"] <| do
+ Lucid.div_ [Lucid.class_ "page-header-row"] <| do
+ Lucid.h1_ <| Lucid.toHtml ("Tasks (" <> tshow (length tasks) <> ")")
+ sortDropdown "/tasks" currentSort
+
+ Lucid.div_ [Lucid.class_ "filter-form"] <| do
+ Lucid.form_
+ [ Lucid.method_ "GET",
+ Lucid.action_ "/tasks",
+ Lucid.makeAttribute "hx-get" "/partials/task-list",
+ Lucid.makeAttribute "hx-target" "#task-list",
+ Lucid.makeAttribute "hx-push-url" "/tasks",
+ Lucid.makeAttribute "hx-trigger" "submit, change from:select"
+ ]
+ <| do
+ Lucid.div_ [Lucid.class_ "filter-row"] <| do
+ Lucid.div_ [Lucid.class_ "filter-group"] <| do
+ Lucid.label_ [Lucid.for_ "status"] "Status:"
+ Lucid.select_ [Lucid.name_ "status", Lucid.id_ "status", Lucid.class_ "filter-select"] <| do
+ Lucid.option_ ([Lucid.value_ ""] <> maybeSelected Nothing (filterStatus filters)) "All"
+ statusFilterOption TaskCore.Open (filterStatus filters)
+ statusFilterOption TaskCore.InProgress (filterStatus filters)
+ statusFilterOption TaskCore.Review (filterStatus filters)
+ statusFilterOption TaskCore.Approved (filterStatus filters)
+ statusFilterOption TaskCore.Done (filterStatus filters)
+
+ Lucid.div_ [Lucid.class_ "filter-group"] <| do
+ Lucid.label_ [Lucid.for_ "priority"] "Priority:"
+ Lucid.select_ [Lucid.name_ "priority", Lucid.id_ "priority", Lucid.class_ "filter-select"] <| do
+ Lucid.option_ ([Lucid.value_ ""] <> maybeSelected Nothing (filterPriority filters)) "All"
+ priorityFilterOption TaskCore.P0 (filterPriority filters)
+ priorityFilterOption TaskCore.P1 (filterPriority filters)
+ priorityFilterOption TaskCore.P2 (filterPriority filters)
+ priorityFilterOption TaskCore.P3 (filterPriority filters)
+ priorityFilterOption TaskCore.P4 (filterPriority filters)
+
+ Lucid.div_ [Lucid.class_ "filter-group"] <| do
+ Lucid.label_ [Lucid.for_ "namespace"] "Namespace:"
+ Lucid.input_
+ [ Lucid.type_ "text",
+ Lucid.name_ "namespace",
+ Lucid.id_ "namespace",
+ Lucid.class_ "filter-input",
+ Lucid.placeholder_ "e.g. Omni/Jr",
+ Lucid.value_ (fromMaybe "" (filterNamespace filters))
+ ]
+
+ Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "filter-btn"] "Filter"
+ Lucid.a_
+ [ Lucid.href_ "/tasks",
+ Lucid.class_ "clear-btn",
+ Lucid.makeAttribute "hx-get" "/partials/task-list",
+ Lucid.makeAttribute "hx-target" "#task-list",
+ Lucid.makeAttribute "hx-push-url" "/tasks"
+ ]
+ "Clear"
+
+ Lucid.div_ [Lucid.id_ "task-list"] <| do
+ if null tasks
+ then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks match the current filters."
+ else Lucid.div_ [Lucid.class_ "list-group"] <| traverse_ renderListGroupItem tasks
+ where
+ maybeSelected :: (Eq a) => Maybe a -> Maybe a -> [Lucid.Attribute]
+ maybeSelected opt current = [Lucid.selected_ "selected" | opt == current]
+
+ statusFilterOption :: (Monad m) => TaskCore.Status -> Maybe TaskCore.Status -> Lucid.HtmlT m ()
+ statusFilterOption s current =
+ let attrs = [Lucid.value_ (tshow s)] <> [Lucid.selected_ "selected" | Just s == current]
+ in Lucid.option_ attrs (Lucid.toHtml (tshow s))
+
+ priorityFilterOption :: (Monad m) => TaskCore.Priority -> Maybe TaskCore.Priority -> Lucid.HtmlT m ()
+ priorityFilterOption p current =
+ let attrs = [Lucid.value_ (tshow p)] <> [Lucid.selected_ "selected" | Just p == current]
+ in Lucid.option_ attrs (Lucid.toHtml (tshow p))
+
+instance Lucid.ToHtml TaskDetailPage where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (TaskDetailNotFound tid) =
+ let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid Nothing]
+ in Lucid.doctypehtml_ <| do
+ pageHead "Task Not Found - Jr"
+ pageBodyWithCrumbs crumbs <| do
+ Lucid.div_ [Lucid.class_ "container"] <| do
+ Lucid.h1_ "Task Not Found"
+ Lucid.p_ <| do
+ "The task "
+ Lucid.code_ (Lucid.toHtml tid)
+ " could not be found."
+ toHtml (TaskDetailFound task allTasks _activities maybeRetry commits maybeAggMetrics agentEvents now) =
+ let crumbs = taskBreadcrumbs allTasks task
+ in Lucid.doctypehtml_ <| do
+ pageHead (TaskCore.taskId task <> " - Jr")
+ pageBodyWithCrumbs crumbs <| do
+ Lucid.div_ [Lucid.class_ "container"] <| do
+ Lucid.h1_ <| Lucid.toHtml (TaskCore.taskTitle task)
+
+ renderRetryContextBanner (TaskCore.taskId task) maybeRetry
+
+ Lucid.div_ [Lucid.class_ "task-detail"] <| do
+ Lucid.div_ [Lucid.class_ "task-meta"] <| do
+ Lucid.div_ [Lucid.class_ "task-meta-primary"] <| do
+ Lucid.code_ [Lucid.class_ "task-meta-id"] (Lucid.toHtml (TaskCore.taskId task))
+ metaSep
+ Lucid.span_ [Lucid.class_ "task-meta-type"] (Lucid.toHtml (tshow (TaskCore.taskType task)))
+ metaSep
+ statusBadgeWithForm (TaskCore.taskStatus task) (TaskCore.taskId task)
+ metaSep
+ priorityBadgeWithForm (TaskCore.taskPriority task) (TaskCore.taskId task)
+ case TaskCore.taskComplexity task of
+ Nothing -> pure ()
+ Just c -> do
+ metaSep
+ complexityBadge c
+ case TaskCore.taskNamespace task of
+ Nothing -> pure ()
+ Just ns -> do
+ metaSep
+ Lucid.span_ [Lucid.class_ "task-meta-ns"] (Lucid.toHtml ns)
+
+ Lucid.div_ [Lucid.class_ "task-meta-secondary"] <| do
+ case TaskCore.taskParent task of
+ Nothing -> pure ()
+ Just pid -> do
+ Lucid.span_ [Lucid.class_ "task-meta-label"] "Parent:"
+ Lucid.a_ [Lucid.href_ ("/tasks/" <> pid), Lucid.class_ "task-link"] (Lucid.toHtml pid)
+ metaSep
+ Lucid.span_ [Lucid.class_ "task-meta-label"] "Created"
+ renderRelativeTimestamp now (TaskCore.taskCreatedAt task)
+ metaSep
+ Lucid.span_ [Lucid.class_ "task-meta-label"] "Updated"
+ renderRelativeTimestamp now (TaskCore.taskUpdatedAt task)
+
+ let deps = TaskCore.taskDependencies task
+ unless (null deps) <| do
+ Lucid.div_ [Lucid.class_ "detail-section"] <| do
+ Lucid.h3_ "Dependencies"
+ Lucid.ul_ [Lucid.class_ "dep-list"] <| do
+ traverse_ renderDependency deps
+
+ when (TaskCore.taskType task == TaskCore.Epic) <| do
+ for_ maybeAggMetrics (renderAggregatedMetrics allTasks task)
+
+ Lucid.div_ [Lucid.class_ "detail-section"] <| do
+ Lucid.toHtml (DescriptionViewPartial (TaskCore.taskId task) (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic))
+
+ let children = filter (maybe False (TaskCore.matchesId (TaskCore.taskId task)) <. TaskCore.taskParent) allTasks
+ unless (null children) <| do
+ Lucid.div_ [Lucid.class_ "detail-section"] <| do
+ Lucid.h3_ "Child Tasks"
+ Lucid.ul_ [Lucid.class_ "child-list"] <| do
+ traverse_ renderChild children
+
+ unless (null commits) <| do
+ Lucid.div_ [Lucid.class_ "detail-section"] <| do
+ Lucid.h3_ "Git Commits"
+ Lucid.div_ [Lucid.class_ "commit-list"] <| do
+ traverse_ (renderCommit (TaskCore.taskId task)) commits
+
+ when (TaskCore.taskStatus task == TaskCore.Review) <| do
+ Lucid.div_ [Lucid.class_ "review-link-section"] <| do
+ Lucid.a_
+ [ Lucid.href_ ("/tasks/" <> TaskCore.taskId task <> "/review"),
+ Lucid.class_ "review-link-btn"
+ ]
+ "Review This Task"
+
+ renderUnifiedTimeline (TaskCore.taskId task) (TaskCore.taskComments task) agentEvents (TaskCore.taskStatus task) now
+ where
+ renderDependency :: (Monad m) => TaskCore.Dependency -> Lucid.HtmlT m ()
+ renderDependency dep =
+ Lucid.li_ <| do
+ Lucid.a_ [Lucid.href_ ("/tasks/" <> TaskCore.depId dep), Lucid.class_ "task-link"] (Lucid.toHtml (TaskCore.depId dep))
+ Lucid.span_ [Lucid.class_ "dep-type"] <| Lucid.toHtml (" [" <> tshow (TaskCore.depType dep) <> "]")
+
+ renderChild :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m ()
+ renderChild child =
+ Lucid.li_ <| do
+ Lucid.a_ [Lucid.href_ ("/tasks/" <> TaskCore.taskId child), Lucid.class_ "task-link"] (Lucid.toHtml (TaskCore.taskId child))
+ Lucid.span_ [Lucid.class_ "child-title"] <| Lucid.toHtml (" - " <> TaskCore.taskTitle child)
+ Lucid.span_ [Lucid.class_ "child-status"] <| Lucid.toHtml (" [" <> tshow (TaskCore.taskStatus child) <> "]")
+
+ renderCommit :: (Monad m) => Text -> GitCommit -> Lucid.HtmlT m ()
+ renderCommit tid c =
+ Lucid.div_ [Lucid.class_ "commit-item"] <| do
+ Lucid.div_ [Lucid.class_ "commit-header"] <| do
+ Lucid.a_
+ [ Lucid.href_ ("/tasks/" <> tid <> "/diff/" <> commitHash c),
+ Lucid.class_ "commit-hash"
+ ]
+ (Lucid.toHtml (commitShortHash c))
+ Lucid.span_ [Lucid.class_ "commit-summary"] (Lucid.toHtml (commitSummary c))
+ Lucid.div_ [Lucid.class_ "commit-meta"] <| do
+ Lucid.span_ [Lucid.class_ "commit-author"] (Lucid.toHtml (commitAuthor c))
+ Lucid.span_ [Lucid.class_ "commit-date"] (Lucid.toHtml (commitRelativeDate c))
+ Lucid.span_ [Lucid.class_ "commit-files"] (Lucid.toHtml (tshow (commitFilesChanged c) <> " files"))
+
+instance Lucid.ToHtml TaskReviewPage where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (ReviewPageNotFound tid) =
+ let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb "Review" Nothing]
+ in Lucid.doctypehtml_ <| do
+ pageHead "Task Not Found - Jr Review"
+ pageBodyWithCrumbs crumbs <| do
+ Lucid.div_ [Lucid.class_ "container"] <| do
+ Lucid.h1_ "Task Not Found"
+ Lucid.p_ <| do
+ "The task "
+ Lucid.code_ (Lucid.toHtml tid)
+ " could not be found."
+ toHtml (ReviewPageFound task reviewInfo) =
+ let tid = TaskCore.taskId task
+ crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb "Review" Nothing]
+ in Lucid.doctypehtml_ <| do
+ pageHead ("Review: " <> TaskCore.taskId task <> " - Jr")
+ pageBodyWithCrumbs crumbs <| do
+ Lucid.div_ [Lucid.class_ "container"] <| do
+ Lucid.h1_ "Review Task"
+
+ Lucid.div_ [Lucid.class_ "task-summary"] <| do
+ Lucid.div_ [Lucid.class_ "detail-row"] <| do
+ Lucid.span_ [Lucid.class_ "detail-label"] "ID:"
+ Lucid.code_ [Lucid.class_ "detail-value"] (Lucid.toHtml (TaskCore.taskId task))
+ Lucid.div_ [Lucid.class_ "detail-row"] <| do
+ Lucid.span_ [Lucid.class_ "detail-label"] "Title:"
+ Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (TaskCore.taskTitle task))
+ Lucid.div_ [Lucid.class_ "detail-row"] <| do
+ Lucid.span_ [Lucid.class_ "detail-label"] "Status:"
+ Lucid.span_ [Lucid.class_ "detail-value"] <| statusBadge (TaskCore.taskStatus task)
+
+ case reviewInfo of
+ ReviewNoCommit ->
+ Lucid.div_ [Lucid.class_ "no-commit-msg"] <| do
+ Lucid.h3_ "No Commit Found"
+ Lucid.p_ "No commit with this task ID was found in the git history."
+ Lucid.p_ "The worker may not have completed yet, or the commit message doesn't include the task ID."
+ ReviewMergeConflict commitSha conflictFiles ->
+ Lucid.div_ [Lucid.class_ "conflict-warning"] <| do
+ Lucid.h3_ "Merge Conflict Detected"
+ Lucid.p_ <| do
+ "Commit "
+ Lucid.code_ (Lucid.toHtml (Text.take 8 commitSha))
+ " cannot be cleanly merged."
+ Lucid.p_ "Conflicting files:"
+ Lucid.ul_ <| traverse_ (Lucid.li_ <. Lucid.toHtml) conflictFiles
+ ReviewReady commitSha diffText -> do
+ Lucid.div_ [Lucid.class_ "diff-section"] <| do
+ Lucid.h3_ <| do
+ "Commit: "
+ Lucid.code_ (Lucid.toHtml (Text.take 8 commitSha))
+ Lucid.pre_ [Lucid.class_ "diff-block"] (Lucid.toHtml diffText)
+
+ Lucid.div_ [Lucid.class_ "review-actions"] <| do
+ Lucid.form_
+ [ Lucid.method_ "POST",
+ Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/accept"),
+ Lucid.class_ "inline-form"
+ ]
+ <| do
+ Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "accept-btn"] "Accept"
+
+ Lucid.form_
+ [ Lucid.method_ "POST",
+ Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/reject"),
+ Lucid.class_ "reject-form"
+ ]
+ <| do
+ Lucid.textarea_
+ [ Lucid.name_ "notes",
+ Lucid.class_ "reject-notes",
+ Lucid.placeholder_ "Rejection notes (optional)"
+ ]
+ ""
+ Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "reject-btn"] "Reject"
+
+instance Lucid.ToHtml TaskDiffPage where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (DiffPageNotFound tid commitHash') =
+ let shortHash = Text.take 8 commitHash'
+ crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb ("Diff " <> shortHash) Nothing]
+ in Lucid.doctypehtml_ <| do
+ pageHead "Commit Not Found - Jr"
+ pageBodyWithCrumbs crumbs <| do
+ Lucid.div_ [Lucid.class_ "container"] <| do
+ Lucid.h1_ "Commit Not Found"
+ Lucid.p_ <| do
+ "Could not find commit "
+ Lucid.code_ (Lucid.toHtml commitHash')
+ Lucid.a_ [Lucid.href_ ("/tasks/" <> tid), Lucid.class_ "back-link"] "← Back to task"
+ toHtml (DiffPageFound tid commitHash' diffOutput) =
+ let shortHash = Text.take 8 commitHash'
+ crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb ("Diff " <> shortHash) Nothing]
+ in Lucid.doctypehtml_ <| do
+ pageHead ("Diff " <> shortHash <> " - Jr")
+ pageBodyWithCrumbs crumbs <| do
+ Lucid.div_ [Lucid.class_ "container"] <| do
+ Lucid.div_ [Lucid.class_ "diff-header"] <| do
+ Lucid.a_ [Lucid.href_ ("/tasks/" <> tid), Lucid.class_ "back-link"] "← Back to task"
+ Lucid.h1_ <| do
+ "Commit "
+ Lucid.code_ (Lucid.toHtml shortHash)
+ Lucid.pre_ [Lucid.class_ "diff-block"] (Lucid.toHtml diffOutput)
+
+instance Lucid.ToHtml StatsPage where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (StatsPage stats maybeEpic) =
+ let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Stats" Nothing]
+ in Lucid.doctypehtml_ <| do
+ pageHead "Task Statistics - Jr"
+ pageBodyWithCrumbs crumbs <| do
+ Lucid.div_ [Lucid.class_ "container"] <| do
+ Lucid.h1_ <| case maybeEpic of
+ Nothing -> "Task Statistics"
+ Just epicId -> Lucid.toHtml ("Statistics for Epic: " <> epicId)
+
+ Lucid.form_ [Lucid.method_ "GET", Lucid.action_ "/stats", Lucid.class_ "filter-form"] <| do
+ Lucid.div_ [Lucid.class_ "filter-row"] <| do
+ Lucid.div_ [Lucid.class_ "filter-group"] <| do
+ Lucid.label_ [Lucid.for_ "epic"] "Epic:"
+ Lucid.input_
+ [ Lucid.type_ "text",
+ Lucid.name_ "epic",
+ Lucid.id_ "epic",
+ Lucid.class_ "filter-input",
+ Lucid.placeholder_ "Epic ID (optional)",
+ Lucid.value_ (fromMaybe "" maybeEpic)
+ ]
+ Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "filter-btn"] "Filter"
+ Lucid.a_ [Lucid.href_ "/stats", Lucid.class_ "clear-btn"] "Clear"
+
+ Lucid.h2_ "By Status"
+ multiColorProgressBar stats
+ Lucid.div_ [Lucid.class_ "stats-grid"] <| do
+ statCard "Open" (TaskCore.openTasks stats) (TaskCore.totalTasks stats)
+ statCard "In Progress" (TaskCore.inProgressTasks stats) (TaskCore.totalTasks stats)
+ statCard "Review" (TaskCore.reviewTasks stats) (TaskCore.totalTasks stats)
+ statCard "Approved" (TaskCore.approvedTasks stats) (TaskCore.totalTasks stats)
+ statCard "Done" (TaskCore.doneTasks stats) (TaskCore.totalTasks stats)
+
+ Lucid.h2_ "By Priority"
+ Lucid.div_ [Lucid.class_ "stats-section"] <| do
+ traverse_ (uncurry renderPriorityRow) (TaskCore.tasksByPriority stats)
+
+ Lucid.h2_ "By Namespace"
+ Lucid.div_ [Lucid.class_ "stats-section"] <| do
+ if null (TaskCore.tasksByNamespace stats)
+ then Lucid.p_ [Lucid.class_ "empty-msg"] "No namespaces found."
+ else traverse_ (uncurry (renderNamespaceRow (TaskCore.totalTasks stats))) (TaskCore.tasksByNamespace stats)
+
+ Lucid.h2_ "Summary"
+ Lucid.div_ [Lucid.class_ "summary-section"] <| do
+ Lucid.div_ [Lucid.class_ "detail-row"] <| do
+ Lucid.span_ [Lucid.class_ "detail-label"] "Total Tasks:"
+ Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.totalTasks stats)))
+ Lucid.div_ [Lucid.class_ "detail-row"] <| do
+ Lucid.span_ [Lucid.class_ "detail-label"] "Epics:"
+ Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.totalEpics stats)))
+ Lucid.div_ [Lucid.class_ "detail-row"] <| do
+ Lucid.span_ [Lucid.class_ "detail-label"] "Ready:"
+ Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.readyTasks stats)))
+ Lucid.div_ [Lucid.class_ "detail-row"] <| do
+ Lucid.span_ [Lucid.class_ "detail-label"] "Blocked:"
+ Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.blockedTasks stats)))
+ where
+ statCard :: (Monad m) => Text -> Int -> Int -> Lucid.HtmlT m ()
+ statCard label count total =
+ let pct = if total == 0 then 0 else (count * 100) `div` total
+ in Lucid.div_ [Lucid.class_ "stat-card"] <| do
+ Lucid.div_ [Lucid.class_ "stat-count"] (Lucid.toHtml (tshow count))
+ Lucid.div_ [Lucid.class_ "stat-label"] (Lucid.toHtml label)
+ Lucid.div_ [Lucid.class_ "progress-bar"] <| do
+ Lucid.div_
+ [ Lucid.class_ "progress-fill",
+ Lucid.style_ ("width: " <> tshow pct <> "%")
+ ]
+ ""
+
+ renderPriorityRow :: (Monad m) => TaskCore.Priority -> Int -> Lucid.HtmlT m ()
+ renderPriorityRow priority count =
+ let total = TaskCore.totalTasks stats
+ pct = if total == 0 then 0 else (count * 100) `div` total
+ in Lucid.div_ [Lucid.class_ "stats-row"] <| do
+ Lucid.span_ [Lucid.class_ "stats-label"] (Lucid.toHtml (tshow priority))
+ Lucid.div_ [Lucid.class_ "stats-bar-container"] <| do
+ Lucid.div_ [Lucid.class_ "progress-bar"] <| do
+ Lucid.div_
+ [ Lucid.class_ "progress-fill",
+ Lucid.style_ ("width: " <> tshow pct <> "%")
+ ]
+ ""
+ Lucid.span_ [Lucid.class_ "stats-count"] (Lucid.toHtml (tshow count))
+
+ renderNamespaceRow :: (Monad m) => Int -> Text -> Int -> Lucid.HtmlT m ()
+ renderNamespaceRow total ns count =
+ let pct = if total == 0 then 0 else (count * 100) `div` total
+ in Lucid.div_ [Lucid.class_ "stats-row"] <| do
+ Lucid.span_ [Lucid.class_ "stats-label"] (Lucid.toHtml ns)
+ Lucid.div_ [Lucid.class_ "stats-bar-container"] <| do
+ Lucid.div_ [Lucid.class_ "progress-bar"] <| do
+ Lucid.div_
+ [ Lucid.class_ "progress-fill",
+ Lucid.style_ ("width: " <> tshow pct <> "%")
+ ]
+ ""
+ Lucid.span_ [Lucid.class_ "stats-count"] (Lucid.toHtml (tshow count))
diff --git a/Omni/Jr/Web/Partials.hs b/Omni/Jr/Web/Partials.hs
new file mode 100644
index 00000000..79c997e3
--- /dev/null
+++ b/Omni/Jr/Web/Partials.hs
@@ -0,0 +1,247 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- : dep lucid
+-- : dep servant-lucid
+module Omni.Jr.Web.Partials
+ ( -- Re-export instances for use by Web.hs
+ )
+where
+
+import Alpha
+import qualified Data.Text as Text
+import Data.Time (UTCTime, diffUTCTime)
+import qualified Lucid
+import qualified Lucid.Base as Lucid
+import Numeric (showFFloat)
+import Omni.Jr.Web.Components
+ ( priorityBadgeWithForm,
+ renderListGroupItem,
+ renderMarkdown,
+ renderRelativeTimestamp,
+ renderTimelineEvent,
+ statusBadgeWithForm,
+ timelineScrollScript,
+ )
+import Omni.Jr.Web.Types
+ ( AgentEventsPartial (..),
+ DescriptionEditPartial (..),
+ DescriptionViewPartial (..),
+ PriorityBadgePartial (..),
+ ReadyCountPartial (..),
+ RecentActivityMorePartial (..),
+ RecentActivityNewPartial (..),
+ StatusBadgePartial (..),
+ TaskListPartial (..),
+ TaskMetricsPartial (..),
+ )
+import qualified Omni.Task.Core as TaskCore
+
+instance Lucid.ToHtml RecentActivityNewPartial where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (RecentActivityNewPartial tasks maybeNewestTs) = do
+ traverse_ renderListGroupItem tasks
+ case maybeNewestTs of
+ Nothing -> pure ()
+ Just ts ->
+ Lucid.div_
+ [ Lucid.id_ "recent-activity",
+ Lucid.makeAttribute "data-newest-ts" (tshow ts),
+ Lucid.makeAttribute "hx-swap-oob" "attributes:#recent-activity data-newest-ts"
+ ]
+ ""
+
+instance Lucid.ToHtml RecentActivityMorePartial where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (RecentActivityMorePartial tasks nextOffset hasMore) = do
+ traverse_ renderListGroupItem tasks
+ if hasMore
+ then
+ Lucid.button_
+ [ Lucid.id_ "activity-load-more",
+ Lucid.class_ "btn btn-secondary load-more-btn",
+ Lucid.makeAttribute "hx-get" ("/partials/recent-activity-more?offset=" <> tshow nextOffset),
+ Lucid.makeAttribute "hx-target" "#activity-list",
+ Lucid.makeAttribute "hx-swap" "beforeend",
+ Lucid.makeAttribute "hx-swap-oob" "true"
+ ]
+ "Load More"
+ else Lucid.span_ [Lucid.id_ "activity-load-more", Lucid.makeAttribute "hx-swap-oob" "true"] ""
+
+instance Lucid.ToHtml ReadyCountPartial where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (ReadyCountPartial count) =
+ Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "ready-link"]
+ <| Lucid.toHtml ("(" <> tshow count <> " tasks)")
+
+instance Lucid.ToHtml StatusBadgePartial where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (StatusBadgePartial status tid) =
+ statusBadgeWithForm status tid
+
+instance Lucid.ToHtml PriorityBadgePartial where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (PriorityBadgePartial priority tid) =
+ priorityBadgeWithForm priority tid
+
+instance Lucid.ToHtml TaskListPartial where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (TaskListPartial tasks) =
+ if null tasks
+ then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks match the current filters."
+ else Lucid.div_ [Lucid.class_ "list-group"] <| traverse_ renderListGroupItem tasks
+
+instance Lucid.ToHtml TaskMetricsPartial where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (TaskMetricsPartial _tid activities maybeRetry now) =
+ let runningActs = filter (\a -> TaskCore.activityStage a == TaskCore.Running) activities
+ in if null runningActs
+ then Lucid.p_ [Lucid.class_ "empty-msg"] "No worker execution data available."
+ else
+ Lucid.div_ [Lucid.class_ "execution-details"] <| do
+ let totalCost = sum [c | act <- runningActs, Just c <- [TaskCore.activityCostCents act]]
+ totalDuration = sum [calcDurSecs act | act <- runningActs]
+ attemptCount = length runningActs
+
+ case maybeRetry of
+ Nothing -> pure ()
+ Just ctx ->
+ Lucid.div_ [Lucid.class_ "metric-row"] <| do
+ Lucid.span_ [Lucid.class_ "metric-label"] "Retry Attempt:"
+ Lucid.span_ [Lucid.class_ "metric-value retry-count"] (Lucid.toHtml (tshow (TaskCore.retryAttempt ctx) <> "/3"))
+
+ when (attemptCount > 1) <| do
+ Lucid.div_ [Lucid.class_ "metric-row"] <| do
+ Lucid.span_ [Lucid.class_ "metric-label"] "Total Attempts:"
+ Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (tshow attemptCount))
+ Lucid.div_ [Lucid.class_ "metric-row"] <| do
+ Lucid.span_ [Lucid.class_ "metric-label"] "Total Duration:"
+ Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDurSecs totalDuration))
+ when (totalCost > 0)
+ <| Lucid.div_ [Lucid.class_ "metric-row"]
+ <| do
+ Lucid.span_ [Lucid.class_ "metric-label"] "Total Cost:"
+ Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCost totalCost))
+ Lucid.hr_ [Lucid.class_ "attempts-divider"]
+
+ traverse_ (renderAttempt attemptCount now) (zip [1 ..] (reverse runningActs))
+ where
+ calcDurSecs :: TaskCore.TaskActivity -> Int
+ calcDurSecs act = case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of
+ (Just start, Just end) -> floor (diffUTCTime end start)
+ _ -> 0
+
+ formatDurSecs :: Int -> Text
+ formatDurSecs secs
+ | secs < 60 = tshow secs <> "s"
+ | secs < 3600 = tshow (secs `div` 60) <> "m " <> tshow (secs `mod` 60) <> "s"
+ | otherwise = tshow (secs `div` 3600) <> "h " <> tshow ((secs `mod` 3600) `div` 60) <> "m"
+
+ renderAttempt :: (Monad m) => Int -> UTCTime -> (Int, TaskCore.TaskActivity) -> Lucid.HtmlT m ()
+ renderAttempt totalAttempts currentTime (attemptNum, act) = do
+ when (totalAttempts > 1)
+ <| Lucid.div_ [Lucid.class_ "attempt-header"] (Lucid.toHtml ("Attempt " <> tshow attemptNum :: Text))
+ case TaskCore.activityThreadUrl act of
+ Nothing -> pure ()
+ Just url ->
+ Lucid.div_ [Lucid.class_ "metric-row"] <| do
+ Lucid.span_ [Lucid.class_ "metric-label"] "Session:"
+ Lucid.a_ [Lucid.href_ url, Lucid.target_ "_blank", Lucid.class_ "amp-thread-btn"] "View in Amp ↗"
+
+ case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of
+ (Just start, Just end) ->
+ Lucid.div_ [Lucid.class_ "metric-row"] <| do
+ Lucid.span_ [Lucid.class_ "metric-label"] "Duration:"
+ Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDuration start end))
+ (Just start, Nothing) ->
+ Lucid.div_ [Lucid.class_ "metric-row"] <| do
+ Lucid.span_ [Lucid.class_ "metric-label"] "Started:"
+ Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp currentTime start)
+ _ -> pure ()
+
+ case TaskCore.activityCostCents act of
+ Nothing -> pure ()
+ Just cents ->
+ Lucid.div_ [Lucid.class_ "metric-row"] <| do
+ Lucid.span_ [Lucid.class_ "metric-label"] "Cost:"
+ Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCost cents))
+
+ Lucid.div_ [Lucid.class_ "metric-row"] <| do
+ Lucid.span_ [Lucid.class_ "metric-label"] "Timestamp:"
+ Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp currentTime (TaskCore.activityTimestamp act))
+
+ formatDuration :: UTCTime -> UTCTime -> Text
+ formatDuration start end =
+ let diffSecs = floor (diffUTCTime end start) :: Int
+ mins = diffSecs `div` 60
+ secs = diffSecs `mod` 60
+ in if mins > 0
+ then tshow mins <> "m " <> tshow secs <> "s"
+ else tshow secs <> "s"
+
+ formatCost :: Int -> Text
+ formatCost cents =
+ let dollars = fromIntegral cents / 100.0 :: Double
+ in "$" <> Text.pack (showFFloat (Just 2) dollars "")
+
+instance Lucid.ToHtml DescriptionViewPartial where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (DescriptionViewPartial tid desc isEpic) =
+ Lucid.div_ [Lucid.id_ "description-block", Lucid.class_ "description-block"] <| do
+ Lucid.div_ [Lucid.class_ "description-header"] <| do
+ Lucid.h3_ (if isEpic then "Design" else "Description")
+ Lucid.a_
+ [ Lucid.href_ "#",
+ Lucid.class_ "edit-link",
+ Lucid.makeAttribute "hx-get" ("/tasks/" <> tid <> "/description/edit"),
+ Lucid.makeAttribute "hx-target" "#description-block",
+ Lucid.makeAttribute "hx-swap" "outerHTML"
+ ]
+ "Edit"
+ if Text.null desc
+ then Lucid.p_ [Lucid.class_ "empty-msg"] (if isEpic then "No design document yet." else "No description yet.")
+ else Lucid.div_ [Lucid.class_ "markdown-content"] (renderMarkdown desc)
+
+instance Lucid.ToHtml DescriptionEditPartial where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (DescriptionEditPartial tid desc isEpic) =
+ Lucid.div_ [Lucid.id_ "description-block", Lucid.class_ "description-block editing"] <| do
+ Lucid.div_ [Lucid.class_ "description-header"] <| do
+ Lucid.h3_ (if isEpic then "Design" else "Description")
+ Lucid.button_
+ [ Lucid.type_ "button",
+ Lucid.class_ "cancel-link",
+ Lucid.makeAttribute "hx-get" ("/tasks/" <> tid <> "/description/view"),
+ Lucid.makeAttribute "hx-target" "#description-block",
+ Lucid.makeAttribute "hx-swap" "outerHTML",
+ Lucid.makeAttribute "hx-confirm" "Discard changes?"
+ ]
+ "Cancel"
+ Lucid.form_
+ [ Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/description"),
+ Lucid.makeAttribute "hx-target" "#description-block",
+ Lucid.makeAttribute "hx-swap" "outerHTML"
+ ]
+ <| do
+ Lucid.textarea_
+ [ Lucid.name_ "description",
+ Lucid.class_ "description-textarea",
+ Lucid.rows_ (if isEpic then "15" else "10"),
+ Lucid.placeholder_ (if isEpic then "Enter design in Markdown..." else "Enter description...")
+ ]
+ (Lucid.toHtml desc)
+ Lucid.div_ [Lucid.class_ "form-actions"] <| do
+ Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Save"
+
+instance Lucid.ToHtml AgentEventsPartial where
+ toHtmlRaw = Lucid.toHtml
+ toHtml (AgentEventsPartial events isInProgress now) = do
+ Lucid.h3_ <| do
+ Lucid.toHtml ("Timeline (" <> tshow (length events) <> ")")
+ when isInProgress <| Lucid.span_ [Lucid.class_ "timeline-live"] " LIVE"
+ if null events
+ then Lucid.p_ [Lucid.class_ "empty-msg"] "No activity yet."
+ else do
+ Lucid.div_ [Lucid.class_ "timeline-events"] <| do
+ traverse_ (renderTimelineEvent now) events
+ timelineScrollScript
diff --git a/Omni/Jr/Web/Types.hs b/Omni/Jr/Web/Types.hs
new file mode 100644
index 00000000..c463bfa5
--- /dev/null
+++ b/Omni/Jr/Web/Types.hs
@@ -0,0 +1,345 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-- : dep servant-server
+-- : dep lucid
+-- : dep http-api-data
+-- : dep aeson
+module Omni.Jr.Web.Types
+ ( TaskFilters (..),
+ TimeRange (..),
+ SortOrder (..),
+ parseSortOrder,
+ sortOrderToParam,
+ sortOrderLabel,
+ sortTasks,
+ parseTimeRange,
+ timeRangeToParam,
+ getTimeRangeStart,
+ startOfDay,
+ startOfWeek,
+ addDays,
+ fromGregorian,
+ daysSinceEpoch,
+ startOfMonth,
+ computeMetricsFromActivities,
+ HomePage (..),
+ ReadyQueuePage (..),
+ BlockedPage (..),
+ InterventionPage (..),
+ TaskListPage (..),
+ TaskDetailPage (..),
+ GitCommit (..),
+ TaskReviewPage (..),
+ ReviewInfo (..),
+ TaskDiffPage (..),
+ StatsPage (..),
+ KBPage (..),
+ FactDetailPage (..),
+ EpicsPage (..),
+ RecentActivityNewPartial (..),
+ RecentActivityMorePartial (..),
+ ReadyCountPartial (..),
+ StatusBadgePartial (..),
+ PriorityBadgePartial (..),
+ TaskListPartial (..),
+ TaskMetricsPartial (..),
+ AgentEventsPartial (..),
+ DescriptionViewPartial (..),
+ DescriptionEditPartial (..),
+ FactEditForm (..),
+ FactCreateForm (..),
+ RejectForm (..),
+ StatusForm (..),
+ PriorityForm (..),
+ DescriptionForm (..),
+ NotesForm (..),
+ CommentForm (..),
+ Breadcrumb (..),
+ Breadcrumbs,
+ CSS,
+ SSE,
+ )
+where
+
+import Alpha
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.List as List
+import qualified Data.Text as Text
+import qualified Data.Text.Lazy as LazyText
+import Data.Time (Day, UTCTime (..), diffUTCTime, toGregorian)
+import Data.Time.Calendar (DayOfWeek (..))
+import Data.Time.Calendar.WeekDate (toWeekCalendar)
+import qualified Lucid
+import qualified Omni.Task.Core as TaskCore
+import Servant (Accept (..), MimeRender (..))
+import Web.FormUrlEncoded (FromForm (..), lookupUnique, parseUnique)
+
+data TaskFilters = TaskFilters
+ { filterStatus :: Maybe TaskCore.Status,
+ filterPriority :: Maybe TaskCore.Priority,
+ filterNamespace :: Maybe Text,
+ filterType :: Maybe TaskCore.TaskType
+ }
+ deriving (Show, Eq)
+
+data TimeRange = Today | Week | Month | AllTime
+ deriving (Show, Eq)
+
+data SortOrder
+ = SortNewest
+ | SortOldest
+ | SortUpdated
+ | SortPriorityHigh
+ | SortPriorityLow
+ deriving (Show, Eq)
+
+parseSortOrder :: Maybe Text -> SortOrder
+parseSortOrder (Just "oldest") = SortOldest
+parseSortOrder (Just "updated") = SortUpdated
+parseSortOrder (Just "priority-high") = SortPriorityHigh
+parseSortOrder (Just "priority-low") = SortPriorityLow
+parseSortOrder _ = SortNewest
+
+sortOrderToParam :: SortOrder -> Text
+sortOrderToParam SortNewest = "newest"
+sortOrderToParam SortOldest = "oldest"
+sortOrderToParam SortUpdated = "updated"
+sortOrderToParam SortPriorityHigh = "priority-high"
+sortOrderToParam SortPriorityLow = "priority-low"
+
+sortOrderLabel :: SortOrder -> Text
+sortOrderLabel SortNewest = "Newest First"
+sortOrderLabel SortOldest = "Oldest First"
+sortOrderLabel SortUpdated = "Recently Updated"
+sortOrderLabel SortPriorityHigh = "Priority (High to Low)"
+sortOrderLabel SortPriorityLow = "Priority (Low to High)"
+
+sortTasks :: SortOrder -> [TaskCore.Task] -> [TaskCore.Task]
+sortTasks SortNewest = List.sortBy (comparing (Down <. TaskCore.taskCreatedAt))
+sortTasks SortOldest = List.sortBy (comparing TaskCore.taskCreatedAt)
+sortTasks SortUpdated = List.sortBy (comparing (Down <. TaskCore.taskUpdatedAt))
+sortTasks SortPriorityHigh = List.sortBy (comparing TaskCore.taskPriority)
+sortTasks SortPriorityLow = List.sortBy (comparing (Down <. TaskCore.taskPriority))
+
+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) = toWeekCalendar day
+ daysBack = dow - 1
+ in UTCTime (addDays (negate (toInteger 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
+
+data CSS
+
+instance Accept CSS where
+ contentType _ = "text/css"
+
+instance MimeRender CSS LazyText.Text where
+ mimeRender _ = LazyText.encodeUtf8
+
+data SSE
+
+instance Accept SSE where
+ contentType _ = "text/event-stream"
+
+instance MimeRender SSE BS.ByteString where
+ mimeRender _ = LBS.fromStrict
+
+data HomePage = HomePage TaskCore.TaskStats [TaskCore.Task] [TaskCore.Task] Bool TaskCore.AggregatedMetrics TimeRange UTCTime
+
+data ReadyQueuePage = ReadyQueuePage [TaskCore.Task] SortOrder UTCTime
+
+data BlockedPage = BlockedPage [(TaskCore.Task, Int)] SortOrder UTCTime
+
+data InterventionPage = InterventionPage TaskCore.HumanActionItems SortOrder UTCTime
+
+data TaskListPage = TaskListPage [TaskCore.Task] TaskFilters SortOrder UTCTime
+
+data TaskDetailPage
+ = TaskDetailFound TaskCore.Task [TaskCore.Task] [TaskCore.TaskActivity] (Maybe TaskCore.RetryContext) [GitCommit] (Maybe TaskCore.AggregatedMetrics) [TaskCore.StoredEvent] UTCTime
+ | TaskDetailNotFound Text
+
+data GitCommit = GitCommit
+ { commitHash :: Text,
+ commitShortHash :: Text,
+ commitSummary :: Text,
+ commitAuthor :: Text,
+ commitRelativeDate :: Text,
+ commitFilesChanged :: Int
+ }
+ deriving (Show, Eq)
+
+data TaskReviewPage
+ = ReviewPageFound TaskCore.Task ReviewInfo
+ | ReviewPageNotFound Text
+
+data ReviewInfo
+ = ReviewNoCommit
+ | ReviewMergeConflict Text [Text]
+ | ReviewReady Text Text
+
+data TaskDiffPage
+ = DiffPageFound Text Text Text
+ | DiffPageNotFound Text Text
+
+data StatsPage = StatsPage TaskCore.TaskStats (Maybe Text)
+
+newtype KBPage = KBPage [TaskCore.Fact]
+
+data FactDetailPage
+ = FactDetailFound TaskCore.Fact UTCTime
+ | FactDetailNotFound Int
+
+data FactEditForm = FactEditForm Text Text Text
+
+instance FromForm FactEditForm where
+ fromForm form = do
+ content <- parseUnique "content" form
+ let files = fromRight "" (lookupUnique "files" form)
+ let confidence = fromRight "0.8" (lookupUnique "confidence" form)
+ Right (FactEditForm content files confidence)
+
+data FactCreateForm = FactCreateForm Text Text Text Text
+
+instance FromForm FactCreateForm where
+ fromForm form = do
+ project <- parseUnique "project" form
+ content <- parseUnique "content" form
+ let files = fromRight "" (lookupUnique "files" form)
+ let confidence = fromRight "0.8" (lookupUnique "confidence" form)
+ Right (FactCreateForm project content files confidence)
+
+data EpicsPage = EpicsPage [TaskCore.Task] [TaskCore.Task] SortOrder
+
+data RecentActivityNewPartial = RecentActivityNewPartial [TaskCore.Task] (Maybe Int)
+
+data RecentActivityMorePartial = RecentActivityMorePartial [TaskCore.Task] Int Bool
+
+newtype ReadyCountPartial = ReadyCountPartial Int
+
+data StatusBadgePartial = StatusBadgePartial TaskCore.Status Text
+
+data PriorityBadgePartial = PriorityBadgePartial TaskCore.Priority Text
+
+newtype TaskListPartial = TaskListPartial [TaskCore.Task]
+
+data TaskMetricsPartial = TaskMetricsPartial Text [TaskCore.TaskActivity] (Maybe TaskCore.RetryContext) UTCTime
+
+data AgentEventsPartial = AgentEventsPartial [TaskCore.StoredEvent] Bool UTCTime
+
+data DescriptionViewPartial = DescriptionViewPartial Text Text Bool
+
+data DescriptionEditPartial = DescriptionEditPartial Text Text Bool
+
+newtype RejectForm = RejectForm (Maybe Text)
+
+instance FromForm RejectForm where
+ fromForm form = Right (RejectForm (either (const Nothing) Just (lookupUnique "notes" form)))
+
+newtype StatusForm = StatusForm TaskCore.Status
+
+instance FromForm StatusForm where
+ fromForm form = do
+ statusText <- parseUnique "status" form
+ case readMaybe (Text.unpack statusText) of
+ Just s -> Right (StatusForm s)
+ Nothing -> Left "Invalid status"
+
+newtype PriorityForm = PriorityForm TaskCore.Priority
+
+instance FromForm PriorityForm where
+ fromForm form = do
+ priorityText <- parseUnique "priority" form
+ case readMaybe (Text.unpack priorityText) of
+ Just p -> Right (PriorityForm p)
+ Nothing -> Left "Invalid priority"
+
+newtype DescriptionForm = DescriptionForm Text
+
+instance FromForm DescriptionForm where
+ fromForm form = do
+ desc <- parseUnique "description" form
+ Right (DescriptionForm desc)
+
+newtype NotesForm = NotesForm Text
+
+instance FromForm NotesForm where
+ fromForm form = do
+ notes <- parseUnique "notes" form
+ Right (NotesForm notes)
+
+newtype CommentForm = CommentForm Text
+
+instance FromForm CommentForm where
+ fromForm form = do
+ commentText <- parseUnique "comment" form
+ Right (CommentForm commentText)
+
+data Breadcrumb = Breadcrumb
+ { breadcrumbLabel :: Text,
+ breadcrumbUrl :: Maybe Text
+ }
+
+type Breadcrumbs = [Breadcrumb]