From 7cc79e24ff8b6f3d735a56214d19c53d6698cd92 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Thu, 31 Aug 2023 18:49:06 +0100 Subject: [PATCH] refactor: simplify artifact substitution API (#8565) Signed-off-by: Rudi Grinberg --- bin/install_uninstall.ml | 19 +- src/dune_rules/artifact_substitution.ml | 228 +++++++++--------- src/dune_rules/artifact_substitution.mli | 43 ++-- src/dune_rules/main.ml | 2 +- .../artifact_substitution.ml | 2 +- 5 files changed, 150 insertions(+), 144 deletions(-) diff --git a/bin/install_uninstall.ml b/bin/install_uninstall.ml index 85f9a16b4db..0db449254bb 100644 --- a/bin/install_uninstall.ml +++ b/bin/install_uninstall.ml @@ -1,4 +1,5 @@ open Import +module Artifact_substitution = Dune_rules.Artifact_substitution let synopsis = [ `P "The installation directories used are defined by priority:" @@ -139,7 +140,7 @@ module type File_operations = sig -> executable:bool -> special_file:Special_file.t option -> package:Package.Name.t - -> conf:Dune_rules.Artifact_substitution.conf + -> conf:Artifact_substitution.Conf.t -> unit Fiber.t val mkdir_p : Path.t -> unit @@ -322,10 +323,11 @@ module File_ops_real (W : sig ~executable ~special_file ~package - ~(conf : Dune_rules.Artifact_substitution.conf) + ~(conf : Artifact_substitution.Conf.t) = let chmod = if executable then fun _ -> 0o755 else fun _ -> 0o644 in match (special_file : Special_file.t option) with + | None -> Artifact_substitution.copy_file ~conf ~executable ~src ~dst ~chmod () | Some sf -> let ic, oc = Io.setup_copy ~chmod ~src ~dst () in Fiber.finalize @@ -336,11 +338,11 @@ module File_ops_real (W : sig let f = match sf with | META -> process_meta - | Dune_package -> process_dune_package ~get_location:conf.get_location + | Dune_package -> + process_dune_package + ~get_location:(Artifact_substitution.Conf.get_location conf) in copy_special_file ~src ~package ~ic ~oc ~f) - | None -> - Dune_rules.Artifact_substitution.copy_file ~conf ~executable ~src ~dst ~chmod () ;; let remove_file_if_exists dst = @@ -718,10 +720,7 @@ let install_uninstall ~what = ~f:(fun (context, entries_per_package) -> let roots = get_dirs context ~prefix_from_command_line ~from_command_line in let conf = - Dune_rules.Artifact_substitution.conf_for_install - ~relocatable - ~roots - ~context + Artifact_substitution.Conf.of_install ~relocatable ~roots ~context in Fiber.sequential_iter entries_per_package ~f:(fun (package, entries) -> let paths = Install.Paths.make ~package ~roots in @@ -739,7 +738,7 @@ let install_uninstall ~what = match special_file with | _ when not create_install_files -> Fiber.return true | None -> - let open Dune_rules.Artifact_substitution in + let open Artifact_substitution in let+ status = test_file ~src:entry.src () in (match status with | Some_substitution -> true diff --git a/src/dune_rules/artifact_substitution.ml b/src/dune_rules/artifact_substitution.ml index f7e249ff050..35fdf56feba 100644 --- a/src/dune_rules/artifact_substitution.ml +++ b/src/dune_rules/artifact_substitution.ml @@ -43,101 +43,9 @@ type hardcoded_ocaml_path = | Hardcoded of Path.t list | Relocatable of Path.t -type conf = - { get_vcs : Path.Source.t -> Vcs.t option Memo.t - ; get_location : Section.t -> Package.Name.t -> Path.t - ; get_config_path : configpath -> Path.t option - ; hardcoded_ocaml_path : hardcoded_ocaml_path - ; sign_hook : (Path.t -> unit Fiber.t) option Lazy.t - } - -let mac_codesign_hook ~codesign path = - let stdout_to = - Process.Io.make_stdout - ~output_on_success:Swallow - ~output_limit:Execution_parameters.Action_output_limit.default - in - let stderr_to = - Process.Io.make_stderr - ~output_on_success:Swallow - ~output_limit:Execution_parameters.Action_output_limit.default - in - Process.run - ~stdout_to - ~stderr_to - ~display:Quiet - Strict - codesign - [ "-f"; "-s"; "-"; Path.to_string path ] -;; - -let sign_hook_of_context (context : Context.t) = - let config = context.ocaml.ocaml_config in - match Ocaml_config.system config, Ocaml_config.architecture config with - | "macosx", "arm64" -> - let codesign_name = "codesign" in - (match Bin.which ~path:context.path codesign_name with - | None -> - Utils.program_not_found - ~loc:None - ~hint:"codesign should be part of the macOS installation" - codesign_name - | Some codesign -> Some (mac_codesign_hook ~codesign)) - | _ -> None -;; - -let conf_of_context (context : Context.t option) = - let get_vcs = Source_tree.nearest_vcs in - match context with - | None -> - { get_vcs - ; get_location = (fun _ _ -> Code_error.raise "no context available" []) - ; get_config_path = (fun _ -> Code_error.raise "no context available" []) - ; hardcoded_ocaml_path = Hardcoded [] - ; sign_hook = lazy None - } - | Some context -> - let get_location = Install.Paths.get_local_location context.name in - let get_config_path = function - | Sourceroot -> Some (Path.source Path.Source.root) - | Stdlib -> Some context.ocaml.lib_config.stdlib_dir - in - let hardcoded_ocaml_path = - let install_dir = Install.Context.dir ~context:context.name in - let install_dir = Path.build (Path.Build.relative install_dir "lib") in - Hardcoded (install_dir :: context.default_ocamlpath) - in - let sign_hook = lazy (sign_hook_of_context context) in - { get_vcs; get_location; get_config_path; hardcoded_ocaml_path; sign_hook } -;; - -let conf_for_install ~relocatable ~roots ~(context : Context.t) = - let get_vcs = Source_tree.nearest_vcs in - let hardcoded_ocaml_path = - match relocatable with - | Some prefix -> Relocatable prefix - | None -> Hardcoded context.default_ocamlpath - in - let get_location section package = - let paths = Install.Paths.make ~package ~roots in - Install.Paths.get paths section - in - let get_config_path = function - | Sourceroot -> None - | Stdlib -> Some context.ocaml.lib_config.stdlib_dir - in - let sign_hook = lazy (sign_hook_of_context context) in - { get_location; get_vcs; get_config_path; hardcoded_ocaml_path; sign_hook } -;; - -let conf_dummy = - { get_vcs = (fun _ -> Memo.return None) - ; get_location = (fun _ _ -> Path.root) - ; get_config_path = (fun _ -> None) - ; hardcoded_ocaml_path = Hardcoded [] - ; sign_hook = lazy None - } -;; +type status = + | Some_substitution + | No_substitution let to_dyn = function | Vcs_describe p -> Dyn.Variant ("Vcs_describe", [ Path.Source.to_dyn p ]) @@ -154,7 +62,116 @@ let to_dyn = function | Repeat (n, s) -> Dyn.Variant ("Repeat", [ Int n; String s ]) ;; -let eval t ~conf = +module Conf = struct + type t = + { get_vcs : Path.Source.t -> Vcs.t option Memo.t + ; get_location : Section.t -> Package.Name.t -> Path.t + ; get_config_path : configpath -> Path.t option + ; hardcoded_ocaml_path : hardcoded_ocaml_path + ; sign_hook : (Path.t -> unit Fiber.t) option Lazy.t + } + + let get_location t = t.get_location + + let mac_codesign_hook ~codesign path = + let stdout_to = + Process.Io.make_stdout + ~output_on_success:Swallow + ~output_limit:Execution_parameters.Action_output_limit.default + in + let stderr_to = + Process.Io.make_stderr + ~output_on_success:Swallow + ~output_limit:Execution_parameters.Action_output_limit.default + in + Process.run + ~stdout_to + ~stderr_to + ~display:Quiet + Strict + codesign + [ "-f"; "-s"; "-"; Path.to_string path ] + ;; + + let sign_hook_of_context (context : Context.t) = + let config = context.ocaml.ocaml_config in + match Ocaml_config.system config, Ocaml_config.architecture config with + | "macosx", "arm64" -> + let codesign_name = "codesign" in + (match Bin.which ~path:context.path codesign_name with + | None -> + Utils.program_not_found + ~loc:None + ~hint:"codesign should be part of the macOS installation" + codesign_name + | Some codesign -> Some (mac_codesign_hook ~codesign)) + | _ -> None + ;; + + let of_context (context : Context.t option) = + let get_vcs = Source_tree.nearest_vcs in + match context with + | None -> + { get_vcs + ; get_location = (fun _ _ -> Code_error.raise "no context available" []) + ; get_config_path = (fun _ -> Code_error.raise "no context available" []) + ; hardcoded_ocaml_path = Hardcoded [] + ; sign_hook = lazy None + } + | Some context -> + let get_location = Install.Paths.get_local_location context.name in + let get_config_path = function + | Sourceroot -> Some (Path.source Path.Source.root) + | Stdlib -> Some context.ocaml.lib_config.stdlib_dir + in + let hardcoded_ocaml_path = + let install_dir = Install.Context.dir ~context:context.name in + let install_dir = Path.build (Path.Build.relative install_dir "lib") in + Hardcoded (install_dir :: context.default_ocamlpath) + in + let sign_hook = lazy (sign_hook_of_context context) in + { get_vcs; get_location; get_config_path; hardcoded_ocaml_path; sign_hook } + ;; + + let of_install ~relocatable ~roots ~(context : Context.t) = + let get_vcs = Source_tree.nearest_vcs in + let hardcoded_ocaml_path = + match relocatable with + | Some prefix -> Relocatable prefix + | None -> Hardcoded context.default_ocamlpath + in + let get_location section package = + let paths = Install.Paths.make ~package ~roots in + Install.Paths.get paths section + in + let get_config_path = function + | Sourceroot -> None + | Stdlib -> Some context.ocaml.lib_config.stdlib_dir + in + let sign_hook = lazy (sign_hook_of_context context) in + { get_location; get_vcs; get_config_path; hardcoded_ocaml_path; sign_hook } + ;; + + let dummy = + { get_vcs = (fun _ -> Memo.return None) + ; get_location = (fun _ _ -> Path.root) + ; get_config_path = (fun _ -> None) + ; hardcoded_ocaml_path = Hardcoded [] + ; sign_hook = lazy None + } + ;; + + let run_sign_hook t ~has_subst file = + match has_subst with + | No_substitution -> Fiber.return () + | Some_substitution -> + (match Lazy.force t.sign_hook with + | Some hook -> hook file + | None -> Fiber.return ()) + ;; +end + +let eval t ~(conf : Conf.t) = let relocatable path = (* return a relative path to the install directory in case of relocatable instead of absolute path *) @@ -458,13 +475,9 @@ type mode = | Copy of { input_file : Path.t ; output : bytes -> int -> int -> unit - ; conf : conf + ; conf : Conf.t } -type status = - | Some_substitution - | No_substitution - (** The copy algorithm works as follow: {v @@ -618,15 +631,6 @@ let copy_file_non_atomic ~conf ?chmod ~src ~dst () = (fun () -> copy ~conf ~input_file:src ~input:(input ic) ~output:(output oc)) ;; -let run_sign_hook conf ~has_subst file = - match has_subst with - | No_substitution -> Fiber.return () - | Some_substitution -> - (match Lazy.force conf.sign_hook with - | Some hook -> hook file - | None -> Fiber.return ()) -;; - (** This is just an optimisation: skip the renaming if the destination exists and has the right digest. The optimisation is useful to avoid unnecessary retriggering of Dune and other file-watching systems. *) @@ -677,7 +681,9 @@ let copy_file Path.parent dst |> Option.iter ~f:Path.mkdir_p; let* has_subst = copy_file_non_atomic ~conf ?chmod ~src ~dst:temp_file () in let+ () = - if executable then run_sign_hook conf ~has_subst temp_file else Fiber.return () + if executable + then Conf.run_sign_hook conf ~has_subst temp_file + else Fiber.return () in replace_if_different ~delete_dst_if_it_is_a_directory ~src:temp_file ~dst) ~finally:(fun () -> diff --git a/src/dune_rules/artifact_substitution.mli b/src/dune_rules/artifact_substitution.mli index 364d1e0c7ea..e0d2d6ce483 100644 --- a/src/dune_rules/artifact_substitution.mli +++ b/src/dune_rules/artifact_substitution.mli @@ -20,25 +20,26 @@ type hardcoded_ocaml_path = | Hardcoded of Path.t list | Relocatable of Path.t -type conf = private - { get_vcs : Path.Source.t -> Vcs.t option Memo.t - ; get_location : Section.t -> Package.Name.t -> Path.t - ; get_config_path : configpath -> Path.t option - ; hardcoded_ocaml_path : hardcoded_ocaml_path - (** Initial prefix of installation when relocatable chosen *) - ; sign_hook : (Path.t -> unit Fiber.t) option Lazy.t - (** Called on binary after if has been edited *) - } - -val conf_of_context : Context.t option -> conf - -val conf_for_install - : relocatable:Path.t option - -> roots:Path.t Install.Roots.t - -> context:Context.t - -> conf - -val conf_dummy : conf +module Conf : sig + type t + + (* val get_vcs : t -> Path.Source.t -> Vcs.t option Memo.t *) + val get_location : t -> Section.t -> Package.Name.t -> Path.t + (* val get_config_path : t -> configpath -> Path.t option *) + (* val hardcoded_ocaml_path : t -> hardcoded_ocaml_path *) + (* val sign_hook : t -> (Path.t -> unit Fiber.t) option Lazy.t *) + + val of_context : Context.t option -> t + + val of_install + : relocatable:Path.t option + -> roots:Path.t Install.Roots.t + -> context:Context.t + -> t + + val dummy : t +end + val to_dyn : t -> Dyn.t (** A string encoding of a substitution. The resulting string is what should be @@ -56,7 +57,7 @@ val decode : string -> t option i.e., the contents is first copied to a temporary file in the same directory and then atomically renamed to [dst]. *) val copy_file - : conf:conf + : conf:Conf.t -> ?executable:bool -> ?chmod:(int -> int) -> ?delete_dst_if_it_is_a_directory:bool @@ -78,7 +79,7 @@ type status = Return whether a substitution happened. *) val copy - : conf:conf + : conf:Conf.t -> input_file:Path.t -> input:(Bytes.t -> int -> int -> int) -> output:(Bytes.t -> int -> int -> unit) diff --git a/src/dune_rules/main.ml b/src/dune_rules/main.ml index 2b1b0da1f8c..f58e801ff74 100644 --- a/src/dune_rules/main.ml +++ b/src/dune_rules/main.ml @@ -57,7 +57,7 @@ let init Memo.run (Memo.Option.map ctx ~f:(fun (ctx : Build_context.t) -> Context.DB.get ctx.name)) in - let conf = Artifact_substitution.conf_of_context ctx in + let conf = Artifact_substitution.Conf.of_context ctx in let src = Path.build src in let dst = Path.source dst in Artifact_substitution.copy_file diff --git a/test/unit-tests/artifact_substitution/artifact_substitution.ml b/test/unit-tests/artifact_substitution/artifact_substitution.ml index 83dac6acdca..8da6dd01f3c 100644 --- a/test/unit-tests/artifact_substitution/artifact_substitution.ml +++ b/test/unit-tests/artifact_substitution/artifact_substitution.ml @@ -148,7 +148,7 @@ let test input = let output = Buffer.add_subbytes buf in let+ (_ : Artifact_substitution.status) = Artifact_substitution.copy - ~conf:Artifact_substitution.conf_dummy + ~conf:Artifact_substitution.Conf.dummy ~input_file:(Path.of_string "") ~input ~output