diff options
Diffstat (limited to 'Omni/Task/Core.hs')
| -rw-r--r-- | Omni/Task/Core.hs | 1567 |
1 files changed, 1567 insertions, 0 deletions
diff --git a/Omni/Task/Core.hs b/Omni/Task/Core.hs new file mode 100644 index 0000000..c930b2c --- /dev/null +++ b/Omni/Task/Core.hs @@ -0,0 +1,1567 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- : dep http-api-data +module Omni.Task.Core where + +import Alpha +import Data.Aeson (FromJSON, ToJSON, decode, encode) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.Char8 as BLC +import qualified Data.List as List +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.Time (UTCTime, diffUTCTime, getCurrentTime) +import qualified Database.SQLite.Simple as SQL +import qualified Database.SQLite.Simple.FromField as SQL +import qualified Database.SQLite.Simple.Ok as SQLOk +import qualified Database.SQLite.Simple.ToField as SQL +import GHC.Generics () +import System.Directory (XdgDirectory (..), createDirectoryIfMissing, doesFileExist, getXdgDirectory) +import System.Environment (lookupEnv) +import System.FilePath (takeDirectory, (</>)) +import System.IO.Unsafe (unsafePerformIO) +import Web.HttpApiData (FromHttpApiData (..)) + +-- Core data types +data Task = Task + { taskId :: Text, + taskTitle :: Text, + taskType :: TaskType, + taskParent :: Maybe Text, -- Parent epic ID + taskNamespace :: Maybe Text, -- Optional namespace (e.g., "Omni/Task", "Biz/Cloud") + taskStatus :: Status, + taskPriority :: Priority, -- Priority level (0-4) + taskComplexity :: Maybe Int, -- Complexity 1-5 for model selection + taskDependencies :: [Dependency], -- List of dependencies with types + taskDescription :: Text, -- Required description + taskComments :: [Comment], -- Timestamped comments for extra context + taskCreatedAt :: UTCTime, + taskUpdatedAt :: UTCTime + } + deriving (Show, Eq, Generic) + +data TaskType = Epic | WorkTask | HumanTask + deriving (Show, Eq, Read, Generic) + +data Status = Draft | Open | InProgress | Review | Approved | Done + deriving (Show, Eq, Read, Generic) + +-- Priority levels (matching beads convention) +data Priority = P0 | P1 | P2 | P3 | P4 + deriving (Show, Eq, Ord, Read, Generic) + +data Dependency = Dependency + { depId :: Text, -- ID of the task this depends on + depType :: DependencyType -- Type of dependency relationship + } + deriving (Show, Eq, Generic) + +data DependencyType + = Blocks -- Hard dependency, blocks ready work queue + | DiscoveredFrom -- Work discovered during other work + | ParentChild -- Epic/subtask relationship + | Related -- Soft relationship, doesn't block + deriving (Show, Eq, Read, Generic) + +data TaskProgress = TaskProgress + { progressTaskId :: Text, + progressTotal :: Int, + progressCompleted :: Int, + progressPercentage :: Int + } + deriving (Show, Eq, Generic) + +data EpicForReview = EpicForReview + { epicTask :: Task, + epicTotal :: Int, + epicCompleted :: Int + } + deriving (Show, Eq, Generic) + +data HumanActionItems = HumanActionItems + { failedTasks :: [Task], + epicsInReview :: [EpicForReview], + humanTasks :: [Task] + } + deriving (Show, Eq, Generic) + +data AggregatedMetrics = AggregatedMetrics + { aggTotalCostCents :: Int, + aggTotalDurationSeconds :: Int, + aggCompletedTasks :: Int, + aggTotalTokens :: Int + } + deriving (Show, Eq, Generic) + +-- Retry context for tasks that failed due to merge conflicts +data RetryContext = RetryContext + { retryTaskId :: Text, + retryOriginalCommit :: Text, + retryConflictFiles :: [Text], + retryAttempt :: Int, + retryReason :: Text, -- "merge_conflict" | "ci_failure" | "rejected" + retryNotes :: Maybe Text -- Human notes/guidance for intervention + } + deriving (Show, Eq, Generic) + +-- Activity stage for task_activity tracking +data ActivityStage = Claiming | Running | Reviewing | Retrying | Completed | Failed + deriving (Show, Eq, Read, Generic) + +-- Task activity log entry +data TaskActivity = TaskActivity + { activityId :: Maybe Int, -- NULL for new entries, set by DB + activityTaskId :: Text, + activityTimestamp :: UTCTime, + activityStage :: ActivityStage, + activityMessage :: Maybe Text, + activityMetadata :: Maybe Text, -- JSON for extra data + activityThreadUrl :: Maybe Text, -- Link to agent session (unused with native Engine) + activityStartedAt :: Maybe UTCTime, -- When work started + activityCompletedAt :: Maybe UTCTime, -- When work completed + activityCostCents :: Maybe Int, -- API cost in cents + activityTokensUsed :: Maybe Int -- Total tokens used + } + deriving (Show, Eq, Generic) + +-- Fact for knowledge base +data Fact = Fact + { factId :: Maybe Int, + factProject :: Text, + factContent :: Text, + factRelatedFiles :: [Text], + factSourceTask :: Maybe Text, + factConfidence :: Double, + factCreatedAt :: UTCTime + } + deriving (Show, Eq, Generic) + +-- Comment for task notes/context +data Comment = Comment + { commentText :: Text, + commentCreatedAt :: UTCTime + } + deriving (Show, Eq, Generic) + +instance ToJSON TaskType + +instance FromJSON TaskType + +instance ToJSON Status + +instance FromJSON Status + +instance ToJSON Priority + +instance FromJSON Priority + +instance ToJSON DependencyType + +instance FromJSON DependencyType + +instance ToJSON Dependency + +instance FromJSON Dependency + +instance ToJSON Task + +instance FromJSON Task + +instance ToJSON TaskProgress + +instance FromJSON TaskProgress + +instance ToJSON AggregatedMetrics + +instance FromJSON AggregatedMetrics + +instance ToJSON RetryContext + +instance FromJSON RetryContext + +instance ToJSON ActivityStage + +instance FromJSON ActivityStage + +instance ToJSON TaskActivity + +instance FromJSON TaskActivity + +instance ToJSON Fact + +instance FromJSON Fact + +instance ToJSON Comment + +instance FromJSON Comment + +-- HTTP API Instances (for Servant query params) + +instance FromHttpApiData Status where + parseQueryParam t + | T.null t = Left "No status provided" + | otherwise = case readMaybe (T.unpack t) of + Just s -> Right s + Nothing -> Left ("Invalid status: " <> t) + +instance FromHttpApiData Priority where + parseQueryParam t + | T.null t = Left "No priority provided" + | otherwise = case readMaybe (T.unpack t) of + Just p -> Right p + Nothing -> Left ("Invalid priority: " <> t) + +-- SQLite Instances + +instance SQL.FromField TaskType where + fromField f = do + t <- SQL.fromField f :: SQLOk.Ok String + case readMaybe t of + Just x -> pure x + Nothing -> SQL.returnError SQL.ConversionFailed f "Invalid TaskType" + +instance SQL.ToField TaskType where + toField x = SQL.toField (show x :: String) + +instance SQL.FromField Status where + fromField f = do + t <- SQL.fromField f :: SQLOk.Ok String + case readMaybe t of + Just x -> pure x + Nothing -> SQL.returnError SQL.ConversionFailed f "Invalid Status" + +instance SQL.ToField Status where + toField x = SQL.toField (show x :: String) + +instance SQL.FromField Priority where + fromField f = do + t <- SQL.fromField f :: SQLOk.Ok String + case readMaybe t of + Just x -> pure x + Nothing -> SQL.returnError SQL.ConversionFailed f "Invalid Priority" + +instance SQL.ToField Priority where + toField x = SQL.toField (show x :: String) + +instance SQL.FromField ActivityStage where + fromField f = do + t <- SQL.fromField f :: SQLOk.Ok String + case readMaybe t of + Just x -> pure x + Nothing -> SQL.returnError SQL.ConversionFailed f "Invalid ActivityStage" + +instance SQL.ToField ActivityStage where + toField x = SQL.toField (show x :: String) + +-- Store dependencies as JSON text +instance SQL.FromField [Dependency] where + fromField f = do + mt <- SQL.fromField f :: SQLOk.Ok (Maybe String) + case mt of + Nothing -> pure [] + Just t -> case Aeson.decode (BLC.pack t) of + Just x -> pure x + Nothing -> pure [] + +instance SQL.ToField [Dependency] where + toField deps = SQL.toField (BLC.unpack (encode deps)) + +-- Store comments as JSON text +instance SQL.FromField [Comment] where + fromField f = do + mt <- SQL.fromField f :: SQLOk.Ok (Maybe String) + case mt of + Nothing -> pure [] + Just t -> case Aeson.decode (BLC.pack t) of + Just x -> pure x + Nothing -> pure [] + +instance SQL.ToField [Comment] where + toField comments = SQL.toField (BLC.unpack (encode comments)) + +instance SQL.FromRow Task where + fromRow = + Task + </ SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field -- complexity + <*> SQL.field + <*> (fromMaybe "" </ SQL.field) -- Handle NULL description from legacy data + <*> SQL.field -- comments + <*> SQL.field + <*> SQL.field + +instance SQL.ToRow Task where + toRow t = + [ SQL.toField (taskId t), + SQL.toField (taskTitle t), + SQL.toField (taskType t), + SQL.toField (taskParent t), + SQL.toField (taskNamespace t), + SQL.toField (taskStatus t), + SQL.toField (taskPriority t), + SQL.toField (taskComplexity t), + SQL.toField (taskDependencies t), + SQL.toField (taskDescription t), + SQL.toField (taskComments t), + SQL.toField (taskCreatedAt t), + SQL.toField (taskUpdatedAt t) + ] + +instance SQL.FromRow TaskActivity where + fromRow = + TaskActivity + </ SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + <*> SQL.field + +instance SQL.ToRow TaskActivity where + toRow a = + [ SQL.toField (activityId a), + SQL.toField (activityTaskId a), + SQL.toField (activityTimestamp a), + SQL.toField (activityStage a), + SQL.toField (activityMessage a), + SQL.toField (activityMetadata a), + SQL.toField (activityThreadUrl a), + SQL.toField (activityStartedAt a), + SQL.toField (activityCompletedAt a), + SQL.toField (activityCostCents a), + SQL.toField (activityTokensUsed a) + ] + +instance SQL.FromRow Fact where + fromRow = do + fid <- SQL.field + proj <- SQL.field + content <- SQL.field + (relatedFilesJson :: String) <- SQL.field + sourceTask <- SQL.field + confidence <- SQL.field + createdAt <- SQL.field + let relatedFiles = fromMaybe [] (decode (BLC.pack relatedFilesJson)) + pure + Fact + { factId = fid, + factProject = proj, + factContent = content, + factRelatedFiles = relatedFiles, + factSourceTask = sourceTask, + factConfidence = confidence, + factCreatedAt = createdAt + } + +instance SQL.ToRow Fact where + toRow f = + [ SQL.toField (factId f), + SQL.toField (factProject f), + SQL.toField (factContent f), + SQL.toField (BLC.unpack (encode (factRelatedFiles f))), + SQL.toField (factSourceTask f), + SQL.toField (factConfidence f), + SQL.toField (factCreatedAt f) + ] + +-- | Case-insensitive ID comparison +matchesId :: Text -> Text -> Bool +matchesId id1 id2 = normalizeId id1 == normalizeId id2 + +-- | Normalize ID to lowercase +normalizeId :: Text -> Text +normalizeId = T.toLower + +-- | Find a task by ID (case-insensitive) +findTask :: Text -> [Task] -> Maybe Task +findTask tid = List.find (\t -> matchesId (taskId t) tid) + +-- | Normalize task IDs (self, parent, dependencies) to lowercase +normalizeTask :: Task -> Task +normalizeTask t = + t + { taskId = normalizeId (taskId t), + taskParent = fmap normalizeId (taskParent t), + taskDependencies = map normalizeDependency (taskDependencies t) + } + +normalizeDependency :: Dependency -> Dependency +normalizeDependency d = d {depId = normalizeId (depId d)} + +-- Lock for application-level thread safety (Read-Calc-Write cycles) +taskLock :: MVar () +taskLock = unsafePerformIO (newMVar ()) +{-# NOINLINE taskLock #-} + +withTaskLock :: IO a -> IO a +withTaskLock action = withMVar taskLock (const action) + +-- Get the tasks database file path +getTasksDbPath :: IO FilePath +getTasksDbPath = do + customPath <- lookupEnv "TASK_DB_PATH" + testMode <- lookupEnv "TASK_TEST_MODE" + case (testMode, customPath) of + (Just "1", _) -> pure "_/tmp/tasks-test.db" + (_, Just p) -> pure p + _ -> do + xdgData <- getXdgDirectory XdgData "jr" + pure (xdgData </> "jr.db") + +-- DB Helper +withDb :: (SQL.Connection -> IO a) -> IO a +withDb action = do + dbPath <- getTasksDbPath + SQL.withConnection dbPath <| \conn -> do + SQL.execute_ conn "PRAGMA busy_timeout = 5000" + action conn + +-- Initialize the task database +initTaskDb :: IO () +initTaskDb = do + dbPath <- getTasksDbPath + createDirectoryIfMissing True (takeDirectory dbPath) + withDb <| \conn -> do + SQL.execute_ + conn + "CREATE TABLE IF NOT EXISTS tasks (\ + \ id TEXT PRIMARY KEY, \ + \ title TEXT NOT NULL, \ + \ type TEXT NOT NULL, \ + \ parent TEXT, \ + \ namespace TEXT, \ + \ status TEXT NOT NULL, \ + \ priority TEXT NOT NULL, \ + \ complexity INTEGER, \ + \ dependencies TEXT NOT NULL, \ + \ description TEXT, \ + \ comments TEXT NOT NULL DEFAULT '[]', \ + \ created_at TIMESTAMP NOT NULL, \ + \ updated_at TIMESTAMP NOT NULL \ + \)" + SQL.execute_ + conn + "CREATE TABLE IF NOT EXISTS id_counter (\ + \ id INTEGER PRIMARY KEY CHECK (id = 1), \ + \ counter INTEGER NOT NULL DEFAULT 0 \ + \)" + SQL.execute_ + conn + "INSERT OR IGNORE INTO id_counter (id, counter) VALUES (1, 0)" + SQL.execute_ + conn + "CREATE TABLE IF NOT EXISTS retry_context (\ + \ task_id TEXT PRIMARY KEY, \ + \ original_commit TEXT NOT NULL, \ + \ conflict_files TEXT NOT NULL, \ + \ attempt INTEGER NOT NULL DEFAULT 1, \ + \ reason TEXT NOT NULL \ + \)" + SQL.execute_ + conn + "CREATE TABLE IF NOT EXISTS task_activity (\ + \ id INTEGER PRIMARY KEY AUTOINCREMENT, \ + \ task_id TEXT NOT NULL, \ + \ timestamp DATETIME DEFAULT CURRENT_TIMESTAMP, \ + \ stage TEXT NOT NULL, \ + \ message TEXT, \ + \ metadata TEXT, \ + \ amp_thread_url TEXT, \ + \ started_at DATETIME, \ + \ completed_at DATETIME, \ + \ cost_cents INTEGER, \ + \ tokens_used INTEGER, \ + \ FOREIGN KEY (task_id) REFERENCES tasks(id) \ + \)" + SQL.execute_ + conn + "CREATE TABLE IF NOT EXISTS facts (\ + \ id INTEGER PRIMARY KEY AUTOINCREMENT, \ + \ project TEXT NOT NULL, \ + \ fact TEXT NOT NULL, \ + \ related_files TEXT NOT NULL, \ + \ source_task TEXT, \ + \ confidence REAL NOT NULL, \ + \ created_at DATETIME DEFAULT CURRENT_TIMESTAMP \ + \)" + runMigrations conn + +-- | Run schema migrations to add missing columns to existing tables +runMigrations :: SQL.Connection -> IO () +runMigrations conn = do + migrateTable conn "task_activity" taskActivityColumns + migrateTable conn "tasks" tasksColumns + migrateTable conn "retry_context" retryContextColumns + migrateTable conn "facts" factsColumns + +-- | Expected columns for task_activity table (name, type, nullable) +taskActivityColumns :: [(Text, Text)] +taskActivityColumns = + [ ("id", "INTEGER"), + ("task_id", "TEXT"), + ("timestamp", "DATETIME"), + ("stage", "TEXT"), + ("message", "TEXT"), + ("metadata", "TEXT"), + ("amp_thread_url", "TEXT"), + ("started_at", "DATETIME"), + ("completed_at", "DATETIME"), + ("cost_cents", "INTEGER"), + ("tokens_used", "INTEGER") + ] + +-- | Expected columns for tasks table +tasksColumns :: [(Text, Text)] +tasksColumns = + [ ("id", "TEXT"), + ("title", "TEXT"), + ("type", "TEXT"), + ("parent", "TEXT"), + ("namespace", "TEXT"), + ("status", "TEXT"), + ("priority", "TEXT"), + ("complexity", "INTEGER"), + ("dependencies", "TEXT"), + ("description", "TEXT"), + ("comments", "TEXT"), + ("created_at", "TIMESTAMP"), + ("updated_at", "TIMESTAMP") + ] + +-- | Expected columns for retry_context table +retryContextColumns :: [(Text, Text)] +retryContextColumns = + [ ("task_id", "TEXT"), + ("original_commit", "TEXT"), + ("conflict_files", "TEXT"), + ("attempt", "INTEGER"), + ("reason", "TEXT"), + ("notes", "TEXT") + ] + +-- | Expected columns for facts table +factsColumns :: [(Text, Text)] +factsColumns = + [ ("id", "INTEGER"), + ("project", "TEXT"), + ("fact", "TEXT"), + ("related_files", "TEXT"), + ("source_task", "TEXT"), + ("confidence", "REAL"), + ("created_at", "DATETIME") + ] + +-- | Migrate a table by adding any missing columns +migrateTable :: SQL.Connection -> Text -> [(Text, Text)] -> IO () +migrateTable conn tableName expectedCols = do + existingCols <- getTableColumns conn tableName + let missingCols = filter (\(name, _) -> name `notElem` existingCols) expectedCols + traverse_ (addColumn conn tableName) missingCols + +-- | Get list of column names for a table using PRAGMA table_info +getTableColumns :: SQL.Connection -> Text -> IO [Text] +getTableColumns conn tableName = do + let query = SQL.Query <| "PRAGMA table_info(" <> tableName <> ")" + rows <- SQL.query_ conn query :: IO [(Int, Text, Text, Int, Maybe Text, Int)] + pure [colName | (_, colName, _, _, _, _) <- rows] + +-- | Add a column to a table +addColumn :: SQL.Connection -> Text -> (Text, Text) -> IO () +addColumn conn tableName (colName, colType) = do + let sql = "ALTER TABLE " <> tableName <> " ADD COLUMN " <> colName <> " " <> colType + SQL.execute_ conn (SQL.Query sql) + +-- Generate a sequential task ID (t-1, t-2, t-3, ...) +generateId :: IO Text +generateId = do + counter <- getNextCounter + pure <| "t-" <> T.pack (show counter) + +-- Get the next counter value (atomically increments) +getNextCounter :: IO Int +getNextCounter = + withDb <| \conn -> do + SQL.execute_ + conn + "CREATE TABLE IF NOT EXISTS id_counter (\ + \ id INTEGER PRIMARY KEY CHECK (id = 1), \ + \ counter INTEGER NOT NULL DEFAULT 0 \ + \)" + SQL.execute_ conn "INSERT OR IGNORE INTO id_counter (id, counter) VALUES (1, 0)" + SQL.execute_ conn "UPDATE id_counter SET counter = counter + 1 WHERE id = 1" + [SQL.Only c] <- SQL.query_ conn "SELECT counter FROM id_counter WHERE id = 1" :: IO [SQL.Only Int] + pure c + +-- Generate a child ID based on parent ID +generateChildId :: Text -> IO Text +generateChildId parentId = do + tasks <- loadTasks + pure <| computeNextChildId tasks (normalizeId parentId) + +computeNextChildId :: [Task] -> Text -> Text +computeNextChildId tasks parentId = + let suffixes = mapMaybe (getSuffix parentId <. taskId) tasks + nextSuffix = case suffixes of + [] -> 1 + s -> maximum s + 1 + in parentId <> "." <> T.pack (show nextSuffix) + +getSuffix :: Text -> Text -> Maybe Int +getSuffix parent childId = + if parent `T.isPrefixOf` childId && T.length childId > T.length parent + then + let rest = T.drop (T.length parent) childId + in if T.head rest == '.' + then readMaybe (T.unpack (T.tail rest)) + else Nothing + else Nothing + +-- Load all tasks from DB +loadTasks :: IO [Task] +loadTasks = + withDb <| \conn -> do + SQL.query_ conn "SELECT id, title, type, parent, namespace, status, priority, complexity, dependencies, description, comments, created_at, updated_at FROM tasks" + +-- Save a single task (UPSERT) +saveTask :: Task -> IO () +saveTask task = + withDb <| \conn -> do + SQL.execute + conn + "INSERT OR REPLACE INTO tasks \ + \ (id, title, type, parent, namespace, status, priority, complexity, dependencies, description, comments, created_at, updated_at) \ + \ VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)" + task + +-- Create a new task +createTask :: Text -> TaskType -> Maybe Text -> Maybe Text -> Priority -> Maybe Int -> [Dependency] -> Text -> IO Task +createTask title taskType parent namespace priority complexity deps description = + withTaskLock <| do + let parent' = fmap normalizeId parent + deps' = map normalizeDependency deps + + tid <- case parent' of + Nothing -> generateUniqueId + Just pid -> do + tasks <- loadTasks + pure <| computeNextChildId tasks pid + now <- getCurrentTime + let task = + Task + { taskId = normalizeId tid, + taskTitle = title, + taskType = taskType, + taskParent = parent', + taskNamespace = namespace, + taskStatus = Open, + taskPriority = priority, + taskComplexity = complexity, + taskDependencies = deps', + taskDescription = description, + taskComments = [], + taskCreatedAt = now, + taskUpdatedAt = now + } + saveTask task + pure task + +-- Generate a unique ID +generateUniqueId :: IO Text +generateUniqueId = do + -- We can query DB directly to check existence + go + where + go = do + tid <- generateId + exists <- + withDb <| \conn -> do + [SQL.Only c] <- SQL.query conn "SELECT COUNT(*) FROM tasks WHERE id = ?" (SQL.Only tid) :: IO [SQL.Only Int] + pure (c > 0) + if exists then go else pure tid + +-- Update task status +updateTaskStatus :: Text -> Status -> [Dependency] -> IO () +updateTaskStatus tid newStatus newDeps = + withTaskLock + <| withDb + <| \conn -> do + now <- getCurrentTime + -- If newDeps is empty, we need to preserve existing deps. + -- If newDeps is NOT empty, we replace them. + -- This logic is slightly tricky in SQL. We fetch first. + rows <- SQL.query conn "SELECT dependencies FROM tasks WHERE id = ?" (SQL.Only tid) :: IO [SQL.Only [Dependency]] + case rows of + [] -> pure () -- Task not found + (SQL.Only existingDeps : _) -> do + let finalDeps = if null newDeps then existingDeps else newDeps + SQL.execute + conn + "UPDATE tasks SET status = ?, updated_at = ?, dependencies = ? WHERE id = ?" + (newStatus, now, finalDeps, tid) + +-- Edit a task +editTask :: Text -> (Task -> Task) -> IO Task +editTask tid modifyFn = + withTaskLock <| do + tasks <- loadTasks + case findTask tid tasks of + Nothing -> panic "Task not found" + Just original -> do + now <- getCurrentTime + let modified = modifyFn original + finalTask = modified {taskUpdatedAt = now} + saveTask finalTask + pure finalTask + +-- Delete a task +deleteTask :: Text -> IO () +deleteTask tid = + withDb <| \conn -> + SQL.execute conn "DELETE FROM tasks WHERE id = ?" (SQL.Only tid) + +-- Add a comment to a task +addComment :: Text -> Text -> IO Task +addComment tid commentText = + withTaskLock <| do + tasks <- loadTasks + case findTask tid tasks of + Nothing -> panic "Task not found" + Just task -> do + now <- getCurrentTime + let newComment = Comment {commentText = commentText, commentCreatedAt = now} + updatedTask = task {taskComments = taskComments task ++ [newComment], taskUpdatedAt = now} + saveTask updatedTask + pure updatedTask + +-- List tasks +listTasks :: Maybe TaskType -> Maybe Text -> Maybe Status -> Maybe Text -> IO [Task] +listTasks maybeType maybeParent maybeStatus maybeNamespace = do + -- Implementing specific filters in SQL would be more efficient, but for MVP and API compat: + tasks <- loadTasks + let filtered = + tasks + |> filterByType maybeType + |> filterByParent maybeParent + |> filterByStatus maybeStatus + |> filterByNamespace maybeNamespace + pure filtered + where + filterByType Nothing ts = ts + filterByType (Just typ) ts = filter (\t -> taskType t == typ) ts + filterByParent Nothing ts = ts + filterByParent (Just pid) ts = filter (\t -> taskParent t == Just pid) ts + filterByStatus Nothing ts = ts + filterByStatus (Just status) ts = filter (\t -> taskStatus t == status) ts + filterByNamespace Nothing ts = ts + filterByNamespace (Just ns) ts = filter (\t -> taskNamespace t == Just ns) ts + +-- Get ready tasks +getReadyTasks :: IO [Task] +getReadyTasks = do + allTasks <- loadTasks + retryContexts <- getAllRetryContexts + let openTasks = filter (\t -> taskStatus t `elem` [Open, InProgress]) allTasks + doneIds = map taskId <| filter (\t -> taskStatus t == Done) allTasks + + parentIds = mapMaybe taskParent allTasks + isParent tid = tid `elem` parentIds + + -- Tasks with retry_attempt >= 3 need human intervention + needsInterventionIds = [retryTaskId ctx | ctx <- retryContexts, retryAttempt ctx >= 3] + + blockingDepIds task = [depId dep | dep <- taskDependencies task, depType dep `elem` [Blocks, ParentChild]] + isReady task = + taskType task + /= Epic + && not (isParent (taskId task)) + && all (`elem` doneIds) (blockingDepIds task) + && taskType task + /= HumanTask + && taskId task + `notElem` needsInterventionIds + pure <| filter isReady openTasks + +-- Get dependency tree +getDependencyTree :: Text -> IO [Task] +getDependencyTree tid = do + tasks <- loadTasks + case findTask tid tasks of + Nothing -> pure [] + Just task -> pure <| collectDeps tasks task + where + collectDeps allTasks task = + let depIds = map depId (taskDependencies task) + deps = filter (\t -> any (matchesId (taskId t)) depIds) allTasks + in task : concatMap (collectDeps allTasks) deps + +-- Get task progress +getTaskProgress :: Text -> IO TaskProgress +getTaskProgress tidRaw = do + let tid = normalizeId tidRaw + -- Could be SQL optimized + tasks <- loadTasks + case findTask tid tasks of + Nothing -> panic "Task not found" + Just _ -> do + let children = filter (\child -> taskParent child == Just tid) tasks + total = length children + completed = length <| filter (\child -> taskStatus child == Done) children + percentage = if total == 0 then 0 else (completed * 100) `div` total + pure + TaskProgress + { progressTaskId = tid, + progressTotal = total, + progressCompleted = completed, + progressPercentage = percentage + } + +showTaskProgress :: Text -> IO () +showTaskProgress tid = do + progress <- getTaskProgress tid + putText <| "Progress for " <> tid <> ": " <> T.pack (show (progressCompleted progress)) <> "/" <> T.pack (show (progressTotal progress)) <> " (" <> T.pack (show (progressPercentage progress)) <> "%)" + +showDependencyTree :: Text -> IO () +showDependencyTree tid = do + tasks <- loadTasks + case findTask tid tasks of + Nothing -> putText "Task not found" + Just task -> printTree tasks task 0 + where + printTree :: [Task] -> Task -> Int -> IO () + printTree allTasks task indent = do + putText <| T.pack (replicate (indent * 2) ' ') <> taskId task <> ": " <> taskTitle task + let depIds = map depId (taskDependencies task) + deps = filter (\t -> any (matchesId (taskId t)) depIds) allTasks + traverse_ (\dep -> printTree allTasks dep (indent + 1)) deps + +getTaskTree :: Maybe Text -> IO [Task] +getTaskTree maybeId = do + tasks <- loadTasks + case maybeId of + Nothing -> do + let epics = filter (\t -> taskType t == Epic) tasks + in pure <| concatMap (collectChildren tasks) epics + Just tid -> do + case findTask tid tasks of + Nothing -> pure [] + Just task -> pure <| collectChildren tasks task + where + collectChildren allTasks task = + let children = filter (maybe False (`matchesId` taskId task) <. taskParent) allTasks + in task : concatMap (collectChildren allTasks) children + +showTaskTree :: Maybe Text -> IO () +showTaskTree maybeId = do + tasks <- loadTasks + case maybeId of + Nothing -> do + let epics = filter (\t -> taskType t == Epic) tasks + if null epics + then putText "No epics found" + else traverse_ (printEpicTree tasks) epics + Just tid -> do + case findTask tid tasks of + Nothing -> putText "Task not found" + Just task -> printEpicTree tasks task + where + printEpicTree allTasks task = printTreeNode allTasks task (0 :: Int) + + printTreeNode allTasks task indent = printTreeNode' allTasks task indent [] + + printTreeNode' allTasks task indent ancestry = do + let children = filter (maybe False (`matchesId` taskId task) <. taskParent) allTasks + prefix = + if indent == 0 + then "" + else + let ancestorPrefixes = map (\hasMore -> if hasMore then "│ " else " ") (List.init ancestry) + myPrefix = if List.last ancestry then "├── " else "└── " + in T.pack <| concat ancestorPrefixes ++ myPrefix + statusStr = case taskType task of + Epic -> + let total = length children + completed = length <| filter (\t -> taskStatus t == Done) children + in "[" <> T.pack (show completed) <> "/" <> T.pack (show total) <> "]" + _ -> case taskStatus task of + Draft -> "[.]" + Open -> "[ ]" + InProgress -> "[~]" + Review -> "[?]" + Approved -> "[+]" + Done -> "[✓]" + + coloredStatusStr = case taskType task of + Epic -> magenta statusStr + _ -> case taskStatus task of + Draft -> gray statusStr + Open -> bold statusStr + InProgress -> yellow statusStr + Review -> magenta statusStr + Approved -> green statusStr + Done -> green statusStr + + nsStr = case taskNamespace task of + Nothing -> "" + Just ns -> "[" <> ns <> "] " + + coloredNsStr = case taskNamespace task of + Nothing -> "" + Just _ -> gray nsStr + + usedWidth = T.length prefix + T.length (taskId task) + T.length statusStr + T.length nsStr + 2 + availableWidth = max 20 (80 - usedWidth) + truncatedTitle = + if T.length (taskTitle task) > availableWidth + then T.take (availableWidth - 3) (taskTitle task) <> "..." + else taskTitle task + + coloredTitle = if taskType task == Epic then bold truncatedTitle else truncatedTitle + + putText <| prefix <> cyan (taskId task) <> " " <> coloredStatusStr <> " " <> coloredNsStr <> coloredTitle + + let indexedChildren = zip [1 ..] children + totalChildren = length children + traverse_ + ( \(idx, child) -> + let hasMoreSiblings = idx < totalChildren + in printTreeNode' allTasks child (indent + 1) (ancestry ++ [hasMoreSiblings]) + ) + indexedChildren + +printTask :: Task -> IO () +printTask t = do + tasks <- loadTasks + let progressInfo = + if taskType t == Epic + then + let children = filter (maybe False (`matchesId` taskId t) <. taskParent) tasks + total = length children + completed = length <| filter (\child -> taskStatus child == Done) children + in " [" <> T.pack (show completed) <> "/" <> T.pack (show total) <> "]" + else "" + + parentInfo = case taskParent t of + Nothing -> "" + Just p -> " (parent: " <> p <> ")" + + namespaceInfo = case taskNamespace t of + Nothing -> "" + Just ns -> " [" <> ns <> "]" + + coloredStatus = + let s = "[" <> T.pack (show (taskStatus t)) <> "]" + in case taskStatus t of + Draft -> gray s + Open -> bold s + InProgress -> yellow s + Review -> magenta s + Approved -> green s + Done -> green s + + coloredTitle = if taskType t == Epic then bold (taskTitle t) else taskTitle t + coloredProgress = if taskType t == Epic then magenta progressInfo else progressInfo + coloredNamespace = case taskNamespace t of + Nothing -> "" + Just _ -> gray namespaceInfo + coloredParent = case taskParent t of + Nothing -> "" + Just _ -> gray parentInfo + + putText + <| cyan (taskId t) + <> " [" + <> T.pack (show (taskType t)) + <> "] " + <> coloredStatus + <> coloredProgress + <> " " + <> coloredTitle + <> coloredParent + <> coloredNamespace + +showTaskDetailed :: Task -> IO () +showTaskDetailed t = do + tasks <- loadTasks + putText "" + putText <| "Title: " <> taskTitle t <> " (ID: " <> taskId t <> ")" + putText <| "Type: " <> T.pack (show (taskType t)) + putText <| "Status: " <> T.pack (show (taskStatus t)) + putText <| "Priority: " <> T.pack (show (taskPriority t)) <> priorityDesc + + when (taskType t == Epic) <| do + let children = filter (maybe False (`matchesId` taskId t) <. taskParent) tasks + total = length children + completed = length <| filter (\child -> taskStatus child == Done) children + percentage = if total == 0 then 0 else (completed * 100) `div` total + putText <| "Progress: " <> T.pack (show completed) <> "/" <> T.pack (show total) <> " (" <> T.pack (show percentage) <> "%)" + + case taskParent t of + Nothing -> pure () + Just p -> putText <| "Parent: " <> p + case taskNamespace t of + Nothing -> pure () + Just ns -> putText <| "Namespace: " <> ns + putText <| "Created: " <> T.pack (show (taskCreatedAt t)) + putText <| "Updated: " <> T.pack (show (taskUpdatedAt t)) + + unless (null (taskDependencies t)) <| do + putText "" + putText "Dependencies:" + traverse_ printDependency (taskDependencies t) + + unless (T.null (taskDescription t)) <| do + putText "" + putText "Description:" + let indented = T.unlines <| map (" " <>) (T.lines (taskDescription t)) + putText indented + + unless (null (taskComments t)) <| do + putText "" + putText "Comments:" + traverse_ printComment (taskComments t) + + putText "" + where + priorityDesc = case taskPriority t of + P0 -> " (Critical)" + P1 -> " (High)" + P2 -> " (Medium)" + P3 -> " (Low)" + P4 -> " (Backlog)" + + printDependency dep = + putText <| " - " <> depId dep <> " [" <> T.pack (show (depType dep)) <> "]" + + printComment c = + putText <| " [" <> T.pack (show (commentCreatedAt c)) <> "] " <> commentText c + +red, green, yellow, blue, magenta, cyan, gray, bold :: Text -> Text +red t = "\ESC[31m" <> t <> "\ESC[0m" +green t = "\ESC[32m" <> t <> "\ESC[0m" +yellow t = "\ESC[33m" <> t <> "\ESC[0m" +blue t = "\ESC[34m" <> t <> "\ESC[0m" +magenta t = "\ESC[35m" <> t <> "\ESC[0m" +cyan t = "\ESC[36m" <> t <> "\ESC[0m" +gray t = "\ESC[90m" <> t <> "\ESC[0m" +bold t = "\ESC[1m" <> t <> "\ESC[0m" + +-- Export tasks: Dump SQLite to JSONL +exportTasks :: Maybe FilePath -> IO () +exportTasks maybePath = do + tasks <- loadTasks + case maybePath of + Just path -> do + TIO.writeFile path "" + traverse_ (saveTaskToJsonl path) tasks + Nothing -> + -- Stream to stdout + traverse_ (BLC.putStrLn <. encode) tasks + +saveTaskToJsonl :: FilePath -> Task -> IO () +saveTaskToJsonl path task = do + let json = encode task + BLC.appendFile path (json <> "\n") + +data TaskStats = TaskStats + { totalTasks :: Int, + draftTasks :: Int, + openTasks :: Int, + inProgressTasks :: Int, + reviewTasks :: Int, + approvedTasks :: Int, + doneTasks :: Int, + totalEpics :: Int, + readyTasks :: Int, + blockedTasks :: Int, + tasksByPriority :: [(Priority, Int)], + tasksByNamespace :: [(Text, Int)] + } + deriving (Show, Eq, Generic) + +instance ToJSON TaskStats + +instance FromJSON TaskStats + +getTaskStats :: Maybe Text -> IO TaskStats +getTaskStats maybeEpicId = do + allTasks <- loadTasks + + targetTasks <- case maybeEpicId of + Nothing -> pure allTasks + Just epicId -> + case findTask epicId allTasks of + Nothing -> panic "Epic not found" + Just task -> pure <| getAllDescendants allTasks (taskId task) + + globalReady <- getReadyTasks + let readyIds = map taskId globalReady + readyCount = length <| filter (\t -> taskId t `elem` readyIds) targetTasks + + tasks = targetTasks + total = length tasks + draft = length <| filter (\t -> taskStatus t == Draft) tasks + open = length <| filter (\t -> taskStatus t == Open) tasks + inProg = length <| filter (\t -> taskStatus t == InProgress) tasks + review = length <| filter (\t -> taskStatus t == Review) tasks + approved = length <| filter (\t -> taskStatus t == Approved) tasks + done = length <| filter (\t -> taskStatus t == Done) tasks + epics = length <| filter (\t -> taskType t == Epic) tasks + readyCount' = readyCount + blockedCount = total - readyCount' - done - draft + byPriority = + [ (P0, length <| filter (\t -> taskPriority t == P0) tasks), + (P1, length <| filter (\t -> taskPriority t == P1) tasks), + (P2, length <| filter (\t -> taskPriority t == P2) tasks), + (P3, length <| filter (\t -> taskPriority t == P3) tasks), + (P4, length <| filter (\t -> taskPriority t == P4) tasks) + ] + namespaces = mapMaybe taskNamespace tasks + uniqueNs = List.nub namespaces + byNamespace = map (\ns -> (ns, length <| filter (\t -> taskNamespace t == Just ns) tasks)) uniqueNs + pure + TaskStats + { totalTasks = total, + draftTasks = draft, + openTasks = open, + inProgressTasks = inProg, + reviewTasks = review, + approvedTasks = approved, + doneTasks = done, + totalEpics = epics, + readyTasks = readyCount', + blockedTasks = blockedCount, + tasksByPriority = byPriority, + tasksByNamespace = byNamespace + } + +getAllDescendants :: [Task] -> Text -> [Task] +getAllDescendants allTasks parentId = + let children = filter (maybe False (`matchesId` parentId) <. taskParent) allTasks + in children ++ concatMap (getAllDescendants allTasks <. taskId) children + +computeTaskStatsFromList :: [Task] -> TaskStats +computeTaskStatsFromList tasks = + let total = length tasks + draft = length [t | t <- tasks, taskStatus t == Draft] + open = length [t | t <- tasks, taskStatus t == Open] + inProg = length [t | t <- tasks, taskStatus t == InProgress] + review = length [t | t <- tasks, taskStatus t == Review] + approved = length [t | t <- tasks, taskStatus t == Approved] + done = length [t | t <- tasks, taskStatus t == Done] + epics = length [t | t <- tasks, taskType t == Epic] + readyCount = open + inProg + blockedCount = 0 + byPriority = + [ (P0, length [t | t <- tasks, taskPriority t == P0]), + (P1, length [t | t <- tasks, taskPriority t == P1]), + (P2, length [t | t <- tasks, taskPriority t == P2]), + (P3, length [t | t <- tasks, taskPriority t == P3]), + (P4, length [t | t <- tasks, taskPriority t == P4]) + ] + namespaces = mapMaybe taskNamespace tasks + uniqueNs = List.nub namespaces + byNamespace = [(ns, length [t | t <- tasks, taskNamespace t == Just ns]) | ns <- uniqueNs] + in TaskStats + { totalTasks = total, + draftTasks = draft, + openTasks = open, + inProgressTasks = inProg, + reviewTasks = review, + approvedTasks = approved, + doneTasks = done, + totalEpics = epics, + readyTasks = readyCount, + blockedTasks = blockedCount, + tasksByPriority = byPriority, + tasksByNamespace = byNamespace + } + +showTaskStats :: Maybe Text -> IO () +showTaskStats maybeEpicId = do + stats <- getTaskStats maybeEpicId + putText "" + case maybeEpicId of + Nothing -> putText "Task Statistics" + Just epicId -> putText <| "Task Statistics for Epic " <> epicId + putText "" + putText <| "Total tasks: " <> T.pack (show (totalTasks stats)) + putText <| " Draft: " <> T.pack (show (draftTasks stats)) + putText <| " Open: " <> T.pack (show (openTasks stats)) + putText <| " In Progress: " <> T.pack (show (inProgressTasks stats)) + putText <| " Review: " <> T.pack (show (reviewTasks stats)) + putText <| " Approved: " <> T.pack (show (approvedTasks stats)) + putText <| " Done: " <> T.pack (show (doneTasks stats)) + putText "" + putText <| "Epics: " <> T.pack (show (totalEpics stats)) + putText "" + putText <| "Ready to work: " <> T.pack (show (readyTasks stats)) + putText <| "Blocked: " <> T.pack (show (blockedTasks stats)) + putText "" + putText "By Priority:" + traverse_ printPriority (tasksByPriority stats) + unless (null (tasksByNamespace stats)) <| do + putText "" + putText "By Namespace:" + traverse_ printNamespace (tasksByNamespace stats) + putText "" + where + printPriority (p, count) = + let label = case p of + P0 -> "P0 (Critical)" + P1 -> "P1 (High)" + P2 -> "P2 (Medium)" + P3 -> "P3 (Low)" + P4 -> "P4 (Backlog)" + in putText <| " " <> T.pack (show count) <> " " <> label + printNamespace (ns, count) = + putText <| " " <> T.pack (show count) <> " " <> ns + +-- Import tasks: Read from JSONL and insert/update DB +importTasks :: FilePath -> IO () +importTasks filePath = do + exists <- doesFileExist filePath + unless exists <| panic (T.pack filePath <> " does not exist") + + content <- TIO.readFile filePath + let importLines = T.lines content + importedTasks = map normalizeTask (mapMaybe decodeTask importLines) + + -- Save all imported tasks (UPSERT logic handles updates) + traverse_ saveTask importedTasks + where + decodeTask :: Text -> Maybe Task + decodeTask line = + if T.null line + then Nothing + else decode (BLC.pack <| T.unpack line) + +-- Retry context management + +-- | Get retry context for a task (if any) +getRetryContext :: Text -> IO (Maybe RetryContext) +getRetryContext tid = + withDb <| \conn -> do + rows <- + SQL.query + conn + "SELECT task_id, original_commit, conflict_files, attempt, reason, notes FROM retry_context WHERE task_id = ?" + (SQL.Only tid) :: + IO [(Text, Text, Text, Int, Text, Maybe Text)] + case rows of + [] -> pure Nothing + ((taskId', commit, filesJson, attempt, reason, notes) : _) -> + let files = fromMaybe [] (decode (BLC.pack <| T.unpack filesJson)) + in pure + <| Just + RetryContext + { retryTaskId = taskId', + retryOriginalCommit = commit, + retryConflictFiles = files, + retryAttempt = attempt, + retryReason = reason, + retryNotes = notes + } + +-- | Set retry context for a task (upsert) +setRetryContext :: RetryContext -> IO () +setRetryContext ctx = + withDb <| \conn -> do + let filesJson = T.pack <| BLC.unpack <| encode (retryConflictFiles ctx) + SQL.execute + conn + "INSERT OR REPLACE INTO retry_context (task_id, original_commit, conflict_files, attempt, reason, notes) VALUES (?, ?, ?, ?, ?, ?)" + (retryTaskId ctx, retryOriginalCommit ctx, filesJson, retryAttempt ctx, retryReason ctx, retryNotes ctx) + +-- | Clear retry context for a task (on successful merge) +clearRetryContext :: Text -> IO () +clearRetryContext tid = + withDb <| \conn -> + SQL.execute conn "DELETE FROM retry_context WHERE task_id = ?" (SQL.Only tid) + +-- | Increment retry attempt and return new count +incrementRetryAttempt :: Text -> IO Int +incrementRetryAttempt tid = do + maybeCtx <- getRetryContext tid + case maybeCtx of + Nothing -> pure 1 + Just ctx -> do + let newAttempt = retryAttempt ctx + 1 + setRetryContext ctx {retryAttempt = newAttempt} + pure newAttempt + +-- | Log activity to the task_activity table +logActivity :: Text -> ActivityStage -> Maybe Text -> IO () +logActivity tid stage metadata = + withDb <| \conn -> + SQL.execute + conn + "INSERT INTO task_activity (task_id, stage, message, metadata) VALUES (?, ?, ?, ?)" + (tid, show stage :: String, Nothing :: Maybe Text, metadata) + +-- | Log activity with worker metrics (amp thread URL, timing, cost) +logActivityWithMetrics :: Text -> ActivityStage -> Maybe Text -> Maybe Text -> Maybe UTCTime -> Maybe UTCTime -> Maybe Int -> Maybe Int -> IO Int +logActivityWithMetrics tid stage metadata ampUrl startedAt completedAt costCents tokens = + withDb <| \conn -> do + SQL.execute + conn + "INSERT INTO task_activity (task_id, stage, message, metadata, amp_thread_url, started_at, completed_at, cost_cents, tokens_used) \ + \VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?)" + (tid, show stage :: String, Nothing :: Maybe Text, metadata, ampUrl, startedAt, completedAt, costCents, tokens) + [SQL.Only actId] <- SQL.query_ conn "SELECT last_insert_rowid()" :: IO [SQL.Only Int] + pure actId + +-- | Update an existing activity record with metrics +updateActivityMetrics :: Int -> Maybe Text -> Maybe UTCTime -> Maybe Int -> Maybe Int -> IO () +updateActivityMetrics actId ampUrl completedAt costCents tokens = + withDb <| \conn -> + SQL.execute + conn + "UPDATE task_activity SET amp_thread_url = COALESCE(?, amp_thread_url), \ + \completed_at = COALESCE(?, completed_at), \ + \cost_cents = COALESCE(?, cost_cents), \ + \tokens_used = COALESCE(?, tokens_used) \ + \WHERE id = ?" + (ampUrl, completedAt, costCents, tokens, actId) + +-- | Get all activities for a task, ordered by timestamp descending +getActivitiesForTask :: Text -> IO [TaskActivity] +getActivitiesForTask tid = + withDb <| \conn -> + SQL.query + conn + "SELECT id, task_id, timestamp, stage, message, metadata, \ + \amp_thread_url, started_at, completed_at, cost_cents, tokens_used \ + \FROM task_activity WHERE task_id = ? ORDER BY timestamp DESC" + (SQL.Only tid) + +-- | Get the most recent running activity for a task (for metrics display) +getLatestRunningActivity :: Text -> IO (Maybe TaskActivity) +getLatestRunningActivity tid = do + activities <- getActivitiesForTask tid + pure <| List.find (\a -> activityStage a == Running) activities + +-- | Get aggregated metrics for all descendants of an epic +getAggregatedMetrics :: Text -> IO AggregatedMetrics +getAggregatedMetrics epicId = do + allTasks <- loadTasks + let descendants = getAllDescendants allTasks epicId + descendantIds = map taskId descendants + completedCount = length [t | t <- descendants, taskStatus t == Done] + activities <- concat </ traverse getActivitiesForTask descendantIds + let totalCost = sum [c | act <- activities, Just c <- [activityCostCents act]] + totalTokens = sum [t | act <- activities, Just t <- [activityTokensUsed act]] + totalDuration = sum [calcDuration act | act <- activities] + pure + AggregatedMetrics + { aggTotalCostCents = totalCost, + aggTotalDurationSeconds = totalDuration, + aggCompletedTasks = completedCount, + aggTotalTokens = totalTokens + } + where + calcDuration act = case (activityStartedAt act, activityCompletedAt act) of + (Just start, Just end) -> floor (diffUTCTime end start) + _ -> 0 + +-- | Get aggregated metrics for all tasks globally (not scoped to an epic) +getGlobalAggregatedMetrics :: IO AggregatedMetrics +getGlobalAggregatedMetrics = do + allTasks <- loadTasks + let completedCount = length [t | t <- allTasks, taskStatus t == Done] + taskIds = map taskId allTasks + activities <- concat </ traverse getActivitiesForTask taskIds + let totalCost = sum [c | act <- activities, Just c <- [activityCostCents act]] + totalTokens = sum [t | act <- activities, Just t <- [activityTokensUsed act]] + totalDuration = sum [calcDuration act | act <- activities] + pure + AggregatedMetrics + { aggTotalCostCents = totalCost, + aggTotalDurationSeconds = totalDuration, + aggCompletedTasks = completedCount, + aggTotalTokens = totalTokens + } + where + calcDuration act = case (activityStartedAt act, activityCompletedAt act) of + (Just start, Just end) -> floor (diffUTCTime end start) + _ -> 0 + +-- | Get tasks with unmet blocking dependencies (not ready, not done) +getBlockedTasks :: IO [Task] +getBlockedTasks = do + allTasks <- loadTasks + readyTasks <- getReadyTasks + let readyIds = map taskId readyTasks + doneIds = [taskId t | t <- allTasks, taskStatus t == Done] + isBlocked task = + taskStatus task + `elem` [Open, InProgress] + && taskId task + `notElem` readyIds + && taskId task + `notElem` doneIds + pure [t | t <- allTasks, isBlocked t] + +-- | Count how many tasks are transitively blocked by this task +getBlockingImpact :: [Task] -> Task -> Int +getBlockingImpact allTasks task = + length (getTransitiveDependents allTasks (taskId task)) + +-- | Get all tasks that depend on this task (directly or transitively) +-- Uses a Set to track visited nodes and avoid infinite loops from circular deps +getTransitiveDependents :: [Task] -> Text -> [Task] +getTransitiveDependents allTasks tid = go Set.empty [tid] + where + go :: Set.Set Text -> [Text] -> [Task] + go _ [] = [] + go visited (current : rest) + | Set.member current visited = go visited rest + | otherwise = + let directDeps = [t | t <- allTasks, dependsOnTask current t] + newIds = [taskId t | t <- directDeps, not (Set.member (taskId t) visited)] + visited' = Set.insert current visited + in directDeps ++ go visited' (newIds ++ rest) + +-- | Check if task depends on given ID with Blocks dependency type +dependsOnTask :: Text -> Task -> Bool +dependsOnTask tid task = + any (\d -> matchesId (depId d) tid && depType d == Blocks) (taskDependencies task) + +-- | Get tasks that have failed 3+ times and need human intervention +getInterventionTasks :: IO [Task] +getInterventionTasks = do + allTasks <- loadTasks + retryContexts <- getAllRetryContexts + let highRetryIds = [retryTaskId ctx | ctx <- retryContexts, retryAttempt ctx >= 3] + pure [t | t <- allTasks, taskId t `elem` highRetryIds] + +-- | Get all items needing human action +getHumanActionItems :: IO HumanActionItems +getHumanActionItems = do + allTasks <- loadTasks + retryContexts <- getAllRetryContexts + let highRetryIds = [retryTaskId ctx | ctx <- retryContexts, retryAttempt ctx >= 3] + failed = [t | t <- allTasks, taskId t `elem` highRetryIds] + epics = [t | t <- allTasks, taskType t == Epic, taskStatus t /= Done] + epicsReady = + [ EpicForReview + { epicTask = e, + epicTotal = total, + epicCompleted = completed + } + | e <- epics, + let children = [c | c <- allTasks, taskParent c == Just (taskId e)], + let total = length children, + total > 0, + let completed = length [c | c <- children, taskStatus c == Done], + completed == total + ] + human = [t | t <- allTasks, taskType t == HumanTask, taskStatus t == Open] + pure + HumanActionItems + { failedTasks = failed, + epicsInReview = epicsReady, + humanTasks = human + } + +-- | Get all retry contexts from the database +getAllRetryContexts :: IO [RetryContext] +getAllRetryContexts = + withDb <| \conn -> do + rows <- + SQL.query_ + conn + "SELECT task_id, original_commit, conflict_files, attempt, reason, notes FROM retry_context" :: + IO [(Text, Text, Text, Int, Text, Maybe Text)] + pure + [ RetryContext + { retryTaskId = tid, + retryOriginalCommit = commit, + retryConflictFiles = fromMaybe [] (decode (BLC.pack (T.unpack filesJson))), + retryAttempt = attempt, + retryReason = reason, + retryNotes = notes + } + | (tid, commit, filesJson, attempt, reason, notes) <- rows + ] + +-- | Update just the notes field for a retry context +updateRetryNotes :: Text -> Text -> IO () +updateRetryNotes tid notes = do + maybeCtx <- getRetryContext tid + case maybeCtx of + Nothing -> + setRetryContext + RetryContext + { retryTaskId = tid, + retryOriginalCommit = "", + retryConflictFiles = [], + retryAttempt = 0, + retryReason = "", + retryNotes = Just notes + } + Just ctx -> + setRetryContext ctx {retryNotes = Just notes} + +-- Fact management + +-- | Save a fact to the database +saveFact :: Fact -> IO Int +saveFact f = + withDb <| \conn -> do + let filesJson = T.pack <| BLC.unpack <| encode (factRelatedFiles f) + SQL.execute + conn + "INSERT INTO facts (project, fact, related_files, source_task, confidence, created_at) \ + \VALUES (?, ?, ?, ?, ?, ?)" + (factProject f, factContent f, filesJson, factSourceTask f, factConfidence f, factCreatedAt f) + [SQL.Only factIdVal] <- SQL.query_ conn "SELECT last_insert_rowid()" :: IO [SQL.Only Int] + pure factIdVal + +-- | Load all facts from the database +loadFacts :: IO [Fact] +loadFacts = + withDb <| \conn -> + SQL.query_ + conn + "SELECT id, project, fact, related_files, source_task, confidence, created_at FROM facts" + +-- | Get facts for a specific project +getFactsForProject :: Text -> IO [Fact] +getFactsForProject proj = + withDb <| \conn -> + SQL.query + conn + "SELECT id, project, fact, related_files, source_task, confidence, created_at \ + \FROM facts WHERE project = ? ORDER BY confidence DESC" + (SQL.Only proj) + +-- | Get facts related to a specific file +getFactsForFile :: Text -> IO [Fact] +getFactsForFile filePath = + withDb <| \conn -> + SQL.query + conn + "SELECT id, project, fact, related_files, source_task, confidence, created_at \ + \FROM facts WHERE related_files LIKE ? ORDER BY confidence DESC" + (SQL.Only ("%" <> filePath <> "%")) + +-- | Delete a fact by ID +deleteFact :: Int -> IO () +deleteFact fid = + withDb <| \conn -> + SQL.execute conn "DELETE FROM facts WHERE id = ?" (SQL.Only fid) |