fix: reject (package ...) inside named dependency bindings

doc/changes/changed/14432.md

@@ -0,0 +1,5 @@
+- `%{bin:NAME}` now resolves to the build artifact path rather than
+  the install staging path. Rules with `%{bin:NAME}` deps additionally
+  get a per-rule bin-layout directory prepended to the action's
+  `PATH`, containing correctly-named symlinks for each declared bin
+  pform dep. (#14432, fixes #3324, @Alizter)

doc/changes/fixed/14373-named-binding-package.md

@@ -0,0 +1,3 @@
+- Reject `(package ...)` inside a named dependency binding
+  (`(deps (:name (package foo)))`). Previously this was silently
+  accepted but `%{name}` would resolve to an empty path list. (@Alizter)

src/dune_rules/action_unexpanded.ml

@@ -629,7 +629,7 @@ let rec expand (t : Dune_lang.Action.t) : Action.t Action_expander.t =
 
 let expand_no_targets t sandbox ~loc ~chdir ~deps:deps_written_by_user ~expander ~what =
   let open Action_builder.O in
-  let deps_builder, expander, sandbox =
+  let action_env, expander, sandbox =
     Dep_conf_eval.named ~expander sandbox deps_written_by_user
   in
   let expander =
@@ -650,11 +650,11 @@ let expand_no_targets t sandbox ~loc ~chdir ~deps:deps_written_by_user ~expander
           (String.capitalize what)
       ; pp_targets targets
       ];
-  let+ () = deps_builder
-  and+ sandbox = sandbox
+  let+ sandbox = sandbox
+  and+ env = action_env
   and+ action = build in
   let action = Action.Chdir (Path.build chdir, action) in
-  Action.Full.make action ~sandbox
+  Action.Full.make action ~sandbox |> Action.Full.add_env env
 ;;
 
 let expand
@@ -668,7 +668,7 @@ let expand
       ~expander
   =
   let open Action_builder.O in
-  let deps_builder, expander, sandbox =
+  let action_env, expander, sandbox =
     Dep_conf_eval.named sandbox ~expander deps_written_by_user
   in
   let expander =
@@ -711,10 +711,11 @@ let expand
       Targets.combine targets (Targets.create ~files ~dirs)
   in
   let build =
-    let+ () = deps_builder
-    and+ sandbox = sandbox
+    let+ sandbox = sandbox
+    and+ env = action_env
     and+ action = build in
     Action.Full.make (Action.Chdir (Path.build chdir, action)) ~sandbox
+    |> Action.Full.add_env env
   in
   Action_builder.with_targets ~targets build
 ;;

src/dune_rules/artifacts.ml

@@ -9,6 +9,7 @@ type origin =
   ; dir : Path.Build.t
   ; dst : Path.Local.t
   ; enabled_if : bool Memo.t
+  ; package : Package.Name.t option
   }
 
 type where =
@@ -87,15 +88,15 @@ let analyze_binary t ~dir name =
             ]))
 ;;
 
-let binary t ?hint ?(where = Install_dir) ~dir ~loc name =
+let binary t ?hint ?(where = Original_path) ~dir ~loc name =
   analyze_binary t ~dir name
   >>= function
   | `Resolved path -> Memo.return @@ Ok path
   | `None ->
     let context = Context.name t.context in
     Memo.return
     @@ Error (Action.Prog.Not_found.create ~program:name ?hint ~context ~loc ())
-  | `Origin { dir; binding; dst; enabled_if = _ } ->
+  | `Origin { dir; binding; dst; enabled_if = _; package = _ } ->
     (match where with
      | Install_dir ->
        let install_dir = Install.Context.bin_dir ~context:(Context.name t.context) in
@@ -112,6 +113,13 @@ let binary t ?hint ?(where = Install_dir) ~dir ~loc name =
        Ok (Path.build src))
 ;;
 
+let binary_package t ~dir name =
+  analyze_binary t ~dir name
+  >>| function
+  | `Origin { package; _ } -> package
+  | `Resolved _ | `None -> None
+;;
+
 let binary_available t ~dir name =
   analyze_binary t ~dir name
   >>| function

src/dune_rules/artifacts.mli

@@ -7,6 +7,7 @@ type origin =
   ; dir : Path.Build.t
   ; dst : Path.Local.t
   ; enabled_if : bool Memo.t
+  ; package : Package.Name.t option
   }
 
 type where =
@@ -38,6 +39,7 @@ val binary
   -> Filename.t
   -> Action.Prog.t Memo.t
 
+val binary_package : t -> dir:Path.Build.t -> string -> Package.Name.t option Memo.t
 val binary_available : t -> dir:Path.Build.t -> string -> bool Memo.t
 val add_binaries : t -> dir:Path.Build.t -> File_binding.Expanded.t list -> t
 

src/dune_rules/artifacts_db.ml

@@ -55,7 +55,7 @@ let get_installed_binaries ~(context : Context.t) stanzas =
       >>| fst
     in
     let eval_blang = Expander0.eval_blang expander in
-    let binaries_from_install ~enabled_if files =
+    let binaries_from_install ~enabled_if ~package files =
       let* unexpanded_file_bindings =
         Install_entry.File.to_file_bindings_unexpanded files ~expand:expand_value ~dir
       in
@@ -70,7 +70,7 @@ let get_installed_binaries ~(context : Context.t) stanzas =
         let dst = Install.Entry.Dst.local p in
         if Path.Local.is_root (Path.Local.parent_exn dst)
         then (
-          let origin = { Artifacts.binding = fb; dir; dst; enabled_if } in
+          let origin = { Artifacts.binding = fb; dir; dst; enabled_if; package } in
           Some (Path.Local.basename dst, origin))
         else None)
       >>| List.filter_opt
@@ -83,12 +83,13 @@ let get_installed_binaries ~(context : Context.t) stanzas =
     Dune_file.static_stanzas d
     |> Memo.List.map ~f:(fun stanza ->
       match Stanza.repr stanza with
-      | Install_conf.T { section = _loc, Section Bin; files; enabled_if; _ } ->
+      | Install_conf.T { section = _loc, Section Bin; files; enabled_if; package; _ } ->
         let enabled_if = eval_blang enabled_if in
-        binaries_from_install ~enabled_if files
+        let package = Some (Package.name package) in
+        binaries_from_install ~enabled_if ~package files
       | Executables.T
-          ({ install_conf = Some { section = _loc, Section Bin; files; _ }; _ } as exes)
-        ->
+          ({ install_conf = Some { section = _loc, Section Bin; files; package; _ }; _ }
+           as exes) ->
         let enabled_if =
           let enabled_if = eval_blang exes.enabled_if in
           match exes.optional with
@@ -99,7 +100,8 @@ let get_installed_binaries ~(context : Context.t) stanzas =
              | false -> Memo.return false
              | true -> available_exes ~dir exes)
         in
-        binaries_from_install ~enabled_if files
+        let package = Some (Package.name package) in
+        binaries_from_install ~enabled_if ~package files
       | _ -> Memo.return Filename.Map.empty)
     >>| Filename.Map.union_all ~f:merge)
   >>| Filename.Map.union_all ~f:merge

src/dune_rules/bin_layout.ml

@@ -0,0 +1,100 @@
+open Import
+
+module Key : sig
+  type encoded = Digest.t
+
+  module Decoded : sig
+    type t = private { bins : string list }
+
+    val of_bins : string list -> t
+  end
+
+  val encode : Decoded.t -> encoded
+  val decode : encoded -> Decoded.t
+end = struct
+  type encoded = Digest.t
+
+  module Decoded = struct
+    type t = { bins : string list }
+
+    let equal x y = List.equal String.equal x.bins y.bins
+    let to_string { bins } = String.enumerate_and bins
+
+    let of_bins bins =
+      let bins = List.sort_uniq bins ~compare:String.compare in
+      { bins }
+    ;;
+  end
+
+  (* This mutable table is safe. [decode] is only called on digests produced
+     by [encode] in the same process (deps are evaluated before paths under
+     the layout dir are resolved), so the entry will always be present. An
+     unknown digest indicates an invariant violation. Same pattern as
+     [Ppx_driver.Key]. *)
+  let reverse_table : (Digest.t, Decoded.t) Table.t = Table.create (module Digest) 128
+
+  let encode ({ Decoded.bins } as x) =
+    let y = Digest.repr Repr.(list string) bins in
+    match Table.find reverse_table y with
+    | None ->
+      Table.set reverse_table y x;
+      y
+    | Some x' ->
+      if Decoded.equal x x'
+      then y
+      else
+        Code_error.raise
+          "Hash collision between sets of binaries"
+          [ "cached", Dyn.string (Decoded.to_string x')
+          ; "new", Dyn.string (Decoded.to_string x)
+          ]
+  ;;
+
+  let decode y =
+    match Table.find reverse_table y with
+    | Some x -> x
+    | None ->
+      Code_error.raise
+        "unknown bin-layout digest (encode was not called first)"
+        [ "digest", Dyn.string (Digest.to_string y) ]
+  ;;
+end
+
+let layout_dir ~context ~key =
+  Path.Build.relative (Install.Context.dir ~context) (".binaries/" ^ key)
+;;
+
+let create context bins =
+  let decoded = Key.Decoded.of_bins bins in
+  let digest = Key.encode decoded in
+  let key = Digest.to_string digest in
+  let dir = layout_dir ~context ~key in
+  let { Key.Decoded.bins } = decoded in
+  let files = List.map bins ~f:(fun name -> Path.build (Path.Build.relative dir name)) in
+  Memo.return (dir, files)
+;;
+
+let gen_rules context_name ~dir key =
+  match Digest.from_hex key with
+  | None -> User_error.raise [ Pp.textf "invalid bin-layout key %S" key ]
+  | Some digest ->
+    let { Key.Decoded.bins } = Key.decode digest in
+    let open Memo.O in
+    let* artifacts =
+      let* sctx = Super_context.find_exn context_name in
+      Artifacts_db.get (Super_context.context sctx)
+    in
+    Memo.parallel_iter bins ~f:(fun name ->
+      let* prog = Artifacts.binary artifacts ~where:Original_path ~dir ~loc:None name in
+      match prog with
+      | Error _ ->
+        Code_error.raise
+          "Bin_layout.gen_rules: binary not found"
+          [ "name", Dyn.string name; "context", Context_name.to_dyn context_name ]
+      | Ok src ->
+        let dst = Path.Build.relative dir name in
+        let { Action_builder.With_targets.build; targets } =
+          Action_builder.symlink ~src ~dst
+        in
+        Rules.Produce.rule (Rule.make ~targets build))
+;;

src/dune_rules/bin_layout.mli

@@ -0,0 +1,12 @@
+open Import
+
+(** Create a bin-layout directory for the given binary names. Returns the
+    layout directory and the list of symlink paths for dependency tracking.
+    The symlinks are created as build rules keyed by a digest of the sorted
+    binary names. *)
+val create : Context_name.t -> string list -> (Path.Build.t * Path.t list) Memo.t
+
+(** Generate symlink rules for the bin-layout directory identified by [key].
+    Called from [gen_rules] when the build system visits
+    [_build/install/<context>/.bin-layout/<key>/]. *)
+val gen_rules : Context_name.t -> dir:Path.Build.t -> string -> unit Memo.t

src/dune_rules/cinaps.ml

@@ -247,22 +247,22 @@ let gen_rules sctx t ~dir ~scope =
         let cinaps_exe = Path.Build.relative cinaps_dir (name ^ ".exe") in
         Path.build cinaps_exe
       in
-      let runtime_deps, sandbox =
+      let action_env, sandbox =
         let sandbox =
           if t.cinaps_version >= (1, 1)
           then Sandbox_config.needs_sandboxing
           else Sandbox_config.no_special_requirements
         in
         Dep_conf_eval.unnamed sandbox ~expander t.runtime_deps
       in
-      let* () = runtime_deps in
       let+ () =
         cinaps_exe :: List.rev_map cinapsed_files ~f:Path.build
         |> Dep.Set.of_files
         |> Action_builder.deps
-      in
-      Action.Full.make ~sandbox
-      @@ Action.chdir
+      and+ env = action_env in
+      Action.Full.make
+        ~sandbox
+        (Action.chdir
            (Path.build dir)
            (Action.progn
               [ Action.run (Ok cinaps_exe) [ "-diff-cmd"; "-" ]
@@ -272,7 +272,8 @@ let gen_rules sctx t ~dir ~scope =
                     ~optional:true
                     (Path.build fn)
                     (Path.Build.extend_basename fn ~suffix:".cinaps-corrected"))
-              ])
+              ]))
+      |> Action.Full.add_env env
     in
     Super_context.add_alias_action sctx ~dir ~loc cinaps_alias action
   in

src/dune_rules/compile_commands.ml

@@ -67,7 +67,7 @@ let collect_from_foreign_sources
     ocaml.lib_config.ext_obj
   in
   Foreign.Sources.to_list_map foreign_sources ~f:(fun _ (_, src) ->
-    let include_flags =
+    let include_flags, _action_env =
       Foreign_rules.build_include_flags ~sctx ~dir ~expander ~dir_contents ~requires ~src
     in
     build_c_command ~sctx ~dir ~expander ~include_flags src ~ext_obj)