2 files changed, 57 insertions, 14 deletions

diff --git a/guix/substitutes.scm b/guix/substitutes.scm
index b2a79c2a48d..289a068dbf3 100644
--- a/guix/substitutes.scm
+++ b/guix/substitutes.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013-2021, 2023-2025 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2021, 2023-2026 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
 ;;; Copyright © 2020 Christopher Baines <mail@cbaines.net>
@@ -230,7 +230,11 @@ it contains invalid store file names--and return the narinfo otherwise."
     (dump-port port (%make-void-port "w")))
 
   (define (handle-narinfo-response request response port result)
-    (let* ((code   (response-code response))
+    (let* ((hash-part (basename
+                       (string-drop-right (uri-path (request-uri request))
+                                          (string-length ".narinfo"))))
+           (path   (hash-part->path hash-part))
+           (code   (response-code response))
            (len    (response-content-length response))
            (cache  (response-cache-control response))
            (ttl    (and cache (assoc-ref cache 'max-age))))
@@ -240,21 +244,18 @@ it contains invalid store file names--and return the narinfo otherwise."
       ;; belong to the next response.
       (if (= code 200)                            ; hit
           (let ((narinfo (read-narinfo port url #:size len)))
-            (if narinfo
+            (if (and narinfo path
+                     ;; Make sure we got what we asked for.
+                     (string=? (narinfo-path narinfo) path))
                 (begin
                   (cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
                   (cons narinfo result))
                 result))
-          (let* ((path      (uri-path (request-uri request)))
-                 (hash-part (basename
-                             (string-drop-right path 8)))) ;drop ".narinfo"
-            ;; Log the failing queries and indicate if it failed because the
-            ;; narinfo is being baked.
-            (let ((baking?
-                   (assoc-ref (response-headers response) 'x-baking)))
-              (debug "could not fetch ~a~a ~a~a~%"
-                     url path code
-                     (if baking? " (baking)" "")))
+          ;; Log the failing queries and indicate if it failed because the
+          ;; narinfo is being baked.
+          (let ((baking? (assoc-ref (response-headers response) 'x-baking)))
+            (debug "could not fetch ~a~a ~a~a~%"
+                   url path code (if baking? " (baking)" ""))
             (if len
                 (get-bytevector-n port len)
                 (read-to-eof port))
@@ -288,7 +289,14 @@ it contains invalid store file names--and return the narinfo otherwise."
               (files (map (compose (cut string-append base <> ".narinfo")
                                    store-path-hash-part)
                           paths)))
-         (filter-map (cut narinfo-from-file <> url) files)))
+         (filter-map (lambda (file path)
+                       (let ((narinfo (narinfo-from-file file url)))
+                         (and narinfo
+                              ;; Make sure we got what we asked for.
+                              (string=? (narinfo-path narinfo) path)
+                              narinfo)))
+                     files
+                     paths)))
       (else
        (leave (G_ "~s: unsupported server URI scheme~%")
               (if uri (uri-scheme uri) url)))))
diff --git a/tests/substitute.scm b/tests/substitute.scm
index 8f32bfa7281..b749561347a 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -357,6 +357,29 @@ Deriver: foo.drv")
              (lambda ()
                (guix-substitute "--query")))))))))
 
+(test-equal "query narinfo that returns different store path"
+  ;; The narinfo is valid and authorized but its 'StorePath' field points to a
+  ;; different store item.
+  ""
+
+  (let ((prefix (string-append "StorePath: " (%store-prefix)
+                               "/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-BAR
+NarHash: sha256:bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb
+References: bar baz\n")))
+    (with-narinfo (string-append prefix
+                                 "Signature: " (signature-field prefix) "
+URL: example.nar
+Compression: none
+NarSize: 42
+Deriver: foo.drv")
+      (string-trim-both
+       (with-output-to-string
+         (lambda ()
+           (with-input-from-string (string-append "have " (%store-prefix)
+                                                  "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+             (lambda ()
+               (guix-substitute "--query")))))))))
+
 (test-equal "query narinfo signed with authorized key"
   (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
 
@@ -893,6 +916,18 @@ System: mips64el-linux\n")))
         (lambda ()
           (false-if-exception (delete-file "substitute-retrieved")))))))
 
+(test-quit "substitute, narinfo does not match requested store item"
+    "no valid substitute"
+  (with-http-server `((200 ,(string-append %narinfo "Signature: "
+                                           (signature-field %narinfo))))
+    (parameterize ((substitute-urls (list (%local-url))))
+      ;; Narinfo is valid, signed, and authorized but requested item is
+      ;; /bbb…-bar and narinfo is for /aaa…-foo.
+      (request-substitution (string-append (%store-prefix)
+                                           "/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb-bar")
+                            "substitute-retrieved")
+      #f)))
+
 (test-end "substitute")
 
 ;;; Local Variables: