Source file opam_repomin.ml

(* Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>

   Permission to use, copy, modify, and/or distribute this software for any
   purpose with or without fee is hereby granted, provided that the above
   copyright notice and this permission notice appear in all copies.

   THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
   WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
   MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
   SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
   WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION
   OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
   CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *)

module Env = struct
  type t = string -> OpamVariable.variable_contents option

  let extend_env ~os base_env var =
    match var with
    | "sys-ocaml-libc" ->
        (* Default to glibc for Linux, none for other platforms *)
        if os = "linux" then Some (OpamVariable.S "glibc") else None
    | _ -> base_env var

  let create ~arch ~os ~os_distribution ~os_family ~os_version () =
    let base_env =
      Opam_0install.Dir_context.std_env ~arch ~os ~os_distribution ~os_family
        ~os_version ()
    in
    extend_env ~os base_env

  let default () =
    create ~arch:"x86_64" ~os:"linux" ~os_distribution:"debian"
      ~os_family:"debian" ~os_version:"" ()
end

module Repo = struct
  type t = { packages_dir : Fpath.t }

  let load path =
    let packages_dir = Fpath.(path / "packages") in
    match Bos.OS.Dir.exists packages_dir with
    | Ok true -> Ok { packages_dir }
    | Ok false ->
        Error (`Msg (Fmt.str "Not a valid opam repository: %a" Fpath.pp path))
    | Error e -> Error e

  let packages_dir t = t.packages_dir

  let list_dirs path ~f =
    Bos.OS.Dir.contents path |> Result.value ~default:[] |> List.filter_map f

  let list_packages t =
    list_dirs t.packages_dir ~f:(fun d ->
        if Fpath.is_dir_path d || Sys.is_directory (Fpath.to_string d) then
          Some (OpamPackage.Name.of_string (Fpath.basename d))
        else None)

  let list_versions t name =
    let pkg_dir = Fpath.(t.packages_dir / OpamPackage.Name.to_string name) in
    list_dirs pkg_dir ~f:(fun d ->
        let base = Fpath.basename d in
        match OpamPackage.of_string_opt base with
        | Some pkg when OpamPackage.name pkg = name ->
            Some (OpamPackage.version pkg)
        | _ -> None)

  let has_package t pkg =
    let pkg_dir =
      Fpath.(
        t.packages_dir
        / OpamPackage.name_to_string pkg
        / OpamPackage.to_string pkg)
    in
    Bos.OS.Dir.exists pkg_dir |> Result.value ~default:false

  let opam_file t pkg =
    let opam_path =
      Fpath.(
        t.packages_dir
        / OpamPackage.name_to_string pkg
        / OpamPackage.to_string pkg / "opam")
    in
    if Bos.OS.File.exists opam_path |> Result.value ~default:false then
      let opam_file = OpamFilename.of_string (Fpath.to_string opam_path) in
      Some (OpamFile.OPAM.read (OpamFile.make opam_file))
    else None
end

module Solver = struct
  type solution = { packages : OpamPackage.t list }

  module Dir_context = Opam_0install.Dir_context
  module Solver_impl = Opam_0install.Solver.Make (Dir_context)

  let solve ~env ~overlay ~full ~compiler =
    (* Get all package names from the overlay *)
    let overlay_packages = Repo.list_packages overlay in
    Logs.info (fun m ->
        m "Found %d packages in overlay" (List.length overlay_packages));
    if overlay_packages = [] then
      Error (`Msg "No packages found in overlay repository")
    else
      (* Create constraints: pin the compiler *)
      let compiler_name = OpamPackage.name compiler in
      let compiler_version = OpamPackage.version compiler in
      let constraints =
        OpamPackage.Name.Map.singleton compiler_name (`Eq, compiler_version)
      in
      (* Use the full repository's packages directory as the context,
         but we need to handle overlay precedence through pins *)
      let pins =
        overlay_packages
        |> List.filter_map (fun name ->
            match Repo.list_versions overlay name with
            | [] -> None
            | versions -> (
                (* Pin to the newest version in overlay *)
                let sorted =
                  List.sort
                    (fun a b -> OpamPackage.Version.compare b a)
                    versions
                in
                let version = List.hd sorted in
                let pkg = OpamPackage.create name version in
                match Repo.opam_file overlay pkg with
                | Some opam -> Some (name, (version, opam))
                | None -> None))
        |> OpamPackage.Name.Map.of_list
      in
      let full_packages_dir = Fpath.to_string (Repo.packages_dir full) in
      let context =
        Dir_context.create ~constraints ~env ~pins full_packages_dir
      in
      (* Solve for all overlay packages plus the compiler *)
      let to_solve = compiler_name :: overlay_packages in
      Logs.info (fun m -> m "Solving for %d packages" (List.length to_solve));
      match Solver_impl.solve context to_solve with
      | Ok selections ->
          let packages = Solver_impl.packages_of_result selections in
          Logs.info (fun m ->
              m "Solution found with %d packages" (List.length packages));
          Ok { packages }
      | Error problem ->
          let msg = Solver_impl.diagnostics problem in
          Error (`Msg (Fmt.str "Solver failed: %s" msg))

  let packages t = t.packages

  let packages_from_full t ~overlay =
    List.filter (fun pkg -> not (Repo.has_package overlay pkg)) t.packages

  let packages_from_overlay t ~overlay =
    List.filter (fun pkg -> Repo.has_package overlay pkg) t.packages
end

module Output = struct
  type copy_result = {
    copied : OpamPackage.t list;
    skipped : OpamPackage.t list;
  }

  let dry_run ~src ~packages =
    List.filter (fun pkg -> Repo.has_package src pkg) packages

  let ( let* ) = Result.bind

  let copy ~src ~dst ~packages =
    let dst_packages = Fpath.(dst / "packages") in
    (* Ensure destination packages directory exists *)
    let* _ = Bos.OS.Dir.create ~path:true dst_packages in
    let copied = ref [] in
    let skipped = ref [] in
    let copy_one pkg =
      let name = OpamPackage.name_to_string pkg in
      let full_name = OpamPackage.to_string pkg in
      let src_dir = Fpath.(Repo.packages_dir src / name / full_name) in
      let dst_name_dir = Fpath.(dst_packages / name) in
      let dst_dir = Fpath.(dst_name_dir / full_name) in
      (* Check if already exists in destination *)
      if Bos.OS.Dir.exists dst_dir |> Result.value ~default:false then (
        skipped := pkg :: !skipped;
        Ok ())
      else
        let* _ = Bos.OS.Dir.create ~path:true dst_name_dir in
        let* () =
          Bos.(
            OS.Cmd.run
              Cmd.(
                v "cp" % "-r" % Fpath.to_string src_dir
                % Fpath.to_string dst_dir))
        in
        copied := pkg :: !copied;
        Ok ()
    in
    let rec copy_all = function
      | [] -> Ok { copied = List.rev !copied; skipped = List.rev !skipped }
      | pkg :: rest ->
          let* () = copy_one pkg in
          copy_all rest
    in
    (* Only copy packages that exist in src *)
    let to_copy = List.filter (fun pkg -> Repo.has_package src pkg) packages in
    copy_all to_copy
end

let ( let* ) = Result.bind

let run ~env ~overlay ~full ~compiler ~output ~dry_run:is_dry_run =
  Logs.info (fun m -> m "Loading overlay repository: %a" Fpath.pp overlay);
  let* overlay_repo = Repo.load overlay in
  Logs.info (fun m -> m "Loading full repository: %a" Fpath.pp full);
  let* full_repo = Repo.load full in
  Logs.info (fun m ->
      m "Solving with compiler: %a"
        Fmt.(using OpamPackage.to_string string)
        compiler);
  let* solution =
    Solver.solve ~env ~overlay:overlay_repo ~full:full_repo ~compiler
  in
  let from_full = Solver.packages_from_full solution ~overlay:overlay_repo in
  let from_overlay =
    Solver.packages_from_overlay solution ~overlay:overlay_repo
  in
  Logs.info (fun m ->
      m "Need to copy %d packages from full repository, %d from overlay"
        (List.length from_full) (List.length from_overlay));
  if is_dry_run then (
    Fmt.pr "@[<v>Packages to copy from full repository:@,";
    List.iter (fun pkg -> Fmt.pr "  %s@," (OpamPackage.to_string pkg)) from_full;
    Fmt.pr "@,Packages to copy from overlay:@,";
    List.iter
      (fun pkg -> Fmt.pr "  %s@," (OpamPackage.to_string pkg))
      from_overlay;
    Fmt.pr "@]@.";
    Ok ())
  else
    let* result1 = Output.copy ~src:full_repo ~dst:output ~packages:from_full in
    let* result2 =
      Output.copy ~src:overlay_repo ~dst:output ~packages:from_overlay
    in
    Logs.info (fun m ->
        m "Copied %d packages from full, %d from overlay, skipped %d"
          (List.length result1.copied)
          (List.length result2.copied)
          (List.length result1.skipped + List.length result2.skipped));
    Ok ()