TaskType has three values: Epic, WorkTask, HumanTask. This is awkward because: 1. HumanTask is filtered out of ready queue entirely 2. To give Jr a 'human' task, you must manually change type to WorkTask 3. Jr has no way to signal 'I need help' during work 4. The retry-context/max-retries mechanism is a workaround for this
Remove HumanTask type. Add new Status: NeedsHelp
New flow:
I'll start by reading AGENTS.md to understand the codebase conventions, then examine the current implementation to make the necessary changes.
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.
Omni/Task.hs1: {-# LANGUAGE OverloadedStrings #-}
2: {-# LANGUAGE QuasiQuotes #-}
3: {-# LANGUAGE RecordWildCards #-}
4: {-# LANGUAGE NoImplicitPrelude #-}
5:
6: -- : dep sqlite-simple
7: module Omni.Task where
8:
9: import Alpha
10: import qualified Data.Aeson as Aeson
11: import qualified Data.Aeson.KeyMap as KM
12: import qualified Data.ByteString.Lazy.Char8 as BLC
13: import qualified Data.Text as T
14: import qualified Data.Text.Encoding as TE
15: import Data.Time (defaultTimeLocale, formatTime)
16: import qualified Omni.Cli as Cli
17: import qualified Omni.Namespace as Namespace
18: import Omni.Task.Core
19: import qualified Omni.Task.MigrationTest as MigrationTest
20: import qualified Omni.Task.RaceTest as RaceTest
21: import qualified Omni.Test as Test
22: import qualified System.Console.Docopt as Docopt
23: import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile)
24: import System.Environment (setEnv)
25: import qualified Test.Tasty as Tasty
26: import Web.HttpApiData (parseQueryParam)
27: import Prelude (read)
28:
29: main :: IO ()
30: main = Cli.main plan
31:
32: plan :: Cli.Plan ()
33: plan =
34: Cli.Plan
35: { help = help,
36: move = move,
37: test = test,
38: tidy = \_ -> pure ()
39: }
40:
41: help :: Cli.Docopt
42: help =
43: [Cli.docopt|
44: task
45:
46: Usage:
47: task init [--quiet]
48: task create <title> [options]
49: task edit <id> [options]
50: task delete <id> [--json]
51: task comment <id> <message> [--json]
52: task list [options]
53: task ready [--json]
54: task show <id> [--json]
55: task update <id> <status> [options] [--verified]
56: task deps <id> [--json]
57: task tree [<id>] [--json]
58: task progress <id> [--json]
59: task stats [--epic=<id>] [--json]
60: task log <id> [--session=<sid>] [--follow] [--json]
61: task export [-o <file>]
62: task import -i <file>
63: task test
64: task (-h | --help)
65:
66: Commands:
67: init Initialize task database
68: create Create a new task or epic
69: edit Edit an existing task
70: delete Delete a task
71: comment Add a comment to a task
72: list List all tasks
73: ready Show ready tasks (not blocked)
74: show Show detailed task information
75: update Update task status
76: deps Show dependency tree
77: tree Show task tree (epics with children, or all epics if no ID given)
78: progress Show progress for an epic
79: stats Show task statistics
80: log Show agent event log for a task
81: export Export tasks to JSONL
82: import Import tasks from JSONL file
83: test Run tests
84:
85: Options:
86: -h --help Show this help
87: --title=<title> Task title
88: --type=<type> Task type: epic, task, or human (default: task)
89: --parent=<id> Parent epic ID
90: --priority=<p> Priority: 0-4 (0=critical, 4=backlog, default: 2)
91: --complexity=<c> Complexity: 1-5 for model selection (1=trivial, 5=expert)
92: --status=<status> Filter by status: draft, open, in-progress, review, approved, done
93: --epic=<id> Filter stats by epic (recursive)
94: --deps=<ids> Comma-separated list of dependency IDs
95: --dep-type=<type> Dependency type: blocks, discovered-from, parent-child, related
96: --discovered-from=<id> Shortcut for --deps=<id> --dep-type=discovered-from
97: --namespace=<ns> Optional namespace (e.g., Omni/Task, Biz/Cloud)
98: --description=<desc> Task description
99: --db=<file> Path to SQLite database (overrides TASK_DB_PATH)
100: --flush Force immediate export
101: --json Output in JSON format (for agent use)
102: --quiet Non-interactive mode (for agents)
103: --verified Mark task as verified (code compiles, tests pass, feature works)
104: --session=<sid> Show events for specific session ID
105: --follow Stream events in real-time (like tail -f)
106: -i <file> Input file for import
107: -o <file> Output file for export
108:
109: Arguments:
110: <title> Task title
111: <id> Task ID
112: <status> Task status (draft, open, in-progress, review, approved, done)
113: <message> Comment message
114: <file> JSONL file to import
115: |]
116:
117: -- Helper to check if JSON output is requested
118: isJsonMode :: Cli.Arguments -> Bool
119: isJsonMode args = args `Cli.has` Cli.longOption "json"
120:
121: -- Helper to output JSON
122: outputJson :: (Aeson.ToJSON a) => a -> IO ()
123: outputJson val = BLC.putStrLn <| Aeson.encode val
124:
125: -- Helper for success message in JSON
126: outputSuccess :: Text -> IO ()
127: outputSuccess msg = outputJson <| Aeson.object ["success" Aeson..= True, "message" Aeson..= msg]
128:
129: move :: Cli.Arguments -> IO ()
130: move args = do
131: -- Handle --db flag globally
132: for_
133: (Cli.getArg args (Cli.longOption "db"))
134: (setEnv "TASK_DB_PATH")
135:
136: move' args
137:
138: move' :: Cli.Arguments -> IO ()
139: move' args
140: | args `Cli.has` Cli.command "init" = do
141: let quiet = args `Cli.has` Cli.longOption "quiet"
142: initTaskDb
143: unless quiet <| putText "Task database initialized. Use 'task create' to add tasks."
144: | args `Cli.has` Cli.command "create" = do
145: title <- getArgText args "title"
146: taskType <- case Cli.getArg args (Cli.longOption "type") of
147: Nothing -> pure WorkTask
148: Just "epic" -> pure Epic
149: Just "task" -> pure WorkTask
150: Just "human" -> pure HumanTask
151: Just other -> panic <| "Invalid task type: " <> T.pack other <> ". Use: epic, task, or human"
152: parent <- case Cli.getArg args (Cli.longOption "parent") of
153: Nothing -> pure Nothing
154: Just p -> pure <| Just (T.pack p)
155:
156: -- Handle --discovered-from as shortcut
157: (depIds, depType) <- case Cli.getArg args (Cli.longOption "discovered-from") of
158: Just discoveredId -> pure ([T.pack discoveredId], DiscoveredFrom)
159: Nothing -> do
160: -- Parse regular --deps and --dep-type
161: ids <- case Cli.getArg args (Cli.longOption "deps") of
162: Nothing -> pure []
163: Just depStr -> pure <| T.splitOn "," (T.pack depStr)
164: dtype <- case Cli.getArg args (Cli.longOption "dep-type") of
165: Nothing -> pure Blocks
166: Just "blocks" -> pure Blocks
167: Just "discovered-from" -> pure DiscoveredFrom
168: Just "parent-child" -> pure ParentChild
169: Just "related" -> pure Related
170: Just other -> panic <| "Invalid dependency type: " <> T.pack other <> ". Use: blocks, discovered-from, parent-child, or related"
171: pure (ids, dtype)
172:
173: let deps = map (\did -> Dependency {depId = did, depType = depType}) depIds
174:
175: -- Parse priority (default to P2 = medium)
176: priority <- case Cli.getArg args (Cli.longOption "priority") of
177: Nothing -> pure P2
178: Just "0" -> pure P0
179: Just "1" -> pure P1
180: Just "2" -> pure P2
181: Just "3" -> pure P3
182: Just "4" -> pure P4
183: Just other -> panic <| "Invalid priority: " <> T.pack other <> ". Use: 0-4"
184:
185: -- Parse complexity (1-5 scale)
186: complexity <- case Cli.getArg args (Cli.longOption "complexity") of
187: Nothing -> pure Nothing
188: Just c -> case readMaybe c of
189: Just n | n >= 1 && n <= 5 -> pure (Just n)
190: _ -> panic <| "Invalid complexity: " <> T.pack c <> ". Use: 1-5"
191:
192: namespace <- case Cli.getArg args (Cli.longOption "namespace") of
193: Nothing -> pure Nothing
194: Just ns -> do
195: -- Validate it's a proper namespace by parsing it
196: let validNs = Namespace.fromHaskellModule ns
197: nsPath = T.pack <| Namespace.toPath validNs
198: pure <| Just nsPath
199:
200: description <- case Cli.getArg args (Cli.longOption "description") of
201: Nothing -> panic "--description is required for task create"
202: Just d -> pure (T.pack d)
203:
204: createdTask <- createTask title taskType parent namespace priority complexity deps description
205: if isJsonMode args
206: then outputJson createdTask
207: else putStrLn <| "Created task: " <> T.unpack (taskId createdTask)
208: | args `Cli.has` Cli.command "edit" = do
209: tid <- getArgText args "id"
210:
211: -- Parse optional edits
212: maybeTitle <- pure <| Cli.getArg args (Cli.longOption "title")
213: maybeType <- case Cli.getArg args (Cli.longOption "type") of
214: Nothing -> pure Nothing
215: Just "epic" -> pure <| Just Epic
216: Just "task" -> pure <| Just WorkTask
217: Just other -> panic <| "Invalid task type: " <> T.pack other <> ". Use: epic or task"
218: maybeParent <- pure <| fmap T.pack (Cli.getArg args (Cli.longOption "parent"))
219: maybePriority <- case Cli.getArg args (Cli.longOption "priority") of
220: Nothing -> pure Nothing
221: Just "0" -> pure <| Just P0
222: Just "1" -> pure <| Just P1
223: Just "2" -> pure <| Just P2
224: Just "3" -> pure <| Just P3
225: Just "4" -> pure <| Just P4
226: Just other -> panic <| "Invalid priority: " <> T.pack other <> ". Use: 0-4"
227: maybeComplexity <- case Cli.getArg args (Cli.longOption "complexity") of
228: Nothing -> pure Nothing
229: Just c -> case readMaybe c of
230: Just n | n >= 1 && n <= 5 -> pure (Just (Just n))
231: _ -> panic <| "Invalid complexity: " <> T.pack c <> ". Use: 1-5"
232: maybeStatus <- case Cli.getArg args (Cli.longOption "status") of
233: Nothing -> pure Nothing
234: Just "draft" -> pure <| Just Draft
235: Just "open" -> pure <| Just Open
236: Just "in-progress" -> pure <| Just InProgress
237: Just "review" -> pure <| Just Review
238: Just "done" -> pure <| Just Done
239: Just other -> panic <| "Invalid status: " <> T.pack other <> ". Use: draft, open, in-progress, review, or done"
240: maybeNamespace <- case Cli.getArg args (Cli.longOption "namespace") of
241: Nothing -> pure Nothing
242: Just ns -> do
243: let validNs = Namespace.fromHaskellModule ns
244: nsPath = T.pack <| Namespace.toPath validNs
245: pure <| Just nsPath
246: maybeDesc <- pure <| fmap T.pack (Cli.getArg args (Cli.longOption "description"))
247:
248: maybeDeps <- case Cli.getArg args (Cli.longOption "discovered-from") of
249: Just discoveredId -> pure <| Just [Dependency {depId = T.pack discoveredId, depType = DiscoveredFrom}]
250: Nothing -> case Cli.getArg args (Cli.longOption "deps") of
251: Nothing -> pure Nothing
252: Just depStr -> do
253: let ids = T.splitOn "," (T.pack depStr)
254: dtype <- case Cli.getArg args (Cli.longOption "dep-type") of
255: Nothing -> pure Blocks
256: Just "blocks" -> pure Blocks
257: Just "discovered-from" -> pure DiscoveredFrom
258: Just "parent-child" -> pure ParentChild
259: Just "related" -> pure Related
260: Just other -> panic <| "Invalid dependency type: " <> T.pack other
261: pure <| Just (map (\did -> Dependency {depId = did, depType = dtype}) ids)
262:
263: let modifyFn task =
264: task
265: { taskTitle = maybe (taskTitle task) T.pack maybeTitle,
266: taskType = fromMaybe (taskType task) maybeType,
267: taskParent = case maybeParent of Nothing -> taskParent task; Just p -> Just p,
268: taskNamespace = case maybeNamespace of Nothing -> taskNamespace task; Just ns -> Just ns,
269: taskStatus = fromMaybe (taskStatus task) maybeStatus,
270: taskPriority = fromMaybe (taskPriority task) maybePriority,
271: taskComplexity = fromMaybe (taskComplexity task) maybeComplexity,
272: taskDescription = fromMaybe (taskDescription task) maybeDesc,
273: taskDependencies = fromMaybe (taskDependencies task) maybeDeps
274: }
275:
276: updatedTask <- editTask tid modifyFn
277: if isJsonMode args
278: then outputJson updatedTask
279: else putStrLn <| "Updated task: " <> T.unpack (taskId updatedTask)
280: | args `Cli.has` Cli.command "delete" = do
281: tid <- getArgText args "id"
282: deleteTask tid
283: if isJsonMode args
284: then outputSuccess ("Deleted task " <> tid)
285: else putStrLn <| "Deleted task: " <> T.unpack tid
286: | args `Cli.has` Cli.command "comment" = do
287: tid <- getArgText args "id"
288: message <- getArgText args "message"
289: updatedTask <- addComment tid message Human
290: if isJsonMode args
291: then outputJson updatedTask
292: else putStrLn <| "Added comment to task: " <> T.unpack tid
293: | args `Cli.has` Cli.command "list" = do
294: maybeType <- case Cli.getArg args (Cli.longOption "type") of
295: Nothing -> pure Nothing
296: Just "epic" -> pure <| Just Epic
297: Just "task" -> pure <| Just WorkTask
298: Just "human" -> pure <| Just HumanTask
299: Just other -> panic <| "Invalid task type: " <> T.pack other
300: maybeParent <- case Cli.getArg args (Cli.longOption "parent") of
301: Nothing -> pure Nothing
302: Just p -> pure <| Just (T.pack p)
303: maybeStatus <- case Cli.getArg args (Cli.longOption "status") of
304: Nothing -> pure Nothing
305: Just "draft" -> pure <| Just Draft
306: Just "open" -> pure <| Just Open
307: Just "in-progress" -> pure <| Just InProgress
308: Just "review" -> pure <| Just Review
309: Just "approved" -> pure <| Just Approved
310: Just "done" -> pure <| Just Done
311: Just other -> panic <| "Invalid status: " <> T.pack other <> ". Use: draft, open, in-progress, review, approved, or done"
312: maybeNamespace <- case Cli.getArg args (Cli.longOption "namespace") of
313: Nothing -> pure Nothing
314: Just ns -> do
315: let validNs = Namespace.fromHaskellModule ns
316: nsPath = T.pack <| Namespace.toPath validNs
317: pure <| Just nsPath
318: tasks <- listTasks maybeType maybeParent maybeStatus maybeNamespace
319: if isJsonMode args
320: then outputJson tasks
321: else traverse_ printTask tasks
322: | args `Cli.has` Cli.command "ready" = do
323: tasks <- getReadyTasks
324: if isJsonMode args
325: then outputJson tasks
326: else do
327: putText "Ready tasks:"
328: traverse_ printTask tasks
329: | args `Cli.has` Cli.command "show" = do
330: tid <- getArgText args "id"
331: tasks <- loadTasks
332: case findTask tid tasks of
333: Nothing -> putText "Task not found"
334: Just task ->
335: if isJsonMode args
336: then outputJson task
337: else showTaskDetailed task
338: | args `Cli.has` Cli.command "update" = do
339: tid <- getArgText args "id"
340: statusStr <- getArgText args "status"
341: let isVerified = args `Cli.has` Cli.longOption "verified"
342:
343: -- Handle update dependencies
344: deps <- do
345: -- Parse --deps and --dep-type
346: ids <- case Cli.getArg args (Cli.longOption "deps") of
347: Nothing -> pure []
348: Just depStr -> pure <| T.splitOn "," (T.pack depStr)
349: dtype <- case Cli.getArg args (Cli.longOption "dep-type") of
350: Nothing -> pure Blocks
351: Just "blocks" -> pure Blocks
352: Just "discovered-from" -> pure DiscoveredFrom
353: Just "parent-child" -> pure ParentChild
354: Just "related" -> pure Related
355: Just other -> panic <| "Invalid dependency type: " <> T.pack other <> ". Use: blocks, discovered-from, parent-child, or related"
356: pure (map (\d -> Dependency {depId = d, depType = dtype}) ids)
357:
358: let newStatus = case statusStr of
359: "draft" -> Draft
360: "open" -> Open
361: "in-progress" -> InProgress
362: "review" -> Review
363: "approved" -> Approved
364: "done" -> Done
365: _ -> panic "Invalid status. Use: draft, open, in-progress, review, approved, or done"
366:
367: -- Show verification checklist warning when marking Done without --verified
368: when (newStatus == Done && not isVerified && not (isJsonMode args)) <| do
369: putText ""
370: putText "⚠️ VERIFICATION CHECKLIST (use --verified to skip):"
371: putText " [ ] Code compiles (bild succeeds)"
372: putText " [ ] Tests pass (bild --test)"
373: putText " [ ] Feature works in production (manual verification)"
374: putText ""
375:
376: updateTaskStatusWithActor tid newStatus deps Human
377:
378: -- Record verification in activity log if verified
379: when (newStatus == Done && isVerified)
380: <| logActivity tid Completed (Just "{\"verified\":true}")
381:
382: if isJsonMode args
383: then
384: if newStatus == Done && isVerified
385: then outputJson <| Aeson.object ["success" Aeson..= True, "message" Aeson..= ("Updated task " <> tid), "verified" Aeson..= True]
386: else outputSuccess <| "Updated task " <> tid
387: else
388: if newStatus == Done && isVerified
389: then putStrLn <| "Updated task " <> T.unpack tid <> " (verified ✓)"
390: else putStrLn <| "Updated task " <> T.unpack tid
391: | args `Cli.has` Cli.command "deps" = do
392: tid <- getArgText args "id"
393: if isJsonMode args
394: then do
395: deps <- getDependencyTree tid
396: outputJson deps
397: else showDependencyTree tid
398: | args `Cli.has` Cli.command "tree" = do
399: maybeId <- case Cli.getArg args (Cli.argument "id") of
400: Nothing -> pure Nothing
401: Just idStr -> pure <| Just (T.pack idStr)
402: if isJsonMode args
403: then do
404: tree <- getTaskTree maybeId
405: outputJson tree
406: else showTaskTree maybeId
407: | args `Cli.has` Cli.command "progress" = do
408: tid <- getArgText args "id"
409: if isJsonMode args
410: then do
411: progress <- getTaskProgress tid
412: outputJson progress
413: else showTaskProgress tid
414: | args `Cli.has` Cli.command "stats" = do
415: maybeEpic <- case Cli.getArg args (Cli.longOption "epic") of
416: Nothing -> pure Nothing
417: Just e -> pure <| Just (T.pack e)
418: if isJsonMode args
419: then do
420: stats <- getTaskStats maybeEpic
421: outputJson stats
422: else showTaskStats maybeEpic
423: | args `Cli.has` Cli.command "log" = do
424: tid <- getArgText args "id"
425: let maybeSession = T.pack </ Cli.getArg args (Cli.longOption "session")
426: followMode = args `Cli.has` Cli.longOption "follow"
427: if followMode
428: then followTaskLog tid maybeSession
429: else showTaskLog tid maybeSession (isJsonMode args)
430: | args `Cli.has` Cli.command "export" = do
431: file <- case Cli.getArg args (Cli.shortOption 'o') of
432: Nothing -> pure Nothing
433: Just f -> pure (Just f)
434: exportTasks file
435: case file of
436: Just f -> putText <| "Exported tasks to " <> T.pack f
437: Nothing -> pure ()
438: | args `Cli.has` Cli.command "import" = do
439: -- Note: -i <file> means the value is stored in option 'i', not argument "file"
440: file <- case Cli.getArg args (Cli.shortOption 'i') of
441: Nothing -> panic "import requires -i <file>"
442: Just f -> pure (T.pack f)
443: importTasks (T.unpack file)
444: putText <| "Imported tasks from " <> file
445: | otherwise = putText (T.pack <| Cli.usage help)
446: where
447: getArgText :: Cli.Arguments -> String -> IO Text
448: getArgText argz name = do
449: maybeArg <- pure <| Cli.getArg argz (Cli.argument name)
450: case maybeArg of
451: Nothing -> panic (T.pack name <> " required")
452: Just val -> pure (T.pack val)
453:
454: -- | Show task log for a given task ID and optional session
455: showTaskLog :: Text -> Maybe Text -> Bool -> IO ()
456: showTaskLog tid maybeSession jsonMode = do
457: events <- case maybeSession of
458: Just sid -> getEventsForSession sid
459: Nothing -> getEventsForTask tid
460:
461: when (null events && not jsonMode) <| do
462: putText "No events found for this task."
463:
464: if jsonMode
465: then outputJson events
466: else traverse_ printEvent events
467:
468: -- | Follow task log in real-time (poll for new events)
469: followTaskLog :: Text -> Maybe Text -> IO ()
470: followTaskLog tid maybeSession = do
471: -- Get session ID (use provided or get latest)
472: sid <- getSid
473:
474: -- Print initial events
475: events <- getEventsForSession sid
476: traverse_ printEvent events
477:
478: -- Start polling for new events
479: let lastEventId = if null events then 0 else maximum (map storedEventId events)
480: pollEvents sid lastEventId
481: where
482: getSid = case maybeSession of
483: Just s -> pure s
484: Nothing -> do
485: maybeSid <- getLatestSessionForTask tid
486: case maybeSid of
487: Nothing -> do
488: putText "No session found for this task. Waiting for events..."
489: threadDelay 1000000
490: getSid -- Recursively retry
491: Just s -> pure s
492:
493: pollEvents sid lastId = do
494: threadDelay 500000 -- Poll every 500ms
495: newEvents <- getEventsSince sid lastId
496: unless (null newEvents) <| do
497: traverse_ printEvent newEvents
498: let newLastId = if null newEvents then lastId else maximum (map storedEventId newEvents)
499: pollEvents sid newLastId
500:
501: -- | Print a single event in human-readable format
502: printEvent :: StoredEvent -> IO ()
503: printEvent event = do
504: let timestamp = storedEventTimestamp event
505: eventType = storedEventType event
506: content = storedEventContent event
507:
508: -- Format timestamp as HH:MM:SS
509: let timeStr = T.pack <| formatTime defaultTimeLocale "%H:%M:%S" timestamp
510:
511: -- Parse and format the content based on event type
512: let formatted = case eventType of
513: "Assistant" -> formatAssistant content
514: "ToolCall" -> formatToolCall content
515: "ToolResult" -> formatToolResult content
516: "Cost" -> formatCost content
517: "Error" -> formatError content
518: "Complete" -> "Complete"
519: _ -> eventType <> ": " <> content
520:
521: putText ("[" <> timeStr <> "] " <> formatted)
522:
523: -- Format Assistant messages
524: formatAssistant :: Text -> Text
525: formatAssistant content =
526: case Aeson.decode (BLC.pack <| T.unpack content) of
527: Just (Aeson.String msg) -> "Assistant: " <> truncateText 200 msg
528: _ -> "Assistant: " <> truncateText 200 content
529:
530: -- Format ToolCall events
531: formatToolCall :: Text -> Text
532: formatToolCall content =
533: case Aeson.decode (BLC.pack <| T.unpack content) of
534: Just (Aeson.String msg) -> "Tool: " <> msg
535: Just (Aeson.Object obj) ->
536: let toolName = case KM.lookup "tool" obj of
537: Just (Aeson.String n) -> n
538: _ -> "<unknown>"
539: args = case KM.lookup "args" obj of
540: Just val -> " " <> TE.decodeUtf8 (BLC.toStrict (Aeson.encode val))
541: _ -> ""
542: in "Tool: " <> toolName <> args
543: _ -> "Tool: " <> truncateText 100 content
544:
545: -- Format ToolResult events
546: formatToolResult :: Text -> Text
547: formatToolResult content =
548: case Aeson.decode (BLC.pack <| T.unpack content) of
549: Just (Aeson.Object obj) ->
550: let toolName = case KM.lookup "tool" obj of
551: Just (Aeson.String n) -> n
552: _ -> "<unknown>"
553: success = case KM.lookup "success" obj of
554: Just (Aeson.Bool True) -> "ok"
555: Just (Aeson.Bool False) -> "failed"
556: _ -> "?"
557: output = case KM.lookup "output" obj of
558: Just (Aeson.String s) -> " (" <> tshow (T.length s) <> " bytes)"
559: _ -> ""
560: in "Result: " <> toolName <> " (" <> success <> ")" <> output
561: _ -> "Result: " <> truncateText 100 content
562:
563: -- Format Cost events
564: formatCost :: Text -> Text
565: formatCost content =
566: case Aeson.decode (BLC.pack <| T.unpack content) of
567: Just (Aeson.Object obj) ->
568: let tokens = case KM.lookup "tokens" obj of
569: Just (Aeson.Number n) -> tshow (round n :: Int)
570: _ -> "?"
571: cents = case KM.lookup "cents" obj of
572: Just (Aeson.Number n) -> tshow (round n :: Int)
573: _ -> "?"
574: in "Cost: " <> tokens <> " tokens, " <> cents <> " cents"
575: _ -> "Cost: " <> content
576:
577: -- Format Error events
578: formatError :: Text -> Text
579: formatError content =
580: case Aeson.decode (BLC.pack <| T.unpack content) of
581: Just (Aeson.String msg) -> "Error: " <> msg
582: _ -> "Error: " <> content
583:
584: -- Truncate text to a maximum length
585: truncateText :: Int -> Text -> Text
586: truncateText maxLen txt =
587: if T.length txt > maxLen
588: then T.take maxLen txt <> "..."
589: else txt
590:
591: test :: Test.Tree
592: test =
593: Test.group
594: "Omni.Task"
595: [ unitTests,
596: cliTests,
597: Tasty.after Tasty.AllSucceed "Unit tests" RaceTest.test,
598: Tasty.after Tasty.AllSucceed "Unit tests" MigrationTest.test
599: ]
600:
601: unitTests :: Test.Tree
602: unitTests =
603: Test.group
604: "Unit tests"
605: [ Test.unit "setup test database" <| do
606: -- Set up test mode for all tests (uses _/tmp/tasks-test.db)
607: setEnv "TASK_TEST_MODE" "1"
608:
609: -- Clean up test database before all tests
610: let testFile = "_/tmp/tasks-test.db"
611: createDirectoryIfMissing True "_/tmp"
612: exists <- doesFileExist testFile
613: when exists <| removeFile testFile
614: initTaskDb
615: True Test.@?= True,
616: Test.unit "can create task" <| do
617: task <- createTask "Test task" WorkTask Nothing Nothing P2 Nothing [] "Test description"
618: taskTitle task Test.@?= "Test task"
619: taskType task Test.@?= WorkTask
620: taskStatus task Test.@?= Open
621: taskPriority task Test.@?= P2
622: null (taskDependencies task) Test.@?= True,
623: Test.unit "can create human task" <| do
624: task <- createTask "Human Task" HumanTask Nothing Nothing P2 Nothing [] "Human task description"
625: taskType task Test.@?= HumanTask,
626: Test.unit "ready tasks exclude human tasks" <| do
627: task <- createTask "Human Task" HumanTask Nothing Nothing P2 Nothing [] "Human task"
628: ready <- getReadyTasks
629: (taskId task `notElem` map taskId ready) Test.@?= True,
630: Test.unit "ready tasks exclude draft tasks" <| do
631: task <- createTask "Draft Task" WorkTask Nothing Nothing P2 Nothing [] "Draft description"
632: updateTaskStatus (taskId task) Draft []
633: ready <- getReadyTasks
634: (taskId task `notElem` map taskId ready) Test.@?= True,
635: Test.unit "can create task with description" <| do
636: task <- createTask "Test task" WorkTask Nothing Nothing P2 Nothing [] "My description"
637: taskDescription task Test.@?= "My description",
638: Test.unit "can create task with complexity" <| do
639: task <- createTask "Complex task" WorkTask Nothing Nothing P2 (Just 4) [] "High complexity task"
640: taskComplexity task Test.@?= Just 4,
641: Test.unit "complexity is persisted" <| do
642: task <- createTask "Persisted complexity" WorkTask Nothing Nothing P2 (Just 3) [] "Medium complexity"
643: tasks <- loadTasks
644: case findTask (taskId task) tasks of
645: Nothing -> Test.assertFailure "Could not reload task"
646: Just reloaded -> taskComplexity reloaded Test.@?= Just 3,
647: Test.unit "can list tasks" <| do
648: _ <- createTask "Test task for list" WorkTask Nothing Nothing P2 Nothing [] "List test"
649: tasks <- listTasks Nothing Nothing Nothing Nothing
650: not (null tasks) Test.@?= True,
651: Test.unit "ready tasks exclude blocked ones" <| do
652: task1 <- createTask "First task" WorkTask Nothing Nothing P2 Nothing [] "First description"
653: let blockingDep = Dependency {depId = taskId task1, depType = Blocks}
654: task2 <- createTask "Blocked task" WorkTask Nothing Nothing P2 Nothing [blockingDep] "Blocked description"
655: ready <- getReadyTasks
656: (taskId task1 `elem` map taskId ready) Test.@?= True
657: (taskId task2 `notElem` map taskId ready) Test.@?= True,
658: Test.unit "discovered-from dependencies don't block" <| do
659: task1 <- createTask "Original task" WorkTask Nothing Nothing P2 Nothing [] "Original"
660: let discDep = Dependency {depId = taskId task1, depType = DiscoveredFrom}
661: task2 <- createTask "Discovered work" WorkTask Nothing Nothing P2 Nothing [discDep] "Discovered"
662: ready <- getReadyTasks
663: -- Both should be ready since DiscoveredFrom doesn't block
664: (taskId task1 `elem` map taskId ready) Test.@?= True
665: (taskId task2 `elem` map taskId ready) Test.@?= True,
666: Test.unit "related dependencies don't block" <| do
667: task1 <- createTask "Task A" WorkTask Nothing Nothing P2 Nothing [] "Task A description"
668: let relDep = Dependency {depId = taskId task1, depType = Related}
669: task2 <- createTask "Task B" WorkTask Nothing Nothing P2 Nothing [relDep] "Task B description"
670: ready <- getReadyTasks
671: -- Both should be ready since Related doesn't block
672: (taskId task1 `elem` map taskId ready) Test.@?= True
673: (taskId task2 `elem` map taskId ready) Test.@?= True,
674: Test.unit "ready tasks exclude epics" <| do
675: epic <- createTask "Epic task" Epic Nothing Nothing P2 Nothing [] "Epic description"
676: ready <- getReadyTasks
677: (taskId epic `notElem` map taskId ready) Test.@?= True,
678: Test.unit "ready tasks exclude tasks needing intervention (retry >= 3)" <| do
679: task <- createTask "Failing task" WorkTask Nothing Nothing P2 Nothing [] "Failing description"
680: ready1 <- getReadyTasks
681: (taskId task `elem` map taskId ready1) Test.@?= True
682: setRetryContext
683: RetryContext
684: { retryTaskId = taskId task,
685: retryOriginalCommit = "abc123",
686: retryConflictFiles = [],
687: retryAttempt = 3,
688: retryReason = "test_failure",
689: retryNotes = Nothing
690: }
691: ready2 <- getReadyTasks
692: (taskId task `notElem` map taskId ready2) Test.@?= True,
693: Test.unit "child task gets sequential ID" <| do
694: parent <- createTask "Parent" Epic Nothing Nothing P2 Nothing [] "Parent epic"
695: child1 <- createTask "Child 1" WorkTask (Just (taskId parent)) Nothing P2 Nothing [] "Child 1 description"
696: child2 <- createTask "Child 2" WorkTask (Just (taskId parent)) Nothing P2 Nothing [] "Child 2 description"
697: taskId child1 Test.@?= taskId parent <> ".1"
698: taskId child2 Test.@?= taskId parent <> ".2",
699: Test.unit "grandchild task gets sequential ID" <| do
700: parent <- createTask "Grandparent" Epic Nothing Nothing P2 Nothing [] "Grandparent epic"
701: child <- createTask "Parent" Epic (Just (taskId parent)) Nothing P2 Nothing [] "Parent epic"
702: grandchild <- createTask "Grandchild" WorkTask (Just (taskId child)) Nothing P2 Nothing [] "Grandchild task"
703: taskId grandchild Test.@?= taskId parent <> ".1.1",
704: Test.unit "siblings of grandchild task get sequential ID" <| do
705: parent <- createTask "Grandparent" Epic Nothing Nothing P2 Nothing [] "Grandparent"
706: child <- createTask "Parent" Epic (Just (taskId parent)) Nothing P2 Nothing [] "Parent"
707: grandchild1 <- createTask "Grandchild 1" WorkTask (Just (taskId child)) Nothing P2 Nothing [] "Grandchild 1"
708: grandchild2 <- createTask "Grandchild 2" WorkTask (Just (taskId child)) Nothing P2 Nothing [] "Grandchild 2"
709: taskId grandchild1 Test.@?= taskId parent <> ".1.1"
710: taskId grandchild2 Test.@?= taskId parent <> ".1.2",
711: Test.unit "child ID generation skips gaps" <| do
712: parent <- createTask "Parent with gaps" Epic Nothing Nothing P2 Nothing [] "Parent with gaps"
713: child1 <- createTask "Child 1" WorkTask (Just (taskId parent)) Nothing P2 Nothing [] "Child 1"
714: -- Manually create a task with .3 suffix to simulate a gap (or deleted task)
715: let child3Id = taskId parent <> ".3"
716: child3 =
717: Task
718: { taskId = child3Id,
719: taskTitle = "Child 3",
720: taskType = WorkTask,
721: taskParent = Just (taskId parent),
722: taskNamespace = Nothing,
723: taskStatus = Open,
724: taskPriority = P2,
725: taskComplexity = Nothing,
726: taskDependencies = [],
727: taskDescription = "Child 3",
728: taskComments = [],
729: taskCreatedAt = taskCreatedAt child1,
730: taskUpdatedAt = taskUpdatedAt child1
731: }
732: saveTask child3
733:
734: -- Create a new child, it should get .4, not .2
735: child4 <- createTask "Child 4" WorkTask (Just (taskId parent)) Nothing P2 Nothing [] "Child 4"
736: taskId child4 Test.@?= taskId parent <> ".4",
737: Test.unit "can edit task" <| do
738: task <- createTask "Original Title" WorkTask Nothing Nothing P2 Nothing [] "Original"
739: let modifyFn t = t {taskTitle = "New Title", taskPriority = P0}
740: updated <- editTask (taskId task) modifyFn
741: taskTitle updated Test.@?= "New Title"
742: taskPriority updated Test.@?= P0
743: -- Check persistence
744: tasks <- loadTasks
745: case findTask (taskId task) tasks of
746: Nothing -> Test.assertFailure "Could not reload task"
747: Just reloaded -> do
748: taskTitle reloaded Test.@?= "New Title"
749: taskPriority reloaded Test.@?= P0,
750: Test.unit "task lookup is case insensitive" <| do
751: task <- createTask "Case sensitive" WorkTask Nothing Nothing P2 Nothing [] "Case sensitive description"
752: let tid = taskId task
753: upperTid = T.toUpper tid
754: tasks <- loadTasks
755: let found = findTask upperTid tasks
756: case found of
757: Just t -> taskId t Test.@?= tid
758: Nothing -> Test.assertFailure "Could not find task with upper case ID",
759: Test.unit "namespace normalization handles .hs suffix" <| do
760: let ns = "Omni/Task.hs"
761: validNs = Namespace.fromHaskellModule ns
762: Namespace.toPath validNs Test.@?= "Omni/Task.hs",
763: Test.unit "generated IDs are lowercase" <| do
764: task <- createTask "Lowercase check" WorkTask Nothing Nothing P2 Nothing [] "Lowercase description"
765: let tid = taskId task
766: tid Test.@?= T.toLower tid
767: -- check it matches regex for base36 (t-[0-9a-z]+)
768: let isLowerBase36 = T.all (\c -> c `elem` ['0' .. '9'] ++ ['a' .. 'z'] || c == 't' || c == '-') tid
769: isLowerBase36 Test.@?= True,
770: Test.unit "dependencies are case insensitive" <| do
771: task1 <- createTask "Blocker" WorkTask Nothing Nothing P2 Nothing [] "Blocker description"
772: let tid1 = taskId task1
773: -- Use uppercase ID for dependency
774: upperTid1 = T.toUpper tid1
775: dep = Dependency {depId = upperTid1, depType = Blocks}
776: task2 <- createTask "Blocked" WorkTask Nothing Nothing P2 Nothing [dep] "Blocked description"
777:
778: -- task1 is Open, so task2 should NOT be ready
779: ready <- getReadyTasks
780: (taskId task2 `notElem` map taskId ready) Test.@?= True
781:
782: updateTaskStatus tid1 Done []
783:
784: -- task2 should now be ready because dependency check normalizes IDs
785: ready2 <- getReadyTasks
786: (taskId task2 `elem` map taskId ready2) Test.@?= True,
787: Test.unit "can create task with lowercase ID" <| do
788: -- This verifies that lowercase IDs are accepted and not rejected
789: let lowerId = "t-lowercase"
790: let task = Task lowerId "Lower" WorkTask Nothing Nothing Open P2 Nothing [] "Lower description" [] (read "2025-01-01 00:00:00 UTC") (read "2025-01-01 00:00:00 UTC")
791: saveTask task
792: tasks <- loadTasks
793: case findTask lowerId tasks of
794: Just t -> taskId t Test.@?= lowerId
795: Nothing -> Test.assertFailure "Should find task with lowercase ID",
796: Test.unit "generateId produces valid ID" <| do
797: tid <- generateId
798: let task = Task tid "Auto" WorkTask Nothing Nothing Open P2 Nothing [] "Auto description" [] (read "2025-01-01 00:00:00 UTC") (read "2025-01-01 00:00:00 UTC")
799: saveTask task
800: tasks <- loadTasks
801: case findTask tid tasks of
802: Just _ -> pure ()
803: Nothing -> Test.assertFailure "Should find generated task",
804: Test.unit "generateId produces sequential IDs" <| do
805: tid1 <- generateId
806: tid2 <- generateId
807: tid3 <- generateId
808: T.isPrefixOf "t-" tid1 Test.@?= True
809: T.isPrefixOf "t-" tid2 Test.@?= True
810: T.isPrefixOf "t-" tid3 Test.@?= True
811: let num1 = readMaybe (T.unpack (T.drop 2 tid1)) :: Maybe Int
812: num2 = readMaybe (T.unpack (T.drop 2 tid2)) :: Maybe Int
813: num3 = readMaybe (T.unpack (T.drop 2 tid3)) :: Maybe Int
814: case (num1, num2, num3) of
815: (Just n1, Just n2, Just n3) -> do
816: (n2 == n1 + 1) Test.@?= True
817: (n3 == n2 + 1) Test.@?= True
818: _ -> Test.assertFailure "IDs should be sequential integers",
819: Test.unit "lowercase ID does not clash with existing uppercase ID" <| do
820: -- Setup: Create task with Uppercase ID
821: let upperId = "t-UPPER"
822: let task1 = Task upperId "Upper Task" WorkTask Nothing Nothing Open P2 Nothing [] "Upper description" [] (read "2025-01-01 00:00:00 UTC") (read "2025-01-01 00:00:00 UTC")
823: saveTask task1
824:
825: -- Action: Try to create task with Lowercase ID (same letters)
826: -- Note: In the current implementation, saveTask blindly appends.
827: -- Ideally, we should be checking for existence if we want to avoid clash.
828: -- OR, we accept that they are the SAME task and this is an update?
829: -- But if they are different tasks (different titles, created at different times),
830: -- treating them as the same is dangerous.
831:
832: let lowerId = "t-upper"
833: let task2 = Task lowerId "Lower Task" WorkTask Nothing Nothing Open P2 Nothing [] "Lower description" [] (read "2025-01-01 00:00:01 UTC") (read "2025-01-01 00:00:01 UTC")
834: saveTask task2
835:
836: tasks <- loadTasks
837: -- What do we expect?
838: -- If we expect them to be distinct:
839: -- let foundUpper = List.find (\t -> taskId t == upperId) tasks
840: -- let foundLower = List.find (\t -> taskId t == lowerId) tasks
841: -- foundUpper /= Nothing
842: -- foundLower /= Nothing
843:
844: -- BUT findTask uses case-insensitive search.
845: -- So findTask upperId returns task1 (probably, as it's first).
846: -- findTask lowerId returns task1.
847: -- task2 is effectively hidden/lost to findTask.
848:
849: -- So, "do not clash" implies we shouldn't end up in this state.
850: -- The test should probably fail if we have multiple tasks that match the same ID case-insensitively.
851:
852: let matches = filter (\t -> matchesId (taskId t) upperId) tasks
853: length matches Test.@?= 2,
854: Test.unit "FromHttpApiData Priority: empty string returns Left" <| do
855: let result = parseQueryParam "" :: Either Text Priority
856: case result of
857: Left _ -> pure ()
858: Right _ -> Test.assertFailure "Empty string should return Left",
859: Test.unit "FromHttpApiData Priority: valid values parse correctly" <| do
860: (parseQueryParam "P0" :: Either Text Priority) Test.@?= Right P0
861: (parseQueryParam "P1" :: Either Text Priority) Test.@?= Right P1
862: (parseQueryParam "P2" :: Either Text Priority) Test.@?= Right P2
863: (parseQueryParam "P3" :: Either Text Priority) Test.@?= Right P3
864: (parseQueryParam "P4" :: Either Text Priority) Test.@?= Right P4,
865: Test.unit "FromHttpApiData Status: empty string returns Left" <| do
866: let result = parseQueryParam "" :: Either Text Status
867: case result of
868: Left _ -> pure ()
869: Right _ -> Test.assertFailure "Empty string should return Left",
870: Test.unit "FromHttpApiData Status: valid values parse correctly" <| do
871: (parseQueryParam "Open" :: Either Text Status) Test.@?= Right Open
872: (parseQueryParam "InProgress" :: Either Text Status) Test.@?= Right InProgress
873: (parseQueryParam "Done" :: Either Text Status) Test.@?= Right Done,
874: Test.unit "can add comment to task" <| do
875: task <- createTask "Task with comment" WorkTask Nothing Nothing P2 Nothing [] "Description"
876: updatedTask <- addComment (taskId task) "This is a test comment" Human
877: length (taskComments updatedTask) Test.@?= 1
878: case taskComments updatedTask of
879: (c : _) -> do
880: commentText c Test.@?= "This is a test comment"
881: commentAuthor c Test.@?= Human
882: [] -> Test.assertFailure "Expected at least one comment",
883: Test.unit "can add multiple comments to task" <| do
884: task <- createTask "Task with comments" WorkTask Nothing Nothing P2 Nothing [] "Description"
885: _ <- addComment (taskId task) "First comment" Junior
886: updatedTask <- addComment (taskId task) "Second comment" Human
887: length (taskComments updatedTask) Test.@?= 2
888: case taskComments updatedTask of
889: (c1 : c2 : _) -> do
890: commentText c1 Test.@?= "First comment"
891: commentAuthor c1 Test.@?= Junior
892: commentText c2 Test.@?= "Second comment"
893: commentAuthor c2 Test.@?= Human
894: _ -> Test.assertFailure "Expected at least two comments",
895: Test.unit "comments are persisted" <| do
896: task <- createTask "Persistent comments" WorkTask Nothing Nothing P2 Nothing [] "Description"
897: _ <- addComment (taskId task) "Persisted comment" Junior
898: tasks <- loadTasks
899: case findTask (taskId task) tasks of
900: Nothing -> Test.assertFailure "Could not reload task"
901: Just reloaded -> do
902: length (taskComments reloaded) Test.@?= 1
903: case taskComments reloaded of
904: (c : _) -> commentText c Test.@?= "Persisted comment"
905: [] -> Test.assertFailure "Expected at least one comment"
906: ]
907:
908: -- | Test CLI argument parsing to ensure docopt string matches actual usage
909: cliTests :: Test.Tree
910: cliTests =
911: Test.group
912: "CLI argument parsing"
913: [ Test.unit "init command" <| do
914: let result = Docopt.parseArgs help ["init"]
915: case result of
916: Left err -> Test.assertFailure <| "Failed to parse 'init': " <> show err
917: Right args -> args `Cli.has` Cli.command "init" Test.@?= True,
918: Test.unit "init with --quiet flag" <| do
919: let result = Docopt.parseArgs help ["init", "--quiet"]
920: case result of
921: Left err -> Test.assertFailure <| "Failed to parse 'init --quiet': " <> show err
922: Right args -> do
923: args `Cli.has` Cli.command "init" Test.@?= True
924: args `Cli.has` Cli.longOption "quiet" Test.@?= True,
925: Test.unit "create with title" <| do
926: let result = Docopt.parseArgs help ["create", "Test task"]
927: case result of
928: Left err -> Test.assertFailure <| "Failed to parse 'create': " <> show err
929: Right args -> do
930: args `Cli.has` Cli.command "create" Test.@?= True
931: Cli.getArg args (Cli.argument "title") Test.@?= Just "Test task",
932: Test.unit "create with --json flag" <| do
933: let result = Docopt.parseArgs help ["create", "Test", "--json"]
934: case result of
935: Left err -> Test.assertFailure <| "Failed to parse 'create --json': " <> show err
936: Right args -> do
937: args `Cli.has` Cli.command "create" Test.@?= True
938: args `Cli.has` Cli.longOption "json" Test.@?= True,
939: Test.unit "create with --namespace flag" <| do
940: let result = Docopt.parseArgs help ["create", "Test", "--namespace=Omni/Task"]
941: case result of
942: Left err -> Test.assertFailure <| "Failed to parse 'create --namespace': " <> show err
943: Right args -> do
944: args `Cli.has` Cli.command "create" Test.@?= True
945: Cli.getArg args (Cli.longOption "namespace") Test.@?= Just "Omni/Task",
946: Test.unit "create with --discovered-from flag" <| do
947: let result = Docopt.parseArgs help ["create", "Test", "--discovered-from=t-abc123"]
948: case result of
949: Left err -> Test.assertFailure <| "Failed to parse 'create --discovered-from': " <> show err
950: Right args -> do
951: args `Cli.has` Cli.command "create" Test.@?= True
952: Cli.getArg args (Cli.longOption "discovered-from") Test.@?= Just "t-abc123",
953: Test.unit "create with --priority flag" <| do
954: let result = Docopt.parseArgs help ["create", "Test", "--priority=1"]
955: case result of
956: Left err -> Test.assertFailure <| "Failed to parse 'create --priority': " <> show err
957: Right args -> do
958: args `Cli.has` Cli.command "create" Test.@?= True
959: Cli.getArg args (Cli.longOption "priority") Test.@?= Just "1",
960: Test.unit "create with --complexity flag" <| do
961: let result = Docopt.parseArgs help ["create", "Test", "--complexity=3"]
962: case result of
963: Left err -> Test.assertFailure <| "Failed to parse 'create --complexity': " <> show err
964: Right args -> do
965: args `Cli.has` Cli.command "create" Test.@?= True
966: Cli.getArg args (Cli.longOption "complexity") Test.@?= Just "3",
967: Test.unit "edit with --complexity flag" <| do
968: let result = Docopt.parseArgs help ["edit", "t-abc123", "--complexity=4"]
969: case result of
970: Left err -> Test.assertFailure <| "Failed to parse 'edit --complexity': " <> show err
971: Right args -> do
972: args `Cli.has` Cli.command "edit" Test.@?= True
973: Cli.getArg args (Cli.longOption "complexity") Test.@?= Just "4",
974: Test.unit "edit command" <| do
975: let result = Docopt.parseArgs help ["edit", "t-abc123"]
976: case result of
977: Left err -> Test.assertFailure <| "Failed to parse 'edit': " <> show err
978: Right args -> do
979: args `Cli.has` Cli.command "edit" Test.@?= True
980: Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123",
981: Test.unit "edit with options" <| do
982: let result = Docopt.parseArgs help ["edit", "t-abc123", "--title=New Title", "--priority=0"]
983: case result of
984: Left err -> Test.assertFailure <| "Failed to parse 'edit' with options: " <> show err
985: Right args -> do
986: args `Cli.has` Cli.command "edit" Test.@?= True
987: Cli.getArg args (Cli.longOption "title") Test.@?= Just "New Title"
988: Cli.getArg args (Cli.longOption "priority") Test.@?= Just "0",
989: Test.unit "list command" <| do
990: let result = Docopt.parseArgs help ["list"]
991: case result of
992: Left err -> Test.assertFailure <| "Failed to parse 'list': " <> show err
993: Right args -> args `Cli.has` Cli.command "list" Test.@?= True,
994: Test.unit "list with --json flag" <| do
995: let result = Docopt.parseArgs help ["list", "--json"]
996: case result of
997: Left err -> Test.assertFailure <| "Failed to parse 'list --json': " <> show err
998: Right args -> do
999: args `Cli.has` Cli.command "list" Test.@?= True
1000: args `Cli.has` Cli.longOption "json" Test.@?= True,
1001: Test.unit "list with --status filter" <| do
1002: let result = Docopt.parseArgs help ["list", "--status=open"]
1003: case result of
1004: Left err -> Test.assertFailure <| "Failed to parse 'list --status': " <> show err
1005: Right args -> do
1006: args `Cli.has` Cli.command "list" Test.@?= True
1007: Cli.getArg args (Cli.longOption "status") Test.@?= Just "open",
1008: Test.unit "list with --status=approved filter" <| do
1009: let result = Docopt.parseArgs help ["list", "--status=approved"]
1010: case result of
1011: Left err -> Test.assertFailure <| "Failed to parse 'list --status=approved': " <> show err
1012: Right args -> do
1013: args `Cli.has` Cli.command "list" Test.@?= True
1014: Cli.getArg args (Cli.longOption "status") Test.@?= Just "approved",
1015: Test.unit "list with --status=draft filter" <| do
1016: let result = Docopt.parseArgs help ["list", "--status=draft"]
1017: case result of
1018: Left err -> Test.assertFailure <| "Failed to parse 'list --status=draft': " <> show err
1019: Right args -> do
1020: args `Cli.has` Cli.command "list" Test.@?= True
1021: Cli.getArg args (Cli.longOption "status") Test.@?= Just "draft",
1022: Test.unit "ready command" <| do
1023: let result = Docopt.parseArgs help ["ready"]
1024: case result of
1025: Left err -> Test.assertFailure <| "Failed to parse 'ready': " <> show err
1026: Right args -> args `Cli.has` Cli.command "ready" Test.@?= True,
1027: Test.unit "ready with --json flag" <| do
1028: let result = Docopt.parseArgs help ["ready", "--json"]
1029: case result of
1030: Left err -> Test.assertFailure <| "Failed to parse 'ready --json': " <> show err
1031: Right args -> do
1032: args `Cli.has` Cli.command "ready" Test.@?= True
1033: args `Cli.has` Cli.longOption "json" Test.@?= True,
1034: Test.unit "update command" <| do
1035: let result = Docopt.parseArgs help ["update", "t-abc123", "done"]
1036: case result of
1037: Left err -> Test.assertFailure <| "Failed to parse 'update': " <> show err
1038: Right args -> do
1039: args `Cli.has` Cli.command "update" Test.@?= True
1040: Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123"
1041: Cli.getArg args (Cli.argument "status") Test.@?= Just "done",
1042: Test.unit "update command with approved" <| do
1043: let result = Docopt.parseArgs help ["update", "t-abc123", "approved"]
1044: case result of
1045: Left err -> Test.assertFailure <| "Failed to parse 'update ... approved': " <> show err
1046: Right args -> do
1047: args `Cli.has` Cli.command "update" Test.@?= True
1048: Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123"
1049: Cli.getArg args (Cli.argument "status") Test.@?= Just "approved",
1050: Test.unit "update command with draft" <| do
1051: let result = Docopt.parseArgs help ["update", "t-abc123", "draft"]
1052: case result of
1053: Left err -> Test.assertFailure <| "Failed to parse 'update ... draft': " <> show err
1054: Right args -> do
1055: args `Cli.has` Cli.command "update" Test.@?= True
1056: Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123"
1057: Cli.getArg args (Cli.argument "status") Test.@?= Just "draft",
1058: Test.unit "update with --json flag" <| do
1059: let result = Docopt.parseArgs help ["update", "t-abc123", "done", "--json"]
1060: case result of
1061: Left err -> Test.assertFailure <| "Failed to parse 'update --json': " <> show err
1062: Right args -> do
1063: args `Cli.has` Cli.command "update" Test.@?= True
1064: args `Cli.has` Cli.longOption "json" Test.@?= True,
1065: Test.unit "update with --verified flag" <| do
1066: let result = Docopt.parseArgs help ["update", "t-abc123", "done", "--verified"]
1067: case result of
1068: Left err -> Test.assertFailure <| "Failed to parse 'update --verified': " <> show err
1069: Right args -> do
1070: args `Cli.has` Cli.command "update" Test.@?= True
1071: args `Cli.has` Cli.longOption "verified" Test.@?= True,
1072: Test.unit "update with --verified and --json flags" <| do
1073: let result = Docopt.parseArgs help ["update", "t-abc123", "done", "--verified", "--json"]
1074: case result of
1075: Left err -> Test.assertFailure <| "Failed to parse 'update --verified --json': " <> show err
1076: Right args -> do
1077: args `Cli.has` Cli.command "update" Test.@?= True
1078: args `Cli.has` Cli.longOption "verified" Test.@?= True
1079: args `Cli.has` Cli.longOption "json" Test.@?= True,
1080: Test.unit "deps command" <| do
1081: let result = Docopt.parseArgs help ["deps", "t-abc123"]
1082: case result of
1083: Left err -> Test.assertFailure <| "Failed to parse 'deps': " <> show err
1084: Right args -> do
1085: args `Cli.has` Cli.command "deps" Test.@?= True
1086: Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123",
1087: Test.unit "tree command" <| do
1088: let result = Docopt.parseArgs help ["tree"]
1089: case result of
1090: Left err -> Test.assertFailure <| "Failed to parse 'tree': " <> show err
1091: Right args -> args `Cli.has` Cli.command "tree" Test.@?= True,
1092: Test.unit "tree with id" <| do
1093: let result = Docopt.parseArgs help ["tree", "t-abc123"]
1094: case result of
1095: Left err -> Test.assertFailure <| "Failed to parse 'tree <id>': " <> show err
1096: Right args -> do
1097: args `Cli.has` Cli.command "tree" Test.@?= True
1098: Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123",
1099: Test.unit "export command" <| do
1100: let result = Docopt.parseArgs help ["export"]
1101: case result of
1102: Left err -> Test.assertFailure <| "Failed to parse 'export': " <> show err
1103: Right args -> args `Cli.has` Cli.command "export" Test.@?= True,
1104: Test.unit "import command" <| do
1105: let result = Docopt.parseArgs help ["import", "-i", "tasks.jsonl"]
1106: case result of
1107: Left err -> Test.assertFailure <| "Failed to parse 'import': " <> show err
1108: Right args -> do
1109: args `Cli.has` Cli.command "import" Test.@?= True
1110: -- Note: -i is a short option, not an argument
1111: Cli.getArg args (Cli.shortOption 'i') Test.@?= Just "tasks.jsonl",
1112: Test.unit "show command" <| do
1113: let result = Docopt.parseArgs help ["show", "t-abc123"]
1114: case result of
1115: Left err -> Test.assertFailure <| "Failed to parse 'show': " <> show err
1116: Right args -> do
1117: args `Cli.has` Cli.command "show" Test.@?= True
1118: Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123",
1119: Test.unit "show with --json flag" <| do
1120: let result = Docopt.parseArgs help ["show", "t-abc123", "--json"]
1121: case result of
1122: Left err -> Test.assertFailure <| "Failed to parse 'show --json': " <> show err
1123: Right args -> do
1124: args `Cli.has` Cli.command "show" Test.@?= True
1125: args `Cli.has` Cli.longOption "json" Test.@?= True,
1126: Test.unit "stats command" <| do
1127: let result = Docopt.parseArgs help ["stats"]
1128: case result of
1129: Left err -> Test.assertFailure <| "Failed to parse 'stats': " <> show err
1130: Right args -> args `Cli.has` Cli.command "stats" Test.@?= True,
1131: Test.unit "stats with --json flag" <| do
1132: let result = Docopt.parseArgs help ["stats", "--json"]
1133: case result of
1134: Left err -> Test.assertFailure <| "Failed to parse 'stats --json': " <> show err
1135: Right args -> do
1136: args `Cli.has` Cli.command "stats" Test.@?= True
1137: args `Cli.has` Cli.longOption "json" Test.@?= True,
1138: Test.unit "stats with --epic flag" <| do
1139: let result = Docopt.parseArgs help ["stats", "--epic=t-abc123"]
1140: case result of
1141: Left err -> Test.assertFailure <| "Failed to parse 'stats --epic': " <> show err
1142: Right args -> do
1143: args `Cli.has` Cli.command "stats" Test.@?= True
1144: Cli.getArg args (Cli.longOption "epic") Test.@?= Just "t-abc123",
1145: Test.unit "create with flags in different order" <| do
1146: let result = Docopt.parseArgs help ["create", "Test", "--json", "--priority=1", "--namespace=Omni/Task"]
1147: case result of
1148: Left err -> Test.assertFailure <| "Failed to parse 'create' with reordered flags: " <> show err
1149: Right args -> do
1150: args `Cli.has` Cli.command "create" Test.@?= True
1151: args `Cli.has` Cli.longOption "json" Test.@?= True
1152: Cli.getArg args (Cli.longOption "priority") Test.@?= Just "1"
1153: Cli.getArg args (Cli.longOption "namespace") Test.@?= Just "Omni/Task",
1154: Test.unit "comment command" <| do
1155: let result = Docopt.parseArgs help ["comment", "t-abc123", "This is a comment"]
1156: case result of
1157: Left err -> Test.assertFailure <| "Failed to parse 'comment': " <> show err
1158: Right args -> do
1159: args `Cli.has` Cli.command "comment" Test.@?= True
1160: Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123"
1161: Cli.getArg args (Cli.argument "message") Test.@?= Just "This is a comment",
1162: Test.unit "comment with --json flag" <| do
1163: let result = Docopt.parseArgs help ["comment", "t-abc123", "Test comment", "--json"]
1164: case result of
1165: Left err -> Test.assertFailure <| "Failed to parse 'comment --json': " <> show err
1166: Right args -> do
1167: args `Cli.has` Cli.command "comment" Test.@?= True
1168: args `Cli.has` Cli.longOption "json" Test.@?= True,
1169: Test.unit "log command" <| do
1170: let result = Docopt.parseArgs help ["log", "t-123"]
1171: case result of
1172: Left err -> Test.assertFailure <| "Failed to parse 'log': " <> show err
1173: Right args -> do
1174: args `Cli.has` Cli.command "log" Test.@?= True
1175: Cli.getArg args (Cli.argument "id") Test.@?= Just "t-123",
1176: Test.unit "log command with --session flag" <| do
1177: let result = Docopt.parseArgs help ["log", "t-123", "--session=s-456"]
1178: case result of
1179: Left err -> Test.assertFailure <| "Failed to parse 'log --session': " <> show err
1180: Right args -> do
1181: args `Cli.has` Cli.command "log" Test.@?= True
1182: Cli.getArg args (Cli.argument "id") Test.@?= Just "t-123"
1183: Cli.getArg args (Cli.longOption "session") Test.@?= Just "s-456",
1184: Test.unit "log command with --follow flag" <| do
1185: let result = Docopt.parseArgs help ["log", "t-123", "--follow"]
1186: case result of
1187: Left err -> Test.assertFailure <| "Failed to parse 'log --follow': " <> show err
1188: Right args -> do
1189: args `Cli.has` Cli.command "log" Test.@?= True
1190: args `Cli.has` Cli.longOption "follow" Test.@?= True,
1191: Test.unit "log command with --json flag" <| do
1192: let result = Docopt.parseArgs help ["log", "t-123", "--json"]
1193: case result of
1194: Left err -> Test.assertFailure <| "Failed to parse 'log --json': " <> show err
1195: Right args -> do
1196: args `Cli.has` Cli.command "log" Test.@?= True
1197: args `Cli.has` Cli.longOption "json" Test.@?= True
1198: ]
Now let me look at Omni/Task/Core.hs to understand the current TaskType and Status definitions:
Omni/Task/Core.hs1: {-# LANGUAGE DeriveGeneric #-}
2: {-# LANGUAGE OverloadedStrings #-}
3: {-# LANGUAGE ScopedTypeVariables #-}
4: {-# LANGUAGE NoImplicitPrelude #-}
5:
6: -- : dep http-api-data
7: module Omni.Task.Core where
8:
9: import Alpha
10: import Data.Aeson (FromJSON, ToJSON, decode, encode)
11: import qualified Data.Aeson as Aeson
12: import qualified Data.Aeson.KeyMap as KeyMap
13: import qualified Data.ByteString.Lazy.Char8 as BLC
14: import qualified Data.List as List
15: import qualified Data.Set as Set
16: import qualified Data.Text as T
17: import qualified Data.Text.IO as TIO
18: import Data.Time (UTCTime, diffUTCTime, getCurrentTime)
19: import qualified Database.SQLite.Simple as SQL
20: import qualified Database.SQLite.Simple.FromField as SQL
21: import qualified Database.SQLite.Simple.Ok as SQLOk
22: import qualified Database.SQLite.Simple.ToField as SQL
23: import GHC.Generics ()
24: import System.Directory (XdgDirectory (..), createDirectoryIfMissing, doesFileExist, getXdgDirectory)
25: import System.Environment (lookupEnv)
26: import System.FilePath (takeDirectory, (</>))
27: import System.IO.Unsafe (unsafePerformIO)
28: import Web.HttpApiData (FromHttpApiData (..))
29:
30: -- Core data types
31: data Task = Task
32: { taskId :: Text,
33: taskTitle :: Text,
34: taskType :: TaskType,
35: taskParent :: Maybe Text, -- Parent epic ID
36: taskNamespace :: Maybe Text, -- Optional namespace (e.g., "Omni/Task", "Biz/Cloud")
37: taskStatus :: Status,
38: taskPriority :: Priority, -- Priority level (0-4)
39: taskComplexity :: Maybe Int, -- Complexity 1-5 for model selection
40: taskDependencies :: [Dependency], -- List of dependencies with types
41: taskDescription :: Text, -- Required description
42: taskComments :: [Comment], -- Timestamped comments for extra context
43: taskCreatedAt :: UTCTime,
44: taskUpdatedAt :: UTCTime
45: }
46: deriving (Show, Eq, Generic)
47:
48: data TaskType = Epic | WorkTask | HumanTask
49: deriving (Show, Eq, Read, Generic)
50:
51: data Status = Draft | Open | InProgress | Review | Approved | Done
52: deriving (Show, Eq, Read, Generic)
53:
54: -- Priority levels (matching beads convention)
55: data Priority = P0 | P1 | P2 | P3 | P4
56: deriving (Show, Eq, Ord, Read, Generic)
57:
58: data Dependency = Dependency
59: { depId :: Text, -- ID of the task this depends on
60: depType :: DependencyType -- Type of dependency relationship
61: }
62: deriving (Show, Eq, Generic)
63:
64: data DependencyType
65: = Blocks -- Hard dependency, blocks ready work queue
66: | DiscoveredFrom -- Work discovered during other work
67: | ParentChild -- Epic/subtask relationship
68: | Related -- Soft relationship, doesn't block
69: deriving (Show, Eq, Read, Generic)
70:
71: data TaskProgress = TaskProgress
72: { progressTaskId :: Text,
73: progressTotal :: Int,
74: progressCompleted :: Int,
75: progressPercentage :: Int
76: }
77: deriving (Show, Eq, Generic)
78:
79: data EpicForReview = EpicForReview
80: { epicTask :: Task,
81: epicTotal :: Int,
82: epicCompleted :: Int
83: }
84: deriving (Show, Eq, Generic)
85:
86: data HumanActionItems = HumanActionItems
87: { failedTasks :: [Task],
88: epicsInReview :: [EpicForReview],
89: humanTasks :: [Task]
90: }
91: deriving (Show, Eq, Generic)
92:
93: data AggregatedMetrics = AggregatedMetrics
94: { aggTotalCostCents :: Int,
95: aggTotalDurationSeconds :: Int,
96: aggCompletedTasks :: Int,
97: aggTotalTokens :: Int
98: }
99: deriving (Show, Eq, Generic)
100:
101: -- Retry context for tasks that failed due to merge conflicts
102: data RetryContext = RetryContext
103: { retryTaskId :: Text,
104: retryOriginalCommit :: Text,
105: retryConflictFiles :: [Text],
106: retryAttempt :: Int,
107: retryReason :: Text, -- "merge_conflict" | "ci_failure" | "rejected"
108: retryNotes :: Maybe Text -- Human notes/guidance for intervention
109: }
110: deriving (Show, Eq, Generic)
111:
112: -- Activity stage for task_activity tracking
113: data ActivityStage = Claiming | Running | Reviewing | Retrying | Completed | Failed
114: deriving (Show, Eq, Read, Generic)
115:
116: -- Task activity log entry
117: data TaskActivity = TaskActivity
118: { activityId :: Maybe Int, -- NULL for new entries, set by DB
119: activityTaskId :: Text,
120: activityTimestamp :: UTCTime,
121: activityStage :: ActivityStage,
122: activityMessage :: Maybe Text,
123: activityMetadata :: Maybe Text, -- JSON for extra data
124: activityThreadUrl :: Maybe Text, -- Link to agent session (unused with native Engine)
125: activityStartedAt :: Maybe UTCTime, -- When work started
126: activityCompletedAt :: Maybe UTCTime, -- When work completed
127: activityCostCents :: Maybe Int, -- API cost in cents
128: activityTokensUsed :: Maybe Int -- Total tokens used
129: }
130: deriving (Show, Eq, Generic)
131:
132: -- Fact for knowledge base
133: data Fact = Fact
134: { factId :: Maybe Int,
135: factProject :: Text,
136: factContent :: Text,
137: factRelatedFiles :: [Text],
138: factSourceTask :: Maybe Text,
139: factConfidence :: Double,
140: factCreatedAt :: UTCTime
141: }
142: deriving (Show, Eq, Generic)
143:
144: -- Comment/event author (also used as Actor for timeline events)
145: data CommentAuthor = Human | Junior | System
146: deriving (Show, Eq, Read, Generic)
147:
148: -- Comment for task notes/context
149: data Comment = Comment
150: { commentText :: Text,
151: commentAuthor :: CommentAuthor,
152: commentCreatedAt :: UTCTime
153: }
154: deriving (Show, Eq, Generic)
155:
156: instance ToJSON TaskType
157:
158: instance FromJSON TaskType
159:
160: instance ToJSON Status
161:
162: instance FromJSON Status
163:
164: instance ToJSON Priority
165:
166: instance FromJSON Priority
167:
168: instance ToJSON DependencyType
169:
170: instance FromJSON DependencyType
171:
172: instance ToJSON Dependency
173:
174: instance FromJSON Dependency
175:
176: instance ToJSON Task
177:
178: instance FromJSON Task
179:
180: instance ToJSON TaskProgress
181:
182: instance FromJSON TaskProgress
183:
184: instance ToJSON AggregatedMetrics
185:
186: instance FromJSON AggregatedMetrics
187:
188: instance ToJSON RetryContext
189:
190: instance FromJSON RetryContext
191:
192: instance ToJSON ActivityStage
193:
194: instance FromJSON ActivityStage
195:
196: instance ToJSON TaskActivity
197:
198: instance FromJSON TaskActivity
199:
200: instance ToJSON Fact
201:
202: instance FromJSON Fact
203:
204: instance ToJSON CommentAuthor
205:
206: instance FromJSON CommentAuthor
207:
208: instance ToJSON Comment
209:
210: instance FromJSON Comment
211:
212: -- HTTP API Instances (for Servant query params)
213:
214: instance FromHttpApiData Status where
215: parseQueryParam t
216: | T.null t = Left "No status provided"
217: | otherwise = case readMaybe (T.unpack t) of
218: Just s -> Right s
219: Nothing -> Left ("Invalid status: " <> t)
220:
221: instance FromHttpApiData Priority where
222: parseQueryParam t
223: | T.null t = Left "No priority provided"
224: | otherwise = case readMaybe (T.unpack t) of
225: Just p -> Right p
226: Nothing -> Left ("Invalid priority: " <> t)
227:
228: -- SQLite Instances
229:
230: instance SQL.FromField TaskType where
231: fromField f = do
232: t <- SQL.fromField f :: SQLOk.Ok String
233: case readMaybe t of
234: Just x -> pure x
235: Nothing -> SQL.returnError SQL.ConversionFailed f "Invalid TaskType"
236:
237: instance SQL.ToField TaskType where
238: toField x = SQL.toField (show x :: String)
239:
240: instance SQL.FromField Status where
241: fromField f = do
242: t <- SQL.fromField f :: SQLOk.Ok String
243: case readMaybe t of
244: Just x -> pure x
245: Nothing -> SQL.returnError SQL.ConversionFailed f "Invalid Status"
246:
247: instance SQL.ToField Status where
248: toField x = SQL.toField (show x :: String)
249:
250: instance SQL.FromField Priority where
251: fromField f = do
252: t <- SQL.fromField f :: SQLOk.Ok String
253: case readMaybe t of
254: Just x -> pure x
255: Nothing -> SQL.returnError SQL.ConversionFailed f "Invalid Priority"
256:
257: instance SQL.ToField Priority where
258: toField x = SQL.toField (show x :: String)
259:
260: instance SQL.FromField ActivityStage where
261: fromField f = do
262: t <- SQL.fromField f :: SQLOk.Ok String
263: case readMaybe t of
264: Just x -> pure x
265: Nothing -> SQL.returnError SQL.ConversionFailed f "Invalid ActivityStage"
266:
267: instance SQL.ToField ActivityStage where
268: toField x = SQL.toField (show x :: String)
269:
270: -- Store dependencies as JSON text
271: instance SQL.FromField [Dependency] where
272: fromField f = do
273: mt <- SQL.fromField f :: SQLOk.Ok (Maybe String)
274: case mt of
275: Nothing -> pure []
276: Just t -> case Aeson.decode (BLC.pack t) of
277: Just x -> pure x
278: Nothing -> pure []
279:
280: instance SQL.ToField [Dependency] where
281: toField deps = SQL.toField (BLC.unpack (encode deps))
282:
283: -- Store comments as JSON text
284: instance SQL.FromField [Comment] where
285: fromField f = do
286: mt <- SQL.fromField f :: SQLOk.Ok (Maybe String)
287: case mt of
288: Nothing -> pure []
289: Just t -> case Aeson.decode (BLC.pack t) of
290: Just x -> pure x
291: Nothing -> pure []
292:
293: instance SQL.ToField [Comment] where
294: toField comments = SQL.toField (BLC.unpack (encode comments))
295:
296: instance SQL.FromRow Task where
297: fromRow =
298: Task
299: </ SQL.field
300: <*> SQL.field
301: <*> SQL.field
302: <*> SQL.field
303: <*> SQL.field
304: <*> SQL.field
305: <*> SQL.field
306: <*> SQL.field -- complexity
307: <*> SQL.field
308: <*> (fromMaybe "" </ SQL.field) -- Handle NULL description from legacy data
309: <*> SQL.field -- comments
310: <*> SQL.field
311: <*> SQL.field
312:
313: instance SQL.ToRow Task where
314: toRow t =
315: [ SQL.toField (taskId t),
316: SQL.toField (taskTitle t),
317: SQL.toField (taskType t),
318: SQL.toField (taskParent t),
319: SQL.toField (taskNamespace t),
320: SQL.toField (taskStatus t),
321: SQL.toField (taskPriority t),
322: SQL.toField (taskComplexity t),
323: SQL.toField (taskDependencies t),
324: SQL.toField (taskDescription t),
325: SQL.toField (taskComments t),
326: SQL.toField (taskCreatedAt t),
327: SQL.toField (taskUpdatedAt t)
328: ]
329:
330: instance SQL.FromRow TaskActivity where
331: fromRow =
332: TaskActivity
333: </ SQL.field
334: <*> SQL.field
335: <*> SQL.field
336: <*> SQL.field
337: <*> SQL.field
338: <*> SQL.field
339: <*> SQL.field
340: <*> SQL.field
341: <*> SQL.field
342: <*> SQL.field
343: <*> SQL.field
344:
345: instance SQL.ToRow TaskActivity where
346: toRow a =
347: [ SQL.toField (activityId a),
348: SQL.toField (activityTaskId a),
349: SQL.toField (activityTimestamp a),
350: SQL.toField (activityStage a),
351: SQL.toField (activityMessage a),
352: SQL.toField (activityMetadata a),
353: SQL.toField (activityThreadUrl a),
354: SQL.toField (activityStartedAt a),
355: SQL.toField (activityCompletedAt a),
356: SQL.toField (activityCostCents a),
357: SQL.toField (activityTokensUsed a)
358: ]
359:
360: instance SQL.FromRow Fact where
361: fromRow = do
362: fid <- SQL.field
363: proj <- SQL.field
364: content <- SQL.field
365: (relatedFilesJson :: String) <- SQL.field
366: sourceTask <- SQL.field
367: confidence <- SQL.field
368: createdAt <- SQL.field
369: let relatedFiles = fromMaybe [] (decode (BLC.pack relatedFilesJson))
370: pure
371: Fact
372: { factId = fid,
373: factProject = proj,
374: factContent = content,
375: factRelatedFiles = relatedFiles,
376: factSourceTask = sourceTask,
377: factConfidence = confidence,
378: factCreatedAt = createdAt
379: }
380:
381: instance SQL.ToRow Fact where
382: toRow f =
383: [ SQL.toField (factId f),
384: SQL.toField (factProject f),
385: SQL.toField (factContent f),
386: SQL.toField (BLC.unpack (encode (factRelatedFiles f))),
387: SQL.toField (factSourceTask f),
388: SQL.toField (factConfidence f),
389: SQL.toField (factCreatedAt f)
390: ]
391:
392: -- | Case-insensitive ID comparison
393: matchesId :: Text -> Text -> Bool
394: matchesId id1 id2 = normalizeId id1 == normalizeId id2
395:
396: -- | Normalize ID to lowercase
397: normalizeId :: Text -> Text
398: normalizeId = T.toLower
399:
400: -- | Find a task by ID (case-insensitive)
401: findTask :: Text -> [Task] -> Maybe Task
402: findTask tid = List.find (\t -> matchesId (taskId t) tid)
403:
404: -- | Normalize task IDs (self, parent, dependencies) to lowercase
405: normalizeTask :: Task -> Task
406: normalizeTask t =
407: t
408: { taskId = normalizeId (taskId t),
409: taskParent = fmap normalizeId (taskParent t),
410: taskDependencies = map normalizeDependency (taskDependencies t)
411: }
412:
413: normalizeDependency :: Dependency -> Dependency
414: normalizeDependency d = d {depId = normalizeId (depId d)}
415:
416: -- Lock for application-level thread safety (Read-Calc-Write cycles)
417: taskLock :: MVar ()
418: taskLock = unsafePerformIO (newMVar ())
419: {-# NOINLINE taskLock #-}
420:
421: withTaskLock :: IO a -> IO a
422: withTaskLock action = withMVar taskLock (const action)
423:
424: -- Get the tasks database file path
425: getTasksDbPath :: IO FilePath
426: getTasksDbPath = do
427: customPath <- lookupEnv "TASK_DB_PATH"
428: testMode <- lookupEnv "TASK_TEST_MODE"
429: case (testMode, customPath) of
430: (Just "1", _) -> pure "_/tmp/tasks-test.db"
431: (_, Just p) -> pure p
432: _ -> do
433: xdgData <- getXdgDirectory XdgData "jr"
434: pure (xdgData </> "jr.db")
435:
436: -- DB Helper
437: withDb :: (SQL.Connection -> IO a) -> IO a
438: withDb action = do
439: dbPath <- getTasksDbPath
440: SQL.withConnection dbPath <| \conn -> do
441: SQL.execute_ conn "PRAGMA busy_timeout = 5000"
442: action conn
443:
444: -- Initialize the task database
445: initTaskDb :: IO ()
446: initTaskDb = do
447: dbPath <- getTasksDbPath
448: createDirectoryIfMissing True (takeDirectory dbPath)
449: withDb <| \conn -> do
450: SQL.execute_
451: conn
452: "CREATE TABLE IF NOT EXISTS tasks (\
453: \ id TEXT PRIMARY KEY, \
454: \ title TEXT NOT NULL, \
455: \ type TEXT NOT NULL, \
456: \ parent TEXT, \
457: \ namespace TEXT, \
458: \ status TEXT NOT NULL, \
459: \ priority TEXT NOT NULL, \
460: \ complexity INTEGER, \
461: \ dependencies TEXT NOT NULL, \
462: \ description TEXT, \
463: \ comments TEXT NOT NULL DEFAULT '[]', \
464: \ created_at TIMESTAMP NOT NULL, \
465: \ updated_at TIMESTAMP NOT NULL \
466: \)"
467: SQL.execute_
468: conn
469: "CREATE TABLE IF NOT EXISTS id_counter (\
470: \ id INTEGER PRIMARY KEY CHECK (id = 1), \
471: \ counter INTEGER NOT NULL DEFAULT 0 \
472: \)"
473: SQL.execute_
474: conn
475: "INSERT OR IGNORE INTO id_counter (id, counter) VALUES (1, 0)"
476: SQL.execute_
477: conn
478: "CREATE TABLE IF NOT EXISTS retry_context (\
479: \ task_id TEXT PRIMARY KEY, \
480: \ original_commit TEXT NOT NULL, \
481: \ conflict_files TEXT NOT NULL, \
482: \ attempt INTEGER NOT NULL DEFAULT 1, \
483: \ reason TEXT NOT NULL \
484: \)"
485: SQL.execute_
486: conn
487: "CREATE TABLE IF NOT EXISTS facts (\
488: \ id INTEGER PRIMARY KEY AUTOINCREMENT, \
489: \ project TEXT NOT NULL, \
490: \ fact TEXT NOT NULL, \
491: \ related_files TEXT NOT NULL, \
492: \ source_task TEXT, \
493: \ confidence REAL NOT NULL, \
494: \ created_at DATETIME DEFAULT CURRENT_TIMESTAMP \
495: \)"
496: runMigrations conn
497:
498: -- | Run schema migrations to add missing columns to existing tables
499: runMigrations :: SQL.Connection -> IO ()
500: runMigrations conn = do
501: migrateTable conn "tasks" tasksColumns
502: migrateTable conn "retry_context" retryContextColumns
503: migrateTable conn "facts" factsColumns
504: createAgentEventsTable conn
505:
506: -- | Create agent_events table if it doesn't exist
507: createAgentEventsTable :: SQL.Connection -> IO ()
508: createAgentEventsTable conn = do
509: SQL.execute_
510: conn
511: "CREATE TABLE IF NOT EXISTS agent_events (\
512: \ id INTEGER PRIMARY KEY AUTOINCREMENT, \
513: \ task_id TEXT NOT NULL, \
514: \ session_id TEXT NOT NULL, \
515: \ timestamp DATETIME DEFAULT CURRENT_TIMESTAMP, \
516: \ event_type TEXT NOT NULL, \
517: \ content TEXT NOT NULL, \
518: \ actor TEXT NOT NULL DEFAULT 'junior' \
519: \)"
520: SQL.execute_ conn "CREATE INDEX IF NOT EXISTS idx_agent_events_task ON agent_events(task_id)"
521: SQL.execute_ conn "CREATE INDEX IF NOT EXISTS idx_agent_events_session ON agent_events(session_id)"
522: -- Add actor column to existing tables (migration)
523: SQL.execute_ conn "ALTER TABLE agent_events ADD COLUMN actor TEXT NOT NULL DEFAULT 'junior'" `catch` ignoreAlterError
524: where
525: ignoreAlterError :: SQL.SQLError -> IO ()
526: ignoreAlterError _ = pure () -- Column already exists
527:
528: -- | Expected columns for tasks table
529: tasksColumns :: [(Text, Text)]
530: tasksColumns =
531: [ ("id", "TEXT"),
532: ("title", "TEXT"),
533: ("type", "TEXT"),
534: ("parent", "TEXT"),
535: ("namespace", "TEXT"),
536: ("status", "TEXT"),
537: ("priority", "TEXT"),
538: ("complexity", "INTEGER"),
539: ("dependencies", "TEXT"),
540: ("description", "TEXT"),
541: ("comments", "TEXT"),
542: ("created_at", "TIMESTAMP"),
543: ("updated_at", "TIMESTAMP")
544: ]
545:
546: -- | Expected columns for retry_context table
547: retryContextColumns :: [(Text, Text)]
548: retryContextColumns =
549: [ ("task_id", "TEXT"),
550: ("original_commit", "TEXT"),
551: ("conflict_files", "TEXT"),
552: ("attempt", "INTEGER"),
553: ("reason", "TEXT"),
554: ("notes", "TEXT")
555: ]
556:
557: -- | Expected columns for facts table
558: factsColumns :: [(Text, Text)]
559: factsColumns =
560: [ ("id", "INTEGER"),
561: ("project", "TEXT"),
562: ("fact", "TEXT"),
563: ("related_files", "TEXT"),
564: ("source_task", "TEXT"),
565: ("confidence", "REAL"),
566: ("created_at", "DATETIME")
567: ]
568:
569: -- | Migrate a table by adding any missing columns
570: migrateTable :: SQL.Connection -> Text -> [(Text, Text)] -> IO ()
571: migrateTable conn tableName expectedCols = do
572: existingCols <- getTableColumns conn tableName
573: let missingCols = filter (\(name, _) -> name `notElem` existingCols) expectedCols
574: traverse_ (addColumn conn tableName) missingCols
575:
576: -- | Get list of column names for a table using PRAGMA table_info
577: getTableColumns :: SQL.Connection -> Text -> IO [Text]
578: getTableColumns conn tableName = do
579: let query = SQL.Query <| "PRAGMA table_info(" <> tableName <> ")"
580: rows <- SQL.query_ conn query :: IO [(Int, Text, Text, Int, Maybe Text, Int)]
581: pure [colName | (_, colName, _, _, _, _) <- rows]
582:
583: -- | Add a column to a table
584: addColumn :: SQL.Connection -> Text -> (Text, Text) -> IO ()
585: addColumn conn tableName (colName, colType) = do
586: let sql = "ALTER TABLE " <> tableName <> " ADD COLUMN " <> colName <> " " <> colType
587: SQL.execute_ conn (SQL.Query sql)
588:
589: -- Generate a sequential task ID (t-1, t-2, t-3, ...)
590: generateId :: IO Text
591: generateId = do
592: counter <- getNextCounter
593: pure <| "t-" <> T.pack (show counter)
594:
595: -- Get the next counter value (atomically increments)
596: getNextCounter :: IO Int
597: getNextCounter =
598: withDb <| \conn -> do
599: SQL.execute_
600: conn
601: "CREATE TABLE IF NOT EXISTS id_counter (\
602: \ id INTEGER PRIMARY KEY CHECK (id = 1), \
603: \ counter INTEGER NOT NULL DEFAULT 0 \
604: \)"
605: SQL.execute_ conn "INSERT OR IGNORE INTO id_counter (id, counter) VALUES (1, 0)"
606: SQL.execute_ conn "UPDATE id_counter SET counter = counter + 1 WHERE id = 1"
607: [SQL.Only c] <- SQL.query_ conn "SELECT counter FROM id_counter WHERE id = 1" :: IO [SQL.Only Int]
608: pure c
609:
610: -- Generate a child ID based on parent ID
611: generateChildId :: Text -> IO Text
612: generateChildId parentId = do
613: tasks <- loadTasks
614: pure <| computeNextChildId tasks (normalizeId parentId)
615:
616: computeNextChildId :: [Task] -> Text -> Text
617: computeNextChildId tasks parentId =
618: let suffixes = mapMaybe (getSuffix parentId <. taskId) tasks
619: nextSuffix = case suffixes of
620: [] -> 1
621: s -> maximum s + 1
622: in parentId <> "." <> T.pack (show nextSuffix)
623:
624: getSuffix :: Text -> Text -> Maybe Int
625: getSuffix parent childId =
626: if parent `T.isPrefixOf` childId && T.length childId > T.length parent
627: then
628: let rest = T.drop (T.length parent) childId
629: in if T.head rest == '.'
630: then readMaybe (T.unpack (T.tail rest))
631: else Nothing
632: else Nothing
633:
634: -- Load all tasks from DB
635: loadTasks :: IO [Task]
636: loadTasks =
637: withDb <| \conn -> do
638: SQL.query_ conn "SELECT id, title, type, parent, namespace, status, priority, complexity, dependencies, description, comments, created_at, updated_at FROM tasks"
639:
640: -- Save a single task (UPSERT)
641: saveTask :: Task -> IO ()
642: saveTask task =
643: withDb <| \conn -> do
644: SQL.execute
645: conn
646: "INSERT OR REPLACE INTO tasks \
647: \ (id, title, type, parent, namespace, status, priority, complexity, dependencies, description, comments, created_at, updated_at) \
648: \ VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)"
649: task
650:
651: -- Create a new task
652: createTask :: Text -> TaskType -> Maybe Text -> Maybe Text -> Priority -> Maybe Int -> [Dependency] -> Text -> IO Task
653: createTask title taskType parent namespace priority complexity deps description =
654: withTaskLock <| do
655: let parent' = fmap normalizeId parent
656: deps' = map normalizeDependency deps
657:
658: tid <- case parent' of
659: Nothing -> generateUniqueId
660: Just pid -> do
661: tasks <- loadTasks
662: pure <| computeNextChildId tasks pid
663: now <- getCurrentTime
664: let task =
665: Task
666: { taskId = normalizeId tid,
667: taskTitle = title,
668: taskType = taskType,
669: taskParent = parent',
670: taskNamespace = namespace,
671: taskStatus = Open,
672: taskPriority = priority,
673: taskComplexity = complexity,
674: taskDependencies = deps',
675: taskDescription = description,
676: taskComments = [],
677: taskCreatedAt = now,
678: taskUpdatedAt = now
679: }
680: saveTask task
681: pure task
682:
683: -- Generate a unique ID
684: generateUniqueId :: IO Text
685: generateUniqueId = do
686: -- We can query DB directly to check existence
687: go
688: where
689: go = do
690: tid <- generateId
691: exists <-
692: withDb <| \conn -> do
693: [SQL.Only c] <- SQL.query conn "SELECT COUNT(*) FROM tasks WHERE id = ?" (SQL.Only tid) :: IO [SQL.Only Int]
694: pure (c > 0)
695: if exists then go else pure tid
696:
697: -- Update task status
698: updateTaskStatus :: Text -> Status -> [Dependency] -> IO ()
699: updateTaskStatus tid newStatus newDeps = updateTaskStatusWithActor tid newStatus newDeps System
700:
701: updateTaskStatusWithActor :: Text -> Status -> [Dependency] -> CommentAuthor -> IO ()
702: updateTaskStatusWithActor tid newStatus newDeps actor =
703: withTaskLock <| do
704: maybeOldStatus <-
705: withDb <| \conn -> do
706: rows <- SQL.query conn "SELECT status, dependencies FROM tasks WHERE id = ?" (SQL.Only tid) :: IO [(Status, [Dependency])]
707: case rows of
708: [] -> pure Nothing
709: ((oldStatus, existingDeps) : _) -> do
710: now <- getCurrentTime
711: let finalDeps = if null newDeps then existingDeps else newDeps
712: SQL.execute
713: conn
714: "UPDATE tasks SET status = ?, updated_at = ?, dependencies = ? WHERE id = ?"
715: (newStatus, now, finalDeps, tid)
716: pure (Just oldStatus)
717: case maybeOldStatus of
718: Nothing -> pure ()
719: Just oldStatus ->
720: when (oldStatus /= newStatus) <| do
721: let content = "{\"from\":\"" <> T.pack (show oldStatus) <> "\",\"to\":\"" <> T.pack (show newStatus) <> "\"}"
722: sessionId <- getOrCreateCommentSession tid
723: insertAgentEvent tid sessionId "status_change" content actor
724:
725: -- Edit a task
726: editTask :: Text -> (Task -> Task) -> IO Task
727: editTask tid modifyFn =
728: withTaskLock <| do
729: tasks <- loadTasks
730: case findTask tid tasks of
731: Nothing -> panic "Task not found"
732: Just original -> do
733: now <- getCurrentTime
734: let modified = modifyFn original
735: finalTask = modified {taskUpdatedAt = now}
736: saveTask finalTask
737: pure finalTask
738:
739: -- Delete a task
740: deleteTask :: Text -> IO ()
741: deleteTask tid =
742: withDb <| \conn ->
743: SQL.execute conn "DELETE FROM tasks WHERE id = ?" (SQL.Only tid)
744:
745: -- Add a comment to a task
746: addComment :: Text -> Text -> CommentAuthor -> IO Task
747: addComment tid commentTextContent author =
748: withTaskLock <| do
749: tasks <- loadTasks
750: case findTask tid tasks of
751: Nothing -> panic "Task not found"
752: Just task -> do
753: now <- getCurrentTime
754: sessionId <- getOrCreateCommentSession tid
755: insertAgentEvent tid sessionId "comment" commentTextContent author
756: let updatedTask = task {taskUpdatedAt = now}
757: saveTask updatedTask
758: pure updatedTask
759:
760: -- | Get or create a session ID for comments on a task
761: -- Uses a dedicated "comments" session so comments are grouped together
762: getOrCreateCommentSession :: Text -> IO Text
763: getOrCreateCommentSession taskId = do
764: let sessionId = "comments-" <> taskId
765: pure sessionId
766:
767: -- List tasks
768: listTasks :: Maybe TaskType -> Maybe Text -> Maybe Status -> Maybe Text -> IO [Task]
769: listTasks maybeType maybeParent maybeStatus maybeNamespace = do
770: -- Implementing specific filters in SQL would be more efficient, but for MVP and API compat:
771: tasks <- loadTasks
772: let filtered =
773: tasks
774: |> filterByType maybeType
775: |> filterByParent maybeParent
776: |> filterByStatus maybeStatus
777: |> filterByNamespace maybeNamespace
778: pure filtered
779: where
780: filterByType Nothing ts = ts
781: filterByType (Just typ) ts = filter (\t -> taskType t == typ) ts
782: filterByParent Nothing ts = ts
783: filterByParent (Just pid) ts = filter (\t -> taskParent t == Just pid) ts
784: filterByStatus Nothing ts = ts
785: filterByStatus (Just status) ts = filter (\t -> taskStatus t == status) ts
786: filterByNamespace Nothing ts = ts
787: filterByNamespace (Just ns) ts = filter (\t -> taskNamespace t == Just ns) ts
788:
789: -- Get ready tasks
790: getReadyTasks :: IO [Task]
791: getReadyTasks = do
792: allTasks <- loadTasks
793: retryContexts <- getAllRetryContexts
794: let openTasks = filter (\t -> taskStatus t `elem` [Open, InProgress]) allTasks
795: doneIds = map taskId <| filter (\t -> taskStatus t == Done) allTasks
796:
797: parentIds = mapMaybe taskParent allTasks
798: isParent tid = tid `elem` parentIds
799:
800: -- Tasks with retry_attempt >= 3 need human intervention
801: needsInterventionIds = [retryTaskId ctx | ctx <- retryContexts, retryAttempt ctx >= 3]
802:
803: blockingDepIds task = [depId dep | dep <- taskDependencies task, depType dep `elem` [Blocks, ParentChild]]
804: isReady task =
805: taskType task
806: /= Epic
807: && not (isParent (taskId task))
808: && all (`elem` doneIds) (blockingDepIds task)
809: && taskType task
810: /= HumanTask
811: && taskId task
812: `notElem` needsInterventionIds
813: pure <| filter isReady openTasks
814:
815: -- Get dependency tree
816: getDependencyTree :: Text -> IO [Task]
817: getDependencyTree tid = do
818: tasks <- loadTasks
819: case findTask tid tasks of
820: Nothing -> pure []
821: Just task -> pure <| collectDeps tasks task
822: where
823: collectDeps allTasks task =
824: let depIds = map depId (taskDependencies task)
825: deps = filter (\t -> any (matchesId (taskId t)) depIds) allTasks
826: in task : concatMap (collectDeps allTasks) deps
827:
828: -- Get task progress
829: getTaskProgress :: Text -> IO TaskProgress
830: getTaskProgress tidRaw = do
831: let tid = normalizeId tidRaw
832: -- Could be SQL optimized
833: tasks <- loadTasks
834: case findTask tid tasks of
835: Nothing -> panic "Task not found"
836: Just _ -> do
837: let children = filter (\child -> taskParent child == Just tid) tasks
838: total = length children
839: completed = length <| filter (\child -> taskStatus child == Done) children
840: percentage = if total == 0 then 0 else (completed * 100) `div` total
841: pure
842: TaskProgress
843: { progressTaskId = tid,
844: progressTotal = total,
845: progressCompleted = completed,
846: progressPercentage = percentage
847: }
848:
849: showTaskProgress :: Text -> IO ()
850: showTaskProgress tid = do
851: progress <- getTaskProgress tid
852: putText <| "Progress for " <> tid <> ": " <> T.pack (show (progressCompleted progress)) <> "/" <> T.pack (show (progressTotal progress)) <> " (" <> T.pack (show (progressPercentage progress)) <> "%)"
853:
854: showDependencyTree :: Text -> IO ()
855: showDependencyTree tid = do
856: tasks <- loadTasks
857: case findTask tid tasks of
858: Nothing -> putText "Task not found"
859: Just task -> printTree tasks task 0
860: where
861: printTree :: [Task] -> Task -> Int -> IO ()
862: printTree allTasks task indent = do
863: putText <| T.pack (replicate (indent * 2) ' ') <> taskId task <> ": " <> taskTitle task
864: let depIds = map depId (taskDependencies task)
865: deps = filter (\t -> any (matchesId (taskId t)) depIds) allTasks
866: traverse_ (\dep -> printTree allTasks dep (indent + 1)) deps
867:
868: getTaskTree :: Maybe Text -> IO [Task]
869: getTaskTree maybeId = do
870: tasks <- loadTasks
871: case maybeId of
872: Nothing -> do
873: let epics = filter (\t -> taskType t == Epic) tasks
874: in pure <| concatMap (collectChildren tasks) epics
875: Just tid -> do
876: case findTask tid tasks of
877: Nothing -> pure []
878: Just task -> pure <| collectChildren tasks task
879: where
880: collectChildren allTasks task =
881: let children = filter (maybe False (`matchesId` taskId task) <. taskParent) allTasks
882: in task : concatMap (collectChildren allTasks) children
883:
884: showTaskTree :: Maybe Text -> IO ()
885: showTaskTree maybeId = do
886: tasks <- loadTasks
887: case maybeId of
888: Nothing -> do
889: let epics = filter (\t -> taskType t == Epic) tasks
890: if null epics
891: then putText "No epics found"
892: else traverse_ (printEpicTree tasks) epics
893: Just tid -> do
894: case findTask tid tasks of
895: Nothing -> putText "Task not found"
896: Just task -> printEpicTree tasks task
897: where
898: printEpicTree allTasks task = printTreeNode allTasks task (0 :: Int)
899:
900: printTreeNode allTasks task indent = printTreeNode' allTasks task indent []
901:
902: printTreeNode' allTasks task indent ancestry = do
903: let children = filter (maybe False (`matchesId` taskId task) <. taskParent) allTasks
904: prefix =
905: if indent == 0
906: then ""
907: else
908: let ancestorPrefixes = map (\hasMore -> if hasMore then "│ " else " ") (List.init ancestry)
909: myPrefix = if List.last ancestry then "├── " else "└── "
910: in T.pack <| concat ancestorPrefixes ++ myPrefix
911: statusStr = case taskType task of
912: Epic ->
913: let total = length children
914: completed = length <| filter (\t -> taskStatus t == Done) children
915: in "[" <> T.pack (show completed) <> "/" <> T.pack (show total) <> "]"
916: _ -> case taskStatus task of
917: Draft -> "[.]"
918: Open -> "[ ]"
919: InProgress -> "[~]"
920: Review -> "[?]"
921: Approved -> "[+]"
922: Done -> "[✓]"
923:
924: coloredStatusStr = case taskType task of
925: Epic -> magenta statusStr
926: _ -> case taskStatus task of
927: Draft -> gray statusStr
928: Open -> bold statusStr
929: InProgress -> yellow statusStr
930: Review -> magenta statusStr
931: Approved -> green statusStr
932: Done -> green statusStr
933:
934: nsStr = case taskNamespace task of
935: Nothing -> ""
936: Just ns -> "[" <> ns <> "] "
937:
938: coloredNsStr = case taskNamespace task of
939: Nothing -> ""
940: Just _ -> gray nsStr
941:
942: usedWidth = T.length prefix + T.length (taskId task) + T.length statusStr + T.length nsStr + 2
943: availableWidth = max 20 (80 - usedWidth)
944: truncatedTitle =
945: if T.length (taskTitle task) > availableWidth
946: then T.take (availableWidth - 3) (taskTitle task) <> "..."
947: else taskTitle task
948:
949: coloredTitle = if taskType task == Epic then bold truncatedTitle else truncatedTitle
950:
951: putText <| prefix <> cyan (taskId task) <> " " <> coloredStatusStr <> " " <> coloredNsStr <> coloredTitle
952:
953: let indexedChildren = zip [1 ..] children
954: totalChildren = length children
955: traverse_
956: ( \(idx, child) ->
957: let hasMoreSiblings = idx < totalChildren
958: in printTreeNode' allTasks child (indent + 1) (ancestry ++ [hasMoreSiblings])
959: )
960: indexedChildren
961:
962: printTask :: Task -> IO ()
963: printTask t = do
964: tasks <- loadTasks
965: let progressInfo =
966: if taskType t == Epic
967: then
968: let children = filter (maybe False (`matchesId` taskId t) <. taskParent) tasks
969: total = length children
970: completed = length <| filter (\child -> taskStatus child == Done) children
971: in " [" <> T.pack (show completed) <> "/" <> T.pack (show total) <> "]"
972: else ""
973:
974: parentInfo = case taskParent t of
975: Nothing -> ""
976: Just p -> " (parent: " <> p <> ")"
977:
978: namespaceInfo = case taskNamespace t of
979: Nothing -> ""
980: Just ns -> " [" <> ns <> "]"
981:
982: coloredStatus =
983: let s = "[" <> T.pack (show (taskStatus t)) <> "]"
984: in case taskStatus t of
985: Draft -> gray s
986: Open -> bold s
987: InProgress -> yellow s
988: Review -> magenta s
989: Approved -> green s
990: Done -> green s
991:
992: coloredTitle = if taskType t == Epic then bold (taskTitle t) else taskTitle t
993: coloredProgress = if taskType t == Epic then magenta progressInfo else progressInfo
994: coloredNamespace = case taskNamespace t of
995: Nothing -> ""
996: Just _ -> gray namespaceInfo
997: coloredParent = case taskParent t of
998: Nothing -> ""
999: Just _ -> gray parentInfo
1000:
1001: putText
1002: <| cyan (taskId t)
1003: <> " ["
1004: <> T.pack (show (taskType t))
1005: <> "] "
1006: <> coloredStatus
1007: <> coloredProgress
1008: <> " "
1009: <> coloredTitle
1010: <> coloredParent
1011: <> coloredNamespace
1012:
1013: showTaskDetailed :: Task -> IO ()
1014: showTaskDetailed t = do
1015: tasks <- loadTasks
1016: putText ""
1017: putText <| "Title: " <> taskTitle t <> " (ID: " <> taskId t <> ")"
1018: putText <| "Type: " <> T.pack (show (taskType t))
1019: putText <| "Status: " <> T.pack (show (taskStatus t))
1020: putText <| "Priority: " <> T.pack (show (taskPriority t)) <> priorityDesc
1021: case taskComplexity t of
1022: Nothing -> pure ()
1023: Just c -> putText ("Complexity: " <> T.pack (show c) <> "/5")
1024:
1025: when (taskType t == Epic) <| do
1026: let children = filter (maybe False (`matchesId` taskId t) <. taskParent) tasks
1027: total = length children
1028: completed = length <| filter (\child -> taskStatus child == Done) children
1029: percentage = if total == 0 then 0 else (completed * 100) `div` total
1030: putText <| "Progress: " <> T.pack (show completed) <> "/" <> T.pack (show total) <> " (" <> T.pack (show percentage) <> "%)"
1031:
1032: case taskParent t of
1033: Nothing -> pure ()
1034: Just p -> putText <| "Parent: " <> p
1035: case taskNamespace t of
1036: Nothing -> pure ()
1037: Just ns -> putText <| "Namespace: " <> ns
1038: putText <| "Created: " <> T.pack (show (taskCreatedAt t))
1039: putText <| "Updated: " <> T.pack (show (taskUpdatedAt t))
1040:
1041: unless (null (taskDependencies t)) <| do
1042: putText ""
1043: putText "Dependencies:"
1044: traverse_ printDependency (taskDependencies t)
1045:
1046: unless (T.null (taskDescription t)) <| do
1047: putText ""
1048: putText "Description:"
1049: let indented = T.unlines <| map (" " <>) (T.lines (taskDescription t))
1050: putText indented
1051:
1052: unless (null (taskComments t)) <| do
1053: putText ""
1054: putText "Comments:"
1055: traverse_ printComment (taskComments t)
1056:
1057: putText ""
1058: where
1059: priorityDesc = case taskPriority t of
1060: P0 -> " (Critical)"
1061: P1 -> " (High)"
1062: P2 -> " (Medium)"
1063: P3 -> " (Low)"
1064: P4 -> " (Backlog)"
1065:
1066: printDependency dep =
1067: putText <| " - " <> depId dep <> " [" <> T.pack (show (depType dep)) <> "]"
1068:
1069: printComment c =
1070: putText <| " [" <> T.pack (show (commentCreatedAt c)) <> "] [" <> T.pack (show (commentAuthor c)) <> "] " <> commentText c
1071:
1072: red, green, yellow, blue, magenta, cyan, gray, bold :: Text -> Text
1073: red t = "\ESC[31m" <> t <> "\ESC[0m"
1074: green t = "\ESC[32m" <> t <> "\ESC[0m"
1075: yellow t = "\ESC[33m" <> t <> "\ESC[0m"
1076: blue t = "\ESC[34m" <> t <> "\ESC[0m"
1077: magenta t = "\ESC[35m" <> t <> "\ESC[0m"
1078: cyan t = "\ESC[36m" <> t <> "\ESC[0m"
1079: gray t = "\ESC[90m" <> t <> "\ESC[0m"
1080: bold t = "\ESC[1m" <> t <> "\ESC[0m"
1081:
1082: -- Export tasks: Dump SQLite to JSONL
1083: exportTasks :: Maybe FilePath -> IO ()
1084: exportTasks maybePath = do
1085: tasks <- loadTasks
1086: case maybePath of
1087: Just path -> do
1088: TIO.writeFile path ""
1089: traverse_ (saveTaskToJsonl path) tasks
1090: Nothing ->
1091: -- Stream to stdout
1092: traverse_ (BLC.putStrLn <. encode) tasks
1093:
1094: saveTaskToJsonl :: FilePath -> Task -> IO ()
1095: saveTaskToJsonl path task = do
1096: let json = encode task
1097: BLC.appendFile path (json <> "\n")
1098:
1099: data TaskStats = TaskStats
1100: { totalTasks :: Int,
1101: draftTasks :: Int,
1102: openTasks :: Int,
1103: inProgressTasks :: Int,
1104: reviewTasks :: Int,
1105: approvedTasks :: Int,
1106: doneTasks :: Int,
1107: totalEpics :: Int,
1108: readyTasks :: Int,
1109: blockedTasks :: Int,
1110: tasksByPriority :: [(Priority, Int)],
1111: tasksByNamespace :: [(Text, Int)]
1112: }
1113: deriving (Show, Eq, Generic)
1114:
1115: instance ToJSON TaskStats
1116:
1117: instance FromJSON TaskStats
1118:
1119: getTaskStats :: Maybe Text -> IO TaskStats
1120: getTaskStats maybeEpicId = do
1121: allTasks <- loadTasks
1122:
1123: targetTasks <- case maybeEpicId of
1124: Nothing -> pure allTasks
1125: Just epicId ->
1126: case findTask epicId allTasks of
1127: Nothing -> panic "Epic not found"
1128: Just task -> pure <| getAllDescendants allTasks (taskId task)
1129:
1130: globalReady <- getReadyTasks
1131: let readyIds = map taskId globalReady
1132: readyCount = length <| filter (\t -> taskId t `elem` readyIds) targetTasks
1133:
1134: tasks = targetTasks
1135: total = length tasks
1136: draft = length <| filter (\t -> taskStatus t == Draft) tasks
1137: open = length <| filter (\t -> taskStatus t == Open) tasks
1138: inProg = length <| filter (\t -> taskStatus t == InProgress) tasks
1139: review = length <| filter (\t -> taskStatus t == Review) tasks
1140: approved = length <| filter (\t -> taskStatus t == Approved) tasks
1141: done = length <| filter (\t -> taskStatus t == Done) tasks
1142: epics = length <| filter (\t -> taskType t == Epic) tasks
1143: readyCount' = readyCount
1144: blockedCount = total - readyCount' - done - draft
1145: byPriority =
1146: [ (P0, length <| filter (\t -> taskPriority t == P0) tasks),
1147: (P1, length <| filter (\t -> taskPriority t == P1) tasks),
1148: (P2, length <| filter (\t -> taskPriority t == P2) tasks),
1149: (P3, length <| filter (\t -> taskPriority t == P3) tasks),
1150: (P4, length <| filter (\t -> taskPriority t == P4) tasks)
1151: ]
1152: namespaces = mapMaybe taskNamespace tasks
1153: uniqueNs = List.nub namespaces
1154: byNamespace = map (\ns -> (ns, length <| filter (\t -> taskNamespace t == Just ns) tasks)) uniqueNs
1155: pure
1156: TaskStats
1157: { totalTasks = total,
1158: draftTasks = draft,
1159: openTasks = open,
1160: inProgressTasks = inProg,
1161: reviewTasks = review,
1162: approvedTasks = approved,
1163: doneTasks = done,
1164: totalEpics = epics,
1165: readyTasks = readyCount',
1166: blockedTasks = blockedCount,
1167: tasksByPriority = byPriority,
1168: tasksByNamespace = byNamespace
1169: }
1170:
1171: getAllDescendants :: [Task] -> Text -> [Task]
1172: getAllDescendants allTasks parentId =
1173: let children = filter (maybe False (`matchesId` parentId) <. taskParent) allTasks
1174: in children ++ concatMap (getAllDescendants allTasks <. taskId) children
1175:
1176: computeTaskStatsFromList :: [Task] -> TaskStats
1177: computeTaskStatsFromList tasks =
1178: let total = length tasks
1179: draft = length [t | t <- tasks, taskStatus t == Draft]
1180: open = length [t | t <- tasks, taskStatus t == Open]
1181: inProg = length [t | t <- tasks, taskStatus t == InProgress]
1182: review = length [t | t <- tasks, taskStatus t == Review]
1183: approved = length [t | t <- tasks, taskStatus t == Approved]
1184: done = length [t | t <- tasks, taskStatus t == Done]
1185: epics = length [t | t <- tasks, taskType t == Epic]
1186: readyCount = open + inProg
1187: blockedCount = 0
1188: byPriority =
1189: [ (P0, length [t | t <- tasks, taskPriority t == P0]),
1190: (P1, length [t | t <- tasks, taskPriority t == P1]),
1191: (P2, length [t | t <- tasks, taskPriority t == P2]),
1192: (P3, length [t | t <- tasks, taskPriority t == P3]),
1193: (P4, length [t | t <- tasks, taskPriority t == P4])
1194: ]
1195: namespaces = mapMaybe taskNamespace tasks
1196: uniqueNs = List.nub namespaces
1197: byNamespace = [(ns, length [t | t <- tasks, taskNamespace t == Just ns]) | ns <- uniqueNs]
1198: in TaskStats
1199: { totalTasks = total,
1200: draftTasks = draft,
1201: openTasks = open,
1202: inProgressTasks = inProg,
1203: reviewTasks = review,
1204: approvedTasks = approved,
1205: doneTasks = done,
1206: totalEpics = epics,
1207: readyTasks = readyCount,
1208: blockedTasks = blockedCount,
1209: tasksByPriority = byPriority,
1210: tasksByNamespace = byNamespace
1211: }
1212:
1213: showTaskStats :: Maybe Text -> IO ()
1214: showTaskStats maybeEpicId = do
1215: stats <- getTaskStats maybeEpicId
1216: putText ""
1217: case maybeEpicId of
1218: Nothing -> putText "Task Statistics"
1219: Just epicId -> putText <| "Task Statistics for Epic " <> epicId
1220: putText ""
1221: putText <| "Total tasks: " <> T.pack (show (totalTasks stats))
1222: putText <| " Draft: " <> T.pack (show (draftTasks stats))
1223: putText <| " Open: " <> T.pack (show (openTasks stats))
1224: putText <| " In Progress: " <> T.pack (show (inProgressTasks stats))
1225: putText <| " Review: " <> T.pack (show (reviewTasks stats))
1226: putText <| " Approved: " <> T.pack (show (approvedTasks stats))
1227: putText <| " Done: " <> T.pack (show (doneTasks stats))
1228: putText ""
1229: putText <| "Epics: " <> T.pack (show (totalEpics stats))
1230: putText ""
1231: putText <| "Ready to work: " <> T.pack (show (readyTasks stats))
1232: putText <| "Blocked: " <> T.pack (show (blockedTasks stats))
1233: putText ""
1234: putText "By Priority:"
1235: traverse_ printPriority (tasksByPriority stats)
1236: unless (null (tasksByNamespace stats)) <| do
1237: putText ""
1238: putText "By Namespace:"
1239: traverse_ printNamespace (tasksByNamespace stats)
1240: putText ""
1241: where
1242: printPriority (p, count) =
1243: let label = case p of
1244: P0 -> "P0 (Critical)"
1245: P1 -> "P1 (High)"
1246: P2 -> "P2 (Medium)"
1247: P3 -> "P3 (Low)"
1248: P4 -> "P4 (Backlog)"
1249: in putText <| " " <> T.pack (show count) <> " " <> label
1250: printNamespace (ns, count) =
1251: putText <| " " <> T.pack (show count) <> " " <> ns
1252:
1253: -- Import tasks: Read from JSONL and insert/update DB
1254: importTasks :: FilePath -> IO ()
1255: importTasks filePath = do
1256: exists <- doesFileExist filePath
1257: unless exists <| panic (T.pack filePath <> " does not exist")
1258:
1259: content <- TIO.readFile filePath
1260: let importLines = T.lines content
1261: importedTasks = map normalizeTask (mapMaybe decodeTask importLines)
1262:
1263: -- Save all imported tasks (UPSERT logic handles updates)
1264: traverse_ saveTask importedTasks
1265: where
1266: decodeTask :: Text -> Maybe Task
1267: decodeTask line =
1268: if T.null line
1269: then Nothing
1270: else decode (BLC.pack <| T.unpack line)
1271:
1272: -- Retry context management
1273:
1274: -- | Get retry context for a task (if any)
1275: getRetryContext :: Text -> IO (Maybe RetryContext)
1276: getRetryContext tid =
1277: withDb <| \conn -> do
1278: rows <-
1279: SQL.query
1280: conn
1281: "SELECT task_id, original_commit, conflict_files, attempt, reason, notes FROM retry_context WHERE task_id = ?"
1282: (SQL.Only tid) ::
1283: IO [(Text, Text, Text, Int, Text, Maybe Text)]
1284: case rows of
1285: [] -> pure Nothing
1286: ((taskId', commit, filesJson, attempt, reason, notes) : _) ->
1287: let files = fromMaybe [] (decode (BLC.pack <| T.unpack filesJson))
1288: in pure
1289: <| Just
1290: RetryContext
1291: { retryTaskId = taskId',
1292: retryOriginalCommit = commit,
1293: retryConflictFiles = files,
1294: retryAttempt = attempt,
1295: retryReason = reason,
1296: retryNotes = notes
1297: }
1298:
1299: -- | Set retry context for a task (upsert)
1300: setRetryContext :: RetryContext -> IO ()
1301: setRetryContext ctx =
1302: withDb <| \conn -> do
1303: let filesJson = T.pack <| BLC.unpack <| encode (retryConflictFiles ctx)
1304: SQL.execute
1305: conn
1306: "INSERT OR REPLACE INTO retry_context (task_id, original_commit, conflict_files, attempt, reason, notes) VALUES (?, ?, ?, ?, ?, ?)"
1307: (retryTaskId ctx, retryOriginalCommit ctx, filesJson, retryAttempt ctx, retryReason ctx, retryNotes ctx)
1308:
1309: -- | Clear retry context for a task (on successful merge)
1310: clearRetryContext :: Text -> IO ()
1311: clearRetryContext tid =
1312: withDb <| \conn ->
1313: SQL.execute conn "DELETE FROM retry_context WHERE task_id = ?" (SQL.Only tid)
1314:
1315: -- | Increment retry attempt and return new count
1316: incrementRetryAttempt :: Text -> IO Int
1317: incrementRetryAttempt tid = do
1318: maybeCtx <- getRetryContext tid
1319: case maybeCtx of
1320: Nothing -> pure 1
1321: Just ctx -> do
1322: let newAttempt = retryAttempt ctx + 1
1323: setRetryContext ctx {retryAttempt = newAttempt}
1324: pure newAttempt
1325:
1326: -- | Map ActivityStage to event_type string for agent_events
1327: activityStageToEventType :: ActivityStage -> Text
1328: activityStageToEventType Claiming = "claim"
1329: activityStageToEventType Running = "running"
1330: activityStageToEventType Reviewing = "reviewing"
1331: activityStageToEventType Retrying = "retrying"
1332: activityStageToEventType Completed = "complete"
1333: activityStageToEventType Failed = "error"
1334:
1335: -- | Log activity to agent_events table (unified timeline)
1336: logActivity :: Text -> ActivityStage -> Maybe Text -> IO ()
1337: logActivity tid stage metadata = do
1338: sessionId <- getOrCreateCommentSession tid
1339: let eventType = activityStageToEventType stage
1340: content = fromMaybe "" metadata
1341: insertAgentEvent tid sessionId eventType content Junior
1342:
1343: -- | Log activity with worker metrics (timing, cost stored in metadata JSON)
1344: logActivityWithMetrics :: Text -> ActivityStage -> Maybe Text -> Maybe Text -> Maybe UTCTime -> Maybe UTCTime -> Maybe Int -> Maybe Int -> IO Int
1345: logActivityWithMetrics tid stage baseMetadata _ampUrl startedAt completedAt costCents tokens = do
1346: sessionId <- getOrCreateCommentSession tid
1347: let eventType = activityStageToEventType stage
1348: metricsJson = buildMetricsJson baseMetadata startedAt completedAt costCents tokens
1349: withDb <| \conn -> do
1350: SQL.execute
1351: conn
1352: "INSERT INTO agent_events (task_id, session_id, event_type, content, actor) VALUES (?, ?, ?, ?, ?)"
1353: (tid, sessionId, eventType, metricsJson, Junior)
1354: [SQL.Only actId] <- SQL.query_ conn "SELECT last_insert_rowid()" :: IO [SQL.Only Int]
1355: pure actId
1356:
1357: -- | Build metrics JSON for activity metadata
1358: buildMetricsJson :: Maybe Text -> Maybe UTCTime -> Maybe UTCTime -> Maybe Int -> Maybe Int -> Text
1359: buildMetricsJson baseMetadata startedAt completedAt costCents tokens =
1360: let base = fromMaybe "{}" baseMetadata
1361: additions =
1362: catMaybes
1363: [ fmap (\t -> "\"started_at\":\"" <> T.pack (show t) <> "\"") startedAt,
1364: fmap (\t -> "\"completed_at\":\"" <> T.pack (show t) <> "\"") completedAt,
1365: fmap (\c -> "\"cost_cents\":" <> T.pack (show c)) costCents,
1366: fmap (\t -> "\"tokens_used\":" <> T.pack (show t)) tokens
1367: ]
1368: in if null additions
1369: then base
1370: else
1371: if base == "{}"
1372: then "{" <> T.intercalate "," additions <> "}"
1373: else T.init base <> "," <> T.intercalate "," additions <> "}"
1374:
1375: -- | Update an existing activity record with metrics (in agent_events)
1376: updateActivityMetrics :: Int -> Maybe Text -> Maybe UTCTime -> Maybe Int -> Maybe Int -> IO ()
1377: updateActivityMetrics actId _ampUrl completedAt costCents tokens =
1378: withDb <| \conn -> do
1379: [SQL.Only currentContent] <- SQL.query conn "SELECT content FROM agent_events WHERE id = ?" (SQL.Only actId) :: IO [SQL.Only Text]
1380: let updatedContent = buildMetricsJson (Just currentContent) Nothing completedAt costCents tokens
1381: SQL.execute conn "UPDATE agent_events SET content = ? WHERE id = ?" (updatedContent, actId)
1382:
1383: -- | Get all activities for a task from agent_events, ordered by timestamp descending
1384: -- Returns TaskActivity for backward compatibility
1385: getActivitiesForTask :: Text -> IO [TaskActivity]
1386: getActivitiesForTask tid = do
1387: events <- getAllEventsForTask tid
1388: let activityEvents = filter (isActivityEvent <. storedEventType) events
1389: pure <| map storedEventToActivity (reverse activityEvents)
1390:
1391: -- | Check if an event type is an activity event
1392: isActivityEvent :: Text -> Bool
1393: isActivityEvent t = t `elem` ["claim", "running", "reviewing", "retrying", "complete", "error"]
1394:
1395: -- | Convert StoredEvent to TaskActivity for backward compatibility
1396: storedEventToActivity :: StoredEvent -> TaskActivity
1397: storedEventToActivity evt =
1398: let stage = eventTypeToActivityStage (storedEventType evt)
1399: (startedAt, completedAt, costCents, tokens) = parseMetricsFromContent (storedEventContent evt)
1400: in TaskActivity
1401: { activityId = Just (storedEventId evt),
1402: activityTaskId = storedEventTaskId evt,
1403: activityTimestamp = storedEventTimestamp evt,
1404: activityStage = stage,
1405: activityMessage = Nothing,
1406: activityMetadata = Just (storedEventContent evt),
1407: activityThreadUrl = Nothing,
1408: activityStartedAt = startedAt,
1409: activityCompletedAt = completedAt,
1410: activityCostCents = costCents,
1411: activityTokensUsed = tokens
1412: }
1413:
1414: -- | Map event_type back to ActivityStage
1415: eventTypeToActivityStage :: Text -> ActivityStage
1416: eventTypeToActivityStage "claim" = Claiming
1417: eventTypeToActivityStage "running" = Running
1418: eventTypeToActivityStage "reviewing" = Reviewing
1419: eventTypeToActivityStage "retrying" = Retrying
1420: eventTypeToActivityStage "complete" = Completed
1421: eventTypeToActivityStage "error" = Failed
1422: eventTypeToActivityStage _ = Running
1423:
1424: -- | Parse metrics from content JSON (best effort)
1425: parseMetricsFromContent :: Text -> (Maybe UTCTime, Maybe UTCTime, Maybe Int, Maybe Int)
1426: parseMetricsFromContent content =
1427: case Aeson.decode (BLC.pack (T.unpack content)) of
1428: Just (Aeson.Object obj) ->
1429: let getCents = case KeyMap.lookup "cost_cents" obj of
1430: Just (Aeson.Number n) -> Just (round n)
1431: _ -> Nothing
1432: getTokens = case KeyMap.lookup "tokens_used" obj of
1433: Just (Aeson.Number n) -> Just (round n)
1434: _ -> Nothing
1435: in (Nothing, Nothing, getCents, getTokens)
1436: _ -> (Nothing, Nothing, Nothing, Nothing)
1437:
1438: -- | Get the most recent running activity for a task (for metrics display)
1439: getLatestRunningActivity :: Text -> IO (Maybe TaskActivity)
1440: getLatestRunningActivity tid = do
1441: activities <- getActivitiesForTask tid
1442: pure <| List.find (\a -> activityStage a == Running) activities
1443:
1444: -- | Get aggregated metrics for all descendants of an epic
1445: getAggregatedMetrics :: Text -> IO AggregatedMetrics
1446: getAggregatedMetrics epicId = do
1447: allTasks <- loadTasks
1448: let descendants = getAllDescendants allTasks epicId
1449: descendantIds = map taskId descendants
1450: completedCount = length [t | t <- descendants, taskStatus t == Done]
1451: activities <- concat </ traverse getActivitiesForTask descendantIds
1452: let totalCost = sum [c | act <- activities, Just c <- [activityCostCents act]]
1453: totalTokens = sum [t | act <- activities, Just t <- [activityTokensUsed act]]
1454: totalDuration = sum [calcDuration act | act <- activities]
1455: pure
1456: AggregatedMetrics
1457: { aggTotalCostCents = totalCost,
1458: aggTotalDurationSeconds = totalDuration,
1459: aggCompletedTasks = completedCount,
1460: aggTotalTokens = totalTokens
1461: }
1462: where
1463: calcDuration act = case (activityStartedAt act, activityCompletedAt act) of
1464: (Just start, Just end) -> floor (diffUTCTime end start)
1465: _ -> 0
1466:
1467: -- | Get aggregated metrics for all tasks globally (not scoped to an epic)
1468: getGlobalAggregatedMetrics :: IO AggregatedMetrics
1469: getGlobalAggregatedMetrics = do
1470: allTasks <- loadTasks
1471: let completedCount = length [t | t <- allTasks, taskStatus t == Done]
1472: taskIds = map taskId allTasks
1473: activities <- concat </ traverse getActivitiesForTask taskIds
1474: let totalCost = sum [c | act <- activities, Just c <- [activityCostCents act]]
1475: totalTokens = sum [t | act <- activities, Just t <- [activityTokensUsed act]]
1476: totalDuration = sum [calcDuration act | act <- activities]
1477: pure
1478: AggregatedMetrics
1479: { aggTotalCostCents = totalCost,
1480: aggTotalDurationSeconds = totalDuration,
1481: aggCompletedTasks = completedCount,
1482: aggTotalTokens = totalTokens
1483: }
1484: where
1485: calcDuration act = case (activityStartedAt act, activityCompletedAt act) of
1486: (Just start, Just end) -> floor (diffUTCTime end start)
1487: _ -> 0
1488:
1489: -- | Get tasks with unmet blocking dependencies (not ready, not done)
1490: getBlockedTasks :: IO [Task]
1491: getBlockedTasks = do
1492: allTasks <- loadTasks
1493: readyTasks <- getReadyTasks
1494: let readyIds = map taskId readyTasks
1495: doneIds = [taskId t | t <- allTasks, taskStatus t == Done]
1496: isBlocked task =
1497: taskStatus task
1498: `elem` [Open, InProgress]
1499: && taskId task
1500: `notElem` readyIds
1501: && taskId task
1502: `notElem` doneIds
1503: pure [t | t <- allTasks, isBlocked t]
1504:
1505: -- | Count how many tasks are transitively blocked by this task
1506: getBlockingImpact :: [Task] -> Task -> Int
1507: getBlockingImpact allTasks task =
1508: length (getTransitiveDependents allTasks (taskId task))
1509:
1510: -- | Get all tasks that depend on this task (directly or transitively)
1511: -- Uses a Set to track visited nodes and avoid infinite loops from circular deps
1512: getTransitiveDependents :: [Task] -> Text -> [Task]
1513: getTransitiveDependents allTasks tid = go Set.empty [tid]
1514: where
1515: go :: Set.Set Text -> [Text] -> [Task]
1516: go _ [] = []
1517: go visited (current : rest)
1518: | Set.member current visited = go visited rest
1519: | otherwise =
1520: let directDeps = [t | t <- allTasks, dependsOnTask current t]
1521: newIds = [taskId t | t <- directDeps, not (Set.member (taskId t) visited)]
1522: visited' = Set.insert current visited
1523: in directDeps ++ go visited' (newIds ++ rest)
1524:
1525: -- | Check if task depends on given ID with Blocks dependency type
1526: dependsOnTask :: Text -> Task -> Bool
1527: dependsOnTask tid task =
1528: any (\d -> matchesId (depId d) tid && depType d == Blocks) (taskDependencies task)
1529:
1530: -- | Get tasks that have failed 3+ times and need human intervention
1531: getInterventionTasks :: IO [Task]
1532: getInterventionTasks = do
1533: allTasks <- loadTasks
1534: retryContexts <- getAllRetryContexts
1535: let highRetryIds = [retryTaskId ctx | ctx <- retryContexts, retryAttempt ctx >= 3]
1536: pure [t | t <- allTasks, taskId t `elem` highRetryIds]
1537:
1538: -- | Get all items needing human action
1539: getHumanActionItems :: IO HumanActionItems
1540: getHumanActionItems = do
1541: allTasks <- loadTasks
1542: retryContexts <- getAllRetryContexts
1543: let highRetryIds = [retryTaskId ctx | ctx <- retryContexts, retryAttempt ctx >= 3]
1544: failed = [t | t <- allTasks, taskId t `elem` highRetryIds]
1545: epics = [t | t <- allTasks, taskType t == Epic, taskStatus t /= Done]
1546: epicsReady =
1547: [ EpicForReview
1548: { epicTask = e,
1549: epicTotal = total,
1550: epicCompleted = completed
1551: }
1552: | e <- epics,
1553: let children = [c | c <- allTasks, taskParent c == Just (taskId e)],
1554: let total = length children,
1555: total > 0,
1556: let completed = length [c | c <- children, taskStatus c == Done],
1557: completed == total
1558: ]
1559: human = [t | t <- allTasks, taskType t == HumanTask, taskStatus t == Open]
1560: pure
1561: HumanActionItems
1562: { failedTasks = failed,
1563: epicsInReview = epicsReady,
1564: humanTasks = human
1565: }
1566:
1567: -- | Get all retry contexts from the database
1568: getAllRetryContexts :: IO [RetryContext]
1569: getAllRetryContexts =
1570: withDb <| \conn -> do
1571: rows <-
1572: SQL.query_
1573: conn
1574: "SELECT task_id, original_commit, conflict_files, attempt, reason, notes FROM retry_context" ::
1575: IO [(Text, Text, Text, Int, Text, Maybe Text)]
1576: pure
1577: [ RetryContext
1578: { retryTaskId = tid,
1579: retryOriginalCommit = commit,
1580: retryConflictFiles = fromMaybe [] (decode (BLC.pack (T.unpack filesJson))),
1581: retryAttempt = attempt,
1582: retryReason = reason,
1583: retryNotes = notes
1584: }
1585: | (tid, commit, filesJson, attempt, reason, notes) <- rows
1586: ]
1587:
1588: -- | Update just the notes field for a retry context
1589: updateRetryNotes :: Text -> Text -> IO ()
1590: updateRetryNotes tid notes = do
1591: maybeCtx <- getRetryContext tid
1592: case maybeCtx of
1593: Nothing ->
1594: setRetryContext
1595: RetryContext
1596: { retryTaskId = tid,
1597: retryOriginalCommit = "",
1598: retryConflictFiles = [],
1599: retryAttempt = 0,
1600: retryReason = "",
1601: retryNotes = Just notes
1602: }
1603: Just ctx ->
1604: setRetryContext ctx {retryNotes = Just notes}
1605:
1606: -- Fact management
1607:
1608: -- | Save a fact to the database
1609: saveFact :: Fact -> IO Int
1610: saveFact f =
1611: withDb <| \conn -> do
1612: let filesJson = T.pack <| BLC.unpack <| encode (factRelatedFiles f)
1613: SQL.execute
1614: conn
1615: "INSERT INTO facts (project, fact, related_files, source_task, confidence, created_at) \
1616: \VALUES (?, ?, ?, ?, ?, ?)"
1617: (factProject f, factContent f, filesJson, factSourceTask f, factConfidence f, factCreatedAt f)
1618: [SQL.Only factIdVal] <- SQL.query_ conn "SELECT last_insert_rowid()" :: IO [SQL.Only Int]
1619: pure factIdVal
1620:
1621: -- | Load all facts from the database
1622: loadFacts :: IO [Fact]
1623: loadFacts =
1624: withDb <| \conn ->
1625: SQL.query_
1626: conn
1627: "SELECT id, project, fact, related_files, source_task, confidence, created_at FROM facts"
1628:
1629: -- | Get facts for a specific project
1630: getFactsForProject :: Text -> IO [Fact]
1631: getFactsForProject proj =
1632: withDb <| \conn ->
1633: SQL.query
1634: conn
1635: "SELECT id, project, fact, related_files, source_task, confidence, created_at \
1636: \FROM facts WHERE project = ? ORDER BY confidence DESC"
1637: (SQL.Only proj)
1638:
1639: -- | Get facts related to a specific file
1640: getFactsForFile :: Text -> IO [Fact]
1641: getFactsForFile filePath =
1642: withDb <| \conn ->
1643: SQL.query
1644: conn
1645: "SELECT id, project, fact, related_files, source_task, confidence, created_at \
1646: \FROM facts WHERE related_files LIKE ? ORDER BY confidence DESC"
1647: (SQL.Only ("%" <> filePath <> "%"))
1648:
1649: -- | Delete a fact by ID
1650: deleteFact :: Int -> IO ()
1651: deleteFact fid =
1652: withDb <| \conn ->
1653: SQL.execute conn "DELETE FROM facts WHERE id = ?" (SQL.Only fid)
1654:
1655: -- ============================================================================
1656: -- Agent Events (for observability)
1657: -- ============================================================================
1658:
1659: instance SQL.FromField CommentAuthor where
1660: fromField f = do
1661: t <- SQL.fromField f :: SQLOk.Ok String
1662: case t of
1663: "human" -> pure Human
1664: "junior" -> pure Junior
1665: "system" -> pure System
1666: _ -> SQL.returnError SQL.ConversionFailed f "Invalid CommentAuthor"
1667:
1668: instance SQL.ToField CommentAuthor where
1669: toField Human = SQL.toField ("human" :: String)
1670: toField Junior = SQL.toField ("junior" :: String)
1671: toField System = SQL.toField ("system" :: String)
1672:
1673: -- | Stored agent event record
1674: data StoredEvent = StoredEvent
1675: { storedEventId :: Int,
1676: storedEventTaskId :: Text,
1677: storedEventSessionId :: Text,
1678: storedEventTimestamp :: UTCTime,
1679: storedEventType :: Text,
1680: storedEventContent :: Text,
1681: storedEventActor :: CommentAuthor
1682: }
1683: deriving (Show, Eq, Generic)
1684:
1685: instance ToJSON StoredEvent
1686:
1687: instance FromJSON StoredEvent
1688:
1689: instance SQL.FromRow StoredEvent where
1690: fromRow =
1691: StoredEvent
1692: </ SQL.field
1693: <*> SQL.field
1694: <*> SQL.field
1695: <*> SQL.field
1696: <*> SQL.field
1697: <*> SQL.field
1698: <*> SQL.field
1699:
1700: -- | Generate a new session ID (timestamp-based for simplicity)
1701: generateSessionId :: IO Text
1702: generateSessionId = do
1703: now <- getCurrentTime
1704: pure <| "s-" <> T.pack (show now)
1705:
1706: -- | Insert an agent event with actor
1707: insertAgentEvent :: Text -> Text -> Text -> Text -> CommentAuthor -> IO ()
1708: insertAgentEvent taskId sessionId eventType content actor =
1709: withDb <| \conn ->
1710: SQL.execute
1711: conn
1712: "INSERT INTO agent_events (task_id, session_id, event_type, content, actor) VALUES (?, ?, ?, ?, ?)"
1713: (taskId, sessionId, eventType, content, actor)
1714:
1715: -- | Get all events for a task (most recent session)
1716: getEventsForTask :: Text -> IO [StoredEvent]
1717: getEventsForTask taskId = do
1718: maybeSession <- getLatestSessionForTask taskId
1719: case maybeSession of
1720: Nothing -> pure []
1721: Just sid -> getEventsForSession sid
1722:
1723: -- | Get all events for a specific session
1724: getEventsForSession :: Text -> IO [StoredEvent]
1725: getEventsForSession sessionId =
1726: withDb <| \conn ->
1727: SQL.query
1728: conn
1729: "SELECT id, task_id, session_id, timestamp, event_type, content, actor \
1730: \FROM agent_events WHERE session_id = ? ORDER BY id ASC"
1731: (SQL.Only sessionId)
1732:
1733: -- | Get all sessions for a task
1734: getSessionsForTask :: Text -> IO [Text]
1735: getSessionsForTask taskId =
1736: withDb <| \conn -> do
1737: rows <-
1738: SQL.query
1739: conn
1740: "SELECT DISTINCT session_id FROM agent_events WHERE task_id = ? ORDER BY session_id DESC"
1741: (SQL.Only taskId) ::
1742: IO [SQL.Only Text]
1743: pure [sid | SQL.Only sid <- rows]
1744:
1745: -- | Get the most recent session ID for a task
1746: getLatestSessionForTask :: Text -> IO (Maybe Text)
1747: getLatestSessionForTask taskId =
1748: withDb <| \conn -> do
1749: rows <-
1750: SQL.query
1751: conn
1752: "SELECT session_id FROM agent_events WHERE task_id = ? ORDER BY id DESC LIMIT 1"
1753: (SQL.Only taskId) ::
1754: IO [SQL.Only Text]
1755: pure <| case rows of
1756: [SQL.Only sid] -> Just sid
1757: _ -> Nothing
1758:
1759: -- | Get events for a task since a given event ID (for streaming/polling)
1760: getEventsSince :: Text -> Int -> IO [StoredEvent]
1761: getEventsSince sessionId lastId =
1762: withDb <| \conn ->
1763: SQL.query
1764: conn
1765: "SELECT id, task_id, session_id, timestamp, event_type, content, actor \
1766: \FROM agent_events WHERE session_id = ? AND id > ? ORDER BY id ASC"
1767: (sessionId, lastId)
1768:
1769: -- | Insert a checkpoint event (for progress tracking)
1770: insertCheckpoint :: Text -> Text -> Text -> IO ()
1771: insertCheckpoint taskId sessionId content =
1772: insertAgentEvent taskId sessionId "Checkpoint" content Junior
1773:
1774: -- | Get all checkpoints for a task (across all sessions)
1775: getCheckpointsForTask :: Text -> IO [StoredEvent]
1776: getCheckpointsForTask taskId =
1777: withDb <| \conn ->
1778: SQL.query
1779: conn
1780: "SELECT id, task_id, session_id, timestamp, event_type, content, actor \
1781: \FROM agent_events WHERE task_id = ? AND event_type = 'Checkpoint' ORDER BY id ASC"
1782: (SQL.Only taskId)
1783:
1784: -- | Get progress summary for a task (concatenated checkpoint contents)
1785: getProgressSummary :: Text -> IO (Maybe Text)
1786: getProgressSummary taskId = do
1787: checkpoints <- getCheckpointsForTask taskId
1788: if null checkpoints
1789: then pure Nothing
1790: else pure <| Just <| T.intercalate "\n\n---\n\n" [storedEventContent e | e <- checkpoints]
1791:
1792: -- | Get all comments for a task (from agent_events)
1793: getCommentsForTask :: Text -> IO [StoredEvent]
1794: getCommentsForTask taskId =
1795: withDb <| \conn ->
1796: SQL.query
1797: conn
1798: "SELECT id, task_id, session_id, timestamp, event_type, content, actor \
1799: \FROM agent_events WHERE task_id = ? AND event_type = 'comment' ORDER BY id ASC"
1800: (SQL.Only taskId)
1801:
1802: -- | Convert stored events to Comment type for backward compatibility
1803: storedEventToComment :: StoredEvent -> Comment
1804: storedEventToComment evt =
1805: Comment
1806: { commentText = storedEventContent evt,
1807: commentAuthor = storedEventActor evt,
1808: commentCreatedAt = storedEventTimestamp evt
1809: }
1810:
1811: -- | Get all timeline events for a task (across all sessions)
1812: -- Includes: comments, status changes, tool calls, checkpoints, errors, etc.
1813: getAllEventsForTask :: Text -> IO [StoredEvent]
1814: getAllEventsForTask taskId =
1815: withDb <| \conn ->
1816: SQL.query
1817: conn
1818: "SELECT id, task_id, session_id, timestamp, event_type, content, actor \
1819: \FROM agent_events WHERE task_id = ? ORDER BY timestamp ASC, id ASC"
1820: (SQL.Only taskId)
Now let me search for any other files that reference HumanTask or the related code:
HumanTask./Omni/Jr/Web.hs:1086: human = TaskCore.humanTasks actionItems ./Omni/Task.hs:150: Just "human" -> pure HumanTask ./Omni/Task.hs:298: Just "human" -> pure <| Just HumanTask ./Omni/Task.hs:624: task <- createTask "Human Task" HumanTask Nothing Nothing P2 Nothing [] "Human task description" ./Omni/Task.hs:625: taskType task Test.@?= HumanTask, ./Omni/Task.hs:627: task <- createTask "Human Task" HumanTask Nothing Nothing P2 Nothing [] "Human task" ./Omni/Task/Core.hs:48:data TaskType = Epic | WorkTask | HumanTask ./Omni/Task/Core.hs:89: humanTasks :: [Task] ./Omni/Task/Core.hs:810: /= HumanTask ./Omni/Task/Core.hs:1559: human = [t | t <- allTasks, taskType t == HumanTask, taskStatus t == Open] ./Omni/Task/Core.hs:1564: humanTasks = human
Now let me check if there are any references to "NeedsHelp" already, and also check the Web.hs file to understand the usage:
NeedsHelpOmni/Jr/Web.hs @1080-10951080: instance Lucid.ToHtml InterventionPage where
1081: toHtmlRaw = Lucid.toHtml
1082: toHtml (InterventionPage actionItems currentSort _now) =
1083: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Needs Human Action" Nothing]
1084: failed = TaskCore.failedTasks actionItems
1085: epicsReady = TaskCore.epicsInReview actionItems
1086: human = TaskCore.humanTasks actionItems
1087: totalCount = length failed + length epicsReady + length human
1088: in Lucid.doctypehtml_ <| do
1089: pageHead "Needs Human Action - Jr"
1090: pageBodyWithCrumbs crumbs <| do
1091: Lucid.div_ [Lucid.class_ "container"] <| do
1092: Lucid.div_ [Lucid.class_ "page-header-row"] <| do
1093: Lucid.h1_ <| Lucid.toHtml ("Needs Human Action (" <> tshow totalCount <> " items)")
1094: sortDropdown "/intervention" currentSort
1095: if totalCount == 0
Now I understand the full context. Let me implement the changes:
1. Remove HumanTask from TaskType
2. Add NeedsHelp to Status
3. Update getReadyTasks to filter NeedsHelp instead of HumanTask
4. Update all call sites
5. Update tests
Let me start by modifying Omni/Task/Core.hs:
Omni/Task/Core.hsNow update the HumanActionItems record to remove humanTasks:
Omni/Task/Core.hsNow update getReadyTasks to filter by NeedsHelp status instead of HumanTask type:
Omni/Task/Core.hsLet me check the exact formatting:
Omni/Task/Core.hs @789-814789: -- Get ready tasks 790: getReadyTasks :: IO [Task] 791: getReadyTasks = do 792: allTasks <- loadTasks 793: retryContexts <- getAllRetryContexts 794: let openTasks = filter (\t -> taskStatus t `elem` [Open, InProgress]) allTasks 795: doneIds = map taskId <| filter (\t -> taskStatus t == Done) allTasks 796: 797: parentIds = mapMaybe taskParent allTasks 798: isParent tid = tid `elem` parentIds 799: 800: -- Tasks with retry_attempt >= 3 need human intervention 801: needsInterventionIds = [retryTaskId ctx | ctx <- retryContexts, retryAttempt ctx >= 3] 802: 803: blockingDepIds task = [depId dep | dep <- taskDependencies task, depType dep `elem` [Blocks, ParentChild]] 804: isReady task = 805: taskType task 806: /= Epic 807: && not (isParent (taskId task)) 808: && all (`elem` doneIds) (blockingDepIds task) 809: && taskType task 810: /= HumanTask 811: && taskId task 812: `notElem` needsInterventionIds 813: pure <| filter isReady openTasks 814:
Omni/Task/Core.hsNow update getHumanActionItems to use NeedsHelp status:
Omni/Task/Core.hs @1538-15661538: -- | Get all items needing human action
1539: getHumanActionItems :: IO HumanActionItems
1540: getHumanActionItems = do
1541: allTasks <- loadTasks
1542: retryContexts <- getAllRetryContexts
1543: let highRetryIds = [retryTaskId ctx | ctx <- retryContexts, retryAttempt ctx >= 3]
1544: failed = [t | t <- allTasks, taskId t `elem` highRetryIds]
1545: epics = [t | t <- allTasks, taskType t == Epic, taskStatus t /= Done]
1546: epicsReady =
1547: [ EpicForReview
1548: { epicTask = e,
1549: epicTotal = total,
1550: epicCompleted = completed
1551: }
1552: | e <- epics,
1553: let children = [c | c <- allTasks, taskParent c == Just (taskId e)],
1554: let total = length children,
1555: total > 0,
1556: let completed = length [c | c <- children, taskStatus c == Done],
1557: completed == total
1558: ]
1559: human = [t | t <- allTasks, taskType t == HumanTask, taskStatus t == Open]
1560: pure
1561: HumanActionItems
1562: { failedTasks = failed,
1563: epicsInReview = epicsReady,
1564: humanTasks = human
1565: }
1566:
Omni/Task/Core.hsNow let's update the CLI in Omni/Task.hs. First, remove "human" from the --type option:
Omni/Task.hsOmni/Task.hsOmni/Task.hs{"contents":[210.42449999999997,200],"tag":"GuardrailCostExceeded"}