Merge pull request #417 from talex5/fetch-tag-objects

Fix fetching of tag objects

ci/src/cI_git.ml

@@ -96,10 +96,11 @@ module Builder = struct
     let hash = Key.hash key in
     Printf.sprintf "git-pull-of-%s" hash
 
-  let generate t ~switch ~log _trans NoContext pr =
+  let generate t ~switch ~log _trans NoContext target =
     let output = CI_live_log.write log in
-    let hash = Key.hash pr in
-    let tmp_branch = branch t pr in
+    let hash = Key.hash target in
+    let tmp_branch = branch t target in
+    let tmp_tag = Printf.sprintf "%s.new" tmp_branch in
     let env = Unix.environment () |> with_gitdir (Filename.concat t.dir ".git") in
     (* First, see if we've already got this commit. *)
     Lwt.try_bind
@@ -116,11 +117,14 @@ module Builder = struct
          CI_live_log.log log "Fetching PR branch";
          (* We can't be sure the PR's head still exists, but we can fetch the current
             head and then try to switch to the one we want. *)
+         (* We fetch to a tag rather than a branch in case the target is a tag object. *)
          (* Three step process to ensure we don't end up pointing at the wrong commit *)
-         CI_process.run ~switch ~env ~output ("", [| "git"; "fetch"; "origin"; Printf.sprintf "%s:%s.new" (Key.branch pr) tmp_branch |]) >>= fun () ->
+         let cmd = [| "git"; "fetch"; "origin";
+                      Printf.sprintf "%s:tags/%s" (Key.branch target) tmp_tag |] in
+         CI_process.run ~switch ~env ~output ("", cmd) >>= fun () ->
          Lwt_mutex.with_lock git_lock @@ fun () -> (* (hopefully fetch can handle parallel uses) *)
          CI_process.run ~env ~output ("", [| "git"; "branch"; "-f"; tmp_branch; hash |]) >>= fun () ->
-         CI_process.run ~env ~output ("", [| "git"; "branch"; "-D"; tmp_branch ^ ".new" |]) >>= fun () ->
+         CI_process.run ~env ~output ("", [| "git"; "tag"; "-d"; tmp_tag |]) >>= fun () ->
          Lwt.return @@ Ok { Commit.repo = t; hash }
       )
 end

ci/src/cI_process.ml

@@ -2,6 +2,9 @@ open! Astring
 open CI_utils
 open Lwt.Infix
 
+let child_src = Logs.Src.create "datakit-ci.child" ~doc:"Output from child process"
+module Child = (val Logs.src_log child_src : Logs.LOG)
+
 let pp_args =
   let sep = Fmt.(const string) " " in
   Fmt.array ~sep String.dump
@@ -69,6 +72,7 @@ let run_with_exit_status ?switch ?log ?cwd ?env ~output ?log_cmd cmd =
                 Lwt.return `Eof
               | data ->
                 output data;
+                Child.debug (fun f -> f "%S" data);
                 (* Hack because child#terminate may not kill sub-children.
                    Hopefully closing stdout will encourage them to exit. *)
                 Lwt_switch.check switch;

ci/tests/test_ci.ml

@@ -37,6 +37,10 @@ module Workflows = struct
 
   let pass check_build _target =
     T.of_lwt_slow (check_build "pass")
+
+  let fetch_only ~local_repo check_build t =
+    Git.fetch_head local_repo t >>= fun _ ->
+    T.of_lwt_slow (check_build "a")
 end
 
 open Lwt.Infix
@@ -319,63 +323,93 @@ let test_pending_updates conn =
   | { result = Ok 1; _ } -> Lwt.return ()
   | _ -> Alcotest.fail "Expected success"
 
-let test_git_dir conn ~clone =
-  let logs = Private.create_logs () in
-  let run args = Process.run ~output:print_string ("", Array.of_list args) in
+let run args = Process.run ~output:print_string ("", Array.of_list args)
+
+let with_git_remote fn =
   let ( / ) = Filename.concat in
   let old_cwd = Sys.getcwd () in
-  let cmd =
-    if clone then Workflows.ls_clone ~logs
-    else Workflows.ls ~logs
-  in
   Lwt.finalize
     (fun () ->
        Utils.with_tmpdir (fun tmpdir ->
            (* Set up the "remote" Git repository *)
            Sys.chdir tmpdir;
-           run ["git"; "init"; "my-repo"] >>= fun () ->
-           Sys.chdir "my-repo";
+           let remote_dir = tmpdir / "my-repo" in
+           run ["git"; "init"; remote_dir] >>= fun () ->
+           Sys.chdir remote_dir;
+           (* Add a test file *)
            Lwt_io.with_file ~mode:Lwt_io.output "src" (fun ch ->
                Lwt_io.write ch "Test"
              )
            >>= fun () ->
-           (* Add a test file *)
            run ["git"; "add"; "src"] >>= fun () ->
            run ["git"; "commit"; "-m"; "Initial commit"] >>= fun () ->
-           Lwt_process.pread_line ("", [| "git"; "rev-parse"; "HEAD" |]) >>= fun hash ->
            (* Clone a "local" copy *)
-           run ["git"; "clone"; tmpdir / "my-repo"; tmpdir / "clone"] >>= fun () ->
-           let local_repo = Git.v ~logs ~dir:(tmpdir / "clone") in
-           (* Start the CI *)
-           Test_utils.with_ci conn (Workflows.pull_and_run local_repo ~cmd) @@ fun ~logs ~switch dk with_handler ->
-           DK.branch dk "github-metadata" >>*= fun hooks ->
-           let wait_for ~commit path = Test_utils.wait_for_file ~switch hooks (Printf.sprintf "user/project/commit/%s/status/%s" commit path) in
-           (* Create a pull request *)
-           with_handler ~logs "a" (fun ~switch:_ _log ->
-               Test_utils.update_pr hooks ~message:"Init" ~id:1 ~head:hash ~states:[] >>= fun () ->
-               wait_for ~commit:hash "ci/datakit/test/state" "pending" >>= fun () ->
-               Lwt.return (Ok "Success!")
-             )
-           >>= fun () ->
-           wait_for ~commit:hash "ci/datakit/test/state" ~old:"pending" "success" >>= fun () ->
-           DK.branch dk (Printf.sprintf "shell-of-ls-on-%s" hash) >>*= fun results ->
-           DK.Branch.head results >>*= function
-           | None -> Alcotest.fail "Missing results branch!"
-           | Some head ->
-             let tree = DK.Commit.tree head in
-             DK.Tree.read_file tree (Datakit_path.of_string_exn "log") >>*= fun log ->
-             let log = Cstruct.to_string log in
-             if not (String.is_infix ~affix:"Running \"ls\"...\nsrc" log) then
-               Alcotest.fail "Missing 'src' in log output"
-             else
-               Lwt.return ()
+           let local_clone = tmpdir / "clone" in
+           run ["git"; "clone"; tmpdir / "my-repo"; local_clone] >>= fun () ->
+           fn ~remote_dir ~local_clone
          )
     )
     (fun () ->
        Sys.chdir old_cwd;
        Lwt.return ()
     )
 
+let test_git_dir conn ~clone =
+  let logs = Private.create_logs () in
+  let cmd =
+    if clone then Workflows.ls_clone ~logs
+    else Workflows.ls ~logs
+  in
+  with_git_remote @@ fun ~remote_dir ~local_clone ->
+  Sys.chdir remote_dir;
+  Lwt_process.pread_line ("", [| "git"; "rev-parse"; "HEAD" |]) >>= fun hash ->
+  let local_repo = Git.v ~logs ~dir:local_clone in
+  (* Start the CI *)
+  Test_utils.with_ci conn (Workflows.pull_and_run local_repo ~cmd) @@ fun ~logs ~switch dk with_handler ->
+  DK.branch dk "github-metadata" >>*= fun hooks ->
+  let wait_for ~commit path = Test_utils.wait_for_file ~switch hooks (Printf.sprintf "user/project/commit/%s/status/%s" commit path) in
+  (* Create a pull request *)
+  with_handler ~logs "a" (fun ~switch:_ _log ->
+      Test_utils.update_pr hooks ~message:"Init" ~id:1 ~head:hash ~states:[] >>= fun () ->
+      wait_for ~commit:hash "ci/datakit/test/state" "pending" >>= fun () ->
+      Lwt.return (Ok "Success!")
+    )
+  >>= fun () ->
+  wait_for ~commit:hash "ci/datakit/test/state" ~old:"pending" "success" >>= fun () ->
+  DK.branch dk (Printf.sprintf "shell-of-ls-on-%s" hash) >>*= fun results ->
+  DK.Branch.head results >>*= function
+  | None -> Alcotest.fail "Missing results branch!"
+  | Some head ->
+    let tree = DK.Commit.tree head in
+    DK.Tree.read_file tree (Datakit_path.of_string_exn "log") >>*= fun log ->
+    let log = Cstruct.to_string log in
+    if not (String.is_infix ~affix:"Running \"ls\"...\nsrc" log) then
+      Alcotest.fail "Missing 'src' in log output"
+    else
+      Lwt.return ()
+
+let test_git_tag conn =
+  let logs = Private.create_logs () in
+  with_git_remote @@ fun ~remote_dir ~local_clone ->
+  let local_repo = Git.v ~logs ~dir:local_clone in
+  (* Start the CI *)
+  Test_utils.with_ci conn Workflows.(fetch_only ~local_repo) @@ fun ~logs ~switch dk with_handler ->
+  DK.branch dk "github-metadata" >>*= fun hooks ->
+  let wait_for ~commit path = Test_utils.wait_for_file ~switch hooks (Printf.sprintf "user/project/commit/%s/status/%s" commit path) in
+  (* Create a tag *)
+  Sys.chdir remote_dir;
+  run ["git"; "commit"; "--allow-empty"; "-m"; "Release 0.1"] >>= fun () ->
+  Lwt_process.pread_line ("", [| "git"; "rev-parse"; "HEAD" |]) >>= fun hash ->
+  run ["git"; "tag"; "-a"; "-m"; "Release 0.1"; "v0.1"; hash] >>= fun () ->
+  with_handler ~logs "a" (fun ~switch:_ _log ->
+      Test_utils.update_ref hooks ~message:"Tag" ~id:"v0.1" ~head:hash ~states:[] >>= fun () ->
+      wait_for ~commit:hash "ci/datakit/test/state" "pending" >>= fun () ->
+      Lwt.return (Ok "Success")
+    )
+  >>= fun () ->
+  wait_for ~old:"pending" ~commit:hash "ci/datakit/test/state" "success" >>= fun () ->
+  Lwt.return ()
+
 let test_cross_project conn =
   Test_utils.with_ci conn Workflows.test_cross_project @@ fun ~logs ~switch dk _with_handler ->
   ignore logs;
@@ -492,6 +526,7 @@ let test_set = [
   "Test pending",   `Quick, Test_utils.run test_pending_updates;
   "Git",            `Quick, Test_utils.run (test_git_dir ~clone:false);
   "Git (clone)",    `Quick, Test_utils.run (test_git_dir ~clone:true);
+  "Git tag",        `Quick, Test_utils.run test_git_tag;
   "Cross-project",  `Quick, Test_utils.run test_cross_project;
   "Auth",           `Quick, test_auth;
   "Roles",          `Quick, Test_utils.run_private test_roles;

ci/tests/test_utils.ml

@@ -53,6 +53,7 @@ let () =
   CI_log_reporter.init None (Some Logs.Info);
   Logs.Src.list () |> List.iter (fun src ->
       match Logs.Src.name src with
+      | "datakit-ci.child" -> Logs.Src.set_level src (Some Logs.Debug)
       | "datakit-ci" -> Logs.Src.set_level src (Some Logs.Debug)
       | "dkt-github" -> Logs.Src.set_level src (Some Logs.Debug)
       | "Client9p" -> Logs.Src.set_level src (Some Logs.Info)
@@ -173,6 +174,13 @@ let assert_file branch path value =
     Alcotest.(check string) (Printf.sprintf "%s=%s" path value) value data;
     Lwt.return ()
 
+let update_ref hooks ~id ~head ~states ~message =
+  update hooks ~message (
+    (Printf.sprintf "user/project/ref/%s/head" id, head) ::
+    (Printf.sprintf "user/project/ref/%s/state" id, "open") ::
+    List.map (fun (path, data) -> Printf.sprintf "user/project/commit/%s/status/%s" head path, data) states
+  )
+
 let update_pr hooks ~id ~head ~states ~message =
   update hooks ~message (
     (Printf.sprintf "user/project/pr/%d/head" id, head) ::