summaryrefslogtreecommitdiff
path: root/guix/build
diff options
context:
space:
mode:
authorRicardo Wurmus <rekado@elephly.net>2016-04-29 22:12:24 +0200
committerRicardo Wurmus <rekado@elephly.net>2016-05-16 18:26:26 +0200
commit8bfd602bb00ba7bed8f0108f4cea5ac92b772b7e (patch)
tree32863bfaeef4c1b59487cca7c4cc798bbf54f6d8 /guix/build
parentd3699b311b01b09d37640ed613fa6094059ed72f (diff)
build: Accept dates with space-padded hour field.
* guix/build/download.scm: Replace "parse-rfc-822-date" from the (web http) module.
Diffstat (limited to 'guix/build')
-rw-r--r--guix/build/download.scm79
1 files changed, 79 insertions, 0 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 824e1c354a..7741726c41 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -426,6 +426,85 @@ port if PORT is a TLS session record port."
(module-define! (resolve-module '(web client))
'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
;; up to 2.0.11.
(unless (or (> (string->number (major-version)) 2)