fix(pkg): correctly extract tarballs (#10122)

Previously, we'd extract sources as [source/$basename-of-tar]. We should
instead extract the sources into [source/] directly.

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

src/dune_pkg/fetch.ml

@@ -189,18 +189,9 @@ type failure =
 let label = "dune-fetch"
 
 let unpack ~target ~archive =
-  let* () = Fiber.return () in
-  Path.mkdir_p target;
-  let+ (), ret =
-    Process.run
-      ~display:Quiet
-      Return
-      (Lazy.force Tar.bin)
-      [ "xf"; Path.to_string archive; "-C"; Path.to_string target ]
-  in
-  match ret with
-  | 0 -> Ok ()
-  | _ -> Error (Pp.textf "unable to extract %S" (Path.to_string archive))
+  Tar.extract ~archive ~target
+  >>| Result.map_error ~f:(fun () ->
+    Pp.textf "unable to extract %S" (Path.to_string archive))
 ;;
 
 let with_download url checksum ~f =

src/dune_pkg/rev_store.ml

@@ -676,14 +676,13 @@ module At_rev = struct
   let check_out { repo = { dir; _ }; revision = Sha1 rev; files = _ } ~target =
     (* TODO iterate over submodules to output sources *)
     let git = Lazy.force Vcs.git in
-    let tar = Lazy.force Tar.bin in
     let temp_dir = Temp.create Dir ~prefix:"rev-store" ~suffix:rev in
     Fiber.finalize ~finally:(fun () ->
       let+ () = Fiber.return () in
       Temp.destroy Dir temp_dir)
     @@ fun () ->
-    let archive_file = Path.relative temp_dir "archive.tar" in
-    let stdout_to = Process.Io.file archive_file Process.Io.Out in
+    let archive = Path.relative temp_dir "archive.tar" in
+    let stdout_to = Process.Io.file archive Process.Io.Out in
     let stderr_to = make_stderr () in
     let* () =
       let args = [ "archive"; "--format=tar"; rev ] in
@@ -692,30 +691,15 @@ module At_rev = struct
       in
       if exit_code <> 0 then git_code_error ~dir ~args ~exit_code ~output:[]
     in
-    let stdout_to = make_stdout () in
-    let stderr_to = make_stderr () in
     (* We untar things into a temp dir to make sure we don't create garbage
        in the build dir until we know can produce the files *)
     let target_in_temp_dir = Path.relative temp_dir "dir" in
-    Path.mkdir_p target_in_temp_dir;
-    let args =
-      [ "xf"; Path.to_string archive_file; "-C"; Path.to_string target_in_temp_dir ]
-    in
-    let+ (), exit_code =
-      Process.run ~display:Quiet ~stdout_to ~stderr_to failure_mode tar args
-    in
-    if exit_code = 0
-    then (
+    Tar.extract ~archive ~target:target_in_temp_dir
+    >>| function
+    | Error () -> User_error.raise [ Pp.text "failed to untar archive created by git" ]
+    | Ok () ->
       Path.mkdir_p (Path.parent_exn target);
-      Path.rename target_in_temp_dir target)
-    else
-      Code_error.raise
-        "tar returned non-zero exit code"
-        [ "exit code", Dyn.int exit_code
-        ; "dir", Path.to_dyn target
-        ; "tar", Path.to_dyn tar
-        ; "args", Dyn.list Dyn.string args
-        ]
+      Path.rename target_in_temp_dir target
   ;;
 end
 

src/dune_pkg/tar.ml

@@ -1,8 +1,58 @@
 open Stdune
+module Process = Dune_engine.Process
+open Fiber.O
 
 let bin =
   lazy
     (match Bin.which ~path:(Env_path.path Env.initial) "tar" with
      | Some x -> x
      | None -> Dune_engine.Utils.program_not_found "tar" ~loc:None)
 ;;
+
+let output_limit = 1_000_000
+
+let temp_dir_in_build =
+  lazy
+    (let dir = Path.relative (Path.build Path.Build.root) ".temp" in
+     Path.mkdir_p dir;
+     dir)
+;;
+
+let extract ~archive ~target =
+  let* () = Fiber.return () in
+  let tar = Lazy.force bin in
+  let target_in_temp =
+    let prefix = Path.basename target in
+    let suffix = Path.basename archive in
+    match target with
+    | In_build_dir _ ->
+      Temp.temp_in_dir Dir ~dir:(Lazy.force temp_dir_in_build) ~prefix ~suffix
+    | _ -> Temp.create Dir ~prefix ~suffix
+  in
+  Fiber.finalize ~finally:(fun () ->
+    Temp.destroy Dir target_in_temp;
+    Fiber.return ())
+  @@ fun () ->
+  Path.mkdir_p target_in_temp;
+  let stdout_to = Process.Io.make_stdout ~output_on_success:Swallow ~output_limit in
+  let stderr_to = Process.Io.make_stderr ~output_on_success:Swallow ~output_limit in
+  let args = [ "xf"; Path.to_string archive; "-C"; Path.to_string target_in_temp ] in
+  let+ (), exit_code = Process.run ~display:Quiet ~stdout_to ~stderr_to Return tar args in
+  match exit_code = 0 with
+  | false -> Error ()
+  | true ->
+    let target_in_temp =
+      match Path.readdir_unsorted_with_kinds target_in_temp with
+      | Error e ->
+        User_error.raise
+          [ Pp.textf "failed to extract %s" (Path.to_string_maybe_quoted archive)
+          ; Pp.text "reason:"
+          ; Pp.text (Unix_error.Detailed.to_string_hum e)
+          ]
+      | Ok [ (fname, S_DIR) ] -> Path.relative target_in_temp fname
+      | Ok _ -> target_in_temp
+    in
+    Path.mkdir_p (Path.parent_exn target);
+    Path.rename target_in_temp target;
+    Ok ()
+;;

src/dune_pkg/tar.mli

@@ -1,3 +1,4 @@
 open Stdune
 
 val bin : Path.t Lazy.t
+val extract : archive:Path.t -> target:Path.t -> (unit, unit) result Fiber.t

test/blackbox-tests/test-cases/pkg/e2e.t

@@ -79,14 +79,6 @@ Lock, build, and run the executable in the project:
 # Temporary failure until 10080 is fixed
 
   $ dune exec bar
-  File "dune", line 3, characters 12-15:
-  3 |  (libraries foo))
-                  ^^^
-  Error: Library "foo" not found.
-  -> required by _build/default/.bar.eobjs/byte/dune__exe__Bar.cmi
-  -> required by _build/default/.bar.eobjs/native/dune__exe__Bar.cmx
-  -> required by _build/default/bar.exe
-  -> required by _build/install/default/bin/bar
-  [1]
+  Hello, World!
 
   $ wait

test/blackbox-tests/test-cases/pkg/tarball.t

@@ -37,7 +37,6 @@ twice in one test (even on different ports)
   ./foo
   $ runtest tarball2.tar.gz
   .
-  ./_source
-  ./_source/foo
+  ./foo
 
   $ wait

test/expect-tests/dune_pkg/dune

@@ -1,7 +1,7 @@
 (library
  (name dune_pkg_unit_tests)
  (inline_tests
-  (deps plaintext.md tarball.tar.gz %{bin:git}))
+  (deps tar-inputs/plaintext.md tarball.tar.gz %{bin:git}))
  (libraries
   dune_tests_common
   stdune
@@ -27,7 +27,8 @@
 
 (rule
  (target tarball.tar.gz)
- (deps plaintext.md)
+ (deps
+  (source_tree tar-inputs))
  (action
   (run tar -czf %{target} %{deps})))
 

test/expect-tests/dune_pkg/fetch_tests.ml

@@ -3,6 +3,7 @@ module Scheduler = Dune_engine.Scheduler
 module Checksum = Dune_pkg.Checksum
 module Fetch = Dune_pkg.Fetch
 
+let plaintext_md = "tar-inputs/plaintext.md"
 let () = Dune_tests_common.init ()
 
 let url ~port ~filename =
@@ -16,6 +17,8 @@ let wrong_checksum =
   OpamHash.compute_from_string "random content" |> Checksum.of_opam_hash
 ;;
 
+let archive = "tarball.tar.gz"
+
 let subdir destination =
   let ext = Path.External.of_filename_relative_to_initial_cwd destination in
   Path.external_ ext
@@ -78,14 +81,14 @@ let run thunk =
 ;;
 
 let%expect_test "downloading simple file" =
-  let filename = "plaintext.md" in
+  let filename = plaintext_md in
   let port, server = serve_once ~filename in
   let destination = "destination.md" in
   run
     (download
        ~unpack:false
        ~port
-       ~filename
+       ~filename:""
        ~target:(subdir destination)
        ~checksum:(calculate_checksum ~filename));
   Thread.join server;
@@ -117,14 +120,13 @@ let%expect_test "downloading simple file" =
 ;;
 
 let%expect_test "downloading but the checksums don't match" =
-  let filename = "plaintext.md" in
-  let port, server = serve_once ~filename in
+  let port, server = serve_once ~filename:plaintext_md in
   let destination = "destination.md" in
   run
     (download
        ~unpack:false
        ~port
-       ~filename
+       ~filename:""
        ~target:(subdir destination)
        ~checksum:wrong_checksum);
   Thread.join server;
@@ -142,10 +144,9 @@ let%expect_test "downloading but the checksums don't match" =
 ;;
 
 let%expect_test "downloading, without any checksum" =
-  let filename = "plaintext.md" in
-  let port, server = serve_once ~filename in
+  let port, server = serve_once ~filename:plaintext_md in
   let destination = "destination.md" in
-  run (download ~unpack:false ~port ~filename ~target:(subdir destination));
+  run (download ~unpack:false ~port ~filename:"" ~target:(subdir destination));
   Thread.join server;
   print_endline "Finished successfully, no checksum verification";
   [%expect {|
@@ -154,8 +155,7 @@ let%expect_test "downloading, without any checksum" =
 ;;
 
 let%expect_test "downloading, tarball" =
-  let filename = "tarball.tar.gz" in
-  let port, server = serve_once ~filename in
+  let port, server = serve_once ~filename:archive in
   let destination = "tarball" in
   run
     (download
@@ -165,7 +165,7 @@ let%expect_test "downloading, tarball" =
        ~unpack:true
        ~checksum:wrong_checksum
        ~port
-       ~filename
+       ~filename:""
        ~target:(subdir destination));
   Thread.join server;
   print_endline "Finished successfully, no checksum verification";
@@ -184,10 +184,9 @@ let%expect_test "downloading, tarball" =
 let%expect_test "downloading, tarball with no checksum match" =
   (* This test ensures that the contents of the extracted tarball are in the
      correct location. *)
-  let filename = "tarball.tar.gz" in
-  let port, server = serve_once ~filename in
+  let port, server = serve_once ~filename:archive in
   let target = subdir "tarball" in
-  run (download ~reproducible:false ~unpack:true ~port ~filename ~target);
+  run (download ~reproducible:false ~unpack:true ~port ~filename:"" ~target);
   Thread.join server;
   print_endline "Finished successfully, no checksum verification";
   (* print all the files in the target directory *)
@@ -203,7 +202,8 @@ let%expect_test "downloading, tarball with no checksum match" =
     Finished successfully, no checksum verification
     ------
     files in target dir:
-    plaintext.md |}]
+    plaintext.md
+    file2.md |}]
 ;;
 
 let download_git rev_store url ~target =