pkg: user error when non-existent repo specified (ocaml#10385)

Previously it would be a code error if a user specified an invalid git
repo url when pinning a package. This change makes it a user error
instead.

Signed-off-by: Stephen Sherratt <stephen@sherra.tt>

src/dune_pkg/fetch.ml

@@ -276,19 +276,19 @@ let fetch_others ~unpack ~checksum ~target (url : OpamUrl.t) =
     Error (Checksum_mismatch (Checksum.of_opam_hash expected))
 ;;
 
-let fetch_git rev_store ~target (url : OpamUrl.t) =
-  OpamUrl.resolve url rev_store
+let fetch_git rev_store ~target ~url:(url_loc, url) =
+  OpamUrl.resolve url ~loc:url_loc rev_store
   >>= (function
          | Error _ as e -> Fiber.return e
-         | Ok r -> OpamUrl.fetch_revision url r rev_store)
+         | Ok r -> OpamUrl.fetch_revision url ~loc:url_loc r rev_store)
   >>= function
   | Error msg -> Fiber.return @@ Error (Unavailable (Some msg))
   | Ok at_rev ->
     let+ res = Rev_store.At_rev.check_out at_rev ~target in
     Ok res
 ;;
 
-let fetch ~unpack ~checksum ~target (url : OpamUrl.t) =
+let fetch ~unpack ~checksum ~target ~url:(url_loc, url) =
   let event =
     Dune_stats.(
       start (global ()) (fun () ->
@@ -315,7 +315,7 @@ let fetch ~unpack ~checksum ~target (url : OpamUrl.t) =
       match url.backend with
       | `git ->
         let* rev_store = Rev_store.get in
-        fetch_git rev_store ~target url
+        fetch_git rev_store ~target ~url:(url_loc, url)
       | `http -> fetch_curl ~unpack ~checksum ~target url
       | _ -> fetch_others ~unpack ~checksum ~target url)
 ;;

src/dune_pkg/fetch.mli

@@ -16,11 +16,11 @@ val fetch
   :  unpack:bool
   -> checksum:Checksum.t option
   -> target:Path.t
-  -> OpamUrl.t
+  -> url:Loc.t * OpamUrl.t
   -> (unit, failure) result Fiber.t
 
 val fetch_git
   :  Rev_store.t
   -> target:Path.t
-  -> OpamUrl.t
+  -> url:Loc.t * OpamUrl.t
   -> (unit, failure) result Fiber.t

src/dune_pkg/opamUrl0.ml

@@ -44,7 +44,7 @@ let local_or_git_only url loc =
 
 include Comparable.Make (T)
 
-let remote t rev_store = Rev_store.remote rev_store ~url:(OpamUrl.base_url t)
+let remote t ~loc rev_store = Rev_store.remote rev_store ~url:(loc, OpamUrl.base_url t)
 
 type resolve =
   | Resolved of Rev_store.Object.resolved
@@ -61,9 +61,9 @@ let not_found t =
        ])
 ;;
 
-let resolve t rev_store =
+let resolve t ~loc rev_store =
   let open Fiber.O in
-  let remote = remote t rev_store in
+  let remote = remote t ~loc rev_store in
   match
     match rev t with
     | None -> `Default_branch
@@ -91,8 +91,8 @@ let resolve t rev_store =
      | Some o -> Ok (Resolved o))
 ;;
 
-let fetch_revision t resolve rev_store =
-  let remote = remote t rev_store in
+let fetch_revision t ~loc resolve rev_store =
+  let remote = remote t ~loc rev_store in
   let open Fiber.O in
   match resolve with
   | Resolved o -> Rev_store.fetch_resolved rev_store remote o >>| Result.ok

src/dune_pkg/opamUrl0.mli

@@ -23,16 +23,17 @@ val local_or_git_only : t -> Loc.t -> [ `Path of Path.t | `Git ]
 module Map : Map.S with type key = t
 module Set : Set.S with type elt = t and type 'a map = 'a Map.t
 
-val remote : t -> Rev_store.t -> Rev_store.Remote.t
+val remote : t -> loc:Loc.t -> Rev_store.t -> Rev_store.Remote.t
 
 type resolve =
   | Resolved of Rev_store.Object.resolved
   | Unresolved of Rev_store.Object.t
 
-val resolve : t -> Rev_store.t -> (resolve, User_message.t) result Fiber.t
+val resolve : t -> loc:Loc.t -> Rev_store.t -> (resolve, User_message.t) result Fiber.t
 
 val fetch_revision
   :  t
+  -> loc:Loc.t
   -> resolve
   -> Rev_store.t
   -> (Rev_store.At_rev.t, User_message.t) result Fiber.t

src/dune_pkg/opam_repo.ml

@@ -96,10 +96,10 @@ let of_opam_repo_dir_path loc opam_repo_dir_path =
 let of_git_repo loc url =
   let+ at_rev =
     let* rev_store = Rev_store.get in
-    OpamUrl.resolve url rev_store
+    OpamUrl.resolve url ~loc rev_store
     >>= function
     | Error _ as e -> Fiber.return e
-    | Ok s -> OpamUrl.fetch_revision url s rev_store
+    | Ok s -> OpamUrl.fetch_revision url ~loc s rev_store
   in
   let at_rev =
     match at_rev with

src/dune_pkg/rev_store.ml

@@ -149,6 +149,32 @@ let git_code_error ~dir ~args ~exit_code ~output =
     ]
 ;;
 
+module Git_error = struct
+  type t =
+    { dir : Path.t
+    ; args : string list
+    ; exit_code : int
+    ; output : string list
+    }
+
+  let raise_code_error { dir; args; exit_code; output } =
+    let git = Lazy.force Vcs.git in
+    Code_error.raise
+      "git returned non-zero exit code"
+      [ "exit code", Dyn.int exit_code
+      ; "dir", Path.to_dyn dir
+      ; "git", Path.to_dyn git
+      ; "args", Dyn.list Dyn.string args
+      ; "output", Dyn.list Dyn.string output
+      ]
+  ;;
+
+  let result_get_or_code_error = function
+    | Ok x -> x
+    | Error t -> raise_code_error t
+  ;;
+end
+
 let run_with_exit_code { dir; _ } ~allow_codes ~display args =
   let stdout_to = make_stdout () in
   let stderr_to = make_stderr () in
@@ -157,28 +183,29 @@ let run_with_exit_code { dir; _ } ~allow_codes ~display args =
     Process.run ~dir ~display ~stdout_to ~stderr_to ~env failure_mode git args
   in
   if allow_codes exit_code
-  then exit_code
-  else git_code_error ~dir ~args ~exit_code ~output:[]
+  then Ok exit_code
+  else Error { Git_error.dir; args; exit_code; output = [] }
 ;;
 
 let run t ~display args =
-  run_with_exit_code t ~allow_codes:(Int.equal 0) ~display args >>| ignore
+  run_with_exit_code t ~allow_codes:(Int.equal 0) ~display args
+  >>| Result.map ~f:(ignore : int -> unit)
 ;;
 
 let run_capture_lines { dir; _ } ~display args =
   let git = Lazy.force Vcs.git in
   let+ output, exit_code =
     Process.run_capture_lines ~dir ~display ~env failure_mode git args
   in
-  if exit_code = 0 then output else git_code_error ~dir ~args ~exit_code ~output
+  if exit_code = 0 then Ok output else Error { Git_error.dir; args; exit_code; output }
 ;;
 
 let run_capture_zero_separated_lines { dir; _ } args =
   let git = Lazy.force Vcs.git in
   let+ output, exit_code =
     Process.run_capture_zero_separated ~dir ~display:Quiet ~env failure_mode git args
   in
-  if exit_code = 0 then output else git_code_error ~dir ~args ~exit_code ~output
+  if exit_code = 0 then Ok output else Error { Git_error.dir; args; exit_code; output }
 ;;
 
 let cat_file { dir; _ } command =
@@ -297,7 +324,11 @@ let load_or_create ~dir =
     with_flock lock ~f:(fun () ->
       match Fpath.mkdir_p (Path.to_string dir) with
       | Already_exists -> Fiber.return ()
-      | Created -> run t ~display:Quiet [ "init"; "--bare" ]
+      | Created ->
+        run t ~display:Quiet [ "init"; "--bare" ]
+        >>| (function
+         | Ok () -> ()
+         | Error git_error -> Git_error.raise_code_error git_error)
       | exception Unix.Unix_error (e, x, y) ->
         User_error.raise
           [ Pp.textf "%s isn't a directory" (Path.to_string_maybe_quoted dir)
@@ -457,10 +488,11 @@ let fetch_allow_failure repo ~url obj =
         ~display:!Dune_engine.Clflags.display
         [ "fetch"; "--no-write-fetch-head"; url; Object.to_string obj ]
       >>| (function
-       | 128 -> `Not_found
-       | 0 ->
+       | Ok 128 -> `Not_found
+       | Ok 0 ->
          Table.set repo.present_objects obj ();
          `Fetched
+       | Error git_error -> Git_error.raise_code_error git_error
        | _ -> assert false))
 ;;
 
@@ -521,6 +553,7 @@ module At_rev = struct
     let config repo (Object.Sha1 rev) path : t Fiber.t =
       [ "config"; "--list"; "--blob"; sprintf "%s:%s" rev (Path.Local.to_string path) ]
       |> run_capture_lines repo ~display:Quiet
+      >>| Git_error.result_get_or_code_error
       >>| List.fold_left ~init:KV.Map.empty ~f:(fun acc line ->
         match parse line with
         | None ->
@@ -577,6 +610,7 @@ module At_rev = struct
 
   let files_and_submodules repo (Object.Sha1 rev) =
     run_capture_zero_separated_lines repo [ "ls-tree"; "-z"; "--long"; "-r"; rev ]
+    >>| Git_error.result_get_or_code_error
     >>| List.fold_left
           ~init:(File.Set.empty, Commit.Set.empty)
           ~f:(fun (files, commits) line ->
@@ -724,12 +758,31 @@ let remote =
                ]
            ])
   in
-  fun t ~url ->
+  fun t ~url:(url_loc, url) ->
     let f url =
       let command = [ "ls-remote"; url ] in
       let refs =
         Fiber_lazy.create (fun () ->
-          let+ hits = run_capture_lines t ~display:!Dune_engine.Clflags.display command in
+          let+ hits =
+            run_capture_lines t ~display:!Dune_engine.Clflags.display command
+            >>| function
+            | Ok lines -> lines
+            | Error git_error ->
+              (match git_error.exit_code with
+               | 128 ->
+                 User_error.raise
+                   ~loc:url_loc
+                   ~hints:
+                     [ Pp.textf
+                         "Check that this Git URL in the project configuration is \
+                          correct: %S"
+                         url
+                     ]
+                   [ Pp.text "Failed to run external command:"
+                   ; User_message.command (sprintf "git ls-remote %S" url)
+                   ]
+               | _ -> Git_error.raise_code_error git_error)
+          in
           let default_branch, branches_and_tags =
             List.fold_left
               hits

src/dune_pkg/rev_store.mli

@@ -46,7 +46,7 @@ module Remote : sig
   val default_branch : t -> Object.resolved option Fiber.t
 end
 
-val remote : t -> url:string -> Remote.t
+val remote : t -> url:Loc.t * string -> Remote.t
 val resolve_revision : t -> Remote.t -> revision:string -> Object.resolved option Fiber.t
 val content_of_files : t -> File.t list -> string list Fiber.t
 val load_or_create : dir:Path.t -> t Fiber.t

src/dune_pkg/source.ml

@@ -47,10 +47,10 @@ let to_dyn = function
 
 let fetch_and_hash_archive_cached =
   let cache = Single_run_file_cache.create () in
-  fun url ->
+  fun (url_loc, url) ->
     let open Fiber.O in
     Single_run_file_cache.with_ cache ~key:(OpamUrl.to_string url) ~f:(fun target ->
-      Fetch.fetch ~unpack:false ~checksum:None ~target url)
+      Fetch.fetch ~unpack:false ~checksum:None ~target ~url:(url_loc, url))
     >>| function
     | Ok target -> Some (Dune_digest.file target |> Checksum.of_dune_digest)
     | Error (Checksum_mismatch _) ->
@@ -94,7 +94,7 @@ let compute_missing_checksum_of_fetch
                (OpamUrl.to_string url)
            ; Pp.text "Dune will compute its own checksum for this source archive."
            ]);
-    fetch_and_hash_archive_cached url
+    fetch_and_hash_archive_cached (url_loc, url)
     >>| Option.map ~f:(fun checksum ->
       { url = url_loc, url; checksum = Some (Loc.none, checksum) })
     >>| Option.value ~default:fetch

src/dune_rules/fetch_rules.ml

@@ -43,7 +43,7 @@ let resolve_url =
     let open Fiber.O in
     let* rev_store = Rev_store.get in
     let+ git_object =
-      OpamUrl.resolve url rev_store
+      OpamUrl.resolve url ~loc:Loc.none rev_store
       >>| function
       | Ok (Resolved r) -> (r :> Rev_store.Object.t)
       | Ok (Unresolved r) -> r
@@ -107,7 +107,7 @@ module Spec = struct
           | `Directory -> true)
        ~checksum
        ~target:(Path.build target)
-       url)
+       ~url:(loc_url, url))
     >>= function
     | Ok () -> Fiber.return ()
     | Error (Checksum_mismatch actual_checksum) ->

test/blackbox-tests/test-cases/pkg/unavailable-package-source.t

@@ -14,21 +14,25 @@ Demonstrate what happens when we try to fetch from a source that doesn't exist:
   > }
 
 Local file system
-  $ runtest "(copy \"$PWD/dummy\")" 2>&1 | sed -ne '/Error: /,$ p'
+  $ runtest "(copy \"$PWD/dummy\")" 2>&1 | sed "s#$(pwd)#PWD#" | sed '/ *^\^*$/d' | sed '\#^File "dune.lock/foo.pkg", line 2, characters#d'
+  2 | (source (copy "PWD/dummy"))
   Error: Unable to read
-  $TESTCASE_ROOT/dummy
-  opendir($TESTCASE_ROOT/dummy): No such file or directory
+  PWD/dummy
+  opendir(PWD/dummy): No such file or directory
 
 Git
-  $ runtest "(fetch (url \"git+file://$PWD/dummy\"))" 2>&1 | awk '/fatal:/,/Description/'
-  fatal: '$TESTCASE_ROOT/dummy' does not appear to be a git repository
+  $ runtest "(fetch (url \"git+file://$PWD/dummy\"))" 2>&1 | sed "s#$(pwd)#PWD#"
+  fatal: 'PWD/dummy' does not appear to be a git repository
   fatal: Could not read from remote repository.
 
   Please make sure you have the correct access rights
   and the repository exists.
-  Internal error, please report upstream including the contents of _build/log.
-  Description:
-
+  Error: Failed to run external command:
+  'git ls-remote "file://PWD/dummy"'
+  -> required by _build/_private/default/.pkg/foo/source
+  -> required by _build/_private/default/.pkg/foo/target
+  Hint: Check that this Git URL in the project configuration is correct:
+  "file://PWD/dummy"
 
 Http
 A bit annoying that this test can pass by accident if there's a server running

test/expect-tests/dune_pkg/fetch_tests.ml

@@ -44,7 +44,7 @@ let serve_once ~filename =
 let download ?(reproducible = true) ~unpack ~port ~filename ~target ?checksum () =
   let open Fiber.O in
   let url = url ~port ~filename in
-  let* res = Fetch.fetch ~unpack ~checksum ~target url in
+  let* res = Fetch.fetch ~unpack ~checksum ~target ~url:(Loc.none, url) in
   match res with
   | Error (Unavailable None) ->
     let errs = [ Pp.text "Failure while downloading" ] in
@@ -209,7 +209,7 @@ let%expect_test "downloading, tarball with no checksum match" =
 
 let download_git rev_store url ~target =
   let open Fiber.O in
-  Fetch.fetch_git rev_store ~target url
+  Fetch.fetch_git rev_store ~target ~url:(Loc.none, url)
   >>| function
   | Error _ ->
     let errs = [ Pp.text "Failure while downloading" ] in
@@ -233,3 +233,32 @@ let%expect_test "downloading via git" =
     print_endline (Io.read_file entry));
   [%expect {| just some content |}]
 ;;
+
+let%expect_test "attempting to download an invalid git url" =
+  let source = subdir "source" in
+  let url = OpamUrl.parse "git+file://foo/bar" in
+  let rev_store_dir = subdir "rev-store-dir" in
+  let target = subdir "target" in
+  let entry = Path.relative target "e" in
+  run (fun () ->
+    let open Fiber.O in
+    let* rev_store = Dune_pkg.Rev_store.load_or_create ~dir:rev_store_dir in
+    let* (_commit : string) = Rev_store_tests.create_repo_at source in
+    let+ () = download_git rev_store url ~target in
+    print_endline (Io.read_file entry));
+  [%expect.unreachable]
+[@@expect.uncaught_exn
+  {|
+  (Dune_util__Report_error.Already_reported)
+  Trailing output
+  ---------------
+  fatal: '/bar' does not appear to be a git repository
+  fatal: Could not read from remote repository.
+
+  Please make sure you have the correct access rights
+  and the repository exists.
+  Error: Failed to run external command:
+  'git ls-remote "file://foo/bar"'
+  Hint: Check that this Git URL in the project configuration is correct:
+  "file://foo/bar" |}]
+;;