From 203bb22721103c35df1539eb5861934220559f2d Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Fri, 2 Apr 2021 22:24:19 -0700 Subject: [PATCH] Fix #3619 When the repository is empty, substitute version with dummy values Signed-off-by: Rudi Grinberg --- bin/install_uninstall.ml | 14 ++- src/dune_engine/build_system.ml | 10 +- src/dune_engine/vcs.ml | 75 ++++++++++--- src/dune_engine/vcs.mli | 4 +- src/dune_rules/artifact_substitution.ml | 4 +- src/dune_rules/watermarks.ml | 100 ++++++++++-------- .../{github4429.t/run.t => github4429.t} | 3 +- test/expect-tests/vcs_tests.ml | 3 +- 8 files changed, 141 insertions(+), 72 deletions(-) rename test/blackbox-tests/test-cases/{github4429.t/run.t => github4429.t} (85%) diff --git a/bin/install_uninstall.ml b/bin/install_uninstall.ml index 9b22bc9e8a58..05405225e795 100644 --- a/bin/install_uninstall.ml +++ b/bin/install_uninstall.ml @@ -134,12 +134,16 @@ module File_ops_real (W : Workspace) : File_operations = struct | Some package -> Memo.Build.run (get_vcs (Package.dir package))) >>= function | None -> plain_copy () - | Some vcs -> + | Some vcs -> ( let open Fiber.O in - let+ version = Memo.Build.run (Dune_engine.Vcs.describe vcs) in - let ppf = Format.formatter_of_out_channel oc in - print ppf ~version; - Format.pp_print_flush ppf ()) + let* version = Memo.Build.run (Dune_engine.Vcs.describe vcs) in + match version with + | None -> plain_copy () + | Some version -> + let ppf = Format.formatter_of_out_channel oc in + print ppf ~version; + Format.pp_print_flush ppf (); + Fiber.return ())) let process_meta ic = let lb = Lexing.from_channel ic in diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index d52f66b14707..bed45f1fdb27 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -444,12 +444,14 @@ let set_vcs vcs = let+ with_repositories = let f ({ Vcs.root; _ } as vcs) = let+ commit = Memo.Build.run (Vcs.commit_id vcs) in - { Cache.directory = Path.to_absolute_filename root - ; remote = "" (* FIXME: fill or drop from the protocol *) - ; commit - } + Option.map commit ~f:(fun commit -> + { Cache.directory = Path.to_absolute_filename root + ; remote = "" (* FIXME: fill or drop from the protocol *) + ; commit + }) in let+ repositories = Fiber.parallel_map ~f (Fdecl.get t.vcs) in + let repositories = List.filter_opt repositories in Caching.Cache.with_repositories Caching.cache repositories in match with_repositories with diff --git a/src/dune_engine/vcs.ml b/src/dune_engine/vcs.ml index 1f54525f25c2..f76e8479f93f 100644 --- a/src/dune_engine/vcs.ml +++ b/src/dune_engine/vcs.ml @@ -79,9 +79,21 @@ let run t args = in String.trim s -let run_zero_separated t args = - Process.run_capture_zero_separated Strict (prog t) args ~dir:t.root - ~env:Env.initial +let git_accept () = + Process.Accept (Predicate_lang.union [ Element 0; Element 128 ]) + +let run_git t args = + let res = + Process.run_capture (git_accept ()) (prog t) args ~dir:t.root + ~env:Env.initial + in + let open Fiber.O in + let+ res = res in + match res with + | Ok s -> Some (String.trim s) + | Error 128 -> None + | Error n -> + User_error.raise [ Pp.textf "Unexpected response from `git` (code %d)" n ] let hg_describe t = let open Fiber.O in @@ -114,25 +126,60 @@ let make_fun name ~output ~doc ~git ~hg = in Staged.stage (Memo.exec memo) +module Option_output (S : sig + type t + + val to_dyn : t -> Dyn.t +end) = +struct + type t = S.t option + + let to_dyn t = Dyn.Encoder.option S.to_dyn t +end + let describe = Staged.unstage @@ make_fun "vcs-describe" ~doc:"Obtain a nice description of the tip from the vcs" - ~output:(Simple (module String)) - ~git:(fun t -> run t [ "describe"; "--always"; "--dirty" ]) - ~hg:hg_describe + ~output:(Simple (module Option_output (String))) + ~git:(fun t -> + run_git t [ "describe"; "--always"; "--dirty" ] + |> Fiber.map ~f:(Option.map ~f:String.trim)) + ~hg:(fun x -> + let open Fiber.O in + let+ res = hg_describe x in + Some res) let commit_id = Staged.unstage @@ make_fun "vcs-commit-id" ~doc:"The hash of the head commit" - ~output:(Simple (module String)) - ~git:(fun t -> run t [ "rev-parse"; "HEAD" ]) - ~hg:(fun t -> run t [ "id"; "-i" ]) + ~output:(Simple (module Option_output (String))) + ~git:(fun t -> run_git t [ "rev-parse"; "HEAD" ]) + ~hg:(fun t -> + let open Fiber.O in + let+ res = run t [ "id"; "-i" ] in + Some res) let files = - let f args t = + let run_zero_separated_hg t args = + Process.run_capture_zero_separated Strict (prog t) args ~dir:t.root + ~env:Env.initial + in + let run_zero_separated_git t args = + let open Fiber.O in + let+ res = + Process.run_capture_zero_separated (git_accept ()) (prog t) args + ~dir:t.root ~env:Env.initial + in + match res with + | Ok s -> s + | Error 128 -> [] + | Error n -> + User_error.raise [ Pp.textf "Unexpected response from `git` (code %d)" n ] + in + let f run args t = let open Fiber.O in - let+ l = run_zero_separated t args in + let+ l = run t args in List.map l ~f:Path.in_source in Staged.unstage @@ -144,5 +191,7 @@ let files = let to_dyn = Dyn.Encoder.list Path.to_dyn end)) - ~git:(f [ "ls-tree"; "-z"; "-r"; "--name-only"; "HEAD" ]) - ~hg:(f [ "files"; "-0" ]) + ~git: + (f run_zero_separated_git + [ "ls-tree"; "-z"; "-r"; "--name-only"; "HEAD" ]) + ~hg:(f run_zero_separated_hg [ "files"; "-0" ]) diff --git a/src/dune_engine/vcs.mli b/src/dune_engine/vcs.mli index 5797b39d9382..799fb94f6b72 100644 --- a/src/dune_engine/vcs.mli +++ b/src/dune_engine/vcs.mli @@ -22,10 +22,10 @@ val equal : t -> t -> bool val to_dyn : t -> Dyn.t (** Nice description of the current tip *) -val describe : t -> string Memo.Build.t +val describe : t -> string option Memo.Build.t (** String uniquely identifying the current head commit *) -val commit_id : t -> string Memo.Build.t +val commit_id : t -> string option Memo.Build.t (** List of files committed in the repo *) val files : t -> Path.t list Memo.Build.t diff --git a/src/dune_rules/artifact_substitution.ml b/src/dune_rules/artifact_substitution.ml index d911de2e6148..42e65fe0caaf 100644 --- a/src/dune_rules/artifact_substitution.ml +++ b/src/dune_rules/artifact_substitution.ml @@ -135,7 +135,9 @@ let eval t ~conf = (let open Memo.Build.O in conf.get_vcs p >>= function | None -> Memo.Build.return "" - | Some vcs -> Vcs.describe vcs) + | Some vcs -> + let+ res = Vcs.describe vcs in + Option.value res ~default:"") | Location (name, lib_name) -> Fiber.return (relocatable (conf.get_location name lib_name)) | Configpath d -> diff --git a/src/dune_rules/watermarks.ml b/src/dune_rules/watermarks.ml index 88792b23ce51..fe7050ebc8bc 100644 --- a/src/dune_rules/watermarks.ml +++ b/src/dune_rules/watermarks.ml @@ -180,48 +180,51 @@ module Dune_project = struct let subst t ~map ~version = let s = - let replace_text start_ofs stop_ofs repl = - sprintf "%s%s%s" - (String.sub t.contents ~pos:0 ~len:start_ofs) - repl - (String.sub t.contents ~pos:stop_ofs - ~len:(String.length t.contents - stop_ofs)) - in - match t.version with - | Some v -> - (* There is a [version] field, overwrite its argument *) - replace_text v.loc_of_arg.start.pos_cnum v.loc_of_arg.stop.pos_cnum - (Dune_lang.to_string (Dune_lang.atom_or_quoted_string version)) - | None -> - let version_field = - Dune_lang.to_string - (List - [ Dune_lang.atom "version" - ; Dune_lang.atom_or_quoted_string version - ]) - ^ "\n" - in - let ofs = - ref - (match t.name with - | Some { loc; _ } -> - (* There is no [version] field but there is a [name] one, add the - version after it *) - loc.stop.pos_cnum - | None -> - (* If all else fails, add the [version] field after the first line - of the file *) - 0) + match version with + | None -> t.contents + | Some version -> ( + let replace_text start_ofs stop_ofs repl = + sprintf "%s%s%s" + (String.sub t.contents ~pos:0 ~len:start_ofs) + repl + (String.sub t.contents ~pos:stop_ofs + ~len:(String.length t.contents - stop_ofs)) in - let len = String.length t.contents in - while !ofs < len && t.contents.[!ofs] <> '\n' do - incr ofs - done; - if !ofs < len && t.contents.[!ofs] = '\n' then ( - incr ofs; - replace_text !ofs !ofs version_field - ) else - replace_text !ofs !ofs ("\n" ^ version_field) + match t.version with + | Some v -> + (* There is a [version] field, overwrite its argument *) + replace_text v.loc_of_arg.start.pos_cnum v.loc_of_arg.stop.pos_cnum + (Dune_lang.to_string (Dune_lang.atom_or_quoted_string version)) + | None -> + let version_field = + Dune_lang.to_string + (List + [ Dune_lang.atom "version" + ; Dune_lang.atom_or_quoted_string version + ]) + ^ "\n" + in + let ofs = + ref + (match t.name with + | Some { loc; _ } -> + (* There is no [version] field but there is a [name] one, add + the version after it *) + loc.stop.pos_cnum + | None -> + (* If all else fails, add the [version] field after the first + line of the file *) + 0) + in + let len = String.length t.contents in + while !ofs < len && t.contents.[!ofs] <> '\n' do + incr ofs + done; + if !ofs < len && t.contents.[!ofs] = '\n' then ( + incr ofs; + replace_text !ofs !ofs version_field + ) else + replace_text !ofs !ofs ("\n" ^ version_field)) in let s = Option.value (subst_string s ~map filename) ~default:s in if s <> t.contents then Io.write_file filename s @@ -230,6 +233,8 @@ end let make_watermark_map ~commit ~version ~dune_project ~info = let dune_project = Dune_project.project dune_project in let version_num = + let open Option.O in + let+ version = version in Option.value ~default:version (String.drop_prefix version ~prefix:"v") in let name = Dune_project.name dune_project in @@ -250,11 +255,18 @@ let make_watermark_map ~commit ~version ~dune_project ~info = | Some (Package.Source_kind.Url url) -> Ok url | None -> Error (sprintf "variable dev-repo not found in dune-project file") in + let make_version = function + | Some s -> Ok s + | None -> Error "repository does not contain any version information" + in String.Map.of_list_exn [ ("NAME", Ok (Dune_project.Name.to_string_hum name)) - ; ("VERSION", Ok version) - ; ("VERSION_NUM", Ok version_num) - ; ("VCS_COMMIT_ID", Ok commit) + ; ("VERSION", make_version version) + ; ("VERSION_NUM", make_version version_num) + ; ( "VCS_COMMIT_ID" + , match commit with + | None -> Error "repositroy does not contain any commits" + | Some s -> Ok s ) ; ( "PKG_MAINTAINER" , make_separated "maintainer" ", " @@ Package.Info.maintainers info ) ; ("PKG_AUTHORS", make_separated "authors" ", " @@ Package.Info.authors info) diff --git a/test/blackbox-tests/test-cases/github4429.t/run.t b/test/blackbox-tests/test-cases/github4429.t similarity index 85% rename from test/blackbox-tests/test-cases/github4429.t/run.t rename to test/blackbox-tests/test-cases/github4429.t index 2fc7ce715d21..c3bf3e3a7054 100644 --- a/test/blackbox-tests/test-cases/github4429.t/run.t +++ b/test/blackbox-tests/test-cases/github4429.t @@ -18,7 +18,6 @@ Create a repository with no HEAD commit: At the moment Dune fails, which is bad: $ dune exec ./main.exe 2>&1 | sed 's/.*\/git/{{ git }}/; s/> .*.output/> {{ output_file }}/g' - git (internal) (exit 128) - {{ git }} describe --always --dirty > {{ output_file }} + git (internal) fatal: bad revision 'HEAD' diff --git a/test/expect-tests/vcs_tests.ml b/test/expect-tests/vcs_tests.ml index 38fff99356ea..9316d4900ba7 100644 --- a/test/expect-tests/vcs_tests.ml +++ b/test/expect-tests/vcs_tests.ml @@ -77,7 +77,8 @@ let run_action (vcs : Vcs.t) action = | Hg when not has_hg -> { vcs with kind = Git } | _ -> vcs in - Memo.Build.run (Vcs.describe vcs) >>| fun s -> + let+ s = Memo.Build.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 ->