me/guix
Archived
1
0
Fork 0
Code Activity

download: Remove (web http) workarounds no longer relevant.

Browse source 
* 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 2020-03-11 16:19:38 +01:00
parent e688c2df39
commit d8a822f462
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 0 additions and 129 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

129
guix/build/download.scm
View file

@ -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.