fix: support package pinning via http+tar (ocaml#11446)

This is a non-optimal version of HTTP+Tar. It will download the files multiple time. Optimizations will be done later based on this version.

Signed-off-by: Etienne Marais <[email protected]>
Co-authored-by: ArthurW <[email protected]>
Co-authored-by: Marek Kubica <[email protected]>

Author: 3 people

bin/pkg/pkg_common.ml

@@ -88,9 +88,15 @@ let get_repos repos ~repositories =
     | Some repo ->
       let loc, opam_url = Repository.opam_url repo in
       let module Opam_repo = Dune_pkg.Opam_repo in
-      (match Dune_pkg.OpamUrl.local_or_git_only opam_url loc with
+      (match Dune_pkg.OpamUrl.local_or_git_or_tar_only opam_url loc with
        | `Git -> Opam_repo.of_git_repo loc opam_url
-       | `Path path -> Fiber.return @@ Opam_repo.of_opam_repo_dir_path loc path))
+       | `Path path -> Fiber.return @@ Opam_repo.of_opam_repo_dir_path loc path
+       | `Tar ->
+         User_error.raise
+           ~loc
+           [ Pp.textf "Repositories stored in archives (%s) are currently unsupported"
+             @@ OpamUrl.to_string opam_url
+           ]))
 ;;
 
 let find_local_packages =

src/dune_pkg/fetch.ml

@@ -201,9 +201,10 @@ let fetch_local ~checksum ~target (url, url_loc) =
   if not (OpamUrl.is_local url)
   then Code_error.raise "fetch_local: url should be file://" [ "url", OpamUrl.to_dyn url ];
   let path =
-    match OpamUrl.local_or_git_only url url_loc with
+    match OpamUrl.local_or_git_or_tar_only url url_loc with
     | `Path p -> p
-    | `Git -> Code_error.raise "fetch_local: not a path" [ "url", OpamUrl.to_dyn url ]
+    | `Git | `Tar ->
+      Code_error.raise "fetch_local: not a path" [ "url", OpamUrl.to_dyn url ]
   in
   match check_checksum checksum path with
   | Error _ as e -> Fiber.return e

src/dune_pkg/mount.ml

@@ -11,7 +11,7 @@ let backend t = t
 
 let of_opam_url loc url =
   let* () = Fiber.return () in
-  match OpamUrl.local_or_git_only url loc with
+  match OpamUrl.local_or_git_or_tar_only url loc with
   | `Path dir -> Fiber.return (Path dir)
   | `Git ->
     let+ rev =
@@ -23,6 +23,40 @@ let of_opam_url loc url =
       >>| User_error.ok_exn
     in
     Git rev
+  | `Tar ->
+    (* To prevent cache dir from growing too much, `/tmp/` stores the archive
+       when running `dune pkg lock`. We download and extract the archive
+       everytime the command runs.
+       CR-someday maiste: downloading and extracting should be cached to be
+       reused by the `dune build` command. *)
+    let dir = Temp.(create Dir ~prefix:"dune" ~suffix:"fetch-pinning") in
+    Source.fetch_archive_cached (loc, url)
+    >>= (function
+     | Error message_opt ->
+       let message =
+         Option.value
+           ~default:
+             (User_message.make
+                [ Pp.textf
+                    "Failed to retrieve source archive from: %s"
+                    (OpamUrl.to_string url)
+                ])
+           message_opt
+       in
+       raise (User_error.E message)
+     | Ok archive ->
+       let target =
+         let file_digest = Path.to_string archive |> Digest.file |> Digest.to_hex in
+         Path.relative dir file_digest
+       in
+       let+ path =
+         Tar.extract ~archive ~target
+         >>| function
+         | Error () ->
+           User_error.raise [ Pp.textf "unable to extract %S" (Path.to_string target) ]
+         | Ok () -> target
+       in
+       Path path)
 ;;
 
 let read t file =

src/dune_pkg/opamUrl0.ml

@@ -30,10 +30,18 @@ let is_version_control t =
 
 let is_local t = String.equal t.transport "file"
 
-let local_or_git_only url loc =
+let is_tarball t =
+  let supported_compress_format = [ ".tar"; ".tar.gz"; ".tgz"; ".tar.bz2"; ".tbz" ] in
+  List.exists
+    ~f:(fun suffix -> Filename.check_suffix t.path suffix)
+    supported_compress_format
+;;
+
+let local_or_git_or_tar_only url loc =
   match (url : t).backend with
   | `rsync when is_local url -> `Path (Path.of_string url.path)
   | `git -> `Git
+  | `http when is_tarball url -> `Tar
   | `rsync | `http | `darcs | `hg ->
     User_error.raise
       ~loc

src/dune_pkg/opamUrl0.mli

@@ -15,10 +15,11 @@ val is_version_control : t -> bool
 (** [is_file t] is true iff [t] is a url beginning with "file://" *)
 val is_local : t -> bool
 
-(* [local_or_git_only t loc] returns [`Path p] for a URL pointing to a local
-   file system or [`Git] if it's a git repository (remote or otherwise). If
-   it's neither of those cases, it will error out. *)
-val local_or_git_only : t -> Loc.t -> [ `Path of Path.t | `Git ]
+(* [local_or_git_or_tar_only t loc] returns [`Path p] for a URL pointing to a
+   local file system or [`Git] if it's a git repository (remote or otherwise)
+   or [`Tar] if it's an http server with a tar resource. If it's neither of
+   those cases, it will error out. *)
+val local_or_git_or_tar_only : t -> Loc.t -> [ `Path of Path.t | `Git | `Tar ]
 
 module Map : Map.S with type key = t
 module Set : Set.S with type elt = t and type 'a map = 'a Map.t

src/dune_pkg/opam_solver.ml

@@ -135,8 +135,8 @@ module Context = struct
          let packages pkg (formula : OpamTypes.formula) =
            OpamFormula.iter
              (fun (name, _) ->
-               let name = Package_name.of_opam_package_name name in
-               Table.Multi.cons acc name pkg)
+                let name = Package_name.of_opam_package_name name in
+                Table.Multi.cons acc name pkg)
              formula
          in
          Lazy.force local_packages

src/dune_pkg/source.ml

@@ -31,27 +31,31 @@ let to_dyn { url = _loc, url; checksum } =
     ]
 ;;
 
-let fetch_and_hash_archive_cached =
+let fetch_archive_cached =
   let cache = Single_run_file_cache.create () in
   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_without_checksum ~unpack:false ~target ~url:(url_loc, url))
-    >>| function
-    | Ok target -> Some (Dune_digest.file target |> Checksum.of_dune_digest)
-    | Error message_opt ->
-      let message =
-        match message_opt with
-        | Some message -> message
-        | None ->
-          User_message.make
-            [ Pp.textf
-                "Failed to retrieve source archive from: %s"
-                (OpamUrl.to_string url)
-            ]
-      in
-      User_warning.emit_message message;
-      None
+;;
+
+let fetch_and_hash_archive_cached (url_loc, url) =
+  let open Fiber.O in
+  fetch_archive_cached (url_loc, url)
+  >>| function
+  | Ok target -> Some (Dune_digest.file target |> Checksum.of_dune_digest)
+  | Error message_opt ->
+    let message =
+      Option.value
+        ~default:
+          (User_message.make
+             [ Pp.textf
+                 "Failed to retrieve source archive from: %s"
+                 (OpamUrl.to_string url)
+             ])
+        message_opt
+    in
+    User_warning.emit_message message;
+    None
 ;;
 
 let compute_missing_checksum

src/dune_pkg/source.mli

@@ -13,3 +13,9 @@ val remove_locs : t -> t
 val compute_missing_checksum : t -> Package_name.t -> pinned:bool -> t Fiber.t
 val external_copy : Loc.t * Path.External.t -> t
 val kind : t -> [ `Directory_or_archive of Path.External.t | `Fetch ]
+
+(** [fetch_archive_cached (loc, url)] downloads and extract a source relying on
+    caching to reduce network calls. *)
+val fetch_archive_cached
+  :  Loc.t * OpamUrl.t
+  -> (Import.Path.t, Import.User_message.t option) result Fiber.t

test/blackbox-tests/test-cases/pkg/dune

@@ -46,6 +46,7 @@
   ocamlformat-dev-tool
   source-caching
   tarball
+  pin-depends
   extra-sources))
 
 (cram
@@ -58,7 +59,7 @@
 
 (cram
  (deps %{bin:tar})
- (applies_to source-caching tarball extra-sources))
+ (applies_to source-caching tarball pin-depends extra-sources))
 
 (cram
  (deps %{bin:ocaml_index})

test/blackbox-tests/test-cases/pkg/pin-depends.t

@@ -175,10 +175,47 @@ Pin to an invalid opam file
   unsupported or missing file format version; should be 2.0 or older
   [1]
 
-Pin to an HTTP archive doesn't work
+Pin to an HTTP archive work
+
+  $ mkdir _source/
+  $ cat > _source/bar.opam << EOF
+  > opam-version: "2.0"
+  > EOF
+  $ tar cf tarball.tar -C _source bar.opam
+  $ MD5_CHECKSUM=$(md5sum tarball.tar  | cut -f1 -d' ')
+  $ echo tarball.tar > fake-curls
+  $ PORT=1
+  $ runtest "http://0.0.0.0:$PORT/tarball.tar" > output
+  Solution for dune.lock:
+  - bar.1.0.0
+  $ grep "md5=$MD5_CHECKSUM" output 2>&1 > /dev/null && echo "Checksum matches"
+  Checksum matches
+
+Pin to an HTTP archive detects wrong hash
+
+  $ cat << EOF > dune
+  > (library
+  >  (name foo)
+  >  (libraries bar))
+  > EOF
+  $ sed -i.tmp "s/$MD5_CHECKSUM/92449184682b45b5f07e811fdd61d35f/g" dune.lock/bar.pkg
+  $ rm -rf already-served
+  $ dune build 2>&1 | grep -v "md5"
+  File "dune.lock/bar.pkg", line 6, characters 12-48:
+                  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+  Error: Invalid checksum, got
+
+Pin to an HTTP archive needs `dune pkg lock` to download and compute the hash
+of the target again
+
+  $ rm tarball.tar already-served
+  $ echo "update checksum" > _source/random_file
+  $ tar cf tarball.tar -C _source bar.opam random_file
+  $ MD5_CHECKSUM=$(md5sum tarball.tar  | cut -f1 -d' ')
+  $ echo tarball.tar > fake-curls
+  $ runtest "http://0.0.0.0:$PORT/tarball.tar" > output
+  Solution for dune.lock:
+  - bar.1.0.0
+  $ grep "md5=$MD5_CHECKSUM" output 2>&1 > /dev/null && echo "Checksum matches"
+  Checksum matches
 
-  $ runtest "http://0.0.0.0/tarball.tgz"
-  File "foo.opam", line 1, characters 0-0:
-  Error: Could not determine location of repository http://0.0.0.0/tarball.tgz
-  Hint: Specify either a file path or git repo via SSH/HTTPS
-  [1]