diff options
Diffstat (limited to 'Omni')
| -rw-r--r-- | Omni/Ci.hs | 193 | ||||
| -rwxr-xr-x | Omni/Ci.sh | 65 | ||||
| -rw-r--r-- | Omni/Task.hs | 28 | ||||
| -rw-r--r-- | Omni/Task/Core.hs | 9 |
4 files changed, 224 insertions, 71 deletions
diff --git a/Omni/Ci.hs b/Omni/Ci.hs new file mode 100644 index 0000000..35abe2b --- /dev/null +++ b/Omni/Ci.hs @@ -0,0 +1,193 @@ +#!/usr/bin/env run.sh +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE QuasiQuotes #-} + +-- | A robust CI program replacing Omni/Ci.sh +-- +-- : out ci +module Omni.Ci (main) where + +import Alpha +import qualified Omni.Cli as Cli +import qualified Omni.Log as Log +import qualified Omni.Test as Test +import qualified System.Environment as Environment +import qualified System.Exit as Exit +import qualified System.Process as Process +import qualified Data.Text as Text +import qualified Data.List as List +import qualified System.Directory as Dir +import System.FilePath ((</>)) + +main :: IO () +main = Cli.main <| Cli.Plan help move test pure + +help :: Cli.Docopt +help = + [Cli.docopt| +omni-ci - Continuous Integration + +Usage: + ci test + ci [options] + +Options: + -h, --help Print this info +|] + +test :: Test.Tree +test = + Test.group + "Omni.Ci" + [ Test.unit "placeholder test" <| do + True @=? True + ] + +move :: Cli.Arguments -> IO () +move _ = do + -- 1. Check for dirty worktree + status <- readProcess "git" ["status", "-s"] "" + unless (null status) <| do + Log.fail ["ci", "dirty worktree"] + Exit.exitWith (Exit.ExitFailure 1) + + -- 2. Setup environment + -- We need to ensure timeout is disabled for CI builds + -- Equivalent to: BILD_ARGS="--time 0 ${BILD_ARGS:-""}" + currentBildArgs <- Environment.lookupEnv "BILD_ARGS" + let bildArgs = "--time 0 " <> fromMaybe "" currentBildArgs + Environment.setEnv "BILD_ARGS" bildArgs + + -- 3. Get user info + at <- readProcess "date" ["-R"] "" |> fmap chomp + user <- readProcess "git" ["config", "--get", "user.name"] "" |> fmap chomp + mail <- readProcess "git" ["config", "--get", "user.email"] "" |> fmap chomp + + -- 4. Check existing git notes + -- commit=$(git notes --ref=ci show HEAD || true) + (exitCode, noteContent, _) <- Process.readProcessWithExitCode "git" ["notes", "--ref=ci", "show", "HEAD"] "" + + let alreadyGood = case exitCode of + Exit.ExitSuccess -> + let content = Text.pack noteContent + in ("Lint-is: good" `Text.isInfixOf` content) && ("Test-is: good" `Text.isInfixOf` content) + _ -> False + + when alreadyGood <| do + Log.pass ["ci", "already verified"] + Exit.exitSuccess + + -- 5. Run Lint + coderoot <- getCoderoot + let runlint = coderoot </> "_/bin/lint" + + lintExists <- Dir.doesFileExist runlint + unless lintExists <| do + Log.info ["ci", "building lint"] + callProcess "bild" [coderoot </> "Omni/Lint.hs"] + + Log.info ["ci", "running lint"] + -- if "$runlint" "${CODEROOT:?}"/**/* + -- We need to expand **/* which shell does. + -- Since we are in Haskell, we can just pass "." or call git ls-files or similar. + -- Omni/Ci.sh used "${CODEROOT:?}"/**/* which relies on bash globbing. + -- Omni/Lint.hs recursively checks if passed directory or uses git diff if no args. + -- But Omni/Ci.sh passes **/*. + -- Let's try passing the root directory or just run it without args? + -- Omni/Lint.hs says: + -- "case Cli.getAllArgs args (Cli.argument "file") of [] -> changedFiles ..." + -- So if we pass nothing, it only checks changed files. + -- The CI script explicitly passed everything. + -- We can replicate "everything" by passing the coderoot, assuming Lint handles directories recursively? + -- Omni/Lint.hs: "traverse Directory.makeAbsolute /> map (Namespace.fromPath root) ... filter (not <. Namespace.isCab)" + -- It seems it expects files. + -- We can use `git ls-files` to get all files. + allFiles <- readProcess "git" ["ls-files"] "" + /> lines + /> map Text.unpack + /> filter (not . null) + + -- We can't pass all files as arguments if there are too many (ARG_MAX). + -- But wait, Omni/Lint.hs takes arguments. + -- If we want to check everything, maybe we should implement a "check all" mode in Lint or pass chunks. + -- However, looking at Omni/Ci.sh: `"$runlint" "${CODEROOT:?}"/**/*` + -- This globbing is handled by the shell. It might be huge. + -- If I run `lint` with `.` it might work if Lint supports directories. + -- Omni/Lint.hs: "files |> ... filterM Directory.doesFileExist" + -- It seems it filters for files. + -- If I pass a directory, `doesFileExist` will return False. + -- So I must pass files. + + -- Let's pass all files from git ls-files. + -- But we must be careful about ARG_MAX. + -- For now, let's try passing them. If it fails, we might need to batch. + + lintResult <- do + -- We run lint on all files. + -- Note: calling callProcess with huge list might fail. + -- Let's see if we can avoid passing all files if Lint supports it. + -- Omni/Lint.hs doesn't seem to support directory recursion on its own if passed a dir, + -- it treats args as file paths. + + -- We will try to run it. + (exitCodeLint, _, _) <- Process.readProcessWithExitCode runlint allFiles "" + pure $ case exitCodeLint of + Exit.ExitSuccess -> "good" + _ -> "fail" + + -- 6. Run Tests + -- if bild "${BILD_ARGS:-""}" --test "${CODEROOT:?}"/**/* + Log.info ["ci", "running tests"] + + testResult <- do + -- similarly, bild takes targets. + -- bild "${CODEROOT:?}"/**/* + -- We can pass namespaces. + -- Let's try passing all files again. + -- bild handles namespaces. + (exitCodeTest, _, _) <- Process.readProcessWithExitCode "bild" ("--test" : allFiles) "" + pure $ case exitCodeTest of + Exit.ExitSuccess -> "good" + _ -> "fail" + + -- 7. Create Note + let note = Text.unlines + [ "Lint-is: " <> lintResult + , "Test-is: " <> testResult + , "Test-by: " <> user <> " <" <> mail <> ">" + , "Test-at: " <> at + ] + + -- 8. Append Note + callProcess "git" ["notes", "--ref=ci", "append", "-m", Text.unpack note] + + -- 9. Exit + if lintResult == "good" && testResult == "good" + then Exit.exitSuccess + else do + Log.fail ["ci", "verification failed"] + Exit.exitWith (Exit.ExitFailure 1) + + +-- Helpers + +readProcess :: FilePath -> [String] -> String -> IO Text +readProcess cmd args input = do + out <- Process.readProcess cmd args input + pure (Text.pack out) + +callProcess :: FilePath -> [String] -> IO () +callProcess cmd args = do + Process.callProcess cmd args + +getCoderoot :: IO FilePath +getCoderoot = do + mEnvRoot <- Environment.lookupEnv "CODEROOT" + cwd <- Dir.getCurrentDirectory + case mEnvRoot of + Just envRoot -> pure envRoot + Nothing -> panic "CODEROOT not set" -- Simplified for now + diff --git a/Omni/Ci.sh b/Omni/Ci.sh deleted file mode 100755 index a749b7a..0000000 --- a/Omni/Ci.sh +++ /dev/null @@ -1,65 +0,0 @@ -#!/usr/bin/env bash -# -# A simple ci that saves its results in a git note, formatted according to -# RFC-2822, more or less. -# -# To run this manually, exec the script. It will by default run the tests for -# HEAD, whatever you currently have checked out. -# -# It would be cool to use a zero-knowledge proof mechanism here to prove that -# so-and-so ran the tests, but I'll have to research how to do that. -# -# ensure we don't exit on bild failure, only on CI script error - set +e - set -u -## - [[ -n $(git status -s) ]] && { echo fail: dirty worktree; exit 1; } -## -## disable timeout for ci builds - BILD_ARGS="--time 0 ${BILD_ARGS:-""}" -## - at=$(date -R) - user=$(git config --get user.name) - mail=$(git config --get user.email) -## - commit=$(git notes --ref=ci show HEAD || true) - if [[ -n "$commit" ]] - then - if grep -q "Lint-is: good" <<< "$commit" - then - exit 0 - fi - if grep -q "Test-is: good" <<< "$commit" - then - exit 0 - fi - fi -## - runlint="$CODEROOT"/_/bin/lint - [[ ! -f "$runlint" ]] && bild "${BILD_ARGS:-""}" "${CODEROOT:?}"/Omni/Lint.hs - if "$runlint" "${CODEROOT:?}"/**/* - then - lint_result="good" - else - lint_result="fail" - fi -## - if bild "${BILD_ARGS:-""}" --test "${CODEROOT:?}"/**/* - then - test_result="good" - else - test_result="fail" - fi -## - read -r -d '' note <<EOF -Lint-is: $lint_result -Test-is: $test_result -Test-by: $user <$mail> -Test-at: $at -EOF -## - git notes --ref=ci append -m "$note" -## -# exit 1 if failure - [[ ! "$lint_result" == "fail" && ! "$test_result" == "fail" ]] -## diff --git a/Omni/Task.hs b/Omni/Task.hs index 12842db..8abf551 100644 --- a/Omni/Task.hs +++ b/Omni/Task.hs @@ -4,6 +4,7 @@ {-# LANGUAGE NoImplicitPrelude #-} -- : out task +-- : modified by benign worker module Omni.Task where import Alpha @@ -79,8 +80,8 @@ Options: --title=<title> Task title --type=<type> Task type: epic or task --parent=<id> Parent epic ID - --priority=<p> Priority: 0-4 (0=critical, 4=backlog) - --status=<status> Task status (open, in-progress, review, done) + --priority=<p> Priority: 0-4 (0=critical, 4=backlog, default: 2) + --status=<status> Filter by status: open, in-progress, review, approved, done --epic=<id> Filter stats by epic (recursive) --deps=<ids> Comma-separated list of dependency IDs --dep-type=<type> Dependency type: blocks, discovered-from, parent-child, related @@ -95,7 +96,7 @@ Options: Arguments: <title> Task title <id> Task ID - <status> Task status (open, in-progress, review, done) + <status> Task status (open, in-progress, review, approved, done) <file> JSONL file to import |] @@ -255,8 +256,9 @@ move args Just "open" -> pure <| Just Open Just "in-progress" -> pure <| Just InProgress Just "review" -> pure <| Just Review + Just "approved" -> pure <| Just Approved Just "done" -> pure <| Just Done - Just other -> panic <| "Invalid status: " <> T.pack other <> ". Use: open, in-progress, review, or done" + Just other -> panic <| "Invalid status: " <> T.pack other <> ". Use: open, in-progress, review, approved, or done" maybeNamespace <- case Cli.getArg args (Cli.longOption "namespace") of Nothing -> pure Nothing Just ns -> do @@ -306,8 +308,9 @@ move args "open" -> Open "in-progress" -> InProgress "review" -> Review + "approved" -> Approved "done" -> Done - _ -> panic "Invalid status. Use: open, in-progress, review, or done" + _ -> panic "Invalid status. Use: open, in-progress, review, approved, or done" updateTaskStatus tid newStatus deps if isJsonMode args @@ -665,6 +668,13 @@ cliTests = Right args -> do args `Cli.has` Cli.command "list" Test.@?= True Cli.getArg args (Cli.longOption "status") Test.@?= Just "open", + Test.unit "list with --status=approved filter" <| do + let result = Docopt.parseArgs help ["list", "--status=approved"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'list --status=approved': " <> show err + Right args -> do + args `Cli.has` Cli.command "list" Test.@?= True + Cli.getArg args (Cli.longOption "status") Test.@?= Just "approved", Test.unit "ready command" <| do let result = Docopt.parseArgs help ["ready"] case result of @@ -685,6 +695,14 @@ cliTests = args `Cli.has` Cli.command "update" Test.@?= True Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123" Cli.getArg args (Cli.argument "status") Test.@?= Just "done", + Test.unit "update command with approved" <| do + let result = Docopt.parseArgs help ["update", "t-abc123", "approved"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'update ... approved': " <> show err + Right args -> do + args `Cli.has` Cli.command "update" Test.@?= True + Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123" + Cli.getArg args (Cli.argument "status") Test.@?= Just "approved", Test.unit "update with --json flag" <| do let result = Docopt.parseArgs help ["update", "t-abc123", "done", "--json"] case result of diff --git a/Omni/Task/Core.hs b/Omni/Task/Core.hs index 3de42b2..ebf5390 100644 --- a/Omni/Task/Core.hs +++ b/Omni/Task/Core.hs @@ -42,7 +42,7 @@ data Task = Task data TaskType = Epic | WorkTask deriving (Show, Eq, Generic) -data Status = Open | InProgress | Review | Done +data Status = Open | InProgress | Review | Approved | Done deriving (Show, Eq, Generic) -- Priority levels (matching beads convention) @@ -578,6 +578,7 @@ showTaskTree maybeId = do Open -> "[ ]" InProgress -> "[~]" Review -> "[?]" + Approved -> "[+]" Done -> "[✓]" coloredStatusStr = case taskType task of @@ -586,6 +587,7 @@ showTaskTree maybeId = do Open -> bold statusStr InProgress -> yellow statusStr Review -> magenta statusStr + Approved -> green statusStr Done -> green statusStr nsStr = case taskNamespace task of @@ -645,6 +647,7 @@ printTask t = do 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 @@ -755,6 +758,7 @@ data TaskStats = TaskStats openTasks :: Int, inProgressTasks :: Int, reviewTasks :: Int, + approvedTasks :: Int, doneTasks :: Int, totalEpics :: Int, readyTasks :: Int, @@ -790,6 +794,7 @@ getTaskStats maybeEpicId = do 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 @@ -812,6 +817,7 @@ getTaskStats maybeEpicId = do openTasks = open, inProgressTasks = inProg, reviewTasks = review, + approvedTasks = approved, doneTasks = done, totalEpics = epics, readyTasks = readyCount', @@ -839,6 +845,7 @@ showTaskStats maybeEpicId = do 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)) |