fix: disallow targets in subdirs

we intended to forbid this all along, but failed to do so for inferred targets. ps-id: 140db227-78c6-4782-90b3-535c3ac8eb90 Signed-off-by: Rudi Grinberg <[email protected]>
ocaml · Aug 3, 2022 · aecdf8f · aecdf8f
1 parent 089727f
commit aecdf8f
Show file tree

Hide file tree

Showing 5 changed files with 58 additions and 42 deletions.
diff --git a/src/dune_rules/action_unexpanded.ml b/src/dune_rules/action_unexpanded.ml
@@ -16,6 +16,15 @@ let as_in_build_dir ~what ~loc p =
           (Path.to_string_maybe_quoted p)
       ]
 
+let validate_target_dir ~targets_dir ~loc targets path =
+  if Path.Build.(parent_exn path <> targets_dir) then
+    User_error.raise ~loc
+      [ Pp.text
+          "This action has targets in a different directory than the current \
+           one, this is not allowed by dune at the moment:"
+      ; Targets.pp targets
+      ]
+
 module Action_expander : sig
   (* An applicative to help write action expansion. It is similar to
      [Action_builder.With_targets.t] but with some differences. The differences
@@ -40,7 +49,10 @@ module Action_expander : sig
   val set_env : var:string -> value:string t -> (value:string -> 'a) t -> 'a t
 
   val run :
-    'a t -> expander:Expander.t -> 'a Action_builder.With_targets.t Memo.t
+       'a t
+    -> targets_dir:Path.Build.t option
+    -> expander:Expander.t
+    -> 'a Action_builder.With_targets.t Memo.t
 
   (* String with vars expansion *)
   module E : sig
@@ -85,7 +97,7 @@ end = struct
   type deps = Path.Set.t Action_builder.t
 
   type collector =
-    { file_targets : Path.Build.Set.t  (** We only infer file targets *)
+    { file_targets : Loc.t Path.Build.Map.t  (** We only infer file targets *)
     ; deps : deps
     ; deps_if_exist : deps
     }
@@ -121,10 +133,10 @@ end = struct
     in
     fun l env acc -> loop [] l env acc
 
-  let run t ~expander =
+  let run t ~targets_dir ~expander =
     let deps = Action_builder.return Path.Set.empty in
     let acc =
-      { file_targets = Path.Build.Set.empty; deps; deps_if_exist = deps }
+      { file_targets = Path.Build.Map.empty; deps; deps_if_exist = deps }
     in
     let env = { expander; infer = true; dir = Expander.dir expander } in
     Memo.map (t env acc) ~f:(fun (b, acc) ->
@@ -135,7 +147,7 @@ end = struct
            {[ (progn (copy a b) (copy b c)) ]} *)
         let remove_targets =
           let file_targets =
-            Path.Build.Set.to_list file_targets
+            Path.Build.Map.keys file_targets
             |> Path.Set.of_list_map ~f:Path.build
           in
           fun deps -> Path.Set.diff deps file_targets
@@ -149,7 +161,13 @@ end = struct
               >>> Action_builder.if_file_exists f ~then_:(Action_builder.path f)
                     ~else_:(Action_builder.return ()))
         in
-        let targets = Targets.Files.create file_targets in
+        let targets =
+          let file_targets = Path.Build.Set.of_keys file_targets in
+          Targets.Files.create file_targets
+        in
+        Option.iter targets_dir ~f:(fun targets_dir ->
+            Path.Build.Map.iteri file_targets ~f:(fun path loc ->
+                validate_target_dir ~targets_dir ~loc targets path));
         Action_builder.with_targets ~targets
           (let+ () = deps >>= Action_builder.path_set
            and+ () = deps_if_exist >>= action_builder_path_set_if_exist
@@ -308,14 +326,16 @@ end = struct
           , acc )
       else
         let+! p = Expander.No_deps.expand_path env sw in
-        let p = as_in_build_dir p ~what ~loc:(loc sw) in
+        let loc = loc sw in
+        let p = as_in_build_dir p ~what ~loc in
         ( Action_builder.return p
-        , { acc with file_targets = f acc.file_targets p } )
+        , { acc with file_targets = f acc.file_targets p loc } )
 
     let consume_file =
-      add_or_remove_target ~what:"File" ~f:Path.Build.Set.remove
+      add_or_remove_target ~what:"File" ~f:(fun map p _loc ->
+          Path.Build.Map.remove map p)
 
-    let target = add_or_remove_target ~what:"Target" ~f:Path.Build.Set.add
+    let target = add_or_remove_target ~what:"Target" ~f:Path.Build.Map.set
 
     let prog_and_args sw env acc =
       let b =
@@ -464,7 +484,8 @@ let expand_no_targets t ~loc ~deps:deps_written_by_user ~expander ~what =
     Expander.set_expanding_what expander (User_action_without_targets { what })
   in
   let* { Action_builder.With_targets.build; targets } =
-    Action_builder.of_memo (Action_expander.run (expand t) ~expander)
+    Action_builder.of_memo
+      (Action_expander.run (expand t) ~targets_dir:None ~expander)
   in
   if not (Targets.is_empty targets) then
     User_error.raise ~loc
@@ -507,21 +528,15 @@ let expand t ~loc ~deps:deps_written_by_user ~targets_dir
     Expander.set_expanding_what expander (User_action targets_written_by_user)
   in
   let+! { Action_builder.With_targets.build; targets } =
-    Action_expander.run (expand t) ~expander
+    Action_expander.run (expand t) ~targets_dir:(Some targets_dir) ~expander
   in
   let targets =
     match (targets_written_by_user : _ Targets_spec.t) with
     | Infer -> targets
     | Static { targets = targets_written_by_user; multiplicity = _ } ->
       let files, dirs =
         List.partition_map targets_written_by_user ~f:(fun (path, kind) ->
-            if Path.Build.(parent_exn path <> targets_dir) then
-              User_error.raise ~loc
-                [ Pp.text
-                    "This action has targets in a different directory than the \
-                     current one, this is not allowed by dune at the moment:"
-                ; Targets.pp targets
-                ];
+            validate_target_dir ~targets_dir ~loc targets path;
             match kind with
             | File -> Left path
             | Directory -> Right path)

diff --git a/src/dune_rules/simple_rules.ml b/src/dune_rules/simple_rules.ml
@@ -13,8 +13,8 @@ module Alias_rules = struct
     add sctx ~loc ~alias action
 end
 
-let check_filename ~kind =
-  let not_in_dir ~error_loc s =
+let check_filename =
+  let not_in_dir ~kind ~error_loc s =
     User_error.raise ~loc:error_loc
       [ (match kind with
         | Targets_spec.Kind.File ->
@@ -23,19 +23,19 @@ let check_filename ~kind =
           Pp.textf "Directory targets must have exactly one path component.")
       ]
   in
-  fun ~error_loc ~dir -> function
+  fun ~kind ~error_loc ~dir -> function
     | Value.String ("." | "..") ->
       User_error.raise ~loc:error_loc
         [ Pp.text "'.' and '..' are not valid targets" ]
     | String s ->
       if Filename.dirname s <> Filename.current_dir_name then
-        not_in_dir ~error_loc s;
+        not_in_dir ~kind ~error_loc s;
       Path.Build.relative ~error_loc dir s
     | Path p -> (
       match Option.equal Path.equal (Path.parent p) (Some (Path.build dir)) with
       | true -> Path.as_in_build_dir_exn p
-      | false -> not_in_dir ~error_loc (Path.to_string p))
-    | Dir p -> not_in_dir ~error_loc (Path.to_string p)
+      | false -> not_in_dir ~kind ~error_loc (Path.to_string p))
+    | Dir p -> not_in_dir ~kind ~error_loc (Path.to_string p)
 
 type rule_kind =
   | Alias_only of Alias.Name.t
@@ -96,11 +96,10 @@ let user_rule sctx ?extra_bindings ~dir ~expander (rule : Rule.t) =
       | None -> expander
       | Some bindings -> Expander.add_bindings expander ~bindings
     in
-    let action =
+    let* (action : _ Action_builder.With_targets.t) =
       Action_unexpanded.expand (snd rule.action) ~loc:(fst rule.action)
         ~expander ~deps:rule.deps ~targets ~targets_dir:dir
     in
-    let* action = action in
     let action =
       if rule.patch_back_source_tree then
         Action_builder.With_targets.map action ~f:(fun action ->

diff --git a/test/blackbox-tests/test-cases/directory-targets/create-target-chdir.t b/test/blackbox-tests/test-cases/directory-targets/create-target-chdir.t
@@ -16,16 +16,10 @@ Attempt to create a directory with chdir + with-stdout-to:
   > EOF
 
   $ dune build foobar/
-  File "dune", line 1, characters 0-130:
-  1 | (rule
-  2 |  (targets (dir output))
-  3 |  (deps (sandbox always))
-  4 |  (action
-  5 |   (progn
-  6 |    (chdir output
+  File "dune", line 7, characters 20-21:
   7 |     (with-stdout-to x (echo foobar))))))
-  Error: Rule has targets in different directories.
-  Targets:
+                          ^
+  Error: This action has targets in a different directory than the current one,
+  this is not allowed by dune at the moment:
   - output/x
-  - output
   [1]
diff --git a/test/blackbox-tests/test-cases/generate-sources.t b/test/blackbox-tests/test-cases/generate-sources.t
@@ -12,9 +12,10 @@ Generate the source of an executable in a subdir:
   > EOF
 
   $ dune exec --display short ./bar.exe
-        ocamlc .bar.eobjs/byte/dune__exe__Bar.{cmi,cmti}
-  File "dune", line 4, characters 0-23:
-  4 | (executable (name bar))
-      ^^^^^^^^^^^^^^^^^^^^^^^
-  Error: No rule found for bar.ml
+  File "dune", line 2, characters 17-27:
+  2 |  (with-stdout-to foo/bar.ml (echo "let foo = 42;;")))
+                       ^^^^^^^^^^
+  Error: This action has targets in a different directory than the current one,
+  this is not allowed by dune at the moment:
+  - foo/bar.ml
   [1]
diff --git a/test/blackbox-tests/test-cases/target-outside-dir.t b/test/blackbox-tests/test-cases/target-outside-dir.t
@@ -15,6 +15,13 @@ The restriction on generating targets should be the same on both.
   > EOF
 
   $ dune build foo/bar.ml
+  File "dune", line 2, characters 17-27:
+  2 |  (with-stdout-to foo/bar.ml (echo "let foo = 42;;")))
+                       ^^^^^^^^^^
+  Error: This action has targets in a different directory than the current one,
+  this is not allowed by dune at the moment:
+  - foo/bar.ml
+  [1]
 
   $ cat >dune <<EOF
   > (rule