01/01: build: Accept dates with space-padded hour field.

[Ricardo Wurmus]

rekado pushed a commit to branch master
in repository guix.

commit 8bfd602bb00ba7bed8f0108f4cea5ac92b772b7e
Author: Ricardo Wurmus <address@hidden>
Date:   Fri Apr 29 22:12:24 2016 +0200

    build: Accept dates with space-padded hour field.
    
    * guix/build/download.scm: Replace "parse-rfc-822-date" from the (web
      http) module.
---
 guix/build/download.scm |   79 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 79 insertions(+)

diff --git a/guix/build/download.scm b/guix/build/download.scm
index 824e1c3..7741726 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)