diff --git a/collects/net/cookie-unit.ss b/collects/net/cookie-unit.ss index 6da069e0e8..98f5d8ac5b 100644 --- a/collects/net/cookie-unit.ss +++ b/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) - (unless (and (cookie-string? name #f) - (cookie-string? value)) - (raise (build-cookie-error (format "Invalid NAME/VALUE pair: ~a / ~a" name value)))) - (make-cookie name value - #f;; comment - #f;; current domain - #f;; at the end of session - #f;; current path - #f;; normal (non SSL) - #f;; default version - ))) + (lambda (name pre-value) + (let ([value (to-rfc2109:value pre-value)]) + (unless (rfc2068:token? name) + (raise (build-cookie-error (format "Invalid cookie name: ~a / ~a" name value)))) + (make-cookie name value + #f;; comment + #f;; current domain + #f;; at the end of session + #f;; current path + #f;; normal (non SSL) + #f;; default version + )))) ;;! ;; @@ -116,13 +116,12 @@ "; "))) (define cookie:add-comment - (lambda (cookie comment) - (unless (cookie-string? comment) - (raise (build-cookie-error (format "Invalid comment: ~a" comment)))) - (unless (cookie? cookie) - (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) - (set-cookie-comment! cookie comment) - cookie)) + (lambda (cookie pre-comment) + (let ([comment (to-rfc2109:value pre-comment)]) + (unless (cookie? cookie) + (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) + (set-cookie-comment! cookie comment) + cookie))) (define cookie:add-domain (lambda (cookie domain) @@ -143,13 +142,12 @@ cookie)) (define cookie:add-path - (lambda (cookie path) - (unless (string? path) - (raise (build-cookie-error (format "Invalid path: ~a" path)))) - (unless (cookie? cookie) - (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) - (set-cookie-path! cookie path) - cookie)) + (lambda (cookie pre-path) + (let ([path (to-rfc2109:value pre-path)]) + (unless (cookie? cookie) + (raise (build-cookie-error (format "Cookie expected, received: ~a" cookie)))) + (set-cookie-path! cookie path) + 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 "_")) - char-set:whitespace)) + (string->char-set "()<>@,;:\\\"/[]?={}") + 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 = > - (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) "\"") - (string=? (string-take-right s 1) "\"")))) - + (if (regexp-match #rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$" s) + 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 - (or (string-every char-set:token s) - (quoted-string? s)) + (rfc2109:value? 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 diff --git a/collects/tests/mzscheme/net.ss b/collects/tests/mzscheme/net.ss index 69a481b21d..5bcb7b5ec9 100644 --- a/collects/tests/mzscheme/net.ss +++ b/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