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 '()))))