63 lines
2.1 KiB
Scheme
63 lines
2.1 KiB
Scheme
#lang scheme
|
|
(require net/cookie
|
|
web-server/http/request-structs
|
|
web-server/http/response-structs
|
|
xml
|
|
web-server/private/xexpr
|
|
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?) pretty-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)))))
|