diff options
| -rw-r--r-- | guix/build/download.scm | 129 |
1 files changed, 0 insertions, 129 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index 0f2d5f402a..c647d00f6b 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -457,135 +457,6 @@ VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." 'set-port-encoding! (lambda (p e) #f)) -;; XXX: Work around <http://bugs.gnu.org/23421>, fixed in Guile commit -;; 16050431f29d56f80c4a8253506fc851b8441840. Guile's date validation -;; procedure rejects dates in which the hour is not padded with a zero but -;; with whitespace. -(begin - (define-syntax string-match? - (lambda (x) - (syntax-case x () - ((_ str pat) (string? (syntax->datum #'pat)) - (let ((p (syntax->datum #'pat))) - #`(let ((s str)) - (and - (= (string-length s) #,(string-length p)) - #,@(let lp ((i 0) (tests '())) - (if (< i (string-length p)) - (let ((c (string-ref p i))) - (lp (1+ i) - (case c - ((#\.) ; Whatever. - tests) - ((#\d) ; Digit. - (cons #`(char-numeric? (string-ref s #,i)) - tests)) - ((#\a) ; Alphabetic. - (cons #`(char-alphabetic? (string-ref s #,i)) - tests)) - (else ; Literal. - (cons #`(eqv? (string-ref s #,i) #,c) - tests))))) - tests))))))))) - - (define (parse-rfc-822-date str space zone-offset) - (let ((parse-non-negative-integer (@@ (web http) parse-non-negative-integer)) - (parse-month (@@ (web http) parse-month)) - (bad-header (@@ (web http) bad-header))) - ;; We could verify the day of the week but we don't. - (cond ((string-match? (substring str 0 space) "aaa, dd aaa dddd dd:dd:dd") - (let ((date (parse-non-negative-integer str 5 7)) - (month (parse-month str 8 11)) - (year (parse-non-negative-integer str 12 16)) - (hour (parse-non-negative-integer str 17 19)) - (minute (parse-non-negative-integer str 20 22)) - (second (parse-non-negative-integer str 23 25))) - (make-date 0 second minute hour date month year zone-offset))) - ((string-match? (substring str 0 space) "aaa, d aaa dddd dd:dd:dd") - (let ((date (parse-non-negative-integer str 5 6)) - (month (parse-month str 7 10)) - (year (parse-non-negative-integer str 11 15)) - (hour (parse-non-negative-integer str 16 18)) - (minute (parse-non-negative-integer str 19 21)) - (second (parse-non-negative-integer str 22 24))) - (make-date 0 second minute hour date month year zone-offset))) - - ;; The next two clauses match dates that have a space instead of - ;; a leading zero for hours, like " 8:49:37". - ((string-match? (substring str 0 space) "aaa, dd aaa dddd d:dd:dd") - (let ((date (parse-non-negative-integer str 5 7)) - (month (parse-month str 8 11)) - (year (parse-non-negative-integer str 12 16)) - (hour (parse-non-negative-integer str 18 19)) - (minute (parse-non-negative-integer str 20 22)) - (second (parse-non-negative-integer str 23 25))) - (make-date 0 second minute hour date month year zone-offset))) - ((string-match? (substring str 0 space) "aaa, d aaa dddd d:dd:dd") - (let ((date (parse-non-negative-integer str 5 6)) - (month (parse-month str 7 10)) - (year (parse-non-negative-integer str 11 15)) - (hour (parse-non-negative-integer str 17 18)) - (minute (parse-non-negative-integer str 19 21)) - (second (parse-non-negative-integer str 22 24))) - (make-date 0 second minute hour date month year zone-offset))) - - (else - (bad-header 'date str) ; prevent tail call - #f)))) - (module-set! (resolve-module '(web http)) - 'parse-rfc-822-date parse-rfc-822-date)) - -;; XXX: Work around broken proxy handling on Guile 2.2 <= 2.2.2, fixed in -;; Guile commits 7d0d9e2c25c1e872cfc7d14ab5139915f1813d56 and -;; 6ad28ae3bc6a6d9e95ab7d70510d12c97673a143. See bug report at -;; <https://lists.gnu.org/archive/html/guix-devel/2017-11/msg00070.html>. -(cond-expand - (guile-2.2 - (when (<= (string->number (micro-version)) 2) - (let () - (define put-symbol (@@ (web http) put-symbol)) - (define put-non-negative-integer - (@@ (web http) put-non-negative-integer)) - (define write-http-version - (@@ (web http) write-http-version)) - - (define (write-request-line method uri version port) - "Write the first line of an HTTP request to PORT." - (put-symbol port method) - (put-char port #\space) - (when (http-proxy-port? port) - (let ((scheme (uri-scheme uri)) - (host (uri-host uri)) - (host-port (uri-port uri))) - (when (and scheme host) - (put-symbol port scheme) - (put-string port "://") - (cond - ((string-index host #\:) ;<---- The fix is here! - (put-char port #\[) ;<---- And here! - (put-string port host) - (put-char port #\])) - (else - (put-string port host))) - (unless ((@@ (web uri) default-port?) scheme host-port) - (put-char port #\:) - (put-non-negative-integer port host-port))))) - (let ((path (uri-path uri)) - (query (uri-query uri))) - (if (string-null? path) - (put-string port "/") - (put-string port path)) - (when query - (put-string port "?") - (put-string port query))) - (put-char port #\space) - (write-http-version version port) - (put-string port "\r\n")) - - (module-set! (resolve-module '(web http)) 'write-request-line - write-request-line)))) - (else #t)) - (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. |