Ignore:
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.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/3/uri-generic/trunk/uri-generic.scm

    r11869 r11993  
    55;; Based on the Haskell URI library by  Graham Klyne <gk@ninebynine.org>.
    66;;
    7 ;; Copyright 2008 Ivan Raikov.
     7;; Copyright 2008 Ivan Raikov, Peter Bex.
    88;;
    99;;
     
    5555         uri? uri-auth uri-authority uri-scheme uri-path uri-query
    5656         uri-fragment uri-host uri-port uri-username uri-password
    57          absolute-uri uri->string uri->list uri-char-list-escape
    58          uri-char-list->string uri-string->char-list
     57         absolute-uri uri->string uri->list
    5958         uri-relative-to uri-relative-from
     59         uri-decode-string uri-encode-string
    6060         uri-normalize-case uri-normalize-path-segments))
    6161
     
    117117(define (ipv-future-char? c)  (char-set-contains? char-set:ipv-future c))
    118118
    119 (define (pct-escaped? c)      (match c ((#\% h1 h2) #t) (else #f)))
     119(define (pct-encoded? c)      (match c ((#\% h1 h2) #t) (else #f)))
    120120
    121121
     
    124124(define (uchar extras)
    125125  (let ((extras-set (or (and (char-set? extras) extras) (string->char-set extras))))
    126     (lambda (c) (or (pct-escaped? c) (unreserved-char? c)
     126    (lambda (c) (or (pct-encoded? c) (unreserved-char? c)
    127127                    (char-set-contains? char-set:sub-delims c)
    128128                    (char-set-contains? extras-set c) ))))
     
    131131(define (schar extras)
    132132  (let ((extras-set (or (and (char-set? extras) extras) (string->char-set extras))))
    133     (lambda (c) (or (pct-escaped? c)  (unreserved-char? c)
     133    (lambda (c) (or (pct-encoded? c)  (unreserved-char? c)
    134134                    (char-set-contains? extras-set c) ))))
    135135                 
     
    205205;; Returns a 'pct-encoded' sequence of octets.
    206206;;
    207 (define (pct-escape lst)
     207(define (pct-encode lst)
    208208  (define (hex-digit i) (and (>= i 0) (< i 16) (car (string->list (sprintf "~X" i)))))
    209209  (reverse (fold (lambda (x ax)
     
    212212                     (cons `(#\% ,h1 ,h2)  ax)))
    213213                 (list) lst)))
     214
    214215 
    215216;; RFC3986, section 2.2
     
    230231(define char-set:unreserved
    231232  (char-set-union char-set:letter+digit (string->char-set "-_.~")))
     233
    232234
    233235
     
    242244
    243245(define (uri s)
    244   (let ((s (if (string? s) (uri-string->char-list s) s)))
     246  (let ((s (if (string? s) (uri-string->normalized-char-list s) s)))
    245247    (match (scheme s)
    246248           ((us rst)
     
    489491(define reg-name
    490492  (count-min-max 0 255 (lambda (c) (or (unreserved-char? c)
    491                                        (pct-escaped? c)
     493                                       (pct-encoded? c)
    492494                                       (char-set-contains? char-set:sub-delims c) ))))
    493495
     
    546548(define (path-abs s)
    547549  (match s
    548          ((#\/ . rst)  (match (path-rootless rst)
    549                               ((() rst)  (list  (list #\/)  rst))
    550                               ((lst rst) (list  (cons (cons #\/ (car lst)) (cdr lst)) rst))
    551                               (else #f)))
     550         ((#\/)          (list (list (list #\/))  (list)))
     551         ((#\/ . rst)    (match (path-rootless rst)
     552                                ((() rst)  (list  (list (list #\/))  rst))
     553                                ((lst rst) (list  (cons (cons #\/ (car lst)) (cdr lst)) rst))
     554                                (else #f)))
    552555         (else #f)))
    553556
     
    607610
    608611(define (uri-reference s)
    609   (let ((s (if (string? s) (uri-string->char-list s) s)))
     612  (let ((s (if (string? s) (uri-string->normalized-char-list s) s)))
    610613    (or (uri s) (relative-ref s))))
    611614
     
    629632                             query: (and uq (filter-map query->string uq))
    630633                             fragment: (and uf (uri-char-list->string uf))))))
     634
    631635(define (relative-part s)
    632636  (match s
     
    643647
    644648(define (absolute-uri s)
    645   (let ((s (if (string? s) (uri-string->char-list s) s)))
     649  (let ((s (if (string? s) (uri-string->normalized-char-list s) s)))
    646650    (match (scheme s)
    647651           ((us rst) 
     
    700704                         
    701705
    702 ;;  Escape sequence handling
    703 
    704 (define (uri-char-list-escape p enc str)
     706;;  Percent encoding and decoding
     707
     708(define (char-list-encode p enc str)
    705709  (reverse
    706710   (fold (lambda (c ax)
    707            (if (not (p c)) (let* ((os (enc c))  (cs (map pct-escape os)))
    708                              (append (reverse cs) ax))
     711           (if (p c) (let* ((os (enc c)) 
     712                            (cs (map pct-encode os)))
     713                       (append (concatenate (reverse cs)) ax))
    709714               (cons c ax)))
    710715         (list) str)))
     716
     717(define (integer->octets i)
     718  (let loop ((i i) (lst (list)))
     719    (if (zero? i) lst
     720        (loop (quotient i 256) (cons (modulo i 256) lst)))))
     721
     722
     723(define (uri-encode-string str)
     724  (let ((clst (uri-string->char-list str)))
     725    (uri-char-list->string
     726     (char-list-encode reserved-char? (compose integer->octets char->integer) clst))))
     727
     728
     729(define (octets->integer lst)
     730  (let loop ((i 0) (m 1) (lst (reverse lst)))
     731    (if (null? lst) i
     732        (loop (+ i (* (car lst) m)) (* m 256) (cdr lst)))))
     733
     734(define (pct-decode c)
     735  (match c
     736         ((#\% h1 h2)  (integer->char (octet-decode h1 h2)))
     737         (else c)))
     738
     739(define (hex-digit-char->integer c)
     740  (case c
     741         ((#\1)  1)
     742         ((#\2)  2)
     743         ((#\3)  3)
     744         ((#\4)  4)
     745         ((#\5)  5)
     746         ((#\6)  6)
     747         ((#\7)  7)
     748         ((#\8)  8)
     749         ((#\9)  9)
     750         ((#\A)  10)
     751         ((#\B)  11)
     752         ((#\C)  12)
     753         ((#\D)  13)
     754         ((#\E)  14)
     755         ((#\F)  15)
     756         (else  (error 'hex-digit-char->integer "invalid hex char " c))))
     757
     758(define (octet-decode h1 h2)
     759  (+ (* 16 (hex-digit-char->integer h1)) (hex-digit-char->integer h2)))
     760
     761(define (uri-decode-string str)
     762  (let loop ((clst (uri-string->char-list str)) (p (list))  (nlst (list)))
     763    (if (null? clst)
     764        (uri-char-list->string (reverse nlst))
     765        (match (car clst)
     766               ((and c (? char?)) 
     767                (if (null? p) (loop (cdr clst) p (cons c nlst))
     768                    (let ((pc (integer->char (octets->integer (reverse p)))))
     769                      (loop (cdr clst) (list) (cons* c pc nlst)))))
     770               ((#\% h1 h2) 
     771                (loop (cdr clst) (cons (octet-decode h1 h2) p) nlst))
     772               (else (error 'uri-decode-string "invalid URI string " str))))))
     773   
     774(define (uri-string->normalized-char-list str)
     775  (let ((clst (uri-string->char-list str)))
     776    (map (lambda (c) (if (pct-encoded? c)
     777                         (let ((e (pct-decode c)))
     778                           (if (unreserved-char? e) e c)) c))
     779         clst)))
     780                         
     781
    711782
    712783;; Convert a URI character list to a string
Note: See TracChangeset for help on using the changeset viewer.