Skip to content

Commit

Permalink
refactor: simplify artifact substitution API (#8565)
Browse files Browse the repository at this point in the history 
Signed-off-by: Rudi Grinberg <me@rgrinberg.com>
  • Loading branch information
@rgrinberg
rgrinberg authored Aug 31, 2023
1 parent 704a212 commit 7cc79e2
Show file tree
Hide file tree
Showing 5 changed files with 150 additions and 144 deletions.
19 changes: 9 additions & 10 deletions bin/install_uninstall.ml
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
open Import
module Artifact_substitution = Dune_rules.Artifact_substitution

let synopsis =
[ `P "The installation directories used are defined by priority:"
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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 =
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
228 changes: 117 additions & 111 deletions src/dune_rules/artifact_substitution.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 ])
Expand All @@ -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 *)
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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. *)
Expand Down Expand Up @@ -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 () ->
Expand Down
43 changes: 22 additions & 21 deletions src/dune_rules/artifact_substitution.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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)
Expand Down
Loading

0 comments on commit 7cc79e2

Please sign in to comment.