mte/unikernel/duniverse/dune_/test/expect-tests/vcs/vcs_tests.ml

open Stdune
open Fiber.O
open Dune_vcs
open! Dune_tests_common
module Process = Dune_engine.Process
module Scheduler = Dune_engine.Scheduler

let () = init ()
let printf = Printf.printf
let temp_dir = lazy (Path.of_string "vcs-tests")
let () = at_exit (fun () -> Path.rm_rf (Lazy.force temp_dir))

(* When hg is not available, we test with git twice indeed. This is because many
   people don't have hg installed. *)
let has_hg =
  match Lazy.force Vcs.hg with
  | (_ : Path.t) -> true
  | exception _ -> false
;;

let run (vcs : Vcs.t) args =
  let prog, prog_str, real_args =
    match vcs.kind with
    | Git -> Vcs.git, "git", args
    | Hg ->
      if has_hg
      then Vcs.hg, "hg", args
      else
        ( Vcs.git
        , "hg"
        , (match args with
           | [ "tag"; s; "-u"; _ ] -> [ "tag"; "-a"; s; "-m"; s ]
           | [ "commit"; "-m"; msg; "-u"; _ ] -> [ "commit"; "-m"; msg ]
           | _ -> args) )
  in
  printf "$ %s\n" (String.quote_list_for_shell (prog_str :: args));
  Process.run
    Strict
    (Lazy.force prog)
    real_args
    ~display:Quiet
    ~env:
      ((* One of the reasons to set GIT_DIR is to override any GIT_DIR set by
          the environment, which helps for example during [git rebase
          --exec]. *)
       Env.add
         Env.initial
         ~var:"GIT_DIR"
         ~value:(Filename.concat (Path.to_absolute_filename vcs.root) ".git"))
    ~dir:vcs.root
    ~stdout_to:(Process.Io.file Dev_null.path Process.Io.Out)
;;

type action =
  | Init
  | Add of string
  | Write of string * string
  | Commit
  | Tag of string
  | Describe of string

let run_action (vcs : Vcs.t) action =
  match action with
  | Init ->
    let* () = run vcs [ "init"; "-q" ] in
    (match vcs.kind with
     | Hg -> Fiber.return ()
     | Git ->
       let* () = run vcs [ "config"; "user.email"; "dune@dune.com" ] in
       run vcs [ "config"; "user.name"; "Dune Dune" ])
  | Add fn -> run vcs [ "add"; fn ]
  | Commit ->
    (match vcs.kind with
     | Git -> run vcs [ "commit"; "-m"; "commit message" ]
     | Hg -> run vcs [ "commit"; "-m"; "commit message"; "-u"; "toto" ])
  | Write (fn, s) ->
    printf "$ echo %S > %s\n" s fn;
    Io.write_file (Path.relative (Lazy.force temp_dir) fn) s;
    Fiber.return ()
  | Describe expected ->
    printf
      "$ %s describe [...]\n"
      (match vcs.kind with
       | Git -> "git"
       | Hg -> "hg");
    Memo.reset (Memo.Invalidation.clear_caches ~reason:Test);
    let vcs =
      match vcs.kind with
      | Hg when not has_hg -> { vcs with kind = Git }
      | _ -> vcs
    in
    let+ s = Memo.run (Vcs.describe vcs) in
    let s = Option.value s ~default:"n/a" in
    let processed =
      String.split s ~on:'-'
      |> List.map ~f:(fun s ->
        match s with
        | "" | "dirty" -> s
        | s
          when String.length s = 1
               && String.for_all s ~f:(function
                 | '0' .. '9' -> true
                 | _ -> false) -> s
        | _
          when String.for_all s ~f:(function
                 | '0' .. '9' | 'a' .. 'z' -> true
                 | _ -> false) -> "<commit-id>"
        | _ -> s)
      |> String.concat ~sep:"-"
    in
    printf "%s\n" processed;
    if processed <> expected then printf "Expected: %s\nOriginal: %s\n" expected s;
    printf "\n"
  | Tag s ->
    (match vcs.kind with
     | Git -> run vcs [ "tag"; "-a"; s; "-m"; s ]
     | Hg -> run vcs [ "tag"; s; "-u"; "toto" ])
;;

let run kind script =
  let (lazy temp_dir) = temp_dir in
  Path.rm_rf temp_dir;
  Path.mkdir_p temp_dir;
  let vcs = { Vcs.kind; root = temp_dir } in
  Dune_engine.Clflags.display := Short;
  let config =
    { Scheduler.Config.concurrency = 1
    ; stats = None
    ; print_ctrl_c_warning = false
    ; watch_exclusions = []
    }
  in
  Scheduler.Run.go
    ~on_event:(fun _ _ -> ())
    config
    (fun () -> Fiber.sequential_iter script ~f:(run_action vcs))
;;

let script =
  [ Init
  ; Write ("a", "-")
  ; Add "a"
  ; Commit
  ; Describe "<commit-id>"
  ; Write ("b", "-")
  ; Add "b"
  ; Describe "<commit-id>-dirty"
  ; Commit
  ; Describe "<commit-id>"
  ; Tag "1.0"
  ; Describe "1.0"
  ; Write ("c", "-")
  ; Add "c"
  ; Describe "1.0-dirty"
  ; Commit
  ; Describe "1.0-1-<commit-id>"
  ; Write ("d", "-")
  ; Add "d"
  ; Describe "1.0-1-<commit-id>-dirty"
  ; Commit
  ; Describe "1.0-2-<commit-id>"
  ]
;;

let%expect_test _ =
  run Git script;
  [%expect
    {|
$ git init -q
$ git config user.email dune@dune.com
$ git config user.name 'Dune Dune'
$ echo "-" > a
$ git add a
$ git commit -m 'commit message'
$ git describe [...]
<commit-id>

$ echo "-" > b
$ git add b
$ git describe [...]
<commit-id>-dirty

$ git commit -m 'commit message'
$ git describe [...]
<commit-id>

$ git tag -a 1.0 -m 1.0
$ git describe [...]
1.0

$ echo "-" > c
$ git add c
$ git describe [...]
1.0-dirty

$ git commit -m 'commit message'
$ git describe [...]
1.0-1-<commit-id>

$ echo "-" > d
$ git add d
$ git describe [...]
1.0-1-<commit-id>-dirty

$ git commit -m 'commit message'
$ git describe [...]
1.0-2-<commit-id>
|}]
;;

let%expect_test _ =
  run Hg script;
  [%expect
    {|
$ hg init -q
$ echo "-" > a
$ hg add a
$ hg commit -m 'commit message' -u toto
$ hg describe [...]
<commit-id>

$ echo "-" > b
$ hg add b
$ hg describe [...]
<commit-id>-dirty

$ hg commit -m 'commit message' -u toto
$ hg describe [...]
<commit-id>

$ hg tag 1.0 -u toto
$ hg describe [...]
1.0

$ echo "-" > c
$ hg add c
$ hg describe [...]
1.0-dirty

$ hg commit -m 'commit message' -u toto
$ hg describe [...]
1.0-1-<commit-id>

$ echo "-" > d
$ hg add d
$ hg describe [...]
1.0-1-<commit-id>-dirty

$ hg commit -m 'commit message' -u toto
$ hg describe [...]
1.0-2-<commit-id>
|}]
;;