129 lines
4.3 KiB
Scheme
129 lines
4.3 KiB
Scheme
#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))))
|