Move the sandbox configuration as a field of Action.Full.t (#5080)

Signed-off-by: Jeremie Dimino <jeremie@dimino.org>

src/dune_engine/action.ml

@@ -283,30 +283,40 @@ module Full = struct
       ; env : Env.t
       ; locks : Path.t list
       ; can_go_in_shared_cache : bool
+      ; sandbox : Sandbox_config.t
       }
 
     let empty =
       { action = Progn []
       ; env = Env.empty
       ; locks = []
       ; can_go_in_shared_cache = true
+      ; sandbox = Sandbox_config.default
       }
 
-    let combine { action; env; locks; can_go_in_shared_cache } x =
+    let combine { action; env; locks; can_go_in_shared_cache; sandbox } x =
       { action = combine action x.action
       ; env = Env.extend_env env x.env
       ; locks = locks @ x.locks
       ; can_go_in_shared_cache =
           can_go_in_shared_cache && x.can_go_in_shared_cache
+      ; sandbox = Sandbox_config.inter sandbox x.sandbox
       }
   end
 
   include T
   include Monoid.Make (T)
 
   let make ?(env = Env.empty) ?(locks = []) ?(can_go_in_shared_cache = true)
-      action =
-    { action; env; locks; can_go_in_shared_cache }
+      ?(sandbox = Sandbox_config.default) action =
+    { action; env; locks; can_go_in_shared_cache; sandbox }
 
   let map t ~f = { t with action = f t.action }
+
+  let add_locks l t = { t with locks = t.locks @ l }
+
+  let add_can_go_in_shared_cache b t =
+    { t with can_go_in_shared_cache = t.can_go_in_shared_cache && b }
+
+  let add_sandbox s t = { t with sandbox = Sandbox_config.inter t.sandbox s }
 end

src/dune_engine/action.mli

@@ -127,16 +127,29 @@ module Full : sig
     ; env : Env.t
     ; locks : Path.t list
     ; can_go_in_shared_cache : bool
+    ; sandbox : Sandbox_config.t
     }
 
   val make :
        ?env:Env.t (** default [Env.empty] *)
     -> ?locks:Path.t list (** default [\[\]] *)
     -> ?can_go_in_shared_cache:bool (** default [true] *)
+    -> ?sandbox:Sandbox_config.t (** default [Sandbox_config.default] *)
     -> action
     -> t
 
   val map : t -> f:(action -> action) -> t
 
+  (** The various [add_xxx] functions merge the given value with existing field
+      of the action. Put another way, [add_xxx x t] is the same as:
+
+      {[ combine t (make ~xxx:x (Progn [])) ]} *)
+
+  val add_locks : Path.t list -> t -> t
+
+  val add_sandbox : Sandbox_config.t -> t -> t
+
+  val add_can_go_in_shared_cache : bool -> t -> t
+
   include Monoid with type t := t
 end

src/dune_engine/build_system.ml

@@ -729,15 +729,14 @@ end = struct
                     ; env = Env.empty
                     ; locks = []
                     ; can_go_in_shared_cache = true
+                    ; (* There's an [assert false] in [prepare_managed_paths]
+                         that blows up if we try to sandbox this. *)
+                      sandbox = Sandbox_config.no_sandboxing
                     }
                   , Dep.Map.singleton (Dep.file path) fact ))
             }
         in
-        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 ~context:None
-          ~info:(Source_file_copy path)
+        Rule.make ~context:None ~info:(Source_file_copy path)
           ~targets:(Targets.File.create ctx_path)
           build)
 
@@ -1310,8 +1309,7 @@ end = struct
          dir-digest pairs [digests] *)
       Dep.Fact.file_selector g digests
     | Universe
-    | Env _
-    | Sandbox_config _ ->
+    | Env _ ->
       (* Facts about these dependencies are constructed in
          [Dep.Facts.digest]. *)
       Memo.Build.return Dep.Fact.nothing
@@ -1373,18 +1371,26 @@ end = struct
 
   (* The current version of the rule digest scheme. We should increment it when
      making any changes to the scheme, to avoid collisions. *)
-  let rule_digest_version = 7
+  let rule_digest_version = 8
 
   let compute_rule_digest (rule : Rule.t) ~deps ~action ~sandbox_mode
       ~execution_parameters =
-    let { Action.Full.action; env; locks; can_go_in_shared_cache } = action in
+    let { Action.Full.action
+        ; env
+        ; locks
+        ; can_go_in_shared_cache
+        ; sandbox = _ (* already taken into account in [sandbox_mode] *)
+        } =
+      action
+    in
     let file_targets, dir_targets =
       Targets.partition_map rule.targets ~file:Path.Build.to_string
         ~dir:Path.Build.to_string
     in
     let trace =
       ( rule_digest_version (* Update when changing the rule digest scheme. *)
-      , Dep.Facts.digest deps ~sandbox_mode ~env
+      , sandbox_mode
+      , Dep.Facts.digest deps ~env
       , file_targets @ dir_targets
       , Option.map rule.context ~f:(fun c -> Context_name.to_string c.name)
       , Action.for_shell action
@@ -1462,7 +1468,12 @@ end = struct
       Targets.map targets ~f:(fun ~files ~dirs ->
           (files, not (Path.Build.Set.is_empty dirs)))
     in
-    let { Action.Full.action; env; locks; can_go_in_shared_cache = _ } =
+    let { Action.Full.action
+        ; env
+        ; locks
+        ; can_go_in_shared_cache = _
+        ; sandbox = _
+        } =
       action
     in
     pending_targets := Path.Build.Set.union file_targets !pending_targets;
@@ -1639,6 +1650,22 @@ end = struct
                   reason)
            ])
 
+  let adapt_action_for_patch_back_source_tree (action : Action.Full.t) =
+    (* Rules that patch back the source tree cannot go in the shared cache *)
+    let can_go_in_shared_cache = false in
+    (* Rules that patch back the source tree must be sandboxed in copy mode.
+
+       If the user specifies (sandbox none), then we get a slightly confusing
+       error message. We could detect this case at parsing time and produce a
+       better error message. It's a bit awkard to implement this check at the
+       moment as the sandbox config is specified in the dependencies, but we
+       plan to change that in the future. *)
+    let sandbox =
+      Sandbox_config.inter action.sandbox
+        (Sandbox_mode.Set.singleton Sandbox_mode.copy)
+    in
+    { action with can_go_in_shared_cache; sandbox }
+
   let execute_rule_impl ~rule_kind rule =
     let t = t () in
     let { Rule.id = _; targets; dir; context; mode; action; info = _; loc } =
@@ -1661,10 +1688,8 @@ end = struct
        here by executing it sequentially. *)
     let* action, deps = Action_builder.run action Eager in
     let action =
-      (* Rules that patch back the source tree cannot go in the shared cache *)
-      match (mode, action.can_go_in_shared_cache) with
-      | Patch_back_source_tree, true ->
-        { action with can_go_in_shared_cache = false }
+      match mode with
+      | Patch_back_source_tree -> adapt_action_for_patch_back_source_tree action
       | _ -> action
     in
     let wrap_fiber f =
@@ -1687,8 +1712,7 @@ end = struct
         let sandbox_mode =
           match Action.is_useful_to_sandbox action.action with
           | Clearly_not ->
-            let config = Dep.Map.sandbox_config deps in
-            if Sandbox_config.mem config Sandbox_mode.none then
+            if Sandbox_config.mem action.sandbox Sandbox_mode.none then
               Sandbox_mode.none
             else
               User_error.raise ~loc
@@ -1698,8 +1722,7 @@ end = struct
                      require sandboxing."
                 ]
           | Maybe ->
-            select_sandbox_mode ~loc
-              (Dep.Map.sandbox_config deps)
+            select_sandbox_mode ~loc action.sandbox
               ~sandboxing_preference:t.sandboxing_preference
         in
         let always_rerun =
@@ -1785,9 +1808,7 @@ end = struct
                 | (deps, old_digest) :: rest ->
                   let deps = Action_exec.Dynamic_dep.Set.to_dep_set deps in
                   let* deps = Memo.Build.run (build_deps deps) in
-                  let new_digest =
-                    Dep.Facts.digest deps ~sandbox_mode ~env:action.env
-                  in
+                  let new_digest = Dep.Facts.digest deps ~env:action.env in
                   if old_digest = new_digest then
                     loop rest
                   else
@@ -1907,9 +1928,7 @@ end = struct
                 let dynamic_deps_stages =
                   List.map exec_result.action_exec_result.dynamic_deps_stages
                     ~f:(fun (deps, fact_map) ->
-                      ( deps
-                      , Dep.Facts.digest fact_map ~sandbox_mode ~env:action.env
-                      ))
+                      (deps, Dep.Facts.digest fact_map ~env:action.env))
                 in
                 let targets_digest =
                   digest_of_target_digests targets_and_digests
@@ -2060,16 +2079,16 @@ end = struct
     let observing_facts = () in
     ignore observing_facts;
     let act =
-      (* Actions that patch back the source tree cannot go in the shared
-         cache *)
-      if act.patch_back_source_tree && act.action.can_go_in_shared_cache then
-        { act with action = { act.action with can_go_in_shared_cache = false } }
+      (* Actions that patch back the source tree cannot go in the shared cache
+         and must be sandboxed *)
+      if act.patch_back_source_tree then
+        { act with action = adapt_action_for_patch_back_source_tree act.action }
       else
         act
     in
     let digest =
       let { Rule.Anonymous_action.context
-          ; action = { action; env; locks; can_go_in_shared_cache }
+          ; action = { action; env; locks; can_go_in_shared_cache; sandbox }
           ; loc
           ; dir
           ; alias
@@ -2106,7 +2125,8 @@ end = struct
         , alias
         , capture_stdout
         , can_go_in_shared_cache
-        , patch_back_source_tree )
+        , patch_back_source_tree
+        , sandbox )
     in
     (* It might seem superfluous to memoize the execution here, given that a
        given anonymous action will typically only appear once during a given

src/dune_engine/dep.ml

@@ -10,7 +10,6 @@ module T = struct
     | Alias of Alias.t
     | File_selector of File_selector.t
     | Universe
-    | Sandbox_config of Sandbox_config.t
 
   module Stable_for_digest = struct
     type t =
@@ -22,7 +21,6 @@ module T = struct
           }
       | File_selector of Dyn.t
       | Universe
-      | Sandbox_config of Sandbox_config.t
   end
 
   let env e = Env e
@@ -35,8 +33,6 @@ module T = struct
 
   let file_selector g = File_selector g
 
-  let sandbox_config config = Sandbox_config config
-
   let compare x y =
     match (x, y) with
     | Env x, Env y -> Env.Var.compare x y
@@ -52,30 +48,15 @@ module T = struct
     | File_selector _, _ -> Lt
     | _, File_selector _ -> Gt
     | Universe, Universe -> Ordering.Eq
-    | Universe, _ -> Lt
-    | _, Universe -> Gt
-    | Sandbox_config x, Sandbox_config y -> Sandbox_config.compare x y
 
   let encode t =
     let open Dune_lang.Encoder in
-    let sandbox_config (config : Sandbox_config.t) =
-      list
-        (fun x -> x)
-        (List.filter_map Sandbox_mode.all ~f:(fun mode ->
-             if not (Sandbox_config.mem config mode) then
-               Some
-                 (pair string string ("disallow", Sandbox_mode.to_string mode))
-             else
-               None))
-    in
     match t with
     | File_selector g -> pair string File_selector.encode ("glob", g)
     | Env e -> pair string string ("Env", e)
     | File f -> pair string Dpath.encode ("File", f)
     | Alias a -> pair string Alias.encode ("Alias", a)
     | Universe -> string "Universe"
-    | Sandbox_config config ->
-      pair string sandbox_config ("Sandbox_config", config)
 
   let to_dyn t = Dyn.String (Dune_lang.to_string (encode t))
 end
@@ -87,17 +68,6 @@ module Map = struct
   include O.Map
   include Memo.Build.Make_map_traversals (O.Map)
 
-  let sandbox_config t =
-    foldi t ~init:Sandbox_config.no_special_requirements ~f:(fun x _ acc ->
-        match x with
-        | File_selector _
-        | Env _
-        | File _
-        | Alias _
-        | Universe ->
-          acc
-        | Sandbox_config config -> Sandbox_config.inter acc config)
-
   let has_universe t = mem t Universe
 end
 
@@ -315,18 +285,14 @@ module Facts = struct
         | Alias ps ->
           Path.Set.union acc ps.parent_dirs)
 
-  let digest t ~sandbox_mode ~env =
+  let digest t ~env =
     let facts =
       let file (p, d) = (Path.to_string p, d) in
       Map.foldi t ~init:[]
         ~f:(fun dep fact acc : Fact.Stable_for_digest.t list ->
           match dep with
           | Env var -> Env (var, Env.get env var) :: acc
           | Universe -> acc
-          | Sandbox_config config ->
-            assert (Sandbox_config.mem config sandbox_mode);
-            (* recorded globally for the whole dep set, see below *)
-            acc
           | File _
           | File_selector _
           | Alias _ -> (
@@ -336,7 +302,7 @@ module Facts = struct
             | File_selector (id, ps) -> File_selector (id, ps.digest) :: acc
             | Alias ps -> Alias ps.digest :: acc))
     in
-    Digest.generic (sandbox_mode, facts)
+    Digest.generic facts
 end
 
 module Set = struct
@@ -432,7 +398,6 @@ module Set = struct
         match dep with
         | Env var -> Env var :: acc
         | Universe -> Universe :: acc
-        | Sandbox_config config -> Sandbox_config config :: acc
         | File p -> File (Path.to_string p) :: acc
         | File_selector fs -> File_selector (File_selector.to_dyn fs) :: acc
         | Alias a ->