build: Accept dates with space-padded hour field.
* guix/build/download.scm: Replace "parse-rfc-822-date" from the (web http) module.
This commit is contained in:
parent
d3699b311b
commit
8bfd602bb0
|
@ -426,6 +426,85 @@ (define (close-connection port)
|
||||||
(module-define! (resolve-module '(web client))
|
(module-define! (resolve-module '(web client))
|
||||||
'shutdown (const #f))
|
'shutdown (const #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 <http://bugs.gnu.org/19840>, present in Guile
|
;; XXX: Work around <http://bugs.gnu.org/19840>, present in Guile
|
||||||
;; up to 2.0.11.
|
;; up to 2.0.11.
|
||||||
(unless (or (> (string->number (major-version)) 2)
|
(unless (or (> (string->number (major-version)) 2)
|
||||||
|
|
Loading…
Reference in a new issue