From 0b816d2942e593c6e4bfc9c8c0acbadff6a3b8ae Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 3 Feb 2009 22:32:35 +0000 Subject: [PATCH] cookies svn: r13397 --- collects/net/cookie-sig.ss | 1 + collects/net/cookie-unit.ss | 33 ++--- collects/net/scribblings/cookie.scrbl | 10 +- .../tests/web-server/all-web-server-tests.ss | 2 + .../tests/web-server/http/all-http-tests.ss | 9 ++ .../tests/web-server/http/cookies-test.ss | 129 ++++++++++++++++++ .../htdocs/servlets/examples/cookie.ss | 24 ++++ .../htdocs/servlets/examples/cookie2.ss | 34 +++++ collects/web-server/http.ss | 4 + collects/web-server/http/cookie-parse.ss | 128 +++++++++++++++++ collects/web-server/http/cookie.ss | 61 +++++++++ collects/web-server/http/redirect.ss | 8 +- collects/web-server/scribblings/http.scrbl | 107 +++++++++++++++ 13 files changed, 527 insertions(+), 23 deletions(-) create mode 100644 collects/tests/web-server/http/all-http-tests.ss create mode 100644 collects/tests/web-server/http/cookies-test.ss create mode 100644 collects/web-server/default-web-root/htdocs/servlets/examples/cookie.ss create mode 100644 collects/web-server/default-web-root/htdocs/servlets/examples/cookie2.ss create mode 100644 collects/web-server/http/cookie-parse.ss create mode 100644 collects/web-server/http/cookie.ss diff --git a/collects/net/cookie-sig.ss b/collects/net/cookie-sig.ss index 409944a51e..390f5be3d6 100644 --- a/collects/net/cookie-sig.ss +++ b/collects/net/cookie-sig.ss @@ -1,6 +1,7 @@ #lang scheme/signature cookie? +valid-domain? set-cookie cookie:add-comment cookie:add-domain diff --git a/collects/net/cookie-unit.ss b/collects/net/cookie-unit.ss index 8eb31e9b41..b3d3b5c21a 100644 --- a/collects/net/cookie-unit.ss +++ b/collects/net/cookie-unit.ss @@ -177,12 +177,12 @@ (define (get-all-results name cookies) (let loop ([c cookies]) (if (null? c) - '() - (let ([pair (car c)]) - (if (string=? name (car pair)) - ;; found an instance of cookie named `name' - (cons (cadr pair) (loop (cdr c))) - (loop (cdr c))))))) + '() + (let ([pair (car c)]) + (if (string=? name (car pair)) + ;; found an instance of cookie named `name' + (cons (cadr pair) (loop (cdr c))) + (loop (cdr c))))))) ;; which typically looks like: ;; (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"") @@ -274,11 +274,11 @@ (cond [(not (string? s)) (error* "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)) @@ -298,9 +298,9 @@ (unless (string? s) (error* "string expected, received: ~a" s)) (if value? - (rfc2109:value? s) - ;; name: token - (rfc2068:token? s))) + (rfc2109:value? s) + ;; name: token + (rfc2068:token? s))) ;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-) (define char-set:hostname @@ -311,11 +311,12 @@ #\.))) (define (valid-domain? dom) - (and ;; 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) - (<= (string-length dom) 76))) + (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) + (<= (string-length dom) 76))) (define (valid-path? v) (and (string? v) (rfc2109:value? v))) diff --git a/collects/net/scribblings/cookie.scrbl b/collects/net/scribblings/cookie.scrbl index 0cab806c86..d1eaf923ca 100644 --- a/collects/net/scribblings/cookie.scrbl +++ b/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) ] diff --git a/collects/tests/web-server/all-web-server-tests.ss b/collects/tests/web-server/all-web-server-tests.ss index 346993f069..3856463b75 100644 --- a/collects/tests/web-server/all-web-server-tests.ss +++ b/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 diff --git a/collects/tests/web-server/http/all-http-tests.ss b/collects/tests/web-server/http/all-http-tests.ss new file mode 100644 index 0000000000..cb869b6fcd --- /dev/null +++ b/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)) diff --git a/collects/tests/web-server/http/cookies-test.ss b/collects/tests/web-server/http/cookies-test.ss new file mode 100644 index 0000000000..fa25ae829f --- /dev/null +++ b/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 #"")) + + (test-equal? "One (body)" + (response/full-body (xexpr-response/cookies (list (make-cookie "name" "value")) `(html))) + (list #"")) + + (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))) + + ))) diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/cookie.ss b/collects/web-server/default-web-root/htdocs/servlets/examples/cookie.ss new file mode 100644 index 0000000000..02ef5e077e --- /dev/null +++ b/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)))) + diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/cookie2.ss b/collects/web-server/default-web-root/htdocs/servlets/examples/cookie2.ss new file mode 100644 index 0000000000..74cc088fb3 --- /dev/null +++ b/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 "")) + (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)])) \ No newline at end of file diff --git a/collects/web-server/http.ss b/collects/web-server/http.ss index 634dc4230f..8f59eeda86 100644 --- a/collects/web-server/http.ss +++ b/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)) diff --git a/collects/web-server/http/cookie-parse.ss b/collects/web-server/http/cookie-parse.ss new file mode 100644 index 0000000000..8f79ceeeca --- /dev/null +++ b/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)))) diff --git a/collects/web-server/http/cookie.ss b/collects/web-server/http/cookie.ss new file mode 100644 index 0000000000..7e4aab5b58 --- /dev/null +++ b/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))))) \ No newline at end of file diff --git a/collects/web-server/http/redirect.ss b/collects/web-server/http/redirect.ss index 0d2a96795a..e6c1d98ba3 100644 --- a/collects/web-server/http/redirect.ss +++ b/collects/web-server/http/redirect.ss @@ -11,10 +11,10 @@ (define see-other (make-redirection-status 303 #"See Other")) ; : str [redirection-status] -> response -(define(redirect-to - uri - [perm/temp temporarily] - #:headers [headers (list)]) +(define (redirect-to + uri + [perm/temp temporarily] + #:headers [headers (list)]) (make-response/full (redirection-status-code perm/temp) (redirection-status-message perm/temp) (current-seconds) #"text/html" diff --git a/collects/web-server/scribblings/http.scrbl b/collects/web-server/scribblings/http.scrbl index 9ace7f9c2d..799cd59c9c 100644 --- a/collects/web-server/scribblings/http.scrbl +++ b/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))