02/06: Handle the same HTTP redirects everywhere.

[Tobias Geerinckx-Rice]

nckx pushed a commit to branch master
in repository guix.

commit 57d28987722cb6b830fae212ea0d6a704580ff9c
Author: Tobias Geerinckx-Rice <address@hidden>
Date:   Mon Aug 28 15:46:10 2017 +0200

    Handle the same HTTP redirects everywhere.
    
    * guix/build/download.scm (http-fetch): Complete the hard-coded list of HTTP
    redirection status codes.
    * guix/http-client.scm (http-fetch): Likewise.
    * guix/scripts/lint.scm (probe-uri): Likewise.
---
 guix/build/download.scm | 5 ++++-
 guix/http-client.scm    | 6 +++++-
 guix/scripts/lint.scm   | 7 ++++++-
 3 files changed, 15 insertions(+), 3 deletions(-)

diff --git a/guix/build/download.scm b/guix/build/download.scm
index 6ef6233..bcf2266 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès 
<address@hidden>
 ;;; Copyright © 2015 Mark H Weaver <address@hidden>
 ;;; Copyright © 2015 Steve Sprang <address@hidden>
+;;; Copyright © 2017 Tobias Geerinckx-Rice <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -763,7 +764,9 @@ certificates; otherwise simply ignore them."
          file))
       ((301                                       ; moved permanently
         302                                       ; found (redirection)
-        307)                                      ; temporary redirection
+        303                                       ; see other
+        307                                       ; temporary redirection
+        308)                                      ; permanent redirection
        (let ((uri (resolve-uri-reference (response-location resp) uri)))
          (format #t "following redirection to `~a'...~%"
                  (uri->string uri))
diff --git a/guix/http-client.scm b/guix/http-client.scm
index 3c5441c..5c9342c 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès 
<address@hidden>
 ;;; Copyright © 2015 Mark H Weaver <address@hidden>
 ;;; Copyright © 2012, 2015 Free Software Foundation, Inc.
+;;; Copyright © 2017 Tobias Geerinckx-Rice <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -259,7 +260,10 @@ Raise an '&http-get-error' condition if downloading fails."
           ((200)
            (values data (response-content-length resp)))
           ((301                                   ; moved permanently
-            302)                                  ; found (redirection)
+            302                                   ; found (redirection)
+            303                                   ; see other
+            307                                   ; temporary redirection
+            308)                                  ; permanent redirection
            (let ((uri (resolve-uri-reference (response-location resp) uri)))
              (close-port port)
              (format #t (G_ "following redirection to `~a'...~%")
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index aceafc6..57bbeec 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -6,6 +6,7 @@
 ;;; Copyright © 2016 Danny Milosavljevic <address@hidden>
 ;;; Copyright © 2016 Hartmut Goebel <address@hidden>
 ;;; Copyright © 2017 Alex Kost <address@hidden>
+;;; Copyright © 2017 Tobias Geerinckx-Rice <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -411,7 +412,11 @@ for connections to complete; when TIMEOUT is #f, wait as 
long as needed."
                    (close-connection port))))
 
              (case (response-code response)
-               ((301 302 307)
+               ((301                    ; moved permanently
+                 302                    ; found (redirection)
+                 303                    ; see other
+                 307                    ; temporary redirection
+                 308)                   ; permanent redirection
                 (let ((location (response-location response)))
                   (if (or (not location) (member location visited))
                       (values 'http-response response)