Move promotion to own module
It's not really related to actions Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>
This commit is contained in:
parent
bf2d842075
commit
1b71d57bba
|
@ -1402,7 +1402,7 @@ let promote =
|
||||||
(* We load and restore the digest cache as we need to clear the
|
(* We load and restore the digest cache as we need to clear the
|
||||||
cache for promoted files, due to issues on OSX. *)
|
cache for promoted files, due to issues on OSX. *)
|
||||||
Utils.Cached_digest.load ();
|
Utils.Cached_digest.load ();
|
||||||
Action_exec.Promotion.promote_files_registered_in_last_run ();
|
Promotion.promote_files_registered_in_last_run ();
|
||||||
Utils.Cached_digest.dump ()
|
Utils.Cached_digest.dump ()
|
||||||
in
|
in
|
||||||
(term, Term.info "promote" ~doc ~man )
|
(term, Term.info "promote" ~doc ~man )
|
||||||
|
|
|
@ -6,112 +6,6 @@ type exec_context =
|
||||||
; purpose : Process.purpose
|
; purpose : Process.purpose
|
||||||
}
|
}
|
||||||
|
|
||||||
module Promotion = struct
|
|
||||||
module File = struct
|
|
||||||
type t =
|
|
||||||
{ src : Path.t
|
|
||||||
; dst : Path.t
|
|
||||||
}
|
|
||||||
|
|
||||||
(* XXX these sexp converters will be useful for the dump command *)
|
|
||||||
let _t =
|
|
||||||
let open Sexp.Of_sexp in
|
|
||||||
peek_exn >>= function
|
|
||||||
| List (_, [_; Atom (_, A "as"); _]) ->
|
|
||||||
enter
|
|
||||||
(Path.t >>= fun src ->
|
|
||||||
junk >>= fun () ->
|
|
||||||
Path.t >>= fun dst ->
|
|
||||||
return { src; dst })
|
|
||||||
| sexp ->
|
|
||||||
Sexp.Of_sexp.of_sexp_errorf (Sexp.Ast.loc sexp)
|
|
||||||
"(<file> as <file>) expected"
|
|
||||||
|
|
||||||
let _sexp_of_t { src; dst } =
|
|
||||||
Sexp.List [Path.sexp_of_t src; Sexp.unsafe_atom_of_string "as";
|
|
||||||
Path.sexp_of_t dst]
|
|
||||||
|
|
||||||
let db : t list ref = ref []
|
|
||||||
|
|
||||||
let register t = db := t :: !db
|
|
||||||
|
|
||||||
let promote { src; dst } =
|
|
||||||
Format.eprintf "Promoting %s to %s.@."
|
|
||||||
(Path.to_string_maybe_quoted src)
|
|
||||||
(Path.to_string_maybe_quoted dst);
|
|
||||||
Io.copy_file ~src ~dst ()
|
|
||||||
end
|
|
||||||
|
|
||||||
module P = Utils.Persistent(struct
|
|
||||||
type t = File.t list
|
|
||||||
let name = "TO-PROMOTE"
|
|
||||||
let version = 1
|
|
||||||
end)
|
|
||||||
|
|
||||||
let db_file = Path.relative Path.build_dir ".to-promote"
|
|
||||||
|
|
||||||
let dump_db db =
|
|
||||||
if Path.build_dir_exists () then begin
|
|
||||||
match db with
|
|
||||||
| [] -> if Path.exists db_file then Path.unlink_no_err db_file
|
|
||||||
| l -> P.dump db_file l
|
|
||||||
end
|
|
||||||
|
|
||||||
let load_db () = Option.value ~default:[] (P.load db_file)
|
|
||||||
|
|
||||||
let group_by_targets db =
|
|
||||||
List.map db ~f:(fun { File. src; dst } ->
|
|
||||||
(dst, src))
|
|
||||||
|> Path.Map.of_list_multi
|
|
||||||
(* Sort the list of possible sources for deterministic behavior *)
|
|
||||||
|> Path.Map.map ~f:(List.sort ~compare:Path.compare)
|
|
||||||
|
|
||||||
let do_promote db =
|
|
||||||
let by_targets = group_by_targets db in
|
|
||||||
let potential_build_contexts =
|
|
||||||
match Path.readdir_unsorted Path.build_dir with
|
|
||||||
| exception _ -> []
|
|
||||||
| files ->
|
|
||||||
List.filter_map files ~f:(fun fn ->
|
|
||||||
if fn = "" || fn.[0] = '.' || fn = "install" then
|
|
||||||
None
|
|
||||||
else
|
|
||||||
let path = Path.(relative build_dir) fn in
|
|
||||||
Option.some_if (Path.is_directory path) path)
|
|
||||||
in
|
|
||||||
let dirs_to_clear_from_cache = Path.root :: potential_build_contexts in
|
|
||||||
Path.Map.iteri by_targets ~f:(fun dst srcs ->
|
|
||||||
match srcs with
|
|
||||||
| [] -> assert false
|
|
||||||
| src :: others ->
|
|
||||||
(* We remove the files from the digest cache to force a rehash
|
|
||||||
on the next run. We do this because on OSX [mtime] is not
|
|
||||||
precise enough and if a file is modified and promoted
|
|
||||||
quickly, it will look like it hasn't changed even though it
|
|
||||||
might have. *)
|
|
||||||
List.iter dirs_to_clear_from_cache ~f:(fun dir ->
|
|
||||||
Utils.Cached_digest.remove (Path.append dir dst));
|
|
||||||
File.promote { src; dst };
|
|
||||||
List.iter others ~f:(fun path ->
|
|
||||||
Format.eprintf " -> ignored %s.@."
|
|
||||||
(Path.to_string_maybe_quoted path)))
|
|
||||||
|
|
||||||
let finalize () =
|
|
||||||
let db =
|
|
||||||
if !Clflags.auto_promote then
|
|
||||||
(do_promote !File.db; [])
|
|
||||||
else
|
|
||||||
!File.db
|
|
||||||
in
|
|
||||||
dump_db db
|
|
||||||
|
|
||||||
let promote_files_registered_in_last_run () =
|
|
||||||
let db = load_db () in
|
|
||||||
do_promote db;
|
|
||||||
dump_db []
|
|
||||||
end
|
|
||||||
|
|
||||||
|
|
||||||
let get_std_output : _ -> Process.std_output_to = function
|
let get_std_output : _ -> Process.std_output_to = function
|
||||||
| None -> Terminal
|
| None -> Terminal
|
||||||
| Some (fn, oc) ->
|
| Some (fn, oc) ->
|
||||||
|
|
|
@ -1,23 +1,5 @@
|
||||||
open Stdune
|
open Stdune
|
||||||
|
|
||||||
module Promotion : sig
|
|
||||||
module File : sig
|
|
||||||
type t =
|
|
||||||
{ src : Path.t
|
|
||||||
; dst : Path.t
|
|
||||||
}
|
|
||||||
|
|
||||||
(** Register a file to promote *)
|
|
||||||
val register : t -> unit
|
|
||||||
end
|
|
||||||
|
|
||||||
(** Promote all registered files if [!Clflags.auto_promote]. Otherwise dump the list of
|
|
||||||
registered files to [_build/.to-promote]. *)
|
|
||||||
val finalize : unit -> unit
|
|
||||||
|
|
||||||
val promote_files_registered_in_last_run : unit -> unit
|
|
||||||
end
|
|
||||||
|
|
||||||
val exec
|
val exec
|
||||||
: targets:Path.Set.t
|
: targets:Path.Set.t
|
||||||
-> context:Context.t option
|
-> context:Context.t option
|
||||||
|
|
|
@ -1214,7 +1214,7 @@ let all_targets t =
|
||||||
let finalize t =
|
let finalize t =
|
||||||
(* Promotion must be handled before dumping the digest cache, as it
|
(* Promotion must be handled before dumping the digest cache, as it
|
||||||
might delete some entries. *)
|
might delete some entries. *)
|
||||||
Action_exec.Promotion.finalize ();
|
Promotion.finalize ();
|
||||||
Promoted_to_delete.dump ();
|
Promoted_to_delete.dump ();
|
||||||
Utils.Cached_digest.dump ();
|
Utils.Cached_digest.dump ();
|
||||||
Trace.dump t.trace
|
Trace.dump t.trace
|
||||||
|
|
|
@ -0,0 +1,104 @@
|
||||||
|
open Stdune
|
||||||
|
|
||||||
|
module File = struct
|
||||||
|
type t =
|
||||||
|
{ src : Path.t
|
||||||
|
; dst : Path.t
|
||||||
|
}
|
||||||
|
|
||||||
|
(* XXX these sexp converters will be useful for the dump command *)
|
||||||
|
let _t =
|
||||||
|
let open Sexp.Of_sexp in
|
||||||
|
peek_exn >>= function
|
||||||
|
| List (_, [_; Atom (_, A "as"); _]) ->
|
||||||
|
enter
|
||||||
|
(Path.t >>= fun src ->
|
||||||
|
junk >>= fun () ->
|
||||||
|
Path.t >>= fun dst ->
|
||||||
|
return { src; dst })
|
||||||
|
| sexp ->
|
||||||
|
Sexp.Of_sexp.of_sexp_errorf (Sexp.Ast.loc sexp)
|
||||||
|
"(<file> as <file>) expected"
|
||||||
|
|
||||||
|
let _sexp_of_t { src; dst } =
|
||||||
|
Sexp.List [Path.sexp_of_t src; Sexp.unsafe_atom_of_string "as";
|
||||||
|
Path.sexp_of_t dst]
|
||||||
|
|
||||||
|
let db : t list ref = ref []
|
||||||
|
|
||||||
|
let register t = db := t :: !db
|
||||||
|
|
||||||
|
let promote { src; dst } =
|
||||||
|
Format.eprintf "Promoting %s to %s.@."
|
||||||
|
(Path.to_string_maybe_quoted src)
|
||||||
|
(Path.to_string_maybe_quoted dst);
|
||||||
|
Io.copy_file ~src ~dst ()
|
||||||
|
end
|
||||||
|
|
||||||
|
module P = Utils.Persistent(struct
|
||||||
|
type t = File.t list
|
||||||
|
let name = "TO-PROMOTE"
|
||||||
|
let version = 1
|
||||||
|
end)
|
||||||
|
|
||||||
|
let db_file = Path.relative Path.build_dir ".to-promote"
|
||||||
|
|
||||||
|
let dump_db db =
|
||||||
|
if Path.build_dir_exists () then begin
|
||||||
|
match db with
|
||||||
|
| [] -> if Path.exists db_file then Path.unlink_no_err db_file
|
||||||
|
| l -> P.dump db_file l
|
||||||
|
end
|
||||||
|
|
||||||
|
let load_db () = Option.value ~default:[] (P.load db_file)
|
||||||
|
|
||||||
|
let group_by_targets db =
|
||||||
|
List.map db ~f:(fun { File. src; dst } ->
|
||||||
|
(dst, src))
|
||||||
|
|> Path.Map.of_list_multi
|
||||||
|
(* Sort the list of possible sources for deterministic behavior *)
|
||||||
|
|> Path.Map.map ~f:(List.sort ~compare:Path.compare)
|
||||||
|
|
||||||
|
let do_promote db =
|
||||||
|
let by_targets = group_by_targets db in
|
||||||
|
let potential_build_contexts =
|
||||||
|
match Path.readdir_unsorted Path.build_dir with
|
||||||
|
| exception _ -> []
|
||||||
|
| files ->
|
||||||
|
List.filter_map files ~f:(fun fn ->
|
||||||
|
if fn = "" || fn.[0] = '.' || fn = "install" then
|
||||||
|
None
|
||||||
|
else
|
||||||
|
let path = Path.(relative build_dir) fn in
|
||||||
|
Option.some_if (Path.is_directory path) path)
|
||||||
|
in
|
||||||
|
let dirs_to_clear_from_cache = Path.root :: potential_build_contexts in
|
||||||
|
Path.Map.iteri by_targets ~f:(fun dst srcs ->
|
||||||
|
match srcs with
|
||||||
|
| [] -> assert false
|
||||||
|
| src :: others ->
|
||||||
|
(* We remove the files from the digest cache to force a rehash
|
||||||
|
on the next run. We do this because on OSX [mtime] is not
|
||||||
|
precise enough and if a file is modified and promoted
|
||||||
|
quickly, it will look like it hasn't changed even though it
|
||||||
|
might have. *)
|
||||||
|
List.iter dirs_to_clear_from_cache ~f:(fun dir ->
|
||||||
|
Utils.Cached_digest.remove (Path.append dir dst));
|
||||||
|
File.promote { src; dst };
|
||||||
|
List.iter others ~f:(fun path ->
|
||||||
|
Format.eprintf " -> ignored %s.@."
|
||||||
|
(Path.to_string_maybe_quoted path)))
|
||||||
|
|
||||||
|
let finalize () =
|
||||||
|
let db =
|
||||||
|
if !Clflags.auto_promote then
|
||||||
|
(do_promote !File.db; [])
|
||||||
|
else
|
||||||
|
!File.db
|
||||||
|
in
|
||||||
|
dump_db db
|
||||||
|
|
||||||
|
let promote_files_registered_in_last_run () =
|
||||||
|
let db = load_db () in
|
||||||
|
do_promote db;
|
||||||
|
dump_db []
|
|
@ -0,0 +1,17 @@
|
||||||
|
open Stdune
|
||||||
|
|
||||||
|
module File : sig
|
||||||
|
type t =
|
||||||
|
{ src : Path.t
|
||||||
|
; dst : Path.t
|
||||||
|
}
|
||||||
|
|
||||||
|
(** Register a file to promote *)
|
||||||
|
val register : t -> unit
|
||||||
|
end
|
||||||
|
|
||||||
|
(** Promote all registered files if [!Clflags.auto_promote]. Otherwise dump the list of
|
||||||
|
registered files to [_build/.to-promote]. *)
|
||||||
|
val finalize : unit -> unit
|
||||||
|
|
||||||
|
val promote_files_registered_in_last_run : unit -> unit
|
Loading…
Reference in New Issue