summaryrefslogtreecommitdiff
path: root/Omni/Jr/Web.hs
diff options
context:
space:
mode:
authorBen Sima <ben@bensima.com>2025-12-01 18:44:47 -0500
committerBen Sima <ben@bensima.com>2025-12-01 18:44:47 -0500
commitdbbad7cff74411b39db6d619a2a1ad6512aad634 (patch)
treee205780cbe8ff065872f14f6095054084dc90c0e /Omni/Jr/Web.hs
parent838350a9afc27618abf9a78e721eb8902e99b6ab (diff)
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>
Diffstat (limited to 'Omni/Jr/Web.hs')
-rw-r--r--Omni/Jr/Web.hs3226
1 files changed, 17 insertions, 3209 deletions
diff --git a/Omni/Jr/Web.hs b/Omni/Jr/Web.hs
index 2a10cb5..761428e 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)
generated by cgit v1.2.3 (git 2.25.1) at 2025-12-19 05:17:49 +0000