Added a test suite for net/cookie.ss, and fixed some bugs revealed by that test suite

svn: r5010

collects/net/cookie-unit.ss

@@ -63,7 +63,7 @@
       (import)
   
       (define-struct cookie (name value comment domain max-age path secure version))
-      (define-struct (cookie-error exn) ())
+      (define-struct (cookie-error exn:fail) ())
   
       ;; The syntax for the Set-Cookie response header is
       ;; set-cookie      =       "Set-Cookie:" cookies
@@ -78,18 +78,18 @@
       ;; 		      |       "Secure"
       ;; 		      |       "Version" "=" 1*DIGIT
       (define set-cookie
-        (lambda (name value)
+        (lambda (name pre-value)
-          (unless (and (cookie-string? name #f)
+          (let ([value (to-rfc2109:value pre-value)])
-                       (cookie-string? value))
+            (unless (rfc2068:token? name)
-            (raise (build-cookie-error (format "Invalid NAME/VALUE pair: ~a / ~a" name value))))
+              (raise (build-cookie-error (format "Invalid cookie name: ~a / ~a" name value))))
-          (make-cookie name value
+            (make-cookie name value
-                       #f;; comment
+                         #f;; comment
-                       #f;; current domain
+                         #f;; current domain
-                       #f;; at the end of session
+                         #f;; at the end of session
-                       #f;; current path
+                         #f;; current path
-                       #f;; normal (non SSL)
+                         #f;; normal (non SSL)
-                       #f;; default version
+                         #f;; default version
-                       )))
+                         ))))
 
       ;;!
       ;;
@@ -116,13 +116,12 @@
            "; ")))
 
       (define cookie:add-comment
-        (lambda (cookie comment)
+        (lambda (cookie pre-comment)
-          (unless (cookie-string? comment)
+          (let ([comment (to-rfc2109:value pre-comment)])
-            (raise (build-cookie-error (format "Invalid comment: ~a" comment))))
+            (unless (cookie? cookie)
-          (unless (cookie? cookie)
+              (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
-            (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
+            (set-cookie-comment! cookie comment)
-          (set-cookie-comment! cookie comment)
+            cookie)))
-          cookie))
 
       (define cookie:add-domain
         (lambda (cookie domain)
@@ -143,13 +142,12 @@
           cookie))
 
       (define cookie:add-path
-        (lambda (cookie path)
+        (lambda (cookie pre-path)
-          (unless (string? path)
+          (let ([path (to-rfc2109:value pre-path)])
-            (raise (build-cookie-error (format "Invalid path: ~a" path))))
+            (unless (cookie? cookie)
-          (unless (cookie? cookie)
+              (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
-            (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie))))
+            (set-cookie-path! cookie path)
-          (set-cookie-path! cookie path)
+            cookie)))
-          cookie))
    
       (define cookie:secure
         (lambda (cookie secure?)
@@ -236,26 +234,74 @@
       ;;	            | "{" | "}" | SP | HT
       (define char-set:tspecials
         (char-set-union
-         (char-set-difference char-set:punctuation (string->char-set "_"))
+         (string->char-set "()<>@,;:\\\"/[]?={}")
-         char-set:whitespace))
+         char-set:whitespace
+         (char-set #\tab)))
+      
       (define char-set:control (char-set-union char-set:iso-control
                                                (char-set (integer->char 127))));; DEL
       (define char-set:token (char-set-difference char-set:ascii char-set:tspecials char-set:control))
-
+      
+      ;; token? : string -> boolean
+      ;; 
+      ;; returns #t if s is an RFC 2068 token (see definition above), #f otherwise.
+      (define rfc2068:token?
+        (lambda (s) (string-every char-set:token s)))
+      
       ;;!
       ;;
       ;; (function (quoted-string? s))
       ;;
       ;; (param s String "The string to check")
       ;;
-      ;; Returns #t only if the string is surrounded by double quotes.  As in:
+      ;; Returns s if the string is an RFC 2068 quoted-string, #f otherwise. As in:
       ;; quoted-string  = ( <"> *(qdtext) <"> )
       ;; qdtext         = <any TEXT except <">>
-      (define quoted-string?
+      ;; 
+      ;; The backslash character ("\") may be used as a single-character quoting
+      ;; mechanism only within quoted-string and comment constructs.
+      ;;
+      ;; quoted-pair    = "\" CHAR
+      ;;
+      ;; implementation note: I have chosen to use a regular expression rather than
+      ;; a character set for this definition because of two dependencies: CRLF must appear
+      ;; as a block to be legal, and " may only appear as \"
+      (define rfc2068:quoted-string?
         (lambda (s)
-          (and (string=? (string-take s 1) "\"")
+          (if (regexp-match #rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$" s)
-               (string=? (string-take-right s 1) "\""))))
+              s
-
+              #f)))
+      
+      ;; value: token | quoted-string
+      (define (rfc2109:value? s)
+        (or (rfc2068:token? s) (rfc2068:quoted-string? s)))
+      
+      ;; convert-to-quoted : string -> quoted-string?
+      ;; takes the given string as a particular message, and converts the given string to that
+      ;; representatation
+      (define (convert-to-quoted str)
+        (string-append "\"" (regexp-replace* #rx"\"" str "\\\\\"") "\""))
+      
+      ;; string -> rfc2109:value? 
+      (define (to-rfc2109:value s)
+        (cond
+          [(not (string? s)) 
+           (raise (build-cookie-error (format "Expected string, given: ~e" s)))] 
+          
+          ; for backwards compatibility, just use the given string if it will work
+          [(rfc2068:token? s) s]
+          [(rfc2068:quoted-string? s) s]
+          
+          ; ... but if it doesn't work (i.e., it's just a normal message) then try to
+          ; convert it into a representation that will work
+          [(rfc2068:quoted-string? (convert-to-quoted s))
+           => (λ (x) x)]
+          [else
+           (raise 
+            (build-cookie-error 
+             (format "Could not convert the given string to an acceptable RFC 2109 value: ~s" s)))]))
+      
+      
       ;;!
       ;;
       ;; (function (cookie-string? s))
@@ -269,11 +315,9 @@
           (unless (string? s)
             (raise (build-cookie-error (format "String expected, received: ~a" s))))
           (if value?
-              ;; value: token | quoted-string
+              (rfc2109:value? s)
-              (or (string-every char-set:token s)
-                  (quoted-string? s))
               ;; name:  token
-              (string-every char-set:token s))))
+              (rfc2068:token? s))))
 
       ;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-)
       (define char-set:hostname
@@ -291,6 +335,10 @@
            ;; The rest are tokens-like strings separated by dots
            (string-every char-set:hostname dom)
            (<= (string-length dom) 76))))
+            
+      (define (valid-path? v)
+        (and (string? v)
+             (rfc2109:value? v)))
       
       ;; build-cookie-error : string -> cookie-error
       ;; constructs a cookie-error struct from the given error message

collects/tests/mzscheme/net.ss

@@ -491,6 +491,79 @@
 (test #"From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\nAthird: data\r\n\r\n"
       append-headers test-header/bytes #"Athird: data\r\n\r\n")
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; cookie tests --- JBM, 2006-12-01
+
+(require (lib "cookie.ss" "net"))
+
+;; cookie-test : (cookie -> cookie) string -> test
+(define (cookie-test fn  expected)
+  (test expected 
+        (λ (c) (print-cookie (fn c)))
+        (set-cookie "a" "b")))
+
+;; RC = "reverse curry"
+(define (RC f arg2) (λ (arg1) (f arg1 arg2)))
+;; o = compose
+(define-syntax o
+    (syntax-rules ()
+      [(o f) f]
+      [(o f g h ...)
+       (λ (x) (o/* x f g h ...))]))
+(define-syntax o/*
+  (syntax-rules ()
+    [(o/* x) x]
+    [(o/* x f g ...)
+     (f (o/* x g ...))]))
+
+;; test the most basic functionality
+(cookie-test (λ (x) x) "a=b; Version=1")
+
+;; test each modifier individually
+(cookie-test (RC cookie:add-comment "set+a+to+b") "a=b; Comment=set+a+to+b; Version=1")
+(cookie-test (RC cookie:add-comment "a comment with spaces") "a=b; Comment=\"a comment with spaces\"; Version=1")
+(cookie-test (RC cookie:add-comment "the \"risks\" involved in waking")
+             "a=b; Comment=\"the \\\"risks\\\" involved in waking\"; Version=1")
+(cookie-test (RC cookie:add-comment "\"already formatted\"")
+             "a=b; Comment=\"already formatted\"; Version=1")
+(cookie-test (RC cookie:add-comment "\"problematic \" internal quote\"")
+             "a=b; Comment=\"\\\"problematic \\\" internal quote\\\"\"; Version=1")
+(cookie-test (RC cookie:add-comment "contains;semicolon")
+             "a=b; Comment=\"contains;semicolon\"; Version=1")
+(cookie-test (RC cookie:add-domain ".example.net") "a=b; Domain=.example.net; Version=1")
+(cookie-test (RC cookie:add-max-age 100) "a=b; Max-Age=100; Version=1")
+(cookie-test (RC cookie:add-path "/whatever/wherever/") "a=b; Path=\"/whatever/wherever/\"; Version=1")
+(cookie-test (RC cookie:add-path "a+path") "a=b; Path=a+path; Version=1")
+(cookie-test (RC cookie:add-path "\"/already/quoted/\"") "a=b; Path=\"/already/quoted/\"; Version=1")
+(cookie-test (RC cookie:secure #t) "a=b; Secure; Version=1")
+(cookie-test (RC cookie:secure #f) "a=b; Version=1")
+(cookie-test (RC cookie:version 12) "a=b; Version=12")
+
+;; test combinations
+(cookie-test (o (RC cookie:add-comment "set+a+to+b")
+                (RC cookie:add-domain ".example.net"))
+             "a=b; Comment=set+a+to+b; Domain=.example.net; Version=1")
+(cookie-test (o (RC cookie:add-max-age 300)
+                (RC cookie:secure #t))
+             "a=b; Max-Age=300; Secure; Version=1")
+(cookie-test (o (RC cookie:add-path "/whatever/wherever/")
+                (RC cookie:version 10)
+                (RC cookie:add-max-age 20))
+             "a=b; Max-Age=20; Path=\"/whatever/wherever/\"; Version=10")
+
+;; test error cases
+(define-syntax cookie-error-test
+  (syntax-rules ()
+    [(cookie-error-test e)
+     (thunk-error-test (λ () (e (set-cookie "a" "b"))) #'e cookie-error?)]))
+
+(cookie-error-test (RC cookie:add-comment "illegal character #\000"))
+(cookie-error-test (RC cookie:add-max-age -10))
+(cookie-error-test (RC cookie:add-domain "doesntstartwithadot.example.com"))
+(cookie-error-test (RC cookie:add-domain "bad domain.com"))
+(cookie-error-test (RC cookie:add-domain ".bad-domain;com"))         
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;; other net tests