Add support for sandboxing
This commit is contained in:
parent
047139a2d7
commit
b9976773a3
|
@ -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; _ } =
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 *)
|
||||
|
|
Loading…
Reference in New Issue