Stricter control of select filenames

CHANGES.md

@@ -190,6 +190,10 @@
 - Allow `ccomp_type` as a variable for evaluating `enabled_if`. (#2855, @dra27,
   @rgrinberg)
 
+- Stricter validation of file names in `select`. The file names of conditional
+  sources must match the prefix and the extension of the resultant filename.
+  (#2867, @rgrinberg)
+
 1.11.4 (09/10/2019)
 -------------------
 

src/dune/dir_contents.ml

@@ -49,6 +49,17 @@ and kind =
   | Group_root of t list
   | Group_part
 
+let empty kind ~dir =
+  { kind
+  ; dir
+  ; text_files = String.Set.empty
+  ; modules = Memo.Lazy.of_val Dir_modules.empty
+  ; mlds = Memo.Lazy.of_val []
+  ; foreign_sources = Memo.Lazy.of_val Foreign_sources.empty
+  ; coq_modules = Memo.Lazy.of_val Lib_name.Map.empty
+  ; artifacts = Memo.Lazy.of_val Dir_artifacts.empty
+  }
+
 type gen_rules_result =
   | Standalone_or_root of t * t list
   | Group_part of Path.Build.t
@@ -457,7 +468,7 @@ end = struct
                 | Direct _ ->
                   []
                 | Select s ->
-                  List.map s.choices ~f:(fun (s : Lib_dep.Select.choice) ->
+                  List.map s.choices ~f:(fun (s : Lib_dep.Select.Choice.t) ->
                       s.file))
           | _ -> [])
       |> String.Set.of_list
@@ -544,16 +555,7 @@ end = struct
       | Some (_, None)
       | None ->
         Here
-          { t =
-              { kind = Standalone
-              ; dir
-              ; text_files = String.Set.empty
-              ; modules = Memo.Lazy.of_val Dir_modules.empty
-              ; mlds = Memo.Lazy.of_val []
-              ; foreign_sources = Memo.Lazy.of_val Foreign_sources.empty
-              ; coq_modules = Memo.Lazy.of_val Lib_name.Map.empty
-              ; artifacts = Memo.Lazy.of_val Dir_artifacts.empty
-              }
+          { t = empty Standalone ~dir
           ; rules = None
           ; subdirs = Path.Build.Map.empty
           } )
@@ -591,24 +593,25 @@ end = struct
       in
       let libs_and_exes =
         Memo.lazy_ (fun () ->
-            check_no_qualified Loc.none qualif_mode;
+            let loc =
+              Loc.in_file
+                (Path.source
+                   ( match File_tree.Dir.dune_file ft_dir with
+                   | Some d -> File_tree.Dune_file.path d
+                   | None ->
+                     Path.Source.relative
+                       (File_tree.Dir.path ft_dir)
+                       "_unknown_" ))
+            in
+            check_no_qualified loc qualif_mode;
             let modules =
               let dialects = Dune_project.dialects (Scope.project d.scope) in
               List.fold_left ((dir, [], files) :: subdirs)
                 ~init:Module_name.Map.empty
                 ~f:(fun acc ((dir : Path.Build.t), _local, files) ->
                   let modules = modules_of_files ~dialects ~dir ~files in
                   Module_name.Map.union acc modules ~f:(fun name x y ->
-                      User_error.raise
-                        ~loc:
-                          (Loc.in_file
-                             (Path.source
-                                ( match File_tree.Dir.dune_file ft_dir with
-                                | None ->
-                                  Path.Source.relative
-                                    (File_tree.Dir.path ft_dir)
-                                    "_unknown_"
-                                | Some d -> File_tree.Dune_file.path d )))
+                      User_error.raise ~loc
                         [ Pp.textf "Module %S appears in several directories:"
                             (Module_name.to_string name)
                         ; Pp.textf "- %s"

src/dune/dune_file.ml

@@ -397,7 +397,7 @@ module Lib_deps = struct
               add Required s acc
             | Select { choices; _ } ->
               List.fold_left choices ~init:acc
-                ~f:(fun acc (c : Lib_dep.Select.choice) ->
+                ~f:(fun acc (c : Lib_dep.Select.Choice.t) ->
                   let acc =
                     Lib_name.Set.fold c.required ~init:acc ~f:(add Optional)
                   in
@@ -413,7 +413,7 @@ module Lib_deps = struct
       | Lib_dep.Direct (_, s) ->
         [ (s, kind) ]
       | Select { choices; _ } ->
-        List.concat_map choices ~f:(fun (c : Lib_dep.Select.choice) ->
+        List.concat_map choices ~f:(fun (c : Lib_dep.Select.Choice.t) ->
             Lib_name.Set.to_list c.required
             |> List.map ~f:(fun d -> (d, Lib_deps_info.Kind.Optional))))
     |> Lib_name.Map.of_list_reduce ~f:Lib_deps_info.Kind.merge

src/dune/lib_dep.ml

@@ -1,32 +1,95 @@
 open Stdune
 
 module Select = struct
-  type choice =
-    { required : Lib_name.Set.t
-    ; forbidden : Lib_name.Set.t
-    ; file : string
-    }
+  module Choice = struct
+    type t =
+      { required : Lib_name.Set.t
+      ; forbidden : Lib_name.Set.t
+      ; file : string
+      }
 
-  let dyn_of_choice { required; forbidden; file } =
-    let open Dyn.Encoder in
-    record
-      [ ("required", Lib_name.Set.to_dyn required)
-      ; ("forbidden", Lib_name.Set.to_dyn forbidden)
-      ; ("file", string file)
-      ]
+    let decode ~result_fn =
+      let open Dune_lang.Decoder in
+      enter
+        (let* dune_version = Dune_lang.Syntax.get_exn Stanza.syntax in
+         let+ loc = loc
+         and+ preds, file =
+           until_keyword "->"
+             ~before:
+               (let+ s = string
+                and+ loc = loc in
+                let loc = Some loc in
+                match String.drop_prefix s ~prefix:"!" with
+                | Some s -> Right (Lib_name.of_string_exn ~loc s)
+                | None -> Left (Lib_name.of_string_exn ~loc s))
+             ~after:(located filename)
+         in
+         match file with
+         | None ->
+           User_error.raise ~loc
+             [ Pp.textf "(<[!]libraries>... -> <file>) expected" ]
+         | Some (loc_file, file) ->
+           let () =
+             if dune_version >= (2, 0) then
+               let prefix, suffix =
+                 let name, ext = Filename.split_extension result_fn in
+                 let prefix = name ^ "." in
+                 (prefix, ext)
+               in
+               if not (String.is_prefix file ~prefix && String.is_suffix file ~suffix)
+               then
+                 User_error.raise ~loc:loc_file
+                   [ Pp.textf
+                       "The format for files in this select branch must be \
+                        %s{name}%s"
+                       prefix suffix
+                   ]
+           in
+           let rec loop required forbidden = function
+             | [] ->
+               let common = Lib_name.Set.inter required forbidden in
+               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)
+                     ]);
+               { required; forbidden; file }
+             | Left s :: l -> loop (Lib_name.Set.add required s) forbidden l
+             | Right s :: l -> loop required (Lib_name.Set.add forbidden s) l
+           in
+           loop Lib_name.Set.empty Lib_name.Set.empty preds)
+
+    let to_dyn { required; forbidden; file } =
+      let open Dyn.Encoder in
+      record
+        [ ("required", Lib_name.Set.to_dyn required)
+        ; ("forbidden", Lib_name.Set.to_dyn forbidden)
+        ; ("file", string file)
+        ]
+  end
 
   type t =
     { result_fn : string
-    ; choices : choice list
+    ; choices : Choice.t list
     ; loc : Loc.t
     }
 
   let to_dyn { result_fn; choices; loc = _ } =
     let open Dyn.Encoder in
     record
       [ ("result_fn", string result_fn)
-      ; ("choices", list dyn_of_choice choices)
+      ; ("choices", list Choice.to_dyn choices)
       ]
+
+  let decode =
+    let open Dune_lang.Decoder in
+    let* result_fn = filename in
+    let+ loc = loc
+    and+ () = keyword "from"
+    and+ choices = repeat (Choice.decode ~result_fn) in
+    { result_fn; choices; loc }
 end
 
 type t =
@@ -51,53 +114,16 @@ let to_lib_names = function
     [ s ]
   | Select s ->
     List.fold_left s.choices ~init:Lib_name.Set.empty
-      ~f:(fun acc (x : Select.choice) ->
+      ~f:(fun acc (x : Select.Choice.t) ->
         Lib_name.Set.union acc (Lib_name.Set.union x.required x.forbidden))
     |> Lib_name.Set.to_list
 
-let choice =
-  let open Dune_lang.Decoder in
-  enter
-    (let+ loc = loc
-     and+ preds, file =
-       until_keyword "->"
-         ~before:
-           (let+ s = string
-            and+ loc = loc in
-            let len = String.length s in
-            if len > 0 && s.[0] = '!' then
-              Right (Lib_name.of_string_exn ~loc:(Some loc) (String.drop s 1))
-            else
-              Left (Lib_name.of_string_exn ~loc:(Some loc) s))
-         ~after:filename
-     in
-     match file with
-     | None ->
-       User_error.raise ~loc
-         [ Pp.textf "(<[!]libraries>... -> <file>) expected" ]
-     | Some file ->
-       let rec loop required forbidden = function
-         | [] ->
-           let common = Lib_name.Set.inter required forbidden in
-           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)
-                 ]);
-           { Select.required; forbidden; file }
-         | Left s :: l -> loop (Lib_name.Set.add required s) forbidden l
-         | Right s :: l -> loop required (Lib_name.Set.add forbidden s) l
-       in
-       loop Lib_name.Set.empty Lib_name.Set.empty preds)
-
 let decode ~allow_re_export =
   let open Dune_lang.Decoder in
   if_list
     ~then_:
       (enter
-         (let* loc = loc in
-          let* cloc, constr = located string in
+         (let* cloc, constr = located string in
           match constr with
           | "re_export" ->
             if not allow_re_export then
@@ -107,10 +133,8 @@ let decode ~allow_re_export =
             and+ loc, name = located Lib_name.decode in
             Re_export (loc, name)
           | "select" ->
-            let+ result_fn = filename
-            and+ () = keyword "from"
-            and+ choices = repeat choice in
-            Select { result_fn; choices; loc }
+            let+ select = Select.decode in
+            Select select
           | _ -> User_error.raise ~loc:cloc [ Pp.text "invalid constructor" ]))
     ~else_:
       (let+ loc, name = located Lib_name.decode in

src/dune/lib_dep.mli

@@ -1,15 +1,17 @@
 open Stdune
 
 module Select : sig
-  type choice =
-    { required : Lib_name.Set.t
-    ; forbidden : Lib_name.Set.t
-    ; file : string
-    }
+  module Choice : sig
+    type t =
+      { required : Lib_name.Set.t
+      ; forbidden : Lib_name.Set.t
+      ; file : string
+      }
+  end
 
   type t =
     { result_fn : string
-    ; choices : choice list
+    ; choices : Choice.t list
     ; loc : Loc.t
     }
 

test/blackbox-tests/dune.inc

@@ -1566,6 +1566,14 @@
    test-cases/select
    (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))
 
+(rule
+ (alias select-2-0-rules)
+ (deps (package dune) (source_tree test-cases/select-2-0-rules))
+ (action
+  (chdir
+   test-cases/select-2-0-rules
+   (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))
+
 (rule
  (alias several-packages)
  (deps (package dune) (source_tree test-cases/several-packages))
@@ -2100,6 +2108,7 @@
   (alias scope-bug)
   (alias scope-ppx-bug)
   (alias select)
+  (alias select-2-0-rules)
   (alias several-packages)
   (alias shadow-bindings)
   (alias stale-artifact-removal)
@@ -2305,6 +2314,7 @@
   (alias sandboxing)
   (alias scope-bug)
   (alias select)
+  (alias select-2-0-rules)
   (alias several-packages)
   (alias shadow-bindings)
   (alias stale-artifact-removal)

test/blackbox-tests/test-cases/select-2-0-rules/run.t

@@ -0,0 +1,19 @@
+  $ echo "(lang dune 2.0)" > dune-project
+  $ cat > dune <<EOF
+  > (library (name foo) (libraries (select foo.ml from (!bar -> f.ml))))
+  > EOF
+  $ dune build
+  File "dune", line 1, characters 60-64:
+  1 | (library (name foo) (libraries (select foo.ml from (!bar -> f.ml))))
+                                                                  ^^^^
+  Error: The format for files in this select branch must be foo.{name}.ml
+  [1]
+  $ cat > dune <<EOF
+  > (library (name foo) (libraries (select foo.ml from (!bar -> foo.mli))))
+  > EOF
+  $ dune build
+  File "dune", line 1, characters 60-67:
+  1 | (library (name foo) (libraries (select foo.ml from (!bar -> foo.mli))))
+                                                                  ^^^^^^^
+  Error: The format for files in this select branch must be foo.{name}.ml
+  [1]

test/blackbox-tests/test-cases/select/run.t

@@ -4,11 +4,11 @@
   >  (name main)
   >  (libraries
   >   (select bar.ml from
-  >    (unix -> bar_unix.ml)
-  >    (!unix -> bar_no_unix.ml))
+  >    (unix -> bar.unix.ml)
+  >    (!unix -> bar.no_unix.ml))
   >   (select foo.ml from
-  >    (fakefoobar -> foo_fake.ml)
-  >    (!fakefoobar -> foo_no_fake.ml))))
+  >    (fakefoobar -> foo.fake.ml)
+  >    (!fakefoobar -> foo.no_fake.ml))))
   > (alias
   >  (name runtest)
   >  (action (run ./main.exe)))
@@ -35,11 +35,11 @@
   >  (name main)
   >  (libraries
   >   (select bar.ml from
-  >    (unix -> bar_unix.ml)
-  >    (!unix -> bar_no_unix.ml))
+  >    (unix -> bar.unix.ml)
+  >    (!unix -> bar.no_unix.ml))
   >   (select foo.ml from
-  >    (fakefoobar -> foo_fake.ml)
-  >    (!fakefoobar -> foo_no_fake.ml))))
+  >    (fakefoobar -> foo.fake.ml)
+  >    (!fakefoobar -> foo.no_fake.ml))))
   > (rule
   >  (alias runtest)
   >  (action (run ./main.exe)))