kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity

download: Handle HTTP redirects to relative URI references.

Browse Source 
Fixes <http://bugs.gnu.org/19840>.
Reported by Ricardo Wurmus <rekado@elephly.net>.

* guix/build/download.scm: On Guile 2.0.11 or earlier, redefine the http
  "Location" header to accept relative URIs.
  (resolve-uri-reference): New exported procedure.
  (http-fetch): Use 'resolve-uri-reference' to resolve redirections.
* guix/http-client.scm (http-fetch): Use 'resolve-uri-reference'
This commit is contained in:
Mark H Weaver 2015-02-18 19:33:10 -05:00
parent e92a4ad928
commit 04dec194d8
2 changed files with 84 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
guix/build/download.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -29,6 +30,7 @@
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:export (open-connection-for-uri
resolve-uri-reference
maybe-expand-mirrors
url-fetch
progress-proc
@ -204,6 +206,84 @@ which is not available during bootstrap."
(module-define! (resolve-module '(web client))
'shutdown (const #f))
;; XXX: Work around <http://bugs.gnu.org/19840>, present in Guile
;; up to 2.0.11.
(unless (or (> (string->number (major-version)) 2)
(> (string->number (minor-version)) 0)
(> (string->number (micro-version)) 11))
(let ((declare-relative-uri-header!
(module-ref (resolve-module '(web http))
'declare-relative-uri-header!)))
(declare-relative-uri-header! "Location")))
(define (resolve-uri-reference ref base)
"Resolve the URI reference REF, interpreted relative to the BASE URI, into a
target URI, according to the algorithm specified in RFC 3986 section 5.2.2.
Return the resulting target URI."
(define (merge-paths base-path rel-path)
(let* ((base-components (string-split base-path #\/))
(base-directory-components (match base-components
((components ... last) components)
(() '())))
(base-directory (string-join base-directory-components "/")))
(string-append base-directory "/" rel-path)))
(define (remove-dot-segments path)
(let loop ((in
;; Drop leading "." and ".." components from a relative path.
;; (absolute paths will start with a "" component)
(drop-while (match-lambda
((or "." "..") #t)
(_ #f))
(string-split path #\/)))
(out '()))
(match in
(("." . rest)
(loop rest out))
((".." . rest)
(match out
((or () (""))
(error "remove-dot-segments: too many '..' components" path))
(_
(loop rest (cdr out)))))
((component . rest)
(loop rest (cons component out)))
(()
(string-join (reverse out) "/")))))
(cond ((or (uri-scheme ref)
(uri-host ref))
(build-uri (or (uri-scheme ref)
(uri-scheme base))
#:userinfo (uri-userinfo ref)
#:host (uri-host ref)
#:port (uri-port ref)
#:path (remove-dot-segments (uri-path ref))
#:query (uri-query ref)
#:fragment (uri-fragment ref)))
((string-null? (uri-path ref))
(build-uri (uri-scheme base)
#:userinfo (uri-userinfo base)
#:host (uri-host base)
#:port (uri-port base)
#:path (remove-dot-segments (uri-path base))
#:query (or (uri-query ref)
(uri-query base))
#:fragment (uri-fragment ref)))
(else
(build-uri (uri-scheme base)
#:userinfo (uri-userinfo base)
#:host (uri-host base)
#:port (uri-port base)
#:path (remove-dot-segments
(if (string-prefix? "/" (uri-path ref))
(uri-path ref)
(merge-paths (uri-path base)
(uri-path ref))))
#:query (uri-query ref)
#:fragment (uri-fragment ref)))))
(define (http-fetch uri file)
"Fetch data from URI and write it to FILE. Return FILE on success."
@ -260,7 +340,7 @@ which is not available during bootstrap."
file))
((301 ; moved permanently
302) ; found (redirection)
(let ((uri (response-location resp)))
(let ((uri (resolve-uri-reference (response-location resp) uri)))
(format #t "following redirection to `~a'...~%"
(uri->string uri))
(close connection)

4
guix/http-client.scm
View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2012 Free Software Foundation, Inc.
;;;
;;; This file is part of GNU Guix.
@ -29,6 +30,7 @@
#:use-module (rnrs bytevectors)
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module ((guix build download) #:select (resolve-uri-reference))
#:export (&http-get-error
http-get-error?
http-get-error-uri
@ -227,7 +229,7 @@ Raise an '&http-get-error' condition if downloading fails."
(values data len)))))
((301 ; moved permanently
302) ; found (redirection)
(let ((uri (response-location resp)))
(let ((uri (resolve-uri-reference (response-location resp) uri)))
(close-port port)
(format #t (_ "following redirection to `~a'...~%")
(uri->string uri))