download: Remove (web http) workarounds no longer relevant.
* guix/build/download.scm <top level>: Remove workarounds for <https://bugs.gnu.org/23421> and for <https://lists.gnu.org/archive/html/guix-devel/2017-11/msg00070.html>.
This commit is contained in:
Ludovic Courtès
parent
e688c2df39
commit
d8a822f462
|
|
@ -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.
|
||||
|
|
|
|||
Loading…
Reference in New Issue