path: root/Omni/Ci.hs

#!/usr/bin/env run.sh
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | A robust CI program replacing Omni/Ci.sh
--
-- : out ci
module Omni.Ci (main) where

import Alpha
import qualified Data.Text as Text
import qualified Omni.Cli as Cli
import qualified Omni.Log as Log
import qualified Omni.Test as Test
import qualified System.Directory as Dir
import qualified System.Environment as Environment
import qualified System.Exit as Exit
import System.FilePath ((</>))
import qualified System.Process as Process

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:
  -r, --rerun  Run CI even if already verified
  -h, --help   Print this info
|]

test :: Test.Tree
test =
  Test.group
    "Omni.Ci"
    [ Test.unit "placeholder test" <| do
        True Test.@=? True
    ]

move :: Cli.Arguments -> IO ()
move args = do
  -- 1. Check for dirty worktree
  status <- readProcess "git" ["status", "-s"] ""
  unless (Text.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
  Log.info ["ci", "set BILD_ARGS=" <> Text.pack bildArgs]

  -- 3. Get user info
  at <- readProcess "date" ["-u", "-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

  let isRerun = args `Cli.has` Cli.longOption "rerun"
  when (alreadyGood && not isRerun) <| 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"]

  -- 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)

  Log.info ["ci", "running lint (checking git diff)"]

  -- 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
    -- Run lint without arguments to let it use its default behavior (git diff for clean repos)
    -- This is much faster than passing all files individually
    (exitCodeLint, _, lintStderr) <- Process.readProcessWithExitCode runlint [] ""
    pure <| case exitCodeLint of
      Exit.ExitSuccess -> ("good", "")
      _ -> ("fail", extractErrorMessage (Text.pack lintStderr))

  -- 6. Run Tests
  -- if bild "${BILD_ARGS:-""}" --test "${CODEROOT:?}"/**/*
  Log.info ["ci", "running tests on " <> show (length allFiles) <> " namespaces"]

  testResult <- do
    -- similarly, bild takes targets.
    -- bild "${CODEROOT:?}"/**/*
    -- We can pass namespaces.
    -- Let's try passing all files again.
    -- bild handles namespaces.
    (exitCodeTest, _, testStderr) <- Process.readProcessWithExitCode "bild" ("--test" : "--time" : "0" : allFiles) ""
    pure <| case exitCodeTest of
      Exit.ExitSuccess -> ("good", "")
      _ -> ("fail", extractErrorMessage (Text.pack testStderr))

  -- 7. Create Note
  let noteMsg = case (fst lintResult, fst testResult) of
        ("good", "good") ->
          Text.unlines
            [ "Lint-is: " <> fst lintResult,
              "Test-is: " <> fst testResult,
              "Test-by: " <> user <> " <" <> mail <> ">",
              "Test-at: " <> at
            ]
        _ ->
          Text.unlines
            <| filter
              (not <. Text.null)
              [ "Lint-is: " <> fst lintResult,
                "Test-is: " <> fst testResult,
                case snd lintResult of
                  "" -> ""
                  err -> "Lint-error: " <> Text.take 300 err,
                case snd testResult of
                  "" -> ""
                  err -> "Test-error: " <> Text.take 300 err,
                "Test-by: " <> user <> " <" <> mail <> ">",
                "Test-at: " <> at
              ]

  -- 8. Append Note
  callProcess "git" ["notes", "--ref=ci", "append", "-m", Text.unpack noteMsg]

  -- 9. Exit
  if fst lintResult == "good" && fst 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"
  case mEnvRoot of
    Just envRoot -> pure envRoot
    Nothing -> panic "CODEROOT not set" -- Simplified for now

-- | Extract meaningful error messages from tool output, filtering out progress/status lines
extractErrorMessage :: Text -> Text
extractErrorMessage output =
  let cleanedLines = Text.lines output |> map stripAnsiEscapes |> filter (not <. Text.null)
      -- First try to find explicit error lines
      errorLines = cleanedLines |> filter isErrorLine |> take 5
      -- If no explicit errors, take last few non-empty lines (likely contain the issue)
      fallbackLines =
        if null errorLines
          then cleanedLines |> reverse |> take 3 |> reverse
          else []
      finalLines
        | null errorLines && null fallbackLines = ["Build failed (exit code non-zero, no error output captured)"]
        | null errorLines = fallbackLines
        | otherwise = errorLines
   in Text.unlines finalLines
  where
    isErrorLine line =
      let stripped = Text.strip line
       in not (Text.null stripped)
            && ( "fail:"
                   `Text.isInfixOf` stripped
                   || "error:"
                   `Text.isInfixOf` stripped
                   || "Error:"
                   `Text.isInfixOf` stripped
                   || "ERROR:"
                   `Text.isInfixOf` stripped
                   || "failed"
                   `Text.isInfixOf` stripped
               )
            && not ("warning:" `Text.isInfixOf` stripped) -- Exclude warnings
            && not ("[" `Text.isPrefixOf` stripped) -- Skip progress indicators like [1/10]

    -- Remove ANSI escape sequences including carriage returns
    stripAnsiEscapes line =
      line
        |> Text.replace "\r" "" -- Remove carriage returns
        |> Text.replace "\ESC[" "" -- Remove ANSI escape start
        |> Text.replace "\x1b[" "" -- Alternative ANSI escape sequence
        |> Text.filter (\c -> c >= ' ' || c == '\t') -- Keep only printable chars and tabs