Add support for sandboxing
This commit is contained in:
parent
047139a2d7
commit
b9976773a3
|
@ -80,6 +80,7 @@ module Mini_shexp = struct
|
||||||
| System of 'a
|
| System of 'a
|
||||||
| Bash of 'a
|
| Bash of 'a
|
||||||
| Update_file of 'path * 'a
|
| Update_file of 'path * 'a
|
||||||
|
| Rename of 'path * 'path
|
||||||
|
|
||||||
let rec t a p sexp =
|
let rec t a p sexp =
|
||||||
sum
|
sum
|
||||||
|
@ -134,6 +135,7 @@ module Mini_shexp = struct
|
||||||
| System x -> List [Atom "system"; f x]
|
| System x -> List [Atom "system"; f x]
|
||||||
| Bash x -> List [Atom "bash"; f x]
|
| Bash x -> List [Atom "bash"; f x]
|
||||||
| Update_file (x, y) -> List [Atom "update-file"; g x; f y]
|
| 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 =
|
let rec fold t ~init:acc ~f =
|
||||||
match t with
|
match t with
|
||||||
|
@ -152,6 +154,35 @@ module Mini_shexp = struct
|
||||||
| System x -> f acc x
|
| System x -> f acc x
|
||||||
| Bash x -> f acc x
|
| Bash x -> f acc x
|
||||||
| Update_file (x, y) -> f (f acc x) y
|
| 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
|
end
|
||||||
open Ast
|
open Ast
|
||||||
|
|
||||||
|
@ -176,7 +207,8 @@ module Mini_shexp = struct
|
||||||
| Symlink _
|
| Symlink _
|
||||||
| Copy_and_add_line_directive _
|
| Copy_and_add_line_directive _
|
||||||
| System _
|
| System _
|
||||||
| Bash _ -> acc
|
| Bash _
|
||||||
|
| Rename _ -> acc
|
||||||
in
|
in
|
||||||
fun t -> loop Path.Set.empty t
|
fun t -> loop Path.Set.empty t
|
||||||
|
|
||||||
|
@ -223,6 +255,8 @@ module Mini_shexp = struct
|
||||||
| System x -> System (expand_str ~dir ~f x)
|
| System x -> System (expand_str ~dir ~f x)
|
||||||
| Bash x -> Bash (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)
|
| 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
|
end
|
||||||
|
|
||||||
open Future
|
open Future
|
||||||
|
@ -323,6 +357,9 @@ module Mini_shexp = struct
|
||||||
else
|
else
|
||||||
write_file fn s;
|
write_file fn s;
|
||||||
return ()
|
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 =
|
and redirect outputs fn t ~purpose ~dir ~env ~env_extra ~stdout_to ~stderr_to =
|
||||||
let fn = Path.to_string fn in
|
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
|
Mini_shexp.exec action ~purpose ~dir ~env ~env_extra:String_map.empty
|
||||||
~stdout_to:None ~stderr_to:None
|
~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
|
type for_hash = string option * Path.t * Mini_shexp.t
|
||||||
|
|
||||||
let for_hash { context; dir; action; _ } =
|
let for_hash { context; dir; action; _ } =
|
||||||
|
|
|
@ -29,6 +29,7 @@ module Mini_shexp : sig
|
||||||
| System of 'a
|
| System of 'a
|
||||||
| Bash of 'a
|
| Bash of 'a
|
||||||
| Update_file of 'path * '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 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
|
val sexp_of_t : 'a Sexp.To_sexp.t -> 'b Sexp.To_sexp.t -> ('a, 'b) t Sexp.To_sexp.t
|
||||||
end
|
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 sexp_of_t : t Sexp.To_sexp.t
|
||||||
val exec : targets:Path.Set.t -> t -> unit Future.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
|
type for_hash
|
||||||
val for_hash : t -> for_hash
|
val for_hash : t -> for_hash
|
||||||
|
|
|
@ -104,10 +104,12 @@ module Rule = struct
|
||||||
type t =
|
type t =
|
||||||
{ build : (unit, Action.t) Build.t
|
{ build : (unit, Action.t) Build.t
|
||||||
; targets : Target.t list
|
; targets : Target.t list
|
||||||
|
; sandbox : bool
|
||||||
}
|
}
|
||||||
|
|
||||||
let make build =
|
let make ?(sandbox=false) build =
|
||||||
{ build
|
{ build
|
||||||
; targets = targets build
|
; targets = targets build
|
||||||
|
; sandbox
|
||||||
}
|
}
|
||||||
end
|
end
|
||||||
|
|
|
@ -13,9 +13,10 @@ module Rule : sig
|
||||||
type t =
|
type t =
|
||||||
{ build : (unit, Action.t) Build.t
|
{ build : (unit, Action.t) Build.t
|
||||||
; targets : Target.t list
|
; 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
|
end
|
||||||
|
|
||||||
val deps
|
val deps
|
||||||
|
|
|
@ -61,6 +61,7 @@ type t =
|
||||||
; (* Table from target to digest of [(deps, targets, action)] *)
|
; (* Table from target to digest of [(deps, targets, action)] *)
|
||||||
trace : (Path.t, Digest.t) Hashtbl.t
|
trace : (Path.t, Digest.t) Hashtbl.t
|
||||||
; timestamps : (Path.t, float) Hashtbl.t
|
; timestamps : (Path.t, float) Hashtbl.t
|
||||||
|
; mutable local_mkdirs : Path.Local.Set.t
|
||||||
}
|
}
|
||||||
|
|
||||||
let timestamp t fn =
|
let timestamp t fn =
|
||||||
|
@ -293,8 +294,22 @@ let () =
|
||||||
pending_targets := Pset.empty;
|
pending_targets := Pset.empty;
|
||||||
Pset.iter fns ~f:Path.unlink_no_err)
|
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 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 deps = Build_interpret.deps build ~all_targets_by_dir in
|
||||||
let targets = Target.paths target_specs 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;
|
end;
|
||||||
|
|
||||||
let exec = Exec_status.Not_started (fun ~targeting ->
|
let exec = Exec_status.Not_started (fun ~targeting ->
|
||||||
Pset.iter targets ~f:(fun fn ->
|
make_local_dirs t targets ~map_path:(fun x -> x);
|
||||||
match Path.kind fn with
|
|
||||||
| Local local -> Path.Local.ensure_parent_directory_exists local
|
|
||||||
| External _ -> ());
|
|
||||||
wait_for_deps t deps ~targeting
|
wait_for_deps t deps ~targeting
|
||||||
>>= fun () ->
|
>>= fun () ->
|
||||||
let action, dyn_deps = Build_exec.exec t build () in
|
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
|
in
|
||||||
Pset.iter targets_to_remove ~f:Path.unlink_no_err;
|
Pset.iter targets_to_remove ~f:Path.unlink_no_err;
|
||||||
pending_targets := Pset.union targets_to_remove !pending_targets;
|
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 () ->
|
Action.exec ~targets action >>| fun () ->
|
||||||
(* All went well, these targets are no longer pending *)
|
(* All went well, these targets are no longer pending *)
|
||||||
pending_targets := Pset.diff !pending_targets targets_to_remove;
|
pending_targets := Pset.diff !pending_targets targets_to_remove;
|
||||||
|
@ -500,6 +523,7 @@ let create ~contexts ~file_tree ~rules =
|
||||||
; files = Hashtbl.create 1024
|
; files = Hashtbl.create 1024
|
||||||
; trace = Trace.load ()
|
; trace = Trace.load ()
|
||||||
; timestamps = Hashtbl.create 1024
|
; timestamps = Hashtbl.create 1024
|
||||||
|
; local_mkdirs = Path.Local.Set.empty
|
||||||
} in
|
} in
|
||||||
List.iter rules ~f:(compile_rule t ~all_targets_by_dir ~allow_override:false);
|
List.iter rules ~f:(compile_rule t ~all_targets_by_dir ~allow_override:false);
|
||||||
setup_copy_rules t ~all_targets_by_dir
|
setup_copy_rules t ~all_targets_by_dir
|
||||||
|
|
|
@ -49,10 +49,18 @@ module Local = struct
|
||||||
|
|
||||||
let root = ""
|
let root = ""
|
||||||
|
|
||||||
|
let is_root = function
|
||||||
|
| "" -> true
|
||||||
|
| _ -> false
|
||||||
|
|
||||||
let to_string = function
|
let to_string = function
|
||||||
| "" -> "."
|
| "" -> "."
|
||||||
| t -> t
|
| t -> t
|
||||||
|
|
||||||
|
let compare = String.compare
|
||||||
|
|
||||||
|
module Set = String_set
|
||||||
|
|
||||||
let to_list =
|
let to_list =
|
||||||
let rec loop t acc i j =
|
let rec loop t acc i j =
|
||||||
if i = 0 then
|
if i = 0 then
|
||||||
|
|
|
@ -4,11 +4,18 @@ open Import
|
||||||
module Local : sig
|
module Local : sig
|
||||||
type t
|
type t
|
||||||
|
|
||||||
|
val compare : t -> t -> int
|
||||||
|
|
||||||
|
module Set : Set.S with type elt = t
|
||||||
|
|
||||||
val root : t
|
val root : t
|
||||||
|
val is_root : t -> bool
|
||||||
val to_string : t -> string
|
val to_string : t -> string
|
||||||
|
val mkdir_p : t -> unit
|
||||||
val ensure_parent_directory_exists : t -> unit
|
val ensure_parent_directory_exists : t -> unit
|
||||||
val append : t -> t -> t
|
val append : t -> t -> t
|
||||||
val descendant : t -> of_:t -> t option
|
val descendant : t -> of_:t -> t option
|
||||||
|
val parent : t -> t
|
||||||
end
|
end
|
||||||
|
|
||||||
(** In the outside world *)
|
(** In the outside world *)
|
||||||
|
|
Loading…
Reference in New Issue