Global sandboxing setting

CHANGES.md

@@ -20,6 +20,12 @@
 - Stop symlinking object files to main directory for stanzas defined `jbuild`
   files (#2440, @rgrinerg)
 
+- Add a new config option `sandboxing_preference`, the cli argument `--sandbox`,
+  and the dep spec `sandbox` in dune language. These let the user control the level of
+  sandboxing done by dune per rule and globally. The rule specification takes precedence.
+  The global configuration merely specifies the default. 
+  (#2213, @aalekseyev)
+
 1.11.0 (23/07/2019)
 -------------------
 

bin/common.ml

@@ -327,6 +327,31 @@ let term =
          & info ["j"] ~docs ~docv:"JOBS"
              ~doc:{|Run no more than $(i,JOBS) commands simultaneously.|}
         )
+  and+ sandboxing_preference =
+    let arg =
+      Arg.conv
+        ((fun s ->
+           Result.map_error (Dune.Sandbox_mode.of_string s)
+             ~f:(fun s -> `Msg s)),
+         (fun pp x ->
+            Format.pp_print_string pp (Dune.Sandbox_mode.to_string x)))
+    in
+    Arg.(value
+         & opt (some arg) None
+         & info ["sandbox"]
+             ~env:(
+               Arg.env_var
+                 ~doc:"Sandboxing mode to use by default. (see --sandbox)"
+                 "DUNE_SANDBOX")
+             ~doc:(
+               Printf.sprintf
+                 "Sandboxing mode to use by default. Some actions require \
+                  a certain sandboxing mode, so they will ignore this \
+                  setting. The allowed values are: %s."
+                 (String.concat ~sep: ", " (
+                    List.map Dune.Sandbox_mode.all
+                      ~f:Dune.Sandbox_mode.to_string))
+             ))
   and+ debug_dep_path =
     Arg.(value
          & flag
@@ -462,6 +487,8 @@ let term =
     Config.merge config
       { display
       ; concurrency
+      ; sandboxing_preference =
+          Option.map sandboxing_preference ~f:(fun x -> [x])
       }
   in
   let config =

bin/import.ml

@@ -48,6 +48,7 @@ module Main = struct
     let open Fiber.O in
     scan_workspace ~log common
     >>= init_build_system
+          ~sandboxing_preference:(common.config.sandboxing_preference)
           ?external_lib_deps_mode
           ?only_packages:common.only_packages
 end

bin/subst.ml

@@ -66,6 +66,7 @@ let term =
     let config : Config.t =
       { display     = Quiet
       ; concurrency = Fixed 1
+      ; sandboxing_preference = []
       }
     in
     Path.set_root (Path.External.cwd ());

doc/dune-files.rst

@@ -1413,8 +1413,7 @@ introduced in 4.08, allowing the user to define custom let operators.
 Dependency specification
 ------------------------
 
-Dependencies in ``dune`` files can be specified using one of the following
-syntax:
+Dependencies in ``dune`` files can be specified using one of the following:
 
 - ``(:name <dependencies>)`` will bind the the list of dependencies to the
   ``name`` variable. This variable will be available as ``%{name}`` in actions.
@@ -1429,7 +1428,6 @@ syntax:
   :ref:`glob <glob>` for details
 
 .. _source_tree:
-
 - ``(source_tree <dir>)``: depend on all source files in the subtree with root
   ``<dir>``
 
@@ -1445,6 +1443,12 @@ syntax:
 - ``(env_var <var>)``: depend on the value of the environment variable ``<var>``.
   If this variable becomes set, becomes unset, or changes value, the target
   will be rebuilt.
+- ``(sandbox <config>)``: require a particular sandboxing configuration.
+  Config can be one (or many) of:
+  - ``always``: the action requires a clean environment.
+  - ``none``: the action must run in the build directory.
+  - ``preserve_file_kind``: the action needs the files it reads to look
+    like normal files (so dune won't use symlinks for sandboxing)
 
 In all these cases, the argument supports `Variables expansion`_.
 

dune-project

@@ -1,4 +1,4 @@
-(lang dune 1.11)
+(lang dune 1.12)
 (name dune)
 
 (implicit_transitive_deps false)

src/action.ml

@@ -173,33 +173,85 @@ let chdirs =
   in
   fun t -> loop Path.Set.empty t
 
-let symlink_managed_paths sandboxed deps ~eval_pred =
+let prepare_managed_paths ~link ~sandboxed deps ~eval_pred =
   let steps =
     Path.Set.fold (Dep.Set.paths deps ~eval_pred) ~init:[]
       ~f:(fun path acc ->
         match Path.as_in_build_dir path with
         | None ->
+          (* This can actually raise if we try to sandbox the "copy from
+             source dir" rules. There is no reason to do that though. *)
           assert (not (Path.is_in_source_tree path));
           acc
-        | Some p -> Symlink (path, sandboxed p) :: acc)
+        | Some p -> link path (sandboxed p) :: acc)
   in
   Progn steps
 
+let link_function ~(mode : Sandbox_mode.some) : path -> target -> t =
+  match mode with
+  | Symlink ->
+    if Sys.win32 then
+      Code_error.raise
+        "Don't have symlinks on win32, but [Symlink] sandboxing \
+         mode was selected. To use emulation via copy, the [Copy] sandboxing \
+         mode should be selected." []
+    else
+      (fun a b -> Symlink (a, b))
+  | Copy ->
+    (fun a b -> Copy (a, b))
+
 let maybe_sandbox_path f p =
   match Path.as_in_build_dir p with
   | None -> p
   | Some p -> Path.build (f p)
 
-let sandbox t ~sandboxed ~deps ~targets ~eval_pred : t =
+let sandbox t ~sandboxed ~mode ~deps ~eval_pred : t =
+  let link = link_function ~mode in
   Progn
-    [ symlink_managed_paths sandboxed deps ~eval_pred
+    [ prepare_managed_paths ~sandboxed ~link deps ~eval_pred
     ; map t
         ~dir:Path.root
         ~f_string:(fun ~dir:_ x -> x)
         ~f_path:(fun ~dir:_ p -> maybe_sandbox_path sandboxed p)
         ~f_target:(fun ~dir:_ -> sandboxed)
         ~f_program:(fun ~dir:_ ->
           Result.map ~f:(maybe_sandbox_path sandboxed))
-    ; Progn (List.filter_map targets ~f:(fun path ->
-        Some (Rename (sandboxed path, path))))
     ]
+
+type is_useful_to_sandbox =
+  | Clearly_not
+  | Maybe
+
+let is_useful_to_sandbox =
+  let rec loop t =
+    match t with
+    | Chdir (_, t) ->
+      loop t
+    | Setenv (_, _, t) ->
+      loop t
+    | Redirect (_, _, t) ->
+      loop t
+    | Ignore (_, t) ->
+      loop t
+    | Progn l -> List.exists l ~f:loop
+    | Echo _ -> false
+    | Cat _ -> false
+    | Copy _ -> false
+    | Symlink _ -> false
+    | Copy_and_add_line_directive _ -> false
+    | Write_file _ -> false
+    | Rename _ -> false
+    | Remove_tree _ -> false
+    | Diff _ -> false
+    | Mkdir _ -> false
+    | Digest_files _ -> false
+    | Merge_files_into _ -> false
+    | Run _ -> true
+    | System _ -> true
+    | Bash _ -> true
+  in
+  fun t -> match loop t with
+    | true ->
+      Maybe
+    | false ->
+      Clearly_not

src/action.mli

@@ -80,11 +80,19 @@ module Unresolved : sig
   val resolve : t -> f:(Loc.t option -> string -> Path.t) -> action
 end with type action := t
 
-(** Return a sandboxed version of an action *)
+(** Return a sandboxed version of an action.
+    It takes care of preparing deps in the sandbox, but it does not copy the
+    targets back out. It's the responsibility of the caller to do that. *)
 val sandbox
   :  t
   -> sandboxed:(Path.Build.t -> Path.Build.t)
+  -> mode:Sandbox_mode.some
   -> deps:Dep.Set.t
-  -> targets:Path.Build.t list
   -> eval_pred:Dep.eval_pred
   -> t
+
+type is_useful_to_sandbox =
+  | Clearly_not
+  | Maybe
+
+val is_useful_to_sandbox : t -> is_useful_to_sandbox

src/action_exec.ml

@@ -94,7 +94,7 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
     Io.with_file_in src ~f:(fun ic ->
       Path.build dst
       |> Io.with_file_out ~f:(fun oc ->
-        let fn = Path.drop_optional_build_context src in
+        let fn = Path.drop_optional_build_context_maybe_sandboxed src in
         output_string oc
           (Utils.line_directive
              ~filename:(Path.to_string fn)
@@ -142,15 +142,17 @@ let rec exec t ~ectx ~dir ~env ~stdout_to ~stderr_to =
       Fiber.return ()
     else begin
       let is_copied_from_source_tree file =
-        match Path.drop_build_context file with
+        match Path.extract_build_context_dir_maybe_sandboxed file with
         | None -> false
-        | Some file -> Path.exists (Path.source file)
+        | Some (_, file) -> Path.exists (Path.source file)
       in
       if is_copied_from_source_tree file1 &&
          not (is_copied_from_source_tree file2) then begin
         Promotion.File.register
-          { src = Path.as_in_build_dir_exn file2
-          ; dst = Option.value_exn (Path.drop_build_context file1)
+          { src = snd (Path.Build.split_sandbox_root (
+              Path.as_in_build_dir_exn file2))
+          ; dst = snd (Option.value_exn (
+              Path.extract_build_context_dir_maybe_sandboxed file1))
           }
       end;
       if mode = Binary then

src/alias.ml

@@ -61,15 +61,18 @@ let suffix = "-" ^ String.make 32 '0'
 let name t = t.name
 let dir  t = t.dir
 
-let fully_qualified_name t = Path.Build.relative t.dir t.name
-
 (* Where we store stamp files for aliases *)
 let alias_dir = Path.Build.(relative root ".aliases")
 
-let stamp_file t =
+let stamp_file_dir t =
   let local = Path.Build.local t.dir in
+  Path.Build.append_local alias_dir local
+
+let fully_qualified_name t = Path.Build.relative t.dir t.name
+
+let stamp_file t =
   Path.Build.relative
-    (Path.Build.append_local alias_dir local)
+    (stamp_file_dir t)
     (t.name ^ suffix)
 
 let find_dir_specified_on_command_line ~dir ~file_tree =

src/alias.mli

@@ -18,6 +18,7 @@ val make : string -> dir:Path.Build.t -> t
 *)
 val name : t -> string
 val dir : t -> Path.Build.t
+val stamp_file_dir : t -> Path.Build.t
 
 val to_dyn : t -> Dyn.t