[gambit-list] AWS, Termite, and Snow
Joe Hosteny
jhosteny at gmail.com
Thu Jan 31 16:47:15 EST 2008
On Jan 30, 2008, at 10:31 AM, Joe Hosteny wrote:
>
> Marc pointed me to some URI parsing code in the Gambit distribution.
> I took a quick look at that, and it may be sufficient. I'll know
> more later. If it is, I'll look into partitioning it into a Snow
> package as well.
>
>>
>> Please keep us posted if you get something working. I'm very
>> interested in that stuff.
>>
>
>
I'm currently stuck with some difficulties getting Gambit (4.0.22 or
4.1.2) working with Snow. I posted two bugs to Bugzilla for the
problems I was having. But I did get a start on a URI package from the
code Marc wrote.
The only real difference, so far, is that I changed the encode-for-uri
and encode-x-www-form-urlencoded to not escape the full set of
unreserved chars - the existing code was escaping [-_.~]. Strictly
speaking, I don't think RFC 3986 requires this, but I believe that
that is the encouraged behavior (and certainly, the URIs for the EC2
API expect the non-percent-encoded unreserved characters).
Also, the string package doesn't seem to have a snow variant of the
with-output-to-string, so I also changed the write routines in encode-
x-www-form-urlencoded to take a port so that snow-call-with-output-
string can be used. Perhaps those could be added to the string package
(unless they aren't there for a reason)?
This was just a start. Perhaps some more utility methods should be
added, for example, to break up the authority component to username,
port, etc.?
Cheers,
--Joe
":";exec snow -- "$0" "$@"
(package* uri/v1.0.0
(provide:
(define (string->uri str decode?))
(define (encode-for-uri str))
(define (encode-x-www-form-urlencoded fields))
(define (decode-x-www-form-urlencoded str))
(define-record* uri
scheme
authority
path
query
fragment))
(maintainer:
"Scheme Now! <snow at iro.uontreal.ca>")
(author:
"Marc Feeley <feeley at iro.umontreal.ca>")
(homepage:
"http://snow.iro.umontreal.ca")
(description:
"URI encoding / decoding and parsing.")
(keywords: uri snow)
(license: lgpl/v2.1)
(require: string/v1))
(cond-expand
(gambit
(declare
(standard-bindings)
(extended-bindings)
(block)
(not safe)))
(else
#f))
;=
=
=
=
=
=
========================================================================
; URI parsing.
(define hex-digit
(lambda (str i)
(let ((n (char->integer (string-ref str i))))
(cond ((and (>= n 48) (<= n 57))
(- n 48))
((and (>= n 65) (<= n 70))
(- n 55))
((and (>= n 97) (<= n 102))
(- n 87))
(else
#f)))))
(define hex-octet
(lambda (str i)
(let ((n1 (hex-digit str i)))
(and n1
(let ((n2 (hex-digit str (+ i 1))))
(and n2
(+ (* n1 16) n2)))))))
(define plausible-hex-escape?
(lambda (str end j)
(and (< (+ j 2) end)
(not (control-or-space-char? (string-ref str (+ j 1))))
(not (control-or-space-char? (string-ref str (+ j 2)))))))
(define control-or-space-char?
(lambda (c)
(or (not (char<? #\space c))
(not (char<? c #\x7f)))))
(define excluded-char?
(lambda (c)
(or (not (char<? #\space c))
(not (char<? c #\x7f))
(char=? c #\<)
(char=? c #\>)
(char=? c #\#)
(char=? c #\%)
(char=? c #\")
(char=? c #\{)
(char=? c #\})
(char=? c #\|)
(char=? c #\\)
(char=? c #\^)
(char=? c #\[)
(char=? c #\])
(char=? c #\`))))
(define unreserved-char?
(lambda (c)
(or (and (char>=? c #\a) (char<=? c #\z))
(and (char>=? c #\A) (char<=? c #\Z))
(and (char>=? c #\0) (char<=? c #\9))
(char=? c #\-)
(char=? c #\.)
(char=? c #\_)
(char=? c #\~))))
(define extract-escaped
(lambda (str start n)
(let ((result (make-string n)))
(let loop ((i start) (j 0))
(if (< j n)
(let ((c (string-ref str i)))
(if (char=? c #\%)
(let ((n (hex-octet str (+ i 1))))
(and n
(begin
(string-set! result j (integer->char n))
(loop (+ i 3)
(+ j 1)))))
(begin
(string-set! result j (if (char=? c #\+) #\space
c))
(loop (+ i 1)
(+ j 1)))))
result)))))
(define parse-uri
(lambda (str start end decode? cont)
(let ((uri (make-uri #f #f "" #f #f)))
(define extract-string
(lambda (i j n)
(if decode?
(extract-escaped str i n)
(substring str i j))))
(define extract-query
(lambda (i j n)
(if decode?
(parse-uri-query
str
i
j
decode?
(lambda (bindings end)
bindings))
(substring str i j))))
(define state0 ; possibly inside the "scheme" part
(lambda (i j n)
(if (< j end)
(let ((c (string-ref str j)))
(cond ((char=? c #\:)
(if (= n 0)
(state2 j (+ j 1) 1) ; the ":" is in the
"path" part
(let ((scheme (extract-string i j n)))
(and scheme
(begin
(uri-scheme-set! uri scheme)
(if (and (< (+ j 2) end)
(char=? (string-ref str
(+ j 1))
#\/)
(char=? (string-ref str
(+ j 2))
#\/))
(state1 (+ j 3) (+ j 3) 0)
(state2 (+ j 1) (+ j 1)
0)))))))
((char=? c #\/)
(if (and (= n 0)
(< (+ j 1) end)
(char=? (string-ref str (+ j 1)) #\/))
(state1 (+ j 2) (+ j 2) 0)
(state2 i (+ j 1) (+ n 1))))
((char=? c #\?)
(let ((path (extract-string i j n)))
(and path
(begin
(uri-path-set! uri path)
(state3 (+ j 1) (+ j 1) 0)))))
((char=? c #\#)
(let ((path (extract-string i j n)))
(and path
(begin
(uri-path-set! uri path)
(state4 (+ j 1) (+ j 1) 0)))))
((char=? c #\%)
(and (plausible-hex-escape? str end j)
(state0 i (+ j 3) (+ n 1))))
((control-or-space-char? c)
(let ((path (extract-string i j n)))
(and path
(begin
(uri-path-set! uri path)
j))))
(else
(state0 i (+ j 1) (+ n 1)))))
(let ((path (extract-string i j n)))
(and path
(begin
(uri-path-set! uri path)
j))))))
(define state1 ; inside the "authority" part
(lambda (i j n)
(if (< j end)
(let ((c (string-ref str j)))
(cond ((char=? c #\/)
(let ((authority (extract-string i j n)))
(and authority
(begin
(uri-authority-set! uri authority)
(state2 j (+ j 1) 1)))))
((char=? c #\?)
(let ((authority (extract-string i j n)))
(and authority
(begin
(uri-authority-set! uri authority)
(state3 (+ j 1) (+ j 1) 0)))))
((char=? c #\#)
(let ((authority (extract-string i j n)))
(and authority
(begin
(uri-authority-set! uri authority)
(state4 (+ j 1) (+ j 1) 0)))))
((char=? c #\%)
(and (plausible-hex-escape? str end j)
(state1 i (+ j 3) (+ n 1))))
((control-or-space-char? c)
(let ((authority (extract-string i j n)))
(and authority
(begin
(uri-authority-set! uri authority)
j))))
(else
(state1 i (+ j 1) (+ n 1)))))
(let ((authority (extract-string i j n)))
(and authority
(begin
(uri-authority-set! uri authority)
j))))))
(define state2 ; inside the "path" part
(lambda (i j n)
(if (< j end)
(let ((c (string-ref str j)))
(cond ((char=? c #\?)
(let ((path (extract-string i j n)))
(and path
(begin
(uri-path-set! uri path)
(state3 (+ j 1) (+ j 1) 0)))))
((char=? c #\#)
(let ((path (extract-string i j n)))
(and path
(begin
(uri-path-set! uri path)
(state4 (+ j 1) (+ j 1) 0)))))
((char=? c #\%)
(and (plausible-hex-escape? str end j)
(state2 i (+ j 3) (+ n 1))))
((control-or-space-char? c)
(let ((path (extract-string i j n)))
(and path
(begin
(uri-path-set! uri path)
j))))
(else
(state2 i (+ j 1) (+ n 1)))))
(let ((path (extract-string i j n)))
(and path
(begin
(uri-path-set! uri path)
j))))))
(define state3 ; inside the "query" part
(lambda (i j n)
(if (< j end)
(let ((c (string-ref str j)))
(cond ((char=? c #\#)
(let ((query (extract-query i j n)))
(and query
(begin
(uri-query-set! uri query)
(state4 (+ j 1) (+ j 1) 0)))))
((char=? c #\%)
(and (plausible-hex-escape? str end j)
(state3 i (+ j 3) (+ n 1))))
((control-or-space-char? c)
(let ((query (extract-query i j n)))
(and query
(begin
(uri-query-set! uri query)
j))))
(else
(state3 i (+ j 1) (+ n 1)))))
(let ((query (extract-query i j n)))
(and query
(begin
(uri-query-set! uri query)
j))))))
(define state4 ; inside the "fragment" part
(lambda (i j n)
(if (< j end)
(let ((c (string-ref str j)))
(cond ((char=? c #\%)
(and (plausible-hex-escape? str end j)
(state4 i (+ j 3) (+ n 1))))
((control-or-space-char? c)
(let ((fragment (extract-string i j n)))
(and fragment
(begin
(uri-fragment-set! uri fragment)
j))))
(else
(state4 i (+ j 1) (+ n 1)))))
(let ((fragment (extract-string i j n)))
(and fragment
(begin
(uri-fragment-set! uri fragment)
j))))))
(let ((i (state0 start start 0)))
(cont (and i uri)
(or i start))))))
(define parse-uri-query
(lambda (str start end decode? cont)
(let ((rev-bindings '()))
(define extract-string
(lambda (i j n)
(if decode?
(extract-escaped str i n)
(substring str i j))))
(define state0
(lambda (i j n)
(if (< j end)
(let ((c (string-ref str j)))
(cond ((char=? c #\%)
(and (plausible-hex-escape? str end j)
(state0 i
(+ j 3)
(+ n 1))))
((char=? c #\=)
(let ((name (extract-string i j n)))
(and name
(let ((j (+ j 1)))
(state1 j
j
0
name)))))
((char=? c #\&)
#f)
((excluded-char? c)
(if (= n 0)
j
#f))
(else
(state0 i
(+ j 1)
(+ n 1)))))
(if (= n 0)
j
#f))))
(define state1
(lambda (i j n name)
(if (< j end)
(let ((c (string-ref str j)))
(cond ((char=? c #\%)
(and (plausible-hex-escape? str end j)
(state1 i
(+ j 3)
(+ n 1)
name)))
((char=? c #\&)
(let ((val (extract-string i j n)))
(and val
(let ((j (+ j 1)))
(set! rev-bindings
(cons (cons name val) rev-
bindings))
(and (< j end)
(state0 j
j
0))))))
((char=? c #\=)
#f)
((excluded-char? c)
(let ((val (extract-string i j n)))
(and val
(begin
(set! rev-bindings
(cons (cons name val) rev-
bindings))
j))))
(else
(state1 i
(+ j 1)
(+ n 1)
name))))
(let ((val (extract-string i j n)))
(and val
(begin
(set! rev-bindings
(cons (cons name val) rev-bindings))
j))))))
(let ((i (state0 start start 0)))
(cont (and i (reverse rev-bindings))
(or i start))))))
(define string->uri
(lambda (str decode?)
(parse-uri str
0
(string-length str)
decode?
(lambda (uri end)
(and (= end (string-length str))
uri)))))
(define string->uri-query
(lambda (str decode?)
(parse-uri-query str
0
(string-length str)
decode?
(lambda (query end)
(and (= end (string-length str))
query)))))
(define encode-for-uri
(lambda (str)
(let ((end (string-length str)))
(define copy
(lambda (result i j n)
(if (< i j)
(let ((new-j (- j 1))
(new-n (- n 1)))
(string-set! result new-n (string-ref str new-j))
(copy result i new-j new-n))
result)))
(define hex
(lambda (x)
(string-ref "0123456789ABCDEF" (bitwise-and x 15))))
(define encode
(lambda (i j n)
(if (< j end)
(let ((c (string-ref str j)))
(cond ((char=? c #\space)
(let ((result (encode (+ j 1) (+ j 1) (+ n 1))))
(string-set! result n #\+)
(copy result i j n)))
((unreserved-char? c)
(let ((result (encode (+ j 1) (+ j 1) (+ n 1))))
(string-set! result n c)
(copy result i j n)))
((or (char=? c #\+)
(excluded-char? c))
(let ((result (encode (+ j 1) (+ j 1) (+ n 3))))
(let* ((x (char->integer c))
(hi (hex (arithmetic-shift x -4)))
(lo (hex x)))
(string-set! result n #\%)
(string-set! result (+ n 1) hi)
(string-set! result (+ n 2) lo))
(copy result i j n)))
(else
(encode i (+ j 1) (+ n 1)))))
(let ((result (make-string n)))
(copy result i j n)))))
(encode 0 0 0))))
;=
=
=
=
=
=
========================================================================
; x-www-form-urlencoded encoding and decoding.
(define encode-x-www-form-urlencoded
(lambda (fields)
(define write-urlencoded
(lambda (str port)
(define write-nibble
(lambda (n port)
(write-char (string-ref "0123456789ABCDEF" n) port)))
(let loop ((i 0))
(if (< i (string-length str))
(let ((c (string-ref str i)))
(cond ((unreserved-char? c)
(write-char c port))
((char=? c #\space)
(write-char #\+ port))
(else
(let ((n (char->integer c)))
(write-char #\% port)
(write-nibble
(bitwise-and (arithmetic-shift n -4) 15)
port)
(write-nibble (bitwise-and n 15) port))))
(loop (+ i 1)))))))
(define write-field
(lambda (field port)
(write-urlencoded (car field) port)
(write-char #\= port)
(write-urlencoded (cdr field) port)))
(if (null? fields)
""
(snow-call-with-output-string
(lambda (port)
(let ((field1 (car fields)))
(write-field field1 port)
(for-each (lambda (field)
(write-char #\& port)
(write-field field port))
(cdr fields))))))))
(define decode-x-www-form-urlencoded
(lambda (str)
(let ((n (string-length str)))
(define extract
(lambda (start len)
(let ((s (make-string len)))
(let loop ((i start) (j 0))
(if (< j len)
(let ((c (string-ref str i)))
(cond ((char=? c #\%)
(cond ((hex (+ i 1))
=>
(lambda (x)
(string-set! s j (integer->char x))
(loop (+ i 3) (+ j 1))))
(else
#f)))
((char=? c #\+)
(string-set! s j #\space)
(loop (+ i 1) (+ j 1)))
(else
(string-set! s j c)
(loop (+ i 1) (+ j 1)))))
s)))))
(define hex
(lambda (i)
(if (< (+ i 1) n)
(let ((h1 (nibble i))
(h2 (nibble (+ i 1))))
(and h1 h2 (+ (* h1 16) h2)))
#f)))
(define nibble
(lambda (i)
(let ((c (string-ref str i)))
(cond ((and (char>=? c #\0) (char<=? c #\9))
(- (char->integer c) (char->integer #\0)))
((and (char>=? c #\a) (char<=? c #\f))
(+ 10 (- (char->integer c) (char->integer #\a))))
((and (char>=? c #\A) (char<=? c #\F))
(+ 10 (- (char->integer c) (char->integer #\A))))
(else
#f)))))
(define state0 ; at beginning of string
(lambda (i rev-fields)
(if (< i n)
(state1 i
i
0
rev-fields)
(reverse rev-fields))))
(define state1 ; in field name
(lambda (i start len rev-fields)
(if (< i n)
(let ((c (string-ref str i)))
(cond ((char=? c #\=)
(state2 (+ i 1)
(+ i 1)
0
(extract start len)
rev-fields))
((char=? c #\%)
(and (hex (+ i 1))
(state1 (+ i 3)
start
(+ len 1)
rev-fields)))
(else
(state1 (+ i 1)
start
(+ len 1)
rev-fields))))
#f)))
(define state2 ; in field value
(lambda (i start len name rev-fields)
(define end-of-field
(lambda ()
(cons (cons name (extract start len))
rev-fields)))
(if (< i n)
(let ((c (string-ref str i)))
(cond ((char=? c #\&)
(state1 (+ i 1)
(+ i 1)
0
(end-of-field)))
((char=? c #\%)
(and (hex (+ i 1))
(state2 (+ i 3)
start
(+ len 1)
name
rev-fields)))
(else
(state2 (+ i 1)
start
(+ len 1)
name
rev-fields))))
(reverse (end-of-field)))))
(state0 0 '()))))
More information about the Gambit-list
mailing list