module/slib/uri.scm

   1 ;;; "uri.scm" Construct and decode Uniform Resource Identifiers. -*-scheme-*-
   2 ; Copyright 1997, 1998, 2000, 2001 Aubrey Jaffer
   3 ;
   4 ;Permission to copy this software, to redistribute it, and to use it
   5 ;for any purpose is granted, subject to the following restrictions and
   6 ;understandings.
   7 ;
   8 ;1.  Any copy made of this software must include this copyright notice
   9 ;in full.
  10 ;
  11 ;2.  I have made no warrantee or representation that the operation of
  12 ;this software will be error-free, and I am under no obligation to
  13 ;provide any services, by way of maintenance, update, or otherwise.
  14 ;
  15 ;3.  In conjunction with products arising from the use of this
  16 ;material, there shall be no use of my name in any advertising,
  17 ;promotional, or sales literature without prior written consent in
  18 ;each case.
  19
  20 (require 'coerce)
  21 (require 'printf)
  22 (require 'string-case)
  23 (require 'string-search)
  24 (require 'common-list-functions)
  25
  26 ;;@code{(require 'uri)}
  27 ;;
  28 ;;@noindent Implements @dfn{Uniform Resource Identifiers} (URI) as
  29 ;;described in RFC 2396.
  30
  31 ;;@args
  32 ;;@args fragment
  33 ;;@args query fragment
  34 ;;@args path query fragment
  35 ;;@args authority path query fragment
  36 ;;@args scheme authority path query fragment
  37 ;;
  38 ;;Returns a Uniform Resource Identifier string from component arguments.
  39 (define (make-uri . args)
  40   (define nargs (length args))
  41   (set! args (reverse args))
  42   (let ((fragment  (if (>= nargs 1) (car args) #f))
  43         (query     (if (>= nargs 2) (cadr args) #f))
  44         (path      (if (>= nargs 3) (caddr args) #f))
  45         (authority (if (>= nargs 4) (cadddr args) #f))
  46         (scheme    (if (>= nargs 5) (list-ref args 4) #f)))
  47     (string-append
  48      (if scheme (sprintf #f "%s:" scheme) "")
  49      (cond ((string? authority)
  50             (sprintf #f "//%s" (uric:encode authority "$,;:@&=+")))
  51            ((list? authority)
  52             (apply (lambda (userinfo host port)
  53                      (cond ((and userinfo port)
  54                             (sprintf #f "//%s@%s:%d"
  55                                      (uric:encode userinfo "$,;:&=+")
  56                                      host port))
  57                            (userinfo
  58                             (sprintf #f "//%s@%s"
  59                                      (uric:encode userinfo "$,;:&=+")
  60                                      host))
  61                            (port
  62                             (sprintf #f "//%s:%d" host port))
  63                            (else host)))
  64                    authority))
  65            (else (or authority "")))
  66      (cond ((string? path) (uric:encode path "/$,;:@&=+"))
  67            ((null? path) "")
  68            ((list? path) (uri:make-path path))
  69            (else path))
  70      (if query (sprintf #f "?%s" (uric:encode query "?/$,;:@&=+")) "")
  71      (if fragment (sprintf #f "#%s" (uric:encode fragment "?/$,;:@&=+")) ""))))
  72
  73 (define (uri:make-path path)
  74   (apply string-append
  75          (uric:encode (car path) "$,;:@&=+")
  76          (map (lambda (pth) (string-append "/" (uric:encode pth "$,;:@&=+")))
  77               (cdr path))))
  78
  79 ;;@body Returns a string which defines this location in the (HTML) file
  80 ;;as @1.  The hypertext @samp{<A HREF="#@1">} will link to this point.
  81 ;;
  82 ;;@example
  83 ;;(html:anchor "(section 7)")
  84 ;;@result{}
  85 ;;"<A NAME=\"(section%207)\"></A>"
  86 ;;@end example
  87 (define (html:anchor name)
  88   (sprintf #f "<A NAME=\"%s\"></A>" (uric:encode name "#?/:@;=")))
  89
  90 ;;@body Returns a string which links the @2 text to @1.
  91 ;;
  92 ;;@example
  93 ;;(html:link (make-uri "(section 7)") "section 7")
  94 ;;@result{}
  95 ;;"<A HREF=\"#(section%207)\">section 7</A>"
  96 ;;@end example
  97 (define (html:link uri highlighted)
  98   (sprintf #f "<A HREF=\"%s\">%s</A>" uri highlighted))
  99
 100 ;;@body Returns a string specifying the @dfn{base} @1 of a document, for
 101 ;;inclusion in the HEAD of the document (@pxref{HTML, head}).
 102 (define (html:base uri)
 103   (sprintf #f "<BASE HREF=\"%s\">" uri))
 104
 105 ;;@body Returns a string specifying the search @1 of a document, for
 106 ;;inclusion in the HEAD of the document (@pxref{HTML, head}).
 107 (define (html:isindex prompt)
 108   (sprintf #f "<ISINDEX PROMPT=\"%s\">" prompt))
 109
 110 ;;@body Returns a list of 5 elements corresponding to the parts
 111 ;;(@var{scheme} @var{authority} @var{path} @var{query} @var{fragment})
 112 ;;of string @1.  Elements corresponding to absent parts are #f.
 113 ;;
 114 ;;The @var{path} is a list of strings.  If the first string is empty,
 115 ;;then the path is absolute; otherwise relative.
 116 ;;
 117 ;;If the @var{authority} component is a
 118 ;;@dfn{Server-based Naming Authority}, then it is a list of the
 119 ;;@var{userinfo}, @var{host}, and @var{port} strings (or #f).  For other
 120 ;;types of @var{authority} components the @var{authority} will be a
 121 ;;string.
 122 ;;
 123 ;;@example
 124 ;;(uri->tree "http://www.ics.uci.edu/pub/ietf/uri/#Related")
 125 ;;@result{}
 126 ;;(http "www.ics.uci.edu" ("" "pub" "ietf" "uri" "") #f "Related")
 127 ;;@end example
 128 (define (uri->tree uri-reference . base-tree)
 129   (define split (uri:split uri-reference))
 130   (apply (lambda (b-scheme b-authority b-path b-query b-fragment)
 131            (apply
 132             (lambda (scheme authority path query fragment)
 133               (define uri-empty?
 134                 (and (equal? "" path) (not scheme) (not authority) (not query)))
 135               (list (if scheme
 136                         (string-ci->symbol scheme)
 137                         b-scheme)
 138                     (if authority
 139                         (uri:decode-authority authority)
 140                         b-authority)
 141                     (if uri-empty?
 142                         (or b-path '(""))
 143                         (uri:decode-path
 144                          (map uric:decode (uri:split-fields path #\/))
 145                          (and (not authority) (not scheme) b-path)))
 146                     (if uri-empty?
 147                         b-query
 148                         query)
 149                     (or (and fragment (uric:decode fragment))
 150                         (and uri-empty? b-fragment))))
 151             split))
 152          (if (or (car split) (null? base-tree) (car split))
 153              '(#f #f #f #f #f)
 154              (car base-tree))))
 155
 156 (define (uri:decode-path path-list base-path)
 157   (cond ((and (equal? "" (car path-list))
 158               (not (equal? '("") path-list)))
 159          path-list)
 160         (base-path
 161          (let* ((cpath0 (append (butlast base-path 1) path-list))
 162                 (cpath1
 163                  (let remove ((l cpath0) (result '()))
 164                    (cond ((null? l) (reverse result))
 165                          ((not (equal? "." (car l)))
 166                           (remove (cdr l) (cons (car l) result)))
 167                          ((null? (cdr l))
 168                           (reverse (cons "" result)))
 169                          (else (remove (cdr l) result)))))
 170                 (cpath2
 171                  (let remove ((l cpath1) (result '()))
 172                    (cond ((null? l) (reverse result))
 173                          ((not (equal? ".." (car l)))
 174                           (remove (cdr l) (cons (car l) result)))
 175                          ((or (null? result)
 176                               (equal? "" (car result)))
 177                           (slib:warn 'uri:decode-path cpath1)
 178                           (append (reverse result) l))
 179                          ((null? (cdr l))
 180                           (reverse (cons "" (cdr result))))
 181                          (else (remove (cdr l) (cdr result)))))))
 182            cpath2))
 183         (else path-list)))
 184
 185 (define (uri:decode-authority authority)
 186   (define idx-at (string-index authority #\@))
 187   (let* ((userinfo (and idx-at (uric:decode (substring authority 0 idx-at))))
 188          (hostport
 189           (if idx-at
 190               (substring authority (+ 1 idx-at) (string-length authority))
 191               authority))
 192          (idx-: (string-index hostport #\:))
 193          (host (if idx-: (substring hostport 0 idx-:) hostport))
 194          (port (and idx-:
 195                     (substring hostport (+ 1 idx-:) (string-length hostport)))))
 196     (if (or userinfo port)
 197         (list userinfo host (or (string->number port) port))
 198         host)))
 199
 200 (define uri:split-fields
 201   (let ((cr (integer->char #xd)))
 202     (lambda (txt chr)
 203       (define idx (string-index txt chr))
 204       (if idx
 205           (cons (substring txt 0
 206                            (if (and (positive? idx)
 207                                     (char=? cr (string-ref txt (+ -1 idx))))
 208                                (+ -1 idx)
 209                                idx))
 210                 (uri:split-fields (substring txt (+ 1 idx) (string-length txt))
 211                                   chr))
 212           (list txt)))))
 213
 214 ;; @body Converts a @dfn{URI} encoded @1 to a query-alist.
 215 (define (uri:decode-query query-string)
 216   (set! query-string (string-subst query-string " " "" "+" " "))
 217   (do ((lst '())
 218        (edx (string-index query-string #\=)
 219             (string-index query-string #\=)))
 220       ((not edx) lst)
 221     (let* ((rxt (substring query-string (+ 1 edx) (string-length query-string)))
 222            (adx (string-index rxt #\&))
 223            (urid (uric:decode
 224                   (substring rxt 0 (or adx (string-length rxt)))))
 225            (name (string-ci->symbol
 226                   (uric:decode (substring query-string 0 edx)))))
 227       (set! lst (append lst (if (equal? "" urid)
 228                                 '()
 229                                 (map (lambda (value) (list name value))
 230                                      (uri:split-fields urid #\newline)))))
 231       (set! query-string
 232             (if adx (substring rxt (+ 1 adx) (string-length rxt)) "")))))
 233
 234 (define (uri:split uri-reference)
 235   (define len (string-length uri-reference))
 236   (define idx-sharp (string-index uri-reference #\#))
 237   (let ((fragment (and idx-sharp
 238                        (substring uri-reference (+ 1 idx-sharp) len)))
 239         (uri (if idx-sharp
 240                  (and (not (zero? idx-sharp))
 241                       (substring uri-reference 0 idx-sharp))
 242                  uri-reference)))
 243     (if uri
 244         (let* ((len (string-length uri))
 245                (idx-? (string-index uri #\?))
 246                (query (and idx-? (substring uri (+ 1 idx-?) len)))
 247                (front (if idx-?
 248                           (and (not (zero? idx-?)) (substring uri 0 idx-?))
 249                           uri)))
 250           (if front
 251               (let* ((len (string-length front))
 252                      (idx-: (string-index front #\:))
 253                      (scheme (and idx-: (substring front 0 idx-:)))
 254                      (path (if idx-:
 255                                (substring front (+ 1 idx-:) len)
 256                                front)))
 257                 (cond ((eqv? 0 (substring? "//" path))
 258                        (set! len (string-length path))
 259                        (set! path (substring path 2 len))
 260                        (set! len (+ -2 len))
 261                        (let* ((idx-/ (string-index path #\/))
 262                               (authority (substring path 0 (or idx-/ len)))
 263                               (path (if idx-/
 264                                         (substring path idx-/ len)
 265                                         "")))
 266                          (list scheme authority path query fragment)))
 267                       (else (list scheme #f path query fragment))))
 268               (list #f #f "" query fragment)))
 269         (list #f #f "" #f fragment))))
 270
 271 ;;@
 272 ;;@noindent @code{uric:} prefixes indicate procedures dealing with
 273 ;;URI-components.
 274
 275 ;;@body Returns a copy of the string @1 in which all @dfn{unsafe} octets
 276 ;;(as defined in RFC 2396) have been @samp{%} @dfn{escaped}.
 277 ;;@code{uric:decode} decodes strings encoded by @0.
 278 (define (uric:encode uri-component allows)
 279   (set! uri-component (sprintf #f "%a" uri-component))
 280   (apply string-append
 281          (map (lambda (chr)
 282                 (if (or (char-alphabetic? chr)
 283                         (char-numeric? chr)
 284                         (string-index "-_.!~*'()" chr)
 285                         (string-index allows chr))
 286                     (string chr)
 287                     (let ((code (char->integer chr)))
 288                       (sprintf #f "%%%02x" code))))
 289               (string->list uri-component))))
 290
 291 ;;@body Returns a copy of the string @1 in which each @samp{%} escaped
 292 ;;characters in @1 is replaced with the character it encodes.  This
 293 ;;routine is useful for showing URI contents on error pages.
 294 (define (uric:decode uri-component)
 295   (define len (string-length uri-component))
 296   (define (sub uri)
 297     (cond
 298      ((string-index uri #\%)
 299       => (lambda (idx)
 300            (if (and (< (+ 2 idx) len)
 301                     (string->number (substring uri (+ 1 idx) (+ 2 idx)) 16)
 302                     (string->number (substring uri (+ 2 idx) (+ 3 idx)) 16))
 303                (string-append
 304                 (substring uri 0 idx)
 305                 (string (integer->char
 306                          (string->number
 307                           (substring uri (+ 1 idx) (+ 3 idx))
 308                           16)))
 309                 (sub (substring uri (+ 3 idx) (string-length uri)))))))
 310      (else uri)))
 311   (sub uri-component))
 312
 313 (define (uri:path->keys path-list ptypes)
 314   (and (not (null? path-list))
 315        (not (equal? '("") path-list))
 316        (let ((path (uri:decode-path (map uric:decode path-list) #f)))
 317          (and (= (length path) (length ptypes))
 318               (map coerce path ptypes)))))