Added a test suite for net/cookie.ss, and fixed some bugs revealed by that test suite
svn: r5010
This commit is contained in:
Jacob Matthews
parent
6e3d607465
commit
7c7ada4514
|
|
@ -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 = <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) "\"")
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user