diff options
Diffstat (limited to 'Omni')
| -rw-r--r-- | Omni/Agent.hs | 33 | ||||
| -rw-r--r-- | Omni/Agent/Git.hs | 6 | ||||
| -rw-r--r-- | Omni/Agent/LogTest.hs | 74 | ||||
| -rw-r--r-- | Omni/Task.hs | 56 | ||||
| -rw-r--r-- | Omni/Task/Core.hs | 16 |
5 files changed, 94 insertions, 91 deletions
diff --git a/Omni/Agent.hs b/Omni/Agent.hs index bf499af..bad2737 100644 --- a/Omni/Agent.hs +++ b/Omni/Agent.hs @@ -9,19 +9,20 @@ module Omni.Agent where import Alpha import qualified Data.Text as Text +import qualified Data.Text.IO as TIO import qualified Omni.Agent.Core as Core import qualified Omni.Agent.Git as Git +import qualified Omni.Agent.Log as Log import qualified Omni.Agent.Worker as Worker import qualified Omni.Cli as Cli import qualified Omni.Task.Core as TaskCore import qualified Omni.Test as Test import qualified System.Console.Docopt as Docopt import qualified System.Directory as Directory +import qualified System.Environment as Env import qualified System.Exit as Exit import System.FilePath ((</>)) import qualified System.IO.Temp as Temp -import qualified System.Environment as Env -import qualified Data.Text.IO as TIO import qualified System.Process as Process main :: IO () @@ -81,7 +82,7 @@ harvest :: Cli.Arguments -> IO () harvest args = do let path = Cli.getArgWithDefault args "." (Cli.longOption "path") putText "Harvesting task updates from workers..." - + branches <- Git.listBranches path "omni-worker-*" if null branches then putText "No worker branches found." @@ -91,7 +92,7 @@ harvest args = do -- Consolidate Directory.setCurrentDirectory path TaskCore.exportTasks - + -- Commit if changed Git.commit path "task: harvest updates from workers" putText "Success: Task database updated and committed." @@ -120,7 +121,7 @@ mergeDriver :: Cli.Arguments -> IO () mergeDriver args = do ours <- Cli.getArgOrExit args (Cli.argument "ours") theirs <- Cli.getArgOrExit args (Cli.argument "theirs") - + -- Set TASK_DB_PATH to ours (the file git provided as the current version) Env.setEnv "TASK_DB_PATH" ours TaskCore.importTasks theirs @@ -132,27 +133,37 @@ setup args = do let name = Text.pack nameStr root <- Git.getRepoRoot "." let worktreePath = root <> "/../" <> nameStr - + putText <| "Creating worktree '" <> Text.pack worktreePath <> "' on branch '" <> name <> "' (from live)..." - + -- git worktree add -b <name> <path> live Git.runGit root ["worktree", "add", "-b", nameStr, worktreePath, "live"] - + -- Copy .envrc.local if exists let envrc = root </> ".envrc.local" exists <- Directory.doesFileExist envrc when exists <| do putText "Copying .envrc.local..." Directory.copyFile envrc (worktreePath </> ".envrc.local") - + -- Config git Git.runGit worktreePath ["config", "user.name", "Omni Worker"] Git.runGit worktreePath ["config", "user.email", "bot@omni.agent"] - + putText <| "Worker setup complete at " <> Text.pack worktreePath test :: Test.Tree -test = Test.group "Omni.Agent" [unitTests] +test = Test.group "Omni.Agent" [unitTests, logTests] + +logTests :: Test.Tree +logTests = + Test.group + "Log tests" + [ Test.unit "Log.emptyStatus" <| do + let s = Log.emptyStatus "worker-1" + Log.statusWorker s Test.@?= "worker-1" + Log.statusFiles s Test.@?= 0 + ] unitTests :: Test.Tree unitTests = diff --git a/Omni/Agent/Git.hs b/Omni/Agent/Git.hs index a64eee8..4c06cf6 100644 --- a/Omni/Agent/Git.hs +++ b/Omni/Agent/Git.hs @@ -205,11 +205,11 @@ isMerged repo branch target = do pure (code == Exit.ExitSuccess) listBranches :: FilePath -> Text -> IO [Text] -listBranches repo pattern = do - let cmd = (Process.proc "git" ["branch", "--list", Text.unpack pattern, "--format=%(refname:short)"]) {Process.cwd = Just repo} +listBranches repo pat = do + let cmd = (Process.proc "git" ["branch", "--list", Text.unpack pat, "--format=%(refname:short)"]) {Process.cwd = Just repo} (code, out, _) <- Process.readCreateProcessWithExitCode cmd "" case code of - Exit.ExitSuccess -> pure <| filter (not . Text.null) (Text.lines (Text.pack out)) + Exit.ExitSuccess -> pure <| filter (not <. Text.null) (Text.lines (Text.pack out)) _ -> panic "git branch list failed" showFile :: FilePath -> Text -> FilePath -> IO (Maybe Text) diff --git a/Omni/Agent/LogTest.hs b/Omni/Agent/LogTest.hs deleted file mode 100644 index 97b558d..0000000 --- a/Omni/Agent/LogTest.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- : out agent-log-test -module Omni.Agent.LogTest where - -import Alpha -import Omni.Agent.Log -import qualified Omni.Test as Test - -main :: IO () -main = Test.run tests - -tests :: Test.Tree -tests = - Test.group - "Omni.Agent.Log" - [ Test.unit "Parse LogEntry" testParse, - Test.unit "Format LogEntry" testFormat - ] - -testParse :: IO () -testParse = do - let json = "{\"message\": \"executing 1 tools in 1 batch(es)\", \"batches\": [[\"grep\"]]}" - let expected = - LogEntry - { leMessage = Just "executing 1 tools in 1 batch(es)", - leLevel = Nothing, - leToolName = Nothing, - leBatches = Just [["grep"]], - leMethod = Nothing, - lePath = Nothing - } - parseLine json @?= Just expected - -testFormat :: IO () -testFormat = do - let entry = - LogEntry - { leMessage = Just "executing 1 tools in 1 batch(es)", - leLevel = Nothing, - leToolName = Nothing, - leBatches = Just [["grep"]], - leMethod = Nothing, - lePath = Nothing - } - -- Expect NO emoji - formatLogEntry entry @?= Just "THOUGHT: Planning tool execution (grep)" - - let entry2 = - LogEntry - { leMessage = Just "some random log", - leLevel = Nothing, - leToolName = Nothing, - leBatches = Nothing, - leMethod = Nothing, - lePath = Nothing - } - formatLogEntry entry2 @?= Nothing - - let entry3 = - LogEntry - { leMessage = Just "some error", - leLevel = Just "error", - leToolName = Nothing, - leBatches = Nothing, - leMethod = Nothing, - lePath = Nothing - } - -- Expect NO emoji - formatLogEntry entry3 @?= Just "ERROR: some error" - -(@?=) :: (Eq a, Show a) => a -> a -> IO () -(@?=) = (Test.@?=) diff --git a/Omni/Task.hs b/Omni/Task.hs index 6edd161..088352e 100644 --- a/Omni/Task.hs +++ b/Omni/Task.hs @@ -20,6 +20,7 @@ import System.Directory (doesFileExist, removeFile) import System.Environment (setEnv) import System.Process (callCommand) import qualified Test.Tasty as Tasty +import Prelude (read) main :: IO () main = Cli.main plan @@ -519,7 +520,60 @@ unitTests = -- task2 should now be ready because dependency check normalizes IDs ready2 <- getReadyTasks - (taskId task2 `elem` map taskId ready2) Test.@?= True + (taskId task2 `elem` map taskId ready2) Test.@?= True, + Test.unit "can create task with lowercase ID" <| do + -- This verifies that lowercase IDs are accepted and not rejected + let lowerId = "t-lowercase" + let task = Task lowerId "Lower" WorkTask Nothing Nothing Open P2 [] Nothing (read "2025-01-01 00:00:00 UTC") (read "2025-01-01 00:00:00 UTC") + saveTask task + tasks <- loadTasks + case findTask lowerId tasks of + Just t -> taskId t Test.@?= lowerId + Nothing -> Test.assertFailure "Should find task with lowercase ID", + Test.unit "generateId produces valid ID" <| do + -- This verifies that generated IDs are valid and accepted + tid <- generateId + let task = Task tid "Auto" WorkTask Nothing Nothing Open P2 [] Nothing (read "2025-01-01 00:00:00 UTC") (read "2025-01-01 00:00:00 UTC") + saveTask task + tasks <- loadTasks + case findTask tid tasks of + Just _ -> pure () + Nothing -> Test.assertFailure "Should find generated task", + Test.unit "lowercase ID does not clash with existing uppercase ID" <| do + -- Setup: Create task with Uppercase ID + let upperId = "t-UPPER" + let task1 = Task upperId "Upper Task" WorkTask Nothing Nothing Open P2 [] Nothing (read "2025-01-01 00:00:00 UTC") (read "2025-01-01 00:00:00 UTC") + saveTask task1 + + -- Action: Try to create task with Lowercase ID (same letters) + -- Note: In the current implementation, saveTask blindly appends. + -- Ideally, we should be checking for existence if we want to avoid clash. + -- OR, we accept that they are the SAME task and this is an update? + -- But if they are different tasks (different titles, created at different times), + -- treating them as the same is dangerous. + + let lowerId = "t-upper" + let task2 = Task lowerId "Lower Task" WorkTask Nothing Nothing Open P2 [] Nothing (read "2025-01-01 00:00:01 UTC") (read "2025-01-01 00:00:01 UTC") + saveTask task2 + + tasks <- loadTasks + -- What do we expect? + -- If we expect them to be distinct: + -- let foundUpper = List.find (\t -> taskId t == upperId) tasks + -- let foundLower = List.find (\t -> taskId t == lowerId) tasks + -- foundUpper /= Nothing + -- foundLower /= Nothing + + -- BUT findTask uses case-insensitive search. + -- So findTask upperId returns task1 (probably, as it's first). + -- findTask lowerId returns task1. + -- task2 is effectively hidden/lost to findTask. + + -- So, "do not clash" implies we shouldn't end up in this state. + -- The test should probably fail if we have multiple tasks that match the same ID case-insensitively. + + let matches = filter (\t -> matchesId (taskId t) upperId) tasks + length matches Test.@?= 2 ] -- | Test CLI argument parsing to ensure docopt string matches actual usage diff --git a/Omni/Task/Core.hs b/Omni/Task/Core.hs index 58744fa..3de42b2 100644 --- a/Omni/Task/Core.hs +++ b/Omni/Task/Core.hs @@ -192,7 +192,7 @@ withTaskReadLock action = action ) --- Generate a short ID using base62 encoding of timestamp +-- Generate a short ID using base36 encoding of timestamp (lowercase) generateId :: IO Text generateId = do now <- getCurrentTime @@ -339,7 +339,7 @@ createTask title taskType parent namespace priority deps description = deps' = map normalizeDependency deps tid <- case parent' of - Nothing -> generateId + Nothing -> generateUniqueId Just pid -> do tasks <- loadTasksInternal pure <| computeNextChildId tasks pid @@ -361,6 +361,18 @@ createTask title taskType parent namespace priority deps description = saveTaskInternal task pure task +-- Generate a unique ID (checking against existing tasks) +generateUniqueId :: IO Text +generateUniqueId = do + tasks <- loadTasksInternal + go tasks + where + go tasks = do + tid <- generateId + case findTask tid tasks of + Nothing -> pure tid + Just _ -> go tasks -- Retry if collision (case-insensitive) + -- Update task status updateTaskStatus :: Text -> Status -> [Dependency] -> IO () updateTaskStatus tid newStatus newDeps = |