check symbols constants uninterned

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

diff --git a/module/web/http.scm b/module/web/http.scm
index 21d2964..a157cf0 100644 (file)
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -1,6 +1,6 @@
 ;;; HTTP messages
 
-;; Copyright (C)  2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;; Copyright (C)  2010, 2011, 2012, 2013, 2014 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
@@ -716,6 +716,8 @@ as an ordered alist."
     (cond
      ((string=? s "GMT")
       0)
+     ((string=? s "UTC")
+      0)
      ((string-match? s ".dddd")
       (let ((sign (case (string-ref s 0)
                     ((#\+) +1)
@@ -916,10 +918,10 @@ as an ordered alist."
 
 (define (write-credentials val port)
   (display (car val) port)
-  (if (pair? (cdr val))
-      (begin
-        (display #\space port)
-        (write-key-value-list (cdr val) port))))
+  (display #\space port)
+  (case (car val)
+    ((basic) (display (cdr val) port))
+    (else (write-key-value-list (cdr val) port))))
 
 ;; challenges = 1#challenge
 ;; challenge = auth-scheme 1*SP 1#auth-param
@@ -1088,20 +1090,19 @@ three values: the method, the URI, and the version."
         (bad-request "Bad Request-Line: ~s" line))))
 
 (define (write-uri uri port)
-  (if (uri-host uri)
-      (begin
-        (display (uri-scheme uri) port)
-        (display "://" port)
-        (if (uri-userinfo uri)
-            (begin
-              (display (uri-userinfo uri) port)
-              (display #\@ port)))
-        (display (uri-host uri) port)
-        (let ((p (uri-port uri)))
-          (if (and p (not (eqv? p 80)))
-              (begin
-                (display #\: port)
-                (display p port))))))
+  (when (uri-host uri)
+    (when (uri-scheme uri)
+      (display (uri-scheme uri) port)
+      (display #\: port))
+    (display "//" port)
+    (when (uri-userinfo uri)
+      (display (uri-userinfo uri) port)
+      (display #\@ port))
+    (display (uri-host uri) port)
+    (let ((p (uri-port uri)))
+      (when (and p (not (eqv? p 80)))
+        (display #\: port)
+        (display p port))))
   (let* ((path (uri-path uri))
          (len (string-length path)))
     (cond
@@ -1111,10 +1112,9 @@ three values: the method, the URI, and the version."
       (bad-request "Empty path and no host for URI: ~s" uri))
      (else
       (display path port))))
-  (if (uri-query uri)
-      (begin
-        (display #\? port)
-        (display (uri-query uri) port))))
+  (when (uri-query uri)
+    (display #\? port)
+    (display (uri-query uri) port)))
 
 (define (write-request-line method uri version port)
   "Write the first line of an HTTP request to PORT."
@@ -1137,16 +1137,13 @@ three values: the method, the URI, and the version."
           (display host-port port)))))
   (let ((path (uri-path uri))
         (query (uri-query uri)))
-    (if (not (string-null? path))
+    (if (string-null? path)
+        (display "/" port)
         (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 query port))))
   (display #\space port)
   (write-http-version version port)
   (display "\r\n" port))
@@ -1227,11 +1224,11 @@ treated specially, and is just returned as a plain string."
     (@@ (web uri) absolute-uri?)
     write-uri))
 
-;; emacs: (put 'declare-relative-uri-header! 'scheme-indent-function 1)
-(define (declare-relative-uri-header! name)
+;; emacs: (put 'declare-uri-reference-header! 'scheme-indent-function 1)
+(define (declare-uri-reference-header! name)
   (declare-header! name
     (lambda (str)
-      (or ((@@ (web uri) string->uri*) str)
+      (or (string->uri-reference str)
           (bad-header-component 'uri str)))
     uri?
     write-uri))
@@ -1484,6 +1481,30 @@ treated specially, and is just returned as a plain string."
 ;;
 (declare-symbol-list-header! "Allow")
 
+;; Content-Disposition = disposition-type *( ";" disposition-parm )
+;; disposition-type = "attachment" | disp-extension-token
+;; disposition-parm = filename-parm | disp-extension-parm
+;; filename-parm = "filename" "=" quoted-string
+;; disp-extension-token = token
+;; disp-extension-parm = token "=" ( token | quoted-string )
+;;
+(declare-header! "Content-Disposition"
+  (lambda (str)
+    (let ((disposition (parse-param-list str default-val-parser)))
+      ;; Lazily reuse the param list parser.
+      (unless (and (pair? disposition)
+                   (null? (cdr disposition)))
+        (bad-header-component 'content-disposition str))
+      (car disposition)))
+  (lambda (val)
+    (and (pair? val)
+         (symbol? (car val))
+         (list-of? (cdr val)
+                   (lambda (x)
+                     (and (pair? x) (symbol? (car x)) (string? (cdr x)))))))
+  (lambda (val port)
+    (write-param-list (list val) port)))
+
 ;; Content-Encoding = 1#content-coding
 ;;
 (declare-symbol-list-header! "Content-Encoding")
@@ -1496,9 +1517,9 @@ treated specially, and is just returned as a plain string."
 ;;
 (declare-integer-header! "Content-Length")
 
-;; Content-Location = ( absoluteURI | relativeURI )
+;; Content-Location = URI-reference
 ;;
-(declare-relative-uri-header! "Content-Location")
+(declare-uri-reference-header! "Content-Location")
 
 ;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
 ;;
@@ -1799,9 +1820,9 @@ treated specially, and is just returned as a plain string."
            (display (cdr pair) port)))
      ",")))
 
-;; Referer = ( absoluteURI | relativeURI )
+;; Referer = URI-reference
 ;;
-(declare-relative-uri-header! "Referer")
+(declare-uri-reference-header! "Referer")
 
 ;; TE = #( t-codings )
 ;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
@@ -1836,9 +1857,13 @@ treated specially, and is just returned as a plain string."
   entity-tag?
   write-entity-tag)
 
-;; Location = absoluteURI
+;; Location = URI-reference
+;;
+;; In RFC 2616, Location was specified as being an absolute URI.  This
+;; was changed in RFC 7231 to permit URI references generally, which
+;; matches web reality.
 ;; 
-(declare-uri-header! "Location")
+(declare-uri-reference-header! "Location")
 
 ;; Proxy-Authenticate = 1#challenge
 ;;