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

Add cookie and uri-code code from Schematics and update docuementation accordingly

Browse Source 
original commit: 254623134bcb533f0b4c8fedada4dccc219f4248
This commit is contained in:
Noel Welsh 2003-04-25 15:04:32 +00:00
parent 6b1c2172e8
commit 7e69d4a0db
4 changed files with 587 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/net/cookie-sig.ss Normal file
View File

@ -0,0 +1,19 @@
(module cookie-sig mzscheme
(require (lib "unitsig.ss"))
(provide net:cookie^)
(define-signature net:cookie^
(set-cookie
cookie:add-comment
cookie:add-domain
cookie:add-max-age
cookie:add-path
cookie:secure
cookie:version
;; To actually return a cookie (string formated as a cookie):
print-cookie
;; To parse the Cookies header:
get-cookie
get-cookie/single
;; exceptions
(struct cookie-error ()))))

297
collects/net/cookie-unit.ss Normal file
View File

@ -0,0 +1,297 @@
;;;
;;; <cookie-unit.ss> ---- HTTP cookies library
;;; Time-stamp: <03/04/25 10:50:05 noel>
;;;
;;; Copyright (C) 2002 by Francisco Solsona.
;;;
;;; This file is part of net.
;;; 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.
;;; 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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.
(module cookie-unit mzscheme
(require (lib "unitsig.ss")
(lib "etc.ss")
(lib "list.ss")
(lib "string.ss" "srfi" "13")
(lib "char-set.ss" "srfi" "14")
"cookie-sig.ss")
(provide cookie@)
(define cookie@
(unit/sig net:cookie^
(import)
(define-struct cookie (name value comment domain max-age path secure version))
(define-struct (cookie-error exn) ())
;; 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
(lambda (name value)
(unless (and (cookie-string? name #f)
(cookie-string? value))
(raise (make-cookie-error (format "Invalid NAME/VALUE pair: ~a / ~a" name value) (current-continuation-marks))))
(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
(lambda (cookie)
(unless (cookie? cookie)
(raise (make-cookie-error (format "Cookie expected, received: ~a" cookie) (current-continuation-marks))))
(string-join
(filter (lambda (s)
(not (string-null? s)))
(list (format "~a=~a" (cookie-name cookie) (cookie-value cookie))
(let ((c (cookie-comment cookie))) (if c (format "Comment=~a" c) ""))
(let ((d (cookie-domain cookie))) (if d (format "Domain=~a" d) ""))
(let ((age (cookie-max-age cookie))) (if age (format "Max-Age=~a" age) ""))
(let ((p (cookie-path cookie))) (if p (format "Path=~a" p) ""))
(let ((s (cookie-secure cookie))) (if s "Secure" ""))
(let ((v (cookie-version cookie))) (format "Version=~a" (if v v 1)))))
"; ")))
(define cookie:add-comment
(lambda (cookie comment)
(unless (cookie-string? comment)
(raise (make-cookie-error (format "Invalid comment: ~a" comment) (current-continuation-marks))))
(unless (cookie? cookie)
(raise (make-cookie-error (format "Cookie expected, received: ~a" cookie) (current-continuation-marks))))
(set-cookie-comment! cookie comment)
cookie))
(define cookie:add-domain
(lambda (cookie domain)
(unless (valid-domain? domain)
(raise (make-cookie-error (format "Invalid domain: ~a" domain) (current-continuation-marks))))
(unless (cookie? cookie)
(raise (make-cookie-error (format "Cookie expected, received: ~a" cookie) (current-continuation-marks))))
(set-cookie-domain! cookie domain)
cookie))
(define cookie:add-max-age
(lambda (cookie seconds)
(unless (and (integer? seconds) (not (negative? seconds)))
(raise (make-cookie-error (format "Invalid Max-Age for cookie: ~a" seconds) (current-continuation-marks))))
(unless (cookie? cookie)
(raise (make-cookie-error (format "Cookie expected, received: ~a" cookie) (current-continuation-marks))))
(set-cookie-max-age! cookie seconds)
cookie))
(define cookie:add-path
(lambda (cookie path)
(unless (string? path)
(raise (make-cookie-error (format "Invalid path: ~a" path) (current-continuation-marks))))
(unless (cookie? cookie)
(raise (make-cookie-error (format "Cookie expected, received: ~a" cookie) (current-continuation-marks))))
(set-cookie-path! cookie path)
cookie))
(define cookie:secure
(lambda (cookie secure?)
(unless (boolean? secure?)
(raise (make-cookie-error (format "Invalid argument (boolean expected), received: ~a" secure?) (current-continuation-marks))))
(unless (cookie? cookie)
(raise (make-cookie-error (format "Cookie expected, received: ~a" cookie) (current-continuation-marks))))
(set-cookie-secure! cookie secure?)
cookie))
(define cookie:version
(lambda (cookie version)
(unless (integer? version)
(raise (make-cookie-error (format "Unsupported version: ~a" version) (current-continuation-marks))))
(unless (cookie? cookie)
(raise (make-cookie-error (format "Cookie expected, received: ~a" cookie) (current-continuation-marks))))
(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
(lambda (name cookies)
(let loop ((c cookies))
(cond ((null? c) ())
(else
(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 tipically 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
(lambda (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
(lambda (name cookies)
(let ((cookies (get-cookie name cookies)))
(and (not (null? cookies))
(car cookies)))))
;;;;;
;; Auxiliar procedures
;;;;;
;; token = 1*<any CHAR except CTLs or tspecials>
;;
;; tspecials = "(" | ")" | "<" | ">" | "@"
;; | "," | ";" | ":" | "\" | <">
;; | "/" | "[" | "]" | "?" | "="
;; | "{" | "}" | SP | HT
(define char-set:tspecials
(char-set-union
(char-set-difference char-set:punctuation (string->char-set "_"))
char-set:whitespace))
(define char-set:control (char-set-union char-set:iso-control
(char-set (latin-1-integer->char 127))));; DEL
(define char-set:token (char-set-difference char-set:ascii char-set:tspecials char-set:control))
;;!
;;
;; (function (quoted-string? s))
;;
;; (param s String "The string to check")
;;
;; Returns #t only if the string is surrounded by double quotes. As in:
;; quoted-string = ( <"> *(qdtext) <"> )
;; qdtext = <any TEXT except <">>
(define quoted-string?
(lambda (s)
(and (string=? (string-take s 1) "\"")
(string=? (string-take-right s 1) "\""))))
;;!
;;
;; (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-string?
(opt-lambda (s (value? #t))
(unless (string? s)
(raise (make-cookie-error (format "String expected, received: ~a" s) (current-continuation-marks))))
(if value?
;; value: token | quoted-string
(or (string-every char-set:token s)
(quoted-string? s))
;; name: token
(string-every char-set: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?
(lambda (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))))
))
)
;;; cookie-unit.ss ends here

11
collects/net/uri-codec-sig.ss Normal file
View File

@ -0,0 +1,11 @@
(module uri-codec-sig mzscheme
(require (lib "unitsig.ss"))
(provide net:uri-codec^)
(define-signature net:uri-codec^
(uri-encode
uri-decode
form-urlencoded-encode
form-urlencoded-decode
alist->form-urlencoded
form-urlencoded->alist)))

260
collects/net/uri-codec-unit.ss Normal file
View File

@ -0,0 +1,260 @@
;;;
;;; <uri-codec-unit.ss> ---- En/Decode URLs and form-urlencoded data
;;; Time-stamp: <03/04/25 10:31:31 noel>
;;;
;;; Copyright (C) 2002 by Noel Welsh.
;;;
;;; This file is part of Net.
;;; 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.
;;; 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
;; The module provides functions to encode and decode strings using
;; the URI encoding rules given in RFC 2396, and to encode and decode
;; name/value pairs using the application/x-www-form-urlencoded
;; mimetype given the in HTML 4.0 specification. There are minor
;; differences between the two encodings.
;; The URI encoding uses allows a few characters to be represented `as
;; is': a-Z, A-Z, 0-9, -, _, ., !, ~, *, ', ( and ). The remaining
;; characters are encoded as %xx, where xx is the hex representation
;; of the integer value of the character (where the mapping
;; character<->integer is determined by US-ASCII if the integer is
;; <128).
;; The encoding, inline with RFC 2396's recommendation, represents a
;; character as is, if possible. The decoding allows any characters
;; to be represented by their hex values, and allows characters to be
;; incorrectly represented `as is'.
;; The rules for the application/x-www-form-urlencoded mimetype given
;; in the HTML 4.0 spec are:
;; 1. Control names and values are escaped. Space characters are
;; replaced by `+', and then reserved characters are escaped as
;; described in [RFC1738], section 2.2: Non-alphanumeric characters
;; are replaced by `%HH', a percent sign and two hexadecimal digits
;; representing the ASCII code of the character. Line breaks are
;; represented as "CR LF" pairs (i.e., `%0D%0A').
;; 2. The control names/values are listed in the order they appear
;; in the document. The name is separated from the value by `=' and
;; name/value pairs are separated from each other by `&'.
;; NB: RFC 2396 supersedes RFC 1738.
;; This differs slightly from the straight encoding in RFC 2396 in
;; that `+' is allowed, and represents a space. We follow this
;; convention, encoding a space as `+' and decoding `+' as a space.
;; There appear to be some brain-dead decoders on the web, so we also
;; encode `!', `~', `'', `(' and ')' using their hex representation.
;; This is the same choice as made by the Java URLEncoder.
;; Draws inspiration from encode-decode.scm by Kurt Normark and a code
;; sample provided by Eli Barzilay
(module uri-codec-unit mzscheme
(require (lib "unitsig.ss")
(lib "match.ss")
"uri-codec-sig.ss")
(provide uri-codec@)
;; Macro to loop over integers from n (inclusive) to m (exclusive)
;; Extracted from iteration.ss in macro package at Schematics
(define-syntax for
(syntax-rules ()
((for (i n m) forms ...)
(let ((fixed-m m))
(let loop ((i n))
(if (< i fixed-m)
(begin
forms ...
(loop (+ i 1)))))))))
(define uri-codec@
(unit/sig net:uri-codec^
(import)
;; The characters that always map to themselves
(define alphanumeric-mapping
(map (lambda (char)
(cons char char))
'(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
#\A #\B #\C #\D #\E #\F #\G #\H #\I #\J
#\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T
#\U #\V #\W #\X #\Y #\Z #\a #\b #\c #\d
#\e #\f #\g #\h #\i #\j #\k #\l #\m #\n
#\o #\p #\q #\r #\s #\t #\u #\v #\w #\x
#\y #\z)))
;; Characters that sometimes map to themselves
(define safe-mapping
(map (lambda (char)
(cons char char))
'(#\- #\_ #\. #\! #\~ #\* #\' #\( #\))))
;; The strict URI mapping
(define uri-mapping
(append alphanumeric-mapping safe-mapping))
;; The form-urlencoded mapping
(define form-urlencoded-mapping
(append '((#\. . #\.)
(#\- . #\-)
(#\* . #\*)
(#\_ . #\_)
(#\space . #\+))
alphanumeric-mapping))
(define (number->hex-string number)
(let ((hex (number->string number 16)))
(string-append "%"
(if (= (string-length hex) 1)
(string-append "0" hex)
hex))))
(define (hex-string->number hex-string)
(string->number (substring hex-string 1 3) 16))
;; (listof (cons char char)) -> (values (vectorof string) (vectorof string))
(define (make-codec-tables alist)
(let ((encoding-table (make-vector 256 ""))
(decoding-table (make-vector 256 "")))
(for (i 0 256)
(vector-set! encoding-table i (number->hex-string i))
(vector-set! decoding-table i (string (integer->char i))))
(for-each (match-lambda
[(orig . enc)
(vector-set! encoding-table
(char->integer orig)
(string enc))
(vector-set! decoding-table
(char->integer enc)
(string orig))])
alist)
(values encoding-table decoding-table)))
(define-values (uri-encoding-vector uri-decoding-vector)
(make-codec-tables uri-mapping))
(define-values (form-urlencoded-encoding-vector
form-urlencoded-decoding-vector)
(make-codec-tables form-urlencoded-mapping))
;; vector string -> string
(define (encode table str)
(apply string-append
(map (lambda (char)
(vector-ref table (char->integer char)))
(string->list str))))
;; vector string -> string
(define (decode table str)
(define internal-decode
(match-lambda
[() (list)]
[(#\% char1 char2 . rest)
(cons
(vector-ref table
(string->number (string char1 char2) 16))
(internal-decode rest))]
[(char . rest)
(cons
(vector-ref table
(char->integer char))
(internal-decode rest))]))
(apply string-append (internal-decode (string->list str))))
;; string -> string
(define (uri-encode str)
(encode uri-encoding-vector str))
;; string -> string
(define (uri-decode str)
(decode uri-decoding-vector str))
;; string -> string
(define (form-urlencoded-encode str)
(encode form-urlencoded-encoding-vector str))
;; string -> string
(define (form-urlencoded-decode str)
(decode form-urlencoded-decoding-vector str))
;; listof (cons string string) -> string
(define alist->form-urlencoded
(match-lambda
[() ""]
[((name . value))
(string-append (form-urlencoded-encode name)
"="
(form-urlencoded-encode value))]
[((name . value) . rest)
(string-append (form-urlencoded-encode name)
"="
(form-urlencoded-encode value)
"&"
(alist->form-urlencoded rest))]))
;; string -> listof (cons string string)
(define (form-urlencoded->alist str)
(define key-regexp (regexp "[^=]*"))
(define value-regexp (regexp "[^&]*"))
(define (next-key str start)
(if (>= start (string-length str))
#f
(match (regexp-match-positions key-regexp str start)
[((start . end))
(vector (form-urlencoded-decode (substring str start end))
(add1 end))]
[#f #f])))
(define (next-value str start)
(if (>= start (string-length str))
#f
(match (regexp-match-positions value-regexp str start)
[((start . end))
(vector (form-urlencoded-decode (substring str start end))
(add1 end))]
[#f #f])))
(define (next-pair str start)
(match (next-key str start)
[#(key start)
(match (next-value str start)
[#(value start)
(vector (cons key value) start)]
[#f
(vector (cons key "") (string-length str))])]
[#f #f]))
(let loop ((start 0)
(end (string-length str))
(alist '()))
(cond
[(>= start end) alist]
[else
(match (next-pair str start)
[#(pair next-start)
(loop next-start end (cons pair alist))]
[#f alist])])))
))
)
;;; uri-codec-unit.ss ends here