1 ;;;; (web uri) --- URI manipulation tools
3 ;;;; Copyright (C) 1997,2001,2002,2010,2011,2012,2013,2014 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
41 string->uri string->uri-reference
44 split-and-decode-uri-path
45 encode-and-join-uri-path))
47 (define-record-type <uri>
48 (make-uri scheme userinfo host port path query fragment)
51 (userinfo uri-userinfo)
56 (fragment uri-fragment))
58 (define (absolute-uri? obj)
59 (and (uri? obj) (uri-scheme obj) #t))
61 (define (uri-error message . args)
62 (throw 'uri-error message args))
64 (define (positive-exact-integer? port)
65 (and (number? port) (exact? port) (integer? port) (positive? port)))
67 (define* (validate-uri scheme userinfo host port path query fragment
70 ((and (not reference?) (not (symbol? scheme)))
71 (uri-error "Expected a symbol for the URI scheme: ~s" scheme))
72 ((and (or userinfo port) (not host))
73 (uri-error "Expected a host, given userinfo or port"))
74 ((and port (not (positive-exact-integer? port)))
75 (uri-error "Expected port to be an integer: ~s" port))
76 ((and host (or (not (string? host)) (not (valid-host? host))))
77 (uri-error "Expected valid host: ~s" host))
78 ((and userinfo (not (string? userinfo)))
79 (uri-error "Expected string for userinfo: ~s" userinfo))
81 (uri-error "Expected string for path: ~s" path))
82 ((and host (not (string-null? path))
83 (not (eqv? (string-ref path 0) #\/)))
84 (uri-error "Expected path of absolute URI to start with a /: ~a" path))))
86 (define* (build-uri scheme #:key userinfo host port (path "") query fragment
88 "Construct a URI object. SCHEME should be a symbol, PORT either a
89 positive, exact integer or ‘#f’, and the rest of the fields are either
90 strings or ‘#f’. If VALIDATE? is true, also run some consistency checks
91 to make sure that the constructed object is a valid absolute URI."
93 (validate-uri scheme userinfo host port path query fragment))
94 (make-uri scheme userinfo host port path query fragment))
96 (define* (build-uri-reference #:key scheme userinfo host port (path "") query
97 fragment (validate? #t))
98 "Construct a URI object. SCHEME should be a symbol or ‘#f’, PORT
99 either a positive, exact integer or ‘#f’, and the rest of the fields
100 are either strings or ‘#f’. If VALIDATE? is true, also run some
101 consistency checks to make sure that the constructed URI is a valid URI
102 reference (either an absolute URI or a relative reference)."
104 (validate-uri scheme userinfo host port path query fragment
106 (make-uri scheme userinfo host port path query fragment))
108 ;; See RFC 3986 #3.2.2 for comments on percent-encodings, IDNA (RFC
109 ;; 3490), and non-ASCII host names.
112 (make-regexp "^([0-9.]+)$"))
114 (make-regexp "^([0-9a-fA-F:.]+)$"))
115 (define domain-label-regexp
116 (make-regexp "^[a-zA-Z0-9]([a-zA-Z0-9-]*[a-zA-Z0-9])?$"))
117 (define top-label-regexp
118 (make-regexp "^[a-zA-Z]([a-zA-Z0-9-]*[a-zA-Z0-9])?$"))
120 (define (valid-host? host)
122 ((regexp-exec ipv4-regexp host)
123 (false-if-exception (inet-pton AF_INET host)))
124 ((regexp-exec ipv6-regexp host)
125 (false-if-exception (inet-pton AF_INET6 host)))
128 (let ((end (string-index host #\. start)))
130 (and (regexp-exec domain-label-regexp
131 (substring host start end))
133 (regexp-exec top-label-regexp host start)))))))
136 "[a-zA-Z0-9_.!~*'();:&=+$,-]+")
139 (define ipv6-host-pat
143 (define authority-regexp
145 (format #f "^//((~a)@)?((~a)|(\\[(~a)\\]))(:(~a))?$"
146 userinfo-pat host-pat ipv6-host-pat port-pat)))
148 (define (parse-authority authority fail)
149 (if (equal? authority "//")
150 ;; Allow empty authorities: file:///etc/hosts is a synonym of
153 (let ((m (regexp-exec authority-regexp authority)))
154 (if (and m (valid-host? (or (match:substring m 4)
155 (match:substring m 6))))
156 (values (match:substring m 2)
157 (or (match:substring m 4)
158 (match:substring m 6))
159 (let ((port (match:substring m 8)))
160 (and port (not (string-null? port))
161 (string->number port))))
167 ;;; URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ]
169 ;;; hier-part = "//" authority path-abempty
174 ;;; A URI-reference is the same as URI, but where the scheme is
175 ;;; optional. If the scheme is not present, its colon isn't present
179 "[a-zA-Z][a-zA-Z0-9+.-]*")
180 (define authority-pat
189 (format #f "^((~a):)?(//~a)?(~a)(\\?(~a))?(#(~a))?$"
190 scheme-pat authority-pat path-pat query-pat fragment-pat))
192 (make-regexp uri-pat))
194 (define (string->uri-reference string)
195 "Parse the URI reference written as STRING into a URI object. Return
196 ‘#f’ if the string could not be parsed."
197 (% (let ((m (regexp-exec uri-regexp string)))
199 (let ((scheme (let ((str (match:substring m 2)))
200 (and str (string->symbol (string-downcase str)))))
201 (authority (match:substring m 3))
202 (path (match:substring m 4))
203 (query (match:substring m 6))
204 (fragment (match:substring m 8)))
208 (parse-authority authority abort)
210 (lambda (userinfo host port)
211 (make-uri scheme userinfo host port path query fragment)))))
215 (define (string->uri string)
216 "Parse STRING into an absolute URI object. Return ‘#f’ if the string
217 could not be parsed."
218 (let ((uri (string->uri-reference string)))
219 (and uri (uri-scheme uri) uri)))
221 (define *default-ports* (make-hash-table))
223 (define (declare-default-port! scheme port)
224 "Declare a default port for the given URI scheme."
225 (hashq-set! *default-ports* scheme port))
227 (define (default-port? scheme port)
229 (eqv? port (hashq-ref *default-ports* scheme))))
231 (declare-default-port! 'http 80)
232 (declare-default-port! 'https 443)
234 (define (uri->string uri)
235 "Serialize URI to a string. If the URI has a port that is the
236 default port for its scheme, the port is not included in the
238 (let* ((scheme (uri-scheme uri))
239 (userinfo (uri-userinfo uri))
240 (host (uri-host uri))
241 (port (uri-port uri))
242 (path (uri-path uri))
243 (query (uri-query uri))
244 (fragment (uri-fragment uri)))
247 (string-append (symbol->string scheme) ":")
251 (if userinfo (string-append userinfo "@")
253 (if (string-index host #\:)
254 (string-append "[" host "]")
256 (if (default-port? (uri-scheme uri) port)
258 (string-append ":" (number->string port))))
262 (string-append "?" query)
265 (string-append "#" fragment)
269 ;; like call-with-output-string, but actually closes the port (doh)
270 (define (call-with-output-string* proc)
271 (let ((port (open-output-string)))
273 (let ((str (get-output-string port)))
277 (define (call-with-output-bytevector* proc)
280 (open-bytevector-output-port))
281 (lambda (port get-bytevector)
283 (let ((bv (get-bytevector)))
287 (define (call-with-encoded-output-string encoding proc)
288 (if (string-ci=? encoding "utf-8")
289 (string->utf8 (call-with-output-string* proc))
290 (call-with-output-bytevector*
292 (set-port-encoding! port encoding)
295 (define (encode-string str encoding)
296 (if (string-ci=? encoding "utf-8")
298 (call-with-encoded-output-string encoding
300 (display str port)))))
302 (define (decode-string bv encoding)
303 (if (string-ci=? encoding "utf-8")
305 (let ((p (open-bytevector-input-port bv)))
306 (set-port-encoding! p encoding)
307 (let ((res (read-string p)))
312 ;; A note on characters and bytes: URIs are defined to be sequences of
313 ;; characters in a subset of ASCII. Those characters may encode a
314 ;; sequence of bytes (octets), which in turn may encode sequences of
315 ;; characters in other character sets.
318 ;; Return a new string made from uri-decoding STR. Specifically,
319 ;; turn ‘+’ into space, and hex-encoded ‘%XX’ strings into
320 ;; their eight-bit characters.
323 (string->char-set "0123456789abcdefABCDEF"))
325 (define* (uri-decode str #:key (encoding "utf-8"))
326 "Percent-decode the given STR, according to ENCODING,
327 which should be the name of a character encoding.
329 Note that this function should not generally be applied to a full URI
330 string. For paths, use ‘split-and-decode-uri-path’ instead. For query
331 strings, split the query on ‘&’ and ‘=’ boundaries, and decode
332 the components separately.
334 Note also that percent-encoded strings encode _bytes_, not characters.
335 There is no guarantee that a given byte sequence is a valid string
336 encoding. Therefore this routine may signal an error if the decoded
337 bytes are not valid for the given encoding. Pass ‘#f’ for ENCODING if
338 you want decoded bytes as a bytevector directly. ‘set-port-encoding!’,
339 for more information on character encodings.
341 Returns a string of the decoded characters, or a bytevector if
343 (let* ((len (string-length str))
345 (call-with-output-bytevector*
349 (let ((ch (string-ref str i)))
352 (put-u8 port (char->integer #\space))
354 ((and (< (+ i 2) len) (eqv? ch #\%)
355 (let ((a (string-ref str (+ i 1)))
356 (b (string-ref str (+ i 2))))
357 (and (char-set-contains? hex-chars a)
358 (char-set-contains? hex-chars b)
359 (string->number (string a b) 16))))
363 ((< (char->integer ch) 128)
364 (put-u8 port (char->integer ch))
367 (uri-error "Invalid character in encoded URI ~a: ~s"
370 (decode-string bv encoding)
371 ;; Otherwise return raw bytevector
374 (define ascii-alnum-chars
376 "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"))
380 (string->char-set ":/?#[]@"))
382 (string->char-set "!$&'()*+,l="))
383 (define reserved-chars
384 (char-set-union gen-delims sub-delims))
387 (define unreserved-chars
388 (char-set-union ascii-alnum-chars
389 (string->char-set "-._~")))
391 ;; Return a new string made from uri-encoding STR, unconditionally
392 ;; transforming any characters not in UNESCAPED-CHARS.
394 (define* (uri-encode str #:key (encoding "utf-8")
395 (unescaped-chars unreserved-chars))
396 "Percent-encode any character not in the character set,
399 The default character set includes alphanumerics from ASCII, as well as
400 the special characters ‘-’, ‘.’, ‘_’, and ‘~’. Any other character will
401 be percent-encoded, by writing out the character to a bytevector within
402 the given ENCODING, then encoding each byte as ‘%HH’, where HH is the
403 uppercase hexadecimal representation of the byte."
404 (define (needs-escaped? ch)
405 (not (char-set-contains? unescaped-chars ch)))
406 (if (string-index str needs-escaped?)
407 (call-with-output-string*
411 (if (char-set-contains? unescaped-chars ch)
413 (let* ((bv (encode-string (string ch) encoding))
414 (len (bytevector-length bv)))
417 (let ((byte (bytevector-u8-ref bv i)))
421 (display (string-upcase (number->string byte 16))
427 (define (split-and-decode-uri-path path)
428 "Split PATH into its components, and decode each component,
429 removing empty components.
431 For example, ‘\"/foo/bar%20baz/\"’ decodes to the two-element list,
432 ‘(\"foo\" \"bar baz\")’."
433 (filter (lambda (x) (not (string-null? x)))
434 (map uri-decode (string-split path #\/))))
436 (define (encode-and-join-uri-path parts)
437 "URI-encode each element of PARTS, which should be a list of
438 strings, and join the parts together with ‘/’ as a delimiter.
440 For example, the list ‘(\"scrambled eggs\" \"biscuits&gravy\")’
441 encodes as ‘\"scrambled%20eggs/biscuits%26gravy\"’."
442 (string-join (map uri-encode parts) "/"))