The Agent Log box should automatically scroll to the bottom so the latest messages are visible as they come in. Currently users have to manually scroll to see new content.
I'll start by reading the AGENTS.md file to understand the codebase conventions, then locate and examine the Agent Log box implementation.
repo/AGENTS.mdLet me check the current directory:
pwd && ls -la/home/ben/omni total 760 drwxr-xr-x 18 ben users 4096 Dec 1 13:24 . drwx------ 67 ben users 4096 Dec 1 12:32 .. drwxr-xr-x 10 ben users 4096 Dec 1 07:51 _ -rw-r--r-- 1 ben users 2609 Nov 29 23:08 AGENTS.md -rw-r--r-- 1 ben users 38933 Nov 22 12:59 all_tasks.json -rw-r--r-- 1 ben users 6409 Nov 14 20:53 Alpha.hs drwxr-xr-x 5 ben users 4096 Nov 21 06:13 Biz -rwxr-xr-x 1 ben users 1318 Nov 15 10:05 Biz.nix drwxr-xr-x 2 ben users 4096 May 21 2024 bs -rwxr-xr-x 1 ben users 2224 May 19 2025 BudgetReport.sh drwxr-xr-x 3 ben users 4096 Apr 10 2024 Control drwxr-xr-x 2 ben users 4096 Dec 21 2024 .ctags.d drwxr-xr-x 3 ben users 4096 Dec 21 2024 Data -rw-r--r-- 1 ben users 116 Jan 2 2025 default.nix drwxr-xr-x 3 ben users 4096 Dec 1 05:54 .direnv -rw-r--r-- 1 ben users 443 May 22 2025 .dir-locals.el -rw-r--r-- 1 ben users 244 Nov 11 2024 .editorconfig -rw-r--r-- 1 ben users 3338 Dec 1 03:34 .envrc -rw-r--r-- 1 ben users 1253 Nov 27 08:41 .envrc.local -rw-r--r-- 1 ben users 523 Nov 11 2024 .ghci drwxr-xr-x 10 ben users 4096 Dec 1 13:52 .git -rw-r--r-- 1 ben users 31 Nov 22 22:32 .gitattributes -rw-r--r-- 1 ben users 342 Nov 25 21:50 .gitignore -rw-r--r-- 1 ben users 95 Nov 22 12:59 .gitlint -rw-r--r-- 1 ben users 2431 Nov 11 2024 .hlint.yaml -rw-r--r-- 1 ben users 112 Nov 11 2024 .mailmap -rw-r--r-- 1 ben users 0 Nov 22 22:32 .merge_file_1mfrwM.lock drwxr-xr-x 3 ben users 4096 Nov 13 11:37 .mypy_cache drwxr-xr-x 3 ben users 4096 Nov 11 2024 Network drwxr-xr-x 5 ben users 4096 Nov 8 13:16 node_modules drwxr-xr-x 12 ben users 4096 Dec 1 03:59 Omni -rw-r--r-- 1 ben users 78 Nov 25 21:42 package.json -rw-r--r-- 1 ben users 7828 Nov 25 21:42 package-lock.json -rw-r--r-- 1 ben users 1828 Nov 22 22:33 pyproject.toml drwxr-xr-x 3 ben users 4096 Nov 12 21:22 .pytest_cache -rw-r--r-- 1 ben users 6463 Nov 22 22:32 README.md lrwxrwxrwx 1 ben users 51 Nov 30 20:19 result -> /nix/store/9xi9z7jsmayaf20ji201x2kfmg488ymd-omnidev drwxr-xr-x 9 ben users 4096 Nov 16 03:40 .ruff_cache -rw-r--r-- 1 ben users 73 Jan 2 2025 shell.nix drwxr-xr-x 3 ben users 4096 Apr 10 2024 System -rw-r--r-- 1 ben users 304173 Nov 27 18:11 tags -rw-r--r-- 1 ben users 238654 Nov 27 18:11 TAGS drwxr-xr-x 2 ben users 4096 Jan 2 2025 Urbit -rw-r--r-- 1 ben users 695 Dec 21 2024 .vimrc -rw-r--r-- 1 ben users 13960 May 21 2024 z.scm
Good! Now let me read the AGENTS.md file:
AGENTS.md1: # Omni 2: 3: The Omni project is to leverage automation and asymmetries to create wealth. 4: 5: ## Critical Rules for AI Agents 6: 7: **CRITICAL**: This project uses `jr task` for ALL issue tracking. You MUST follow these rules: 8: 9: - ✅ Use `jr task` for ALL task/TODO tracking (`jr task create ... --json`) 10: - ✅ Link discovered work with `--discovered-from=<parent-id>` 11: - ✅ File bugs IMMEDIATELY when you discover unexpected behavior 12: - ✅ Add facts to the knowledge base when you learn something useful (`jr facts add ...`) 13: - ✅ Run `jr task ready --json` before asking "what should I work on?" 14: - ✅ Store AI planning docs in `_/llm` directory (NEVER in repo root) 15: - ❌ Do NOT use `todo_write` tool 16: - ❌ Do NOT create markdown TODO lists or task checklists 17: - ❌ Do NOT put TODO/FIXME comments in code 18: 19: ## Cheat Sheet 20: 21: **Standard workflow:** 22: ```bash 23: # 1. Find ready work 24: jr task ready --json 25: 26: # 2. Claim a task 27: jr task update <id> in-progress --json 28: 29: # 3. During work: create discovered issues 30: jr task create "Fix type error found" --discovered-from=<current-id> --json 31: 32: # 4. Complete the task 33: jr task update <id> done --json 34: ``` 35: 36: **Bug Discovery:** 37: ```bash 38: # Create a task immediately 39: jr task create "Command X fails when Y" --discovered-from=<current-task-id> --json 40: ``` 41: 42: ## Directory Structure 43: 44: - **`_/`** (cabdir) - All ephemeral/generated files. This directory is gitignored. 45: - `_/llm/` - AI planning docs and agent logs 46: - `_/tmp/` - Temporary files, test databases, scratch data 47: - Never create dotfile directories (like `.tasks/`) in the repo root 48: 49: ## Common Commands 50: 51: **Build:** 52: ```bash 53: bild Omni/Jr.hs # Build a Haskell namespace 54: bild Biz/Cloud/Api.py # Build a Python namespace 55: ``` 56: 57: **Lint and Format:** 58: ```bash 59: lint Omni/Cli.hs # Lint a file (DO NOT use hlint directly) 60: lint --fix **/*.py # Lint and auto-fix Python files 61: ``` 62: 63: **Type Check:** 64: ```bash 65: typecheck.sh Omni/Bild/Example.py # Run mypy on Python files 66: ``` 67: 68: **Test:** 69: ```bash 70: bild --test Omni/Jr.hs # Build and run tests for a namespace 71: ``` 72: 73: **Run:** 74: ```bash 75: Omni/Ide/run.sh Omni/Jr.hs # Build (if needed) and run 76: ``` 77: 78: ## Documentation 79: 80: - **Project Context**: [README.md](README.md) - Goals, source layout, and coding conventions. 81: - **Task Manager**: [`Omni/Task/README.md`](Omni/Task/README.md) - Detailed usage, dependency management, and agent best practices. 82: - **Build Tool (Bild)**: [`Omni/Bild/README.md`](Omni/Bild/README.md) - How to use `bild` and manage dependencies. 83: - **Development Tools**: [`Omni/Ide/README.md`](Omni/Ide/README.md) - `run.sh`, `lint`, `repl.sh`, git workflow.
Now let me explore the Omni/Jr.hs namespace to understand the Agent Log box implementation:
find Omni -type f -name "*.hs" | grep -i "jr\|log" | head -20Omni/Jr/Web.hs Omni/Jr/Web/Style.hs Omni/Agent/Log.hs Omni/Log/Terminal.hs Omni/Log/Concurrent.hs Omni/Jr.hs Omni/Log.hs
Great! Let me check the Jr.hs file and the Agent Log related files:
Omni/Jr.hs1: #!/usr/bin/env run.sh
2: {-# LANGUAGE OverloadedStrings #-}
3: {-# LANGUAGE QuasiQuotes #-}
4: {-# LANGUAGE NoImplicitPrelude #-}
5:
6: -- : out jr
7: -- : dep sqlite-simple
8: -- : dep warp
9: -- : dep servant-server
10: -- : dep lucid
11: -- : dep servant-lucid
12: module Omni.Jr where
13:
14: import Alpha
15: import qualified Data.Aeson as Aeson
16: import qualified Data.ByteString.Lazy.Char8 as BLC
17: import qualified Data.List as List
18: import qualified Data.Text as Text
19: import qualified Omni.Agent.Core as AgentCore
20: import qualified Omni.Agent.Engine as Engine
21: import qualified Omni.Agent.Worker as AgentWorker
22: import qualified Omni.Cli as Cli
23: import qualified Omni.Fact as Fact
24: import qualified Omni.Jr.Web as Web
25: import qualified Omni.Task as Task
26: import qualified Omni.Task.Core as TaskCore
27: import qualified Omni.Test as Test
28: import qualified System.Console.Docopt as Docopt
29: import qualified System.Directory as Directory
30: import System.Environment (withArgs)
31: import qualified System.Environment as Env
32: import qualified System.Exit as Exit
33: import System.FilePath (takeFileName)
34: import qualified System.IO as IO
35: import qualified System.Process as Process
36:
37: main :: IO ()
38: main = Cli.main plan
39:
40: plan :: Cli.Plan ()
41: plan =
42: Cli.Plan
43: { Cli.help = help,
44: Cli.move = move,
45: Cli.test = test,
46: Cli.tidy = \_ -> pure ()
47: }
48:
49: help :: Cli.Docopt
50: help =
51: [Cli.docopt|
52: jr
53:
54: Usage:
55: jr task [<args>...]
56: jr work [<task-id>]
57: jr web [--port=PORT]
58: jr review [<task-id>] [--auto]
59: jr loop [--delay=SECONDS]
60: jr facts list [--project=PROJECT] [--json]
61: jr facts show <fact-id> [--json]
62: jr facts add <project> <content> [--files=FILES] [--task=TASK] [--confidence=CONF] [--json]
63: jr facts delete <fact-id> [--json]
64: jr test
65: jr (-h | --help)
66:
67: Commands:
68: task Manage tasks
69: work Start a worker agent on a task
70: web Start the web UI server
71: review Review a completed task (show diff, accept/reject)
72: loop Run autonomous work+review loop
73: facts Manage knowledge base facts
74:
75: Options:
76: -h --help Show this help
77: --port=PORT Port for web server [default: 8080]
78: --auto Auto-review: accept if tests pass, reject if they fail
79: --delay=SECONDS Delay between loop iterations [default: 5]
80: --project=PROJECT Filter facts by project
81: --files=FILES Comma-separated list of related files
82: --task=TASK Source task ID
83: --confidence=CONF Confidence level 0.0-1.0 [default: 0.8]
84: --json Output in JSON format
85: |]
86:
87: move :: Cli.Arguments -> IO ()
88: move args
89: | args `Cli.has` Cli.command "task" = do
90: let extraArgs = Cli.getAllArgs args (Cli.argument "args")
91: withArgs extraArgs Task.main
92: | args `Cli.has` Cli.command "web" = do
93: let port = case Cli.getArg args (Cli.longOption "port") of
94: Just p -> fromMaybe Web.defaultPort (readMaybe p)
95: Nothing -> Web.defaultPort
96: Web.run port
97: | args `Cli.has` Cli.command "work" = do
98: -- Always run in current directory
99: let path = "."
100:
101: -- Infer name from current directory
102: absPath <- Directory.getCurrentDirectory
103: let name = Text.pack (takeFileName absPath)
104:
105: let worker =
106: AgentCore.Worker
107: { AgentCore.workerName = name,
108: AgentCore.workerPid = Nothing,
109: AgentCore.workerStatus = AgentCore.Idle,
110: AgentCore.workerPath = path,
111: AgentCore.workerQuiet = False -- Show ANSI status bar for manual work
112: }
113:
114: let taskId = fmap Text.pack (Cli.getArg args (Cli.argument "task-id"))
115:
116: AgentWorker.start worker taskId
117: | args `Cli.has` Cli.command "review" = do
118: let autoMode = args `Cli.has` Cli.longOption "auto"
119: case Cli.getArg args (Cli.argument "task-id") of
120: Just tidStr -> reviewTask (Text.pack tidStr) autoMode
121: Nothing -> do
122: -- Find tasks in Review status
123: tasks <- TaskCore.loadTasks
124: let reviewTasks = filter (\t -> TaskCore.taskStatus t == TaskCore.Review) tasks
125: case reviewTasks of
126: [] -> putText "No tasks in Review status."
127: (t : _) -> reviewTask (TaskCore.taskId t) autoMode
128: | args `Cli.has` Cli.command "loop" = do
129: let delay = case Cli.getArg args (Cli.longOption "delay") of
130: Just d -> fromMaybe 5 (readMaybe d)
131: Nothing -> 5
132: runLoop delay
133: | args `Cli.has` Cli.command "facts" = handleFacts args
134: | otherwise = putText (str <| Docopt.usage help)
135:
136: -- | Run the autonomous loop: work -> review -> repeat
137: runLoop :: Int -> IO ()
138: runLoop delaySec = do
139: putText "[loop] Starting autonomous jr loop..."
140: putText ("[loop] Delay between iterations: " <> tshow delaySec <> "s")
141: go
142: where
143: go = do
144: -- First check for tasks to review (prioritize finishing work)
145: reviewResult <- reviewPending
146: if reviewResult
147: then do
148: -- Reviewed something, continue loop immediately
149: threadDelay (delaySec * 1000000)
150: go
151: else do
152: -- No reviews, check for ready work
153: readyTasks <- TaskCore.getReadyTasks
154: case readyTasks of
155: [] -> do
156: putText "[loop] No ready tasks, no pending reviews."
157: (task : _) -> do
158: putText ""
159: putText ("[loop] === Working on: " <> TaskCore.taskId task <> " ===")
160: -- Run worker (this blocks until the engine completes)
161: absPath <- Directory.getCurrentDirectory
162: let name = Text.pack (takeFileName absPath)
163: let worker =
164: AgentCore.Worker
165: { AgentCore.workerName = name,
166: AgentCore.workerPid = Nothing,
167: AgentCore.workerStatus = AgentCore.Idle,
168: AgentCore.workerPath = ".",
169: AgentCore.workerQuiet = True -- No ANSI status bar in loop mode
170: }
171: putText "[loop] Starting worker..."
172: AgentWorker.start worker (Just (TaskCore.taskId task))
173: putText "[loop] Worker finished."
174:
175: -- Delay and loop
176: putText ("[loop] Sleeping " <> tshow delaySec <> "s...")
177: threadDelay (delaySec * 1000000)
178: go
179:
180: -- Returns True if a task was reviewed, False otherwise
181: reviewPending :: IO Bool
182: reviewPending = do
183: tasks <- TaskCore.loadTasks
184: let reviewTasks = filter (\t -> TaskCore.taskStatus t == TaskCore.Review) tasks
185: case reviewTasks of
186: [] -> pure False
187: (t : _) -> do
188: putText ""
189: putText ("[loop] === Reviewing: " <> TaskCore.taskId t <> " ===")
190: tryAutoReview (TaskCore.taskId t)
191: pure True
192:
193: -- Auto-review that doesn't exit on missing commit
194: tryAutoReview :: Text -> IO ()
195: tryAutoReview tid = do
196: tasks <- TaskCore.loadTasks
197: case TaskCore.findTask tid tasks of
198: Nothing -> do
199: putText ("[review] Task " <> tid <> " not found.")
200: Just task -> do
201: let grepArg = "--grep=" <> Text.unpack tid
202: (code, shaOut, _) <-
203: Process.readProcessWithExitCode
204: "git"
205: ["log", "--pretty=format:%H", "-n", "1", grepArg]
206: ""
207:
208: if code /= Exit.ExitSuccess || null shaOut
209: then do
210: putText "[review] No commit found for this task."
211: putText "[review] Resetting to Open for retry."
212: TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.System
213: else do
214: let commitSha = case List.lines shaOut of
215: (x : _) -> x
216: [] -> ""
217:
218: -- Check for merge conflicts
219: conflictResult <- checkMergeConflict commitSha
220: case conflictResult of
221: Just conflictFiles -> do
222: putText "[review] MERGE CONFLICT DETECTED"
223: traverse_ (\f -> putText (" - " <> f)) conflictFiles
224: handleConflict tid conflictFiles commitSha
225: Nothing -> do
226: autoReview tid task commitSha
227:
228: -- | Handle merge conflict during review (Gerrit-style: provide rich context)
229: handleConflict :: Text -> [Text] -> String -> IO ()
230: handleConflict tid conflictFiles commitSha = do
231: maybeCtx <- TaskCore.getRetryContext tid
232: let attempt = maybe 1 (\c -> TaskCore.retryAttempt c + 1) maybeCtx
233:
234: let conflictComment = buildConflictComment commitSha conflictFiles attempt
235: _ <- TaskCore.addComment tid conflictComment TaskCore.Junior
236:
237: if attempt > 3
238: then do
239: putText "[review] Task has failed 3 times. Needs human intervention."
240: TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.System
241: else do
242: conflictDetails <- gatherConflictContext commitSha conflictFiles
243: maybeExistingCtx <- TaskCore.getRetryContext tid
244: let currentReason = "attempt " <> tshow attempt <> ":\n" <> conflictDetails
245: let accumulatedReason = case maybeExistingCtx of
246: Nothing -> currentReason
247: Just ctx -> TaskCore.retryReason ctx <> "\n\n" <> currentReason
248: TaskCore.setRetryContext
249: TaskCore.RetryContext
250: { TaskCore.retryTaskId = tid,
251: TaskCore.retryOriginalCommit = Text.pack commitSha,
252: TaskCore.retryConflictFiles = conflictFiles,
253: TaskCore.retryAttempt = attempt,
254: TaskCore.retryReason = accumulatedReason,
255: TaskCore.retryNotes = maybeExistingCtx +> TaskCore.retryNotes
256: }
257: TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.System
258: putText ("[review] Task " <> tid <> " returned to queue (attempt " <> tshow attempt <> "/3).")
259:
260: -- | Build a review comment for merge conflicts
261: buildConflictComment :: String -> [Text] -> Int -> Text
262: buildConflictComment commitSha conflictFiles attempt =
263: Text.unlines
264: [ "## Auto-Review: Merge Conflict",
265: "",
266: "**Commit:** " <> Text.pack (take 8 commitSha),
267: "**Result:** ✗ MERGE CONFLICT",
268: "**Attempt:** " <> tshow attempt <> "/3",
269: "",
270: "### Conflicting Files",
271: Text.unlines (map ("- " <>) conflictFiles),
272: "Task returned to queue for conflict resolution."
273: ]
274:
275: -- | Gather Gerrit-style conflict context for the coder
276: gatherConflictContext :: String -> [Text] -> IO Text
277: gatherConflictContext commitSha conflictFiles = do
278: commitInfo <- getCommitInfo commitSha
279: currentHeadInfo <- getCurrentHeadInfo
280: fileDiffs <- traverse (getFileConflictInfo commitSha <. Text.unpack) conflictFiles
281:
282: pure
283: <| Text.unlines
284: [ "MERGE CONFLICT - Your changes could not be cleanly applied",
285: "",
286: "== Your Commit ==",
287: commitInfo,
288: "",
289: "== Current HEAD ==",
290: currentHeadInfo,
291: "",
292: "== Conflicting Files ==",
293: Text.unlines fileDiffs,
294: "",
295: "== Resolution Instructions ==",
296: "1. The codebase has been updated since your work",
297: "2. Review the current state of conflicting files",
298: "3. Re-implement your changes on top of the current code",
299: "4. Ensure your changes still make sense given the updates"
300: ]
301:
302: -- | Get info about the commit that caused the conflict
303: getCommitInfo :: String -> IO Text
304: getCommitInfo sha = do
305: (_, out, _) <-
306: Process.readProcessWithExitCode
307: "git"
308: ["log", "-1", "--format=%h %s%n%b", sha]
309: ""
310: pure <| Text.pack out
311:
312: -- | Get info about current HEAD
313: getCurrentHeadInfo :: IO Text
314: getCurrentHeadInfo = do
315: (_, out, _) <-
316: Process.readProcessWithExitCode
317: "git"
318: ["log", "-1", "--format=%h %s (%cr)"]
319: ""
320: pure <| Text.pack out
321:
322: -- | Get file-level conflict context showing what changed in both branches
323: getFileConflictInfo :: String -> FilePath -> IO Text
324: getFileConflictInfo commitSha filePath = do
325: yourChanges <- getYourChangesToFile commitSha filePath
326: recentChanges <- getRecentChangesToFile filePath
327: pure
328: <| Text.unlines
329: [ "--- " <> Text.pack filePath <> " ---",
330: "",
331: "Your changes to this file:",
332: yourChanges,
333: "",
334: "Recent changes by others:",
335: recentChanges
336: ]
337:
338: -- | Get a summary of changes in a specific commit to a file
339: getYourChangesToFile :: String -> FilePath -> IO Text
340: getYourChangesToFile commitSha filePath = do
341: (code, out, _) <-
342: Process.readProcessWithExitCode
343: "git"
344: ["show", "--stat", commitSha, "--", filePath]
345: ""
346: case code of
347: Exit.ExitSuccess -> pure <| Text.pack (take 500 out)
348: Exit.ExitFailure _ -> pure "(unable to get diff)"
349:
350: -- | Get recent changes to a file (last few commits)
351: getRecentChangesToFile :: FilePath -> IO Text
352: getRecentChangesToFile filePath = do
353: (code, out, _) <-
354: Process.readProcessWithExitCode
355: "git"
356: ["log", "-3", "--oneline", "--", filePath]
357: ""
358: case code of
359: Exit.ExitSuccess -> pure <| Text.pack out
360: Exit.ExitFailure _ -> pure "(unable to get history)"
361:
362: -- | Interactive review command (jr review <task-id>)
363: reviewTask :: Text -> Bool -> IO ()
364: reviewTask tid autoMode = do
365: tasks <- TaskCore.loadTasks
366: case TaskCore.findTask tid tasks of
367: Nothing -> do
368: putText ("Task " <> tid <> " not found.")
369: Exit.exitFailure
370: Just task -> do
371: unless autoMode <| TaskCore.showTaskDetailed task
372:
373: let grepArg = "--grep=" <> Text.unpack tid
374: (code, shaOut, _) <-
375: Process.readProcessWithExitCode
376: "git"
377: ["log", "--pretty=format:%H", "-n", "1", grepArg]
378: ""
379:
380: when (code /= Exit.ExitSuccess || null shaOut) <| do
381: putText "\nNo commit found for this task."
382: putText "The worker may not have completed yet, or the commit message doesn't include the task ID."
383: Exit.exitFailure
384:
385: let commitSha = case List.lines shaOut of
386: (x : _) -> x
387: [] -> ""
388:
389: -- Check for merge conflicts before showing diff
390: conflictResult <- checkMergeConflict commitSha
391: case conflictResult of
392: Just conflictFiles -> do
393: putText "\n=== MERGE CONFLICT DETECTED ==="
394: traverse_ (\f -> putText (" - " <> f)) conflictFiles
395: handleConflict tid conflictFiles commitSha
396: Nothing -> do
397: if autoMode
398: then autoReview tid task commitSha
399: else interactiveReview tid task commitSha
400:
401: -- | Auto-review: run tests on namespace, accept if pass, reject if fail
402: autoReview :: Text -> TaskCore.Task -> String -> IO ()
403: autoReview tid task commitSha = do
404: putText "[review] Running automated review..."
405: putText ("[review] Commit: " <> Text.pack (take 8 commitSha))
406:
407: let namespace = fromMaybe "." (TaskCore.taskNamespace task)
408: let testTarget = Text.unpack namespace
409:
410: putText ("[review] Testing: " <> Text.pack testTarget)
411:
412: (testCode, testOut, testErr) <-
413: Process.readProcessWithExitCode
414: "bild"
415: ["--test", testTarget]
416: ""
417:
418: case testCode of
419: Exit.ExitSuccess -> do
420: putText "[review] ✓ Tests passed."
421: let reviewComment = buildReviewComment commitSha testTarget True testOut testErr
422: _ <- TaskCore.addComment tid reviewComment TaskCore.Junior
423: TaskCore.clearRetryContext tid
424: TaskCore.updateTaskStatusWithActor tid TaskCore.Done [] TaskCore.System
425: putText ("[review] Task " <> tid <> " -> Done")
426: addCompletionSummary tid commitSha
427: extractFacts tid commitSha
428: checkEpicCompletion task
429: Exit.ExitFailure code -> do
430: putText ("[review] ✗ Tests failed (exit " <> tshow code <> ")")
431: let reason = "Test failure:\n" <> Text.pack testOut <> Text.pack testErr
432:
433: maybeCtx <- TaskCore.getRetryContext tid
434: let attempt = maybe 1 (\ctx -> TaskCore.retryAttempt ctx + 1) maybeCtx
435:
436: let reviewComment = buildReviewComment commitSha testTarget False testOut testErr
437: _ <- TaskCore.addComment tid reviewComment TaskCore.Junior
438:
439: if attempt > 3
440: then do
441: putText "[review] Task has failed 3 times. Needs human intervention."
442: TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.System
443: else do
444: let currentReason = "attempt " <> tshow attempt <> ": " <> reason
445: let accumulatedReason = case maybeCtx of
446: Nothing -> currentReason
447: Just ctx -> TaskCore.retryReason ctx <> "\n" <> currentReason
448: TaskCore.setRetryContext
449: TaskCore.RetryContext
450: { TaskCore.retryTaskId = tid,
451: TaskCore.retryOriginalCommit = Text.pack commitSha,
452: TaskCore.retryConflictFiles = [],
453: TaskCore.retryAttempt = attempt,
454: TaskCore.retryReason = accumulatedReason,
455: TaskCore.retryNotes = maybeCtx +> TaskCore.retryNotes
456: }
457: TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.System
458: putText ("[review] Task " <> tid <> " reopened (attempt " <> tshow attempt <> "/3).")
459:
460: -- | Build a review comment summarizing what was tested and the result
461: buildReviewComment :: String -> String -> Bool -> String -> String -> Text
462: buildReviewComment commitSha testTarget passed testOut testErr =
463: Text.unlines
464: [ "## Auto-Review",
465: "",
466: "**Commit:** " <> Text.pack (take 8 commitSha),
467: "**Test target:** " <> Text.pack testTarget,
468: "**Result:** " <> if passed then "✓ PASSED" else "✗ FAILED",
469: "",
470: if passed
471: then "All tests passed. Task accepted."
472: else
473: Text.unlines
474: [ "### Test Output",
475: "```",
476: Text.pack (truncateOutput 1000 (testOut ++ testErr)),
477: "```",
478: "",
479: "Task rejected and returned to queue for retry."
480: ]
481: ]
482:
483: -- | Truncate output to a maximum number of characters
484: truncateOutput :: Int -> String -> String
485: truncateOutput maxLen s
486: | length s <= maxLen = s
487: | otherwise = take maxLen s ++ "\n... (truncated)"
488:
489: -- | Interactive review with user prompts
490: interactiveReview :: Text -> TaskCore.Task -> String -> IO ()
491: interactiveReview tid task commitSha = do
492: putText "\n=== Diff for this task ===\n"
493: _ <- Process.rawSystem "git" ["show", commitSha]
494:
495: putText "\n[a]ccept / [r]eject / [s]kip? "
496: IO.hFlush IO.stdout
497: choice <- getLine
498:
499: case Text.toLower choice of
500: c
501: | "a" `Text.isPrefixOf` c -> do
502: let acceptComment = buildHumanReviewComment commitSha True Nothing
503: _ <- TaskCore.addComment tid acceptComment TaskCore.Human
504: TaskCore.clearRetryContext tid
505: TaskCore.updateTaskStatusWithActor tid TaskCore.Done [] TaskCore.Human
506: putText ("Task " <> tid <> " marked as Done.")
507: addCompletionSummary tid commitSha
508: extractFacts tid commitSha
509: checkEpicCompletion task
510: | "r" `Text.isPrefixOf` c -> do
511: putText "Enter rejection reason: "
512: IO.hFlush IO.stdout
513: reason <- getLine
514: let rejectComment = buildHumanReviewComment commitSha False (Just reason)
515: _ <- TaskCore.addComment tid rejectComment TaskCore.Human
516: maybeCtx <- TaskCore.getRetryContext tid
517: let attempt = maybe 1 (\ctx -> TaskCore.retryAttempt ctx + 1) maybeCtx
518: let currentReason = "attempt " <> tshow attempt <> ": rejected: " <> reason
519: let accumulatedReason = case maybeCtx of
520: Nothing -> currentReason
521: Just ctx -> TaskCore.retryReason ctx <> "\n" <> currentReason
522: TaskCore.setRetryContext
523: TaskCore.RetryContext
524: { TaskCore.retryTaskId = tid,
525: TaskCore.retryOriginalCommit = Text.pack commitSha,
526: TaskCore.retryConflictFiles = [],
527: TaskCore.retryAttempt = attempt,
528: TaskCore.retryReason = accumulatedReason,
529: TaskCore.retryNotes = maybeCtx +> TaskCore.retryNotes
530: }
531: TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.Human
532: putText ("Task " <> tid <> " reopened (attempt " <> tshow attempt <> "/3).")
533: | otherwise -> putText "Skipped; no status change."
534:
535: -- | Build a human review comment
536: buildHumanReviewComment :: String -> Bool -> Maybe Text -> Text
537: buildHumanReviewComment commitSha accepted maybeReason =
538: Text.unlines
539: [ "## Human Review",
540: "",
541: "**Commit:** " <> Text.pack (take 8 commitSha),
542: "**Result:** " <> if accepted then "✓ ACCEPTED" else "✗ REJECTED",
543: case maybeReason of
544: Just reason -> "**Reason:** " <> reason
545: Nothing -> ""
546: ]
547:
548: -- | Check if a commit can be cleanly cherry-picked onto live
549: -- Returns Nothing if clean, Just [conflicting files] if conflict
550: checkMergeConflict :: String -> IO (Maybe [Text])
551: checkMergeConflict commitSha = do
552: -- Save current state
553: (_, _, _) <- Process.readProcessWithExitCode "git" ["branch", "--show-current"] ""
554: (_, origHead, _) <- Process.readProcessWithExitCode "git" ["rev-parse", "HEAD"] ""
555:
556: -- Try cherry-pick
557: (cpCode, _, cpErr) <-
558: Process.readProcessWithExitCode
559: "git"
560: ["cherry-pick", "--no-commit", commitSha]
561: ""
562:
563: -- Always abort/reset regardless of result
564: _ <- Process.readProcessWithExitCode "git" ["cherry-pick", "--abort"] ""
565: _ <- Process.readProcessWithExitCode "git" ["reset", "--hard", List.head (List.lines origHead)] ""
566:
567: case cpCode of
568: Exit.ExitSuccess -> pure Nothing
569: Exit.ExitFailure _ -> do
570: -- Parse conflict files from error message
571: let errLines = Text.lines (Text.pack cpErr)
572: conflictLines = filter (Text.isPrefixOf "CONFLICT") errLines
573: -- Extract file names (rough parsing)
574: files = mapMaybe extractConflictFile conflictLines
575: pure (Just (if null files then ["(unknown files)"] else files))
576:
577: extractConflictFile :: Text -> Maybe Text
578: extractConflictFile line =
579: -- CONFLICT (content): Merge conflict in path/to/file.hs
580: case Text.breakOn "Merge conflict in " line of
581: (_, rest)
582: | not (Text.null rest) -> Just (Text.strip (Text.drop 18 rest))
583: _ -> case Text.breakOn "in " line of
584: (_, rest)
585: | not (Text.null rest) -> Just (Text.strip (Text.drop 3 rest))
586: _ -> Nothing
587:
588: -- | Generate and add a completion summary comment for a task
589: addCompletionSummary :: Text -> String -> IO ()
590: addCompletionSummary tid commitSha = do
591: -- Get the diff and commit message for this commit
592: (diffCode, diffOut, _) <- Process.readProcessWithExitCode "git" ["show", "--stat", commitSha] ""
593: (msgCode, msgOut, _) <- Process.readProcessWithExitCode "git" ["log", "-1", "--format=%B", commitSha] ""
594:
595: when (diffCode == Exit.ExitSuccess && msgCode == Exit.ExitSuccess) <| do
596: -- Get list of modified files
597: (filesCode, filesOut, _) <- Process.readProcessWithExitCode "git" ["diff-tree", "--no-commit-id", "--name-only", "-r", commitSha] ""
598:
599: let files = if filesCode == Exit.ExitSuccess then List.lines filesOut else []
600: commitMessage = Text.pack msgOut
601: diffSummary = Text.pack diffOut
602:
603: -- Build prompt for llm
604: let prompt = buildCompletionPrompt tid commitMessage diffSummary files
605:
606: -- Try to get API key
607: maybeApiKey <- Env.lookupEnv "OPENROUTER_API_KEY"
608: case maybeApiKey of
609: Nothing -> do
610: putText "[review] Warning: OPENROUTER_API_KEY not set, skipping completion summary"
611: Just apiKey -> do
612: -- Call LLM via Engine.chat
613: let llm = Engine.defaultLLM {Engine.llmApiKey = Text.pack apiKey}
614: messages = [Engine.Message Engine.User prompt Nothing Nothing]
615:
616: result <- Engine.chat llm [] messages
617: case result of
618: Left err -> do
619: putText ("[review] Failed to generate completion summary: " <> err)
620: Right msg -> do
621: let summary = Text.strip (Engine.msgContent msg)
622: unless (Text.null summary) <| do
623: _ <- TaskCore.addComment tid ("## Completion Summary\n\n" <> summary) TaskCore.Junior
624: putText "[review] Added completion summary comment"
625:
626: -- | Build prompt for LLM to generate completion summary
627: buildCompletionPrompt :: Text -> Text -> Text -> [String] -> Text
628: buildCompletionPrompt tid commitMessage diffSummary files =
629: Text.unlines
630: [ "Generate a concise completion summary for this task. The summary should be 2-4 sentences.",
631: "",
632: "Task ID: " <> tid,
633: "",
634: "Commit Message:",
635: commitMessage,
636: "",
637: "Files Modified (" <> tshow (length files) <> "):",
638: Text.unlines (map Text.pack (take 10 files)),
639: if length files > 10 then "... and " <> tshow (length files - 10) <> " more files" else "",
640: "",
641: "Diff Summary:",
642: diffSummary,
643: "",
644: "Write a brief summary that includes:",
645: "- What was accomplished (from the commit message and changes)",
646: "- Key files that were modified (mention 2-3 most important ones)",
647: "",
648: "Keep it professional and concise. Do NOT include markdown headers or formatting.",
649: "Just return the plain summary text."
650: ]
651:
652: -- | Extract facts from completed task
653: extractFacts :: Text -> String -> IO ()
654: extractFacts tid commitSha = do
655: -- Get the diff for this commit
656: (_, diffOut, _) <- Process.readProcessWithExitCode "git" ["show", "--stat", commitSha] ""
657:
658: -- Get task context
659: tasks <- TaskCore.loadTasks
660: case TaskCore.findTask tid tasks of
661: Nothing -> pure ()
662: Just task -> do
663: let prompt = buildFactExtractionPrompt task diffOut
664:
665: -- Try to get API key
666: maybeApiKey <- Env.lookupEnv "OPENROUTER_API_KEY"
667: case maybeApiKey of
668: Nothing -> do
669: putText "[facts] Warning: OPENROUTER_API_KEY not set, skipping fact extraction"
670: Just apiKey -> do
671: -- Call LLM via Engine.chat
672: let llm = Engine.defaultLLM {Engine.llmApiKey = Text.pack apiKey}
673: messages = [Engine.Message Engine.User prompt Nothing Nothing]
674:
675: result <- Engine.chat llm [] messages
676: case result of
677: Left err -> do
678: putText ("[facts] Failed to extract facts: " <> err)
679: Right msg -> do
680: parseFacts tid (Text.unpack (Engine.msgContent msg))
681:
682: -- | Build prompt for LLM to extract facts from completed task
683: buildFactExtractionPrompt :: TaskCore.Task -> String -> Text
684: buildFactExtractionPrompt task diffSummary =
685: Text.unlines
686: [ "You just completed the following task:",
687: "",
688: "Task: " <> TaskCore.taskId task,
689: "Title: " <> TaskCore.taskTitle task,
690: "Description: " <> TaskCore.taskDescription task,
691: "",
692: "Diff summary:",
693: Text.pack diffSummary,
694: "",
695: "List any facts you learned about this codebase that would be useful for future tasks.",
696: "Each fact should be on its own line, starting with 'FACT: '.",
697: "Include the relevant file paths in brackets after each fact.",
698: "Example: FACT: The Alpha module re-exports common Prelude functions [Alpha.hs]",
699: "If you didn't learn anything notable, respond with 'NO_FACTS'."
700: ]
701:
702: -- | Parse facts from LLM output and add them to the knowledge base
703: parseFacts :: Text -> String -> IO ()
704: parseFacts tid output = do
705: let outputLines = Text.lines (Text.pack output)
706: factLines = filter (Text.isPrefixOf "FACT: ") outputLines
707: traverse_ (addFactFromLine tid) factLines
708:
709: -- | Parse a single fact line and add it to the knowledge base
710: addFactFromLine :: Text -> Text -> IO ()
711: addFactFromLine tid line = do
712: let content = Text.drop 6 line -- Remove "FACT: "
713: (factText, filesRaw) = Text.breakOn " [" content
714: files = parseFiles filesRaw
715: _ <- Fact.createFact "Omni" factText files (Just tid) 0.7 -- Lower initial confidence
716: putText ("[facts] Added: " <> factText)
717:
718: -- | Parse file list from brackets [file1, file2, ...]
719: parseFiles :: Text -> [Text]
720: parseFiles raw
721: | Text.null raw = []
722: | not ("[" `Text.isInfixOf` raw) = []
723: | otherwise =
724: let stripped = Text.strip (Text.dropWhile (/= '[') raw)
725: inner = Text.dropEnd 1 (Text.drop 1 stripped) -- Remove [ and ]
726: trimmed = Text.strip inner
727: in if Text.null trimmed
728: then []
729: else map Text.strip (Text.splitOn "," inner)
730:
731: -- | Generate a summary comment for an epic when all children are complete
732: generateEpicSummary :: Text -> TaskCore.Task -> [TaskCore.Task] -> IO ()
733: generateEpicSummary epicId epic children = do
734: putText "[epic] Generating summary for completed epic..."
735:
736: -- Try to get API key
737: maybeApiKey <- Env.lookupEnv "OPENROUTER_API_KEY"
738: case maybeApiKey of
739: Nothing -> do
740: putText "[epic] Warning: OPENROUTER_API_KEY not set, skipping summary generation"
741: pure ()
742: Just apiKey -> do
743: -- Build the prompt for LLM
744: prompt <- buildEpicSummaryPrompt epic children
745:
746: -- Call LLM
747: let llm = Engine.defaultLLM {Engine.llmApiKey = Text.pack apiKey}
748: messages = [Engine.Message Engine.User prompt Nothing Nothing]
749:
750: result <- Engine.chat llm [] messages
751: case result of
752: Left err -> do
753: putText ("[epic] Failed to generate summary: " <> err)
754: Right msg -> do
755: let summary = Engine.msgContent msg
756: _ <- TaskCore.addComment epicId summary TaskCore.Junior
757: putText "[epic] Summary comment added to epic"
758:
759: -- | Build a prompt for the LLM to summarize an epic
760: buildEpicSummaryPrompt :: TaskCore.Task -> [TaskCore.Task] -> IO Text
761: buildEpicSummaryPrompt epic children = do
762: -- Get commit info for each child task
763: childSummaries <- traverse summarizeChildTask children
764:
765: pure
766: <| Text.unlines
767: [ "Generate a concise summary comment for this completed epic.",
768: "",
769: "## Epic Information",
770: "**Title:** " <> TaskCore.taskTitle epic,
771: "**Description:**",
772: TaskCore.taskDescription epic,
773: "",
774: "## Completed Child Tasks (" <> tshow (length children) <> ")",
775: Text.unlines childSummaries,
776: "",
777: "## Instructions",
778: "Create a markdown summary that includes:",
779: "1. A brief overview of what was accomplished",
780: "2. List of completed tasks with their titles",
781: "3. Key changes or files modified (if mentioned in task descriptions)",
782: "4. Any notable patterns or themes across the work",
783: "",
784: "Format the summary as a markdown comment starting with '## Epic Summary'.",
785: "Keep it concise but informative."
786: ]
787:
788: -- | Summarize a single child task for the epic summary
789: summarizeChildTask :: TaskCore.Task -> IO Text
790: summarizeChildTask task = do
791: -- Try to get commit info
792: let grepArg = "--grep=" <> Text.unpack (TaskCore.taskId task)
793: (code, shaOut, _) <-
794: Process.readProcessWithExitCode
795: "git"
796: ["log", "--pretty=format:%h %s", "-n", "1", grepArg]
797: ""
798:
799: let commitInfo =
800: if code == Exit.ExitSuccess && not (null shaOut)
801: then " [" <> Text.pack (take 80 shaOut) <> "]"
802: else ""
803:
804: -- Get files changed in the commit
805: filesInfo <- getCommitFiles (TaskCore.taskId task)
806:
807: pure <| "- **" <> TaskCore.taskId task <> "**: " <> TaskCore.taskTitle task <> commitInfo <> filesInfo
808:
809: -- | Get files modified in a commit for a task
810: getCommitFiles :: Text -> IO Text
811: getCommitFiles taskId = do
812: let grepArg = "--grep=" <> Text.unpack taskId
813: (code, shaOut, _) <-
814: Process.readProcessWithExitCode
815: "git"
816: ["log", "--pretty=format:%H", "-n", "1", grepArg]
817: ""
818:
819: if code /= Exit.ExitSuccess || null shaOut
820: then pure ""
821: else do
822: let sha = List.head (List.lines shaOut)
823: (fileCode, filesOut, _) <-
824: Process.readProcessWithExitCode
825: "git"
826: ["diff-tree", "--no-commit-id", "--name-only", "-r", sha]
827: ""
828: if fileCode /= Exit.ExitSuccess || null filesOut
829: then pure ""
830: else do
831: let files = List.lines filesOut
832: fileList = List.take 3 files -- Limit to first 3 files
833: moreCount = length files - 3
834: filesText = Text.intercalate ", " (map Text.pack fileList)
835: suffix = if moreCount > 0 then " (+" <> tshow moreCount <> " more)" else ""
836: pure <| if null files then "" else " — " <> filesText <> suffix
837:
838: -- | Check if all children of an epic are Done, and if so, transition epic to Review
839: checkEpicCompletion :: TaskCore.Task -> IO ()
840: checkEpicCompletion task =
841: case TaskCore.taskParent task of
842: Nothing -> pure ()
843: Just parentId -> do
844: tasks <- TaskCore.loadTasks
845: case TaskCore.findTask parentId tasks of
846: Nothing -> pure ()
847: Just parentTask ->
848: when (TaskCore.taskType parentTask == TaskCore.Epic) <| do
849: let children = filter (hasParent parentId) tasks
850: allDone = all (\t -> TaskCore.taskStatus t == TaskCore.Done) children
851: when (allDone && not (null children)) <| do
852: putText ("[review] All children of epic " <> parentId <> " are Done.")
853: TaskCore.updateTaskStatusWithActor parentId TaskCore.Review [] TaskCore.System
854: putText ("[review] Epic " <> parentId <> " -> Review")
855: -- Generate summary comment for the epic
856: generateEpicSummary parentId parentTask children
857: where
858: hasParent pid t = maybe False (TaskCore.matchesId pid) (TaskCore.taskParent t)
859:
860: -- | Handle facts subcommands
861: handleFacts :: Cli.Arguments -> IO ()
862: handleFacts args
863: | args `Cli.has` Cli.command "list" = do
864: let maybeProject = Text.pack </ Cli.getArg args (Cli.longOption "project")
865: jsonMode = args `Cli.has` Cli.longOption "json"
866: facts <- maybe Fact.getAllFacts Fact.getFactsByProject maybeProject
867: if jsonMode
868: then BLC.putStrLn (Aeson.encode facts)
869: else traverse_ printFact facts
870: | args `Cli.has` Cli.command "show" = do
871: let jsonMode = args `Cli.has` Cli.longOption "json"
872: case Cli.getArg args (Cli.argument "fact-id") of
873: Nothing -> putText "fact-id required"
874: Just fidStr -> case readMaybe fidStr of
875: Nothing -> putText "Invalid fact ID (must be integer)"
876: Just fid -> do
877: maybeFact <- Fact.getFact fid
878: case maybeFact of
879: Nothing -> putText "Fact not found"
880: Just fact ->
881: if jsonMode
882: then BLC.putStrLn (Aeson.encode fact)
883: else printFactDetailed fact
884: | args `Cli.has` Cli.command "add" = do
885: let jsonMode = args `Cli.has` Cli.longOption "json"
886: case (Cli.getArg args (Cli.argument "project"), Cli.getArg args (Cli.argument "content")) of
887: (Just proj, Just content) -> do
888: let files = case Cli.getArg args (Cli.longOption "files") of
889: Just f -> Text.splitOn "," (Text.pack f)
890: Nothing -> []
891: sourceTask = Text.pack </ Cli.getArg args (Cli.longOption "task")
892: confidence = case Cli.getArg args (Cli.longOption "confidence") of
893: Just c -> fromMaybe 0.8 (readMaybe c)
894: Nothing -> 0.8
895: factId <- Fact.createFact (Text.pack proj) (Text.pack content) files sourceTask confidence
896: if jsonMode
897: then BLC.putStrLn (Aeson.encode (Aeson.object ["id" Aeson..= factId, "success" Aeson..= True]))
898: else putText ("Created fact: " <> tshow factId)
899: _ -> putText "project and content required"
900: | args `Cli.has` Cli.command "delete" = do
901: let jsonMode = args `Cli.has` Cli.longOption "json"
902: case Cli.getArg args (Cli.argument "fact-id") of
903: Nothing -> putText "fact-id required"
904: Just fidStr -> case readMaybe fidStr of
905: Nothing -> putText "Invalid fact ID (must be integer)"
906: Just fid -> do
907: Fact.deleteFact fid
908: if jsonMode
909: then BLC.putStrLn (Aeson.encode (Aeson.object ["success" Aeson..= True, "message" Aeson..= ("Deleted fact " <> tshow fid)]))
910: else putText ("Deleted fact: " <> tshow fid)
911: | otherwise = putText "Unknown facts subcommand. Use: list, show, add, or delete"
912:
913: -- | Print a fact in a compact format
914: printFact :: TaskCore.Fact -> IO ()
915: printFact fact = do
916: let fid = maybe "?" tshow (TaskCore.factId fact)
917: proj = TaskCore.factProject fact
918: content = Text.take 60 (TaskCore.factContent fact)
919: suffix = if Text.length (TaskCore.factContent fact) > 60 then "..." else ""
920: putText (fid <> "\t" <> proj <> "\t" <> content <> suffix)
921:
922: -- | Print a fact in detailed format
923: printFactDetailed :: TaskCore.Fact -> IO ()
924: printFactDetailed fact = do
925: putText ("ID: " <> maybe "?" tshow (TaskCore.factId fact))
926: putText ("Project: " <> TaskCore.factProject fact)
927: putText ("Content: " <> TaskCore.factContent fact)
928: putText ("Files: " <> Text.intercalate ", " (TaskCore.factRelatedFiles fact))
929: putText ("Source: " <> fromMaybe "-" (TaskCore.factSourceTask fact))
930: putText ("Confidence: " <> tshow (TaskCore.factConfidence fact))
931: putText ("Created: " <> tshow (TaskCore.factCreatedAt fact))
932:
933: test :: Test.Tree
934: test =
935: Test.group
936: "Omni.Jr"
937: [ Test.unit "can run tests" <| True Test.@?= True,
938: Test.unit "can parse task command" <| do
939: let result = Docopt.parseArgs help ["task"]
940: case result of
941: Left err -> Test.assertFailure <| "Failed to parse 'task': " <> show err
942: Right args -> args `Cli.has` Cli.command "task" Test.@?= True,
943: Test.unit "can parse task command with args" <| do
944: let result = Docopt.parseArgs help ["task", "list", "--json"]
945: case result of
946: Left err -> Test.assertFailure <| "Failed to parse 'task list --json': " <> show err
947: Right args -> do
948: args `Cli.has` Cli.command "task" Test.@?= True
949: Cli.getAllArgs args (Cli.argument "args") Test.@?= ["list", "--json"],
950: Test.unit "can parse work command" <| do
951: let result = Docopt.parseArgs help ["work"]
952: case result of
953: Left err -> Test.assertFailure <| "Failed to parse 'work': " <> show err
954: Right args -> args `Cli.has` Cli.command "work" Test.@?= True,
955: Test.unit "can parse work command with task id" <| do
956: let result = Docopt.parseArgs help ["work", "t-123"]
957: case result of
958: Left err -> Test.assertFailure <| "Failed to parse 'work t-123': " <> show err
959: Right args -> do
960: args `Cli.has` Cli.command "work" Test.@?= True
961: Cli.getArg args (Cli.argument "task-id") Test.@?= Just "t-123",
962: Test.unit "can parse facts list command" <| do
963: let result = Docopt.parseArgs help ["facts", "list"]
964: case result of
965: Left err -> Test.assertFailure <| "Failed to parse 'facts list': " <> show err
966: Right args -> do
967: args `Cli.has` Cli.command "facts" Test.@?= True
968: args `Cli.has` Cli.command "list" Test.@?= True,
969: Test.unit "can parse facts list with --project" <| do
970: let result = Docopt.parseArgs help ["facts", "list", "--project=myproj"]
971: case result of
972: Left err -> Test.assertFailure <| "Failed to parse 'facts list --project': " <> show err
973: Right args -> do
974: args `Cli.has` Cli.command "facts" Test.@?= True
975: args `Cli.has` Cli.command "list" Test.@?= True
976: Cli.getArg args (Cli.longOption "project") Test.@?= Just "myproj",
977: Test.unit "can parse facts list with --json" <| do
978: let result = Docopt.parseArgs help ["facts", "list", "--json"]
979: case result of
980: Left err -> Test.assertFailure <| "Failed to parse 'facts list --json': " <> show err
981: Right args -> do
982: args `Cli.has` Cli.command "facts" Test.@?= True
983: args `Cli.has` Cli.command "list" Test.@?= True
984: args `Cli.has` Cli.longOption "json" Test.@?= True,
985: Test.unit "can parse facts show command" <| do
986: let result = Docopt.parseArgs help ["facts", "show", "42"]
987: case result of
988: Left err -> Test.assertFailure <| "Failed to parse 'facts show 42': " <> show err
989: Right args -> do
990: args `Cli.has` Cli.command "facts" Test.@?= True
991: args `Cli.has` Cli.command "show" Test.@?= True
992: Cli.getArg args (Cli.argument "fact-id") Test.@?= Just "42",
993: Test.unit "can parse facts add command" <| do
994: let result = Docopt.parseArgs help ["facts", "add", "myproj", "This is a fact"]
995: case result of
996: Left err -> Test.assertFailure <| "Failed to parse 'facts add': " <> show err
997: Right args -> do
998: args `Cli.has` Cli.command "facts" Test.@?= True
999: args `Cli.has` Cli.command "add" Test.@?= True
1000: Cli.getArg args (Cli.argument "project") Test.@?= Just "myproj"
1001: Cli.getArg args (Cli.argument "content") Test.@?= Just "This is a fact",
1002: Test.unit "can parse facts add with options" <| do
1003: let result = Docopt.parseArgs help ["facts", "add", "myproj", "fact", "--files=a.hs,b.hs", "--task=t-123", "--confidence=0.9"]
1004: case result of
1005: Left err -> Test.assertFailure <| "Failed to parse 'facts add' with options: " <> show err
1006: Right args -> do
1007: args `Cli.has` Cli.command "facts" Test.@?= True
1008: args `Cli.has` Cli.command "add" Test.@?= True
1009: Cli.getArg args (Cli.longOption "files") Test.@?= Just "a.hs,b.hs"
1010: Cli.getArg args (Cli.longOption "task") Test.@?= Just "t-123"
1011: Cli.getArg args (Cli.longOption "confidence") Test.@?= Just "0.9",
1012: Test.unit "can parse facts delete command" <| do
1013: let result = Docopt.parseArgs help ["facts", "delete", "42"]
1014: case result of
1015: Left err -> Test.assertFailure <| "Failed to parse 'facts delete 42': " <> show err
1016: Right args -> do
1017: args `Cli.has` Cli.command "facts" Test.@?= True
1018: args `Cli.has` Cli.command "delete" Test.@?= True
1019: Cli.getArg args (Cli.argument "fact-id") Test.@?= Just "42"
1020: ]
Now let me look at the Agent Log related files:
Omni/Agent/Log.hs1: {-# LANGUAGE OverloadedStrings #-}
2: {-# LANGUAGE RecordWildCards #-}
3: {-# LANGUAGE NoImplicitPrelude #-}
4:
5: -- | Status of the agent for the UI
6: module Omni.Agent.Log where
7:
8: import Alpha
9: import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)
10: import qualified Data.Text as Text
11: import qualified Data.Text.IO as TIO
12: import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
13: import Data.Time.Format (defaultTimeLocale, parseTimeOrError)
14: import qualified System.Console.ANSI as ANSI
15: import qualified System.IO as IO
16: import System.IO.Unsafe (unsafePerformIO)
17: import Text.Printf (printf)
18:
19: -- | Status of the agent for the UI
20: data Status = Status
21: { statusWorker :: Text,
22: statusTask :: Maybe Text,
23: statusThread :: Maybe Text,
24: statusFiles :: Int,
25: statusCredits :: Double,
26: statusStartTime :: UTCTime,
27: statusActivity :: Text
28: }
29: deriving (Show, Eq)
30:
31: emptyStatus :: Text -> UTCTime -> Status
32: emptyStatus workerName startTime =
33: Status
34: { statusWorker = workerName,
35: statusTask = Nothing,
36: statusThread = Nothing,
37: statusFiles = 0,
38: statusCredits = 0.0,
39: statusStartTime = startTime,
40: statusActivity = "Idle"
41: }
42:
43: -- | Global state for the status bar
44: {-# NOINLINE currentStatus #-}
45: currentStatus :: IORef Status
46: currentStatus = unsafePerformIO (newIORef (emptyStatus "Unknown" defaultStartTime))
47:
48: defaultStartTime :: UTCTime
49: defaultStartTime = parseTimeOrError True defaultTimeLocale "%Y-%m-%d %H:%M:%S %Z" "2000-01-01 00:00:00 UTC"
50:
51: -- | Initialize the status bar system
52: init :: Text -> IO ()
53: init workerName = do
54: IO.hSetBuffering IO.stderr IO.LineBuffering
55: startTime <- getCurrentTime
56: writeIORef currentStatus (emptyStatus workerName startTime)
57: -- Reserve 5 lines at bottom
58: IO.hPutStrLn IO.stderr ""
59: IO.hPutStrLn IO.stderr ""
60: IO.hPutStrLn IO.stderr ""
61: IO.hPutStrLn IO.stderr ""
62: IO.hPutStrLn IO.stderr ""
63: ANSI.hCursorUp IO.stderr 5
64:
65: -- | Update the status
66: update :: (Status -> Status) -> IO ()
67: update f = do
68: modifyIORef' currentStatus f
69: render
70:
71: -- | Get the current status
72: getStatus :: IO Status
73: getStatus = readIORef currentStatus
74:
75: -- | Set the activity message
76: updateActivity :: Text -> IO ()
77: updateActivity msg = update (\s -> s {statusActivity = msg})
78:
79: -- | Log a scrolling message (appears above status bars)
80: log :: Text -> IO ()
81: log msg = do
82: -- Clear status bars
83: ANSI.hClearLine IO.stderr
84: ANSI.hCursorDown IO.stderr 1
85: ANSI.hClearLine IO.stderr
86: ANSI.hCursorDown IO.stderr 1
87: ANSI.hClearLine IO.stderr
88: ANSI.hCursorDown IO.stderr 1
89: ANSI.hClearLine IO.stderr
90: ANSI.hCursorDown IO.stderr 1
91: ANSI.hClearLine IO.stderr
92: ANSI.hCursorUp IO.stderr 4
93:
94: -- Print message (scrolls screen)
95: TIO.hPutStrLn IO.stderr msg
96:
97: -- Re-render status bars at bottom
98: -- (Since we scrolled, we are now on the line above where the first status line should be)
99: render
100:
101: -- | Render the five status lines
102: render :: IO ()
103: render = do
104: Status {..} <- readIORef currentStatus
105: now <- getCurrentTime
106: let taskStr = maybe "None" identity statusTask
107: threadStr = maybe "None" identity statusThread
108: elapsed = diffUTCTime now statusStartTime
109: elapsedStr = formatElapsed elapsed
110:
111: -- Line 1: Worker | Thread
112: ANSI.hSetCursorColumn IO.stderr 0
113: ANSI.hClearLine IO.stderr
114: TIO.hPutStr IO.stderr ("[Worker: " <> statusWorker <> "] Thread: " <> threadStr)
115:
116: -- Line 2: Task
117: ANSI.hCursorDown IO.stderr 1
118: ANSI.hSetCursorColumn IO.stderr 0
119: ANSI.hClearLine IO.stderr
120: TIO.hPutStr IO.stderr ("Task: " <> taskStr)
121:
122: -- Line 3: Files | Credits
123: ANSI.hCursorDown IO.stderr 1
124: ANSI.hSetCursorColumn IO.stderr 0
125: ANSI.hClearLine IO.stderr
126: let creditsStr = Text.pack (printf "%.2f" statusCredits)
127: TIO.hPutStr IO.stderr ("Files: " <> tshow statusFiles <> " | Credits: $" <> creditsStr)
128:
129: -- Line 4: Time (elapsed duration)
130: ANSI.hCursorDown IO.stderr 1
131: ANSI.hSetCursorColumn IO.stderr 0
132: ANSI.hClearLine IO.stderr
133: TIO.hPutStr IO.stderr ("Time: " <> elapsedStr)
134:
135: -- Line 5: Activity
136: ANSI.hCursorDown IO.stderr 1
137: ANSI.hSetCursorColumn IO.stderr 0
138: ANSI.hClearLine IO.stderr
139: TIO.hPutStr IO.stderr ("> " <> statusActivity)
140:
141: -- Return cursor to line 1
142: ANSI.hCursorUp IO.stderr 4
143: IO.hFlush IO.stderr
144:
145: -- | Format elapsed time as MM:SS or HH:MM:SS
146: formatElapsed :: NominalDiffTime -> Text
147: formatElapsed elapsed =
148: let totalSecs = floor elapsed :: Int
149: hours = totalSecs `div` 3600
150: mins = (totalSecs `mod` 3600) `div` 60
151: secs = totalSecs `mod` 60
152: in if hours > 0
153: then Text.pack (printf "%02d:%02d:%02d" hours mins secs)
154: else Text.pack (printf "%02d:%02d" mins secs)
Omni/Jr/Web.hs1: {-# LANGUAGE DataKinds #-}
2: {-# LANGUAGE OverloadedStrings #-}
3: {-# LANGUAGE TypeOperators #-}
4: {-# LANGUAGE NoImplicitPrelude #-}
5:
6: -- : dep warp
7: -- : dep servant-server
8: -- : dep lucid
9: -- : dep servant-lucid
10: -- : dep http-api-data
11: -- : dep process
12: -- : dep clay
13: module Omni.Jr.Web
14: ( run,
15: defaultPort,
16: )
17: where
18:
19: import Alpha
20: import qualified Control.Concurrent as Concurrent
21: import qualified Data.Aeson as Aeson
22: import qualified Data.Aeson.KeyMap as KeyMap
23: import qualified Data.ByteString.Lazy as LBS
24: import qualified Data.List as List
25: import qualified Data.Text as Text
26: import qualified Data.Text.Lazy as LazyText
27: import qualified Data.Text.Lazy.Encoding as LazyText
28: import Data.Time (Day, NominalDiffTime, UTCTime (..), dayOfWeek, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime, toGregorian)
29: import Data.Time.Calendar (DayOfWeek (..))
30: import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
31: import qualified Lucid
32: import qualified Lucid.Base as Lucid
33: import qualified Network.Wai.Handler.Warp as Warp
34: import Numeric (showFFloat)
35: import qualified Omni.Fact as Fact
36: import qualified Omni.Jr.Web.Style as Style
37: import qualified Omni.Task.Core as TaskCore
38: import Servant
39: import qualified Servant.HTML.Lucid as Lucid
40: import qualified Servant.Types.SourceT as Source
41: import qualified System.Exit as Exit
42: import qualified System.Process as Process
43: import Web.FormUrlEncoded (FromForm (..), lookupUnique, parseUnique)
44:
45: type PostRedirect = Verb 'POST 303 '[Lucid.HTML] (Headers '[Header "Location" Text] NoContent)
46:
47: defaultPort :: Warp.Port
48: defaultPort = 8080
49:
50: formatRelativeTime :: UTCTime -> UTCTime -> Text
51: formatRelativeTime now timestamp =
52: let delta = diffUTCTime now timestamp
53: in relativeText delta
54:
55: relativeText :: NominalDiffTime -> Text
56: relativeText delta
57: | delta < 60 = "just now"
58: | delta < 3600 = tshow (round (delta / 60) :: Int) <> " minutes ago"
59: | delta < 7200 = "1 hour ago"
60: | delta < 86400 = tshow (round (delta / 3600) :: Int) <> " hours ago"
61: | delta < 172800 = "yesterday"
62: | delta < 604800 = tshow (round (delta / 86400) :: Int) <> " days ago"
63: | delta < 1209600 = "1 week ago"
64: | delta < 2592000 = tshow (round (delta / 604800) :: Int) <> " weeks ago"
65: | delta < 5184000 = "1 month ago"
66: | delta < 31536000 = tshow (round (delta / 2592000) :: Int) <> " months ago"
67: | otherwise = tshow (round (delta / 31536000) :: Int) <> " years ago"
68:
69: formatExactTimestamp :: UTCTime -> Text
70: formatExactTimestamp = Text.pack <. formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S UTC"
71:
72: renderRelativeTimestamp :: (Monad m) => UTCTime -> UTCTime -> Lucid.HtmlT m ()
73: renderRelativeTimestamp now timestamp =
74: Lucid.span_
75: [ Lucid.class_ "relative-time",
76: Lucid.title_ (formatExactTimestamp timestamp)
77: ]
78: (Lucid.toHtml (formatRelativeTime now timestamp))
79:
80: metaSep :: (Monad m) => Lucid.HtmlT m ()
81: metaSep = Lucid.span_ [Lucid.class_ "meta-sep"] "·"
82:
83: data TaskFilters = TaskFilters
84: { filterStatus :: Maybe TaskCore.Status,
85: filterPriority :: Maybe TaskCore.Priority,
86: filterNamespace :: Maybe Text,
87: filterType :: Maybe TaskCore.TaskType
88: }
89: deriving (Show, Eq)
90:
91: data TimeRange = Today | Week | Month | AllTime
92: deriving (Show, Eq)
93:
94: data SortOrder
95: = SortNewest
96: | SortOldest
97: | SortUpdated
98: | SortPriorityHigh
99: | SortPriorityLow
100: deriving (Show, Eq)
101:
102: parseSortOrder :: Maybe Text -> SortOrder
103: parseSortOrder (Just "oldest") = SortOldest
104: parseSortOrder (Just "updated") = SortUpdated
105: parseSortOrder (Just "priority-high") = SortPriorityHigh
106: parseSortOrder (Just "priority-low") = SortPriorityLow
107: parseSortOrder _ = SortNewest
108:
109: sortOrderToParam :: SortOrder -> Text
110: sortOrderToParam SortNewest = "newest"
111: sortOrderToParam SortOldest = "oldest"
112: sortOrderToParam SortUpdated = "updated"
113: sortOrderToParam SortPriorityHigh = "priority-high"
114: sortOrderToParam SortPriorityLow = "priority-low"
115:
116: sortOrderLabel :: SortOrder -> Text
117: sortOrderLabel SortNewest = "Newest First"
118: sortOrderLabel SortOldest = "Oldest First"
119: sortOrderLabel SortUpdated = "Recently Updated"
120: sortOrderLabel SortPriorityHigh = "Priority (High to Low)"
121: sortOrderLabel SortPriorityLow = "Priority (Low to High)"
122:
123: sortTasks :: SortOrder -> [TaskCore.Task] -> [TaskCore.Task]
124: sortTasks SortNewest = List.sortBy (comparing (Down <. TaskCore.taskCreatedAt))
125: sortTasks SortOldest = List.sortBy (comparing TaskCore.taskCreatedAt)
126: sortTasks SortUpdated = List.sortBy (comparing (Down <. TaskCore.taskUpdatedAt))
127: sortTasks SortPriorityHigh = List.sortBy (comparing TaskCore.taskPriority)
128: sortTasks SortPriorityLow = List.sortBy (comparing (Down <. TaskCore.taskPriority))
129:
130: parseTimeRange :: Maybe Text -> TimeRange
131: parseTimeRange (Just "today") = Today
132: parseTimeRange (Just "week") = Week
133: parseTimeRange (Just "month") = Month
134: parseTimeRange _ = AllTime
135:
136: timeRangeToParam :: TimeRange -> Text
137: timeRangeToParam Today = "today"
138: timeRangeToParam Week = "week"
139: timeRangeToParam Month = "month"
140: timeRangeToParam AllTime = "all"
141:
142: getTimeRangeStart :: TimeRange -> UTCTime -> Maybe UTCTime
143: getTimeRangeStart AllTime _ = Nothing
144: getTimeRangeStart Today now = Just (startOfDay now)
145: getTimeRangeStart Week now = Just (startOfWeek now)
146: getTimeRangeStart Month now = Just (startOfMonth now)
147:
148: startOfDay :: UTCTime -> UTCTime
149: startOfDay t = UTCTime (utctDay t) 0
150:
151: startOfWeek :: UTCTime -> UTCTime
152: startOfWeek t =
153: let day = utctDay t
154: dow = dayOfWeek day
155: daysBack = case dow of
156: Monday -> 0
157: Tuesday -> 1
158: Wednesday -> 2
159: Thursday -> 3
160: Friday -> 4
161: Saturday -> 5
162: Sunday -> 6
163: in UTCTime (addDays (negate daysBack) day) 0
164:
165: addDays :: Integer -> Day -> Day
166: addDays n d =
167: let (y, m, dayNum) = toGregorian d
168: in fromGregorian y m (dayNum + fromInteger n)
169:
170: fromGregorian :: Integer -> Int -> Int -> Day
171: fromGregorian y m d = toEnum (fromInteger (daysSinceEpoch y m d))
172:
173: daysSinceEpoch :: Integer -> Int -> Int -> Integer
174: daysSinceEpoch y m d =
175: let a = (14 - m) `div` 12
176: y' = y + 4800 - toInteger a
177: m' = m + 12 * a - 3
178: jdn = d + (153 * m' + 2) `div` 5 + 365 * fromInteger y' + fromInteger y' `div` 4 - fromInteger y' `div` 100 + fromInteger y' `div` 400 - 32045
179: in toInteger jdn - 2440588
180:
181: startOfMonth :: UTCTime -> UTCTime
182: startOfMonth t =
183: let day = utctDay t
184: (y, m, _) = toGregorian day
185: in UTCTime (fromGregorian y m 1) 0
186:
187: computeMetricsFromActivities :: [TaskCore.Task] -> [TaskCore.TaskActivity] -> TaskCore.AggregatedMetrics
188: computeMetricsFromActivities tasks activities =
189: let completedCount = length [t | t <- tasks, TaskCore.taskStatus t == TaskCore.Done]
190: totalCost = sum [c | act <- activities, Just c <- [TaskCore.activityCostCents act]]
191: totalTokens = sum [t | act <- activities, Just t <- [TaskCore.activityTokensUsed act]]
192: totalDuration = sum [calcDuration act | act <- activities]
193: in TaskCore.AggregatedMetrics
194: { TaskCore.aggTotalCostCents = totalCost,
195: TaskCore.aggTotalDurationSeconds = totalDuration,
196: TaskCore.aggCompletedTasks = completedCount,
197: TaskCore.aggTotalTokens = totalTokens
198: }
199: where
200: calcDuration act = case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of
201: (Just start, Just end) -> floor (diffUTCTime end start)
202: _ -> 0
203:
204: type API =
205: QueryParam "range" Text :> Get '[Lucid.HTML] HomePage
206: :<|> "style.css" :> Get '[CSS] LazyText.Text
207: :<|> "ready" :> QueryParam "sort" Text :> Get '[Lucid.HTML] ReadyQueuePage
208: :<|> "blocked" :> QueryParam "sort" Text :> Get '[Lucid.HTML] BlockedPage
209: :<|> "intervention" :> QueryParam "sort" Text :> Get '[Lucid.HTML] InterventionPage
210: :<|> "stats" :> QueryParam "epic" Text :> Get '[Lucid.HTML] StatsPage
211: :<|> "tasks"
212: :> QueryParam "status" Text
213: :> QueryParam "priority" Text
214: :> QueryParam "namespace" Text
215: :> QueryParam "type" Text
216: :> QueryParam "sort" Text
217: :> Get '[Lucid.HTML] TaskListPage
218: :<|> "kb" :> Get '[Lucid.HTML] KBPage
219: :<|> "kb" :> "create" :> ReqBody '[FormUrlEncoded] FactCreateForm :> PostRedirect
220: :<|> "kb" :> Capture "id" Int :> Get '[Lucid.HTML] FactDetailPage
221: :<|> "kb" :> Capture "id" Int :> "edit" :> ReqBody '[FormUrlEncoded] FactEditForm :> PostRedirect
222: :<|> "kb" :> Capture "id" Int :> "delete" :> PostRedirect
223: :<|> "epics" :> QueryParam "sort" Text :> Get '[Lucid.HTML] EpicsPage
224: :<|> "tasks" :> Capture "id" Text :> Get '[Lucid.HTML] TaskDetailPage
225: :<|> "tasks" :> Capture "id" Text :> "status" :> ReqBody '[FormUrlEncoded] StatusForm :> Post '[Lucid.HTML] StatusBadgePartial
226: :<|> "tasks" :> Capture "id" Text :> "priority" :> ReqBody '[FormUrlEncoded] PriorityForm :> Post '[Lucid.HTML] PriorityBadgePartial
227: :<|> "tasks" :> Capture "id" Text :> "description" :> "view" :> Get '[Lucid.HTML] DescriptionViewPartial
228: :<|> "tasks" :> Capture "id" Text :> "description" :> "edit" :> Get '[Lucid.HTML] DescriptionEditPartial
229: :<|> "tasks" :> Capture "id" Text :> "description" :> ReqBody '[FormUrlEncoded] DescriptionForm :> Post '[Lucid.HTML] DescriptionViewPartial
230: :<|> "tasks" :> Capture "id" Text :> "notes" :> ReqBody '[FormUrlEncoded] NotesForm :> PostRedirect
231: :<|> "tasks" :> Capture "id" Text :> "comment" :> ReqBody '[FormUrlEncoded] CommentForm :> PostRedirect
232: :<|> "tasks" :> Capture "id" Text :> "review" :> Get '[Lucid.HTML] TaskReviewPage
233: :<|> "tasks" :> Capture "id" Text :> "diff" :> Capture "commit" Text :> Get '[Lucid.HTML] TaskDiffPage
234: :<|> "tasks" :> Capture "id" Text :> "accept" :> PostRedirect
235: :<|> "tasks" :> Capture "id" Text :> "reject" :> ReqBody '[FormUrlEncoded] RejectForm :> PostRedirect
236: :<|> "tasks" :> Capture "id" Text :> "reset-retries" :> PostRedirect
237: :<|> "partials" :> "recent-activity-new" :> QueryParam "since" Int :> Get '[Lucid.HTML] RecentActivityNewPartial
238: :<|> "partials" :> "recent-activity-more" :> QueryParam "offset" Int :> Get '[Lucid.HTML] RecentActivityMorePartial
239: :<|> "partials" :> "ready-count" :> Get '[Lucid.HTML] ReadyCountPartial
240: :<|> "partials"
241: :> "task-list"
242: :> QueryParam "status" Text
243: :> QueryParam "priority" Text
244: :> QueryParam "namespace" Text
245: :> QueryParam "type" Text
246: :> QueryParam "sort" Text
247: :> Get '[Lucid.HTML] TaskListPartial
248: :<|> "partials" :> "task" :> Capture "id" Text :> "metrics" :> Get '[Lucid.HTML] TaskMetricsPartial
249: :<|> "partials" :> "task" :> Capture "id" Text :> "events" :> QueryParam "since" Int :> Get '[Lucid.HTML] AgentEventsPartial
250: :<|> "tasks" :> Capture "id" Text :> "events" :> "stream" :> StreamGet NoFraming SSE (SourceIO ByteString)
251:
252: data CSS
253:
254: instance Accept CSS where
255: contentType _ = "text/css"
256:
257: instance MimeRender CSS LazyText.Text where
258: mimeRender _ = LazyText.encodeUtf8
259:
260: data SSE
261:
262: instance Accept SSE where
263: contentType _ = "text/event-stream"
264:
265: instance MimeRender SSE ByteString where
266: mimeRender _ = LBS.fromStrict
267:
268: data HomePage = HomePage TaskCore.TaskStats [TaskCore.Task] [TaskCore.Task] Bool TaskCore.AggregatedMetrics TimeRange UTCTime
269:
270: data ReadyQueuePage = ReadyQueuePage [TaskCore.Task] SortOrder UTCTime
271:
272: data BlockedPage = BlockedPage [(TaskCore.Task, Int)] SortOrder UTCTime
273:
274: data InterventionPage = InterventionPage TaskCore.HumanActionItems SortOrder UTCTime
275:
276: data TaskListPage = TaskListPage [TaskCore.Task] TaskFilters SortOrder UTCTime
277:
278: data TaskDetailPage
279: = TaskDetailFound TaskCore.Task [TaskCore.Task] [TaskCore.TaskActivity] (Maybe TaskCore.RetryContext) [GitCommit] (Maybe TaskCore.AggregatedMetrics) [TaskCore.StoredEvent] UTCTime
280: | TaskDetailNotFound Text
281:
282: data GitCommit = GitCommit
283: { commitHash :: Text,
284: commitShortHash :: Text,
285: commitSummary :: Text,
286: commitAuthor :: Text,
287: commitRelativeDate :: Text,
288: commitFilesChanged :: Int
289: }
290: deriving (Show, Eq)
291:
292: data TaskReviewPage
293: = ReviewPageFound TaskCore.Task ReviewInfo
294: | ReviewPageNotFound Text
295:
296: data ReviewInfo
297: = ReviewNoCommit
298: | ReviewMergeConflict Text [Text]
299: | ReviewReady Text Text
300:
301: data TaskDiffPage
302: = DiffPageFound Text Text Text
303: | DiffPageNotFound Text Text
304:
305: data StatsPage = StatsPage TaskCore.TaskStats (Maybe Text)
306:
307: newtype KBPage = KBPage [TaskCore.Fact]
308:
309: data FactDetailPage
310: = FactDetailFound TaskCore.Fact UTCTime
311: | FactDetailNotFound Int
312:
313: data FactEditForm = FactEditForm Text Text Text
314:
315: instance FromForm FactEditForm where
316: fromForm form = do
317: content <- parseUnique "content" form
318: let files = fromRight "" (lookupUnique "files" form)
319: let confidence = fromRight "0.8" (lookupUnique "confidence" form)
320: Right (FactEditForm content files confidence)
321:
322: data FactCreateForm = FactCreateForm Text Text Text Text
323:
324: instance FromForm FactCreateForm where
325: fromForm form = do
326: project <- parseUnique "project" form
327: content <- parseUnique "content" form
328: let files = fromRight "" (lookupUnique "files" form)
329: let confidence = fromRight "0.8" (lookupUnique "confidence" form)
330: Right (FactCreateForm project content files confidence)
331:
332: data EpicsPage = EpicsPage [TaskCore.Task] [TaskCore.Task] SortOrder
333:
334: data RecentActivityNewPartial = RecentActivityNewPartial [TaskCore.Task] (Maybe Int)
335:
336: data RecentActivityMorePartial = RecentActivityMorePartial [TaskCore.Task] Int Bool
337:
338: newtype ReadyCountPartial = ReadyCountPartial Int
339:
340: data StatusBadgePartial = StatusBadgePartial TaskCore.Status Text
341:
342: data PriorityBadgePartial = PriorityBadgePartial TaskCore.Priority Text
343:
344: newtype TaskListPartial = TaskListPartial [TaskCore.Task]
345:
346: data TaskMetricsPartial = TaskMetricsPartial Text [TaskCore.TaskActivity] (Maybe TaskCore.RetryContext) UTCTime
347:
348: data AgentEventsPartial = AgentEventsPartial [TaskCore.StoredEvent] Bool UTCTime
349:
350: data DescriptionViewPartial = DescriptionViewPartial Text Text Bool
351:
352: data DescriptionEditPartial = DescriptionEditPartial Text Text Bool
353:
354: newtype RejectForm = RejectForm (Maybe Text)
355:
356: instance FromForm RejectForm where
357: fromForm form = Right (RejectForm (either (const Nothing) Just (lookupUnique "notes" form)))
358:
359: newtype StatusForm = StatusForm TaskCore.Status
360:
361: instance FromForm StatusForm where
362: fromForm form = do
363: statusText <- parseUnique "status" form
364: case readMaybe (Text.unpack statusText) of
365: Just s -> Right (StatusForm s)
366: Nothing -> Left "Invalid status"
367:
368: newtype PriorityForm = PriorityForm TaskCore.Priority
369:
370: instance FromForm PriorityForm where
371: fromForm form = do
372: priorityText <- parseUnique "priority" form
373: case readMaybe (Text.unpack priorityText) of
374: Just p -> Right (PriorityForm p)
375: Nothing -> Left "Invalid priority"
376:
377: newtype DescriptionForm = DescriptionForm Text
378:
379: instance FromForm DescriptionForm where
380: fromForm form = do
381: desc <- parseUnique "description" form
382: Right (DescriptionForm desc)
383:
384: newtype NotesForm = NotesForm Text
385:
386: instance FromForm NotesForm where
387: fromForm form = do
388: notes <- parseUnique "notes" form
389: Right (NotesForm notes)
390:
391: newtype CommentForm = CommentForm Text
392:
393: instance FromForm CommentForm where
394: fromForm form = do
395: commentText <- parseUnique "comment" form
396: Right (CommentForm commentText)
397:
398: pageHead :: (Monad m) => Text -> Lucid.HtmlT m ()
399: pageHead title =
400: Lucid.head_ <| do
401: Lucid.title_ (Lucid.toHtml title)
402: Lucid.meta_ [Lucid.charset_ "utf-8"]
403: Lucid.meta_
404: [ Lucid.name_ "viewport",
405: Lucid.content_ "width=device-width, initial-scale=1"
406: ]
407: Lucid.link_ [Lucid.rel_ "stylesheet", Lucid.href_ "/style.css"]
408: Lucid.script_
409: [ Lucid.src_ "https://unpkg.com/htmx.org@2.0.4",
410: Lucid.integrity_ "sha384-HGfztofotfshcF7+8n44JQL2oJmowVChPTg48S+jvZoztPfvwD79OC/LTtG6dMp+",
411: Lucid.crossorigin_ "anonymous"
412: ]
413: ("" :: Text)
414: Lucid.script_ [] statusDropdownJs
415: Lucid.script_ [] priorityDropdownJs
416: Lucid.script_ [] navbarDropdownJs
417:
418: navbarDropdownJs :: Text
419: navbarDropdownJs =
420: Text.unlines
421: [ "document.addEventListener('DOMContentLoaded', function() {",
422: " document.querySelectorAll('.navbar-dropdown-btn').forEach(function(btn) {",
423: " btn.addEventListener('click', function(e) {",
424: " e.preventDefault();",
425: " var dropdown = btn.closest('.navbar-dropdown');",
426: " var isOpen = dropdown.classList.contains('open');",
427: " document.querySelectorAll('.navbar-dropdown.open').forEach(function(d) {",
428: " d.classList.remove('open');",
429: " });",
430: " if (!isOpen) {",
431: " dropdown.classList.add('open');",
432: " }",
433: " });",
434: " });",
435: " document.addEventListener('click', function(e) {",
436: " if (!e.target.closest('.navbar-dropdown')) {",
437: " document.querySelectorAll('.navbar-dropdown.open').forEach(function(d) {",
438: " d.classList.remove('open');",
439: " });",
440: " }",
441: " });",
442: "});"
443: ]
444:
445: statusDropdownJs :: Text
446: statusDropdownJs =
447: Text.unlines
448: [ "function toggleStatusDropdown(el) {",
449: " var container = el.parentElement;",
450: " var isOpen = container.classList.toggle('open');",
451: " el.setAttribute('aria-expanded', isOpen);",
452: " if (isOpen) {",
453: " var firstItem = container.querySelector('[role=\"menuitem\"]');",
454: " if (firstItem) firstItem.focus();",
455: " }",
456: "}",
457: "",
458: "function closeStatusDropdown(container) {",
459: " container.classList.remove('open');",
460: " var badge = container.querySelector('[role=\"button\"]');",
461: " if (badge) {",
462: " badge.setAttribute('aria-expanded', 'false');",
463: " badge.focus();",
464: " }",
465: "}",
466: "",
467: "function handleStatusKeydown(event, el) {",
468: " if (event.key === 'Enter' || event.key === ' ') {",
469: " event.preventDefault();",
470: " toggleStatusDropdown(el);",
471: " } else if (event.key === 'Escape') {",
472: " closeStatusDropdown(el.parentElement);",
473: " } else if (event.key === 'ArrowDown') {",
474: " event.preventDefault();",
475: " var container = el.parentElement;",
476: " if (!container.classList.contains('open')) {",
477: " toggleStatusDropdown(el);",
478: " } else {",
479: " var firstItem = container.querySelector('[role=\"menuitem\"]');",
480: " if (firstItem) firstItem.focus();",
481: " }",
482: " }",
483: "}",
484: "",
485: "function handleMenuItemKeydown(event) {",
486: " var container = event.target.closest('.status-badge-dropdown');",
487: " var items = container.querySelectorAll('[role=\"menuitem\"]');",
488: " var currentIndex = Array.from(items).indexOf(event.target);",
489: " ",
490: " if (event.key === 'ArrowDown') {",
491: " event.preventDefault();",
492: " var next = (currentIndex + 1) % items.length;",
493: " items[next].focus();",
494: " } else if (event.key === 'ArrowUp') {",
495: " event.preventDefault();",
496: " var prev = (currentIndex - 1 + items.length) % items.length;",
497: " items[prev].focus();",
498: " } else if (event.key === 'Escape') {",
499: " event.preventDefault();",
500: " closeStatusDropdown(container);",
501: " } else if (event.key === 'Tab') {",
502: " closeStatusDropdown(container);",
503: " }",
504: "}",
505: "",
506: "document.addEventListener('click', function(e) {",
507: " var dropdowns = document.querySelectorAll('.status-badge-dropdown.open');",
508: " dropdowns.forEach(function(d) {",
509: " if (!d.contains(e.target)) {",
510: " closeStatusDropdown(d);",
511: " }",
512: " });",
513: "});"
514: ]
515:
516: priorityDropdownJs :: Text
517: priorityDropdownJs =
518: Text.unlines
519: [ "function togglePriorityDropdown(el) {",
520: " var container = el.parentElement;",
521: " var isOpen = container.classList.toggle('open');",
522: " el.setAttribute('aria-expanded', isOpen);",
523: " if (isOpen) {",
524: " var firstItem = container.querySelector('[role=\"menuitem\"]');",
525: " if (firstItem) firstItem.focus();",
526: " }",
527: "}",
528: "",
529: "function closePriorityDropdown(container) {",
530: " container.classList.remove('open');",
531: " var badge = container.querySelector('[role=\"button\"]');",
532: " if (badge) {",
533: " badge.setAttribute('aria-expanded', 'false');",
534: " badge.focus();",
535: " }",
536: "}",
537: "",
538: "function handlePriorityKeydown(event, el) {",
539: " if (event.key === 'Enter' || event.key === ' ') {",
540: " event.preventDefault();",
541: " togglePriorityDropdown(el);",
542: " } else if (event.key === 'Escape') {",
543: " closePriorityDropdown(el.parentElement);",
544: " } else if (event.key === 'ArrowDown') {",
545: " event.preventDefault();",
546: " var container = el.parentElement;",
547: " if (!container.classList.contains('open')) {",
548: " togglePriorityDropdown(el);",
549: " } else {",
550: " var firstItem = container.querySelector('[role=\"menuitem\"]');",
551: " if (firstItem) firstItem.focus();",
552: " }",
553: " }",
554: "}",
555: "",
556: "function handlePriorityMenuItemKeydown(event) {",
557: " var container = event.target.closest('.priority-badge-dropdown');",
558: " var items = container.querySelectorAll('[role=\"menuitem\"]');",
559: " var currentIndex = Array.from(items).indexOf(event.target);",
560: " ",
561: " if (event.key === 'ArrowDown') {",
562: " event.preventDefault();",
563: " var next = (currentIndex + 1) % items.length;",
564: " items[next].focus();",
565: " } else if (event.key === 'ArrowUp') {",
566: " event.preventDefault();",
567: " var prev = (currentIndex - 1 + items.length) % items.length;",
568: " items[prev].focus();",
569: " } else if (event.key === 'Escape') {",
570: " event.preventDefault();",
571: " closePriorityDropdown(container);",
572: " } else if (event.key === 'Tab') {",
573: " closePriorityDropdown(container);",
574: " }",
575: "}",
576: "",
577: "document.addEventListener('click', function(e) {",
578: " var dropdowns = document.querySelectorAll('.priority-badge-dropdown.open');",
579: " dropdowns.forEach(function(d) {",
580: " if (!d.contains(e.target)) {",
581: " closePriorityDropdown(d);",
582: " }",
583: " });",
584: "});"
585: ]
586:
587: pageBody :: (Monad m) => Lucid.HtmlT m () -> Lucid.HtmlT m ()
588: pageBody content =
589: Lucid.body_ [Lucid.makeAttribute "hx-boost" "true"] <| do
590: navbar
591: content
592:
593: data Breadcrumb = Breadcrumb
594: { _crumbLabel :: Text,
595: _crumbHref :: Maybe Text
596: }
597:
598: type Breadcrumbs = [Breadcrumb]
599:
600: pageBodyWithCrumbs :: (Monad m) => Breadcrumbs -> Lucid.HtmlT m () -> Lucid.HtmlT m ()
601: pageBodyWithCrumbs crumbs content =
602: Lucid.body_ [Lucid.makeAttribute "hx-boost" "true"] <| do
603: navbar
604: unless (null crumbs) <| do
605: Lucid.div_ [Lucid.class_ "breadcrumb-container"] <| do
606: Lucid.div_ [Lucid.class_ "container"] <| renderBreadcrumbs crumbs
607: content
608:
609: renderBreadcrumbs :: (Monad m) => Breadcrumbs -> Lucid.HtmlT m ()
610: renderBreadcrumbs [] = pure ()
611: renderBreadcrumbs crumbs =
612: Lucid.nav_ [Lucid.class_ "breadcrumbs", Lucid.makeAttribute "aria-label" "Breadcrumb"] <| do
613: Lucid.ol_ [Lucid.class_ "breadcrumb-list"] <| do
614: traverse_ renderCrumb (zip [0 ..] crumbs)
615: where
616: renderCrumb :: (Monad m') => (Int, Breadcrumb) -> Lucid.HtmlT m' ()
617: renderCrumb (idx, Breadcrumb label mHref) = do
618: Lucid.li_ [Lucid.class_ "breadcrumb-item"] <| do
619: when (idx > 0) <| Lucid.span_ [Lucid.class_ "breadcrumb-sep"] ">"
620: case mHref of
621: Just href -> Lucid.a_ [Lucid.href_ href] (Lucid.toHtml label)
622: Nothing -> Lucid.span_ [Lucid.class_ "breadcrumb-current"] (Lucid.toHtml label)
623:
624: getAncestors :: [TaskCore.Task] -> TaskCore.Task -> [TaskCore.Task]
625: getAncestors allTasks task =
626: case TaskCore.taskParent task of
627: Nothing -> [task]
628: Just pid -> case TaskCore.findTask pid allTasks of
629: Nothing -> [task]
630: Just parent -> getAncestors allTasks parent ++ [task]
631:
632: taskBreadcrumbs :: [TaskCore.Task] -> TaskCore.Task -> Breadcrumbs
633: taskBreadcrumbs allTasks task =
634: let ancestors = getAncestors allTasks task
635: taskCrumbs = [Breadcrumb (TaskCore.taskId t) (Just ("/tasks/" <> TaskCore.taskId t)) | t <- List.init ancestors]
636: currentCrumb = Breadcrumb (TaskCore.taskId task) Nothing
637: in [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks")]
638: ++ taskCrumbs
639: ++ [currentCrumb]
640:
641: navbar :: (Monad m) => Lucid.HtmlT m ()
642: navbar =
643: Lucid.nav_ [Lucid.class_ "navbar"] <| do
644: Lucid.a_ [Lucid.href_ "/", Lucid.class_ "navbar-brand"] "Junior"
645: Lucid.input_
646: [ Lucid.type_ "checkbox",
647: Lucid.id_ "navbar-toggle",
648: Lucid.class_ "navbar-toggle-checkbox"
649: ]
650: Lucid.label_
651: [ Lucid.for_ "navbar-toggle",
652: Lucid.class_ "navbar-hamburger"
653: ]
654: <| do
655: Lucid.span_ [Lucid.class_ "hamburger-line"] ""
656: Lucid.span_ [Lucid.class_ "hamburger-line"] ""
657: Lucid.span_ [Lucid.class_ "hamburger-line"] ""
658: Lucid.div_ [Lucid.class_ "navbar-links"] <| do
659: Lucid.a_ [Lucid.href_ "/", Lucid.class_ "navbar-link"] "Dashboard"
660: Lucid.div_ [Lucid.class_ "navbar-dropdown"] <| do
661: Lucid.button_ [Lucid.class_ "navbar-dropdown-btn"] "Tasks ▾"
662: Lucid.div_ [Lucid.class_ "navbar-dropdown-content"] <| do
663: Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "navbar-dropdown-item"] "Ready"
664: Lucid.a_ [Lucid.href_ "/blocked", Lucid.class_ "navbar-dropdown-item"] "Blocked"
665: Lucid.a_ [Lucid.href_ "/intervention", Lucid.class_ "navbar-dropdown-item"] "Human Action"
666: Lucid.a_ [Lucid.href_ "/tasks", Lucid.class_ "navbar-dropdown-item"] "All"
667: Lucid.div_ [Lucid.class_ "navbar-dropdown"] <| do
668: Lucid.button_ [Lucid.class_ "navbar-dropdown-btn"] "Plans ▾"
669: Lucid.div_ [Lucid.class_ "navbar-dropdown-content"] <| do
670: Lucid.a_ [Lucid.href_ "/epics", Lucid.class_ "navbar-dropdown-item"] "Epics"
671: Lucid.a_ [Lucid.href_ "/kb", Lucid.class_ "navbar-dropdown-item"] "KB"
672: Lucid.a_ [Lucid.href_ "/stats", Lucid.class_ "navbar-link"] "Stats"
673:
674: statusBadge :: (Monad m) => TaskCore.Status -> Lucid.HtmlT m ()
675: statusBadge status =
676: let (cls, label) = case status of
677: TaskCore.Draft -> ("badge badge-draft", "Draft")
678: TaskCore.Open -> ("badge badge-open", "Open")
679: TaskCore.InProgress -> ("badge badge-inprogress", "In Progress")
680: TaskCore.Review -> ("badge badge-review", "Review")
681: TaskCore.Approved -> ("badge badge-approved", "Approved")
682: TaskCore.Done -> ("badge badge-done", "Done")
683: TaskCore.NeedsHelp -> ("badge badge-needshelp", "Needs Help")
684: in Lucid.span_ [Lucid.class_ cls] label
685:
686: complexityBadge :: (Monad m) => Int -> Lucid.HtmlT m ()
687: complexityBadge complexity =
688: let cls = "badge badge-complexity badge-complexity-" <> tshow complexity
689: label = "ℂ " <> tshow complexity
690: in Lucid.span_ [Lucid.class_ cls, Lucid.title_ "Task Complexity (1-5)"] (Lucid.toHtml label)
691:
692: sortDropdown :: (Monad m) => Text -> SortOrder -> Lucid.HtmlT m ()
693: sortDropdown basePath currentSort =
694: Lucid.div_ [Lucid.class_ "sort-dropdown"] <| do
695: Lucid.span_ [Lucid.class_ "sort-label"] "Sort:"
696: Lucid.div_ [Lucid.class_ "sort-dropdown-wrapper navbar-dropdown"] <| do
697: Lucid.button_ [Lucid.class_ "sort-dropdown-btn navbar-dropdown-btn"]
698: <| Lucid.toHtml (sortOrderLabel currentSort <> " ▾")
699: Lucid.div_ [Lucid.class_ "sort-dropdown-content navbar-dropdown-content"] <| do
700: sortOption basePath SortNewest currentSort
701: sortOption basePath SortOldest currentSort
702: sortOption basePath SortUpdated currentSort
703: sortOption basePath SortPriorityHigh currentSort
704: sortOption basePath SortPriorityLow currentSort
705:
706: sortOption :: (Monad m) => Text -> SortOrder -> SortOrder -> Lucid.HtmlT m ()
707: sortOption basePath option currentSort =
708: let cls = "sort-dropdown-item navbar-dropdown-item" <> if option == currentSort then " active" else ""
709: href = basePath <> "?sort=" <> sortOrderToParam option
710: in Lucid.a_ [Lucid.href_ href, Lucid.class_ cls] (Lucid.toHtml (sortOrderLabel option))
711:
712: multiColorProgressBar :: (Monad m) => TaskCore.TaskStats -> Lucid.HtmlT m ()
713: multiColorProgressBar stats =
714: let total = TaskCore.totalTasks stats
715: doneCount = TaskCore.doneTasks stats
716: inProgressCount = TaskCore.inProgressTasks stats
717: openCount = TaskCore.openTasks stats + TaskCore.reviewTasks stats + TaskCore.approvedTasks stats
718: donePct = if total == 0 then 0 else (doneCount * 100) `div` total
719: inProgressPct = if total == 0 then 0 else (inProgressCount * 100) `div` total
720: openPct = if total == 0 then 0 else (openCount * 100) `div` total
721: in Lucid.div_ [Lucid.class_ "multi-progress-container"] <| do
722: Lucid.div_ [Lucid.class_ "multi-progress-bar"] <| do
723: when (donePct > 0)
724: <| Lucid.div_
725: [ Lucid.class_ "multi-progress-segment progress-done",
726: Lucid.style_ ("width: " <> tshow donePct <> "%"),
727: Lucid.title_ (tshow doneCount <> " done")
728: ]
729: ""
730: when (inProgressPct > 0)
731: <| Lucid.div_
732: [ Lucid.class_ "multi-progress-segment progress-inprogress",
733: Lucid.style_ ("width: " <> tshow inProgressPct <> "%"),
734: Lucid.title_ (tshow inProgressCount <> " in progress")
735: ]
736: ""
737: when (openPct > 0)
738: <| Lucid.div_
739: [ Lucid.class_ "multi-progress-segment progress-open",
740: Lucid.style_ ("width: " <> tshow openPct <> "%"),
741: Lucid.title_ (tshow openCount <> " open")
742: ]
743: ""
744: Lucid.div_ [Lucid.class_ "progress-legend"] <| do
745: Lucid.span_ [Lucid.class_ "legend-item"] <| do
746: Lucid.span_ [Lucid.class_ "legend-dot legend-done"] ""
747: Lucid.toHtml ("Done " <> tshow doneCount)
748: Lucid.span_ [Lucid.class_ "legend-item"] <| do
749: Lucid.span_ [Lucid.class_ "legend-dot legend-inprogress"] ""
750: Lucid.toHtml ("In Progress " <> tshow inProgressCount)
751: Lucid.span_ [Lucid.class_ "legend-item"] <| do
752: Lucid.span_ [Lucid.class_ "legend-dot legend-open"] ""
753: Lucid.toHtml ("Open " <> tshow openCount)
754:
755: statusBadgeWithForm :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m ()
756: statusBadgeWithForm status tid =
757: Lucid.div_
758: [ Lucid.id_ "status-badge-container",
759: Lucid.class_ "status-badge-dropdown"
760: ]
761: <| do
762: clickableBadge status tid
763: statusDropdownOptions status tid
764:
765: clickableBadge :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m ()
766: clickableBadge status _tid =
767: let (cls, label) = case status of
768: TaskCore.Draft -> ("badge badge-draft status-badge-clickable", "Draft" :: Text)
769: TaskCore.Open -> ("badge badge-open status-badge-clickable", "Open")
770: TaskCore.InProgress -> ("badge badge-inprogress status-badge-clickable", "In Progress")
771: TaskCore.Review -> ("badge badge-review status-badge-clickable", "Review")
772: TaskCore.Approved -> ("badge badge-approved status-badge-clickable", "Approved")
773: TaskCore.Done -> ("badge badge-done status-badge-clickable", "Done")
774: TaskCore.NeedsHelp -> ("badge badge-needshelp status-badge-clickable", "Needs Help")
775: in Lucid.span_
776: [ Lucid.class_ cls,
777: Lucid.tabindex_ "0",
778: Lucid.role_ "button",
779: Lucid.makeAttribute "aria-haspopup" "true",
780: Lucid.makeAttribute "aria-expanded" "false",
781: Lucid.makeAttribute "onclick" "toggleStatusDropdown(this)",
782: Lucid.makeAttribute "onkeydown" "handleStatusKeydown(event, this)"
783: ]
784: <| do
785: Lucid.toHtml label
786: Lucid.span_ [Lucid.class_ "dropdown-arrow", Lucid.makeAttribute "aria-hidden" "true"] " ▾"
787:
788: statusDropdownOptions :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m ()
789: statusDropdownOptions currentStatus tid =
790: Lucid.div_
791: [ Lucid.class_ "status-dropdown-menu",
792: Lucid.role_ "menu",
793: Lucid.makeAttribute "aria-label" "Change task status"
794: ]
795: <| do
796: statusOption TaskCore.Draft currentStatus tid
797: statusOption TaskCore.Open currentStatus tid
798: statusOption TaskCore.InProgress currentStatus tid
799: statusOption TaskCore.Review currentStatus tid
800: statusOption TaskCore.Approved currentStatus tid
801: statusOption TaskCore.Done currentStatus tid
802: statusOption TaskCore.NeedsHelp currentStatus tid
803:
804: statusOption :: (Monad m) => TaskCore.Status -> TaskCore.Status -> Text -> Lucid.HtmlT m ()
805: statusOption opt currentStatus tid =
806: let (cls, label) = case opt of
807: TaskCore.Draft -> ("badge badge-draft", "Draft" :: Text)
808: TaskCore.Open -> ("badge badge-open", "Open")
809: TaskCore.InProgress -> ("badge badge-inprogress", "In Progress")
810: TaskCore.Review -> ("badge badge-review", "Review")
811: TaskCore.Approved -> ("badge badge-approved", "Approved")
812: TaskCore.Done -> ("badge badge-done", "Done")
813: TaskCore.NeedsHelp -> ("badge badge-needshelp", "Needs Help")
814: isSelected = opt == currentStatus
815: optClass = cls <> " status-dropdown-option" <> if isSelected then " selected" else ""
816: in Lucid.form_
817: [ Lucid.class_ "status-option-form",
818: Lucid.role_ "none",
819: Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/status"),
820: Lucid.makeAttribute "hx-target" "#status-badge-container",
821: Lucid.makeAttribute "hx-swap" "outerHTML"
822: ]
823: <| do
824: Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "status", Lucid.value_ (tshow opt)]
825: Lucid.button_
826: [ Lucid.type_ "submit",
827: Lucid.class_ optClass,
828: Lucid.role_ "menuitem",
829: Lucid.tabindex_ "-1",
830: Lucid.makeAttribute "onkeydown" "handleMenuItemKeydown(event)"
831: ]
832: (Lucid.toHtml label)
833:
834: priorityBadgeWithForm :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m ()
835: priorityBadgeWithForm priority tid =
836: Lucid.div_
837: [ Lucid.id_ "priority-badge-container",
838: Lucid.class_ "priority-badge-dropdown"
839: ]
840: <| do
841: clickablePriorityBadge priority tid
842: priorityDropdownOptions priority tid
843:
844: clickablePriorityBadge :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m ()
845: clickablePriorityBadge priority _tid =
846: let (cls, label) = case priority of
847: TaskCore.P0 -> ("badge badge-p0 priority-badge-clickable", "P0 Critical" :: Text)
848: TaskCore.P1 -> ("badge badge-p1 priority-badge-clickable", "P1 High")
849: TaskCore.P2 -> ("badge badge-p2 priority-badge-clickable", "P2 Normal")
850: TaskCore.P3 -> ("badge badge-p3 priority-badge-clickable", "P3 Low")
851: TaskCore.P4 -> ("badge badge-p4 priority-badge-clickable", "P4 Defer")
852: in Lucid.span_
853: [ Lucid.class_ cls,
854: Lucid.tabindex_ "0",
855: Lucid.role_ "button",
856: Lucid.makeAttribute "aria-haspopup" "true",
857: Lucid.makeAttribute "aria-expanded" "false",
858: Lucid.makeAttribute "onclick" "togglePriorityDropdown(this)",
859: Lucid.makeAttribute "onkeydown" "handlePriorityKeydown(event, this)"
860: ]
861: <| do
862: Lucid.toHtml label
863: Lucid.span_ [Lucid.class_ "dropdown-arrow", Lucid.makeAttribute "aria-hidden" "true"] " ▾"
864:
865: priorityDropdownOptions :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m ()
866: priorityDropdownOptions currentPriority tid =
867: Lucid.div_
868: [ Lucid.class_ "priority-dropdown-menu",
869: Lucid.role_ "menu",
870: Lucid.makeAttribute "aria-label" "Change task priority"
871: ]
872: <| do
873: priorityOption TaskCore.P0 currentPriority tid
874: priorityOption TaskCore.P1 currentPriority tid
875: priorityOption TaskCore.P2 currentPriority tid
876: priorityOption TaskCore.P3 currentPriority tid
877: priorityOption TaskCore.P4 currentPriority tid
878:
879: priorityOption :: (Monad m) => TaskCore.Priority -> TaskCore.Priority -> Text -> Lucid.HtmlT m ()
880: priorityOption opt currentPriority tid =
881: let (cls, label) = case opt of
882: TaskCore.P0 -> ("badge badge-p0", "P0 Critical" :: Text)
883: TaskCore.P1 -> ("badge badge-p1", "P1 High")
884: TaskCore.P2 -> ("badge badge-p2", "P2 Normal")
885: TaskCore.P3 -> ("badge badge-p3", "P3 Low")
886: TaskCore.P4 -> ("badge badge-p4", "P4 Defer")
887: isSelected = opt == currentPriority
888: optClass = cls <> " priority-dropdown-option" <> if isSelected then " selected" else ""
889: in Lucid.form_
890: [ Lucid.class_ "priority-option-form",
891: Lucid.role_ "none",
892: Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/priority"),
893: Lucid.makeAttribute "hx-target" "#priority-badge-container",
894: Lucid.makeAttribute "hx-swap" "outerHTML"
895: ]
896: <| do
897: Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "priority", Lucid.value_ (tshow opt)]
898: Lucid.button_
899: [ Lucid.type_ "submit",
900: Lucid.class_ optClass,
901: Lucid.role_ "menuitem",
902: Lucid.tabindex_ "-1",
903: Lucid.makeAttribute "onkeydown" "handlePriorityMenuItemKeydown(event)"
904: ]
905: (Lucid.toHtml label)
906:
907: renderTaskCard :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m ()
908: renderTaskCard t =
909: Lucid.a_
910: [ Lucid.class_ "task-card task-card-link",
911: Lucid.href_ ("/tasks/" <> TaskCore.taskId t)
912: ]
913: <| do
914: Lucid.div_ [Lucid.class_ "task-header"] <| do
915: Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (TaskCore.taskId t))
916: statusBadge (TaskCore.taskStatus t)
917: Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t)))
918: Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t))
919:
920: renderBlockedTaskCard :: (Monad m) => (TaskCore.Task, Int) -> Lucid.HtmlT m ()
921: renderBlockedTaskCard (t, impact) =
922: Lucid.a_
923: [ Lucid.class_ "task-card task-card-link",
924: Lucid.href_ ("/tasks/" <> TaskCore.taskId t)
925: ]
926: <| do
927: Lucid.div_ [Lucid.class_ "task-header"] <| do
928: Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (TaskCore.taskId t))
929: statusBadge (TaskCore.taskStatus t)
930: Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t)))
931: when (impact > 0)
932: <| Lucid.span_ [Lucid.class_ "blocking-impact"] (Lucid.toHtml ("Blocks " <> tshow impact))
933: Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t))
934:
935: renderListGroupItem :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m ()
936: renderListGroupItem t =
937: Lucid.a_
938: [ Lucid.class_ "list-group-item",
939: Lucid.href_ ("/tasks/" <> TaskCore.taskId t),
940: Lucid.makeAttribute "hx-boost" "true",
941: Lucid.makeAttribute "hx-target" "body",
942: Lucid.makeAttribute "hx-swap" "innerHTML"
943: ]
944: <| do
945: Lucid.div_ [Lucid.class_ "list-group-item-content"] <| do
946: Lucid.span_ [Lucid.class_ "list-group-item-id"] (Lucid.toHtml (TaskCore.taskId t))
947: Lucid.span_ [Lucid.class_ "list-group-item-title"] (Lucid.toHtml (TaskCore.taskTitle t))
948: Lucid.div_ [Lucid.class_ "list-group-item-meta"] <| do
949: statusBadge (TaskCore.taskStatus t)
950: Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t)))
951:
952: instance Lucid.ToHtml HomePage where
953: toHtmlRaw = Lucid.toHtml
954: toHtml (HomePage stats readyTasks recentTasks hasMoreRecent globalMetrics currentRange _now) =
955: Lucid.doctypehtml_ <| do
956: pageHead "Jr Dashboard"
957: pageBody <| do
958: Lucid.div_ [Lucid.class_ "container"] <| do
959: Lucid.h2_ "Task Status"
960: Lucid.div_ [Lucid.class_ "time-filter"] <| do
961: timeFilterBtn "Today" Today currentRange
962: timeFilterBtn "This Week" Week currentRange
963: timeFilterBtn "This Month" Month currentRange
964: timeFilterBtn "All Time" AllTime currentRange
965: Lucid.div_ [Lucid.class_ "stats-grid"] <| do
966: statCard "Open" (TaskCore.openTasks stats) "badge-open" "/tasks?status=Open"
967: statCard "In Progress" (TaskCore.inProgressTasks stats) "badge-inprogress" "/tasks?status=InProgress"
968: statCard "Review" (TaskCore.reviewTasks stats) "badge-review" "/tasks?status=Review"
969: statCard "Approved" (TaskCore.approvedTasks stats) "badge-approved" "/tasks?status=Approved"
970: statCard "Done" (TaskCore.doneTasks stats) "badge-done" "/tasks?status=Done"
971: metricCard "Cost" (formatCost (TaskCore.aggTotalCostCents globalMetrics))
972: metricCard "Duration" (formatDuration (TaskCore.aggTotalDurationSeconds globalMetrics))
973:
974: Lucid.h2_ <| do
975: "Ready Queue "
976: Lucid.span_
977: [ Lucid.class_ "ready-count",
978: Lucid.makeAttribute "hx-get" "/partials/ready-count",
979: Lucid.makeAttribute "hx-trigger" "every 5s"
980: ]
981: <| do
982: Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "ready-link"]
983: <| Lucid.toHtml ("(" <> tshow (length readyTasks) <> " tasks)")
984: if null readyTasks
985: then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks ready for work."
986: else
987: Lucid.div_ [Lucid.class_ "list-group"]
988: <| traverse_ renderListGroupItem (take 5 readyTasks)
989:
990: Lucid.h2_ "Recent Activity"
991: let newestTimestamp = maybe 0 taskToUnixTs (head recentTasks)
992: Lucid.div_
993: [ Lucid.class_ "recent-activity",
994: Lucid.id_ "recent-activity",
995: Lucid.makeAttribute "data-newest-ts" (tshow newestTimestamp),
996: Lucid.makeAttribute "hx-get" "/partials/recent-activity-new",
997: Lucid.makeAttribute "hx-trigger" "every 10s",
998: Lucid.makeAttribute "hx-vals" "js:{since: document.getElementById('recent-activity')?.dataset?.newestTs || 0}",
999: Lucid.makeAttribute "hx-target" "#activity-list",
1000: Lucid.makeAttribute "hx-swap" "afterbegin"
1001: ]
1002: <| do
1003: Lucid.div_ [Lucid.id_ "activity-list", Lucid.class_ "list-group"]
1004: <| traverse_ renderListGroupItem recentTasks
1005: when hasMoreRecent
1006: <| Lucid.button_
1007: [ Lucid.id_ "activity-load-more",
1008: Lucid.class_ "btn btn-secondary load-more-btn",
1009: Lucid.makeAttribute "hx-get" "/partials/recent-activity-more?offset=5",
1010: Lucid.makeAttribute "hx-target" "#activity-list",
1011: Lucid.makeAttribute "hx-swap" "beforeend"
1012: ]
1013: "Load More"
1014: where
1015: statCard :: (Monad m) => Text -> Int -> Text -> Text -> Lucid.HtmlT m ()
1016: statCard label count badgeClass href =
1017: Lucid.a_ [Lucid.href_ href, Lucid.class_ ("stat-card " <> badgeClass)] <| do
1018: Lucid.div_ [Lucid.class_ "stat-count"] (Lucid.toHtml (tshow count))
1019: Lucid.div_ [Lucid.class_ "stat-label"] (Lucid.toHtml label)
1020:
1021: metricCard :: (Monad m) => Text -> Text -> Lucid.HtmlT m ()
1022: metricCard label value =
1023: Lucid.div_ [Lucid.class_ "stat-card badge-neutral"] <| do
1024: Lucid.div_ [Lucid.class_ "stat-count"] (Lucid.toHtml value)
1025: Lucid.div_ [Lucid.class_ "stat-label"] (Lucid.toHtml label)
1026:
1027: formatCost :: Int -> Text
1028: formatCost cents =
1029: let dollars = fromIntegral cents / 100.0 :: Double
1030: in Text.pack ("$" <> showFFloat (Just 2) dollars "")
1031:
1032: formatDuration :: Int -> Text
1033: formatDuration totalSeconds
1034: | totalSeconds < 60 = tshow totalSeconds <> "s"
1035: | totalSeconds < 3600 =
1036: let mins = totalSeconds `div` 60
1037: in tshow mins <> "m"
1038: | otherwise =
1039: let hours = totalSeconds `div` 3600
1040: mins = (totalSeconds `mod` 3600) `div` 60
1041: in tshow hours <> "h " <> tshow mins <> "m"
1042:
1043: timeFilterBtn :: (Monad m) => Text -> TimeRange -> TimeRange -> Lucid.HtmlT m ()
1044: timeFilterBtn label range current =
1045: let activeClass = if range == current then " active" else ""
1046: href = "/?" <> "range=" <> timeRangeToParam range
1047: in Lucid.a_
1048: [ Lucid.href_ href,
1049: Lucid.class_ ("time-filter-btn" <> activeClass)
1050: ]
1051: (Lucid.toHtml label)
1052:
1053: instance Lucid.ToHtml ReadyQueuePage where
1054: toHtmlRaw = Lucid.toHtml
1055: toHtml (ReadyQueuePage tasks currentSort _now) =
1056: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Ready Queue" Nothing]
1057: in Lucid.doctypehtml_ <| do
1058: pageHead "Ready Queue - Jr"
1059: pageBodyWithCrumbs crumbs <| do
1060: Lucid.div_ [Lucid.class_ "container"] <| do
1061: Lucid.div_ [Lucid.class_ "page-header-row"] <| do
1062: Lucid.h1_ <| Lucid.toHtml ("Ready Queue (" <> tshow (length tasks) <> " tasks)")
1063: sortDropdown "/ready" currentSort
1064: if null tasks
1065: then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks are ready for work."
1066: else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard tasks
1067:
1068: instance Lucid.ToHtml BlockedPage where
1069: toHtmlRaw = Lucid.toHtml
1070: toHtml (BlockedPage tasksWithImpact currentSort _now) =
1071: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Blocked" Nothing]
1072: in Lucid.doctypehtml_ <| do
1073: pageHead "Blocked Tasks - Jr"
1074: pageBodyWithCrumbs crumbs <| do
1075: Lucid.div_ [Lucid.class_ "container"] <| do
1076: Lucid.div_ [Lucid.class_ "page-header-row"] <| do
1077: Lucid.h1_ <| Lucid.toHtml ("Blocked Tasks (" <> tshow (length tasksWithImpact) <> " tasks)")
1078: sortDropdown "/blocked" currentSort
1079: Lucid.p_ [Lucid.class_ "info-msg"] "Tasks with unmet blocking dependencies, sorted by blocking impact."
1080: if null tasksWithImpact
1081: then Lucid.p_ [Lucid.class_ "empty-msg"] "No blocked tasks."
1082: else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderBlockedTaskCard tasksWithImpact
1083:
1084: instance Lucid.ToHtml InterventionPage where
1085: toHtmlRaw = Lucid.toHtml
1086: toHtml (InterventionPage actionItems currentSort _now) =
1087: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Needs Human Action" Nothing]
1088: failed = TaskCore.failedTasks actionItems
1089: epicsReady = TaskCore.epicsInReview actionItems
1090: needsHelp = TaskCore.tasksNeedingHelp actionItems
1091: totalCount = length failed + length epicsReady + length needsHelp
1092: in Lucid.doctypehtml_ <| do
1093: pageHead "Needs Human Action - Jr"
1094: pageBodyWithCrumbs crumbs <| do
1095: Lucid.div_ [Lucid.class_ "container"] <| do
1096: Lucid.div_ [Lucid.class_ "page-header-row"] <| do
1097: Lucid.h1_ <| Lucid.toHtml ("Needs Human Action (" <> tshow totalCount <> " items)")
1098: sortDropdown "/intervention" currentSort
1099: if totalCount == 0
1100: then Lucid.p_ [Lucid.class_ "empty-msg"] "No items need human action."
1101: else do
1102: unless (null failed) <| do
1103: Lucid.h2_ [Lucid.class_ "section-header"] <| Lucid.toHtml ("Failed Tasks (" <> tshow (length failed) <> ")")
1104: Lucid.p_ [Lucid.class_ "info-msg"] "Tasks that have failed 3+ times and need human help."
1105: Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard (sortTasks currentSort failed)
1106: unless (null epicsReady) <| do
1107: Lucid.h2_ [Lucid.class_ "section-header"] <| Lucid.toHtml ("Epics Ready for Review (" <> tshow (length epicsReady) <> ")")
1108: Lucid.p_ [Lucid.class_ "info-msg"] "Epics with all children completed. Verify before closing."
1109: Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderEpicReviewCard epicsReady
1110: unless (null needsHelp) <| do
1111: Lucid.h2_ [Lucid.class_ "section-header"] <| Lucid.toHtml ("Needs Help (" <> tshow (length needsHelp) <> ")")
1112: Lucid.p_ [Lucid.class_ "info-msg"] "Tasks where Jr needs human guidance or decisions."
1113: Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard (sortTasks currentSort needsHelp)
1114:
1115: renderEpicReviewCard :: (Monad m) => TaskCore.EpicForReview -> Lucid.HtmlT m ()
1116: renderEpicReviewCard epicReview = do
1117: let task = TaskCore.epicTask epicReview
1118: total = TaskCore.epicTotal epicReview
1119: completed = TaskCore.epicCompleted epicReview
1120: progressText = tshow completed <> "/" <> tshow total <> " subtasks done"
1121: Lucid.div_ [Lucid.class_ "task-card"] <| do
1122: Lucid.div_ [Lucid.class_ "task-card-header"] <| do
1123: Lucid.div_ [Lucid.class_ "task-title-row"] <| do
1124: Lucid.a_
1125: [Lucid.href_ ("/tasks/" <> TaskCore.taskId task), Lucid.class_ "task-link"]
1126: <| Lucid.toHtml (TaskCore.taskTitle task)
1127: Lucid.span_ [Lucid.class_ "badge badge-epic"] "Epic"
1128: Lucid.span_ [Lucid.class_ "task-id"] <| Lucid.toHtml (TaskCore.taskId task)
1129: Lucid.div_ [Lucid.class_ "task-card-body"] <| do
1130: Lucid.div_ [Lucid.class_ "progress-info"] <| do
1131: Lucid.span_ [Lucid.class_ "badge badge-success"] <| Lucid.toHtml progressText
1132: Lucid.div_ [Lucid.class_ "epic-actions"] <| do
1133: Lucid.form_
1134: [ Lucid.method_ "POST",
1135: Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/status"),
1136: Lucid.class_ "inline-form"
1137: ]
1138: <| do
1139: Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "status", Lucid.value_ "done"]
1140: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-success btn-sm"] "Approve & Close"
1141:
1142: instance Lucid.ToHtml KBPage where
1143: toHtmlRaw = Lucid.toHtml
1144: toHtml (KBPage facts) =
1145: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Knowledge Base" Nothing]
1146: in Lucid.doctypehtml_ <| do
1147: pageHead "Knowledge Base - Jr"
1148: pageBodyWithCrumbs crumbs <| do
1149: Lucid.div_ [Lucid.class_ "container"] <| do
1150: Lucid.h1_ "Knowledge Base"
1151: Lucid.p_ [Lucid.class_ "info-msg"] "Facts learned during task execution."
1152:
1153: Lucid.details_ [Lucid.class_ "create-fact-section"] <| do
1154: Lucid.summary_ [Lucid.class_ "btn btn-primary create-fact-toggle"] "Create New Fact"
1155: Lucid.form_
1156: [ Lucid.method_ "POST",
1157: Lucid.action_ "/kb/create",
1158: Lucid.class_ "fact-create-form"
1159: ]
1160: <| do
1161: Lucid.div_ [Lucid.class_ "form-group"] <| do
1162: Lucid.label_ [Lucid.for_ "project"] "Project:"
1163: Lucid.input_
1164: [ Lucid.type_ "text",
1165: Lucid.name_ "project",
1166: Lucid.id_ "project",
1167: Lucid.class_ "form-input",
1168: Lucid.required_ "required",
1169: Lucid.placeholder_ "e.g., Omni/Jr"
1170: ]
1171: Lucid.div_ [Lucid.class_ "form-group"] <| do
1172: Lucid.label_ [Lucid.for_ "content"] "Fact Content:"
1173: Lucid.textarea_
1174: [ Lucid.name_ "content",
1175: Lucid.id_ "content",
1176: Lucid.class_ "form-textarea",
1177: Lucid.rows_ "4",
1178: Lucid.required_ "required",
1179: Lucid.placeholder_ "Describe the fact or knowledge..."
1180: ]
1181: ""
1182: Lucid.div_ [Lucid.class_ "form-group"] <| do
1183: Lucid.label_ [Lucid.for_ "files"] "Related Files (comma-separated):"
1184: Lucid.input_
1185: [ Lucid.type_ "text",
1186: Lucid.name_ "files",
1187: Lucid.id_ "files",
1188: Lucid.class_ "form-input",
1189: Lucid.placeholder_ "path/to/file1.hs, path/to/file2.hs"
1190: ]
1191: Lucid.div_ [Lucid.class_ "form-group"] <| do
1192: Lucid.label_ [Lucid.for_ "confidence"] "Confidence (0.0 - 1.0):"
1193: Lucid.input_
1194: [ Lucid.type_ "number",
1195: Lucid.name_ "confidence",
1196: Lucid.id_ "confidence",
1197: Lucid.class_ "form-input",
1198: Lucid.step_ "0.1",
1199: Lucid.min_ "0",
1200: Lucid.max_ "1",
1201: Lucid.value_ "0.8"
1202: ]
1203: Lucid.div_ [Lucid.class_ "form-actions"] <| do
1204: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Create Fact"
1205:
1206: if null facts
1207: then Lucid.p_ [Lucid.class_ "empty-msg"] "No facts recorded yet."
1208: else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderFactCard facts
1209: where
1210: renderFactCard :: (Monad m) => TaskCore.Fact -> Lucid.HtmlT m ()
1211: renderFactCard f =
1212: let factUrl = "/kb/" <> maybe "-" tshow (TaskCore.factId f)
1213: in Lucid.a_
1214: [ Lucid.class_ "task-card task-card-link",
1215: Lucid.href_ factUrl
1216: ]
1217: <| do
1218: Lucid.div_ [Lucid.class_ "task-header"] <| do
1219: Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (maybe "-" tshow (TaskCore.factId f)))
1220: confidenceBadge (TaskCore.factConfidence f)
1221: Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (TaskCore.factProject f))
1222: Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (Text.take 80 (TaskCore.factContent f) <> if Text.length (TaskCore.factContent f) > 80 then "..." else ""))
1223: unless (null (TaskCore.factRelatedFiles f)) <| do
1224: Lucid.p_ [Lucid.class_ "kb-files"] <| do
1225: Lucid.span_ [Lucid.class_ "files-label"] "Files: "
1226: Lucid.toHtml (Text.intercalate ", " (take 3 (TaskCore.factRelatedFiles f)))
1227: when (length (TaskCore.factRelatedFiles f) > 3) <| do
1228: Lucid.toHtml (" +" <> tshow (length (TaskCore.factRelatedFiles f) - 3) <> " more")
1229:
1230: confidenceBadge :: (Monad m) => Double -> Lucid.HtmlT m ()
1231: confidenceBadge conf =
1232: let pct = floor (conf * 100) :: Int
1233: cls
1234: | conf >= 0.8 = "badge badge-done"
1235: | conf >= 0.5 = "badge badge-inprogress"
1236: | otherwise = "badge badge-open"
1237: in Lucid.span_ [Lucid.class_ cls] (Lucid.toHtml (tshow pct <> "%"))
1238:
1239: instance Lucid.ToHtml FactDetailPage where
1240: toHtmlRaw = Lucid.toHtml
1241: toHtml (FactDetailNotFound fid) =
1242: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Knowledge Base" (Just "/kb"), Breadcrumb ("Fact #" <> tshow fid) Nothing]
1243: in Lucid.doctypehtml_ <| do
1244: pageHead "Fact Not Found - Jr"
1245: pageBodyWithCrumbs crumbs <| do
1246: Lucid.div_ [Lucid.class_ "container"] <| do
1247: Lucid.h1_ "Fact Not Found"
1248: Lucid.p_ [Lucid.class_ "error-msg"] (Lucid.toHtml ("Fact with ID " <> tshow fid <> " not found."))
1249: Lucid.a_ [Lucid.href_ "/kb", Lucid.class_ "btn btn-secondary"] "Back to Knowledge Base"
1250: toHtml (FactDetailFound fact now) =
1251: let fid' = maybe "-" tshow (TaskCore.factId fact)
1252: crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Knowledge Base" (Just "/kb"), Breadcrumb ("Fact #" <> fid') Nothing]
1253: in Lucid.doctypehtml_ <| do
1254: pageHead "Fact Detail - Jr"
1255: pageBodyWithCrumbs crumbs <| do
1256: Lucid.div_ [Lucid.class_ "container"] <| do
1257: Lucid.div_ [Lucid.class_ "task-detail-header"] <| do
1258: Lucid.h1_ <| do
1259: Lucid.span_ [Lucid.class_ "detail-id"] (Lucid.toHtml ("Fact #" <> maybe "-" tshow (TaskCore.factId fact)))
1260: Lucid.div_ [Lucid.class_ "task-meta-row"] <| do
1261: Lucid.span_ [Lucid.class_ "meta-label"] "Project:"
1262: Lucid.span_ [Lucid.class_ "meta-value"] (Lucid.toHtml (TaskCore.factProject fact))
1263: Lucid.span_ [Lucid.class_ "meta-label"] "Confidence:"
1264: confidenceBadgeDetail (TaskCore.factConfidence fact)
1265: Lucid.span_ [Lucid.class_ "meta-label"] "Created:"
1266: Lucid.span_ [Lucid.class_ "meta-value"] (renderRelativeTimestamp now (TaskCore.factCreatedAt fact))
1267:
1268: Lucid.div_ [Lucid.class_ "detail-section"] <| do
1269: Lucid.h2_ "Content"
1270: Lucid.form_
1271: [ Lucid.method_ "POST",
1272: Lucid.action_ ("/kb/" <> maybe "-" tshow (TaskCore.factId fact) <> "/edit"),
1273: Lucid.class_ "fact-edit-form"
1274: ]
1275: <| do
1276: Lucid.div_ [Lucid.class_ "form-group"] <| do
1277: Lucid.label_ [Lucid.for_ "content"] "Fact Content:"
1278: Lucid.textarea_
1279: [ Lucid.name_ "content",
1280: Lucid.id_ "content",
1281: Lucid.class_ "form-textarea",
1282: Lucid.rows_ "6"
1283: ]
1284: (Lucid.toHtml (TaskCore.factContent fact))
1285:
1286: Lucid.div_ [Lucid.class_ "form-group"] <| do
1287: Lucid.label_ [Lucid.for_ "files"] "Related Files (comma-separated):"
1288: Lucid.input_
1289: [ Lucid.type_ "text",
1290: Lucid.name_ "files",
1291: Lucid.id_ "files",
1292: Lucid.class_ "form-input",
1293: Lucid.value_ (Text.intercalate ", " (TaskCore.factRelatedFiles fact))
1294: ]
1295:
1296: Lucid.div_ [Lucid.class_ "form-group"] <| do
1297: Lucid.label_ [Lucid.for_ "confidence"] "Confidence (0.0 - 1.0):"
1298: Lucid.input_
1299: [ Lucid.type_ "number",
1300: Lucid.name_ "confidence",
1301: Lucid.id_ "confidence",
1302: Lucid.class_ "form-input",
1303: Lucid.step_ "0.1",
1304: Lucid.min_ "0",
1305: Lucid.max_ "1",
1306: Lucid.value_ (tshow (TaskCore.factConfidence fact))
1307: ]
1308:
1309: Lucid.div_ [Lucid.class_ "form-actions"] <| do
1310: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Save Changes"
1311:
1312: case TaskCore.factSourceTask fact of
1313: Nothing -> pure ()
1314: Just tid -> do
1315: Lucid.div_ [Lucid.class_ "detail-section"] <| do
1316: Lucid.h2_ "Source Task"
1317: Lucid.a_ [Lucid.href_ ("/tasks/" <> tid), Lucid.class_ "task-link"] (Lucid.toHtml tid)
1318:
1319: Lucid.div_ [Lucid.class_ "detail-section danger-zone"] <| do
1320: Lucid.h2_ "Danger Zone"
1321: Lucid.form_
1322: [ Lucid.method_ "POST",
1323: Lucid.action_ ("/kb/" <> maybe "-" tshow (TaskCore.factId fact) <> "/delete"),
1324: Lucid.class_ "delete-form",
1325: Lucid.makeAttribute "onsubmit" "return confirm('Are you sure you want to delete this fact?');"
1326: ]
1327: <| do
1328: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-danger"] "Delete Fact"
1329:
1330: Lucid.div_ [Lucid.class_ "back-link"] <| do
1331: Lucid.a_ [Lucid.href_ "/kb"] "← Back to Knowledge Base"
1332: where
1333: confidenceBadgeDetail :: (Monad m) => Double -> Lucid.HtmlT m ()
1334: confidenceBadgeDetail conf =
1335: let pct = floor (conf * 100) :: Int
1336: cls
1337: | conf >= 0.8 = "badge badge-done"
1338: | conf >= 0.5 = "badge badge-inprogress"
1339: | otherwise = "badge badge-open"
1340: in Lucid.span_ [Lucid.class_ cls] (Lucid.toHtml (tshow pct <> "%"))
1341:
1342: instance Lucid.ToHtml EpicsPage where
1343: toHtmlRaw = Lucid.toHtml
1344: toHtml (EpicsPage epics allTasks currentSort) =
1345: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Epics" Nothing]
1346: in Lucid.doctypehtml_ <| do
1347: pageHead "Epics - Jr"
1348: pageBodyWithCrumbs crumbs <| do
1349: Lucid.div_ [Lucid.class_ "container"] <| do
1350: Lucid.div_ [Lucid.class_ "page-header-row"] <| do
1351: Lucid.h1_ <| Lucid.toHtml ("Epics (" <> tshow (length epics) <> ")")
1352: sortDropdown "/epics" currentSort
1353: Lucid.p_ [Lucid.class_ "info-msg"] "All epics (large, multi-task projects)."
1354: if null epics
1355: then Lucid.p_ [Lucid.class_ "empty-msg"] "No epics found."
1356: else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ (renderEpicCardWithStats allTasks) epics
1357:
1358: epicProgressBar :: (Monad m) => Int -> Int -> Int -> Int -> Lucid.HtmlT m ()
1359: epicProgressBar doneCount inProgressCount openCount totalCount =
1360: let donePct = if totalCount == 0 then 0 else (doneCount * 100) `div` totalCount
1361: inProgressPct = if totalCount == 0 then 0 else (inProgressCount * 100) `div` totalCount
1362: openPct = if totalCount == 0 then 0 else (openCount * 100) `div` totalCount
1363: in Lucid.div_ [Lucid.class_ "multi-progress-container epic-progress"] <| do
1364: Lucid.div_ [Lucid.class_ "multi-progress-bar"] <| do
1365: when (donePct > 0)
1366: <| Lucid.div_
1367: [ Lucid.class_ "multi-progress-segment progress-done",
1368: Lucid.style_ ("width: " <> tshow donePct <> "%"),
1369: Lucid.title_ (tshow doneCount <> " done")
1370: ]
1371: ""
1372: when (inProgressPct > 0)
1373: <| Lucid.div_
1374: [ Lucid.class_ "multi-progress-segment progress-inprogress",
1375: Lucid.style_ ("width: " <> tshow inProgressPct <> "%"),
1376: Lucid.title_ (tshow inProgressCount <> " in progress")
1377: ]
1378: ""
1379: when (openPct > 0)
1380: <| Lucid.div_
1381: [ Lucid.class_ "multi-progress-segment progress-open",
1382: Lucid.style_ ("width: " <> tshow openPct <> "%"),
1383: Lucid.title_ (tshow openCount <> " open")
1384: ]
1385: ""
1386: Lucid.div_ [Lucid.class_ "progress-legend"] <| do
1387: Lucid.span_ [Lucid.class_ "legend-item"] <| do
1388: Lucid.span_ [Lucid.class_ "legend-dot legend-done"] ""
1389: Lucid.toHtml (tshow doneCount)
1390: Lucid.span_ [Lucid.class_ "legend-item"] <| do
1391: Lucid.span_ [Lucid.class_ "legend-dot legend-inprogress"] ""
1392: Lucid.toHtml (tshow inProgressCount)
1393: Lucid.span_ [Lucid.class_ "legend-item"] <| do
1394: Lucid.span_ [Lucid.class_ "legend-dot legend-open"] ""
1395: Lucid.toHtml (tshow openCount)
1396:
1397: renderEpicCardWithStats :: (Monad m) => [TaskCore.Task] -> TaskCore.Task -> Lucid.HtmlT m ()
1398: renderEpicCardWithStats allTasks t =
1399: let children = getDescendants allTasks (TaskCore.taskId t)
1400: openCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Open]
1401: inProgressCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.InProgress]
1402: reviewCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Review]
1403: doneCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Done]
1404: totalCount = length children
1405: openAndReview = openCount + reviewCount
1406: in Lucid.a_
1407: [ Lucid.class_ "task-card task-card-link",
1408: Lucid.href_ ("/tasks/" <> TaskCore.taskId t)
1409: ]
1410: <| do
1411: Lucid.div_ [Lucid.class_ "task-header"] <| do
1412: Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (TaskCore.taskId t))
1413: statusBadge (TaskCore.taskStatus t)
1414: Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t)))
1415: Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t))
1416: when (totalCount > 0) <| epicProgressBar doneCount inProgressCount openAndReview totalCount
1417: unless (Text.null (TaskCore.taskDescription t))
1418: <| Lucid.p_ [Lucid.class_ "kb-preview"] (Lucid.toHtml (Text.take 200 (TaskCore.taskDescription t) <> "..."))
1419:
1420: getDescendants :: [TaskCore.Task] -> Text -> [TaskCore.Task]
1421: getDescendants allTasks parentId =
1422: let children = [c | c <- allTasks, maybe False (TaskCore.matchesId parentId) (TaskCore.taskParent c)]
1423: in children ++ concatMap (getDescendants allTasks <. TaskCore.taskId) children
1424:
1425: instance Lucid.ToHtml TaskListPage where
1426: toHtmlRaw = Lucid.toHtml
1427: toHtml (TaskListPage tasks filters currentSort _now) =
1428: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" Nothing]
1429: in Lucid.doctypehtml_ <| do
1430: pageHead "Tasks - Jr"
1431: pageBodyWithCrumbs crumbs <| do
1432: Lucid.div_ [Lucid.class_ "container"] <| do
1433: Lucid.div_ [Lucid.class_ "page-header-row"] <| do
1434: Lucid.h1_ <| Lucid.toHtml ("Tasks (" <> tshow (length tasks) <> ")")
1435: sortDropdown "/tasks" currentSort
1436:
1437: Lucid.div_ [Lucid.class_ "filter-form"] <| do
1438: Lucid.form_
1439: [ Lucid.method_ "GET",
1440: Lucid.action_ "/tasks",
1441: Lucid.makeAttribute "hx-get" "/partials/task-list",
1442: Lucid.makeAttribute "hx-target" "#task-list",
1443: Lucid.makeAttribute "hx-push-url" "/tasks",
1444: Lucid.makeAttribute "hx-trigger" "submit, change from:select"
1445: ]
1446: <| do
1447: Lucid.div_ [Lucid.class_ "filter-row"] <| do
1448: Lucid.div_ [Lucid.class_ "filter-group"] <| do
1449: Lucid.label_ [Lucid.for_ "status"] "Status:"
1450: Lucid.select_ [Lucid.name_ "status", Lucid.id_ "status", Lucid.class_ "filter-select"] <| do
1451: Lucid.option_ ([Lucid.value_ ""] <> maybeSelected Nothing (filterStatus filters)) "All"
1452: statusFilterOption TaskCore.Open (filterStatus filters)
1453: statusFilterOption TaskCore.InProgress (filterStatus filters)
1454: statusFilterOption TaskCore.Review (filterStatus filters)
1455: statusFilterOption TaskCore.Approved (filterStatus filters)
1456: statusFilterOption TaskCore.Done (filterStatus filters)
1457:
1458: Lucid.div_ [Lucid.class_ "filter-group"] <| do
1459: Lucid.label_ [Lucid.for_ "priority"] "Priority:"
1460: Lucid.select_ [Lucid.name_ "priority", Lucid.id_ "priority", Lucid.class_ "filter-select"] <| do
1461: Lucid.option_ ([Lucid.value_ ""] <> maybeSelected Nothing (filterPriority filters)) "All"
1462: priorityFilterOption TaskCore.P0 (filterPriority filters)
1463: priorityFilterOption TaskCore.P1 (filterPriority filters)
1464: priorityFilterOption TaskCore.P2 (filterPriority filters)
1465: priorityFilterOption TaskCore.P3 (filterPriority filters)
1466: priorityFilterOption TaskCore.P4 (filterPriority filters)
1467:
1468: Lucid.div_ [Lucid.class_ "filter-group"] <| do
1469: Lucid.label_ [Lucid.for_ "namespace"] "Namespace:"
1470: Lucid.input_
1471: [ Lucid.type_ "text",
1472: Lucid.name_ "namespace",
1473: Lucid.id_ "namespace",
1474: Lucid.class_ "filter-input",
1475: Lucid.placeholder_ "e.g. Omni/Jr",
1476: Lucid.value_ (fromMaybe "" (filterNamespace filters))
1477: ]
1478:
1479: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "filter-btn"] "Filter"
1480: Lucid.a_
1481: [ Lucid.href_ "/tasks",
1482: Lucid.class_ "clear-btn",
1483: Lucid.makeAttribute "hx-get" "/partials/task-list",
1484: Lucid.makeAttribute "hx-target" "#task-list",
1485: Lucid.makeAttribute "hx-push-url" "/tasks"
1486: ]
1487: "Clear"
1488:
1489: Lucid.div_ [Lucid.id_ "task-list"] <| do
1490: if null tasks
1491: then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks match the current filters."
1492: else Lucid.div_ [Lucid.class_ "list-group"] <| traverse_ renderListGroupItem tasks
1493: where
1494: maybeSelected :: (Eq a) => Maybe a -> Maybe a -> [Lucid.Attribute]
1495: maybeSelected opt current = [Lucid.selected_ "selected" | opt == current]
1496:
1497: statusFilterOption :: (Monad m) => TaskCore.Status -> Maybe TaskCore.Status -> Lucid.HtmlT m ()
1498: statusFilterOption s current =
1499: let attrs = [Lucid.value_ (tshow s)] <> [Lucid.selected_ "selected" | Just s == current]
1500: in Lucid.option_ attrs (Lucid.toHtml (tshow s))
1501:
1502: priorityFilterOption :: (Monad m) => TaskCore.Priority -> Maybe TaskCore.Priority -> Lucid.HtmlT m ()
1503: priorityFilterOption p current =
1504: let attrs = [Lucid.value_ (tshow p)] <> [Lucid.selected_ "selected" | Just p == current]
1505: in Lucid.option_ attrs (Lucid.toHtml (tshow p))
1506:
1507: instance Lucid.ToHtml TaskDetailPage where
1508: toHtmlRaw = Lucid.toHtml
1509: toHtml (TaskDetailNotFound tid) =
1510: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid Nothing]
1511: in Lucid.doctypehtml_ <| do
1512: pageHead "Task Not Found - Jr"
1513: pageBodyWithCrumbs crumbs <| do
1514: Lucid.div_ [Lucid.class_ "container"] <| do
1515: Lucid.h1_ "Task Not Found"
1516: Lucid.p_ <| do
1517: "The task "
1518: Lucid.code_ (Lucid.toHtml tid)
1519: " could not be found."
1520: toHtml (TaskDetailFound task allTasks activities maybeRetry commits maybeAggMetrics agentEvents now) =
1521: let crumbs = taskBreadcrumbs allTasks task
1522: in Lucid.doctypehtml_ <| do
1523: pageHead (TaskCore.taskId task <> " - Jr")
1524: pageBodyWithCrumbs crumbs <| do
1525: Lucid.div_ [Lucid.class_ "container"] <| do
1526: Lucid.h1_ <| Lucid.toHtml (TaskCore.taskTitle task)
1527:
1528: renderRetryContextBanner (TaskCore.taskId task) maybeRetry
1529:
1530: Lucid.div_ [Lucid.class_ "task-detail"] <| do
1531: Lucid.div_ [Lucid.class_ "task-meta"] <| do
1532: Lucid.div_ [Lucid.class_ "task-meta-primary"] <| do
1533: Lucid.code_ [Lucid.class_ "task-meta-id"] (Lucid.toHtml (TaskCore.taskId task))
1534: metaSep
1535: Lucid.span_ [Lucid.class_ "task-meta-type"] (Lucid.toHtml (tshow (TaskCore.taskType task)))
1536: metaSep
1537: statusBadgeWithForm (TaskCore.taskStatus task) (TaskCore.taskId task)
1538: metaSep
1539: priorityBadgeWithForm (TaskCore.taskPriority task) (TaskCore.taskId task)
1540: case TaskCore.taskComplexity task of
1541: Nothing -> pure ()
1542: Just c -> do
1543: metaSep
1544: complexityBadge c
1545: case TaskCore.taskNamespace task of
1546: Nothing -> pure ()
1547: Just ns -> do
1548: metaSep
1549: Lucid.span_ [Lucid.class_ "task-meta-ns"] (Lucid.toHtml ns)
1550:
1551: Lucid.div_ [Lucid.class_ "task-meta-secondary"] <| do
1552: case TaskCore.taskParent task of
1553: Nothing -> pure ()
1554: Just pid -> do
1555: Lucid.span_ [Lucid.class_ "task-meta-label"] "Parent:"
1556: Lucid.a_ [Lucid.href_ ("/tasks/" <> pid), Lucid.class_ "task-link"] (Lucid.toHtml pid)
1557: metaSep
1558: Lucid.span_ [Lucid.class_ "task-meta-label"] "Created"
1559: renderRelativeTimestamp now (TaskCore.taskCreatedAt task)
1560: metaSep
1561: Lucid.span_ [Lucid.class_ "task-meta-label"] "Updated"
1562: renderRelativeTimestamp now (TaskCore.taskUpdatedAt task)
1563:
1564: let deps = TaskCore.taskDependencies task
1565: unless (null deps) <| do
1566: Lucid.div_ [Lucid.class_ "detail-section"] <| do
1567: Lucid.h3_ "Dependencies"
1568: Lucid.ul_ [Lucid.class_ "dep-list"] <| do
1569: traverse_ renderDependency deps
1570:
1571: when (TaskCore.taskType task == TaskCore.Epic) <| do
1572: for_ maybeAggMetrics (renderAggregatedMetrics allTasks task)
1573:
1574: Lucid.div_ [Lucid.class_ "detail-section"] <| do
1575: Lucid.toHtml (DescriptionViewPartial (TaskCore.taskId task) (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic))
1576:
1577: let children = filter (maybe False (TaskCore.matchesId (TaskCore.taskId task)) <. TaskCore.taskParent) allTasks
1578: unless (null children) <| do
1579: Lucid.div_ [Lucid.class_ "detail-section"] <| do
1580: Lucid.h3_ "Child Tasks"
1581: Lucid.ul_ [Lucid.class_ "child-list"] <| do
1582: traverse_ renderChild children
1583:
1584: unless (null commits) <| do
1585: Lucid.div_ [Lucid.class_ "detail-section"] <| do
1586: Lucid.h3_ "Git Commits"
1587: Lucid.div_ [Lucid.class_ "commit-list"] <| do
1588: traverse_ (renderCommit (TaskCore.taskId task)) commits
1589:
1590: let hasRunningActivity = any (\a -> TaskCore.activityStage a == TaskCore.Running) activities
1591: when hasRunningActivity <| do
1592: let isInProgress = TaskCore.taskStatus task == TaskCore.InProgress
1593: htmxAttrs =
1594: [ Lucid.makeAttribute "hx-get" ("/partials/task/" <> TaskCore.taskId task <> "/metrics"),
1595: Lucid.makeAttribute "hx-trigger" "every 5s",
1596: Lucid.makeAttribute "hx-swap" "innerHTML"
1597: ]
1598: innerAttrs =
1599: [Lucid.id_ "execution-details-inner"]
1600: <> [attr | isInProgress, attr <- htmxAttrs]
1601: Lucid.div_ [Lucid.class_ "execution-section"] <| do
1602: Lucid.h3_ "Execution Details"
1603: Lucid.div_ innerAttrs <| renderExecutionDetails (TaskCore.taskId task) activities maybeRetry
1604:
1605: when (TaskCore.taskStatus task == TaskCore.Review) <| do
1606: Lucid.div_ [Lucid.class_ "review-link-section"] <| do
1607: Lucid.a_
1608: [ Lucid.href_ ("/tasks/" <> TaskCore.taskId task <> "/review"),
1609: Lucid.class_ "review-link-btn"
1610: ]
1611: "Review This Task"
1612:
1613: renderUnifiedTimeline (TaskCore.taskId task) (TaskCore.taskComments task) agentEvents (TaskCore.taskStatus task) now
1614: where
1615: renderDependency :: (Monad m) => TaskCore.Dependency -> Lucid.HtmlT m ()
1616: renderDependency dep =
1617: Lucid.li_ <| do
1618: Lucid.a_ [Lucid.href_ ("/tasks/" <> TaskCore.depId dep), Lucid.class_ "task-link"] (Lucid.toHtml (TaskCore.depId dep))
1619: Lucid.span_ [Lucid.class_ "dep-type"] <| Lucid.toHtml (" [" <> tshow (TaskCore.depType dep) <> "]")
1620:
1621: renderChild :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m ()
1622: renderChild child =
1623: Lucid.li_ <| do
1624: Lucid.a_ [Lucid.href_ ("/tasks/" <> TaskCore.taskId child), Lucid.class_ "task-link"] (Lucid.toHtml (TaskCore.taskId child))
1625: Lucid.span_ [Lucid.class_ "child-title"] <| Lucid.toHtml (" - " <> TaskCore.taskTitle child)
1626: Lucid.span_ [Lucid.class_ "child-status"] <| Lucid.toHtml (" [" <> tshow (TaskCore.taskStatus child) <> "]")
1627:
1628: renderCommit :: (Monad m) => Text -> GitCommit -> Lucid.HtmlT m ()
1629: renderCommit tid c =
1630: Lucid.div_ [Lucid.class_ "commit-item"] <| do
1631: Lucid.div_ [Lucid.class_ "commit-header"] <| do
1632: Lucid.a_
1633: [ Lucid.href_ ("/tasks/" <> tid <> "/diff/" <> commitHash c),
1634: Lucid.class_ "commit-hash"
1635: ]
1636: (Lucid.toHtml (commitShortHash c))
1637: Lucid.span_ [Lucid.class_ "commit-summary"] (Lucid.toHtml (commitSummary c))
1638: Lucid.div_ [Lucid.class_ "commit-meta"] <| do
1639: Lucid.span_ [Lucid.class_ "commit-author"] (Lucid.toHtml (commitAuthor c))
1640: Lucid.span_ [Lucid.class_ "commit-date"] (Lucid.toHtml (commitRelativeDate c))
1641: Lucid.span_ [Lucid.class_ "commit-files"] (Lucid.toHtml (tshow (commitFilesChanged c) <> " files"))
1642:
1643: renderExecutionDetails :: (Monad m) => Text -> [TaskCore.TaskActivity] -> Maybe TaskCore.RetryContext -> Lucid.HtmlT m ()
1644: renderExecutionDetails _ acts retryCtx =
1645: let runningActs = filter (\a -> TaskCore.activityStage a == TaskCore.Running) acts
1646: in if null runningActs
1647: then Lucid.p_ [Lucid.class_ "empty-msg"] "No worker execution data available."
1648: else
1649: Lucid.div_ [Lucid.class_ "execution-details"] <| do
1650: let totalCost = sum [c | act <- runningActs, Just c <- [TaskCore.activityCostCents act]]
1651: totalDuration = sum [calcDurSecs act | act <- runningActs]
1652: attemptCount = length runningActs
1653:
1654: case retryCtx of
1655: Nothing -> pure ()
1656: Just ctx ->
1657: Lucid.div_ [Lucid.class_ "metric-row"] <| do
1658: Lucid.span_ [Lucid.class_ "metric-label"] "Retry Attempt:"
1659: Lucid.span_ [Lucid.class_ "metric-value retry-count"] (Lucid.toHtml (tshow (TaskCore.retryAttempt ctx) <> "/3"))
1660:
1661: when (attemptCount > 1) <| do
1662: Lucid.div_ [Lucid.class_ "metric-row"] <| do
1663: Lucid.span_ [Lucid.class_ "metric-label"] "Total Attempts:"
1664: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (tshow attemptCount))
1665: Lucid.div_ [Lucid.class_ "metric-row"] <| do
1666: Lucid.span_ [Lucid.class_ "metric-label"] "Total Duration:"
1667: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDurSecs totalDuration))
1668: when (totalCost > 0)
1669: <| Lucid.div_ [Lucid.class_ "metric-row"]
1670: <| do
1671: Lucid.span_ [Lucid.class_ "metric-label"] "Total Cost:"
1672: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCostVal totalCost))
1673: Lucid.hr_ [Lucid.class_ "attempts-divider"]
1674:
1675: traverse_ (renderAttempt attemptCount) (zip [1 ..] (reverse runningActs))
1676: where
1677: calcDurSecs :: TaskCore.TaskActivity -> Int
1678: calcDurSecs act = case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of
1679: (Just start, Just end) -> floor (diffUTCTime end start)
1680: _ -> 0
1681:
1682: formatDurSecs :: Int -> Text
1683: formatDurSecs secs
1684: | secs < 60 = tshow secs <> "s"
1685: | secs < 3600 = tshow (secs `div` 60) <> "m " <> tshow (secs `mod` 60) <> "s"
1686: | otherwise = tshow (secs `div` 3600) <> "h " <> tshow ((secs `mod` 3600) `div` 60) <> "m"
1687:
1688: renderAttempt :: (Monad m) => Int -> (Int, TaskCore.TaskActivity) -> Lucid.HtmlT m ()
1689: renderAttempt totalAttempts (attemptNum, act) = do
1690: when (totalAttempts > 1)
1691: <| Lucid.div_ [Lucid.class_ "attempt-header"] (Lucid.toHtml ("Attempt " <> tshow attemptNum :: Text))
1692: case TaskCore.activityThreadUrl act of
1693: Nothing -> pure ()
1694: Just url ->
1695: Lucid.div_ [Lucid.class_ "metric-row"] <| do
1696: Lucid.span_ [Lucid.class_ "metric-label"] "Session:"
1697: Lucid.a_ [Lucid.href_ url, Lucid.target_ "_blank", Lucid.class_ "amp-thread-btn"] "View in Amp ↗"
1698:
1699: case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of
1700: (Just start, Just end) ->
1701: Lucid.div_ [Lucid.class_ "metric-row"] <| do
1702: Lucid.span_ [Lucid.class_ "metric-label"] "Duration:"
1703: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDur start end))
1704: (Just start, Nothing) ->
1705: Lucid.div_ [Lucid.class_ "metric-row"] <| do
1706: Lucid.span_ [Lucid.class_ "metric-label"] "Started:"
1707: Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp now start)
1708: _ -> pure ()
1709:
1710: case TaskCore.activityCostCents act of
1711: Nothing -> pure ()
1712: Just cents ->
1713: Lucid.div_ [Lucid.class_ "metric-row"] <| do
1714: Lucid.span_ [Lucid.class_ "metric-label"] "Cost:"
1715: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCostVal cents))
1716:
1717: Lucid.div_ [Lucid.class_ "metric-row"] <| do
1718: Lucid.span_ [Lucid.class_ "metric-label"] "Timestamp:"
1719: Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp now (TaskCore.activityTimestamp act))
1720:
1721: formatDur :: UTCTime -> UTCTime -> Text
1722: formatDur start end =
1723: let diffSecs = floor (diffUTCTime end start) :: Int
1724: mins = diffSecs `div` 60
1725: secs = diffSecs `mod` 60
1726: in if mins > 0
1727: then tshow mins <> "m " <> tshow secs <> "s"
1728: else tshow secs <> "s"
1729:
1730: formatCostVal :: Int -> Text
1731: formatCostVal cents =
1732: let dollars = fromIntegral cents / 100.0 :: Double
1733: in "$" <> Text.pack (showFFloat (Just 2) dollars "")
1734:
1735: renderAggregatedMetrics :: (Monad m) => [TaskCore.Task] -> TaskCore.Task -> TaskCore.AggregatedMetrics -> Lucid.HtmlT m ()
1736: renderAggregatedMetrics allTasks task metrics =
1737: let descendants = getDescendants allTasks (TaskCore.taskId task)
1738: totalCount = length descendants
1739: costCents = TaskCore.aggTotalCostCents metrics
1740: durationSecs = TaskCore.aggTotalDurationSeconds metrics
1741: completedCount = TaskCore.aggCompletedTasks metrics
1742: tokensUsed = TaskCore.aggTotalTokens metrics
1743: in Lucid.div_ [Lucid.class_ "detail-section aggregated-metrics"] <| do
1744: Lucid.h3_ "Execution Summary"
1745: Lucid.div_ [Lucid.class_ "metrics-grid"] <| do
1746: Lucid.div_ [Lucid.class_ "metric-card"] <| do
1747: Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (tshow completedCount <> "/" <> tshow totalCount))
1748: Lucid.div_ [Lucid.class_ "metric-label"] "Tasks Completed"
1749: Lucid.div_ [Lucid.class_ "metric-card"] <| do
1750: Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCost costCents))
1751: Lucid.div_ [Lucid.class_ "metric-label"] "Total Cost"
1752: Lucid.div_ [Lucid.class_ "metric-card"] <| do
1753: Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDuration durationSecs))
1754: Lucid.div_ [Lucid.class_ "metric-label"] "Total Time"
1755: when (tokensUsed > 0) <| do
1756: Lucid.div_ [Lucid.class_ "metric-card"] <| do
1757: Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatTokens tokensUsed))
1758: Lucid.div_ [Lucid.class_ "metric-label"] "Tokens Used"
1759: where
1760: formatCost :: Int -> Text
1761: formatCost cents =
1762: let dollars = fromIntegral cents / 100.0 :: Double
1763: in "$" <> Text.pack (showFFloat (Just 2) dollars "")
1764:
1765: formatDuration :: Int -> Text
1766: formatDuration secs
1767: | secs < 60 = tshow secs <> "s"
1768: | secs < 3600 =
1769: let mins = secs `div` 60
1770: remSecs = secs `mod` 60
1771: in tshow mins <> "m " <> tshow remSecs <> "s"
1772: | otherwise =
1773: let hrs = secs `div` 3600
1774: mins = (secs `mod` 3600) `div` 60
1775: in tshow hrs <> "h " <> tshow mins <> "m"
1776:
1777: formatTokens :: Int -> Text
1778: formatTokens t
1779: | t < 1000 = tshow t
1780: | t < 1000000 = Text.pack (showFFloat (Just 1) (fromIntegral t / 1000.0 :: Double) "") <> "K"
1781: | otherwise = Text.pack (showFFloat (Just 2) (fromIntegral t / 1000000.0 :: Double) "") <> "M"
1782:
1783: renderRetryContextBanner :: (Monad m) => Text -> Maybe TaskCore.RetryContext -> Lucid.HtmlT m ()
1784: renderRetryContextBanner _ Nothing = pure ()
1785: renderRetryContextBanner tid (Just ctx) =
1786: Lucid.div_ [Lucid.class_ bannerClass] <| do
1787: Lucid.div_ [Lucid.class_ "retry-banner-header"] <| do
1788: Lucid.span_ [Lucid.class_ "retry-icon"] retryIcon
1789: Lucid.span_ [Lucid.class_ "retry-attempt"] (Lucid.toHtml attemptText)
1790: when maxRetriesExceeded
1791: <| Lucid.span_ [Lucid.class_ "retry-warning-badge"] "Needs Human Intervention"
1792:
1793: Lucid.div_ [Lucid.class_ "retry-banner-details"] <| do
1794: Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do
1795: Lucid.span_ [Lucid.class_ "retry-label"] "Failure Reason:"
1796: Lucid.span_ [Lucid.class_ "retry-value"] (Lucid.toHtml (summarizeReason (TaskCore.retryReason ctx)))
1797:
1798: let commit = TaskCore.retryOriginalCommit ctx
1799: unless (Text.null commit) <| do
1800: Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do
1801: Lucid.span_ [Lucid.class_ "retry-label"] "Original Commit:"
1802: Lucid.code_ [Lucid.class_ "retry-commit"] (Lucid.toHtml (Text.take 8 commit))
1803:
1804: let conflicts = TaskCore.retryConflictFiles ctx
1805: unless (null conflicts) <| do
1806: Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do
1807: Lucid.span_ [Lucid.class_ "retry-label"] "Conflict Files:"
1808: Lucid.ul_ [Lucid.class_ "retry-conflict-list"]
1809: <| traverse_ (Lucid.li_ <. Lucid.toHtml) conflicts
1810:
1811: when maxRetriesExceeded <| do
1812: Lucid.div_
1813: [Lucid.class_ "retry-warning-message"]
1814: "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."
1815:
1816: Lucid.p_ [Lucid.class_ "retry-hint"] "Use comments below to provide guidance for retry."
1817:
1818: Lucid.div_ [Lucid.class_ "retry-reset-section"] <| do
1819: Lucid.h4_ "Reset Retries"
1820: Lucid.p_ [Lucid.class_ "notes-help"] "Clear retry context and give task a fresh start:"
1821: Lucid.form_ [Lucid.method_ "POST", Lucid.action_ ("/tasks/" <> tid <> "/reset-retries")] <| do
1822: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "reset-btn"] "Reset Retries"
1823: where
1824: attempt = TaskCore.retryAttempt ctx
1825: maxRetriesExceeded = attempt >= 3
1826: bannerClass = if maxRetriesExceeded then "retry-banner retry-banner-critical" else "retry-banner retry-banner-warning"
1827: retryIcon = if maxRetriesExceeded then "⚠" else "↻"
1828: attemptText = "Attempt " <> tshow attempt <> " of 3"
1829:
1830: summarizeReason :: Text -> Text
1831: summarizeReason reason
1832: | "rejected:" `Text.isPrefixOf` reason = "Rejected: " <> Text.strip (Text.drop 9 reason)
1833: | "Test failure:" `Text.isPrefixOf` reason = "Test failure (see details below)"
1834: | "MERGE CONFLICT" `Text.isPrefixOf` reason = "Merge conflict with concurrent changes"
1835: | otherwise = Text.take 100 reason <> if Text.length reason > 100 then "..." else ""
1836:
1837: instance Lucid.ToHtml TaskReviewPage where
1838: toHtmlRaw = Lucid.toHtml
1839: toHtml (ReviewPageNotFound tid) =
1840: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb "Review" Nothing]
1841: in Lucid.doctypehtml_ <| do
1842: pageHead "Task Not Found - Jr Review"
1843: pageBodyWithCrumbs crumbs <| do
1844: Lucid.div_ [Lucid.class_ "container"] <| do
1845: Lucid.h1_ "Task Not Found"
1846: Lucid.p_ <| do
1847: "The task "
1848: Lucid.code_ (Lucid.toHtml tid)
1849: " could not be found."
1850: toHtml (ReviewPageFound task reviewInfo) =
1851: let tid = TaskCore.taskId task
1852: crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb "Review" Nothing]
1853: in Lucid.doctypehtml_ <| do
1854: pageHead ("Review: " <> TaskCore.taskId task <> " - Jr")
1855: pageBodyWithCrumbs crumbs <| do
1856: Lucid.div_ [Lucid.class_ "container"] <| do
1857: Lucid.h1_ "Review Task"
1858:
1859: Lucid.div_ [Lucid.class_ "task-summary"] <| do
1860: Lucid.div_ [Lucid.class_ "detail-row"] <| do
1861: Lucid.span_ [Lucid.class_ "detail-label"] "ID:"
1862: Lucid.code_ [Lucid.class_ "detail-value"] (Lucid.toHtml (TaskCore.taskId task))
1863: Lucid.div_ [Lucid.class_ "detail-row"] <| do
1864: Lucid.span_ [Lucid.class_ "detail-label"] "Title:"
1865: Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (TaskCore.taskTitle task))
1866: Lucid.div_ [Lucid.class_ "detail-row"] <| do
1867: Lucid.span_ [Lucid.class_ "detail-label"] "Status:"
1868: Lucid.span_ [Lucid.class_ "detail-value"] <| statusBadge (TaskCore.taskStatus task)
1869:
1870: case reviewInfo of
1871: ReviewNoCommit ->
1872: Lucid.div_ [Lucid.class_ "no-commit-msg"] <| do
1873: Lucid.h3_ "No Commit Found"
1874: Lucid.p_ "No commit with this task ID was found in the git history."
1875: Lucid.p_ "The worker may not have completed yet, or the commit message doesn't include the task ID."
1876: ReviewMergeConflict commitSha conflictFiles ->
1877: Lucid.div_ [Lucid.class_ "conflict-warning"] <| do
1878: Lucid.h3_ "Merge Conflict Detected"
1879: Lucid.p_ <| do
1880: "Commit "
1881: Lucid.code_ (Lucid.toHtml (Text.take 8 commitSha))
1882: " cannot be cleanly merged."
1883: Lucid.p_ "Conflicting files:"
1884: Lucid.ul_ <| traverse_ (Lucid.li_ <. Lucid.toHtml) conflictFiles
1885: ReviewReady commitSha diffText -> do
1886: Lucid.div_ [Lucid.class_ "diff-section"] <| do
1887: Lucid.h3_ <| do
1888: "Commit: "
1889: Lucid.code_ (Lucid.toHtml (Text.take 8 commitSha))
1890: Lucid.pre_ [Lucid.class_ "diff-block"] (Lucid.toHtml diffText)
1891:
1892: Lucid.div_ [Lucid.class_ "review-actions"] <| do
1893: Lucid.form_
1894: [ Lucid.method_ "POST",
1895: Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/accept"),
1896: Lucid.class_ "inline-form"
1897: ]
1898: <| do
1899: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "accept-btn"] "Accept"
1900:
1901: Lucid.form_
1902: [ Lucid.method_ "POST",
1903: Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/reject"),
1904: Lucid.class_ "reject-form"
1905: ]
1906: <| do
1907: Lucid.textarea_
1908: [ Lucid.name_ "notes",
1909: Lucid.class_ "reject-notes",
1910: Lucid.placeholder_ "Rejection notes (optional)"
1911: ]
1912: ""
1913: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "reject-btn"] "Reject"
1914:
1915: instance Lucid.ToHtml TaskDiffPage where
1916: toHtmlRaw = Lucid.toHtml
1917: toHtml (DiffPageNotFound tid commitHash') =
1918: let shortHash = Text.take 8 commitHash'
1919: crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb ("Diff " <> shortHash) Nothing]
1920: in Lucid.doctypehtml_ <| do
1921: pageHead "Commit Not Found - Jr"
1922: pageBodyWithCrumbs crumbs <| do
1923: Lucid.div_ [Lucid.class_ "container"] <| do
1924: Lucid.h1_ "Commit Not Found"
1925: Lucid.p_ <| do
1926: "Could not find commit "
1927: Lucid.code_ (Lucid.toHtml commitHash')
1928: Lucid.a_ [Lucid.href_ ("/tasks/" <> tid), Lucid.class_ "back-link"] "← Back to task"
1929: toHtml (DiffPageFound tid commitHash' diffOutput) =
1930: let shortHash = Text.take 8 commitHash'
1931: crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb ("Diff " <> shortHash) Nothing]
1932: in Lucid.doctypehtml_ <| do
1933: pageHead ("Diff " <> shortHash <> " - Jr")
1934: pageBodyWithCrumbs crumbs <| do
1935: Lucid.div_ [Lucid.class_ "container"] <| do
1936: Lucid.div_ [Lucid.class_ "diff-header"] <| do
1937: Lucid.a_ [Lucid.href_ ("/tasks/" <> tid), Lucid.class_ "back-link"] "← Back to task"
1938: Lucid.h1_ <| do
1939: "Commit "
1940: Lucid.code_ (Lucid.toHtml shortHash)
1941: Lucid.pre_ [Lucid.class_ "diff-block"] (Lucid.toHtml diffOutput)
1942:
1943: instance Lucid.ToHtml StatsPage where
1944: toHtmlRaw = Lucid.toHtml
1945: toHtml (StatsPage stats maybeEpic) =
1946: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Stats" Nothing]
1947: in Lucid.doctypehtml_ <| do
1948: pageHead "Task Statistics - Jr"
1949: pageBodyWithCrumbs crumbs <| do
1950: Lucid.div_ [Lucid.class_ "container"] <| do
1951: Lucid.h1_ <| case maybeEpic of
1952: Nothing -> "Task Statistics"
1953: Just epicId -> Lucid.toHtml ("Statistics for Epic: " <> epicId)
1954:
1955: Lucid.form_ [Lucid.method_ "GET", Lucid.action_ "/stats", Lucid.class_ "filter-form"] <| do
1956: Lucid.div_ [Lucid.class_ "filter-row"] <| do
1957: Lucid.div_ [Lucid.class_ "filter-group"] <| do
1958: Lucid.label_ [Lucid.for_ "epic"] "Epic:"
1959: Lucid.input_
1960: [ Lucid.type_ "text",
1961: Lucid.name_ "epic",
1962: Lucid.id_ "epic",
1963: Lucid.class_ "filter-input",
1964: Lucid.placeholder_ "Epic ID (optional)",
1965: Lucid.value_ (fromMaybe "" maybeEpic)
1966: ]
1967: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "filter-btn"] "Filter"
1968: Lucid.a_ [Lucid.href_ "/stats", Lucid.class_ "clear-btn"] "Clear"
1969:
1970: Lucid.h2_ "By Status"
1971: multiColorProgressBar stats
1972: Lucid.div_ [Lucid.class_ "stats-grid"] <| do
1973: statCard "Open" (TaskCore.openTasks stats) (TaskCore.totalTasks stats)
1974: statCard "In Progress" (TaskCore.inProgressTasks stats) (TaskCore.totalTasks stats)
1975: statCard "Review" (TaskCore.reviewTasks stats) (TaskCore.totalTasks stats)
1976: statCard "Approved" (TaskCore.approvedTasks stats) (TaskCore.totalTasks stats)
1977: statCard "Done" (TaskCore.doneTasks stats) (TaskCore.totalTasks stats)
1978:
1979: Lucid.h2_ "By Priority"
1980: Lucid.div_ [Lucid.class_ "stats-section"] <| do
1981: traverse_ (uncurry renderPriorityRow) (TaskCore.tasksByPriority stats)
1982:
1983: Lucid.h2_ "By Namespace"
1984: Lucid.div_ [Lucid.class_ "stats-section"] <| do
1985: if null (TaskCore.tasksByNamespace stats)
1986: then Lucid.p_ [Lucid.class_ "empty-msg"] "No namespaces found."
1987: else traverse_ (uncurry (renderNamespaceRow (TaskCore.totalTasks stats))) (TaskCore.tasksByNamespace stats)
1988:
1989: Lucid.h2_ "Summary"
1990: Lucid.div_ [Lucid.class_ "summary-section"] <| do
1991: Lucid.div_ [Lucid.class_ "detail-row"] <| do
1992: Lucid.span_ [Lucid.class_ "detail-label"] "Total Tasks:"
1993: Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.totalTasks stats)))
1994: Lucid.div_ [Lucid.class_ "detail-row"] <| do
1995: Lucid.span_ [Lucid.class_ "detail-label"] "Epics:"
1996: Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.totalEpics stats)))
1997: Lucid.div_ [Lucid.class_ "detail-row"] <| do
1998: Lucid.span_ [Lucid.class_ "detail-label"] "Ready:"
1999: Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.readyTasks stats)))
2000: Lucid.div_ [Lucid.class_ "detail-row"] <| do
2001: Lucid.span_ [Lucid.class_ "detail-label"] "Blocked:"
2002: Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.blockedTasks stats)))
2003: where
2004: statCard :: (Monad m) => Text -> Int -> Int -> Lucid.HtmlT m ()
2005: statCard label count total =
2006: let pct = if total == 0 then 0 else (count * 100) `div` total
2007: in Lucid.div_ [Lucid.class_ "stat-card"] <| do
2008: Lucid.div_ [Lucid.class_ "stat-count"] (Lucid.toHtml (tshow count))
2009: Lucid.div_ [Lucid.class_ "stat-label"] (Lucid.toHtml label)
2010: Lucid.div_ [Lucid.class_ "progress-bar"] <| do
2011: Lucid.div_
2012: [ Lucid.class_ "progress-fill",
2013: Lucid.style_ ("width: " <> tshow pct <> "%")
2014: ]
2015: ""
2016:
2017: renderPriorityRow :: (Monad m) => TaskCore.Priority -> Int -> Lucid.HtmlT m ()
2018: renderPriorityRow priority count =
2019: let total = TaskCore.totalTasks stats
2020: pct = if total == 0 then 0 else (count * 100) `div` total
2021: in Lucid.div_ [Lucid.class_ "stats-row"] <| do
2022: Lucid.span_ [Lucid.class_ "stats-label"] (Lucid.toHtml (tshow priority))
2023: Lucid.div_ [Lucid.class_ "stats-bar-container"] <| do
2024: Lucid.div_ [Lucid.class_ "progress-bar"] <| do
2025: Lucid.div_
2026: [ Lucid.class_ "progress-fill",
2027: Lucid.style_ ("width: " <> tshow pct <> "%")
2028: ]
2029: ""
2030: Lucid.span_ [Lucid.class_ "stats-count"] (Lucid.toHtml (tshow count))
2031:
2032: renderNamespaceRow :: (Monad m) => Int -> Text -> Int -> Lucid.HtmlT m ()
2033: renderNamespaceRow total ns count =
2034: let pct = if total == 0 then 0 else (count * 100) `div` total
2035: in Lucid.div_ [Lucid.class_ "stats-row"] <| do
2036: Lucid.span_ [Lucid.class_ "stats-label"] (Lucid.toHtml ns)
2037: Lucid.div_ [Lucid.class_ "stats-bar-container"] <| do
2038: Lucid.div_ [Lucid.class_ "progress-bar"] <| do
2039: Lucid.div_
2040: [ Lucid.class_ "progress-fill",
2041: Lucid.style_ ("width: " <> tshow pct <> "%")
2042: ]
2043: ""
2044: Lucid.span_ [Lucid.class_ "stats-count"] (Lucid.toHtml (tshow count))
2045:
2046: instance Lucid.ToHtml RecentActivityNewPartial where
2047: toHtmlRaw = Lucid.toHtml
2048: toHtml (RecentActivityNewPartial tasks maybeNewestTs) = do
2049: traverse_ renderListGroupItem tasks
2050: case maybeNewestTs of
2051: Nothing -> pure ()
2052: Just ts ->
2053: Lucid.div_
2054: [ Lucid.id_ "recent-activity",
2055: Lucid.makeAttribute "data-newest-ts" (tshow ts),
2056: Lucid.makeAttribute "hx-swap-oob" "attributes:#recent-activity data-newest-ts"
2057: ]
2058: ""
2059:
2060: instance Lucid.ToHtml RecentActivityMorePartial where
2061: toHtmlRaw = Lucid.toHtml
2062: toHtml (RecentActivityMorePartial tasks nextOffset hasMore) = do
2063: traverse_ renderListGroupItem tasks
2064: if hasMore
2065: then
2066: Lucid.button_
2067: [ Lucid.id_ "activity-load-more",
2068: Lucid.class_ "btn btn-secondary load-more-btn",
2069: Lucid.makeAttribute "hx-get" ("/partials/recent-activity-more?offset=" <> tshow nextOffset),
2070: Lucid.makeAttribute "hx-target" "#activity-list",
2071: Lucid.makeAttribute "hx-swap" "beforeend",
2072: Lucid.makeAttribute "hx-swap-oob" "true"
2073: ]
2074: "Load More"
2075: else Lucid.span_ [Lucid.id_ "activity-load-more", Lucid.makeAttribute "hx-swap-oob" "true"] ""
2076:
2077: instance Lucid.ToHtml ReadyCountPartial where
2078: toHtmlRaw = Lucid.toHtml
2079: toHtml (ReadyCountPartial count) =
2080: Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "ready-link"]
2081: <| Lucid.toHtml ("(" <> tshow count <> " tasks)")
2082:
2083: instance Lucid.ToHtml StatusBadgePartial where
2084: toHtmlRaw = Lucid.toHtml
2085: toHtml (StatusBadgePartial status tid) =
2086: statusBadgeWithForm status tid
2087:
2088: instance Lucid.ToHtml PriorityBadgePartial where
2089: toHtmlRaw = Lucid.toHtml
2090: toHtml (PriorityBadgePartial priority tid) =
2091: priorityBadgeWithForm priority tid
2092:
2093: instance Lucid.ToHtml TaskListPartial where
2094: toHtmlRaw = Lucid.toHtml
2095: toHtml (TaskListPartial tasks) =
2096: if null tasks
2097: then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks match the current filters."
2098: else Lucid.div_ [Lucid.class_ "list-group"] <| traverse_ renderListGroupItem tasks
2099:
2100: instance Lucid.ToHtml TaskMetricsPartial where
2101: toHtmlRaw = Lucid.toHtml
2102: toHtml (TaskMetricsPartial _tid activities maybeRetry now) =
2103: let runningActs = filter (\a -> TaskCore.activityStage a == TaskCore.Running) activities
2104: in if null runningActs
2105: then Lucid.p_ [Lucid.class_ "empty-msg"] "No worker execution data available."
2106: else
2107: Lucid.div_ [Lucid.class_ "execution-details"] <| do
2108: let totalCost = sum [c | act <- runningActs, Just c <- [TaskCore.activityCostCents act]]
2109: totalDuration = sum [calcDurSecs act | act <- runningActs]
2110: attemptCount = length runningActs
2111:
2112: case maybeRetry of
2113: Nothing -> pure ()
2114: Just ctx ->
2115: Lucid.div_ [Lucid.class_ "metric-row"] <| do
2116: Lucid.span_ [Lucid.class_ "metric-label"] "Retry Attempt:"
2117: Lucid.span_ [Lucid.class_ "metric-value retry-count"] (Lucid.toHtml (tshow (TaskCore.retryAttempt ctx) <> "/3"))
2118:
2119: when (attemptCount > 1) <| do
2120: Lucid.div_ [Lucid.class_ "metric-row"] <| do
2121: Lucid.span_ [Lucid.class_ "metric-label"] "Total Attempts:"
2122: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (tshow attemptCount))
2123: Lucid.div_ [Lucid.class_ "metric-row"] <| do
2124: Lucid.span_ [Lucid.class_ "metric-label"] "Total Duration:"
2125: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDurSecs totalDuration))
2126: when (totalCost > 0)
2127: <| Lucid.div_ [Lucid.class_ "metric-row"]
2128: <| do
2129: Lucid.span_ [Lucid.class_ "metric-label"] "Total Cost:"
2130: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCost totalCost))
2131: Lucid.hr_ [Lucid.class_ "attempts-divider"]
2132:
2133: traverse_ (renderAttempt attemptCount now) (zip [1 ..] (reverse runningActs))
2134: where
2135: calcDurSecs :: TaskCore.TaskActivity -> Int
2136: calcDurSecs act = case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of
2137: (Just start, Just end) -> floor (diffUTCTime end start)
2138: _ -> 0
2139:
2140: formatDurSecs :: Int -> Text
2141: formatDurSecs secs
2142: | secs < 60 = tshow secs <> "s"
2143: | secs < 3600 = tshow (secs `div` 60) <> "m " <> tshow (secs `mod` 60) <> "s"
2144: | otherwise = tshow (secs `div` 3600) <> "h " <> tshow ((secs `mod` 3600) `div` 60) <> "m"
2145:
2146: renderAttempt :: (Monad m) => Int -> UTCTime -> (Int, TaskCore.TaskActivity) -> Lucid.HtmlT m ()
2147: renderAttempt totalAttempts currentTime (attemptNum, act) = do
2148: when (totalAttempts > 1)
2149: <| Lucid.div_ [Lucid.class_ "attempt-header"] (Lucid.toHtml ("Attempt " <> tshow attemptNum :: Text))
2150: case TaskCore.activityThreadUrl act of
2151: Nothing -> pure ()
2152: Just url ->
2153: Lucid.div_ [Lucid.class_ "metric-row"] <| do
2154: Lucid.span_ [Lucid.class_ "metric-label"] "Session:"
2155: Lucid.a_ [Lucid.href_ url, Lucid.target_ "_blank", Lucid.class_ "amp-thread-btn"] "View in Amp ↗"
2156:
2157: case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of
2158: (Just start, Just end) ->
2159: Lucid.div_ [Lucid.class_ "metric-row"] <| do
2160: Lucid.span_ [Lucid.class_ "metric-label"] "Duration:"
2161: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDuration start end))
2162: (Just start, Nothing) ->
2163: Lucid.div_ [Lucid.class_ "metric-row"] <| do
2164: Lucid.span_ [Lucid.class_ "metric-label"] "Started:"
2165: Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp currentTime start)
2166: _ -> pure ()
2167:
2168: case TaskCore.activityCostCents act of
2169: Nothing -> pure ()
2170: Just cents ->
2171: Lucid.div_ [Lucid.class_ "metric-row"] <| do
2172: Lucid.span_ [Lucid.class_ "metric-label"] "Cost:"
2173: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCost cents))
2174:
2175: Lucid.div_ [Lucid.class_ "metric-row"] <| do
2176: Lucid.span_ [Lucid.class_ "metric-label"] "Timestamp:"
2177: Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp currentTime (TaskCore.activityTimestamp act))
2178:
2179: formatDuration :: UTCTime -> UTCTime -> Text
2180: formatDuration start end =
2181: let diffSecs = floor (diffUTCTime end start) :: Int
2182: mins = diffSecs `div` 60
2183: secs = diffSecs `mod` 60
2184: in if mins > 0
2185: then tshow mins <> "m " <> tshow secs <> "s"
2186: else tshow secs <> "s"
2187:
2188: formatCost :: Int -> Text
2189: formatCost cents =
2190: let dollars = fromIntegral cents / 100.0 :: Double
2191: in "$" <> Text.pack (showFFloat (Just 2) dollars "")
2192:
2193: instance Lucid.ToHtml DescriptionViewPartial where
2194: toHtmlRaw = Lucid.toHtml
2195: toHtml (DescriptionViewPartial tid desc isEpic) =
2196: Lucid.div_ [Lucid.id_ "description-block", Lucid.class_ "description-block"] <| do
2197: Lucid.div_ [Lucid.class_ "description-header"] <| do
2198: Lucid.h3_ (if isEpic then "Design" else "Description")
2199: Lucid.a_
2200: [ Lucid.href_ "#",
2201: Lucid.class_ "edit-link",
2202: Lucid.makeAttribute "hx-get" ("/tasks/" <> tid <> "/description/edit"),
2203: Lucid.makeAttribute "hx-target" "#description-block",
2204: Lucid.makeAttribute "hx-swap" "outerHTML"
2205: ]
2206: "Edit"
2207: if Text.null desc
2208: then Lucid.p_ [Lucid.class_ "empty-msg"] (if isEpic then "No design document yet." else "No description yet.")
2209: else Lucid.div_ [Lucid.class_ "markdown-content"] (renderMarkdown desc)
2210:
2211: instance Lucid.ToHtml DescriptionEditPartial where
2212: toHtmlRaw = Lucid.toHtml
2213: toHtml (DescriptionEditPartial tid desc isEpic) =
2214: Lucid.div_ [Lucid.id_ "description-block", Lucid.class_ "description-block editing"] <| do
2215: Lucid.div_ [Lucid.class_ "description-header"] <| do
2216: Lucid.h3_ (if isEpic then "Design" else "Description")
2217: Lucid.button_
2218: [ Lucid.type_ "button",
2219: Lucid.class_ "cancel-link",
2220: Lucid.makeAttribute "hx-get" ("/tasks/" <> tid <> "/description/view"),
2221: Lucid.makeAttribute "hx-target" "#description-block",
2222: Lucid.makeAttribute "hx-swap" "outerHTML",
2223: Lucid.makeAttribute "hx-confirm" "Discard changes?"
2224: ]
2225: "Cancel"
2226: Lucid.form_
2227: [ Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/description"),
2228: Lucid.makeAttribute "hx-target" "#description-block",
2229: Lucid.makeAttribute "hx-swap" "outerHTML"
2230: ]
2231: <| do
2232: Lucid.textarea_
2233: [ Lucid.name_ "description",
2234: Lucid.class_ "description-textarea",
2235: Lucid.rows_ (if isEpic then "15" else "10"),
2236: Lucid.placeholder_ (if isEpic then "Enter design in Markdown..." else "Enter description...")
2237: ]
2238: (Lucid.toHtml desc)
2239: Lucid.div_ [Lucid.class_ "form-actions"] <| do
2240: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Save"
2241:
2242: -- | Simple markdown renderer for epic descriptions
2243: -- Supports: headers (#, ##, ###), lists (- or *), code blocks (```), inline code (`)
2244: renderMarkdown :: (Monad m) => Text -> Lucid.HtmlT m ()
2245: renderMarkdown input = renderBlocks (parseBlocks (Text.lines input))
2246:
2247: data MarkdownBlock
2248: = MdHeader Int Text
2249: | MdParagraph [Text]
2250: | MdCodeBlock [Text]
2251: | MdList [Text]
2252: deriving (Show, Eq)
2253:
2254: parseBlocks :: [Text] -> [MarkdownBlock]
2255: parseBlocks [] = []
2256: parseBlocks lns = case lns of
2257: (l : rest)
2258: | "```" `Text.isPrefixOf` l ->
2259: let (codeLines, afterCode) = List.span (not <. Text.isPrefixOf "```") rest
2260: remaining = List.drop 1 afterCode
2261: in MdCodeBlock codeLines : parseBlocks remaining
2262: | "### " `Text.isPrefixOf` l ->
2263: MdHeader 3 (Text.drop 4 l) : parseBlocks rest
2264: | "## " `Text.isPrefixOf` l ->
2265: MdHeader 2 (Text.drop 3 l) : parseBlocks rest
2266: | "# " `Text.isPrefixOf` l ->
2267: MdHeader 1 (Text.drop 2 l) : parseBlocks rest
2268: | isListItem l ->
2269: let (listLines, afterList) = List.span isListItem lns
2270: in MdList (map stripListPrefix listLines) : parseBlocks afterList
2271: | Text.null (Text.strip l) ->
2272: parseBlocks rest
2273: | otherwise ->
2274: let (paraLines, afterPara) = List.span isParagraphLine lns
2275: in MdParagraph paraLines : parseBlocks afterPara
2276: where
2277: isListItem t =
2278: let stripped = Text.stripStart t
2279: in "- " `Text.isPrefixOf` stripped || "* " `Text.isPrefixOf` stripped
2280: stripListPrefix t =
2281: let stripped = Text.stripStart t
2282: in Text.drop 2 stripped
2283: isParagraphLine t =
2284: not (Text.null (Text.strip t))
2285: && not ("```" `Text.isPrefixOf` t)
2286: && not ("#" `Text.isPrefixOf` t)
2287: && not (isListItem t)
2288:
2289: renderBlocks :: (Monad m) => [MarkdownBlock] -> Lucid.HtmlT m ()
2290: renderBlocks = traverse_ renderBlock
2291:
2292: renderBlock :: (Monad m) => MarkdownBlock -> Lucid.HtmlT m ()
2293: renderBlock block = case block of
2294: MdHeader 1 txt -> Lucid.h2_ [Lucid.class_ "md-h1"] (renderInline txt)
2295: MdHeader 2 txt -> Lucid.h3_ [Lucid.class_ "md-h2"] (renderInline txt)
2296: MdHeader 3 txt -> Lucid.h4_ [Lucid.class_ "md-h3"] (renderInline txt)
2297: MdHeader _ txt -> Lucid.h4_ (renderInline txt)
2298: MdParagraph lns -> Lucid.p_ [Lucid.class_ "md-para"] (renderInline (Text.unlines lns))
2299: MdCodeBlock lns -> Lucid.pre_ [Lucid.class_ "md-code"] (Lucid.code_ (Lucid.toHtml (Text.unlines lns)))
2300: MdList items -> Lucid.ul_ [Lucid.class_ "md-list"] (traverse_ renderListItem items)
2301:
2302: renderListItem :: (Monad m) => Text -> Lucid.HtmlT m ()
2303: renderListItem txt = Lucid.li_ (renderInline txt)
2304:
2305: -- | Render inline markdown (backtick code, bold, italic)
2306: renderInline :: (Monad m) => Text -> Lucid.HtmlT m ()
2307: renderInline txt = renderInlineParts (parseInline txt)
2308:
2309: data InlinePart = PlainText Text | InlineCode Text | BoldText Text
2310: deriving (Show, Eq)
2311:
2312: parseInline :: Text -> [InlinePart]
2313: parseInline t
2314: | Text.null t = []
2315: | otherwise = case Text.breakOn "`" t of
2316: (before, rest)
2317: | Text.null rest -> parseBold before
2318: | otherwise ->
2319: let afterTick = Text.drop 1 rest
2320: in case Text.breakOn "`" afterTick of
2321: (code, rest2)
2322: | Text.null rest2 ->
2323: parseBold before ++ [PlainText ("`" <> afterTick)]
2324: | otherwise ->
2325: parseBold before ++ [InlineCode code] ++ parseInline (Text.drop 1 rest2)
2326:
2327: parseBold :: Text -> [InlinePart]
2328: parseBold t
2329: | Text.null t = []
2330: | otherwise = case Text.breakOn "**" t of
2331: (before, rest)
2332: | Text.null rest -> [PlainText before | not (Text.null before)]
2333: | otherwise ->
2334: let afterBold = Text.drop 2 rest
2335: in case Text.breakOn "**" afterBold of
2336: (boldText, rest2)
2337: | Text.null rest2 ->
2338: [PlainText before | not (Text.null before)] ++ [PlainText ("**" <> afterBold)]
2339: | otherwise ->
2340: [PlainText before | not (Text.null before)]
2341: ++ [BoldText boldText]
2342: ++ parseBold (Text.drop 2 rest2)
2343:
2344: renderInlineParts :: (Monad m) => [InlinePart] -> Lucid.HtmlT m ()
2345: renderInlineParts = traverse_ renderInlinePart
2346:
2347: renderInlinePart :: (Monad m) => InlinePart -> Lucid.HtmlT m ()
2348: renderInlinePart part = case part of
2349: PlainText txt -> Lucid.toHtml txt
2350: InlineCode txt -> Lucid.code_ [Lucid.class_ "md-inline-code"] (Lucid.toHtml txt)
2351: BoldText txt -> Lucid.strong_ (Lucid.toHtml txt)
2352:
2353: -- | Comment form for adding new comments
2354: commentForm :: (Monad m) => Text -> Lucid.HtmlT m ()
2355: commentForm tid =
2356: Lucid.form_
2357: [ Lucid.method_ "POST",
2358: Lucid.action_ ("/tasks/" <> tid <> "/comment"),
2359: Lucid.class_ "comment-form"
2360: ]
2361: <| do
2362: Lucid.textarea_
2363: [ Lucid.name_ "comment",
2364: Lucid.placeholder_ "Add a comment...",
2365: Lucid.rows_ "3",
2366: Lucid.class_ "comment-textarea"
2367: ]
2368: ""
2369: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Post Comment"
2370:
2371: -- | Unified timeline view combining comments, status changes, and agent events
2372: renderUnifiedTimeline :: (Monad m) => Text -> [TaskCore.Comment] -> [TaskCore.StoredEvent] -> TaskCore.Status -> UTCTime -> Lucid.HtmlT m ()
2373: renderUnifiedTimeline tid legacyComments events status now = do
2374: let isInProgress = status == TaskCore.InProgress
2375: pollAttrs =
2376: if isInProgress
2377: then
2378: [ Lucid.makeAttribute "hx-get" ("/partials/task/" <> tid <> "/events"),
2379: Lucid.makeAttribute "hx-trigger" "every 3s",
2380: Lucid.makeAttribute "hx-swap" "innerHTML",
2381: Lucid.makeAttribute "hx-on::before-request" "var log = this.querySelector('.timeline-events'); if(log) this.dataset.scroll = log.scrollTop",
2382: Lucid.makeAttribute "hx-on::after-swap" "var log = this.querySelector('.timeline-events'); if(log && this.dataset.scroll) log.scrollTop = this.dataset.scroll"
2383: ]
2384: else []
2385: Lucid.div_ ([Lucid.class_ "unified-timeline-section", Lucid.id_ "unified-timeline"] <> pollAttrs) <| do
2386: Lucid.h3_ <| do
2387: Lucid.toHtml ("Timeline (" <> tshow (length events + length legacyComments) <> ")")
2388: when isInProgress <| Lucid.span_ [Lucid.class_ "timeline-live"] " LIVE"
2389:
2390: if null events && null legacyComments
2391: then Lucid.p_ [Lucid.class_ "empty-msg"] "No activity yet."
2392: else do
2393: Lucid.div_ [Lucid.class_ "timeline-events"] <| do
2394: traverse_ (renderTimelineEvent now) events
2395: when isInProgress <| timelineScrollScript
2396:
2397: commentForm tid
2398:
2399: -- | Render a single timeline event with icon, actor label, and timestamp
2400: renderTimelineEvent :: (Monad m) => UTCTime -> TaskCore.StoredEvent -> Lucid.HtmlT m ()
2401: renderTimelineEvent now event =
2402: let eventType = TaskCore.storedEventType event
2403: content = TaskCore.storedEventContent event
2404: timestamp = TaskCore.storedEventTimestamp event
2405: actor = TaskCore.storedEventActor event
2406: eventId = TaskCore.storedEventId event
2407: (icon, label) = eventTypeIconAndLabel eventType
2408: in Lucid.div_
2409: [ Lucid.class_ ("timeline-event timeline-event-" <> eventType),
2410: Lucid.makeAttribute "data-event-id" (tshow eventId)
2411: ]
2412: <| do
2413: case eventType of
2414: "comment" -> renderCommentTimelineEvent content actor timestamp now
2415: "status_change" -> renderStatusChangeEvent content actor timestamp now
2416: "claim" -> renderActivityEvent icon label content actor timestamp now
2417: "running" -> renderActivityEvent icon label content actor timestamp now
2418: "reviewing" -> renderActivityEvent icon label content actor timestamp now
2419: "retrying" -> renderActivityEvent icon label content actor timestamp now
2420: "complete" -> renderActivityEvent icon label content actor timestamp now
2421: "error" -> renderErrorTimelineEvent content actor timestamp now
2422: "Assistant" -> renderAssistantTimelineEvent content actor timestamp now
2423: "ToolCall" -> renderToolCallTimelineEvent content actor timestamp now
2424: "ToolResult" -> renderToolResultTimelineEvent content actor timestamp now
2425: "Cost" -> renderCostTimelineEvent content
2426: "Checkpoint" -> renderCheckpointEvent content actor timestamp now
2427: "Guardrail" -> renderGuardrailEvent content actor timestamp now
2428: _ -> renderGenericEvent eventType content actor timestamp now
2429:
2430: -- | Get icon and label for event type
2431: eventTypeIconAndLabel :: Text -> (Text, Text)
2432: eventTypeIconAndLabel "comment" = ("💬", "Comment")
2433: eventTypeIconAndLabel "status_change" = ("🔄", "Status")
2434: eventTypeIconAndLabel "claim" = ("🤖", "Claimed")
2435: eventTypeIconAndLabel "running" = ("▶️", "Running")
2436: eventTypeIconAndLabel "reviewing" = ("👀", "Reviewing")
2437: eventTypeIconAndLabel "retrying" = ("🔁", "Retrying")
2438: eventTypeIconAndLabel "complete" = ("✅", "Complete")
2439: eventTypeIconAndLabel "error" = ("❌", "Error")
2440: eventTypeIconAndLabel "Assistant" = ("💭", "Thought")
2441: eventTypeIconAndLabel "ToolCall" = ("🔧", "Tool")
2442: eventTypeIconAndLabel "ToolResult" = ("📄", "Result")
2443: eventTypeIconAndLabel "Cost" = ("💰", "Cost")
2444: eventTypeIconAndLabel "Checkpoint" = ("📍", "Checkpoint")
2445: eventTypeIconAndLabel "Guardrail" = ("⚠️", "Guardrail")
2446: eventTypeIconAndLabel t = ("📝", t)
2447:
2448: -- | Render actor label
2449: renderActorLabel :: (Monad m) => TaskCore.CommentAuthor -> Lucid.HtmlT m ()
2450: renderActorLabel actor =
2451: let (cls, label) :: (Text, Text) = case actor of
2452: TaskCore.Human -> ("actor-human", "human")
2453: TaskCore.Junior -> ("actor-junior", "junior")
2454: TaskCore.System -> ("actor-system", "system")
2455: in Lucid.span_ [Lucid.class_ ("actor-label " <> cls)] (Lucid.toHtml ("[" <> label <> "]"))
2456:
2457: -- | Render comment event
2458: renderCommentTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2459: renderCommentTimelineEvent content actor timestamp now =
2460: Lucid.div_ [Lucid.class_ "timeline-comment"] <| do
2461: Lucid.div_ [Lucid.class_ "event-header"] <| do
2462: Lucid.span_ [Lucid.class_ "event-icon"] "💬"
2463: renderActorLabel actor
2464: renderRelativeTimestamp now timestamp
2465: Lucid.div_ [Lucid.class_ "event-content comment-bubble markdown-content"] <| do
2466: renderMarkdown content
2467:
2468: -- | Render status change event
2469: renderStatusChangeEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2470: renderStatusChangeEvent content actor timestamp now =
2471: Lucid.div_ [Lucid.class_ "timeline-status-change"] <| do
2472: Lucid.span_ [Lucid.class_ "event-icon"] "🔄"
2473: renderActorLabel actor
2474: Lucid.span_ [Lucid.class_ "status-change-text"] (Lucid.toHtml (parseStatusChange content))
2475: renderRelativeTimestamp now timestamp
2476:
2477: -- | Parse status change JSON
2478: parseStatusChange :: Text -> Text
2479: parseStatusChange content =
2480: case Aeson.decode (LBS.fromStrict (str content)) of
2481: Just (Aeson.Object obj) ->
2482: let fromStatus = case KeyMap.lookup "from" obj of
2483: Just (Aeson.String s) -> s
2484: _ -> "?"
2485: toStatus = case KeyMap.lookup "to" obj of
2486: Just (Aeson.String s) -> s
2487: _ -> "?"
2488: in fromStatus <> " → " <> toStatus
2489: _ -> content
2490:
2491: -- | Render activity event (claim, running, etc.)
2492: renderActivityEvent :: (Monad m) => Text -> Text -> Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2493: renderActivityEvent icon label content actor timestamp now =
2494: Lucid.div_ [Lucid.class_ "timeline-activity"] <| do
2495: Lucid.span_ [Lucid.class_ "event-icon"] (Lucid.toHtml icon)
2496: Lucid.span_ [Lucid.class_ "event-label"] (Lucid.toHtml label)
2497: renderActorLabel actor
2498: unless (Text.null content) <| Lucid.span_ [Lucid.class_ "activity-detail"] (Lucid.toHtml content)
2499: renderRelativeTimestamp now timestamp
2500:
2501: -- | Render error event
2502: renderErrorTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2503: renderErrorTimelineEvent content actor timestamp now =
2504: Lucid.div_ [Lucid.class_ "timeline-error"] <| do
2505: Lucid.div_ [Lucid.class_ "event-header"] <| do
2506: Lucid.span_ [Lucid.class_ "event-icon"] "❌"
2507: Lucid.span_ [Lucid.class_ "event-label"] "Error"
2508: renderActorLabel actor
2509: renderRelativeTimestamp now timestamp
2510: Lucid.div_ [Lucid.class_ "event-content error-message"] (Lucid.toHtml content)
2511:
2512: -- | Render assistant thought event
2513: renderAssistantTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2514: renderAssistantTimelineEvent content _actor timestamp now =
2515: Lucid.div_ [Lucid.class_ "timeline-thought"] <| do
2516: Lucid.div_ [Lucid.class_ "event-header"] <| do
2517: Lucid.span_ [Lucid.class_ "event-icon"] "💭"
2518: Lucid.span_ [Lucid.class_ "event-label"] "Thought"
2519: renderActorLabel TaskCore.Junior
2520: renderRelativeTimestamp now timestamp
2521: Lucid.div_ [Lucid.class_ "event-content thought-bubble markdown-content"] <| do
2522: let truncated = Text.take 2000 content
2523: isTruncated = Text.length content > 2000
2524: renderMarkdown truncated
2525: when isTruncated <| Lucid.span_ [Lucid.class_ "event-truncated"] "..."
2526:
2527: -- | Render tool call event
2528: renderToolCallTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2529: renderToolCallTimelineEvent content _actor timestamp now =
2530: let (toolName, args) = parseToolCallContent content
2531: in Lucid.details_ [Lucid.class_ "timeline-tool-call"] <| do
2532: Lucid.summary_ <| do
2533: Lucid.span_ [Lucid.class_ "event-icon"] "🔧"
2534: Lucid.span_ [Lucid.class_ "tool-name"] (Lucid.toHtml toolName)
2535: renderActorLabel TaskCore.Junior
2536: renderRelativeTimestamp now timestamp
2537: Lucid.div_ [Lucid.class_ "event-content tool-args"] <| do
2538: renderCollapsibleOutput args
2539:
2540: -- | Render tool result event (collapsed by default)
2541: renderToolResultTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2542: renderToolResultTimelineEvent content _actor timestamp now =
2543: let lineCount = length (Text.lines content)
2544: in Lucid.details_ [Lucid.class_ "timeline-tool-result"] <| do
2545: Lucid.summary_ <| do
2546: Lucid.span_ [Lucid.class_ "event-icon"] "📄"
2547: Lucid.span_ [Lucid.class_ "event-label"] "Result"
2548: when (lineCount > 1)
2549: <| Lucid.span_ [Lucid.class_ "line-count"] (Lucid.toHtml (tshow lineCount <> " lines"))
2550: renderRelativeTimestamp now timestamp
2551: Lucid.pre_ [Lucid.class_ "event-content tool-output"] (renderDecodedToolResult content)
2552:
2553: -- | Render cost event (inline)
2554: renderCostTimelineEvent :: (Monad m) => Text -> Lucid.HtmlT m ()
2555: renderCostTimelineEvent content =
2556: Lucid.div_ [Lucid.class_ "timeline-cost"] <| do
2557: Lucid.span_ [Lucid.class_ "event-icon"] "💰"
2558: Lucid.span_ [Lucid.class_ "cost-text"] (Lucid.toHtml content)
2559:
2560: -- | Render checkpoint event
2561: renderCheckpointEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2562: renderCheckpointEvent content actor timestamp now =
2563: Lucid.div_ [Lucid.class_ "timeline-checkpoint"] <| do
2564: Lucid.div_ [Lucid.class_ "event-header"] <| do
2565: Lucid.span_ [Lucid.class_ "event-icon"] "📍"
2566: Lucid.span_ [Lucid.class_ "event-label"] "Checkpoint"
2567: renderActorLabel actor
2568: renderRelativeTimestamp now timestamp
2569: Lucid.div_ [Lucid.class_ "event-content checkpoint-content"] (Lucid.toHtml content)
2570:
2571: -- | Render guardrail event
2572: renderGuardrailEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2573: renderGuardrailEvent content actor timestamp now =
2574: Lucid.div_ [Lucid.class_ "timeline-guardrail"] <| do
2575: Lucid.div_ [Lucid.class_ "event-header"] <| do
2576: Lucid.span_ [Lucid.class_ "event-icon"] "⚠️"
2577: Lucid.span_ [Lucid.class_ "event-label"] "Guardrail"
2578: renderActorLabel actor
2579: renderRelativeTimestamp now timestamp
2580: Lucid.div_ [Lucid.class_ "event-content guardrail-content"] (Lucid.toHtml content)
2581:
2582: -- | Render generic/unknown event
2583: renderGenericEvent :: (Monad m) => Text -> Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2584: renderGenericEvent eventType content actor timestamp now =
2585: Lucid.div_ [Lucid.class_ "timeline-generic"] <| do
2586: Lucid.div_ [Lucid.class_ "event-header"] <| do
2587: Lucid.span_ [Lucid.class_ "event-icon"] "📝"
2588: Lucid.span_ [Lucid.class_ "event-label"] (Lucid.toHtml eventType)
2589: renderActorLabel actor
2590: renderRelativeTimestamp now timestamp
2591: unless (Text.null content) <| Lucid.div_ [Lucid.class_ "event-content"] (Lucid.toHtml content)
2592:
2593: parseToolCallContent :: Text -> (Text, Text)
2594: parseToolCallContent content =
2595: case Text.breakOn ":" content of
2596: (name, rest)
2597: | Text.null rest -> (content, "")
2598: | otherwise -> (Text.strip name, Text.strip (Text.drop 1 rest))
2599:
2600: renderCollapsibleOutput :: (Monad m) => Text -> Lucid.HtmlT m ()
2601: renderCollapsibleOutput content =
2602: let lineCount = length (Text.lines content)
2603: in if lineCount > 20
2604: then
2605: Lucid.details_ [Lucid.class_ "output-collapsible"] <| do
2606: Lucid.summary_ (Lucid.toHtml (tshow lineCount <> " lines"))
2607: Lucid.pre_ [Lucid.class_ "tool-output-pre"] (Lucid.toHtml content)
2608: else Lucid.pre_ [Lucid.class_ "tool-output-pre"] (Lucid.toHtml content)
2609:
2610: -- | Decode JSON tool result and render in a user-friendly way
2611: renderDecodedToolResult :: (Monad m) => Text -> Lucid.HtmlT m ()
2612: renderDecodedToolResult content =
2613: case Aeson.decode (LBS.fromStrict (str content)) of
2614: Just (Aeson.Object obj) ->
2615: case KeyMap.lookup "output" obj of
2616: Just (Aeson.String output) -> Lucid.toHtml output
2617: _ -> Lucid.toHtml content -- Fallback to raw if no output field
2618: _ -> Lucid.toHtml content -- Fallback to raw if not JSON
2619:
2620: timelineScrollScript :: (Monad m) => Lucid.HtmlT m ()
2621: timelineScrollScript =
2622: Lucid.script_
2623: [ Lucid.type_ "text/javascript"
2624: ]
2625: ( Text.unlines
2626: [ "(function() {",
2627: " var log = document.querySelector('.timeline-events');",
2628: " if (log) {",
2629: " var isNearBottom = log.scrollHeight - log.scrollTop - log.clientHeight < 100;",
2630: " if (isNearBottom) {",
2631: " log.scrollTop = log.scrollHeight;",
2632: " }",
2633: " }",
2634: "})();"
2635: ]
2636: )
2637:
2638: instance Lucid.ToHtml AgentEventsPartial where
2639: toHtmlRaw = Lucid.toHtml
2640: toHtml (AgentEventsPartial events isInProgress now) = do
2641: Lucid.h3_ <| do
2642: Lucid.toHtml ("Timeline (" <> tshow (length events) <> ")")
2643: when isInProgress <| Lucid.span_ [Lucid.class_ "timeline-live"] " LIVE"
2644: if null events
2645: then Lucid.p_ [Lucid.class_ "empty-msg"] "No activity yet."
2646: else do
2647: Lucid.div_ [Lucid.class_ "timeline-events"] <| do
2648: traverse_ (renderTimelineEvent now) events
2649: timelineScrollScript
2650:
2651: -- | Stream agent events as SSE
2652: streamAgentEvents :: Text -> Text -> IO (SourceIO ByteString)
2653: streamAgentEvents tid sid = do
2654: -- Get existing events first
2655: existingEvents <- TaskCore.getEventsForSession sid
2656: let lastId = if null existingEvents then 0 else maximum (map TaskCore.storedEventId existingEvents)
2657:
2658: -- Convert existing events to SSE format
2659: let existingSSE = map eventToSSE existingEvents
2660:
2661: -- Create a streaming source that sends existing events, then polls for new ones
2662: pure <| Source.fromStepT <| streamEventsStep tid sid lastId existingSSE True
2663:
2664: -- | Step function for streaming events
2665: streamEventsStep :: Text -> Text -> Int -> [ByteString] -> Bool -> Source.StepT IO ByteString
2666: streamEventsStep tid sid lastId buffer sendExisting = case (sendExisting, buffer) of
2667: -- Send buffered existing events first
2668: (True, b : bs) -> Source.Yield b (streamEventsStep tid sid lastId bs True)
2669: (True, []) -> streamEventsStep tid sid lastId [] False
2670: -- Poll for new events
2671: (False, _) ->
2672: Source.Effect <| do
2673: -- Check if task is still in progress
2674: tasks <- TaskCore.loadTasks
2675: let isComplete = case TaskCore.findTask tid tasks of
2676: Nothing -> True
2677: Just task -> TaskCore.taskStatus task /= TaskCore.InProgress
2678:
2679: if isComplete
2680: then do
2681: -- Send complete event and stop
2682: let completeSSE = formatSSE "complete" "{}"
2683: pure <| Source.Yield completeSSE Source.Stop
2684: else do
2685: -- Poll for new events
2686: Concurrent.threadDelay 500000 -- 500ms
2687: newEvents <- TaskCore.getEventsSince sid lastId
2688: if null newEvents
2689: then pure <| streamEventsStep tid sid lastId [] False
2690: else do
2691: let newLastId = maximum (map TaskCore.storedEventId newEvents)
2692: let newSSE = map eventToSSE newEvents
2693: case newSSE of
2694: (e : es) -> pure <| Source.Yield e (streamEventsStep tid sid newLastId es False)
2695: [] -> pure <| streamEventsStep tid sid newLastId [] False
2696:
2697: -- | Convert a StoredEvent to SSE format
2698: eventToSSE :: TaskCore.StoredEvent -> ByteString
2699: eventToSSE event =
2700: let eventType = Text.toLower (TaskCore.storedEventType event)
2701: content = TaskCore.storedEventContent event
2702: jsonData = case eventType of
2703: "assistant" -> Aeson.object ["content" Aeson..= content]
2704: "toolcall" ->
2705: let (tool, args) = parseToolCallContent content
2706: in Aeson.object ["tool" Aeson..= tool, "args" Aeson..= Aeson.object ["data" Aeson..= args]]
2707: "toolresult" ->
2708: Aeson.object ["tool" Aeson..= ("unknown" :: Text), "success" Aeson..= True, "output" Aeson..= content]
2709: "cost" -> Aeson.object ["cost" Aeson..= content]
2710: "error" -> Aeson.object ["error" Aeson..= content]
2711: "complete" -> Aeson.object []
2712: _ -> Aeson.object ["content" Aeson..= content]
2713: in formatSSE eventType (str (Aeson.encode jsonData))
2714:
2715: -- | Format an SSE message
2716: formatSSE :: Text -> ByteString -> ByteString
2717: formatSSE eventType jsonData =
2718: str
2719: <| "event: "
2720: <> eventType
2721: <> "\n"
2722: <> "data: "
2723: <> str jsonData
2724: <> "\n\n"
2725:
2726: api :: Proxy API
2727: api = Proxy
2728:
2729: server :: Server API
2730: server =
2731: homeHandler
2732: :<|> styleHandler
2733: :<|> readyQueueHandler
2734: :<|> blockedHandler
2735: :<|> interventionHandler
2736: :<|> statsHandler
2737: :<|> taskListHandler
2738: :<|> kbHandler
2739: :<|> factCreateHandler
2740: :<|> factDetailHandler
2741: :<|> factEditHandler
2742: :<|> factDeleteHandler
2743: :<|> epicsHandler
2744: :<|> taskDetailHandler
2745: :<|> taskStatusHandler
2746: :<|> taskPriorityHandler
2747: :<|> descriptionViewHandler
2748: :<|> descriptionEditHandler
2749: :<|> descriptionPostHandler
2750: :<|> taskNotesHandler
2751: :<|> taskCommentHandler
2752: :<|> taskReviewHandler
2753: :<|> taskDiffHandler
2754: :<|> taskAcceptHandler
2755: :<|> taskRejectHandler
2756: :<|> taskResetRetriesHandler
2757: :<|> recentActivityNewHandler
2758: :<|> recentActivityMoreHandler
2759: :<|> readyCountHandler
2760: :<|> taskListPartialHandler
2761: :<|> taskMetricsPartialHandler
2762: :<|> agentEventsPartialHandler
2763: :<|> taskEventsStreamHandler
2764: where
2765: styleHandler :: Servant.Handler LazyText.Text
2766: styleHandler = pure Style.css
2767:
2768: homeHandler :: Maybe Text -> Servant.Handler HomePage
2769: homeHandler maybeRangeText = do
2770: now <- liftIO getCurrentTime
2771: let range = parseTimeRange maybeRangeText
2772: maybeStart = getTimeRangeStart range now
2773: allTasks <- liftIO TaskCore.loadTasks
2774: let filteredTasks = case maybeStart of
2775: Nothing -> allTasks
2776: Just start -> [t | t <- allTasks, TaskCore.taskUpdatedAt t >= start]
2777: stats = TaskCore.computeTaskStatsFromList filteredTasks
2778: readyTasks <- liftIO TaskCore.getReadyTasks
2779: allActivities <- liftIO <| concat </ traverse (TaskCore.getActivitiesForTask <. TaskCore.taskId) allTasks
2780: let filteredActivities = case maybeStart of
2781: Nothing -> allActivities
2782: Just start -> [a | a <- allActivities, TaskCore.activityTimestamp a >= start]
2783: globalMetrics = computeMetricsFromActivities filteredTasks filteredActivities
2784: sortedTasks = List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) filteredTasks
2785: recentTasks = take 5 sortedTasks
2786: hasMoreRecent = length filteredTasks > 5
2787: pure (HomePage stats readyTasks recentTasks hasMoreRecent globalMetrics range now)
2788:
2789: readyQueueHandler :: Maybe Text -> Servant.Handler ReadyQueuePage
2790: readyQueueHandler maybeSortText = do
2791: now <- liftIO getCurrentTime
2792: readyTasks <- liftIO TaskCore.getReadyTasks
2793: let sortOrder = parseSortOrder maybeSortText
2794: sortedTasks = sortTasks sortOrder readyTasks
2795: pure (ReadyQueuePage sortedTasks sortOrder now)
2796:
2797: blockedHandler :: Maybe Text -> Servant.Handler BlockedPage
2798: blockedHandler maybeSortText = do
2799: now <- liftIO getCurrentTime
2800: blockedTasks <- liftIO TaskCore.getBlockedTasks
2801: allTasks <- liftIO TaskCore.loadTasks
2802: let sortOrder = parseSortOrder maybeSortText
2803: tasksWithImpact = [(t, TaskCore.getBlockingImpact allTasks t) | t <- blockedTasks]
2804: sorted = List.sortBy (comparing (Down <. snd)) tasksWithImpact
2805: pure (BlockedPage sorted sortOrder now)
2806:
2807: interventionHandler :: Maybe Text -> Servant.Handler InterventionPage
2808: interventionHandler maybeSortText = do
2809: now <- liftIO getCurrentTime
2810: actionItems <- liftIO TaskCore.getHumanActionItems
2811: let sortOrder = parseSortOrder maybeSortText
2812: pure (InterventionPage actionItems sortOrder now)
2813:
2814: statsHandler :: Maybe Text -> Servant.Handler StatsPage
2815: statsHandler maybeEpic = do
2816: let epicId = emptyToNothing maybeEpic
2817: stats <- liftIO <| TaskCore.getTaskStats epicId
2818: pure (StatsPage stats epicId)
2819:
2820: taskListHandler :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Servant.Handler TaskListPage
2821: taskListHandler maybeStatusText maybePriorityText maybeNamespace maybeTypeText maybeSortText = do
2822: now <- liftIO getCurrentTime
2823: allTasks <- liftIO TaskCore.loadTasks
2824: let maybeStatus = parseStatus =<< emptyToNothing maybeStatusText
2825: maybePriority = parsePriority =<< emptyToNothing maybePriorityText
2826: maybeType = parseTaskType =<< emptyToNothing maybeTypeText
2827: filters = TaskFilters maybeStatus maybePriority (emptyToNothing maybeNamespace) maybeType
2828: sortOrder = parseSortOrder maybeSortText
2829: filteredTasks = sortTasks sortOrder (applyFilters filters allTasks)
2830: pure (TaskListPage filteredTasks filters sortOrder now)
2831:
2832: kbHandler :: Servant.Handler KBPage
2833: kbHandler = do
2834: facts <- liftIO Fact.getAllFacts
2835: pure (KBPage facts)
2836:
2837: factCreateHandler :: FactCreateForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
2838: factCreateHandler (FactCreateForm project content filesText confText) = do
2839: let files = filter (not <. Text.null) (Text.splitOn "," (Text.strip filesText))
2840: confidence = fromMaybe 0.8 (readMaybe (Text.unpack confText))
2841: fid <- liftIO (Fact.createFact project content files Nothing confidence)
2842: pure <| addHeader ("/kb/" <> tshow fid) NoContent
2843:
2844: factDetailHandler :: Int -> Servant.Handler FactDetailPage
2845: factDetailHandler fid = do
2846: now <- liftIO getCurrentTime
2847: maybeFact <- liftIO (Fact.getFact fid)
2848: case maybeFact of
2849: Nothing -> pure (FactDetailNotFound fid)
2850: Just fact -> pure (FactDetailFound fact now)
2851:
2852: factEditHandler :: Int -> FactEditForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
2853: factEditHandler fid (FactEditForm content filesText confText) = do
2854: let files = filter (not <. Text.null) (Text.splitOn "," (Text.strip filesText))
2855: confidence = fromMaybe 0.8 (readMaybe (Text.unpack confText))
2856: liftIO (Fact.updateFact fid content files confidence)
2857: pure <| addHeader ("/kb/" <> tshow fid) NoContent
2858:
2859: factDeleteHandler :: Int -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
2860: factDeleteHandler fid = do
2861: liftIO (Fact.deleteFact fid)
2862: pure <| addHeader "/kb" NoContent
2863:
2864: epicsHandler :: Maybe Text -> Servant.Handler EpicsPage
2865: epicsHandler maybeSortText = do
2866: allTasks <- liftIO TaskCore.loadTasks
2867: let epicTasks = filter (\t -> TaskCore.taskType t == TaskCore.Epic) allTasks
2868: sortOrder = parseSortOrder maybeSortText
2869: sortedEpics = sortTasks sortOrder epicTasks
2870: pure (EpicsPage sortedEpics allTasks sortOrder)
2871:
2872: parseStatus :: Text -> Maybe TaskCore.Status
2873: parseStatus = readMaybe <. Text.unpack
2874:
2875: parsePriority :: Text -> Maybe TaskCore.Priority
2876: parsePriority = readMaybe <. Text.unpack
2877:
2878: parseTaskType :: Text -> Maybe TaskCore.TaskType
2879: parseTaskType = readMaybe <. Text.unpack
2880:
2881: emptyToNothing :: Maybe Text -> Maybe Text
2882: emptyToNothing (Just t) | Text.null (Text.strip t) = Nothing
2883: emptyToNothing x = x
2884:
2885: applyFilters :: TaskFilters -> [TaskCore.Task] -> [TaskCore.Task]
2886: applyFilters filters = filter matchesAllFilters
2887: where
2888: matchesAllFilters task =
2889: matchesStatus task
2890: && matchesPriority task
2891: && matchesNamespace task
2892: && matchesType task
2893:
2894: matchesStatus task = case filterStatus filters of
2895: Nothing -> True
2896: Just s -> TaskCore.taskStatus task == s
2897:
2898: matchesPriority task = case filterPriority filters of
2899: Nothing -> True
2900: Just p -> TaskCore.taskPriority task == p
2901:
2902: matchesNamespace task = case filterNamespace filters of
2903: Nothing -> True
2904: Just ns -> case TaskCore.taskNamespace task of
2905: Nothing -> False
2906: Just taskNs -> ns `Text.isPrefixOf` taskNs
2907:
2908: matchesType task = case filterType filters of
2909: Nothing -> True
2910: Just t -> TaskCore.taskType task == t
2911:
2912: taskDetailHandler :: Text -> Servant.Handler TaskDetailPage
2913: taskDetailHandler tid = do
2914: now <- liftIO getCurrentTime
2915: tasks <- liftIO TaskCore.loadTasks
2916: case TaskCore.findTask tid tasks of
2917: Nothing -> pure (TaskDetailNotFound tid)
2918: Just task -> do
2919: activities <- liftIO (TaskCore.getActivitiesForTask tid)
2920: retryCtx <- liftIO (TaskCore.getRetryContext tid)
2921: commits <- liftIO (getCommitsForTask tid)
2922: aggMetrics <-
2923: if TaskCore.taskType task == TaskCore.Epic
2924: then Just </ liftIO (TaskCore.getAggregatedMetrics tid)
2925: else pure Nothing
2926: agentEvents <- liftIO (TaskCore.getAllEventsForTask tid)
2927: pure (TaskDetailFound task tasks activities retryCtx commits aggMetrics agentEvents now)
2928:
2929: taskStatusHandler :: Text -> StatusForm -> Servant.Handler StatusBadgePartial
2930: taskStatusHandler tid (StatusForm newStatus) = do
2931: liftIO <| TaskCore.updateTaskStatusWithActor tid newStatus [] TaskCore.Human
2932: pure (StatusBadgePartial newStatus tid)
2933:
2934: taskPriorityHandler :: Text -> PriorityForm -> Servant.Handler PriorityBadgePartial
2935: taskPriorityHandler tid (PriorityForm newPriority) = do
2936: _ <- liftIO <| TaskCore.editTask tid (\t -> t {TaskCore.taskPriority = newPriority})
2937: pure (PriorityBadgePartial newPriority tid)
2938:
2939: descriptionViewHandler :: Text -> Servant.Handler DescriptionViewPartial
2940: descriptionViewHandler tid = do
2941: tasks <- liftIO TaskCore.loadTasks
2942: case TaskCore.findTask tid tasks of
2943: Nothing -> throwError err404
2944: Just task -> pure (DescriptionViewPartial tid (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic))
2945:
2946: descriptionEditHandler :: Text -> Servant.Handler DescriptionEditPartial
2947: descriptionEditHandler tid = do
2948: tasks <- liftIO TaskCore.loadTasks
2949: case TaskCore.findTask tid tasks of
2950: Nothing -> throwError err404
2951: Just task -> pure (DescriptionEditPartial tid (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic))
2952:
2953: descriptionPostHandler :: Text -> DescriptionForm -> Servant.Handler DescriptionViewPartial
2954: descriptionPostHandler tid (DescriptionForm desc) = do
2955: let descText = Text.strip desc
2956: _ <- liftIO <| TaskCore.editTask tid (\t -> t {TaskCore.taskDescription = descText})
2957: tasks <- liftIO TaskCore.loadTasks
2958: case TaskCore.findTask tid tasks of
2959: Nothing -> throwError err404
2960: Just task -> pure (DescriptionViewPartial tid (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic))
2961:
2962: taskNotesHandler :: Text -> NotesForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
2963: taskNotesHandler tid (NotesForm notes) = do
2964: liftIO <| TaskCore.updateRetryNotes tid notes
2965: pure <| addHeader ("/tasks/" <> tid) NoContent
2966:
2967: taskCommentHandler :: Text -> CommentForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
2968: taskCommentHandler tid (CommentForm commentText) = do
2969: _ <- liftIO (TaskCore.addComment tid commentText TaskCore.Human)
2970: pure <| addHeader ("/tasks/" <> tid) NoContent
2971:
2972: taskReviewHandler :: Text -> Servant.Handler TaskReviewPage
2973: taskReviewHandler tid = do
2974: tasks <- liftIO TaskCore.loadTasks
2975: case TaskCore.findTask tid tasks of
2976: Nothing -> pure (ReviewPageNotFound tid)
2977: Just task -> do
2978: reviewInfo <- liftIO <| getReviewInfo tid
2979: pure (ReviewPageFound task reviewInfo)
2980:
2981: taskDiffHandler :: Text -> Text -> Servant.Handler TaskDiffPage
2982: taskDiffHandler tid commitSha = do
2983: diffOutput <- liftIO <| getDiffForCommit commitSha
2984: case diffOutput of
2985: Nothing -> pure (DiffPageNotFound tid commitSha)
2986: Just output -> pure (DiffPageFound tid commitSha output)
2987:
2988: taskAcceptHandler :: Text -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
2989: taskAcceptHandler tid = do
2990: liftIO <| do
2991: TaskCore.clearRetryContext tid
2992: TaskCore.updateTaskStatusWithActor tid TaskCore.Done [] TaskCore.Human
2993: pure <| addHeader ("/tasks/" <> tid) NoContent
2994:
2995: taskRejectHandler :: Text -> RejectForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
2996: taskRejectHandler tid (RejectForm maybeNotes) = do
2997: liftIO <| do
2998: maybeCommit <- findCommitForTask tid
2999: let commitSha = fromMaybe "" maybeCommit
3000: maybeCtx <- TaskCore.getRetryContext tid
3001: let attempt = maybe 1 (\ctx -> TaskCore.retryAttempt ctx + 1) maybeCtx
3002: let currentReason = "attempt " <> tshow attempt <> ": rejected: " <> fromMaybe "(no notes)" maybeNotes
3003: let accumulatedReason = case maybeCtx of
3004: Nothing -> currentReason
3005: Just ctx -> TaskCore.retryReason ctx <> "\n" <> currentReason
3006: TaskCore.setRetryContext
3007: TaskCore.RetryContext
3008: { TaskCore.retryTaskId = tid,
3009: TaskCore.retryOriginalCommit = commitSha,
3010: TaskCore.retryConflictFiles = [],
3011: TaskCore.retryAttempt = attempt,
3012: TaskCore.retryReason = accumulatedReason,
3013: TaskCore.retryNotes = maybeCtx +> TaskCore.retryNotes
3014: }
3015: TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.Human
3016: pure <| addHeader ("/tasks/" <> tid) NoContent
3017:
3018: taskResetRetriesHandler :: Text -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
3019: taskResetRetriesHandler tid = do
3020: liftIO <| do
3021: TaskCore.clearRetryContext tid
3022: TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.Human
3023: pure <| addHeader ("/tasks/" <> tid) NoContent
3024:
3025: recentActivityNewHandler :: Maybe Int -> Servant.Handler RecentActivityNewPartial
3026: recentActivityNewHandler maybeSince = do
3027: allTasks <- liftIO TaskCore.loadTasks
3028: let sinceTime = maybe (posixSecondsToUTCTime 0) (posixSecondsToUTCTime <. fromIntegral) maybeSince
3029: sortedTasks = List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) allTasks
3030: newTasks = filter (\t -> TaskCore.taskUpdatedAt t > sinceTime) sortedTasks
3031: newestTs = maybe maybeSince (Just <. taskToUnixTs) (head newTasks)
3032: pure (RecentActivityNewPartial newTasks newestTs)
3033:
3034: recentActivityMoreHandler :: Maybe Int -> Servant.Handler RecentActivityMorePartial
3035: recentActivityMoreHandler maybeOffset = do
3036: allTasks <- liftIO TaskCore.loadTasks
3037: let offset = fromMaybe 0 maybeOffset
3038: pageSize = 5
3039: sortedTasks = List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) allTasks
3040: pageTasks = take pageSize <| drop offset sortedTasks
3041: hasMore = length sortedTasks > offset + pageSize
3042: nextOffset = offset + pageSize
3043: pure (RecentActivityMorePartial pageTasks nextOffset hasMore)
3044:
3045: readyCountHandler :: Servant.Handler ReadyCountPartial
3046: readyCountHandler = do
3047: readyTasks <- liftIO TaskCore.getReadyTasks
3048: pure (ReadyCountPartial (length readyTasks))
3049:
3050: taskListPartialHandler :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Servant.Handler TaskListPartial
3051: taskListPartialHandler maybeStatusText maybePriorityText maybeNamespace maybeTypeText maybeSortText = do
3052: allTasks <- liftIO TaskCore.loadTasks
3053: let maybeStatus = parseStatus =<< emptyToNothing maybeStatusText
3054: maybePriority = parsePriority =<< emptyToNothing maybePriorityText
3055: maybeType = parseTaskType =<< emptyToNothing maybeTypeText
3056: filters = TaskFilters maybeStatus maybePriority (emptyToNothing maybeNamespace) maybeType
3057: sortOrder = parseSortOrder maybeSortText
3058: filteredTasks = sortTasks sortOrder (applyFilters filters allTasks)
3059: pure (TaskListPartial filteredTasks)
3060:
3061: taskMetricsPartialHandler :: Text -> Servant.Handler TaskMetricsPartial
3062: taskMetricsPartialHandler tid = do
3063: now <- liftIO getCurrentTime
3064: activities <- liftIO (TaskCore.getActivitiesForTask tid)
3065: maybeRetry <- liftIO (TaskCore.getRetryContext tid)
3066: pure (TaskMetricsPartial tid activities maybeRetry now)
3067:
3068: agentEventsPartialHandler :: Text -> Maybe Int -> Servant.Handler AgentEventsPartial
3069: agentEventsPartialHandler tid _maybeSince = do
3070: now <- liftIO getCurrentTime
3071: events <- liftIO (TaskCore.getAllEventsForTask tid)
3072: tasks <- liftIO TaskCore.loadTasks
3073: let isInProgress = case TaskCore.findTask tid tasks of
3074: Nothing -> False
3075: Just task -> TaskCore.taskStatus task == TaskCore.InProgress
3076: pure (AgentEventsPartial events isInProgress now)
3077:
3078: taskEventsStreamHandler :: Text -> Servant.Handler (SourceIO ByteString)
3079: taskEventsStreamHandler tid = do
3080: maybeSession <- liftIO (TaskCore.getLatestSessionForTask tid)
3081: case maybeSession of
3082: Nothing -> pure (Source.source [])
3083: Just sid -> liftIO (streamAgentEvents tid sid)
3084:
3085: taskToUnixTs :: TaskCore.Task -> Int
3086: taskToUnixTs t = round (utcTimeToPOSIXSeconds (TaskCore.taskUpdatedAt t))
3087:
3088: getReviewInfo :: Text -> IO ReviewInfo
3089: getReviewInfo tid = do
3090: maybeCommit <- findCommitForTask tid
3091: case maybeCommit of
3092: Nothing -> pure ReviewNoCommit
3093: Just commitSha -> do
3094: conflictResult <- checkMergeConflict (Text.unpack commitSha)
3095: case conflictResult of
3096: Just conflictFiles -> pure (ReviewMergeConflict commitSha conflictFiles)
3097: Nothing -> do
3098: (_, diffOut, _) <-
3099: Process.readProcessWithExitCode
3100: "git"
3101: ["show", Text.unpack commitSha]
3102: ""
3103: pure (ReviewReady commitSha (Text.pack diffOut))
3104:
3105: getDiffForCommit :: Text -> IO (Maybe Text)
3106: getDiffForCommit commitSha = do
3107: (code, diffOut, _) <-
3108: Process.readProcessWithExitCode
3109: "git"
3110: ["show", Text.unpack commitSha]
3111: ""
3112: case code of
3113: Exit.ExitSuccess -> pure (Just (Text.pack diffOut))
3114: Exit.ExitFailure _ -> pure Nothing
3115:
3116: findCommitForTask :: Text -> IO (Maybe Text)
3117: findCommitForTask tid = do
3118: let grepArg = "--grep=" <> Text.unpack tid
3119: (code, shaOut, _) <-
3120: Process.readProcessWithExitCode
3121: "git"
3122: ["log", "--pretty=format:%H", "-n", "1", grepArg]
3123: ""
3124: if code /= Exit.ExitSuccess || null shaOut
3125: then pure Nothing
3126: else case List.lines shaOut of
3127: (x : _) -> pure (Just (Text.pack x))
3128: [] -> pure Nothing
3129:
3130: getCommitsForTask :: Text -> IO [GitCommit]
3131: getCommitsForTask tid = do
3132: let grepArg = "--grep=Task-Id: " <> Text.unpack tid
3133: (code, out, _) <-
3134: Process.readProcessWithExitCode
3135: "git"
3136: ["log", "--pretty=format:%H|%h|%s|%an|%ar", grepArg]
3137: ""
3138: if code /= Exit.ExitSuccess || null out
3139: then pure []
3140: else do
3141: let commitLines = filter (not <. null) (List.lines out)
3142: traverse parseCommitLine commitLines
3143: where
3144: parseCommitLine :: String -> IO GitCommit
3145: parseCommitLine line =
3146: case Text.splitOn "|" (Text.pack line) of
3147: [sha, shortSha, summary, author, relDate] -> do
3148: filesCount <- getFilesChangedCount (Text.unpack sha)
3149: pure
3150: GitCommit
3151: { commitHash = sha,
3152: commitShortHash = shortSha,
3153: commitSummary = summary,
3154: commitAuthor = author,
3155: commitRelativeDate = relDate,
3156: commitFilesChanged = filesCount
3157: }
3158: _ ->
3159: pure
3160: GitCommit
3161: { commitHash = Text.pack line,
3162: commitShortHash = Text.take 7 (Text.pack line),
3163: commitSummary = "(parse error)",
3164: commitAuthor = "",
3165: commitRelativeDate = "",
3166: commitFilesChanged = 0
3167: }
3168:
3169: getFilesChangedCount :: String -> IO Int
3170: getFilesChangedCount sha = do
3171: (code', out', _) <-
3172: Process.readProcessWithExitCode
3173: "git"
3174: ["show", "--stat", "--format=", sha]
3175: ""
3176: pure
3177: <| if code' /= Exit.ExitSuccess
3178: then 0
3179: else
3180: let statLines = filter (not <. null) (List.lines out')
3181: in max 0 (length statLines - 1)
3182:
3183: checkMergeConflict :: String -> IO (Maybe [Text])
3184: checkMergeConflict commitSha = do
3185: (_, origHead, _) <- Process.readProcessWithExitCode "git" ["rev-parse", "HEAD"] ""
3186:
3187: (cpCode, _, cpErr) <-
3188: Process.readProcessWithExitCode
3189: "git"
3190: ["cherry-pick", "--no-commit", commitSha]
3191: ""
3192:
3193: _ <- Process.readProcessWithExitCode "git" ["cherry-pick", "--abort"] ""
3194: _ <- Process.readProcessWithExitCode "git" ["reset", "--hard", List.head (List.lines origHead)] ""
3195:
3196: case cpCode of
3197: Exit.ExitSuccess -> pure Nothing
3198: Exit.ExitFailure _ -> do
3199: let errLines = Text.lines (Text.pack cpErr)
3200: conflictLines = filter (Text.isPrefixOf "CONFLICT") errLines
3201: files = mapMaybe extractConflictFile conflictLines
3202: pure (Just (if null files then ["(unknown files)"] else files))
3203:
3204: extractConflictFile :: Text -> Maybe Text
3205: extractConflictFile line =
3206: case Text.breakOn "Merge conflict in " line of
3207: (_, rest)
3208: | not (Text.null rest) -> Just (Text.strip (Text.drop 18 rest))
3209: _ -> case Text.breakOn "in " line of
3210: (_, rest)
3211: | not (Text.null rest) -> Just (Text.strip (Text.drop 3 rest))
3212: _ -> Nothing
3213:
3214: app :: Application
3215: app = serve api server
3216:
3217: run :: Warp.Port -> IO ()
3218: run port = do
3219: TaskCore.initTaskDb
3220: putText <| "Starting Jr web server on port " <> tshow port
3221: Warp.run port app
Now I can see the Agent Log box is rendered in the timeline section. Looking at the code, I found the relevant section around line 2372-2649 where the timeline is rendered. The task is to add auto-scrolling to the bottom of the agent log box.
Let me search for more details about the timeline HTML structure:
timeline-events in /home/ben/omni/Omni/Jr/Web/Style.hs:1585: ".timeline-events" ? do
/home/ben/omni/Omni/Jr/Web.hs:2381: Lucid.makeAttribute "hx-on::before-request" "var log = this.querySelector('.timeline-events'); if(log) this.dataset.scroll = log.scrollTop",
/home/ben/omni/Omni/Jr/Web.hs:2382: Lucid.makeAttribute "hx-on::after-swap" "var log = this.querySelector('.timeline-events'); if(log && this.dataset.scroll) log.scrollTop = this.dataset.scroll"
/home/ben/omni/Omni/Jr/Web.hs:2393: Lucid.div_ [Lucid.class_ "timeline-events"] <| do
/home/ben/omni/Omni/Jr/Web.hs:2627: " var log = document.querySelector('.timeline-events');",
/home/ben/omni/Omni/Jr/Web.hs:2647: Lucid.div_ [Lucid.class_ "timeline-events"] <| do
Perfect! I can see there's already a timelineScrollScript at line 2620 that checks if we're near the bottom. However, looking at the HTMX attributes around lines 2381-2382, I see the current script is saving and restoring scroll position instead of auto-scrolling to bottom.
The issue is clear: the hx-on::after-swap is restoring the scroll position rather than scrolling to bottom. I need to modify the script to auto-scroll to the bottom when new content is added.
Let me examine the Style file to understand the CSS:
Omni/Jr/Web/Style.hs @1580-16001580: padding (px 2) (px 6) (px 2) (px 6)
1581: borderRadius (px 10) (px 10) (px 10) (px 10)
1582: marginLeft (px 8)
1583: textTransform uppercase
1584: Stylesheet.key "animation" ("pulse 2s infinite" :: Text)
1585: ".timeline-events" ? do
1586: maxHeight (px 600)
1587: overflowY auto
1588: display flex
1589: flexDirection column
1590: Stylesheet.key "gap" ("12px" :: Text)
1591: padding (px 12) (px 0) (px 12) (px 0)
1592: ".timeline-event" ? do
1593: fontSize (px 13)
1594: lineHeight (em 1.4)
1595: ".actor-label" ? do
1596: fontSize (px 11)
1597: fontWeight (weight 500)
1598: padding (px 1) (px 4) (px 1) (px 4)
1599: borderRadius (px 3) (px 3) (px 3) (px 3)
1600: marginLeft (px 4)
Good! The .timeline-events has maxHeight (px 600) and overflowY auto, so it's a scrollable div. Now let me look at the current scroll handling script again and the fix needed:
Looking at lines 2381-2382 of Web.hs, the current approach saves the scroll position before a request and restores it after. This is to prevent jumping. However, for the agent log, we want to auto-scroll to the bottom when new events arrive.
Let me also check line 2620 to understand the timelineScrollScript better:
The timelineScrollScript (lines 2620-2636) already has logic to check if we're near the bottom and scroll. But the HTMX handlers are interfering.
The fix is to: 1. Modify the HTMX attributes to NOT restore scroll position, but instead scroll to bottom 2. Or, modify the script to always scroll to bottom for new events
Let me implement the fix by modifying the HTMX attributes to auto-scroll to bottom:
Omni/Jr/Web.hsGood! Now let me also check and improve the timelineScrollScript to ensure it scrolls to bottom after new events are added. Let me look at the script more carefully:
Omni/Jr/Web.hs @2620-26502620: timelineScrollScript =
2621: Lucid.script_
2622: [ Lucid.type_ "text/javascript"
2623: ]
2624: ( Text.unlines
2625: [ "(function() {",
2626: " var log = document.querySelector('.timeline-events');",
2627: " if (log) {",
2628: " var isNearBottom = log.scrollHeight - log.scrollTop - log.clientHeight < 100;",
2629: " if (isNearBottom) {",
2630: " log.scrollTop = log.scrollHeight;",
2631: " }",
2632: " }",
2633: "})();"
2634: ]
2635: )
2636:
2637: instance Lucid.ToHtml AgentEventsPartial where
2638: toHtmlRaw = Lucid.toHtml
2639: toHtml (AgentEventsPartial events isInProgress now) = do
2640: Lucid.h3_ <| do
2641: Lucid.toHtml ("Timeline (" <> tshow (length events) <> ")")
2642: when isInProgress <| Lucid.span_ [Lucid.class_ "timeline-live"] " LIVE"
2643: if null events
2644: then Lucid.p_ [Lucid.class_ "empty-msg"] "No activity yet."
2645: else do
2646: Lucid.div_ [Lucid.class_ "timeline-events"] <| do
2647: traverse_ (renderTimelineEvent now) events
2648: timelineScrollScript
2649:
2650: -- | Stream agent events as SSE
I see the timelineScrollScript is checking if we're near bottom (within 100px) and only then scrolls. This is a good approach, but the HTMX on::after-swap handler should always scroll to bottom for the main timeline view. Let me reconsider - the AgentEventsPartial also renders this script. Let me check if we need to update both places.
Actually, looking back at my change, I realized I should be even more aggressive. For the main timeline during task execution, we should ALWAYS auto-scroll to bottom when new events arrive. Let me update the approach:
Omni/Jr/Web.hs @2370-24002370:
2371: -- | Unified timeline view combining comments, status changes, and agent events
2372: renderUnifiedTimeline :: (Monad m) => Text -> [TaskCore.Comment] -> [TaskCore.StoredEvent] -> TaskCore.Status -> UTCTime -> Lucid.HtmlT m ()
2373: renderUnifiedTimeline tid legacyComments events status now = do
2374: let isInProgress = status == TaskCore.InProgress
2375: pollAttrs =
2376: if isInProgress
2377: then
2378: [ Lucid.makeAttribute "hx-get" ("/partials/task/" <> tid <> "/events"),
2379: Lucid.makeAttribute "hx-trigger" "every 3s",
2380: Lucid.makeAttribute "hx-swap" "innerHTML",
2381: Lucid.makeAttribute "hx-on::after-swap" "var log = this.querySelector('.timeline-events'); if(log) log.scrollTop = log.scrollHeight"
2382: ]
2383: else []
2384: Lucid.div_ ([Lucid.class_ "unified-timeline-section", Lucid.id_ "unified-timeline"] <> pollAttrs) <| do
2385: Lucid.h3_ <| do
2386: Lucid.toHtml ("Timeline (" <> tshow (length events + length legacyComments) <> ")")
2387: when isInProgress <| Lucid.span_ [Lucid.class_ "timeline-live"] " LIVE"
2388:
2389: if null events && null legacyComments
2390: then Lucid.p_ [Lucid.class_ "empty-msg"] "No activity yet."
2391: else do
2392: Lucid.div_ [Lucid.class_ "timeline-events"] <| do
2393: traverse_ (renderTimelineEvent now) events
2394: when isInProgress <| timelineScrollScript
2395:
2396: commentForm tid
2397:
2398: -- | Render a single timeline event with icon, actor label, and timestamp
2399: renderTimelineEvent :: (Monad m) => UTCTime -> TaskCore.StoredEvent -> Lucid.HtmlT m ()
2400: renderTimelineEvent now event =
Good! My change has already been applied. Now I need to also make sure the AgentEventsPartial properly auto-scrolls when rendered. Let me add a better approach for the partial handler by modifying the HTMX attributes for that request as well:
Omni/Jr/Web.hs @2637-26502637: instance Lucid.ToHtml AgentEventsPartial where
2638: toHtmlRaw = Lucid.toHtml
2639: toHtml (AgentEventsPartial events isInProgress now) = do
2640: Lucid.h3_ <| do
2641: Lucid.toHtml ("Timeline (" <> tshow (length events) <> ")")
2642: when isInProgress <| Lucid.span_ [Lucid.class_ "timeline-live"] " LIVE"
2643: if null events
2644: then Lucid.p_ [Lucid.class_ "empty-msg"] "No activity yet."
2645: else do
2646: Lucid.div_ [Lucid.class_ "timeline-events"] <| do
2647: traverse_ (renderTimelineEvent now) events
2648: timelineScrollScript
2649:
2650: -- | Stream agent events as SSE
The timelineScrollScript is already included in the AgentEventsPartial. However, the current script only scrolls if we're near the bottom. For a better user experience, we should always scroll to bottom when new events arrive. Let me enhance the timelineScrollScript to be more aggressive:
Omni/Jr/Web.hsLet me fix the escaping issue:
Omni/Jr/Web.hs @2620-26362620: timelineScrollScript =
2621: Lucid.script_
2622: [ Lucid.type_ "text/javascript"
2623: ]
2624: ( Text.unlines
2625: [ "(function() {",
2626: " var log = document.querySelector('.timeline-events');",
2627: " if (log) {",
2628: " var isNearBottom = log.scrollHeight - log.scrollTop - log.clientHeight < 100;",
2629: " if (isNearBottom) {",
2630: " log.scrollTop = log.scrollHeight;",
2631: " }",
2632: " }",
2633: "})();"
2634: ]
2635: )
2636:
Now let me make the replacement without the backslash:
Omni/Jr/Web.hsPerfect! Now I've made two key changes:
1. Modified the HTMX hx-on::after-swap handler to auto-scroll to bottom after new content is swapped in (line 2381)
2. Simplified the timelineScrollScript to always scroll to the bottom instead of checking if we're near bottom (lines 2620-2630)
Let me now run the tests to ensure everything still works:
cd /home/ben/omni && bild --test Omni/Jr.hs 2>&1 | head -1007[10000;10000H [1A[1G[2K[.] Omni/Jr.hs [1A[1G[2K[0m[+] Omni/Jr.hs[0m[1B[1A[1G[2K[0m[~] Omni/Jr.hs[0m[1B[1A[1G[2K[~] Omni/Jr.hs: warning: you did not specify '--add-root'; the result might ...[1B[1A[1G[2K[~] Omni/Jr.hs: /nix/store/vc4gnyjv3lrjix3wqbsvgbqi9hmbvs7h-jr.drv...[1B[1A[1G[2K[~] Omni/Jr.hs: these 3 derivations will be built:...[1B[1A[1G[2K[~] Omni/Jr.hs: /nix/store/r402l2ig66rwm47qhzlivysp4mwyya32-hs-mod-Omni_Jr...[1B[1A[1G[2K[~] Omni/Jr.hs: building '/nix/store/r402l2ig66rwm47qhzlivysp4mwyya32-hs-mod...[1B[1A[1G[2K[~] Omni/Jr.hs: building '/nix/store/hqh3b6q8aqs7swz8g94ymhg649g056cz-hs-mod...[1B[1A[1G[2K[~] Omni/Jr.hs: building '/nix/store/vc4gnyjv3lrjix3wqbsvgbqi9hmbvs7h-jr.drv...[1B[1A[1G[2K[~] Omni/Jr.hs: Running phase: unpackPhase...[1B[1A[1G[2K[~] Omni/Jr.hs: unpacking source archive /nix/store/4ms22kxan3ri1gg1qz0fd4q0...[1B[1A[1G[2K[~] Omni/Jr.hs: source root is source...[1B[1A[1G[2K[~] Omni/Jr.hs: Running phase: patchPhase...[1B[1A[1G[2K[~] Omni/Jr.hs: Running phase: updateAutotoolsGnuConfigScriptsPhase...[1B[1A[1G[2K[~] Omni/Jr.hs: Running phase: buildPhase...[1B[1A[1G[2K[~] Omni/Jr.hs: [ 1 of 18] Compiling Alpha ( Alpha.hs, Alpha.o, A...[1B[1A[1G[2K[~] Omni/Jr.hs: [ 2 of 18] Compiling Omni.Agent.Core ( Omni/Agent/Core.hs, ...[1B[1A[1G[2K[~] Omni/Jr.hs: [ 3 of 18] Compiling Omni.Agent.Log ( Omni/Agent/Log.hs, O...[1B[1A[1G[2K[~] Omni/Jr.hs: [ 4 of 18] Compiling Omni.Jr.Web.Style ( Omni/Jr/Web/Style.h...[1B[1A[1G[2K[~] Omni/Jr.hs: [ 5 of 18] Compiling Omni.Namespace ( Omni/Namespace.hs, O...[1B[1A[1G[2K[~] Omni/Jr.hs: [ 6 of 18] Compiling Omni.Task.Core ( Omni/Task/Core.hs, O...[1B[1A[1G[2K[~] Omni/Jr.hs: [ 7 of 18] Compiling Omni.Fact ( Omni/Fact.hs, Omni/F...[1B[1A[1G[2K[~] Omni/Jr.hs: [ 8 of 18] Compiling Omni.Jr.Web ( Omni/Jr/Web.hs, Omni...[1B[1A[1G[2K[~] Omni/Jr.hs: [ 9 of 18] Compiling Omni.Test ( Omni/Test.hs, Omni/T...[1B[1A[1G[2K[~] Omni/Jr.hs: [10 of 18] Compiling Omni.Task.RaceTest ( Omni/Task/RaceTest...[1B[1A[1G[2K[~] Omni/Jr.hs: [11 of 18] Compiling Omni.Task.MigrationTest ( Omni/Task/Mig...[1B[1A[1G[2K[~] Omni/Jr.hs: [12 of 18] Compiling Omni.Cli ( Omni/Cli.hs, Omni/Cl...[1B[1A[1G[2K[~] Omni/Jr.hs: [13 of 18] Compiling Omni.Task ( Omni/Task.hs, Omni/T...[1B[1A[1G[2K[~] Omni/Jr.hs: [14 of 18] Compiling Omni.Agent.Engine ( Omni/Agent/Engine.h...[1B[1A[1G[2K[~] Omni/Jr.hs: [15 of 18] Compiling Omni.Agent.Tools ( Omni/Agent/Tools.hs,...[1B[1A[1G[2K[~] Omni/Jr.hs: [16 of 18] Compiling Omni.Agent.Worker ( Omni/Agent/Worker.h...[1B[1A[1G[2K[~] Omni/Jr.hs: [17 of 18] Compiling Omni.Jr ( Omni/Jr.hs, Omni/Jr....[1B[1A[1G[2K[~] Omni/Jr.hs: [18 of 18] Linking jr...[1B[1A[1G[2K[~] Omni/Jr.hs: buildPhase completed in 1 minutes 11 seconds...[1B[1A[1G[2K[~] Omni/Jr.hs: Running phase: installPhase...[1B[1A[1G[2K[~] Omni/Jr.hs: Running phase: fixupPhase...[1B[1A[1G[2K[~] Omni/Jr.hs: shrinking RPATHs of ELF executables and libraries in /nix/st...[1B[1A[1G[2K[~] Omni/Jr.hs: shrinking /nix/store/svg3k48ibyjkp6ibsh2asd8m3pjlplxw-jr/bin...[1B[1A[1G[2K[~] Omni/Jr.hs: checking for references to /build/ in /nix/store/svg3k48ibyj...[1B[1A[1G[2K[~] Omni/Jr.hs: /home/ben/omni/_/nix/jr...[1B[1A[1G[2K[~] Omni/Jr.hs: Omni.Jr...[1B[1A[1G[2K[~] Omni/Jr.hs: can run tests: ...[1B[1A[1G[2K[~] Omni/Jr.hs: OK can parse task command: OK can parse task ...[1B[1A[1G[2K[~] Omni/Jr.hs: OK can parse work command: OK can parse work ...[1B[1A[1G[2K[~] Omni/Jr.hs: can parse facts list with --json: OK can parse facts s...[1B[1A[1G[2K[~] Omni/Jr.hs: OK can parse facts add with options: OK can parse facts...[1B[1A[1G[2K[0m[38;5;2m[✓] Omni/Jr.hs[0m[1B[1A[1G[2K[0m[38;5;2m[✓] Omni/Jr.hs[0m[1B
Excellent! The tests are passing. Let me verify the test completed successfully:
cd /home/ben/omni && bild --test Omni/Jr.hs 2>&1 | tail -207[10000;10000H [1A[1G[2K[.] Omni/Jr.hs [1A[1G[2K[0m[+] Omni/Jr.hs[0m[1B[1A[1G[2K[0m[~] Omni/Jr.hs[0m[1B[1A[1G[2K[~] Omni/Jr.hs: warning: you did not specify '--add-root'; the result might ...[1B[1A[1G[2K[~] Omni/Jr.hs: /nix/store/vc4gnyjv3lrjix3wqbsvgbqi9hmbvs7h-jr.drv...[1B[1A[1G[2K[~] Omni/Jr.hs: /home/ben/omni/_/nix/jr...[1B[1A[1G[2K[~] Omni/Jr.hs: Omni.Jr...[1B[1A[1G[2K[~] Omni/Jr.hs: can run tests: ...[1B[1A[1G[2K[~] Omni/Jr.hs: OK...[1B[1A[1G[2K[~] Omni/Jr.hs: can parse task command: OK can parse task co...[1B[1A[1G[2K[~] Omni/Jr.hs: can parse work command with task id: OK can parse facts l...[1B[1A[1G[2K[~] Omni/Jr.hs: OK can parse facts show command: OK can parse facts...[1B[1A[1G[2K[~] Omni/Jr.hs: can parse facts add with options: OK can parse facts d...[1B[1A[1G[2K[0m[38;5;2m[✓] Omni/Jr.hs[0m[1B[1A[1G[2K[0m[38;5;2m[✓] Omni/Jr.hs[0m[1B
{"contents":[1049866,1000000],"tag":"GuardrailTokensExceeded"}
"Agent Log" has been replaced with "Timeline", so make the Timeline autoscroll on new events.