suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

De-unitizing cookies and making the serializable

Browse Source 
original commit: b207f1051ac8845c75f2d2296dadbd0e88cbe397
This commit is contained in:
Jay McCarthy 2011-08-15 09:05:58 -06:00
parent 4692fba599
commit eefd959974
1 changed files with 6 additions and 324 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

330
collects/net/cookie-unit.rkt
View File

@ -1,326 +1,8 @@
;;;
;;; <cookie-unit.rkt> ---- HTTP cookies library
;;; Time-stamp: <03/04/25 10:50:05 noel>
;;;
;;; Copyright (C) 2002 by Francisco Solsona.
;;;
;;; This file is part of net.
#lang racket/base
(require racket/unit
"cookie-sig.rkt"
"cookie.rkt")
;;; net is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.
(define-unit-from-context cookie@ cookie^)
;;; net is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; Lesser General Public License for more details.
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with net; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;;; 02110-1301 USA.
;;; Author: Francisco Solsona <solsona@acm.org>
;;
;;
;; Commentary:
;;
;; The PLT Web server offers functionality to keep state beyond the
;; capacity of HTTP cookies. Believe or not, sometimes you may want
;; to keep stuff on the client end, like the theme the (anonymous)
;; user likes, a session id, etc., so I wrote this wanna be library.
;;
;; It uses some of the surfies you see on the require section below.
;; It doesn't actually "send" the Set-Cookie header to the browser, it
;; doesn't even add the string "Set-Cookie: " to the will-be cookie it
;; generates. Why? well because you may want to use this code with
;; very different Web browsers, and the way to send them may vary
;; drastically. For instance, if you are writing a CGI to be executed
;; from a non-cooperative (from the PLT Scheme point of view) web
;; server, like Apache, then you will `display' de cookie right to the
;; standard output. If you use FastCGI, you will `display' it trhough
;; the `output' communication stream between your CGI, and the Web
;; browser, but if you are using PLT Scheme Web browser, you will use
;; `make-response/full', or similar, chances are you will add cookies
;; to the `extras' parameter (extra headers), as cons pairs... as in
;; `(("Set-Cookie" . "cookie=\"as_returned_by_this_library";etc"))'.
;;
;; You should think of this procedures as a `format' for cookies.
#lang racket/unit
(require srfi/13/string srfi/14/char-set "cookie-sig.rkt")
(import)
(export cookie^)
(define-struct cookie
(name value comment domain max-age path secure version) #:mutable)
(define-struct (cookie-error exn:fail) ())
;; error* : string args ... -> raises a cookie-error exception
;; constructs a cookie-error struct from the given error message
;; (added to fix exceptions-must-take-immutable-strings bug)
(define (error* fmt . args)
(raise (make-cookie-error (apply format fmt args)
(current-continuation-marks))))
;; The syntax for the Set-Cookie response header is
;; set-cookie = "Set-Cookie:" cookies
;; cookies = 1#cookie
;; cookie = NAME "=" VALUE *(";" cookie-av)
;; NAME = attr
;; VALUE = value
;; cookie-av = "Comment" "=" value
;; | "Domain" "=" value
;; | "Max-Age" "=" value
;; | "Path" "=" value
;; | "Secure"
;; | "Version" "=" 1*DIGIT
(define (set-cookie name pre-value)
(let ([value (to-rfc2109:value pre-value)])
(unless (rfc2068:token? name)
(error* "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
)))
;;!
;;
;; (function (print-cookie cookie))
;;
;; (param cookie Cookie-structure "The cookie to return as a string")
;;
;; Formats the cookie contents in a string ready to be appended to a
;; "Set-Cookie: " header, and sent to a client (browser).
(define (print-cookie cookie)
(define (format-if fmt val) (and val (format fmt val)))
(unless (cookie? cookie) (error* "cookie expected, received: ~a" cookie))
(string-join
(filter values
(list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
(format-if "Comment=~a" (cookie-comment cookie))
(format-if "Domain=~a" (cookie-domain cookie))
(format-if "Max-Age=~a" (cookie-max-age cookie))
(format-if "Path=~a" (cookie-path cookie))
(and (cookie-secure cookie) "Secure")
(format "Version=~a" (or (cookie-version cookie) 1))))
"; "))
(define (cookie:add-comment cookie pre-comment)
(let ([comment (to-rfc2109:value pre-comment)])
(unless (cookie? cookie)
(error* "cookie expected, received: ~a" cookie))
(set-cookie-comment! cookie comment)
cookie))
(define (cookie:add-domain cookie domain)
(unless (valid-domain? domain)
(error* "invalid domain: ~a" domain))
(unless (cookie? cookie)
(error* "cookie expected, received: ~a" cookie))
(set-cookie-domain! cookie domain)
cookie)
(define (cookie:add-max-age cookie seconds)
(unless (and (integer? seconds) (not (negative? seconds)))
(error* "invalid Max-Age for cookie: ~a" seconds))
(unless (cookie? cookie)
(error* "cookie expected, received: ~a" cookie))
(set-cookie-max-age! cookie seconds)
cookie)
(define (cookie:add-path cookie pre-path)
(let ([path (to-rfc2109:value pre-path)])
(unless (cookie? cookie)
(error* "cookie expected, received: ~a" cookie))
(set-cookie-path! cookie path)
cookie))
(define (cookie:secure cookie secure?)
(unless (boolean? secure?)
(error* "invalid argument (boolean expected), received: ~a" secure?))
(unless (cookie? cookie)
(error* "cookie expected, received: ~a" cookie))
(set-cookie-secure! cookie secure?)
cookie)
(define (cookie:version cookie version)
(unless (integer? version)
(error* "unsupported version: ~a" version))
(unless (cookie? cookie)
(error* "cookie expected, received: ~a" cookie))
(set-cookie-version! cookie version)
cookie)
;; Parsing the Cookie header:
(define char-set:all-but=
(char-set-difference char-set:full (string->char-set "=")))
(define char-set:all-but-semicolon
(char-set-difference char-set:full (string->char-set ";")))
;;!
;;
;; (function (get-all-results name cookies))
;;
;; Auxiliar procedure that returns all values associated with
;; `name' in the association list (cookies).
(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)))))))
;; which typically looks like:
;; (cookie . "test5=\"5\"; test1=\"1\"; test0=\"0\"; test1=\"20\"")
;; note that it can be multi-valued: `test1' has values: "1", and "20". Of
;; course, in the same spirit, we only receive the "string content".
(define (get-cookie name cookies)
(let ([cookies (map (lambda (p)
(map string-trim-both
(string-tokenize p char-set:all-but=)))
(string-tokenize cookies char-set:all-but-semicolon))])
(get-all-results name cookies)))
;;!
;;
;; (function (get-cookie/single name cookies))
;;
;; (param name String "The name of the cookie we are looking for")
;; (param cookies String "The string (from the environment) with the content of the cookie header.")
;;
;; Returns the first name associated with the cookie named `name', if any, or #f.
(define (get-cookie/single name cookies)
(let ([cookies (get-cookie name cookies)])
(and (not (null? cookies)) (car cookies))))
;;;;;
;; Auxiliary procedures
;;;;;
;; token = 1*<any CHAR except CTLs or tspecials>
;;
;; tspecials = "(" | ")" | "<" | ">" | "@"
;; | "," | ";" | ":" | "\" | <">
;; | "/" | "[" | "]" | "?" | "="
;; | "{" | "}" | SP | HT
(define char-set:tspecials
(char-set-union (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? s)
(string-every char-set:token s))
;;!
;;
;; (function (quoted-string? s))
;;
;; (param s String "The string to check")
;;
;; Returns s if the string is an RFC 2068 quoted-string, #f otherwise. As in:
;; quoted-string = ( <"> *(qdtext) <"> )
;; qdtext = <any TEXT except <">>
;;
;; 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? s)
(and (regexp-match?
#rx"^\"([^\"\u0000-\u001F]| |\r\n|\t|\\\\\")*\"$"
s)
s))
;; value: token | quoted-string
(define (rfc2109:value? s)
(or (rfc2068:token? s) (rfc2068:quoted-string? s)
(rfc2068:quoted-string? (convert-to-quoted 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))
(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))
=> (λ (x) x)]
[else
(error* "could not convert the given string to an acceptable RFC 2109 value: ~s" s)]))
;;!
;;
;; (function (cookie-string? s))
;;
;; (param s String "String to check")
;;
;; Returns whether this is a valid string to use as the value or the
;; name (depending on value?) of an HTTP cookie.
(define (cookie-value? s)
(and (string? s)
(rfc2109:value? s)))
(define (cookie-name? s)
(and (string? s)
;; name: token
(rfc2068:token? s)))
;; Host names as per RFC 1123 and RFC952, more or less, anyway. :-)
(define char-set:hostname
(let ([a-z-lowercase (ucs-range->char-set #x61 #x7B)]
[a-z-uppercase (ucs-range->char-set #x41 #x5B)])
(char-set-adjoin!
(char-set-union char-set:digit a-z-lowercase a-z-uppercase)
#\.)))
(define (valid-domain? dom)
(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)))
;;; cookie-unit.rkt ends here
(provide cookie@)