Source file cli.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2020-2023 Nomadic Labs <contact@nomadic-labs.com>           *)
(* Copyright (c) 2020 Metastate AG <hello@metastate.dev>                     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Base

let () =
  Clap.description
    "Run or manage test suite.\n\n\
     Running without any argument runs the full test suite. To see the list of \
     tests instead of running it, run with the argument `--list`. See below \
     for more details on how to control test execution and select tests."

module Options = struct
  type temporary_file_mode = Delete | Delete_if_successful | Keep

  let temporary_file_mode =
    Clap.flag_enum
      ~description:
        "Whether to delete temporary files and directories that were created.\n\n\
         --keep-temp: Keep temporary files and directories after tests.\n\n\
         --delete-temp: Delete temporary files and directories after tests.\n\n\
         --delete-temp-if-success: Delete temporary files and directories, \
         except if the test failed. If a test succeeds after it however, it \
         causes all temporary files to be deleted, even those of the failed \
         tests; so you should probably avoid using this argument in \
         conjunction with --keep-going or --job-count."
      [
        (["keep-temp"], [], Keep);
        (["delete-temp"], [], Delete);
        (["delete-temp-if-success"], [], Delete_if_successful);
      ]
      Delete

  let keep_going =
    Clap.flag
      ~set_long:"keep-going"
      ~set_short:'k'
      ~description:
        "If a test fails, continue with the remaining tests instead of \
         stopping. Aborting manually with Ctrl+C still stops everything."
      false

  let global_timeout =
    Clap.optional_float
      ~long:"global-timeout"
      ~placeholder:"SECONDS"
      ~description:"Fail if the set of tests takes more than SECONDS to run."
      ()

  let test_timeout =
    Clap.optional_float
      ~long:"test-timeout"
      ~placeholder:"SECONDS"
      ~description:"Fail if a test takes, on its own, more than SECONDS to run."
      ()

  let cleanup_timeout =
    Clap.default_float
      ~long:"cleanup-timeout"
      ~placeholder:"SECONDS"
      ~description:
        "If a process spawned by a test is still running SECONDS after it was \
         sent SIGTERM at the end of the test, send it SIGKILL."
      60.

  let retry =
    Clap.default_int
      ~long:"retry"
      ~placeholder:"COUNT"
      ~description:
        "Retry each failing test up to COUNT times. If one retry is \
         successful, the test is considered successful."
      0

  let reset_regressions =
    Clap.flag
      ~set_long:"reset-regressions"
      ~description:
        "Remove regression test outputs if they exist, and regenerate them."
      false

  type on_unknown_regression_files_mode = Warn | Ignore | Fail | Delete

  let on_unknown_regression_files_mode_type =
    Clap.enum
      "mode for --on-unknown-regression-files"
      [("warn", Warn); ("ignore", Ignore); ("fail", Fail); ("delete", Delete)]

  let on_unknown_regression_files_mode =
    Clap.default
      on_unknown_regression_files_mode_type
      ~long:"on-unknown-regression-files"
      ~placeholder:"MODE"
      ~description:
        "How to handle regression test outputs that are not declared by any \
         test. MODE can be:\n\
         - warn: emit a warning for unknown output files;\n\
         - ignore: ignore unknown output files;\n\
         - fail: terminate execution with exit code 1 and without running any \
         further action when unknown output files are found;\n\
         - delete: delete unknown output files.\n\n\
         To check which files would be deleted, run with this option set to \
         'warn', which is the default."
      Warn

  type loop_mode = Infinite | Count of int

  let loop =
    Clap.flag
      ~set_long:"loop"
      ~description:
        "Restart from the beginning once all tests are done. All tests are \
         repeated until one of them fails or if you interrupt with Ctrl+C. \
         This is useful to reproduce non-deterministic failures. When used in \
         conjunction with --keep-going, tests are repeated even if they fail, \
         until you interrupt them with Ctrl+C."
      false

  let loop_count =
    Clap.optional_int
      ~long:"loop-count"
      ~placeholder:"COUNT"
      ~description:
        "Stop after all tests have been run COUNT times. Implies --loop. A \
         value of 0 means tests are not run."
      ()

  let loop_mode =
    match loop_count with
    | None -> if loop then Infinite else Count 1
    | Some count -> Count count

  let resume_file =
    Clap.optional_string
      ~long:"resume-file"
      ~placeholder:"FILE"
      ~description:
        "Record test results to FILE for use with --resume. When using \
         --resume, test results that existed in FILE are kept, contrary to \
         --record."
      ()

  let resume =
    Clap.flag
      ~set_long:"resume"
      ~set_short:'r'
      ~description:
        "Resume from a previous run. This reads the resume file located at \
         --resume-file to resume from it.\n\n\
         If --resume-file is not specified, --resume implies --resume-file \
         tezt-resume.json. If the resume file does not exist, act as if it was \
         empty.\n\n\
         Before running a test, it is checked whether this test was already \
         successfully ran according to the resume file. If it was, the test is \
         skipped.\n\n\
         When using --loop or --loop-count, the test is skipped as many times \
         as it was successful according to the resume file."
      false

  let job_count =
    Clap.default_int
      ~long:"job-count"
      ~short:'j'
      ~placeholder:"COUNT"
      ~description:
        "Run COUNT tests in parallel, in separate processes. With \
         --suggest-jobs, set the number of target jobs for --suggest-jobs \
         instead."
      1

  let test_arg_type =
    Clap.typ
      ~name:"test argument"
      ~dummy:("", "")
      ~parse:(fun string ->
        let len = String.length string in
        let rec find_equal i =
          if i >= len then None
          else if string.[i] = '=' then Some i
          else find_equal (i + 1)
        in
        Some
          (match find_equal 0 with
          | None -> (string, "true")
          | Some i ->
              (String.sub string 0 i, String.sub string (i + 1) (len - i - 1))))
      ~show:(fun (parameter, value) -> parameter ^ "=" ^ value)

  let test_args_list =
    Clap.list
      test_arg_type
      ~long:"test-arg"
      ~short:'a'
      ~placeholder:"<PARAMETER>=<VALUE>"
      ~description:
        "Pass a generic argument to tests. Tests can get this argument with \
         Cli.get. --test-arg <PARAMETER> is a short-hand for: --test-arg \
         <PARAMETER>=true"
      ()

  let test_args =
    List.fold_left
      (fun acc (k, v) -> String_map.add k v acc)
      String_map.empty
      test_args_list

  let seed =
    Clap.optional_int
      ~long:"seed"
      ~placeholder:"SEED"
      ~description:
        "Force tests declared with ~seed:Random to initialize the \
         pseudo-random number generator with this seed."
      ()
end

module Logs = struct
  let section = Clap.section "LOGS"

  let color =
    Clap.flag
      ~section
      ~set_long:"color"
      ~unset_long:"no-color"
      ~description:
        "Whether to use colors in output. Default value depends on whether \
         stdout is a terminal and on the value of the TERM environment \
         variable."
      (Unix.isatty Unix.stdout && Sys.getenv_opt "TERM" <> Some "dumb")

  type level = Quiet | Error | Warn | Report | Info | Debug

  let level_type =
    Clap.enum
      "log level"
      [
        ("quiet", Quiet);
        ("error", Error);
        ("warn", Warn);
        ("report", Report);
        ("info", Info);
        ("debug", Debug);
      ]

  let level_1 =
    Clap.default
      level_type
      ~section
      ~long:"log-level"
      ~placeholder:"LEVEL"
      ~description:
        "Set log level. Possible LEVELs are: quiet, error, warn, report, info, \
         debug."
      Report

  let level_2 =
    Clap.flag_enum
      ~section
      ~description:
        "Set log level. Overrides --log-level.\n\n\
         --verbose, -v: Same as --log-level debug.\n\
         --quiet, -q: Same as --log-level quiet.\n\
         --info, -i: Same as --log-level info."
      [
        (["verbose"], ['v'], Some Debug);
        (["quiet"], ['q'], Some Quiet);
        (["info"], ['i'], Some Info);
      ]
      None

  let level = match level_2 with Some x -> x | None -> level_1

  let file =
    Clap.optional_string
      ~section
      ~long:"log-file"
      ~placeholder:"FILE"
      ~description:
        "Also log to FILE. Note that --log-level does not apply: FILE contains \
         logs in verbose mode. In the presence of --job-count, the main \
         process will log test results to FILE while each worker writes test \
         logs to a separate file BASENAME-WORKER_ID[.EXT]. BASENAME is the \
         basename of FILE, WORKER_ID is the zero-indexed id of the worker and \
         .EXT is the extension of FILE if present."
      ()

  let buffer_size =
    Clap.default_int
      ~section
      ~long:"log-buffer-size"
      ~placeholder:"COUNT"
      ~description:
        "Before logging an error on stdout, also log the last COUNT messages \
         that have been ignored because of the log level since the last \
         message that was not ignored."
      50

  let worker_id =
    Clap.flag
      ~section
      ~set_long:"log-worker-id"
      ~description:
        "Decorate logs with worker IDs when --job-count is more than 1."
      false

  let commands =
    Clap.flag
      ~section
      ~set_long:"commands"
      ~set_short:'c'
      ~description:
        "Output commands which are run, in a way that is easily copy-pasted \
         for manual reproducibility."
      false
end

module Reports = struct
  let section = Clap.section "REPORTS"

  let time =
    Clap.flag
      ~section
      ~set_long:"time"
      ~description:
        "Print a summary of the total time taken by each test. Ignored if a \
         test failed. Includes the time read from records: to display a \
         record, you can use --from-record <FILE> --list --time."
      false

  let record =
    Clap.optional_string
      ~section
      ~long:"record"
      ~placeholder:"FILE"
      ~description:
        "Record test results to FILE. This file can then be used with \
         --from-record. If you use --loop or --loop-count, times are averaged \
         for each test."
      ()

  let from_records =
    Clap.list_string
      ~section
      ~long:"from-record"
      ~placeholder:"FILE"
      ~description:
        "Use data recorded with --record. If specified multiple times, use the \
         union of those records.\n\n\
         If <FILE> is a directory, this is equivalent to specifying \
         --from-record for all files in this directory that have the .json \
         extension.\n\n\
         When using --time, test durations include tests found in record \
         files.\n\n\
         When using --record, the new record which is output does NOT include \
         the input records.\n\n\
         When using --junit, reports do NOT include input records."
      ()

  let junit =
    Clap.optional_string
      ~section
      ~long:"junit"
      ~placeholder:"FILE"
      ~description:
        "Store test results in FILE using JUnit XML format. Time information \
         for each test is the sum of all runs of this test for the current \
         session. Test result (success or failure) is the result for the last \
         run of the test."
      ()
end

module Commands = struct
  let section = Clap.section "COMMANDS"

  type command = Run | List | List_tsv | Suggest_jobs | Version

  let command =
    Clap.flag_enum
      ~section
      ~description:
        "Do not run tests. Instead:\n\n\
         --list, -l: List tests.\n\n\
         Pass --time to also display results and timings (in seconds) from a \
         previous execution given through --from-record, in the format TIME \
         (COUNT). TIME is the average time of successful executions. COUNT is \
         SCOUNT/(SCOUNT+FCOUNT) where SCOUNT (resp. FCOUNT) is the number of \
         successful (resp. failed) tests in the record. If there is only one \
         successful test, then (COUNT) is omitted. Tests lacking a past record \
         of successful executions are noted '-'. A final row is added \
         containing the total of the averages of successful test executions, \
         and the total number of selected tests.\n\n\
         --list-tsv: List tests as tab-separated values in the format FILE \
         TITLE TAGS.\n\n\
         Pass --time to also display results and timings (in nanoseconds) from \
         a previous execution given through --from-record. Then each line is \
         appended with STIME SCOUNT FTIME FCOUNT. STIME (resp. FTIME) is the \
         total running time in nanoseconds of successful (resp. failed) \
         previous runs. SCOUNT (resp. FCOUNT) is the count of successful \
         (resp. failed) previous runs.\n\n\
         --suggest-jobs: Read test results records specified with \
         --from-record and suggest a partition of the tests that would result \
         in --job-count sets of roughly the same total duration. Output each \
         job as a list of flags that can be passed to Tezt, followed by a \
         shell comment that denotes the expected duration of the job.\n\n\
         A similar result can be obtained with --list --job, except that the \
         last job suggested by --suggest-jobs uses --not-test to express \"all \
         tests that are not already in other jobs\", meaning that the last job \
         acts as a catch-all for unknown tests.\n\n\
         --version: Print the version number of Tezt and exit."
      [
        (["list"], ['l'], List);
        (["list-tsv"], [], List_tsv);
        (["suggest-jobs"], [], Suggest_jobs);
        (["version"], [], Version);
      ]
      Run
end

module Selecting_tests = struct
  let section =
    Clap.section
      "SELECTING TESTS"
      ~description:
        ("Tests are registered with a filename, a title, and a list of tags. \
          You can specify multiple tags, negated tags, titles, title patterns \
          and filenames on the command line. Only tests which match all the \
          following conditions will be run:\n\
          - the test must have all tags and none of the negated tags;\n\
          - the test must have one of the specified titles;\n\
          - the test must have a title matching one of the specified patterns;\n\
          - the test must be implemented in one of the specified files.\n\n\
          The tags of a test are given by the ~tags argument of Test.register. \
          To negate a tag, prefix it with a slash: /\n\n\
          The title of a test is given by the ~title argument of \
          Test.register. It is what is printed after [SUCCESS] (or [FAILURE] \
          or [ABORTED]) in the reports. Use --title (respectively --not-title) \
          to select (respectively unselect) a test by its title on the \
          command-line. You can also select (respectively unselect) tests for \
          which 'filename: title' matches one or several Perl regular \
          expressions using --match (respectively --not-match).\n\n\
          The file in which a test is implemented is specified by the \
          ~__FILE__ argument of Test.register. In other words, it is the path \
          of the file in which the test is defined. Use --file (respectively \
          --not-file) to select (respectively unselect) a test by its path (or \
          a suffix thereof) on the command-line.\n\n\
          For instance:\n\n" ^ Sys.argv.(0)
       ^ " node bake /rpc --file bootstrap.ml --file sync.ml\n\n\
          will run all tests defined in either bootstrap.ml or sync.ml, which \
          have at least tags 'node' and 'bake', but which do not have the \
          'rpc' tag.\n\n\
          You can also specify more complex predicates using the Test \
          Selection Language (TSL). For instance:\n\n" ^ Sys.argv.(0)
       ^ " 'file = bootstrap.ml || bake && /rpc'\n\n\
          runs all tests defined in bootstrap.ml, as well as tests (possibly \
          from other files) with tag 'bake' but without tag 'rpc'. This \
          example cannot be expressed without TSL.\n\n\
          Passing multiple predicates is equivalent to passing their \
          conjunction as a single predicate. For instance, passing the two \
          command-line arguments 'a || b' and 'c || d' is equivalent to \
          passing the single argument '(a || b) && (c || d)'.\n\n\
         \          TSL allows the following expressions, where STRING denotes \
          a string and EXPR denotes a TSL expression:\n\
          - 'true': always true;\n\
          - 'false': always false;\n\
          - 'EXPR && EXPR': conjunction;\n\
          - 'EXPR || EXPR': disjunction;\n\
          - 'not EXPR': negation;\n\
          - 'STRING': test has tag STRING;\n\
          - '/STRING': same as 'not STRING' (STRING must not be quoted);\n\
          - 'file = STRING': test file is STRING;\n\
          - 'file <> STRING': same as 'not (file = STRING)';\n\
          - 'title = STRING': test title is STRING;\n\
          - 'title <> STRING': same as 'not (title = STRING)';\n\
          - 'file =~ STRING': test file matches the regular expression STRING;\n\
          - 'file =~! STRING': same as 'not (file =~ STRING)';\n\
          - 'title =~ STRING': test title matches the regular expression STRING;\n\
          - 'title =~! STRING': same as 'not (title =~ STRING)';\n\
          - '(EXPR)': same as EXPR.\n\n\
          'not' has higher precedence than '&&' which has higher precedence \
          than '||'.\n\n\
          TSL strings need to be quoted using double quotes '\"' unless they \
          only contain characters 'a-zA-Z0-9_-./' and do not start with a \
          slash '/'. Double quotes '\"' and backslashes '\\' need to be \
          escaped using backslashes '\\'.\n\n\
          Note that 'file = STRING' is not equivalent to '--file STRING'. \
          Indeed, '--file a.ml' selects 'x/a.ml', while 'file = a.ml' does \
          not.")

  let files_to_run =
    Clap.list_string
      ~section
      ~long:"file"
      ~short:'f'
      ~placeholder:"FILE"
      ~description:
        "Only run tests implemented in source files ending with FILE."
      ()

  let files_not_to_run =
    Clap.list_string
      ~section
      ~long:"not-file"
      ~placeholder:"FILE"
      ~description:
        "Only run tests not implemented in source files ending with FILE."
      ()

  let rex_type =
    Clap.typ
      ~name:"Perl regular expression"
      ~dummy:(rex "")
      ~parse:(fun s -> Some (rex s))
      ~show:show_rex

  let patterns_to_run =
    Clap.list
      rex_type
      ~section
      ~long:"match"
      ~short:'m'
      ~placeholder:"PERL_REGEXP"
      ~description:
        "Only run tests for which 'FILE: TITLE' matches PERL_REGEXP (case \
         insensitive), where FILE is the source file of the test and TITLE its \
         title."
      ()

  let patterns_not_to_run =
    Clap.list
      rex_type
      ~section
      ~long:"not-match"
      ~placeholder:"PERL_REGEXP"
      ~description:
        "Only run tests for which 'FILE: TITLE' does not match PERL_REGEXP \
         (case insensitive), where FILE is the source file of the test and \
         TITLE its title."
      ()

  let tests_to_run =
    Clap.list_string
      ~section
      ~long:"title"
      ~long_synonyms:["test"]
      ~short:'t'
      ~description:"Only run tests which are exactly entitled TITLE."
      ()

  let tests_not_to_run =
    Clap.list_string
      ~section
      ~long:"not-title"
      ~long_synonyms:["not-test"]
      ~description:"Only run tests which are not exactly entitled TITLE."
      ()

  let job_type =
    Clap.typ
      ~name:"--job"
      ~dummy:(1, 1)
      ~parse:(fun value ->
        match String.split_on_char '/' value with
        | [index; count] -> (
            match (int_of_string_opt index, int_of_string_opt count) with
            | Some index, Some count
              when index >= 1 && count >= 1 && index <= count ->
                Some (index, count)
            | _ -> None)
        | _ -> None)
      ~show:(fun (index, count) ->
        string_of_int index ^ "/" ^ string_of_int count)

  let job =
    Clap.optional
      job_type
      ~section
      ~long:"job"
      ~placeholder:"<INDEX>/<COUNT>"
      ~description:
        "Split the set of selected tests into COUNT subsets of roughly the \
         same total duration. Execute only one of these subsets, specified by \
         INDEX.\n\n\
         COUNT must be at least 1 and INDEX must be between 1 and COUNT.\n\n\
         Use --from-record to feed duration data from past runs. Tests for \
         which no time data is available are given a default duration of 1 \
         second.\n\n\
         You can use --list to see what tests are in a subset without actually \
         running the tests.\n\n\
         A typical use is to run tests in parallel on different machines. For \
         instance, have one machine run with --job 1/3, one with --job 2/3 and \
         one with --job 3/3. Be sure to provide exactly the same records with \
         --from-record, in the same order, and to select exactly the same set \
         of tests (same tags, same --file and same --test) for all machines, \
         otherwise some tests may not be run at all."
      ()

  let skip =
    Clap.default_int
      ~section
      ~long:"skip"
      ~placeholder:"COUNT"
      ~description:
        "Skip the first COUNT tests. This filter is applied after --job and \
         before --only."
      0

  let only =
    Clap.optional_int
      ~section
      ~long:"only"
      ~placeholder:"COUNT"
      ~description:
        "Only run the first COUNT tests. This filter is applied after --job \
         and --skip."
      ()

  let tsl_expression_type =
    Clap.typ
      ~name:"TSL expression"
      ~dummy:TSL_AST.True
      ~parse:TSL.parse
      ~show:TSL.show

  let tsl_expression () =
    Clap.list
      tsl_expression_type
      ~section
      ~placeholder:"TSL_EXPRESSION"
      ~description:
        "Only run tests that satisfy the predicate denoted by TSL_EXPRESSION."
      ()
    |> TSL.conjunction
end

let get_opt parse parameter =
  match String_map.find_opt parameter Options.test_args with
  | Some value -> (
      match parse value with
      | None -> failwith (sf "invalid value for -a %s: %s" parameter value)
      | Some value -> Some value)
  | None -> None

let get ?default parse parameter =
  match get_opt parse parameter with
  | Some v -> v
  | None -> (
      match default with
      | None ->
          failwith
            (sf
               "missing test argument %s, please specify it with: -a %s=<VALUE>"
               parameter
               parameter)
      | Some default -> default)

let get_bool ?default parameter = get ?default bool_of_string_opt parameter

let get_int ?default parameter = get ?default int_of_string_opt parameter

let get_float ?default parameter = get ?default float_of_string_opt parameter

let get_string ?default parameter = get ?default Option.some parameter

let get_bool_opt parameter = get_opt bool_of_string_opt parameter

let get_int_opt parameter = get_opt int_of_string_opt parameter

let get_float_opt parameter = get_opt float_of_string_opt parameter

let get_string_opt parameter = get_opt Option.some parameter