web http: fix Ma -> Mar

[bpt/guile.git] / module / web / http.scm

diff --git a/module/web/http.scm b/module/web/http.scm
index 70db813..879923f 100644 (file)
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -1,6 +1,6 @@
 ;;; HTTP messages
 
-;; Copyright (C)  2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C)  2010, 2011, 2012 Free Software Foundation, Inc.
 
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -205,7 +205,7 @@ header with name @var{sym}."
 (define (write-header sym val port)
   "Writes the given header name and value to @var{port}.  If @var{sym}
 is a known header, uses the specific writer registered for that header.
-Otherwise the value is written using @var{display}."
+Otherwise the value is written using @code{display}."
   (display (header->string sym) port)
   (display ": " port)
   ((header-writer sym) val port)
@@ -470,7 +470,7 @@ ordered alist."
   val)
 
 (define (default-val-validator k val)
-  (string? val))
+  (or (not val) (string? val)))
 
 (define (default-val-writer k val port)
   (if (or (string-index val #\;)
@@ -518,9 +518,9 @@ ordered alist."
                ((pair? elt)
                 (let ((k (car elt))
                       (v (cdr elt)))
-                  (and (or (string? k) (symbol? k))
+                  (and (symbol? k)
                        (valid? k v))))
-               ((or (string? elt) (symbol? elt))
+               ((symbol? elt)
                 (valid? elt #f))
                (else #f)))))
 
@@ -611,7 +611,7 @@ ordered alist."
                               (valid? default-val-validator))
   (list-of? list
             (lambda (elt)
-              (key-value-list? list valid?))))
+              (key-value-list? elt valid?))))
 
 (define* (write-param-list list port #:optional
                            (val-writer default-val-writer))
@@ -784,13 +784,13 @@ ordered alist."
                   date
                   (time-tai->date (date->time-tai date) 0))))
     (display (case (date-week-day date)
-               ((0) "Sun, ") ((2) "Mon, ") ((2) "Tue, ")
+               ((0) "Sun, ") ((1) "Mon, ") ((2) "Tue, ")
                ((3) "Wed, ") ((4) "Thu, ") ((5) "Fri, ")
                ((6) "Sat, ") (else (error "bad date" date)))
              port)
     (display-digits (date-day date) 2 port)
     (display (case (date-month date)
-               ((1)  " Jan ") ((2)  " Feb ") ((3)  " Ma ")
+               ((1)  " Jan ") ((2)  " Feb ") ((3)  " Mar ")
                ((4)  " Apr ") ((5)  " May ") ((6)  " Jun ")
                ((7)  " Jul ") ((8)  " Aug ") ((9)  " Sep ")
                ((10) " Oct ") ((11) " Nov ") ((12) " Dec ")
@@ -805,9 +805,6 @@ ordered alist."
     (display-digits (date-second date) 2 port)
     (display " GMT" port)))
 
-(define (write-uri uri port)
-  (display (uri->string uri) port))
-
 (define (parse-entity-tag val)
   (if (string-prefix? "W/" val)
       (cons (parse-qstring val 2) #f)
@@ -871,7 +868,10 @@ ordered alist."
          (cons scheme (parse-key-value-list str default-val-parser delim end)))))))
 
 (define (validate-credentials val)
-  (and (pair? val) (symbol? (car val)) (key-value-list? (cdr val))))
+  (and (pair? val) (symbol? (car val))
+       (case (car val)
+         ((basic) (string? (cdr val)))
+         (else (key-value-list? (cdr val))))))
 
 (define (write-credentials val port)
   (display (car val) port)
@@ -1079,7 +1079,18 @@ three values: the method, the URI, and the version."
   "Write the first line of an HTTP request to @var{port}."
   (display method port)
   (display #\space port)
-  (write-uri uri port)
+  (let ((path (uri-path uri))
+        (query (uri-query uri)))
+    (if (not (string-null? path))
+        (display path port))
+    (if query
+        (begin
+          (display "?" port)
+          (display query port)))
+    (if (and (string-null? path)
+             (not query))
+        ;; Make sure we display something.
+        (display "/" port)))
   (display #\space port)
   (write-http-version version port)
   (display "\r\n" port))
@@ -1137,7 +1148,7 @@ phrase\"."
     (lambda (str)
       (map string->symbol (split-and-trim str)))
     (lambda (v)
-      (list-of? symbol? v))
+      (list-of? v symbol?))
     (lambda (v port)
       (write-list v port display ", "))))
 
@@ -1237,15 +1248,28 @@ phrase\"."
 (declare-key-value-list-header! "Cache-Control"
   (lambda (k v-str)
     (case k
-      ((max-age max-stale min-fresh s-maxage)
+      ((max-age min-fresh s-maxage)
        (parse-non-negative-integer v-str))
+      ((max-stale)
+       (and v-str (parse-non-negative-integer v-str)))
       ((private no-cache)
        (and v-str (split-header-names v-str)))
       (else v-str)))
-  default-val-validator
+  (lambda (k v)
+    (case k
+      ((max-age min-fresh s-maxage)
+       (non-negative-integer? v))
+      ((max-stale)
+       (or (not v) (non-negative-integer? v)))
+      ((private no-cache)
+       (or (not v) (list-of-header-names? v)))
+      ((no-store no-transform only-if-cache must-revalidate proxy-revalidate)
+       (not v))
+      (else
+       (or (not v) (string? v)))))
   (lambda (k v port)
     (cond
-     ((string? v) (display v port))
+     ((string? v) (default-val-writer k v port))
      ((pair? v)
       (display #\" port)
       (write-header-list v port)
@@ -1490,7 +1514,15 @@ phrase\"."
 
 ;; Expires = HTTP-date
 ;;
-(declare-date-header! "Expires")
+(define *date-in-the-past* (parse-date "Thu, 01 Jan 1970 00:00:00 GMT"))
+
+(declare-header! "Expires"
+  (lambda (str)
+    (if (member str '("0" "-1"))
+        *date-in-the-past*
+        (parse-date str)))
+  date?
+  write-date)
 
 ;; Last-Modified = HTTP-date
 ;;
@@ -1522,7 +1554,7 @@ phrase\"."
   (lambda (k v)
     (if (eq? k 'q)
         (valid-quality? v)
-        (string? v)))
+        (or (not v) (string? v))))
   (lambda (k v port)
     (if (eq? k 'q)
         (write-quality v port)