diff options
Diffstat (limited to 'Omni/Task')
| -rw-r--r-- | Omni/Task/Core.hs | 499 | ||||
| -rw-r--r-- | Omni/Task/RaceTest.hs | 56 |
2 files changed, 423 insertions, 132 deletions
diff --git a/Omni/Task/Core.hs b/Omni/Task/Core.hs index 228ab05..b17c2aa 100644 --- a/Omni/Task/Core.hs +++ b/Omni/Task/Core.hs @@ -18,6 +18,10 @@ import Data.Time.Calendar (toModifiedJulianDay) import GHC.Generics () import System.Directory (createDirectoryIfMissing, doesFileExist) import System.Environment (lookupEnv) +import System.IO (SeekMode (AbsoluteSeek)) +import qualified System.IO as IO +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.IO (LockRequest (..), closeFd, handleToFd, waitToSetLock) -- Core data types data Task = Task @@ -29,6 +33,7 @@ data Task = Task taskStatus :: Status, taskPriority :: Priority, -- Priority level (0-4) taskDependencies :: [Dependency], -- List of dependencies with types + taskDescription :: Maybe Text, -- Optional detailed description taskCreatedAt :: UTCTime, taskUpdatedAt :: UTCTime } @@ -57,6 +62,14 @@ data DependencyType | Related -- Soft relationship, doesn't block deriving (Show, Eq, Generic) +data TaskProgress = TaskProgress + { progressTaskId :: Text, + progressTotal :: Int, + progressCompleted :: Int, + progressPercentage :: Int + } + deriving (Show, Eq, Generic) + instance ToJSON TaskType instance FromJSON TaskType @@ -81,15 +94,44 @@ instance ToJSON Task instance FromJSON Task +-- | 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)} + +instance ToJSON TaskProgress + +instance FromJSON TaskProgress + -- Get the tasks database file path (use test file if TASK_TEST_MODE is set) getTasksFilePath :: IO FilePath getTasksFilePath = do customPath <- lookupEnv "TASK_DB_PATH" testMode <- lookupEnv "TASK_TEST_MODE" - pure <| case (customPath, testMode) of - (Just path, _) -> path - (_, Just "1") -> ".tasks/tasks-test.jsonl" - _ -> ".tasks/tasks.jsonl" + let path = case (customPath, testMode) of + (Just p, _) -> p + (_, Just "1") -> ".tasks/tasks-test.jsonl" + _ -> ".tasks/tasks.jsonl" + pure path -- Initialize the task database initTaskDb :: IO () @@ -101,6 +143,55 @@ initTaskDb = do TIO.writeFile tasksFile "" putText <| "Initialized task database at " <> T.pack tasksFile +-- Lock for in-process thread safety +taskLock :: MVar () +taskLock = unsafePerformIO (newMVar ()) +{-# NOINLINE taskLock #-} + +-- Execute action with write lock (exclusive) +withTaskWriteLock :: IO a -> IO a +withTaskWriteLock action = + withMVar taskLock <| \_ -> do + -- In test mode, we rely on MVar for thread safety to avoid GHC "resource busy" errors + -- when mixing openFd (flock) and standard IO in threaded tests. + testMode <- lookupEnv "TASK_TEST_MODE" + case testMode of + Just "1" -> action + _ -> do + tasksFile <- getTasksFilePath + let lockFile = tasksFile <> ".lock" + bracket + ( do + h <- IO.openFile lockFile IO.ReadWriteMode + handleToFd h + ) + closeFd + ( \fd -> do + waitToSetLock fd (WriteLock, AbsoluteSeek, 0, 0) + action + ) + +-- Execute action with read lock (shared) +withTaskReadLock :: IO a -> IO a +withTaskReadLock action = + withMVar taskLock <| \_ -> do + testMode <- lookupEnv "TASK_TEST_MODE" + case testMode of + Just "1" -> action + _ -> do + tasksFile <- getTasksFilePath + let lockFile = tasksFile <> ".lock" + bracket + ( do + h <- IO.openFile lockFile IO.ReadWriteMode + handleToFd h + ) + closeFd + ( \fd -> do + waitToSetLock fd (ReadLock, AbsoluteSeek, 0, 0) + action + ) + -- Generate a short ID using base62 encoding of timestamp generateId :: IO Text generateId = do @@ -113,14 +204,19 @@ generateId = do -- Combine MJD and micros to ensure uniqueness across days. -- Multiplier 10^11 (100,000 seconds) is safe for any day length. totalMicros = (mjd * 100000000000) + micros - encoded = toBase62 totalMicros + encoded = toBase36 totalMicros pure <| "t-" <> T.pack encoded -- Generate a child ID based on parent ID (e.g. "t-abc.1", "t-abc.1.2") -- Finds the next available sequential suffix among existing children. generateChildId :: Text -> IO Text -generateChildId parentId = do - tasks <- loadTasks +generateChildId parentId = + withTaskReadLock <| do + tasks <- loadTasksInternal + pure <| computeNextChildId tasks (normalizeId parentId) + +computeNextChildId :: [Task] -> Text -> Text +computeNextChildId tasks parentId = -- Find the max suffix among ALL tasks that look like children (to avoid ID collisions) -- We check all tasks, not just those with taskParent set, because we want to ensure -- ID uniqueness even if the parent link is missing. @@ -128,7 +224,7 @@ generateChildId parentId = do nextSuffix = case suffixes of [] -> 1 s -> maximum s + 1 - pure <| parentId <> "." <> T.pack (show nextSuffix) + in parentId <> "." <> T.pack (show nextSuffix) getSuffix :: Text -> Text -> Maybe Int getSuffix parent childId = @@ -140,15 +236,15 @@ getSuffix parent childId = else Nothing else Nothing --- Convert number to base62 (0-9, a-z, A-Z) -toBase62 :: Integer -> String -toBase62 0 = "0" -toBase62 n = reverse <| go n +-- Convert number to base36 (0-9, a-z) +toBase36 :: Integer -> String +toBase36 0 = "0" +toBase36 n = reverse <| go n where - alphabet = ['0' .. '9'] ++ ['a' .. 'z'] ++ ['A' .. 'Z'] + alphabet = ['0' .. '9'] ++ ['a' .. 'z'] go 0 = [] go x = - let (q, r) = x `divMod` 62 + let (q, r) = x `divMod` 36 idx = fromIntegral r char = case drop idx alphabet of (c : _) -> c @@ -157,7 +253,10 @@ toBase62 n = reverse <| go n -- Load all tasks from JSONL file (with migration support) loadTasks :: IO [Task] -loadTasks = do +loadTasks = withTaskReadLock loadTasksInternal + +loadTasksInternal :: IO [Task] +loadTasksInternal = do tasksFile <- getTasksFilePath exists <- doesFileExist tasksFile if exists @@ -173,11 +272,11 @@ loadTasks = do then Nothing else case decode (BLC.pack <| T.unpack line) of Just task -> Just task - Nothing -> migrateOldTask line + Nothing -> migrateTask line - -- Migrate old task format (with taskProject field or missing priority) to new format - migrateOldTask :: Text -> Maybe Task - migrateOldTask line = case Aeson.decode (BLC.pack <| T.unpack line) :: Maybe Aeson.Object of + -- Migrate old task formats to new format + migrateTask :: Text -> Maybe Task + migrateTask line = case Aeson.decode (BLC.pack <| T.unpack line) :: Maybe Aeson.Object of Nothing -> Nothing Just obj -> let taskId' = KM.lookup "taskId" obj +> parseMaybe Aeson.parseJSON @@ -185,12 +284,22 @@ loadTasks = do taskStatus' = KM.lookup "taskStatus" obj +> parseMaybe Aeson.parseJSON taskCreatedAt' = KM.lookup "taskCreatedAt" obj +> parseMaybe Aeson.parseJSON taskUpdatedAt' = KM.lookup "taskUpdatedAt" obj +> parseMaybe Aeson.parseJSON - -- Extract old taskDependencies (could be [Text] or [Dependency]) - oldDeps = KM.lookup "taskDependencies" obj +> parseMaybe Aeson.parseJSON :: Maybe [Text] - newDeps = maybe [] (map (\tid -> Dependency {depId = tid, depType = Blocks})) oldDeps + + -- Extract taskDescription (new field) + taskDescription' = KM.lookup "taskDescription" obj +> parseMaybe Aeson.parseJSON + + -- Extract dependencies (handle V1 [Dependency] and V0 [Text]) + v1Deps = KM.lookup "taskDependencies" obj +> parseMaybe Aeson.parseJSON :: Maybe [Dependency] + v0Deps = KM.lookup "taskDependencies" obj +> parseMaybe Aeson.parseJSON :: Maybe [Text] + finalDeps = case v1Deps of + Just ds -> ds + Nothing -> case v0Deps of + Just ts -> map (\tid -> Dependency {depId = tid, depType = Blocks}) ts + Nothing -> [] + -- taskProject is ignored in new format (use epics instead) - taskType' = WorkTask -- Old tasks become WorkTask by default - taskParent' = Nothing + taskType' = fromMaybe WorkTask (KM.lookup "taskType" obj +> parseMaybe Aeson.parseJSON) + taskParent' = KM.lookup "taskParent" obj +> parseMaybe Aeson.parseJSON taskNamespace' = KM.lookup "taskNamespace" obj +> parseMaybe Aeson.parseJSON -- Default priority to P2 (medium) for old tasks taskPriority' = fromMaybe P2 (KM.lookup "taskPriority" obj +> parseMaybe Aeson.parseJSON) @@ -205,7 +314,8 @@ loadTasks = do taskNamespace = taskNamespace', taskStatus = status, taskPriority = taskPriority', - taskDependencies = newDeps, + taskDependencies = finalDeps, + taskDescription = taskDescription', taskCreatedAt = created, taskUpdatedAt = updated } @@ -213,46 +323,59 @@ loadTasks = do -- Save a single task (append to JSONL) saveTask :: Task -> IO () -saveTask task = do +saveTask = withTaskWriteLock <. saveTaskInternal + +saveTaskInternal :: Task -> IO () +saveTaskInternal task = do tasksFile <- getTasksFilePath let json = encode task BLC.appendFile tasksFile (json <> "\n") -- Create a new task -createTask :: Text -> TaskType -> Maybe Text -> Maybe Text -> Priority -> [Dependency] -> IO Task -createTask title taskType parent namespace priority deps = do - tid <- maybe generateId generateChildId parent - now <- getCurrentTime - let task = - Task - { taskId = tid, - taskTitle = title, - taskType = taskType, - taskParent = parent, - taskNamespace = namespace, - taskStatus = Open, - taskPriority = priority, - taskDependencies = deps, - taskCreatedAt = now, - taskUpdatedAt = now - } - saveTask task - pure task +createTask :: Text -> TaskType -> Maybe Text -> Maybe Text -> Priority -> [Dependency] -> Maybe Text -> IO Task +createTask title taskType parent namespace priority deps description = + withTaskWriteLock <| do + let parent' = fmap normalizeId parent + deps' = map normalizeDependency deps + + tid <- case parent' of + Nothing -> generateId + Just pid -> do + tasks <- loadTasksInternal + pure <| computeNextChildId tasks pid + now <- getCurrentTime + let task = + Task + { taskId = normalizeId tid, + taskTitle = title, + taskType = taskType, + taskParent = parent', + taskNamespace = namespace, + taskStatus = Open, + taskPriority = priority, + taskDependencies = deps', + taskDescription = description, + taskCreatedAt = now, + taskUpdatedAt = now + } + saveTaskInternal task + pure task -- Update task status -updateTaskStatus :: Text -> Status -> IO () -updateTaskStatus tid newStatus = do - tasks <- loadTasks - now <- getCurrentTime - let updatedTasks = map updateIfMatch tasks - updateIfMatch t = - if taskId t == tid - then t {taskStatus = newStatus, taskUpdatedAt = now} - else t - -- Rewrite the entire file (simple approach for MVP) - tasksFile <- getTasksFilePath - TIO.writeFile tasksFile "" - traverse_ saveTask updatedTasks +updateTaskStatus :: Text -> Status -> [Dependency] -> IO () +updateTaskStatus tid newStatus newDeps = + withTaskWriteLock <| do + tasks <- loadTasksInternal + now <- getCurrentTime + let updatedTasks = map updateIfMatch tasks + updateIfMatch t = + if matchesId (taskId t) tid + then t {taskStatus = newStatus, taskUpdatedAt = now, taskDependencies = if null newDeps then taskDependencies t else newDeps} + else t + -- Rewrite the entire file (simple approach for MVP) + tasksFile <- getTasksFilePath + TIO.writeFile tasksFile "" + traverse_ saveTaskInternal updatedTasks -- List tasks, optionally filtered by type, parent, status, or namespace listTasks :: Maybe TaskType -> Maybe Text -> Maybe Status -> Maybe Text -> IO [Task] @@ -279,7 +402,9 @@ listTasks maybeType maybeParent maybeStatus maybeNamespace = do getReadyTasks :: IO [Task] getReadyTasks = do allTasks <- loadTasks - let openTasks = filter (\t -> taskStatus t /= Done) allTasks + -- Only Open or InProgress tasks are considered ready for work. + -- Review tasks are waiting for review, and Done tasks are complete. + let openTasks = filter (\t -> taskStatus t == Open || taskStatus t == InProgress) allTasks doneIds = map taskId <| filter (\t -> taskStatus t == Done) allTasks -- Find all tasks that act as parents @@ -297,29 +422,56 @@ getReadyTasks = do getDependencyTree :: Text -> IO [Task] getDependencyTree tid = do tasks <- loadTasks - case filter (\t -> taskId t == tid) tasks of - [] -> pure [] - (task : _) -> pure <| collectDeps tasks task + case findTask tid tasks of + Nothing -> pure [] + Just task -> pure <| collectDeps tasks task where collectDeps :: [Task] -> Task -> [Task] collectDeps allTasks task = let depIds = map depId (taskDependencies task) - deps = filter (\t -> taskId t `elem` depIds) allTasks + 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 + tasks <- loadTasks + -- Verify task exists (optional, but good for error handling) + 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 + } + +-- Show task progress +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)) <> "%)" + -- Show dependency tree for a task showDependencyTree :: Text -> IO () showDependencyTree tid = do tasks <- loadTasks - case filter (\t -> taskId t == tid) tasks of - [] -> putText "Task not found" - (task : _) -> printTree tasks task 0 + 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 -> taskId t `elem` depIds) allTasks + deps = filter (\t -> any (matchesId (taskId t)) depIds) allTasks traverse_ (\dep -> printTree allTasks dep (indent + 1)) deps -- Get task tree (returns tasks hierarchically) @@ -333,13 +485,13 @@ getTaskTree maybeId = do in pure <| concatMap (collectChildren tasks) epics Just tid -> do -- Return specific task/epic with its children - case filter (\t -> taskId t == tid) tasks of - [] -> pure [] - (task : _) -> pure <| collectChildren tasks task + case findTask tid tasks of + Nothing -> pure [] + Just task -> pure <| collectChildren tasks task where collectChildren :: [Task] -> Task -> [Task] collectChildren allTasks task = - let children = filter (\t -> taskParent t == Just (taskId task)) allTasks + let children = filter (maybe False (`matchesId` taskId task) <. taskParent) allTasks in task : concatMap (collectChildren allTasks) children -- Show task tree (epic with children, or all epics if no ID given) @@ -355,9 +507,9 @@ showTaskTree maybeId = do else traverse_ (printEpicTree tasks) epics Just tid -> do -- Show specific task/epic with its children - case filter (\t -> taskId t == tid) tasks of - [] -> putText "Task not found" - (task : _) -> printEpicTree tasks task + case findTask tid tasks of + Nothing -> putText "Task not found" + Just task -> printEpicTree tasks task where printEpicTree :: [Task] -> Task -> IO () printEpicTree allTasks task = printTreeNode allTasks task 0 @@ -367,7 +519,7 @@ showTaskTree maybeId = do printTreeNode' :: [Task] -> Task -> Int -> [Bool] -> IO () printTreeNode' allTasks task indent ancestry = do - let children = filter (\t -> taskParent t == Just (taskId task)) allTasks + let children = filter (maybe False (`matchesId` taskId task) <. taskParent) allTasks -- Build tree prefix using box-drawing characters prefix = if indent == 0 @@ -387,9 +539,23 @@ showTaskTree maybeId = do InProgress -> "[~]" Review -> "[?]" Done -> "[✓]" + + coloredStatusStr = case taskType task of + Epic -> magenta statusStr + WorkTask -> case taskStatus task of + Open -> bold statusStr + InProgress -> yellow statusStr + Review -> magenta statusStr + Done -> green statusStr + nsStr = case taskNamespace task of Nothing -> "" Just ns -> "[" <> ns <> "] " + + coloredNsStr = case taskNamespace task of + Nothing -> "" + Just _ -> gray nsStr + -- Calculate available width for title (80 cols - prefix - id - labels) usedWidth = T.length prefix + T.length (taskId task) + T.length statusStr + T.length nsStr + 2 availableWidth = max 20 (80 - usedWidth) @@ -397,7 +563,10 @@ showTaskTree maybeId = do if T.length (taskTitle task) > availableWidth then T.take (availableWidth - 3) (taskTitle task) <> "..." else taskTitle task - putText <| prefix <> taskId task <> " " <> statusStr <> " " <> nsStr <> truncatedTitle + + coloredTitle = if taskType task == Epic then bold truncatedTitle else truncatedTitle + + putText <| prefix <> cyan (taskId task) <> " " <> coloredStatusStr <> " " <> coloredNsStr <> coloredTitle -- Print children with updated ancestry let indexedChildren = zip [1 ..] children @@ -416,29 +585,51 @@ printTask t = do let progressInfo = if taskType t == Epic then - let children = filter (\child -> taskParent child == Just (taskId t)) tasks + 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 + Open -> bold s + InProgress -> yellow s + Review -> magenta 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 - <| taskId t + <| cyan (taskId t) <> " [" <> T.pack (show (taskType t)) - <> "] [" - <> T.pack (show (taskStatus t)) - <> "]" - <> progressInfo + <> "] " + <> coloredStatus + <> coloredProgress <> " " - <> taskTitle t - <> parentInfo - <> namespaceInfo + <> coloredTitle + <> coloredParent + <> coloredNamespace -- Show detailed task information (human-readable) showTaskDetailed :: Task -> IO () @@ -454,7 +645,7 @@ showTaskDetailed t = do -- Show epic progress if this is an epic when (taskType t == Epic) <| do - let children = filter (\child -> taskParent child == Just (taskId t)) tasks + 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 @@ -475,6 +666,16 @@ showTaskDetailed t = do putText "Dependencies:" traverse_ printDependency (taskDependencies t) + -- Show description + case taskDescription t of + Nothing -> pure () + Just desc -> do + putText "" + putText "Description:" + -- Indent description for better readability + let indented = T.unlines <| map (" " <>) (T.lines desc) + putText indented + putText "" where priorityDesc = case taskPriority t of @@ -487,14 +688,26 @@ showTaskDetailed t = do printDependency dep = putText <| " - " <> depId dep <> " [" <> T.pack (show (depType dep)) <> "]" +-- ANSI Colors +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: Consolidate JSONL file (remove duplicates, keep latest version) exportTasks :: IO () -exportTasks = do - tasks <- loadTasks - -- Rewrite the entire file with deduplicated tasks - tasksFile <- getTasksFilePath - TIO.writeFile tasksFile "" - traverse_ saveTask tasks +exportTasks = + withTaskWriteLock <| do + tasks <- loadTasksInternal + -- Rewrite the entire file with deduplicated tasks + tasksFile <- getTasksFilePath + TIO.writeFile tasksFile "" + traverse_ saveTaskInternal tasks -- Task statistics data TaskStats = TaskStats @@ -516,18 +729,31 @@ instance ToJSON TaskStats instance FromJSON TaskStats -- Get task statistics -getTaskStats :: IO TaskStats -getTaskStats = do - tasks <- loadTasks - ready <- getReadyTasks - let total = length tasks +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 + -- Filter ready tasks to only include those in our target set + readyCount = length <| filter (\t -> taskId t `elem` readyIds) targetTasks + + tasks = targetTasks + total = length 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 done = length <| filter (\t -> taskStatus t == Done) tasks epics = length <| filter (\t -> taskType t == Epic) tasks - readyCount = length ready - blockedCount = total - readyCount - done + readyCount' = readyCount + blockedCount = total - readyCount' - done -- Count tasks by priority byPriority = [ (P0, length <| filter (\t -> taskPriority t == P0) tasks), @@ -548,18 +774,26 @@ getTaskStats = do reviewTasks = review, doneTasks = done, totalEpics = epics, - readyTasks = readyCount, + readyTasks = readyCount', blockedTasks = blockedCount, tasksByPriority = byPriority, tasksByNamespace = byNamespace } +-- Helper to get all descendants of a task (recursive) +getAllDescendants :: [Task] -> Text -> [Task] +getAllDescendants allTasks parentId = + let children = filter (maybe False (`matchesId` parentId) <. taskParent) allTasks + in children ++ concatMap (getAllDescendants allTasks <. taskId) children + -- Show task statistics (human-readable) -showTaskStats :: IO () -showTaskStats = do - stats <- getTaskStats +showTaskStats :: Maybe Text -> IO () +showTaskStats maybeEpicId = do + stats <- getTaskStats maybeEpicId putText "" - putText "Task Statistics" + 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 <| " Open: " <> T.pack (show (openTasks stats)) @@ -593,31 +827,32 @@ showTaskStats = do -- Import tasks: Read from another JSONL file and merge with existing tasks importTasks :: FilePath -> IO () -importTasks filePath = do - exists <- doesFileExist filePath - unless exists <| panic (T.pack filePath <> " does not exist") - - -- Load tasks from import file - content <- TIO.readFile filePath - let importLines = T.lines content - importedTasks = mapMaybe decodeTask importLines - - -- Load existing tasks - existingTasks <- loadTasks - - -- Create a map of existing task IDs for quick lookup - let existingIds = map taskId existingTasks - -- Filter to only new tasks (not already in our database) - newTasks = filter (\t -> taskId t `notElem` existingIds) importedTasks - -- For tasks that exist, update them with imported data - updatedTasks = map (updateWithImported importedTasks) existingTasks - -- Combine: updated existing tasks + new tasks - allTasks = updatedTasks ++ newTasks - - -- Rewrite tasks.jsonl with merged data - tasksFile <- getTasksFilePath - TIO.writeFile tasksFile "" - traverse_ saveTask allTasks +importTasks filePath = + withTaskWriteLock <| do + exists <- doesFileExist filePath + unless exists <| panic (T.pack filePath <> " does not exist") + + -- Load tasks from import file + content <- TIO.readFile filePath + let importLines = T.lines content + importedTasks = map normalizeTask (mapMaybe decodeTask importLines) + + -- Load existing tasks + existingTasks <- loadTasksInternal + + -- Create a map of existing task IDs for quick lookup + let existingIds = map taskId existingTasks + -- Filter to only new tasks (not already in our database) + newTasks = filter (\t -> not (any (`matchesId` taskId t) existingIds)) importedTasks + -- For tasks that exist, update them with imported data + updatedTasks = map (updateWithImported importedTasks) existingTasks + -- Combine: updated existing tasks + new tasks + allTasks = updatedTasks ++ newTasks + + -- Rewrite tasks.jsonl with merged data + tasksFile <- getTasksFilePath + TIO.writeFile tasksFile "" + traverse_ saveTaskInternal allTasks where decodeTask :: Text -> Maybe Task decodeTask line = @@ -628,9 +863,9 @@ importTasks filePath = do -- Update an existing task if there's a newer version in imported tasks updateWithImported :: [Task] -> Task -> Task updateWithImported imported existing = - case filter (\t -> taskId t == taskId existing) imported of - [] -> existing -- No imported version, keep existing - (importedTask : _) -> + case findTask (taskId existing) imported of + Nothing -> existing -- No imported version, keep existing + Just importedTask -> -- Use imported version if it's newer (based on updatedAt) if taskUpdatedAt importedTask > taskUpdatedAt existing then importedTask diff --git a/Omni/Task/RaceTest.hs b/Omni/Task/RaceTest.hs new file mode 100644 index 0000000..cfadaca --- /dev/null +++ b/Omni/Task/RaceTest.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Omni.Task.RaceTest where + +import Alpha +import Control.Concurrent.Async (mapConcurrently) +import Data.List (nub) +import qualified Data.Text as T +import Omni.Task.Core +import qualified Omni.Test as Test +import System.Directory (doesFileExist, removeFile) +import System.Environment (setEnv) + +test :: Test.Tree +test = Test.group "Omni.Task.Race" [raceTest] + +raceTest :: Test.Tree +raceTest = + Test.unit "concurrent child creation (race condition)" <| do + -- Set up test mode + setEnv "TASK_TEST_MODE" "1" + setEnv "TASK_DB_PATH" ".tasks/race-test.jsonl" + + -- Clean up test database + let testFile = ".tasks/race-test.jsonl" + exists <- doesFileExist testFile + when exists <| removeFile testFile + initTaskDb + + -- Create a parent epic + parent <- createTask "Parent Epic" Epic Nothing Nothing P2 [] Nothing + let parentId = taskId parent + + -- Create multiple children concurrently + -- We'll create 10 children in parallel + let childCount = 10 + indices = [1 .. childCount] + + -- Run concurrent creations + children <- + mapConcurrently + (\i -> createTask ("Child " <> tshow i) WorkTask (Just parentId) Nothing P2 [] Nothing) + indices + + -- Check for duplicates in generated IDs + let ids = map taskId children + uniqueIds = nub ids + + -- If there was a race condition, we'd have fewer unique IDs than children + length uniqueIds Test.@?= length children + length uniqueIds Test.@?= childCount + + -- Verify IDs follow the pattern parentId.N + for_ ids <| \tid -> do + (parentId `T.isPrefixOf` tid) Test.@?= True |