nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
Tobias Geerinckx-Rice 2017-08-28 15:46:10 +02:00
parent a4c1e99ed9
commit 57d2898772
No known key found for this signature in database
GPG Key ID: 0DB0FF884F556D79
3 changed files with 15 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
guix/build/download.scm
View File

@ -2,6 +2,7 @@
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com> ;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -763,7 +764,9 @@ certificates; otherwise simply ignore them."
file)) file))
((301 ; moved permanently ((301 ; moved permanently
302 ; found (redirection) 302 ; found (redirection)
307) ; temporary redirection 303 ; see other
307 ; temporary redirection
308) ; permanent redirection
(let ((uri (resolve-uri-reference (response-location resp) uri))) (let ((uri (resolve-uri-reference (response-location resp) uri)))
(format #t "following redirection to `~a'...~%" (format #t "following redirection to `~a'...~%"
(uri->string uri)) (uri->string uri))

6
guix/http-client.scm
View File

@ -2,6 +2,7 @@
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2012, 2015 Free Software Foundation, Inc. ;;; Copyright © 2012, 2015 Free Software Foundation, Inc.
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -259,7 +260,10 @@ Raise an '&http-get-error' condition if downloading fails."
((200) ((200)
(values data (response-content-length resp))) (values data (response-content-length resp)))
((301 ; moved permanently ((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))) (let ((uri (resolve-uri-reference (response-location resp) uri)))
(close-port port) (close-port port)
(format #t (G_ "following redirection to `~a'...~%") (format #t (G_ "following redirection to `~a'...~%")

7
guix/scripts/lint.scm
View File

@ -6,6 +6,7 @@
;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org> ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2017 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; ;;;
;;; This file is part of GNU Guix. ;;; 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)))) (close-connection port))))
(case (response-code response) (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))) (let ((location (response-location response)))
(if (or (not location) (member location visited)) (if (or (not location) (member location visited))
(values 'http-response response) (values 'http-response response)