Changeset 11916 in project

Timestamp:

09/07/08 13:38:04 (12 years ago)

Author:

sjamaan

Message:

Add etag-unparser and split out token unparsing from string quoting

Location:

release/4/intarweb/trunk

Files:

• header-parsers.scm (modified) (2 diffs)
• intarweb.scm (modified) (2 diffs)
• tests/run.scm (modified) (1 diff)

release/4/intarweb/trunk/header-parsers.scm

@@ -323 +323 @@
           (loop (cdr params) (if str (cons str results) results))))))
 
+(define must-be-quoted-chars (char-set-adjoin char-set:iso-control #\"))
+
+(define quote-string
+  (let ((smap (map (lambda (c)
+                     (cons (string c)
+                           (string-append "\\" (string c))))
+                   (char-set->list must-be-quoted-chars))))
+    (lambda (string)
+      (let ((error-chars (char-set #\newline)))
+        (if (string-any error-chars string)
+            (signal-http-condition "Unencoded newline in header contents! Please encode the newline in a way appropriate for this header"
+                                   'unencoded-header 'value string)
+            (string-append "\"" (string-translate* string smap) "\""))))))
+
 (define unparse-token
-  (let* ((must-be-quoted-chars (char-set-adjoin char-set:iso-control #\"))
-         (trigger-quoting-chars (char-set-union
+  (let* ((trigger-quoting-chars (char-set-union
                                  (char-set-adjoin must-be-quoted-chars #\, #\; #\=)
-                                 char-set:blank))
-         (error-chars (char-set #\newline))
-         (smap (map (lambda (c)
-                      (cons (string c)
-                            (string-append "\\" (string c))))
-                    (char-set->list must-be-quoted-chars))))
+                                 char-set:blank)))
    (lambda (token)
-     (cond
-      ((string-any error-chars token)
-       (signal-http-condition "Unencoded newline in header contents! Please encode the newline in a way appropriate for this header"
-                              'unencoded-header 'value token))
-      ((string-any trigger-quoting-chars token)
-       (string-append "\"" (string-translate* token smap) "\""))
-      (else token)))))
+     (if (string-any trigger-quoting-chars token)
+         (quote-string token)
+         token))))
 
 ;; There's no need to make a specific header unparser for every header type.
@@ -369 +373 @@
                                  parameter-unparsers))
                 result))))))
+
+(define (etag-unparser header-name header-contents)
+  (let ((contents (get-value (car header-contents))))
+   (sprintf "~A: ~A\r\n"
+            (header-name->string header-name)
+            (string-append
+             (if (eq? 'weak (car contents)) "W/" "")
+             (if (string-prefix? "W/" (cdr contents))
+                 (quote-string (cdr contents))
+                 (unparse-token (cdr contents)))))))

release/4/intarweb/trunk/intarweb.scm

@@ -64 +64 @@
    get-quality get-value get-params get-param
    natnum-parser symbol-parser-ci symbol-parser
-   unparse-token default-header-unparser
+   quote-string unparse-token default-header-unparser etag-unparser
    )
 
@@ -351 +351 @@
 (define header-unparsers
   (make-parameter
-   `()))
+   `((etag . ,etag-unparser))))
 
 (define (unparse-headers headers out)

release/4/intarweb/trunk/tests/run.scm

@@ -326 +326 @@
                                               (mumble . mutter)
                                               (blah . #t)
-                                              (feh . #f)))))))))
+                                              (feh . #f))))))))
+  (test-group "Entity-tag unparser"
+    (test "Weak tag"
+          "Etag: W/blah\r\n"
+          (test-unparse-headers `((etag (weak . "blah")))))
+    (test "Strong tag"
+          "Etag: blah\r\n"
+          (test-unparse-headers `((etag (strong . "blah")))))
+    (test "Strong tag starting with W/"
+          "Etag: \"W/blah\"\r\n"
+          (test-unparse-headers `((etag (strong . "W/blah")))))))
 
 (define (test-read-request str)