Fix #3619

When the repository is empty, substitute version with dummy values

Signed-off-by: Rudi Grinberg <[email protected]>

Author: rgrinberg

CHANGES.md

@@ -3,6 +3,8 @@ Unreleased
 
 - Allow multiple cinaps stanzas in the same directory (#4460, @rgrinberg)
 
+- Fix `$ dune subst` in empty git repositories (#4441, fixes #3619, @rgrinberg)
+
 - Improve interpretation of ansi escape sequence when spawning processes (#4408,
   fixes #2665, @rgrinberg)
 

bin/install_uninstall.ml

@@ -158,12 +158,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

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
+      ~stderr_to:(Process.Io.file Config.dev_null Out)
+  in
+  let open Fiber.O in
+  let+ res = res in
+  match res with
+  | Ok s -> Some (String.trim s)
+  | Error 128 -> None
+  | Error _ -> assert false
 
 let hg_describe t =
   let open Fiber.O in
@@ -114,25 +126,57 @@ 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" ])
+       ~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 _ -> assert false
+  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 +188,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" ])

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

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

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)

test/blackbox-tests/test-cases/github4429.t/run.t renamed to test/blackbox-tests/test-cases/github4429.t

@@ -15,10 +15,6 @@ Create a repository with no HEAD commit:
   >  (promote (until-clean)))
   > EOF
 
-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 }}
-  fatal: bad revision 'HEAD'
+Dune handles this gracefully since #4441
 
+  $ dune exec ./main.exe 2>&1

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