1 ;;;; (web uri) --- URI manipulation tools
3 ;;;; Copyright (C) 1997,2001,2002,2010,2011,2012,2013 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
22 ;; A data type for Universal Resource Identifiers, as defined in RFC
27 (define-module (web uri)
28 #:use-module (srfi srfi-9)
29 #:use-module (ice-9 regex)
30 #:use-module (ice-9 rdelim)
31 #:use-module (ice-9 control)
32 #:use-module (rnrs bytevectors)
33 #:use-module (ice-9 binary-ports)
35 uri-scheme uri-userinfo uri-host uri-port
36 uri-path uri-query uri-fragment
40 string->uri uri->string
42 split-and-decode-uri-path
43 encode-and-join-uri-path))
45 (define-record-type <uri>
46 (make-uri scheme userinfo host port path query fragment)
49 (userinfo uri-userinfo)
54 (fragment uri-fragment))
56 (define (absolute-uri? obj)
57 (and (uri? obj) (uri-scheme obj) #t))
59 (define (uri-error message . args)
60 (throw 'uri-error message args))
62 (define (positive-exact-integer? port)
63 (and (number? port) (exact? port) (integer? port) (positive? port)))
65 (define (validate-uri scheme userinfo host port path query fragment)
67 ((not (symbol? scheme))
68 (uri-error "Expected a symbol for the URI scheme: ~s" scheme))
69 ((and (or userinfo port) (not host))
70 (uri-error "Expected a host, given userinfo or port"))
71 ((and port (not (positive-exact-integer? port)))
72 (uri-error "Expected port to be an integer: ~s" port))
73 ((and host (or (not (string? host)) (not (valid-host? host))))
74 (uri-error "Expected valid host: ~s" host))
75 ((and userinfo (not (string? userinfo)))
76 (uri-error "Expected string for userinfo: ~s" userinfo))
78 (uri-error "Expected string for path: ~s" path))
79 ((and host (not (string-null? path))
80 (not (eqv? (string-ref path 0) #\/)))
81 (uri-error "Expected path of absolute URI to start with a /: ~a" path))))
83 (define* (build-uri scheme #:key userinfo host port (path "") query fragment
85 "Construct a URI object. SCHEME should be a symbol, PORT
86 either a positive, exact integer or ‘#f’, and the rest of the
87 fields are either strings or ‘#f’. If VALIDATE? is true,
88 also run some consistency checks to make sure that the constructed URI
91 (validate-uri scheme userinfo host port path query fragment))
92 (make-uri scheme userinfo host port path query fragment))
94 ;; See RFC 3986 #3.2.2 for comments on percent-encodings, IDNA (RFC
95 ;; 3490), and non-ASCII host names.
98 (make-regexp "^([0-9.]+)$"))
100 (make-regexp "^([0-9a-fA-F:.]+)$"))
101 (define domain-label-regexp
102 (make-regexp "^[a-zA-Z0-9]([a-zA-Z0-9-]*[a-zA-Z0-9])?$"))
103 (define top-label-regexp
104 (make-regexp "^[a-zA-Z]([a-zA-Z0-9-]*[a-zA-Z0-9])?$"))
106 (define (valid-host? host)
108 ((regexp-exec ipv4-regexp host)
109 (false-if-exception (inet-pton AF_INET host)))
110 ((regexp-exec ipv6-regexp host)
111 (false-if-exception (inet-pton AF_INET6 host)))
114 (let ((end (string-index host #\. start)))
116 (and (regexp-exec domain-label-regexp
117 (substring host start end))
119 (regexp-exec top-label-regexp host start)))))))
122 "[a-zA-Z0-9_.!~*'();:&=+$,-]+")
125 (define ipv6-host-pat
129 (define authority-regexp
131 (format #f "^//((~a)@)?((~a)|(\\[(~a)\\]))(:(~a))?$"
132 userinfo-pat host-pat ipv6-host-pat port-pat)))
134 (define (parse-authority authority fail)
135 (if (equal? authority "//")
136 ;; Allow empty authorities: file:///etc/hosts is a synonym of
139 (let ((m (regexp-exec authority-regexp authority)))
140 (if (and m (valid-host? (or (match:substring m 4)
141 (match:substring m 6))))
142 (values (match:substring m 2)
143 (or (match:substring m 4)
144 (match:substring m 6))
145 (let ((port (match:substring m 8)))
146 (and port (not (string-null? port))
147 (string->number port))))
153 ;;; URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ]
155 ;;; hier-part = "//" authority path-abempty
161 "[a-zA-Z][a-zA-Z0-9+.-]*")
162 (define authority-pat
171 (format #f "^((~a):)?(//~a)?(~a)(\\?(~a))?(#(~a))?$"
172 scheme-pat authority-pat path-pat query-pat fragment-pat))
174 (make-regexp uri-pat))
176 (define (string->uri* string)
177 "Parse STRING into a URI object. Return ‘#f’ if the string
178 could not be parsed."
179 (% (let ((m (regexp-exec uri-regexp string)))
181 (let ((scheme (let ((str (match:substring m 2)))
182 (and str (string->symbol (string-downcase str)))))
183 (authority (match:substring m 3))
184 (path (match:substring m 4))
185 (query (match:substring m 6))
186 (fragment (match:substring m 7)))
190 (parse-authority authority abort)
192 (lambda (userinfo host port)
193 (make-uri scheme userinfo host port path query fragment)))))
197 (define (string->uri string)
198 "Parse STRING into a URI object. Return ‘#f’ if the string
199 could not be parsed."
200 (let ((uri (string->uri* string)))
201 (and uri (uri-scheme uri) uri)))
203 (define *default-ports* (make-hash-table))
205 (define (declare-default-port! scheme port)
206 "Declare a default port for the given URI scheme."
207 (hashq-set! *default-ports* scheme port))
209 (define (default-port? scheme port)
211 (eqv? port (hashq-ref *default-ports* scheme))))
213 (declare-default-port! 'http 80)
214 (declare-default-port! 'https 443)
216 (define (uri->string uri)
217 "Serialize URI to a string. If the URI has a port that is the
218 default port for its scheme, the port is not included in the
220 (let* ((scheme (uri-scheme uri))
221 (userinfo (uri-userinfo uri))
222 (host (uri-host uri))
223 (port (uri-port uri))
224 (path (uri-path uri))
225 (query (uri-query uri))
226 (fragment (uri-fragment uri)))
229 (string-append (symbol->string scheme) ":")
233 (if userinfo (string-append userinfo "@")
235 (if (string-index host #\:)
236 (string-append "[" host "]")
238 (if (default-port? (uri-scheme uri) port)
240 (string-append ":" (number->string port))))
244 (string-append "?" query)
247 (string-append "#" fragment)
251 ;; like call-with-output-string, but actually closes the port (doh)
252 (define (call-with-output-string* proc)
253 (let ((port (open-output-string)))
255 (let ((str (get-output-string port)))
259 (define (call-with-output-bytevector* proc)
262 (open-bytevector-output-port))
263 (lambda (port get-bytevector)
265 (let ((bv (get-bytevector)))
269 (define (call-with-encoded-output-string encoding proc)
270 (if (string-ci=? encoding "utf-8")
271 (string->utf8 (call-with-output-string* proc))
272 (call-with-output-bytevector*
274 (set-port-encoding! port encoding)
277 (define (encode-string str encoding)
278 (if (string-ci=? encoding "utf-8")
280 (call-with-encoded-output-string encoding
282 (display str port)))))
284 (define (decode-string bv encoding)
285 (if (string-ci=? encoding "utf-8")
287 (let ((p (open-bytevector-input-port bv)))
288 (set-port-encoding! p encoding)
289 (let ((res (read-string p)))
294 ;; A note on characters and bytes: URIs are defined to be sequences of
295 ;; characters in a subset of ASCII. Those characters may encode a
296 ;; sequence of bytes (octets), which in turn may encode sequences of
297 ;; characters in other character sets.
300 ;; Return a new string made from uri-decoding STR. Specifically,
301 ;; turn ‘+’ into space, and hex-encoded ‘%XX’ strings into
302 ;; their eight-bit characters.
305 (string->char-set "0123456789abcdefABCDEF"))
307 (define* (uri-decode str #:key (encoding "utf-8"))
308 "Percent-decode the given STR, according to ENCODING,
309 which should be the name of a character encoding.
311 Note that this function should not generally be applied to a full URI
312 string. For paths, use ‘split-and-decode-uri-path’ instead. For query
313 strings, split the query on ‘&’ and ‘=’ boundaries, and decode
314 the components separately.
316 Note also that percent-encoded strings encode _bytes_, not characters.
317 There is no guarantee that a given byte sequence is a valid string
318 encoding. Therefore this routine may signal an error if the decoded
319 bytes are not valid for the given encoding. Pass ‘#f’ for ENCODING if
320 you want decoded bytes as a bytevector directly. ‘set-port-encoding!’,
321 for more information on character encodings.
323 Returns a string of the decoded characters, or a bytevector if
325 (let* ((len (string-length str))
327 (call-with-output-bytevector*
331 (let ((ch (string-ref str i)))
334 (put-u8 port (char->integer #\space))
336 ((and (< (+ i 2) len) (eqv? ch #\%)
337 (let ((a (string-ref str (+ i 1)))
338 (b (string-ref str (+ i 2))))
339 (and (char-set-contains? hex-chars a)
340 (char-set-contains? hex-chars b)
341 (string->number (string a b) 16))))
345 ((< (char->integer ch) 128)
346 (put-u8 port (char->integer ch))
349 (uri-error "Invalid character in encoded URI ~a: ~s"
352 (decode-string bv encoding)
353 ;; Otherwise return raw bytevector
356 (define ascii-alnum-chars
358 "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"))
362 (string->char-set ":/?#[]@"))
364 (string->char-set "!$&'()*+,l="))
365 (define reserved-chars
366 (char-set-union gen-delims sub-delims))
369 (define unreserved-chars
370 (char-set-union ascii-alnum-chars
371 (string->char-set "-._~")))
373 ;; Return a new string made from uri-encoding STR, unconditionally
374 ;; transforming any characters not in UNESCAPED-CHARS.
376 (define* (uri-encode str #:key (encoding "utf-8")
377 (unescaped-chars unreserved-chars))
378 "Percent-encode any character not in the character set,
381 The default character set includes alphanumerics from ASCII, as well as
382 the special characters ‘-’, ‘.’, ‘_’, and ‘~’. Any other character will
383 be percent-encoded, by writing out the character to a bytevector within
384 the given ENCODING, then encoding each byte as ‘%HH’, where HH is the
385 uppercase hexadecimal representation of the byte."
386 (define (needs-escaped? ch)
387 (not (char-set-contains? unescaped-chars ch)))
388 (if (string-index str needs-escaped?)
389 (call-with-output-string*
393 (if (char-set-contains? unescaped-chars ch)
395 (let* ((bv (encode-string (string ch) encoding))
396 (len (bytevector-length bv)))
399 (let ((byte (bytevector-u8-ref bv i)))
403 (display (string-upcase (number->string byte 16))
409 (define (split-and-decode-uri-path path)
410 "Split PATH into its components, and decode each component,
411 removing empty components.
413 For example, ‘\"/foo/bar%20baz/\"’ decodes to the two-element list,
414 ‘(\"foo\" \"bar baz\")’."
415 (filter (lambda (x) (not (string-null? x)))
416 (map uri-decode (string-split path #\/))))
418 (define (encode-and-join-uri-path parts)
419 "URI-encode each element of PARTS, which should be a list of
420 strings, and join the parts together with ‘/’ as a delimiter.
422 For example, the list ‘(\"scrambled eggs\" \"biscuits&gravy\")’
423 encodes as ‘\"scrambled%20eggs/biscuits%26gravy\"’."
424 (string-join (map uri-encode parts) "/"))