Prevent relative paths leaking out of install dirs

This disallows install dst paths from begining with ".." to prevent them
referencing a directory outside the install directories of the package.

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

doc/changes/8350.md

@@ -0,0 +1,2 @@
+- Deprecate install destination paths beginning with ".." to prevent packages
+  escaping their designated installation directories. (#8350, @gridbugs)

doc/stanzas/install.rst

@@ -106,6 +106,16 @@ installed with mode ``0o644`` (``rw-r--r--``).
 Note that all files in the install stanza must be specified by relative paths
 only. It is an error to specify files by absolute paths.
 
+Also note that as of dune-lang 3.11 (ie. ``(lang dune 3.11)`` in
+``dune-project``) it is deprecated to use the ``as`` keyword to specify a
+destination beginning with ``..``. Dune intends for files associated with a
+package to only be installed under specific directories in the file system
+implied by the installation section (e.g. ``share``, ``bin``, ``doc``, etc.)
+and the package name. Starting destination paths with ``..`` allows packages to
+install files to arbitrary locations on the file system. In 3.11 this behaviour
+is still supported (as some projects may depend on it) but will generate a
+warning and will be removed in a future version of Dune.
+
 Including Files in the Install Stanza
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 

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,26 +4,77 @@ 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 -> Filename.(equal relative_path parent_dir_name)
+  | Some (first, _) -> String.equal first Filename.parent_dir_name
+;;
+
+let validate_dst_for_install_stanza
+  ~relative_dst_path_starts_with_parent_error_when
+  ~loc
+  dst
+  dune_syntax
+  =
+  if relative_path_starts_with_parent dst
+  then (
+    match relative_dst_path_starts_with_parent_error_when with
+    | `Deprecation_warning_from_3_11 ->
+      let open Syntax.Version.Infix in
+      if dune_syntax >= (3, 11)
+      then
+        User_warning.emit
+          ~loc
+          [ Pp.textf
+              "The destination path %s begins with %s which will become an error in a \
+               future version of Dune. Destinations of files in install stanzas \
+               beginning with %s will be disallowed to prevent a package's installed \
+               files from escaping that package's install directories."
+              (String.maybe_quoted dst)
+              (String.maybe_quoted Filename.parent_dir_name)
+              (String.maybe_quoted Filename.parent_dir_name)
+          ]
+    | `Always_error ->
+      User_error.raise
+        ~loc
+        [ Pp.textf
+            "The destination path %s begins with %s which is not allowed. Destinations \
+             in install stanzas may not begin with %s to prevent a package's installed \
+             files from escaping that package's install directories."
+            (String.maybe_quoted dst)
+            (String.maybe_quoted Filename.parent_dir_name)
+            (String.maybe_quoted Filename.parent_dir_name)
+        ])
+;;
 
 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 ->
@@ -32,31 +83,55 @@ module Expanded = struct
   ;;
 
   let dst_path t ~dir = Path.Build.relative dir (dst_basename t)
+
+  let validate_for_install_stanza ~relative_dst_path_starts_with_parent_error_when t =
+    Option.iter t.dst ~f:(fun (loc, dst) ->
+      validate_dst_for_install_stanza
+        ~relative_dst_path_starts_with_parent_error_when
+        ~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
     }
   ;;
 
   let expand_src t ~dir ~f = f t.src >>| Path.Build.relative dir
 
   let destination_relative_to_install_path t ~section ~expand ~expand_partial =
     let+ src = expand_partial t.src
-    and+ dst = Memo.Option.map ~f:expand t.dst in
-    Install.Entry.adjust_dst ~section ~src ~dst
+    and+ dst_loc_opt =
+      Memo.Option.map t.dst ~f:(fun dst ->
+        let loc = String_with_vars.loc dst in
+        let+ dst = expand dst in
+        dst, loc)
+    in
+    Option.iter dst_loc_opt ~f:(fun (dst, loc) ->
+      validate_dst_for_install_stanza
+        ~relative_dst_path_starts_with_parent_error_when:`Deprecation_warning_from_3_11
+        ~loc
+        dst
+        t.dune_syntax);
+    Install.Entry.adjust_dst ~section ~src ~dst:(Option.map dst_loc_opt ~f:fst)
   ;;
 
   let expand t ~dir ~f =
@@ -75,7 +150,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 =
@@ -87,34 +162,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

@@ -8,15 +8,22 @@ module Expanded : sig
   val dst : t -> string option
   val src_loc : t -> Loc.t
   val dst_path : t -> dir:Path.Build.t -> Path.Build.t
+
+  val validate_for_install_stanza
+    :  relative_dst_path_starts_with_parent_error_when:
+         [ `Deprecation_warning_from_3_11 | `Always_error ]
+    -> t
+    -> unit
 end
 
 module Unexpanded : sig
   type t
 
   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/gen_rules.ml

@@ -236,6 +236,7 @@ let gen_rules
           install_conf.dirs
           ~expand_str
           ~dir:ctx_dir
+          ~relative_dst_path_starts_with_parent_error_when:`Deprecation_warning_from_3_11
       in
       List.map (files_expanded @ dirs_expanded) ~f:(fun fb ->
         File_binding.Expanded.src fb |> Path.build)