Global sandboxing setting

CHANGES.md

@@ -15,6 +15,12 @@
   is done to prevent the accidental collision with library dependencies of the
   executable. (#2364, fixes #2292, @rgrinberg)
 
+- 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 (unreleased)
 -------------------
 

bin/common.ml

@@ -327,6 +327,27 @@ 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"]
+             ~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 +483,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 ());

src/action.ml

@@ -173,26 +173,42 @@ 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 ~targets ~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)

src/action.mli

@@ -84,6 +84,7 @@ end with type action := t
 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

src/build_system.ml

@@ -120,7 +120,6 @@ module Internal_rule = struct
       ; info             : Rule.Info.t
       ; dir              : Path.Build.t
       ; env              : Env.t option
-      ; sandbox          : bool
       ; locks            : Path.t list
       ; (* Reverse dependencies discovered so far, labelled by the
            requested target *)
@@ -166,7 +165,6 @@ module Internal_rule = struct
     ; info        = Internal
     ; dir         = Path.Build.root
     ; env         = None
-    ; sandbox     = false
     ; locks       = []
     ; rev_deps    = []
     ; transitive_rev_deps = Id.Set.empty
@@ -420,6 +418,7 @@ type t =
   ; hook : hook -> unit
   ; (* Package files are part of *)
     packages : (Path.Build.t -> Package.Name.Set.t) Fdecl.t
+  ; sandboxing_preference : Sandbox_mode.t list
   }
 
 let t = ref None
@@ -720,7 +719,6 @@ end = struct
         ; env
         ; build
         ; targets
-        ; sandbox
         ; mode
         ; locks
         ; info
@@ -738,7 +736,6 @@ end = struct
       ; build
       ; context
       ; env
-      ; sandbox
       ; locks
       ; mode
       ; info
@@ -760,7 +757,11 @@ end = struct
     |> List.map ~f:(fun path ->
       let ctx_path = Path.Build.append_source ctx_dir path in
       let build = Build.copy ~src:(Path.source path) ~dst:ctx_path in
-      Pre_rule.make build ~context:None ~env:None ~info:Source_file_copy)
+      Pre_rule.make
+        (* There's an [assert false] in [prepare_managed_paths] that blows up
+           if we try to sandbox this. *)
+        ~sandbox:Sandbox_config.no_sandboxing
+        build ~context:None ~env:None ~info:Source_file_copy)
 
   let compile_rules ~dir rules =
     List.concat_map rules ~f:(fun rule ->
@@ -825,6 +826,8 @@ end = struct
                       in
                       let rule =
                         Pre_rule.make ~locks ~context:(Some context) ~env
+                          (* [no_sandboxing] here is necessary for some reason *)
+                          ~sandbox:Sandbox_config.no_sandboxing
                           ~info:(Rule.Info.of_loc_opt loc)
                           (Build.progn [ action; Build.create_file path ])
                       in
@@ -1341,7 +1344,9 @@ end = struct
       | File f -> build_file f
       | Glob g -> Pred.build g
       | Universe
-      | Env _ -> Fiber.return ())
+      | Env _ -> Fiber.return ()
+      | Sandbox_config _ -> Fiber.return ()
+    )
 
   let eval_pred = Pred.eval
 
@@ -1366,6 +1371,34 @@ end = struct
   let evaluate_action_and_dynamic_deps =
     Memo.exec evaluate_action_and_dynamic_deps_memo
 
+  let select_sandbox_mode
+        (config : Sandbox_config.t) ~loc ~sandboxing_preference =
+    match
+      List.find_map sandboxing_preference ~f:(fun preference ->
+        match (preference, config) with
+        | None, { none = true; _ } ->
+          Some None
+        | Some Sandbox_mode.Copy, { copy = true; _ } ->
+          Some (Some Sandbox_mode.Copy)
+        | Some Symlink, { symlink = true; copy; _ } ->
+          (if copy then
+             Some (Some (if Sys.win32 then Copy else Symlink))
+           else
+             Code_error.raise
+               "This rule requires sandboxing with symlinks, but that won't \
+                work on Windows." [])
+        | _, _ -> None) with
+    | None ->
+      (* This is not trivial to reach because the user rules are checked
+         at parse time and [sandboxing_preference] always includes all possible
+         modes. However, it can still be reached if multiple sandbox config
+         specs are combined into an unsatisfiable one. *)
+      User_error.raise
+        ~loc
+        [ Pp.text "This rule forbids all sandboxing \
+                   modes (but it also requires sandboxing)" ]
+    | Some choice -> choice
+
   let evaluate_rule (rule : Internal_rule.t) =
     let* static_deps = Fiber.Once.get rule.static_deps in
     let+ (action, dynamic_action_deps) = evaluate_action_and_dynamic_deps rule in
@@ -1413,7 +1446,6 @@ end = struct
         ; env
         ; context
         ; mode
-        ; sandbox
         ; locks
         ; id = _
         ; static_deps = _
@@ -1429,6 +1461,12 @@ end = struct
     let targets_as_list  = Path.Build.Set.to_list targets  in
     let head_target = List.hd targets_as_list in
     let prev_trace = Trace.get (Path.build head_target) in
+    let sandbox_mode =
+      select_sandbox_mode
+        ~loc:(rule_loc ~file_tree:t.file_tree ~info ~dir)
+        (Dep.Set.sandbox_config deps)
+        ~sandboxing_preference:t.sandboxing_preference
+    in
     let rule_digest =
       let env =
         match env, context with
@@ -1437,7 +1475,7 @@ end = struct
         | None, Some c -> c.env
       in
       let trace =
-        ( Dep.Set.trace deps ~env ~eval_pred
+        ( Dep.Set.trace deps ~sandbox_mode ~env ~eval_pred
         , List.map targets_as_list ~f:(fun p -> Path.to_string (Path.build p))
         , Option.map context ~f:(fun c -> c.name)
         , Action.for_shell action
@@ -1451,11 +1489,12 @@ end = struct
       | l -> Some (Digest.generic l)
       | exception (Unix.Unix_error _ | Sys_error _) -> None
     in
-    let sandbox_dir =
-      if sandbox then
+    let sandbox =
+      match sandbox_mode with
+      | Some mode ->
         let digest = Digest.to_string rule_digest in
-        Some (Path.Build.relative sandbox_dir digest)
-      else
+        Some (Path.Build.relative sandbox_dir digest, mode)
+      | None ->
         None
     in
     let force =
@@ -1476,10 +1515,10 @@ end = struct
         pending_targets := Path.Build.Set.union targets !pending_targets;
         let loc = Rule.Info.loc info in
         let action =
-          match sandbox_dir with
+          match sandbox with
           | None ->
             action
-          | Some sandbox_dir ->
+          | Some (sandbox_dir, sandbox_mode) ->
             Path.rm_rf (Path.build sandbox_dir);
             let sandboxed path : Path.Build.t =
               Path.Build.append_local sandbox_dir
@@ -1493,6 +1532,7 @@ end = struct
             Fs.mkdir_p (sandboxed dir);
             Action.sandbox action
               ~sandboxed
+              ~mode:sandbox_mode
               ~deps
               ~targets:targets_as_list
               ~eval_pred
@@ -1503,7 +1543,7 @@ end = struct
           with_locks locks ~f:(fun () ->
             Action_exec.exec ~context ~env ~targets action)
         in
-        Option.iter sandbox_dir ~f:(fun p -> Path.rm_rf (Path.build p));
+        Option.iter sandbox ~f:(fun (p, _mode) -> Path.rm_rf (Path.build p));
         (* All went well, these targets are no longer pending *)
         pending_targets := Path.Build.Set.diff !pending_targets targets;
         let targets_digest =
@@ -1951,7 +1991,7 @@ let load_dir_and_produce_its_rules ~dir =
 
 let load_dir ~dir = load_dir_and_produce_its_rules ~dir
 
-let init ~contexts ~file_tree ~hook =
+let init ~contexts ~file_tree ~hook ~sandboxing_preference =
   let contexts =
     List.map contexts ~f:(fun c -> (c.Context.name, c))
     |> String.Map.of_list_exn
@@ -1964,6 +2004,7 @@ let init ~contexts ~file_tree ~hook =
     ; gen_rules = Fdecl.create ()
     ; init_rules = Fdecl.create ()
     ; hook
+    ; sandboxing_preference = sandboxing_preference @ Sandbox_mode.all
     }
   in
   set t

src/build_system.mli

@@ -16,6 +16,7 @@ val init
   :  contexts:Context.t list
   -> file_tree:File_tree.t
   -> hook:(hook -> unit)
+  -> sandboxing_preference:Sandbox_mode.t list
   -> unit
 
 val reset : unit -> unit

src/compilation_context.ml

@@ -59,7 +59,7 @@ type t =
   ; stdlib               : Dune_file.Library.Stdlib.t option
   ; js_of_ocaml          : Dune_file.Js_of_ocaml.t option
   ; dynlink              : bool
-  ; sandbox              : bool option
+  ; sandbox              : Sandbox_config.t
   ; package              : Package.t option
   ; vimpl                : Vimpl.t option
   }
@@ -91,13 +91,22 @@ let create ~super_context ~scope ~expander ~obj_dir
       ?(dir_kind=Dune_lang.File_syntax.Dune)
       ~modules ~flags ~requires_compile ~requires_link
       ?(preprocessing=Preprocessing.dummy) ?(no_keep_locs=false)
-      ~opaque ?stdlib ?js_of_ocaml ~dynlink ?sandbox ~package ?vimpl () =
+      ~opaque ?stdlib ?js_of_ocaml ~dynlink ~package ?vimpl () =
   let requires_compile =
     if Dune_project.implicit_transitive_deps (Scope.project scope) then
       Lazy.force requires_link
     else
       requires_compile
   in
+  let sandbox =
+    (* With sandboxing, there are a few build errors in ocaml platform
+       1162238ae like:
+       File "ocaml_modules/ocamlgraph/src/pack.ml", line 1:
+       Error: The implementation ocaml_modules/ocamlgraph/src/pack.ml
+       does not match the interface ocaml_modules/ocamlgraph/src/.graph.objs/byte/graph__Pack.cmi:
+    *)
+    Sandbox_config.no_sandboxing
+  in
   { super_context
   ; scope
   ; expander
@@ -128,17 +137,21 @@ let for_alias_module t =
   let sandbox =
     let ctx = Super_context.context t.super_context in
     (* If the compiler reads the cmi for module alias even with [-w -49
-    -no-alias-deps], we must sandbox the build of the alias module since the
-    modules it references are built after. *)
-    Ocaml_version.always_reads_alias_cmi ctx.version
+       -no-alias-deps], we must sandbox the build of the alias module since the
+       modules it references are built after. *)
+    if Ocaml_version.always_reads_alias_cmi ctx.version
+    then
+      Sandbox_config.needs_sandboxing
+    else
+      Sandbox_config.no_special_requirements
   in
   { t with
     flags =
       Ocaml_flags.append_common flags
         ["-w"; "-49"; "-nopervasives"; "-nostdlib"]
   ; includes     = Includes.empty
   ; stdlib       = None
-  ; sandbox      = Some sandbox
+  ; sandbox      = sandbox
   }
 
 let for_wrapped_compat t =