Changeset 11993 in project

Timestamp:

09/25/08 02:30:13 (12 years ago)

Author:

Ivan Raikov

Message:

Added string encode/decode routines and bug fix in the path-abs.

Location:

release/3/uri-generic/trunk

Files:

• uri-generic.scm (modified) (15 diffs)
• uri-generic.setup (modified) (1 diff)

release/3/uri-generic/trunk/uri-generic.scm

@@ -5 +5 @@
 ;; Based on the Haskell URI library by  Graham Klyne <gk@ninebynine.org>.
 ;;
-;; Copyright 2008 Ivan Raikov.
+;; Copyright 2008 Ivan Raikov, Peter Bex.
 ;;
 ;; 
@@ -55 +55 @@
          uri? uri-auth uri-authority uri-scheme uri-path uri-query
          uri-fragment uri-host uri-port uri-username uri-password
-         absolute-uri uri->string uri->list uri-char-list-escape
-         uri-char-list->string uri-string->char-list 
+         absolute-uri uri->string uri->list 
          uri-relative-to uri-relative-from 
+         uri-decode-string uri-encode-string 
          uri-normalize-case uri-normalize-path-segments))
 
@@ -117 +117 @@
 (define (ipv-future-char? c)  (char-set-contains? char-set:ipv-future c))
 
-(define (pct-escaped? c)      (match c ((#\% h1 h2) #t) (else #f)))
+(define (pct-encoded? c)      (match c ((#\% h1 h2) #t) (else #f)))
 
 
@@ -124 +124 @@
 (define (uchar extras)
   (let ((extras-set (or (and (char-set? extras) extras) (string->char-set extras))))
-    (lambda (c) (or (pct-escaped? c) (unreserved-char? c) 
+    (lambda (c) (or (pct-encoded? c) (unreserved-char? c) 
                     (char-set-contains? char-set:sub-delims c) 
                     (char-set-contains? extras-set c) ))))
@@ -131 +131 @@
 (define (schar extras)
   (let ((extras-set (or (and (char-set? extras) extras) (string->char-set extras))))
-    (lambda (c) (or (pct-escaped? c)  (unreserved-char? c) 
+    (lambda (c) (or (pct-encoded? c)  (unreserved-char? c) 
                     (char-set-contains? extras-set c) ))))
                   
@@ -205 +205 @@
 ;; Returns a 'pct-encoded' sequence of octets.
 ;;
-(define (pct-escape lst)
+(define (pct-encode lst)
   (define (hex-digit i) (and (>= i 0) (< i 16) (car (string->list (sprintf "~X" i)))))
   (reverse (fold (lambda (x ax)
@@ -212 +212 @@
                      (cons `(#\% ,h1 ,h2)  ax)))
                  (list) lst)))
+
   
 ;; RFC3986, section 2.2 
@@ -230 +231 @@
 (define char-set:unreserved 
   (char-set-union char-set:letter+digit (string->char-set "-_.~")))
+
 
 
@@ -242 +244 @@
 
 (define (uri s)
-  (let ((s (if (string? s) (uri-string->char-list s) s)))
+  (let ((s (if (string? s) (uri-string->normalized-char-list s) s)))
     (match (scheme s)
            ((us rst)
@@ -489 +491 @@
 (define reg-name
   (count-min-max 0 255 (lambda (c) (or (unreserved-char? c) 
-                                       (pct-escaped? c) 
+                                       (pct-encoded? c) 
                                        (char-set-contains? char-set:sub-delims c) ))))
 
@@ -546 +548 @@
 (define (path-abs s)
   (match s
-         ((#\/ . rst)  (match (path-rootless rst)
-                              ((() rst)  (list  (list #\/)  rst))
-                              ((lst rst) (list  (cons (cons #\/ (car lst)) (cdr lst)) rst))
-                              (else #f)))
+         ((#\/)          (list (list (list #\/))  (list)))
+         ((#\/ . rst)    (match (path-rootless rst)
+                                ((() rst)  (list  (list (list #\/))  rst))
+                                ((lst rst) (list  (cons (cons #\/ (car lst)) (cdr lst)) rst))
+                                (else #f)))
          (else #f)))
 
@@ -607 +610 @@
 
 (define (uri-reference s)
-  (let ((s (if (string? s) (uri-string->char-list s) s)))
+  (let ((s (if (string? s) (uri-string->normalized-char-list s) s)))
     (or (uri s) (relative-ref s))))
 
@@ -629 +632 @@
                              query: (and uq (filter-map query->string uq))
                              fragment: (and uf (uri-char-list->string uf))))))
+
 (define (relative-part s)
   (match s
@@ -643 +647 @@
 
 (define (absolute-uri s)
-  (let ((s (if (string? s) (uri-string->char-list s) s)))
+  (let ((s (if (string? s) (uri-string->normalized-char-list s) s)))
     (match (scheme s)
            ((us rst)  
@@ -700 +704 @@
                          
 
-;;  Escape sequence handling
-
-(define (uri-char-list-escape p enc str)
+;;  Percent encoding and decoding
+
+(define (char-list-encode p enc str)
   (reverse
    (fold (lambda (c ax) 
-           (if (not (p c)) (let* ((os (enc c))  (cs (map pct-escape os)))
-                             (append (reverse cs) ax))
+           (if (p c) (let* ((os (enc c))  
+                            (cs (map pct-encode os)))
+                       (append (concatenate (reverse cs)) ax))
                (cons c ax)))
          (list) str)))
+
+(define (integer->octets i)
+  (let loop ((i i) (lst (list)))
+    (if (zero? i) lst
+        (loop (quotient i 256) (cons (modulo i 256) lst)))))
+
+
+(define (uri-encode-string str)
+  (let ((clst (uri-string->char-list str)))
+    (uri-char-list->string 
+     (char-list-encode reserved-char? (compose integer->octets char->integer) clst))))
+
+
+(define (octets->integer lst)
+  (let loop ((i 0) (m 1) (lst (reverse lst)))
+    (if (null? lst) i
+        (loop (+ i (* (car lst) m)) (* m 256) (cdr lst)))))
+
+(define (pct-decode c)
+  (match c
+         ((#\% h1 h2)  (integer->char (octet-decode h1 h2)))
+         (else c)))
+
+(define (hex-digit-char->integer c)
+  (case c
+         ((#\1)  1)
+         ((#\2)  2)
+         ((#\3)  3)
+         ((#\4)  4)
+         ((#\5)  5)
+         ((#\6)  6)
+         ((#\7)  7)
+         ((#\8)  8)
+         ((#\9)  9)
+         ((#\A)  10)
+         ((#\B)  11)
+         ((#\C)  12)
+         ((#\D)  13)
+         ((#\E)  14)
+         ((#\F)  15)
+         (else  (error 'hex-digit-char->integer "invalid hex char " c))))
+
+(define (octet-decode h1 h2)
+  (+ (* 16 (hex-digit-char->integer h1)) (hex-digit-char->integer h2)))
+
+(define (uri-decode-string str)
+  (let loop ((clst (uri-string->char-list str)) (p (list))  (nlst (list)))
+    (if (null? clst)
+        (uri-char-list->string (reverse nlst))
+        (match (car clst)
+               ((and c (? char?))  
+                (if (null? p) (loop (cdr clst) p (cons c nlst))
+                    (let ((pc (integer->char (octets->integer (reverse p)))))
+                      (loop (cdr clst) (list) (cons* c pc nlst)))))
+               ((#\% h1 h2)  
+                (loop (cdr clst) (cons (octet-decode h1 h2) p) nlst))
+               (else (error 'uri-decode-string "invalid URI string " str))))))
+    
+(define (uri-string->normalized-char-list str)
+  (let ((clst (uri-string->char-list str)))
+    (map (lambda (c) (if (pct-encoded? c) 
+                         (let ((e (pct-decode c)))
+                           (if (unreserved-char? e) e c)) c))
+         clst)))
+                         
+
 
 ;; Convert a URI character list to a string

release/3/uri-generic/trunk/uri-generic.setup

@@ -21 +21 @@
 
   ;; Assoc list with properties for your extension:
-  '((version 1.7)
+  '((version 1.8)
     (documentation "uri-generic.html")
     ,@(if has-exports? `((exports "uri-generic.exports")) (list)) ))