Commit | Line | Data |
---|---|---|
9ddacf86 KN |
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))))) |