diff options
Diffstat (limited to 'Omni/Task')
| -rw-r--r-- | Omni/Task/Core.hs | 108 | ||||
| -rw-r--r-- | Omni/Task/RaceTest.hs | 55 |
2 files changed, 142 insertions, 21 deletions
diff --git a/Omni/Task/Core.hs b/Omni/Task/Core.hs index 6856a83..066ad95 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 @@ -106,10 +110,11 @@ 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 () @@ -121,6 +126,53 @@ 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 @@ -139,8 +191,12 @@ generateId = do -- 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 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. @@ -148,7 +204,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 = @@ -177,7 +233,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 @@ -233,15 +292,22 @@ 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 +createTask title taskType parent namespace priority deps = withTaskWriteLock <| do + tid <- case parent of + Nothing -> generateId + Just pid -> do + tasks <- loadTasksInternal + pure <| computeNextChildId tasks pid now <- getCurrentTime let task = Task @@ -256,13 +322,13 @@ createTask title taskType parent namespace priority deps = do taskCreatedAt = now, taskUpdatedAt = now } - saveTask task + saveTaskInternal task pure task -- Update task status updateTaskStatus :: Text -> Status -> IO () -updateTaskStatus tid newStatus = do - tasks <- loadTasks +updateTaskStatus tid newStatus = withTaskWriteLock <| do + tasks <- loadTasksInternal now <- getCurrentTime let updatedTasks = map updateIfMatch tasks updateIfMatch t = @@ -272,7 +338,7 @@ updateTaskStatus tid newStatus = do -- Rewrite the entire file (simple approach for MVP) tasksFile <- getTasksFilePath TIO.writeFile tasksFile "" - traverse_ saveTask updatedTasks + traverse_ saveTaskInternal updatedTasks -- List tasks, optionally filtered by type, parent, status, or namespace listTasks :: Maybe TaskType -> Maybe Text -> Maybe Status -> Maybe Text -> IO [Task] @@ -587,12 +653,12 @@ bold t = "\ESC[1m" <> t <> "\ESC[0m" -- Export tasks: Consolidate JSONL file (remove duplicates, keep latest version) exportTasks :: IO () -exportTasks = do - tasks <- loadTasks +exportTasks = withTaskWriteLock <| do + tasks <- loadTasksInternal -- Rewrite the entire file with deduplicated tasks tasksFile <- getTasksFilePath TIO.writeFile tasksFile "" - traverse_ saveTask tasks + traverse_ saveTaskInternal tasks -- Task statistics data TaskStats = TaskStats @@ -712,7 +778,7 @@ showTaskStats maybeEpicId = do -- Import tasks: Read from another JSONL file and merge with existing tasks importTasks :: FilePath -> IO () -importTasks filePath = do +importTasks filePath = withTaskWriteLock <| do exists <- doesFileExist filePath unless exists <| panic (T.pack filePath <> " does not exist") @@ -722,7 +788,7 @@ importTasks filePath = do importedTasks = mapMaybe decodeTask importLines -- Load existing tasks - existingTasks <- loadTasks + existingTasks <- loadTasksInternal -- Create a map of existing task IDs for quick lookup let existingIds = map taskId existingTasks @@ -736,7 +802,7 @@ importTasks filePath = do -- Rewrite tasks.jsonl with merged data tasksFile <- getTasksFilePath TIO.writeFile tasksFile "" - traverse_ saveTask allTasks + traverse_ saveTaskInternal allTasks where decodeTask :: Text -> Maybe Task decodeTask line = diff --git a/Omni/Task/RaceTest.hs b/Omni/Task/RaceTest.hs new file mode 100644 index 0000000..d4780fd --- /dev/null +++ b/Omni/Task/RaceTest.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Omni.Task.RaceTest where + +import Alpha +import Omni.Task.Core +import qualified Omni.Test as Test +import System.Directory (doesFileExist, removeFile) +import System.Environment (setEnv) +import Control.Concurrent.Async (mapConcurrently) +import qualified Data.Text as T +import Data.List (nub) + +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 [] + 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 []) + 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 |