diff --git a/src/action.ml b/src/action.ml index 611aa03a..d19053a4 100644 --- a/src/action.ml +++ b/src/action.ml @@ -80,6 +80,7 @@ module Mini_shexp = struct | System of 'a | Bash of 'a | Update_file of 'path * 'a + | Rename of 'path * 'path let rec t a p sexp = sum @@ -134,6 +135,7 @@ module Mini_shexp = struct | System x -> List [Atom "system"; f x] | Bash x -> List [Atom "bash"; f x] | Update_file (x, y) -> List [Atom "update-file"; g x; f y] + | Rename (x, y) -> List [Atom "rename"; g x; g y] let rec fold t ~init:acc ~f = match t with @@ -152,6 +154,35 @@ module Mini_shexp = struct | System x -> f acc x | Bash x -> f acc x | Update_file (x, y) -> f (f acc x) y + | Rename (x, y) -> f (f acc x) y + + let rec map + : 'a 'b 'c 'd. ('a, 'b) t -> f1:('a -> 'c) -> f2:('b -> 'd) -> ('c, 'd) t + = fun t ~f1 ~f2 -> + match t with + | Run (prog, args) -> + Run (f2 prog, List.map args ~f:f1) + | Chdir (fn, t) -> + Chdir (f2 fn, map t ~f1 ~f2) + | Setenv (var, value, t) -> + Setenv (f1 var, f1 value, map t ~f1 ~f2) + | Redirect (outputs, fn, t) -> + Redirect (outputs, f2 fn, map t ~f1 ~f2) + | Ignore (outputs, t) -> + Ignore (outputs, map t ~f1 ~f2) + | Progn l -> Progn (List.map l ~f:(fun t -> map t ~f1 ~f2)) + | Echo x -> Echo (f1 x) + | Cat x -> Cat (f2 x) + | Create_file x -> Create_file (f2 x) + | Copy (x, y) -> Copy (f2 x, f2 y) + | Symlink (x, y) -> + Symlink (f2 x, f2 y) + | Copy_and_add_line_directive (x, y) -> + Copy_and_add_line_directive (f2 x, f2 y) + | System x -> System (f1 x) + | Bash x -> Bash (f1 x) + | Update_file (x, y) -> Update_file (f2 x, f1 y) + | Rename (x, y) -> Rename (f2 x, f2 y) end open Ast @@ -176,7 +207,8 @@ module Mini_shexp = struct | Symlink _ | Copy_and_add_line_directive _ | System _ - | Bash _ -> acc + | Bash _ + | Rename _ -> acc in fun t -> loop Path.Set.empty t @@ -223,6 +255,8 @@ module Mini_shexp = struct | System x -> System (expand_str ~dir ~f x) | Bash x -> Bash (expand_str ~dir ~f x) | Update_file (x, y) -> Update_file (expand_path ~dir ~f x, expand_str ~dir ~f y) + | Rename (x, y) -> + Rename (expand_path ~dir ~f x, expand_path ~dir ~f y) end open Future @@ -323,6 +357,9 @@ module Mini_shexp = struct else write_file fn s; return () + | Rename (src, dst) -> + Unix.rename (Path.to_string src) (Path.to_string dst); + return () and redirect outputs fn t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to = let fn = Path.to_string fn in @@ -393,6 +430,17 @@ let exec ~targets { action; dir; context } = Mini_shexp.exec action ~purpose ~dir ~env ~env_extra:String_map.empty ~stdout_to:None ~stderr_to:None +let sandbox t ~sandboxed ~deps ~targets = + let action = + let module M = Mini_shexp.Ast in + M.Progn + [ M.Progn (List.map deps ~f:(fun path -> M.Symlink (path, sandboxed path))) + ; M.map t.action ~f1:(fun x -> x) ~f2:sandboxed + ; M.Progn (List.map targets ~f:(fun path -> M.Rename (sandboxed path, path))) + ] + in + { t with action } + type for_hash = string option * Path.t * Mini_shexp.t let for_hash { context; dir; action; _ } = diff --git a/src/action.mli b/src/action.mli index 687e75d1..63f88a35 100644 --- a/src/action.mli +++ b/src/action.mli @@ -29,6 +29,7 @@ module Mini_shexp : sig | System of 'a | Bash of 'a | Update_file of 'path * 'a + | Rename of 'path * 'path val t : 'a Sexp.Of_sexp.t -> 'b Sexp.Of_sexp.t -> ('a, 'b) t Sexp.Of_sexp.t val sexp_of_t : 'a Sexp.To_sexp.t -> 'b Sexp.To_sexp.t -> ('a, 'b) t Sexp.To_sexp.t end @@ -60,5 +61,13 @@ val t : Context.t String_map.t -> t Sexp.Of_sexp.t val sexp_of_t : t Sexp.To_sexp.t val exec : targets:Path.Set.t -> t -> unit Future.t +(* Return a sandboxed version of an action *) +val sandbox + : t + -> sandboxed:(Path.t -> Path.t) + -> deps:Path.t list + -> targets:Path.t list + -> t + type for_hash val for_hash : t -> for_hash diff --git a/src/build_interpret.ml b/src/build_interpret.ml index fe24eacf..b5207bfd 100644 --- a/src/build_interpret.ml +++ b/src/build_interpret.ml @@ -104,10 +104,12 @@ module Rule = struct type t = { build : (unit, Action.t) Build.t ; targets : Target.t list + ; sandbox : bool } - let make build = + let make ?(sandbox=false) build = { build ; targets = targets build + ; sandbox } end diff --git a/src/build_interpret.mli b/src/build_interpret.mli index 025454eb..ba3d9c68 100644 --- a/src/build_interpret.mli +++ b/src/build_interpret.mli @@ -13,9 +13,10 @@ module Rule : sig type t = { build : (unit, Action.t) Build.t ; targets : Target.t list + ; sandbox : bool } - val make : (unit, Action.t) Build.t -> t + val make : ?sandbox:bool -> (unit, Action.t) Build.t -> t end val deps diff --git a/src/build_system.ml b/src/build_system.ml index 24e9895a..28c50a04 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -61,6 +61,7 @@ type t = ; (* Table from target to digest of [(deps, targets, action)] *) trace : (Path.t, Digest.t) Hashtbl.t ; timestamps : (Path.t, float) Hashtbl.t + ; mutable local_mkdirs : Path.Local.Set.t } let timestamp t fn = @@ -293,8 +294,22 @@ let () = pending_targets := Pset.empty; Pset.iter fns ~f:Path.unlink_no_err) +let make_local_dirs t paths ~map_path = + Pset.iter paths ~f:(fun path -> + match Path.kind (map_path path) with + | Local path when not (Path.Local.is_root path) -> + let parent = Path.Local.parent path in + if not (Path.Local.Set.mem parent t.local_mkdirs) then begin + Path.Local.mkdir_p parent; + t.local_mkdirs <- Path.Local.Set.add parent t.local_mkdirs + end + | _ -> ()) + +let sandbox_dir = Path.of_string "_build/.sandbox" +let sandboxed path = Path.append sandbox_dir path + let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule = - let { Pre_rule. build; targets = target_specs } = pre_rule in + let { Pre_rule. build; targets = target_specs; sandbox } = pre_rule in let deps = Build_interpret.deps build ~all_targets_by_dir in let targets = Target.paths target_specs in @@ -322,10 +337,7 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule = end; let exec = Exec_status.Not_started (fun ~targeting -> - Pset.iter targets ~f:(fun fn -> - match Path.kind fn with - | Local local -> Path.Local.ensure_parent_directory_exists local - | External _ -> ()); + make_local_dirs t targets ~map_path:(fun x -> x); wait_for_deps t deps ~targeting >>= fun () -> let action, dyn_deps = Build_exec.exec t build () in @@ -383,6 +395,17 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule = in Pset.iter targets_to_remove ~f:Path.unlink_no_err; pending_targets := Pset.union targets_to_remove !pending_targets; + let action = + if sandbox then begin + make_local_dirs t all_deps ~map_path:sandboxed; + make_local_dirs t targets ~map_path:sandboxed; + Action.sandbox action + ~sandboxed + ~deps:all_deps_as_list + ~targets:targets_as_list + end else + action + in Action.exec ~targets action >>| fun () -> (* All went well, these targets are no longer pending *) pending_targets := Pset.diff !pending_targets targets_to_remove; @@ -500,6 +523,7 @@ let create ~contexts ~file_tree ~rules = ; files = Hashtbl.create 1024 ; trace = Trace.load () ; timestamps = Hashtbl.create 1024 + ; local_mkdirs = Path.Local.Set.empty } in List.iter rules ~f:(compile_rule t ~all_targets_by_dir ~allow_override:false); setup_copy_rules t ~all_targets_by_dir diff --git a/src/path.ml b/src/path.ml index 6e44f5b5..64eb7e87 100644 --- a/src/path.ml +++ b/src/path.ml @@ -49,10 +49,18 @@ module Local = struct let root = "" + let is_root = function + | "" -> true + | _ -> false + let to_string = function | "" -> "." | t -> t + let compare = String.compare + + module Set = String_set + let to_list = let rec loop t acc i j = if i = 0 then diff --git a/src/path.mli b/src/path.mli index b01c98a6..efd5b8ef 100644 --- a/src/path.mli +++ b/src/path.mli @@ -4,11 +4,18 @@ open Import module Local : sig type t + val compare : t -> t -> int + + module Set : Set.S with type elt = t + val root : t + val is_root : t -> bool val to_string : t -> string + val mkdir_p : t -> unit val ensure_parent_directory_exists : t -> unit val append : t -> t -> t val descendant : t -> of_:t -> t option + val parent : t -> t end (** In the outside world *)