From 683c8d597f3570c3c5bacead331298c7925b6bce Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Mon, 24 Nov 2025 22:42:24 -0500 Subject: fix(task): ensure thread safety and isolate tests Re-introduces MVar locking in Task Core to prevent race conditions during Read-Modify-Write cycles (e.g. ID generation). Updates tests to use isolated SQLite databases instead of the production DB or JSONL files. Removes legacy test artifacts. Amp-Thread-ID: https://ampcode.com/threads/T-ac41b9b6-d117-46de-9e4f-842887a22f1d Co-authored-by: Amp --- Omni/Task/Core.hs | 115 ++++++++++++++++++++++++++++++------------------------ 1 file changed, 64 insertions(+), 51 deletions(-) (limited to 'Omni/Task/Core.hs') diff --git a/Omni/Task/Core.hs b/Omni/Task/Core.hs index 4ce9066..af982d8 100644 --- a/Omni/Task/Core.hs +++ b/Omni/Task/Core.hs @@ -21,6 +21,7 @@ import qualified Database.SQLite.Simple.ToField as SQL import GHC.Generics () import System.Directory (createDirectoryIfMissing, doesFileExist) import System.Environment (lookupEnv) +import System.IO.Unsafe (unsafePerformIO) -- Core data types data Task = Task @@ -194,13 +195,21 @@ normalizeTask 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" let path = case (customPath, testMode) of - (Just p, _) -> p + (Just p, _) -> p -- Custom path wins (even in test mode, to allow specific test DBs) (_, Just "1") -> ".tasks/tasks-test.db" _ -> ".tasks/tasks.db" pure path @@ -304,32 +313,33 @@ saveTask task = -- Create a new task createTask :: Text -> TaskType -> Maybe Text -> Maybe Text -> Priority -> [Dependency] -> Maybe Text -> IO Task -createTask title taskType parent namespace priority deps description = 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, - taskDependencies = deps', - taskDescription = description, - taskCreatedAt = now, - taskUpdatedAt = now - } - saveTask task - pure task +createTask title taskType parent namespace priority 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, + taskDependencies = deps', + taskDescription = description, + taskCreatedAt = now, + taskUpdatedAt = now + } + saveTask task + pure task -- Generate a unique ID generateUniqueId :: IO Text @@ -348,33 +358,36 @@ generateUniqueId = do -- Update task status updateTaskStatus :: Text -> Status -> [Dependency] -> IO () updateTaskStatus tid newStatus newDeps = - 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) + 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 = 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 +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 -- List tasks listTasks :: Maybe TaskType -> Maybe Text -> Maybe Status -> Maybe Text -> IO [Task] -- cgit v1.2.3