cookies

svn: r13397

collects/net/cookie-sig.ss

@@ -1,6 +1,7 @@
 #lang scheme/signature
 
 cookie?
+valid-domain?
 set-cookie
 cookie:add-comment
 cookie:add-domain

collects/net/cookie-unit.ss

@@ -311,7 +311,8 @@
      #\.)))
 
 (define (valid-domain? dom)
-  (and ;; Domain must start with a dot (.)
+  (and (string? dom)
+       ;; Domain must start with a dot (.)
        (string=? (string-take dom 1) ".")
        ;; The rest are tokens-like strings separated by dots
        (string-every char-set:hostname dom)

collects/net/scribblings/cookie.scrbl

@@ -21,6 +21,10 @@ utilities for using cookies as specified in RFC 2109 @cite["RFC2109"].}
 Returns @scheme[#t] if @scheme[v] represents a cookie, @scheme[#f]
 otherwise.}
 
+@defproc[(valid-domain? [v any/c]) boolean?]{
+ Returns @scheme[#t] if @scheme[v] represents a valid domain, @scheme[#f] otherwise.
+}
+
 @defproc[(set-cookie [name string?] [value string?]) cookie?]{
 
 Creates a new cookie, with default values for required fields.}
@@ -31,7 +35,7 @@ Creates a new cookie, with default values for required fields.}
 Modifies @scheme[cookie] with a comment, and also returns
 @scheme[cookie].}
 
-@defproc[(cookie:add-domain [cookie cookie?] [domain string?])
+@defproc[(cookie:add-domain [cookie cookie?] [domain valid-domain?])
          cookie?]{
 
 Modifies @scheme[cookie] with a domain, and also returns
@@ -45,7 +49,7 @@ Modifies @scheme[cookie] with a maximum age, and also returns
 @scheme[cookie]. The @scheme[seconds] argument is number of seconds
 that a client should retain the cookie.}
 
-@defproc[(cookie:add-path [cookie cookie?] [path string?])
+@defproc[(cookie:add-path [cookie cookie?] [path valid-path?])
          cookie?]{
 
 Modifies @scheme[cookie] with a path, and also returns
@@ -121,7 +125,7 @@ and to use with the PLT Web Server, use:
 
 @schemeblock[
   (make-response/full code message (current-seconds) mime
-                      `((Set-Cookie . ,(print-cookie c)))
+                      (list (make-header #"Set-Cookie" (string->bytes/utf-8 (print-cookie c))))
                       body)
 ]
 

collects/tests/web-server/all-web-server-tests.ss

@@ -5,6 +5,7 @@
          "lang/all-lang-tests.ss"
          "lang-test.ss"
          "managers/all-managers-tests.ss"
+         "http/all-http-tests.ss"
          "private/all-private-tests.ss"
          "servlet/all-servlet-tests.ss"
          "servlet-env-test.ss")
@@ -13,6 +14,7 @@
 (define all-web-server-tests  
   (test-suite
    "Web Server"
+   all-http-tests
    all-configuration-tests
    all-dispatchers-tests
    all-lang-tests

collects/tests/web-server/http/all-http-tests.ss

@@ -0,0 +1,9 @@
+#lang scheme/base
+(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+         "cookies-test.ss")
+(provide all-http-tests)
+
+(define all-http-tests
+  (test-suite
+   "HTTP"
+   cookies-tests))

collects/tests/web-server/http/cookies-test.ss

@@ -0,0 +1,129 @@
+#lang scheme
+(require (planet "test.ss" ("schematics" "schemeunit.plt" 2))
+         net/url
+         web-server/http/request-structs
+         web-server/http/response-structs
+         web-server/http/cookie
+         web-server/http/cookie-parse)
+(provide cookies-tests)
+
+(define (header-equal? h1 h2)
+  (and (bytes=? (header-field h1)
+                (header-field h2))
+       (bytes=? (header-value h1)
+                (header-value h2))))
+
+(define (set-header->read-header h)
+  (make-header #"Cookie" (header-value h)))
+
+(define cookies-tests
+  (test-suite
+   "Cookies"
+   
+   (test-suite
+    "cookie.ss"
+    
+    (test-suite
+     "cookie->header and make-cookie"
+     (test-check "Simple" header-equal?
+                 (cookie->header (make-cookie "name" "value"))
+                 (make-header #"Set-Cookie" #"name=value; Version=1"))
+     
+     (test-equal? "Comment"
+                  (header-value (cookie->header (make-cookie "name" "value" #:comment "comment")))
+                  #"name=value; Comment=comment; Version=1")
+     
+     (test-equal? "Domain"
+                  (header-value (cookie->header (make-cookie "name" "value" #:domain ".domain")))
+                  #"name=value; Domain=.domain; Version=1")
+     
+     (test-equal? "max-age"
+                  (header-value (cookie->header (make-cookie "name" "value" #:max-age 24)))
+                  #"name=value; Max-Age=24; Version=1")
+     
+     (test-equal? "path"
+                  (header-value (cookie->header (make-cookie "name" "value" #:path "path")))
+                  #"name=value; Path=path; Version=1")
+     
+     (test-equal? "secure? #t"
+                  (header-value (cookie->header (make-cookie "name" "value" #:secure? #t)))
+                  #"name=value; Secure; Version=1")
+     
+     (test-equal? "secure? #f"
+                  (header-value (cookie->header (make-cookie "name" "value" #:secure? #f)))
+                  #"name=value; Version=1"))
+    
+    (test-suite
+     "xexpr-response/cookies"
+     (test-equal? "Simple"
+                  (response/full-body (xexpr-response/cookies empty `(html)))
+                  (list #"<html></html>"))
+     
+     (test-equal? "One (body)"
+                  (response/full-body (xexpr-response/cookies (list (make-cookie "name" "value")) `(html)))
+                  (list #"<html></html>"))
+     
+     (test-equal? "One (headers)"
+                  (map (lambda (h) (cons (header-field h) (header-value h)))
+                       (response/basic-headers (xexpr-response/cookies (list (make-cookie "name" "value")) `(html))))
+                  (list (cons #"Set-Cookie" #"name=value; Version=1")))))
+   
+   (test-suite
+    "cookie-parse.ss"
+    
+    (test-equal? "None"
+                 (request-cookies 
+                  (make-request 
+                   #"GET" (string->url "http://test.com/foo")
+                   empty empty #f
+                   "host" 80 "client"))
+                 empty)
+    
+    (test-equal? "Simple"
+                 (request-cookies 
+                  (make-request 
+                   #"GET" (string->url "http://test.com/foo")
+                   (list (make-header #"Cookie" #"$Version=\"1\"; name=\"value\""))
+                   empty #f
+                   "host" 80 "client"))
+                 (list (make-client-cookie "name" "value" #f #f)))
+    
+    (test-equal? "Path"
+                 (request-cookies 
+                  (make-request 
+                   #"GET" (string->url "http://test.com/foo")
+                   (list (make-header #"Cookie" #"$Version=\"1\"; name=\"value\"; $Path=\"/acme\""))
+                   empty #f
+                   "host" 80 "client"))
+                 (list (make-client-cookie "name" "value" #f "/acme")))
+    
+    (test-equal? "Domain"
+                 (request-cookies 
+                  (make-request 
+                   #"GET" (string->url "http://test.com/foo")
+                   (list (make-header #"Cookie" #"$Version=\"1\"; name=\"value\"; $Domain=\".acme\""))
+                   empty #f
+                   "host" 80 "client"))
+                 (list (make-client-cookie "name" "value" ".acme" #f)))
+    
+    (test-equal? "Multiple"
+                 (request-cookies 
+                  (make-request 
+                   #"GET" (string->url "http://test.com/foo")
+                   (list (make-header #"Cookie" #"$Version=\"1\"; key1=\"value1\"; key2=\"value2\""))
+                   empty #f
+                   "host" 80 "client"))
+                 (list (make-client-cookie "key1" "value1" #f #f)
+                       (make-client-cookie "key2" "value2" #f #f)))
+    
+    (test-equal? "Multiple w/ paths & domains"
+                 (request-cookies 
+                  (make-request 
+                   #"GET" (string->url "http://test.com/foo")
+                   (list (make-header #"Cookie" #"$Version=\"1\"; key1=\"value1\"; $Path=\"/acme\"; key2=\"value2\"; $Domain=\".acme\""))
+                   empty #f
+                   "host" 80 "client"))
+                 (list (make-client-cookie "key1" "value1" #f "/acme")
+                       (make-client-cookie "key2" "value2" ".acme" #f)))
+    
+    )))

collects/web-server/default-web-root/htdocs/servlets/examples/cookie.ss

@@ -0,0 +1,24 @@
+#lang web-server/insta
+(require net/url)
+
+(define (start req)
+  (define cookies (request-cookies req))
+  (define id-cookie
+    (findf (lambda (c)
+             (string=? "id" (client-cookie-name c)))
+           cookies))
+  (if id-cookie
+      (hello (client-cookie-value id-cookie))
+      (redirect-to
+       (url->string (request-uri req))
+       see-other
+       #:headers
+       (list
+        (cookie->header (make-cookie "id" "joseph"))))))
+
+(define (hello who)
+  `(html (head (title "Hello!"))
+         (body
+          (h1 "Hello "
+              ,who))))
+

collects/web-server/default-web-root/htdocs/servlets/examples/cookie2.ss

@@ -0,0 +1,34 @@
+#lang web-server/insta
+(require net/url)
+
+(define (start req)
+  (define cookies (request-cookies req))
+  (define id-cookie
+    (findf (lambda (c)
+             (string=? "id" (client-cookie-name c)))
+           cookies))
+  (define who
+    (if id-cookie
+        (client-cookie-value id-cookie)
+        #f))
+  (define new-req
+    (send/suspend
+     (lambda (k-url)
+       `(html (head (title "Hello!"))
+              (body (h1 "Hello " ,(if who who "<unknown>"))
+                    (form ([action ,k-url])
+                          (input ([name "who"]))))))))
+  (define binds
+    (request-bindings/raw new-req))
+  (match (bindings-assq #"who" binds)
+    [(? binding:form? b)
+     (define new-who (bytes->string/utf-8 (binding:form-value b)))
+     (redirect-to (url->string (request-uri req))
+      see-other
+      #:headers
+      (list
+       (cookie->header (make-cookie "id" new-who))))]
+    [else
+     (redirect-to
+      (url->string (request-uri req))
+      see-other)]))

collects/web-server/http.ss

@@ -2,8 +2,12 @@
 (require web-server/http/basic-auth
          web-server/http/request-structs
          web-server/http/response-structs
+         web-server/http/cookie
+         web-server/http/cookie-parse
          web-server/http/redirect)
 (provide (all-from-out web-server/http/basic-auth
                        web-server/http/request-structs
                        web-server/http/response-structs
+                       web-server/http/cookie
+                       web-server/http/cookie-parse
                        web-server/http/redirect))

collects/web-server/http/cookie-parse.ss

@@ -0,0 +1,128 @@
+#lang scheme
+(require web-server/http/request-structs
+         net/cookie
+         web-server/private/util         
+         scheme/contract)
+
+(define-struct client-cookie 
+  (name value domain path)
+  #:transparent)
+
+(provide/contract
+ [struct client-cookie 
+         ([name string?]
+          [value string?]
+          [domain (or/c false/c valid-domain?)]
+          [path (or/c false/c string?)])]
+ [request-cookies (request? . -> . (listof client-cookie?))])
+
+;; ============================================================
+;; utilities for retrieving cookies
+
+(require parser-tools/lex
+         parser-tools/yacc
+         (prefix-in : parser-tools/lex-sre))
+
+#|
+   cookie          =       "Cookie:" cookie-version
+                           1*((";" | ",") cookie-value)
+   cookie-value    =       NAME "=" VALUE [";" path] [";" domain]
+   cookie-version  =       "$Version" "=" value
+   NAME            =       attr
+   VALUE           =       value
+   path            =       "$Path" "=" value
+   domain          =       "$Domain" "=" value
+|#
+(define-lex-abbrevs
+  (tspecial (:or (char-set "()<>@,;:\\\"/[]?={}") whitespace #\tab))
+  (token-char (:- any-char tspecial iso-control)))
+
+(define-tokens regular (TOKEN QUOTED-STRING))
+(define-empty-tokens keywords (EQUALS SEMI COMMA PATH DOMAIN VERSION EOF))
+
+(define cookie-lexer
+  (lexer
+   [(eof) (token-EOF)]
+   [whitespace (cookie-lexer input-port)]
+   ["=" (token-EQUALS)]
+   [";" (token-SEMI)]
+   ["," (token-COMMA)]
+   ["$Path" (token-PATH)]
+   ["$Domain" (token-DOMAIN)]
+   ["$Version" (token-VERSION)]
+   [(:: #\" (:* (:or (:~ #\") "\\\"")) #\")
+    (token-QUOTED-STRING (substring lexeme 1 (- (string-length lexeme) 1)))]
+   [(:+ token-char) (token-TOKEN lexeme)]))
+
+(define assoc-list-parser
+  (parser (start cookie)
+          (tokens regular keywords)
+          (grammar (cookie [(VERSION EQUALS rhs separator items) $5]
+                           [(items) $1])
+                   (items [(item separator items) (cons $1 $3)]
+                          [(item) (list $1)])
+                   (separator
+                    [(COMMA) #t]
+                    [(SEMI) #t])
+                   (item [(lhs EQUALS rhs) (cons $1 $3)])
+                   (lhs [(DOMAIN) 'domain]
+                        [(PATH) 'path]
+                        [(TOKEN) $1])
+                   (rhs [(TOKEN) $1]
+                        [(QUOTED-STRING) $1]))
+          (end EOF)
+          (error (lambda (a b c) (error 'assoc-list-parser "Malformed cookie: ~v ~v ~v" a b c)))))
+
+(define (do-parse str)
+  (with-handlers ([exn:fail? 
+                   (λ (e) empty)])
+    (let ([ip (open-input-string str)])
+      (dynamic-wind
+       void
+       (λ () (raw->cookies (assoc-list-parser (λ () (cookie-lexer ip)))))
+       (λ () (close-input-port ip))))))
+
+;; raw->cookies : flat-property-list -> (listof cookie)
+(define (raw->cookies associations)
+  
+  ;; get-cookie-setter : symbol -> cookie string -> cookie
+  ;; gets a setter for the given property
+  (define (get-cookie-setter property-name)
+    (case property-name
+      [(domain)
+       (λ (c x) 
+         (struct-copy client-cookie c
+                      [domain x]))]      
+      [(path)
+       (λ (c x) 
+         (struct-copy client-cookie c
+                      [path x]))]
+      [else 
+       (λ (c x) c)]))
+  
+  (unless (and (pair? associations) (string? (car (car associations))))
+    (error 'raw->cookies "expected a non-empty association list headed by a cookie"))
+  
+  (let loop ([l (cdr associations)]
+             [c (make-client-cookie (car (car associations))
+                                    (cdr (car associations))
+                                    #f #f)])
+    (cond
+      [(null? l) (list c)]
+      [(string? (car (car l)))
+       (cons c (loop (cdr l) (make-client-cookie
+                              (car (car l))
+                              (cdr (car l))
+                              #f #f)))]
+      [else
+       (loop (cdr l)
+             ((get-cookie-setter (car (car l))) c (cdr (car l))))])))
+
+;; request-cookies* : request -> (listof cookie)
+(define (request-cookies req)
+  (define hdrs (request-headers/raw req))
+  (apply append
+         (map (compose do-parse bytes->string/utf-8 header-value)
+              (filter (lambda (h)
+                        (bytes-ci=? #"Cookie" (header-field h)))
+                      hdrs))))

collects/web-server/http/cookie.ss

@@ -0,0 +1,61 @@
+#lang scheme
+(require net/cookie
+         web-server/http/request-structs
+         web-server/http/response-structs
+         xml
+         scheme/contract)
+
+(provide/contract 
+ [make-cookie ((string? string?) (#:comment (or/c false/c string?)
+                                            #:domain (or/c false/c valid-domain?)
+                                            #:max-age (or/c false/c exact-nonnegative-integer?)
+                                            #:path (or/c false/c string?)
+                                            #:secure? (or/c false/c boolean?))
+                                 . ->* . cookie?)]
+ [cookie->header (cookie? . -> . header?)]
+ [xexpr-response/cookies ((listof cookie?) xexpr/c . -> . response/full?)])
+
+(define (set-when-true fn val)
+  (if val
+      (λ (c) (fn c val))
+      (λ (c) c)))
+
+(define-syntax o
+  (syntax-rules ()
+    [(o f) f]
+    [(o f f2 ...) (lambda (x) (o* x f f2 ...))]))
+
+(define-syntax o*
+  (syntax-rules ()
+    [(o* x) x]
+    [(o* x f g ...) (f (o* x g ...))]))
+
+(define (make-cookie name val
+                     #:comment [comment #f]
+                     #:domain  [domain #f]
+                     #:max-age [max-age #f]
+                     #:path    [path #f]
+                     #:secure? [secure? #f])
+  ((o (set-when-true cookie:add-comment comment)
+      (set-when-true cookie:add-domain domain)
+      (set-when-true cookie:add-max-age max-age)
+      (set-when-true cookie:add-path path)
+      (set-when-true cookie:secure secure?))
+   (set-cookie name val)))
+
+;; cookie->header : cookie -> header
+;; gets the header that will set the given cookie
+(define (cookie->header cookie)
+  (make-header #"Set-Cookie" (string->bytes/utf-8 (print-cookie cookie))))
+
+;; build-cookie-response : xexpr[xhtml] (listof cookie) -> response
+(define (xexpr-response/cookies cookies xexpr)
+  (make-response/full 
+   200
+   #"Okay"
+   (current-seconds)
+   TEXT/HTML-MIME-TYPE
+   (map cookie->header cookies) ; rfc2109 also recommends some cache-control stuff here
+   (list 
+    (string->bytes/utf-8 
+     (xexpr->string xexpr)))))

collects/web-server/http/redirect.ss

@@ -11,7 +11,7 @@
 (define see-other (make-redirection-status 303 #"See Other"))
 
 ; : str [redirection-status] -> response
-(define(redirect-to 
+(define (redirect-to 
          uri
          [perm/temp temporarily]
          #:headers [headers (list)])

collects/web-server/scribblings/http.scrbl

@@ -236,6 +236,113 @@ transmission that the server @bold{will not catch}.}
 
 }
 
+@; ------------------------------------------------------------
+@section[#:tag "cookie"]{Placing Cookies}
+
+@(require (for-label net/cookie
+                     web-server/servlet
+                     web-server/http/redirect
+                     web-server/http/request-structs
+                     web-server/http/response-structs
+                     web-server/http/cookie))
+
+@defmodule[web-server/http/cookie]{
+ This module provides functions to create cookies and responses that set them.
+      
+ @defproc[(make-cookie [name string?] [value string?]
+                       [#:comment comment (or/c false/c string?) #f]
+                       [#:domain domain (or/c false/c valid-domain?) #f]
+                       [#:max-age max-age (or/c false/c exact-nonnegative-integer?) #f]
+                       [#:path path (or/c false/c string?) #f]
+                       [#:secure? secure? (or/c false/c boolean?) #f])
+          cookie?]{
+  Constructs a cookie with the appropriate fields.
+ }
+ 
+ @defproc[(cookie->header [c cookie?]) header?]{
+  Constructs a header that sets the cookie.
+ }             
+                  
+ @defproc[(xexpr-response/cookies [cookies (listof cookie?)]
+                                  [xexpr xexpr/c])
+          response/full?]{
+  Constructs a response using @scheme[xexpr] that sets all the cookies in @scheme[cookies].
+ }
+                         
+ Examples:
+ @schemeblock[
+  (define time-cookie 
+    (make-cookie "time" (number->string (current-seconds))))
+  (define id-cookie
+    (make-cookie "id" "joseph" #:secure? #t))
+  
+  (redirect-to 
+   "http://localhost/logged-in"
+   see-other
+   #:headers 
+   (map cookie->header
+        (list time-cookie id-cookie)))
+  
+  (send/suspend
+    (lambda (k-url)
+      (xexpr-response/cookies
+       (list time-cookie id-cookie)
+       `(html (head (title "Cookie Example"))
+              (body (h1 "You're cookie'd!"))))))
+ ]
+ 
+ @warning{When using cookies, make sure you follow the advice of the @link["http://cookies.lcs.mit.edu/"]{MIT Cookie Eaters},
+          or you will be susceptible to dangerous attacks.} 
+}                                  
+
+@; ------------------------------------------------------------
+@section[#:tag "cookie-parse"]{Extracting Cookies}
+
+@(require (for-label web-server/http/cookie-parse
+                     net/cookie
+                     net/url
+                     scheme/list))
+@defmodule[web-server/http/cookie-parse]{
+ @defstruct[client-cookie 
+            ([name string?]
+             [value string?]
+             [domain (or/c false/c valid-domain?)]
+             [path (or/c false/c string?)])]{
+                              
+  While server cookies are represented with @scheme[cookie?]s, cookies that come from the client are represented
+  with a @scheme[client-cookie] structure.                              
+ }
+ 
+ @defproc[(request-cookies [req request?])
+          (listof client-cookie?)]{
+  Extracts the cookies from @scheme[req]'s headers.
+ }
+
+ Examples:
+ @schemeblock[
+  (define (start req)
+    (define cookies (request-cookies req))
+    (define id-cookie 
+      (findf (lambda (c)
+               (string=? "id" (client-cookie-name c)))
+             cookies))
+    (if id-cookie
+        (hello (client-cookie-value id-cookie))
+        (redirect-to 
+         (url->string (request-uri req))
+         see-other
+         #:headers 
+         (list
+          (cookie->header (make-cookie "id" "joseph"))))))
+        
+   (define (hello who)
+     `(html (head (title "Hello!"))
+            (body 
+             (h1 "Hello " 
+                 ,who))))
+ ]
+}
+
 @; ------------------------------------------------------------
 @section[#:tag "redirect.ss"]{Redirect}
 @(require (for-label web-server/http/redirect))