pkg: rewrite archive extraction with typed tar capabilities

We rewrite the extraction capabilities for package management, enforcing
the invariants we wish to preserve at the type level. The aim is to
separate the concerns of finding an appropriate archive binary, checking
the capabilities of this binary, creating arguments for this binary and
invoking this for extraction.

The public API of extraction is still simple, so the typed invariants
are more of an internal impelementation detail.

A sumamry of the changes are as follows:

- Use GADTs to encode which formats each tar implementation supports,
  preventing invalid combinations at compile time
- Detect tar implementation (BSD/GNU/Other) via --version output
- Prefer BSD tar over unzip for zip extraction
- Check bsdtar before tar to get more capable implementation
- Add gtar to binary list for GNU tar on macOS/BSD
- Pass explicit -z/-j flags for OpenBSD/busybox tar

Signed-off-by: Ali Caglayan <[email protected]>

Author: Alizter

src/dune_pkg/archive.ml

@@ -0,0 +1,362 @@
+open Stdune
+module Process = Dune_engine.Process
+open Fiber.O
+
+(** {1 Archive Extraction}
+
+    This module handles extraction of .tar, .tar.gz, .tar.bz2, and .zip archives
+    using system tools (tar, bsdtar, unzip). The main complexity comes from
+    supporting different tar implementations with varying capabilities:
+
+    - BSD tar (libarchive): Auto-detects compression, supports zip extraction
+    - GNU tar: Auto-detects compression, no zip support
+    - Other (OpenBSD, busybox): Requires explicit -z/-j flags, no zip support
+
+    We use GADTs with polymorphic variants to encode these capabilities at the
+    type level. [Tar.t] has a type parameter indicating which formats it supports,
+    and [Tar.args] can only be called with formats valid for that tar. This
+    prevents invalid combinations (like extracting zip with GNU tar) at compile
+    time rather than runtime.
+
+    For zip extraction, we prefer BSD tar when available, falling back to the
+    [unzip] binary if BSD tar is not found. *)
+
+module Format : sig
+  (** Supported archive formats:
+      - [`Tar]: uncompressed tar (.tar)
+      - [`Tar_gz]: gzip-compressed tar (.tar.gz, .tgz)
+      - [`Tar_bz2]: bzip2-compressed tar (.tar.bz2, .tbz)
+      - [`Zip]: zip archive (.zip) *)
+  type t =
+    [ `Tar
+    | `Tar_gz
+    | `Tar_bz2
+    | `Zip
+    ]
+
+  (** Detect archive format from filename extension. Returns the format and
+      the matched extension. *)
+  val of_filename : Filename.t -> (t * string) option
+end = struct
+  type t =
+    [ `Tar
+    | `Tar_gz
+    | `Tar_bz2
+    | `Zip
+    ]
+
+  let of_filename =
+    let extensions =
+      [ ".tar", `Tar
+      ; ".tar.gz", `Tar_gz
+      ; ".tgz", `Tar_gz
+      ; ".tar.bz2", `Tar_bz2
+      ; ".tbz", `Tar_bz2
+      ; ".zip", `Zip
+      ]
+    in
+    fun filename ->
+      let check_suffix suffix = Filename.check_suffix filename suffix in
+      List.find_map extensions ~f:(fun (ext, format) ->
+        Option.some_if (check_suffix ext) (format, ext))
+  ;;
+end
+
+let is_supported filename = Option.is_some (Format.of_filename filename)
+let which bin_name = Bin.which ~path:(Env_path.path Env.initial) bin_name
+
+module Error = struct
+  type t =
+    | No_extractor of
+        { ext : string
+        ; tried : string list
+        }
+    | Command_failed of
+        { bin : Path.t
+        ; archive : Path.t
+        ; exit_code : int
+        ; stderr : string list
+        }
+    | Read_dir_failed of
+        { archive : Path.t
+        ; error : Unix_error.Detailed.t
+        }
+
+  let message = function
+    | No_extractor { ext; tried } ->
+      [ Pp.textf "No program found to extract %s files. Tried:" ext
+      ; Pp.enumerate tried ~f:Pp.verbatim
+      ]
+    | Command_failed { bin; archive; exit_code; stderr } ->
+      [ Pp.textf "Failed to extract '%s':" (Path.basename archive)
+      ; Pp.hovbox
+          (Pp.concat
+             ~sep:Pp.space
+             [ User_message.command (Path.basename bin)
+             ; Pp.textf "failed with non-zero exit code '%d' and output:" exit_code
+             ])
+      ; Pp.vbox (Pp.concat_map ~sep:Pp.cut ~f:Pp.paragraph stderr)
+      ]
+    | Read_dir_failed { archive; error } ->
+      [ Pp.textf "Failed to extract '%s':" (Path.to_string_maybe_quoted archive)
+      ; Pp.text (Unix_error.Detailed.to_string_hum error)
+      ]
+  ;;
+
+  let raise t = User_error.raise (message t)
+end
+
+module Tar : sig
+  (** Tar executable for current system. The type parameter encodes which
+      formats this tar supports - pattern match on [found] to get the right
+      type.
+
+ {v
+ | Kind  | Implementations          | Detects compression | Zip support |
+ |-------|--------------------------|---------------------|-------------|
+ | Bsd   | bsdtar, libarchive       | yes                 | yes         |
+ |       | (macOS, FreeBSD, Win10+) |                     |             |
+ |       |                          |                     |             |
+ | Gnu   | GNU tar (most Linux)     | yes                 | no          |
+ |       |                          |                     |             |
+ | Other | OpenBSD tar, busybox tar | no                  | no          |
+ v}
+
+      [Other] is the fallback for unknown implementations. We use explicit
+      [-z]/[-j] flags which is the safest approach. *)
+  type 'fmt t
+
+  (** Archive formats supported by BSD tar. *)
+  type bsd =
+    [ `Tar
+    | `Tar_gz
+    | `Tar_bz2
+    | `Zip
+    ]
+
+  (** Result of finding tar. Pattern match to get the appropriately typed tar. *)
+  type found =
+    | Bsd of bsd t
+    | Gnu of [ `Tar | `Tar_gz | `Tar_bz2 ] t
+    | Other of [ `Tar | `Tar_gz | `Tar_bz2 ] t
+
+  (** Attempt to find tar executable for current system. *)
+  val find : found option Fiber.Lazy.t
+
+  (** Names of binaries checked when attempting to find tar executable. *)
+  val bin_names : string list
+
+  (** Path to tar executable. *)
+  val path : 'a t -> Path.t
+
+  (** [args t format ~archive ~target] provides the arguments for extraction.
+      The [format] must be in the set of formats supported by [t]. *)
+  val args : 'fmt t -> format:'fmt -> archive:Path.t -> target:Path.t -> string list
+end = struct
+  type _ kind =
+    | K_bsd : [ `Tar | `Tar_gz | `Tar_bz2 | `Zip ] kind
+    | K_gnu : [ `Tar | `Tar_gz | `Tar_bz2 ] kind
+    | K_other : [ `Tar | `Tar_gz | `Tar_bz2 ] kind
+
+  type 'fmt t =
+    { path : Path.t
+    ; kind : 'fmt kind
+    }
+
+  type bsd =
+    [ `Tar
+    | `Tar_gz
+    | `Tar_bz2
+    | `Zip
+    ]
+
+  type found =
+    | Bsd of bsd t
+    | Gnu of [ `Tar | `Tar_gz | `Tar_bz2 ] t
+    | Other of [ `Tar | `Tar_gz | `Tar_bz2 ] t
+
+  (** The order of binaries we should try from most capable to least + Windows. *)
+  let bin_names = [ "bsdtar"; "tar"; "gtar"; "tar.exe" ]
+
+  let find =
+    Fiber.Lazy.create (fun () ->
+      match List.find_map bin_names ~f:which with
+      | None -> Fiber.return None
+      | Some path ->
+        let+ output, _ = Process.run_capture ~display:Quiet Return path [ "--version" ] in
+        let matches s = Re.execp (Re.compile (Re.str s)) output in
+        Some
+          (if matches "bsdtar" || matches "libarchive"
+           then Bsd { path; kind = K_bsd }
+           else if matches "GNU tar"
+           then Gnu { path; kind = K_gnu }
+           else Other { path; kind = K_other }))
+  ;;
+
+  let path t = t.path
+
+  let args (type fmt) (t : fmt t) ~(format : fmt) ~archive ~target =
+    let decompress_flag =
+      match t.kind, format with
+      | K_bsd, (`Tar | `Tar_gz | `Tar_bz2 | `Zip) -> []
+      | K_gnu, (`Tar | `Tar_gz | `Tar_bz2) -> []
+      | K_other, `Tar -> []
+      | K_other, `Tar_gz -> [ "-z" ]
+      | K_other, `Tar_bz2 -> [ "-j" ]
+    in
+    [ "-x" ]
+    @ decompress_flag
+    @ [ "-f"; Path.to_string archive; "-C"; Path.to_string target ]
+  ;;
+end
+
+module Unzip : sig
+  (** A binary that can extract zip files. *)
+  type t
+
+  (** Find a binary that can extract zip files. *)
+  val find : t option Fiber.Lazy.t
+
+  (** Names of binaries checked when attempting to find binary that can extract
+      zip files. *)
+  val bin_names : string list
+
+  (** Path to binary that can extract zip files. *)
+  val path : t -> Path.t
+
+  (** Arguments given to binary that can extract zip files. *)
+  val args : t -> archive:Path.t -> target:Path.t -> string list
+end = struct
+  type t =
+    | Unzip of Path.t
+    | Tar of Tar.bsd Tar.t
+
+  let bin_names = Tar.bin_names @ [ "unzip" ]
+
+  let find =
+    (* We first check if we have a tar binary capable of unzipping, if not we
+       fallback to unzip. *)
+    Fiber.Lazy.create (fun () ->
+      Fiber.Lazy.force Tar.find
+      >>| function
+      | Some (Bsd tar) -> Some (Tar tar)
+      | Some (Gnu _ | Other _) | None ->
+        (match which "unzip" with
+         | Some path -> Some (Unzip path)
+         | None -> None))
+  ;;
+
+  let path = function
+    | Unzip path -> path
+    | Tar tar -> Tar.path tar
+  ;;
+
+  let args t ~archive ~target =
+    match t with
+    | Unzip _ -> [ Path.to_string archive; "-d"; Path.to_string target ]
+    | Tar tar -> Tar.args tar ~format:`Zip ~archive ~target
+  ;;
+end
+
+module Extractor : sig
+  (** [Extractor.run ~archive ~target] extracts the given [archive] using an
+      appropriate tool to do so. *)
+  val run : archive:Path.t -> target:Path.t -> (unit, Error.t) result Fiber.t
+end = struct
+  let no_extractor_error ~ext ~bin_names =
+    Fiber.return @@ Error (Error.No_extractor { ext; tried = bin_names })
+  ;;
+
+  let run_cmd ~bin ~args ~archive =
+    let temp_stderr = Temp.create File ~prefix:"extract" ~suffix:"stderr" in
+    Fiber.finalize ~finally:(fun () ->
+      Temp.destroy File temp_stderr;
+      Fiber.return ())
+    @@ fun () ->
+    let+ (), exit_code =
+      Process.run
+        ~display:Quiet
+        ~stdout_to:
+          (Process.Io.make_stdout ~output_on_success:Swallow ~output_limit:1_000_000)
+        ~stderr_to:(Process.Io.file temp_stderr Out)
+        Return
+        bin
+        args
+    in
+    if exit_code <> 0
+    then
+      Io.with_file_in temp_stderr ~f:(fun err_channel ->
+        let stderr = Io.input_lines err_channel in
+        Error (Error.Command_failed { bin; archive; exit_code; stderr }))
+    else Ok ()
+  ;;
+
+  let run ~archive ~target =
+    let format, ext =
+      Format.of_filename (Path.to_string archive) |> Option.value ~default:(`Tar, ".tar")
+    in
+    match (format : Format.t) with
+    | `Zip ->
+      Fiber.Lazy.force Unzip.find
+      >>= (function
+       | Some unzip ->
+         let bin = Unzip.path unzip in
+         let args = Unzip.args unzip ~archive ~target in
+         run_cmd ~bin ~args ~archive
+       | None -> no_extractor_error ~ext ~bin_names:Unzip.bin_names)
+    | (`Tar | `Tar_gz | `Tar_bz2) as format ->
+      Fiber.Lazy.force Tar.find
+      >>= (function
+       | Some (Bsd tar) ->
+         let bin = Tar.path tar in
+         let args = Tar.args tar ~format ~archive ~target in
+         run_cmd ~bin ~args ~archive
+       | Some (Gnu tar | Other tar) ->
+         let bin = Tar.path tar in
+         let args = Tar.args tar ~format ~archive ~target in
+         run_cmd ~bin ~args ~archive
+       | None -> no_extractor_error ~ext ~bin_names:Tar.bin_names)
+  ;;
+end
+
+(** Make extraction atomic by extracting to a temp directory and renaming. *)
+let extract ~archive ~target =
+  let target_in_temp =
+    let prefix = Path.basename target in
+    let suffix = Path.basename archive in
+    Temp_dir.dir_for_target ~target ~prefix ~suffix
+  in
+  Fiber.finalize ~finally:(fun () ->
+    Temp.destroy Dir target_in_temp;
+    Fiber.return ())
+  @@ fun () ->
+  Path.mkdir_p target_in_temp;
+  Extractor.run ~archive ~target:target_in_temp
+  >>| function
+  | Error _ as e -> e
+  | Ok () ->
+    (* Opam expects only one top-level directory and then strips it. We employ a
+       similar heuristic here. Opam is stricter in the multiple top-level entries
+       case since it errors, whereas we use the extraction directory as-is. *)
+    let target_in_temp =
+      match Path.readdir_unsorted_with_kinds target_in_temp with
+      | Error error -> Error (Error.Read_dir_failed { archive; error })
+      | Ok [ (fname, S_DIR) ] -> Ok (Path.relative target_in_temp fname)
+      | Ok _ -> Ok target_in_temp
+    in
+    (match target_in_temp with
+     | Error _ as e -> e
+     | Ok target_in_temp ->
+       (* CR-soon Alizter: this might already exist, don't do pointeless work *)
+       Path.mkdir_p (Path.parent_exn target);
+       (* CR-someday Alizter: Add fallback to copy if EXDEV raised here *)
+       Path.rename target_in_temp target;
+       Ok ())
+;;
+
+let extract_exn ~archive ~target =
+  extract ~archive ~target
+  >>| function
+  | Ok () -> ()
+  | Error e -> Error.raise e
+;;

src/dune_pkg/archive.mli

@@ -0,0 +1,35 @@
+open Stdune
+
+(** Returns [true] if the filename has a supported archive extension
+    (.tar, .tar.gz, .tgz, .tar.bz2, .tbz, .zip). *)
+val is_supported : Filename.t -> bool
+
+module Error : sig
+  type t = private
+    | No_extractor of
+        { ext : string
+        ; tried : string list
+        }
+    | Command_failed of
+        { bin : Path.t
+        ; archive : Path.t
+        ; exit_code : int
+        ; stderr : string list
+        }
+    | Read_dir_failed of
+        { archive : Path.t
+        ; error : Unix_error.Detailed.t
+        }
+
+  val message : t -> User_message.Style.t Pp.t list
+  val raise : t -> 'a
+end
+
+(** [extract ~archive ~target] extracts the archive at [archive] into the
+    directory at [target], creating the directory if it doesn't already exist.
+    The archive format is determined from the file extension. If the extension
+    is not recognized, defaults to tar. *)
+val extract : archive:Path.t -> target:Path.t -> (unit, Error.t) result Fiber.t
+
+(** Same as [extract] but raises [User_error] on failure. *)
+val extract_exn : archive:Path.t -> target:Path.t -> unit Fiber.t