explore an idea: why not treat sandbox requirement as one of the depe…

…ndencies

Signed-off-by: Arseniy Alekseyev <[email protected]>

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          : Sandbox_config.t
       ; 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     = Sandbox_config.no_special_requirements
     ; locks       = []
     ; rev_deps    = []
     ; transitive_rev_deps = Id.Set.empty
@@ -721,7 +719,6 @@ end = struct
         ; env
         ; build
         ; targets
-        ; sandbox
         ; mode
         ; locks
         ; info
@@ -739,7 +736,6 @@ end = struct
       ; build
       ; context
       ; env
-      ; sandbox
       ; locks
       ; mode
       ; info
@@ -1348,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
 
@@ -1442,7 +1440,6 @@ end = struct
         ; env
         ; context
         ; mode
-        ; sandbox
         ; locks
         ; id = _
         ; static_deps = _
@@ -1459,7 +1456,9 @@ end = struct
     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 sandbox ~sandboxing_preference:t.sandboxing_preference
+      select_sandbox_mode
+        (Dep.Set.sandbox_config deps)
+        ~sandboxing_preference:t.sandboxing_preference
     in
     let rule_digest =
       let env =
@@ -1469,11 +1468,10 @@ 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
-        , (sandbox_mode : Sandbox_mode.t)
         )
       in
       Digest.generic trace

src/dep.ml

@@ -1,7 +1,10 @@
 open Stdune
 
 module Trace = struct
-  type t = (string * Digest.t) list
+  type t = {
+    sandbox_mode : Sandbox_mode.t;
+    files : (string * Digest.t) list;
+  }
 end
 
 module T = struct
@@ -11,12 +14,14 @@ module T = struct
     | Alias of Alias.t
     | Glob of File_selector.t
     | Universe
+    | Sandbox_config of Sandbox_config.t
 
   let env e = Env e
   let file f = File f
   let alias a = Alias a
   let universe = Universe
   let glob g = Glob g
+  let sandbox_config config = Sandbox_config config
 
   let compare x y =
     match x, y with
@@ -33,12 +38,16 @@ module T = struct
     | Glob _, _ -> Lt
     | _, Glob _ -> Gt
     | Universe, Universe -> Ordering.Eq
+    | Universe, _ -> Lt
+    | _, Universe -> Gt
+    | Sandbox_config x, Sandbox_config y ->
+      Sandbox_config.compare x y
 
   let unset = lazy (Digest.string "unset")
 
   let trace_file fn = (Path.to_string fn, Cached_digest.file fn)
 
-  let trace t ~env ~eval_pred =
+  let trace t ~sandbox_mode ~env ~eval_pred =
     match t with
     | Universe -> ["universe", Digest.string "universe"]
     | File fn -> [trace_file fn]
@@ -55,15 +64,36 @@ module T = struct
         end
       in
       [var, value]
+    | Sandbox_config config ->
+      assert (Sandbox_config.mem config sandbox_mode);
+      (* recorded globally for the whole dep set *)
+      []
 
   let encode t =
     let open Dune_lang.Encoder in
+    let sandbox_mode (mode : Sandbox_mode.t) =
+      match mode with
+      | None -> "none"
+      | Some Copy -> "copy"
+      | Some Symlink -> "symlink"
+    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 mode))
+          else
+            None))
+    in
     match t with
     | Glob 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 _ = Dyn.opaque
 end
@@ -78,13 +108,26 @@ module Set = struct
 
   let has_universe t = mem t Universe
 
+  let sandbox_config t =
+    List.fold_left (to_list t) ~init:(Sandbox_config.no_special_requirements)
+      ~f:(fun acc x -> match x with
+        | Glob _ | Env _ | File _ | Alias _ | Universe -> acc
+        | Sandbox_config config ->
+          Sandbox_config.inter acc config)
+
   let of_files = List.fold_left ~init:empty ~f:(fun acc f -> add acc (file f))
 
   let of_files_set =
     Path.Set.fold ~init:empty ~f:(fun f acc -> add acc (file f))
 
-  let trace t ~env ~eval_pred =
-    List.concat_map (to_list t) ~f:(trace ~env ~eval_pred)
+  let trace t ~sandbox_mode ~env ~eval_pred =
+    let files =
+      List.concat_map (to_list t) ~f:(trace ~sandbox_mode ~env ~eval_pred)
+    in
+    { Trace.
+      files;
+      sandbox_mode;
+    }
 
   let add_paths t paths =
     Path.Set.fold paths ~init:t ~f:(fun p set -> add set (File p))
@@ -98,7 +141,8 @@ module Set = struct
       | File f -> Path.Set.add acc f
       | Glob g -> Path.Set.union acc (eval_pred g)
       | Universe
-      | Env _ -> acc)
+      | Env _ -> acc
+      | Sandbox_config _ -> acc)
 
   let parallel_iter t ~f = Fiber.parallel_iter ~f (to_list t)
 
@@ -114,7 +158,8 @@ module Set = struct
       | Glob g -> Path.Set.add acc (File_selector.dir g)
       | File f -> Path.Set.add acc (Path.parent_exn f)
       | Universe
-      | Env _ -> acc)
+      | Env _ -> acc
+      | Sandbox_config _ -> acc)
 end
 
 type eval_pred = File_selector.t -> Path.Set.t

src/dep.mli

@@ -6,12 +6,14 @@ type t = private
   | Alias of Alias.t
   | Glob of File_selector.t
   | Universe
+  | Sandbox_config of Sandbox_config.t
 
 val file : Path.t -> t
 val env : Env.Var.t -> t
 val universe : t
 val glob : File_selector.t -> t
 val alias : Alias.t -> t
+val sandbox_config : Sandbox_config.t -> t
 
 val compare : t -> t -> Ordering.t
 
@@ -26,6 +28,8 @@ module Set : sig
 
   val has_universe : t -> bool
 
+  val sandbox_config : t -> Sandbox_config.t
+
   val of_files : Path.t list -> t
 
   val of_files_set : Path.Set.t -> t
@@ -34,7 +38,8 @@ module Set : sig
 
   val encode : t -> Dune_lang.t
 
-  val trace : t -> env:Env.t -> eval_pred:eval_pred -> Trace.t
+  val trace :
+    t -> sandbox_mode:Sandbox_mode.t -> env:Env.t -> eval_pred:eval_pred -> Trace.t
 
   val add_paths : t -> Path.Set.t -> t
 

src/dune_file.ml

@@ -236,6 +236,7 @@ module Dep_conf = struct
     | Package of String_with_vars.t
     | Universe
     | Env_var of String_with_vars.t
+    | Sandbox_config of Sandbox_config.t
 
   let remove_locs = function
     | File sw -> File (String_with_vars.remove_locs sw)
@@ -246,6 +247,7 @@ module Dep_conf = struct
     | Package sw -> Package (String_with_vars.remove_locs sw)
     | Universe -> Universe
     | Env_var sw -> Env_var sw
+    | Sandbox_config s -> Sandbox_config s
 
   let decode =
     let decode =
@@ -298,6 +300,11 @@ module Dep_conf = struct
     | Env_var t ->
       List [ Dune_lang.unsafe_atom_of_string "env_var"
            ; String_with_vars.encode t]
+    | Sandbox_config config ->
+      if Sandbox_config.equal config Sandbox_config.no_special_requirements
+      then
+        List []
+      else Code_error.raise "There's no syntax for [Sandbox_config] yet" []
 
   let to_dyn t = Dune_lang.to_dyn (encode t)
 end
@@ -434,15 +441,15 @@ module Per_module = struct
             let+ x =
               repeat
                 (let+ (pp, names) = pair a (list module_name) in
-                (names, pp))
+                 (names, pp))
             in
             of_mapping x ~default
             |> function
             | Ok t -> t
             | Error (name, _, _) ->
               User_error.raise ~loc
                 [ Pp.textf "module %s present in two different sets"
-                (Module.Name.to_string name) ]
+                    (Module.Name.to_string name) ]
           ]
     | _ -> a >>| for_all
 end
@@ -536,7 +543,7 @@ module Lib_dep = struct
             Option.iter (Lib_name.Set.choose common) ~f:(fun name ->
               User_error.raise ~loc
                 [ Pp.textf "library %S is both required and forbidden in this clause"
-                (Lib_name.to_string name) ]);
+                    (Lib_name.to_string name) ]);
             { required
             ; forbidden
             ; file
@@ -593,19 +600,19 @@ module Lib_deps = struct
         match kind, kind' with
         | Required, Required ->
           User_error.raise ~loc [ Pp.textf "library %S is present twice"
-            (Lib_name.to_string name) ]
+                                    (Lib_name.to_string name) ]
         | (Optional|Forbidden), (Optional|Forbidden) ->
           acc
         | Optional, Required | Required, Optional ->
           User_error.raise ~loc
             [ Pp.textf "library %S is present both as an optional \
-             and required dependency"
-            (Lib_name.to_string name) ]
+                        and required dependency"
+                (Lib_name.to_string name) ]
         | Forbidden, Required | Required, Forbidden ->
           User_error.raise ~loc
             [ Pp.textf "library %S is present both as a forbidden \
-             and required dependency"
-            (Lib_name.to_string name) ]
+                        and required dependency"
+                (Lib_name.to_string name) ]
     in
     ignore (
       List.fold_left t ~init:Lib_name.Map.empty ~f:(fun acc x ->
@@ -1434,16 +1441,16 @@ module Executables = struct
           else
             User_error.raise ~loc
               [ Pp.textf "%s field may not be omitted before dune version %s"
-              (pluralize ~multi "name")
-              (Syntax.Version.to_string allow_omit_names_version) ]
+                  (pluralize ~multi "name")
+                  (Syntax.Version.to_string allow_omit_names_version) ]
         | None, None ->
           if dune_syntax >= allow_omit_names_version then
             User_error.raise ~loc [ Pp.textf "either the %s or the %s field must be present"
-              (pluralize ~multi "name")
-              (pluralize ~multi "public_name") ]
+                                      (pluralize ~multi "name")
+                                      (pluralize ~multi "public_name") ]
           else
             User_error.raise ~loc [ Pp.textf "field %s is missing"
-              (pluralize ~multi "name") ]
+                                      (pluralize ~multi "name") ]
       in
       let public =
         match package, public_names with
@@ -1587,7 +1594,7 @@ module Executables = struct
              (mem t native_shared_object && mem t shared_object) then
             User_error.raise ~loc
               [ Pp.textf "It is not allowed use both native and best \
-               for the same binary kind." ]
+                          for the same binary kind." ]
           else
             t
 
@@ -1616,7 +1623,7 @@ module Executables = struct
   let common =
     let+ buildable = Buildable.decode
     and+ (_ : bool) = field "link_executables" ~default:true
-                       (Syntax.deleted_in Stanza.syntax (1, 0) >>> bool)
+                        (Syntax.deleted_in Stanza.syntax (1, 0) >>> bool)
     and+ link_deps = field "link_deps" (list Dep_conf.decode) ~default:[]
     and+ link_flags = field_oslu "link_flags"
     and+ modes = field "modes" Link_mode.Set.decode ~default:Link_mode.Set.default
@@ -2203,7 +2210,7 @@ module Tests = struct
        and+ package = field_o "package" Pkg.decode
        and+ locks = field "locks" (list String_with_vars.decode) ~default:[]
        and+ modes = field "modes" Executables.Link_mode.Set.decode
-                     ~default:Executables.Link_mode.Set.default
+                      ~default:Executables.Link_mode.Set.default
        and+ deps =
          field "deps" (Bindings.decode Dep_conf.decode) ~default:Bindings.empty
        and+ enabled_if = enabled_if ~since:(Some (1, 4))

src/dune_file.mli

@@ -112,6 +112,12 @@ module Dep_conf : sig
     | Package of String_with_vars.t
     | Universe
     | Env_var of String_with_vars.t
+    (* [Sandbox_config] is a way to declare that your action also depends
+       on there being a clean filesystem around its deps.
+       (or, if you require [no_sandboxing], it's that your action depends on
+       something undeclared (e.g. absolute path of cwd) and you want to
+       allow it) *)
+    | Sandbox_config of Sandbox_config.t
 
   val remove_locs : t -> t