summaryrefslogtreecommitdiff
path: root/guix/build/download.scm
diff options
context:
space:
mode:
authorMark H Weaver <mhw@netris.org>2015-02-18 19:33:10 -0500
committerMark H Weaver <mhw@netris.org>2015-02-19 03:32:22 -0500
commit04dec194d8e460831ec0695a944d9c7313affea2 (patch)
tree7b384927264e072da1211aff2a9c58b0ac606be1 /guix/build/download.scm
parente92a4ad928e869e98043f1f4afc7df20666bbf02 (diff)
download: Handle HTTP redirects to relative URI references.
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'
Diffstat (limited to 'guix/build/download.scm')
-rw-r--r--guix/build/download.scm82
1 files changed, 81 insertions, 1 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 5928ccd154..16afb1dce1 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -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)