From f20e01f2a8df538519660772a7431b53d650d64f Mon Sep 17 00:00:00 2001
From: Julien Lepiller <julien@lepiller.eu>
Date: Tue, 12 Jan 2021 18:07:25 +0100
Subject: [PATCH] substitute: Follow narinfo redirections.

* guix/scripts/substitute.scm (fetch-narinfos): Follow redirections.
---
 guix/scripts/substitute.scm | 38 +++++++++++++++++++++++++++----------
 1 file changed, 28 insertions(+), 10 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index e53de8c304..790168091e 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -663,18 +663,36 @@ port to it, or, if connection failed, print a warning and return #f.  Pass
            (len    (response-content-length response))
            (cache  (response-cache-control response))
            (ttl    (and cache (assoc-ref cache 'max-age))))
-      (update-progress!)
 
       ;; Make sure to read no more than LEN bytes since subsequent bytes may
       ;; belong to the next response.
-      (if (= code 200)                            ; hit
-          (let ((narinfo (read-narinfo port url #:size len)))
-            (if (string=? (dirname (narinfo-path narinfo))
-                          (%store-prefix))
-                (begin
-                  (cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
-                  (cons narinfo result))
-                result))
+      (case code
+        ((200)                            ; hit
+         (update-progress!)
+         (let ((narinfo (read-narinfo port url #:size len)))
+           (if (string=? (dirname (narinfo-path narinfo))
+                         (%store-prefix))
+               (begin
+                 (cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
+                 (cons narinfo result))
+               result)))
+        ((301 302 303 307 308)            ; redirect
+         (let* ((uri (response-location response))
+                (new-request (build-request
+                               uri #:headers '((User-Agent . "GNU Guile")))))
+           (if len
+               (get-bytevector-n port len)
+               (read-to-eof port))
+           (append
+             (http-multiple-get uri
+                                handle-narinfo-response '()
+                                (list new-request)
+                                #:open-connection
+                                open-connection-for-uri/cached
+                                #:verify-certificate? #f)
+             result)))
+        (else
+          (update-progress!)
           (let* ((path      (uri-path (request-uri request)))
                  (hash-part (basename
                              (string-drop-right path 8)))) ;drop ".narinfo"
@@ -685,7 +703,7 @@ port to it, or, if connection failed, print a warning and return #f.  Pass
                             (if (or (= 404 code) (= 202 code))
                                 ttl
                                 %narinfo-transient-error-ttl))
-            result))))
+            result)))))
 
   (define (do-fetch uri)
     (case (and=> uri uri-scheme)
-- 
2.29.2