Add version check and deprecation warning

Starting a dst path with ".." now just generates a deprecation warning
rather than an error, and only on versions of dune before 3.11.

Signed-off-by: Stephen Sherratt <stephen@sherra.tt>

src/dune_rules/dune_file.ml

@@ -1179,6 +1179,7 @@ module Executables = struct
     type t =
       { names : (Loc.t * string) list
       ; public : public option
+      ; dune_syntax : Syntax.Version.t
       }
 
     let names t = t.names
@@ -1319,7 +1320,7 @@ module Executables = struct
                 (pluralize "public_name" ~multi)
             ]
       in
-      { names; public }
+      { names; public; dune_syntax }
     ;;
 
     let install_conf t ~ext ~enabled_if =
@@ -1328,7 +1329,10 @@ module Executables = struct
           List.map2 t.names public_names ~f:(fun (locn, name) (locp, pub) ->
             Option.map pub ~f:(fun pub ->
               Install_entry.File.of_file_binding
-                (File_binding.Unexpanded.make ~src:(locn, name ^ ext) ~dst:(locp, pub))))
+                (File_binding.Unexpanded.make
+                   ~src:(locn, name ^ ext)
+                   ~dst:(locp, pub)
+                   ~dune_syntax:t.dune_syntax)))
           |> List.filter_opt
         in
         { Install_conf.section = Section Bin

src/dune_rules/file_binding.ml

@@ -4,45 +4,57 @@ open Memo.O
 type ('src, 'dst) t =
   { src : 'src
   ; dst : 'dst option
+      (* The [dune_syntax] field is used for validation which has different
+         behaviour depending on the version of dune syntax in use. *)
+  ; dune_syntax : Syntax.Version.t
   }
 
-let equal f g { src; dst } t = f src t.src && Option.equal g dst t.dst
+let equal f g { src; dst; dune_syntax } t =
+  f src t.src
+  && Option.equal g dst t.dst
+  && Syntax.Version.equal dune_syntax t.dune_syntax
+;;
 
 let relative_path_starts_with_parent relative_path =
   match String.lsplit2 relative_path ~on:'/' with
   | None -> false
   | Some (first, _) -> String.equal first Filename.parent_dir_name
 ;;
 
-let validate_dst_for_install_stanza ~loc dst =
+let validate_dst_for_install_stanza ~loc dst dune_syntax =
   if relative_path_starts_with_parent dst
-  then
-    User_error.raise
-      ~loc
-      [ Pp.textf
-          "The destination path %s begins with \"..\" which is not allowed. Destinations \
-           of files in install stanzas may not begin with \"..\" to prevent them from \
-           escaping the package's install directory."
-          (String.maybe_quoted dst)
-      ]
+  then (
+    match Syntax.Version.compare dune_syntax (3, 11) with
+    | Lt -> ()
+    | _ ->
+      User_warning.emit
+        ~loc
+        [ Pp.textf
+            "The destination path %s begins with \"..\" which will become an error in a \
+             future version of Dune. Destinations of files in install stanzas beginning \
+             with \"..\" will be disallowed to prevent a package's installed files from \
+             escaping that package's install directories."
+            (String.maybe_quoted dst)
+        ])
 ;;
 
 module Expanded = struct
   type nonrec t = (Loc.t * Path.Build.t, Loc.t * string) t
 
-  let to_dyn { src; dst } =
+  let to_dyn { src; dst; dune_syntax } =
     let open Dyn in
     record
       [ "src", pair Loc.to_dyn Path.Build.to_dyn src
       ; "dst", option (pair Loc.to_dyn string) dst
+      ; "dune_syntax", Syntax.Version.to_dyn dune_syntax
       ]
   ;;
 
   let src t = snd t.src
   let dst t = Option.map ~f:snd t.dst
   let src_loc t = fst t.src
 
-  let dst_basename { src = _, src; dst } =
+  let dst_basename { src = _, src; dst; dune_syntax = _ } =
     match dst with
     | Some (_, dst) -> dst
     | None ->
@@ -53,24 +65,29 @@ module Expanded = struct
   let dst_path t ~dir = Path.Build.relative dir (dst_basename t)
 
   let validate_for_install_stanza t =
-    Option.iter t.dst ~f:(fun (loc, dst) -> validate_dst_for_install_stanza ~loc dst)
+    Option.iter t.dst ~f:(fun (loc, dst) ->
+      validate_dst_for_install_stanza ~loc dst t.dune_syntax)
   ;;
 end
 
 module Unexpanded = struct
   type nonrec t = (String_with_vars.t, String_with_vars.t) t
 
-  let to_dyn { src; dst } =
+  let to_dyn { src; dst; dune_syntax } =
     let open Dyn in
     record
-      [ "src", String_with_vars.to_dyn src; "dst", option String_with_vars.to_dyn dst ]
+      [ "src", String_with_vars.to_dyn src
+      ; "dst", option String_with_vars.to_dyn dst
+      ; "dune_syntax", Syntax.Version.to_dyn dune_syntax
+      ]
   ;;
 
   let equal = equal String_with_vars.equal_no_loc String_with_vars.equal_no_loc
 
-  let make ~src:(locs, src) ~dst:(locd, dst) =
+  let make ~src:(locs, src) ~dst:(locd, dst) ~dune_syntax =
     { src = String_with_vars.make_text locs src
     ; dst = Some (String_with_vars.make_text locd dst)
+    ; dune_syntax
     }
   ;;
 
@@ -85,7 +102,7 @@ module Unexpanded = struct
         dst, loc)
     in
     Option.iter dst_loc_opt ~f:(fun (dst, loc) ->
-      validate_dst_for_install_stanza ~loc dst);
+      validate_dst_for_install_stanza ~loc dst t.dune_syntax);
     Install.Entry.adjust_dst ~section ~src ~dst:(Option.map dst_loc_opt ~f:fst)
   ;;
 
@@ -105,7 +122,7 @@ module Unexpanded = struct
         let+ loc, p = f dst in
         Some (loc, p)
     in
-    { src; dst }
+    { src; dst; dune_syntax = t.dune_syntax }
   ;;
 
   let decode =
@@ -117,34 +134,37 @@ module Unexpanded = struct
         | Atom _ -> true
         | _ -> false
       and+ s = String_with_vars.decode
-      and+ version = Dune_lang.Syntax.get_exn Stanza.syntax in
-      if (not is_atom) && version < (1, 6)
+      and+ dune_syntax = Dune_lang.Syntax.get_exn Stanza.syntax in
+      if (not is_atom) && dune_syntax < (1, 6)
       then (
         let what =
           (if String_with_vars.has_pforms s then "variables" else "quoted strings")
           |> sprintf "Using %s here"
         in
         Dune_lang.Syntax.Error.since (String_with_vars.loc s) Stanza.syntax (1, 6) ~what)
-      else s
+      else s, dune_syntax
     in
     peek_exn
     >>= function
-    | Atom _ | Quoted_string _ | Template _ -> decode >>| fun src -> { src; dst = None }
+    | Atom _ | Quoted_string _ | Template _ ->
+      decode >>| fun (src, dune_syntax) -> { src; dst = None; dune_syntax }
     | List (_, [ _; Atom (_, A "as"); _ ]) ->
       enter
-        (let* src = decode in
+        (let* src, dune_syntax = decode in
          keyword "as"
-         >>> let* dst = decode in
-             return { src; dst = Some dst })
+         >>> let* dst, _ = decode in
+             return { src; dst = Some dst; dune_syntax })
     | sexp ->
       User_error.raise
         ~loc:(Dune_lang.Ast.loc sexp)
         [ Pp.text "Invalid format, <name> or (<name> as <install-as>) expected" ]
   ;;
 
+  let dune_syntax t = t.dune_syntax
+
   module L = struct
     let decode = Dune_lang.Decoder.repeat decode
-    let strings_with_vars { src; dst } = src :: Option.to_list dst
+    let strings_with_vars { src; dst; dune_syntax = _ } = src :: Option.to_list dst
 
     let find_pform fbs =
       List.find_map fbs ~f:(fun fb ->

src/dune_rules/file_binding.mli

@@ -16,8 +16,9 @@ module Unexpanded : sig
 
   val to_dyn : t -> Dyn.t
   val equal : t -> t -> bool
-  val make : src:Loc.t * string -> dst:Loc.t * string -> t
+  val make : src:Loc.t * string -> dst:Loc.t * string -> dune_syntax:Syntax.Version.t -> t
   val decode : t Dune_lang.Decoder.t
+  val dune_syntax : t -> Syntax.Version.t
 
   val expand
     :  t

src/dune_rules/install_entry.ml

@@ -67,7 +67,7 @@ module File = struct
       file_binding_decode <|> glob_files_decode
     ;;
 
-    let to_file_bindings_unexpanded t ~expand_str ~dir =
+    let to_file_bindings_unexpanded t ~expand_str ~dir ~dune_syntax =
       match t with
       | File_binding file_binding -> Memo.return [ file_binding ]
       | Glob_files { glob_files; prefix } ->
@@ -105,11 +105,11 @@ module File = struct
               let dst = Filename.concat prefix path_without_prefix in
               prefix_loc, dst
           in
-          File_binding.Unexpanded.make ~src ~dst)
+          File_binding.Unexpanded.make ~src ~dst ~dune_syntax)
     ;;
 
-    let to_file_bindings_expanded t ~expand_str ~dir =
-      to_file_bindings_unexpanded t ~expand_str ~dir
+    let to_file_bindings_expanded t ~expand_str ~dir ~dune_syntax =
+      to_file_bindings_unexpanded t ~expand_str ~dir ~dune_syntax
       |> Memo.bind
            ~f:
              (Memo.List.map
@@ -120,40 +120,58 @@ module File = struct
     ;;
   end
 
-  type t = Without_include.t Recursive_include.t
+  type t =
+    { binding : Without_include.t Recursive_include.t
+    ; dune_syntax : Syntax.Version.t
+    }
 
   let decode =
-    Recursive_include.decode
-      ~base_term:Without_include.decode
-      ~include_keyword:"include"
-      ~non_sexp_behaviour:`User_error
-      ~include_allowed_in_versions:(`Since (3, 5))
-  ;;
-
-  let expand_include = Recursive_include.expand_include
-
-  let expand_include_multi ts ~expand_str ~dir =
-    Memo.List.concat_map ts ~f:(expand_include ~expand_str ~dir)
+    let open Dune_lang.Decoder in
+    let+ binding =
+      Recursive_include.decode
+        ~base_term:Without_include.decode
+        ~include_keyword:"include"
+        ~non_sexp_behaviour:`User_error
+        ~include_allowed_in_versions:(`Since (3, 5))
+    and+ dune_syntax = Dune_lang.Syntax.get_exn Stanza.syntax in
+    { binding; dune_syntax }
   ;;
 
   let of_file_binding file_binding =
-    Recursive_include.of_base (Without_include.File_binding file_binding)
+    let binding = Recursive_include.of_base (Without_include.File_binding file_binding) in
+    let dune_syntax = File_binding.Unexpanded.dune_syntax file_binding in
+    { binding; dune_syntax }
   ;;
 
   let to_file_bindings_unexpanded ts ~expand_str ~dir =
-    expand_include_multi ts ~expand_str ~dir
+    let open Memo.O in
+    Memo.List.concat_map ts ~f:(fun { binding; dune_syntax } ->
+      let+ bindings = Recursive_include.expand_include binding ~expand_str ~dir in
+      List.map bindings ~f:(fun binding -> binding, dune_syntax))
     |> Memo.bind
          ~f:
-           (Memo.List.concat_map
-              ~f:(Without_include.to_file_bindings_unexpanded ~expand_str ~dir))
+           (Memo.List.concat_map ~f:(fun (binding, dune_syntax) ->
+              Without_include.to_file_bindings_unexpanded
+                ~expand_str
+                ~dir
+                ~dune_syntax
+                binding))
   ;;
 
   let to_file_bindings_expanded ts ~expand_str ~dir =
     let open Memo.O in
     let+ file_bindings_expanded =
-      expand_include_multi ts ~expand_str ~dir
-      >>= Memo.List.concat_map
-            ~f:(Without_include.to_file_bindings_expanded ~expand_str ~dir)
+      Memo.List.concat_map ts ~f:(fun { binding; dune_syntax } ->
+        let+ bindings = Recursive_include.expand_include binding ~expand_str ~dir in
+        List.map bindings ~f:(fun binding -> binding, dune_syntax))
+      |> Memo.bind
+           ~f:
+             (Memo.List.concat_map ~f:(fun (binding, dune_syntax) ->
+                Without_include.to_file_bindings_expanded
+                  ~expand_str
+                  ~dir
+                  ~dune_syntax
+                  binding))
     in
     List.iter file_bindings_expanded ~f:File_binding.Expanded.validate_for_install_stanza;
     file_bindings_expanded

test/blackbox-tests/test-cases/install/install-glob/install-glob-relative.t

@@ -31,10 +31,17 @@ Incorrect install stanza that would place files outside the package's install di
   File "stanza/dune", line 2, characters 24-38:
   2 |  (files (glob_files_rec ../stuff/*.txt))
                               ^^^^^^^^^^^^^^
-  Error: The destination path ../stuff/foo.txt begins with ".." which is not
-  allowed. Destinations of files in install stanzas may not begin with ".." to
-  prevent them from escaping the package's install directory.
-  [1]
+  Warning: The destination path ../stuff/foo.txt begins with ".." which will
+  become an error in a future version of Dune. Destinations of files in install
+  stanzas beginning with ".." will be disallowed to prevent a package's
+  installed files from escaping that package's install directories.
+  File "stanza/dune", line 2, characters 24-38:
+  2 |  (files (glob_files_rec ../stuff/*.txt))
+                              ^^^^^^^^^^^^^^
+  Warning: The destination path ../stuff/xy/bar.txt begins with ".." which will
+  become an error in a future version of Dune. Destinations of files in install
+  stanzas beginning with ".." will be disallowed to prevent a package's
+  installed files from escaping that package's install directories.
 
 
 Correction to the above which uses `with_prefix` to change the install destination: