Add support for sandboxing

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; _ } =

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

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

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

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

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

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 *)