Commit | Line | Data |
---|---|---|
440840c1 AW |
1 | ;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*- |
2 | ;;;; | |
6f4cc6a3 | 3 | ;;;; Copyright (C) 2010, 2011, 2014 Free Software Foundation, Inc. |
440840c1 AW |
4 | ;;;; |
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. | |
9 | ;;;; | |
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. | |
14 | ;;;; | |
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 | |
18 | ||
19 | ||
20 | (define-module (test-suite web-http) | |
21 | #:use-module (web uri) | |
22 | #:use-module (web http) | |
312e79f8 | 23 | #:use-module (rnrs io ports) |
440840c1 AW |
24 | #:use-module (ice-9 regex) |
25 | #:use-module (ice-9 control) | |
26 | #:use-module (srfi srfi-19) | |
27 | #:use-module (test-suite lib)) | |
28 | ||
29 | ||
30 | (define-syntax pass-if-named-exception | |
31 | (syntax-rules () | |
32 | ((_ name k pat exp) | |
33 | (pass-if name | |
34 | (catch 'k | |
35 | (lambda () exp (error "expected exception" 'k)) | |
36 | (lambda (k message args) | |
37 | (if (string-match pat message) | |
38 | #t | |
39 | (error "unexpected exception" message args)))))))) | |
40 | ||
41 | (define-syntax pass-if-parse | |
42 | (syntax-rules () | |
43 | ((_ sym str val) | |
44 | (pass-if (format #f "~a: ~s -> ~s" 'sym str val) | |
4855c634 DH |
45 | (and (equal? (parse-header 'sym str) |
46 | val) | |
47 | (valid-header? 'sym val)))))) | |
440840c1 | 48 | |
61fe8eaf AW |
49 | (define-syntax pass-if-round-trip |
50 | (syntax-rules () | |
51 | ((_ str) | |
d0d8c872 MW |
52 | (pass-if-equal (format #f "~s round trip" str) |
53 | str | |
54 | (call-with-output-string | |
55 | (lambda (port) | |
56 | (call-with-values | |
57 | (lambda () (read-header (open-input-string str))) | |
58 | (lambda (sym val) | |
59 | (write-header sym val port))))))))) | |
61fe8eaf | 60 | |
440840c1 AW |
61 | (define-syntax pass-if-any-error |
62 | (syntax-rules () | |
63 | ((_ sym str) | |
64 | (pass-if (format #f "~a: ~s -> any error" 'sym str) | |
65 | (% (catch #t | |
66 | (lambda () | |
be1be3e5 | 67 | (parse-header 'sym str) |
440840c1 AW |
68 | (abort (lambda () (error "expected exception")))) |
69 | (lambda (k . args) | |
70 | #t)) | |
71 | (lambda (k thunk) | |
72 | (thunk))))))) | |
73 | ||
74 | (define-syntax pass-if-parse-error | |
75 | (syntax-rules () | |
76 | ((_ sym str expected-component) | |
77 | (pass-if (format #f "~a: ~s -> ~a error" 'sym str 'expected-component) | |
78 | (catch 'bad-header | |
79 | (lambda () | |
be1be3e5 | 80 | (parse-header 'sym str) |
440840c1 AW |
81 | (error "expected exception" 'expected-component)) |
82 | (lambda (k component arg) | |
83 | (if (or (not 'expected-component) | |
84 | (eq? 'expected-component component)) | |
85 | #t | |
86 | (error "unexpected exception" component arg)))))))) | |
87 | ||
2e08ff38 DH |
88 | (define-syntax pass-if-read-request-line |
89 | (syntax-rules () | |
90 | ((_ str expected-method expected-uri expected-version) | |
91 | (pass-if str | |
92 | (equal? (call-with-values | |
93 | (lambda () | |
94 | (read-request-line (open-input-string | |
95 | (string-append str "\r\n")))) | |
96 | list) | |
97 | (list 'expected-method | |
98 | expected-uri | |
99 | 'expected-version)))))) | |
100 | ||
101 | (define-syntax pass-if-write-request-line | |
102 | (syntax-rules () | |
103 | ((_ expected-str method uri version) | |
104 | (pass-if expected-str | |
105 | (equal? (string-append expected-str "\r\n") | |
106 | (call-with-output-string | |
107 | (lambda (port) | |
108 | (write-request-line 'method uri 'version port)))))))) | |
109 | ||
110 | (define-syntax pass-if-read-response-line | |
111 | (syntax-rules () | |
112 | ((_ str expected-version expected-code expected-phrase) | |
113 | (pass-if str | |
114 | (equal? (call-with-values | |
115 | (lambda () | |
116 | (read-response-line (open-input-string | |
117 | (string-append str "\r\n")))) | |
118 | list) | |
119 | (list 'expected-version | |
120 | expected-code | |
121 | expected-phrase)))))) | |
122 | ||
123 | (define-syntax pass-if-write-response-line | |
124 | (syntax-rules () | |
125 | ((_ expected-str version code phrase) | |
126 | (pass-if expected-str | |
127 | (equal? (string-append expected-str "\r\n") | |
128 | (call-with-output-string | |
129 | (lambda (port) | |
130 | (write-response-line 'version code phrase port)))))))) | |
131 | ||
132 | (with-test-prefix "read-request-line" | |
133 | (pass-if-read-request-line "GET / HTTP/1.1" | |
134 | GET | |
135 | (build-uri 'http | |
136 | #:path "/") | |
137 | (1 . 1)) | |
138 | (pass-if-read-request-line "GET http://www.w3.org/pub/WWW/TheProject.html HTTP/1.1" | |
139 | GET | |
140 | (build-uri 'http | |
141 | #:host "www.w3.org" | |
142 | #:path "/pub/WWW/TheProject.html") | |
143 | (1 . 1)) | |
144 | (pass-if-read-request-line "GET /pub/WWW/TheProject.html HTTP/1.1" | |
145 | GET | |
146 | (build-uri 'http | |
147 | #:path "/pub/WWW/TheProject.html") | |
148 | (1 . 1)) | |
149 | (pass-if-read-request-line "HEAD /etc/hosts?foo=bar HTTP/1.1" | |
150 | HEAD | |
151 | (build-uri 'http | |
152 | #:path "/etc/hosts" | |
153 | #:query "foo=bar") | |
154 | (1 . 1))) | |
155 | ||
156 | (with-test-prefix "write-request-line" | |
157 | (pass-if-write-request-line "GET / HTTP/1.1" | |
158 | GET | |
159 | (build-uri 'http | |
160 | #:path "/") | |
161 | (1 . 1)) | |
162 | ;;; FIXME: Test fails due to scheme, host always being removed. | |
163 | ;;; However, it should be supported to request these be present, and | |
164 | ;;; that is possible with absolute/relative URI support. | |
165 | ;; (pass-if-write-request-line "GET http://www.w3.org/pub/WWW/TheProject.html HTTP/1.1" | |
166 | ;; GET | |
167 | ;; (build-uri 'http | |
168 | ;; #:host "www.w3.org" | |
169 | ;; #:path "/pub/WWW/TheProject.html") | |
170 | ;; (1 . 1)) | |
171 | (pass-if-write-request-line "GET /pub/WWW/TheProject.html HTTP/1.1" | |
172 | GET | |
173 | (build-uri 'http | |
174 | #:path "/pub/WWW/TheProject.html") | |
175 | (1 . 1)) | |
20d28792 IP |
176 | (pass-if-write-request-line "GET /?foo HTTP/1.1" |
177 | GET | |
178 | (build-uri 'http #:query "foo") | |
179 | (1 . 1)) | |
2e08ff38 DH |
180 | (pass-if-write-request-line "HEAD /etc/hosts?foo=bar HTTP/1.1" |
181 | HEAD | |
182 | (build-uri 'http | |
183 | #:path "/etc/hosts" | |
184 | #:query "foo=bar") | |
185 | (1 . 1))) | |
186 | ||
187 | (with-test-prefix "read-response-line" | |
188 | (pass-if-read-response-line "HTTP/1.0 404 Not Found" | |
189 | (1 . 0) 404 "Not Found") | |
190 | (pass-if-read-response-line "HTTP/1.1 200 OK" | |
191 | (1 . 1) 200 "OK")) | |
192 | ||
193 | (with-test-prefix "write-response-line" | |
194 | (pass-if-write-response-line "HTTP/1.0 404 Not Found" | |
195 | (1 . 0) 404 "Not Found") | |
196 | (pass-if-write-response-line "HTTP/1.1 200 OK" | |
197 | (1 . 1) 200 "OK")) | |
198 | ||
440840c1 AW |
199 | (with-test-prefix "general headers" |
200 | ||
201 | (pass-if-parse cache-control "no-transform" '(no-transform)) | |
0acc595b | 202 | (pass-if-parse cache-control "no-transform,foo" '(no-transform foo)) |
25731543 AW |
203 | (pass-if-parse cache-control "no-cache" '(no-cache)) |
204 | (pass-if-parse cache-control "no-cache=\"Authorization, Date\"" | |
205 | '((no-cache . (authorization date)))) | |
206 | (pass-if-parse cache-control "private=\"Foo\"" | |
be1be3e5 | 207 | '((private . (foo)))) |
440840c1 | 208 | (pass-if-parse cache-control "no-cache,max-age=10" |
25731543 | 209 | '(no-cache (max-age . 10))) |
321770b2 DH |
210 | (pass-if-parse cache-control "max-stale" '(max-stale)) |
211 | (pass-if-parse cache-control "max-stale=10" '((max-stale . 10))) | |
61fe8eaf AW |
212 | (pass-if-round-trip "Cache-Control: acme-cache-extension\r\n") |
213 | (pass-if-round-trip "Cache-Control: acme-cache-extension=20\r\n") | |
214 | (pass-if-round-trip "Cache-Control: acme-cache-extension=100 quux\r\n") | |
215 | (pass-if-round-trip "Cache-Control: acme-cache-extension=\"100, quux\"\r\n") | |
440840c1 | 216 | |
94f16a5b AW |
217 | (pass-if-parse connection "close" '(close)) |
218 | (pass-if-parse connection "Content-Encoding" '(content-encoding)) | |
440840c1 AW |
219 | |
220 | (pass-if-parse date "Tue, 15 Nov 1994 08:12:31 GMT" | |
221 | (string->date "Tue, 15 Nov 1994 08:12:31 +0000" | |
222 | "~a, ~d ~b ~Y ~H:~M:~S ~z")) | |
ffc8eca6 DH |
223 | (pass-if-parse date "Tue, 15 Nov 1994 16:12:31 +0800" |
224 | (string->date "Tue, 15 Nov 1994 08:12:31 +0000" | |
225 | "~a, ~d ~b ~Y ~H:~M:~S ~z")) | |
cb7bcfca IP |
226 | (pass-if-parse date "Wed, 7 Sep 2011 11:25:00 GMT" |
227 | (string->date "Wed, 7 Sep 2011 11:25:00 +0000" | |
228 | "~a,~e ~b ~Y ~H:~M:~S ~z")) | |
440840c1 AW |
229 | (pass-if-parse-error date "Tue, 15 Nov 1994 08:12:31 EST" date) |
230 | (pass-if-any-error date "Tue, 15 Qux 1994 08:12:31 EST") | |
231 | ||
232 | (pass-if-parse pragma "no-cache" '(no-cache)) | |
0acc595b | 233 | (pass-if-parse pragma "no-cache, foo" '(no-cache foo)) |
440840c1 | 234 | |
be1be3e5 AW |
235 | (pass-if-parse trailer "foo, bar" '(foo bar)) |
236 | (pass-if-parse trailer "connection, bar" '(connection bar)) | |
440840c1 | 237 | |
0acc595b | 238 | (pass-if-parse transfer-encoding "foo, chunked" '((foo) (chunked))) |
440840c1 AW |
239 | |
240 | (pass-if-parse upgrade "qux" '("qux")) | |
241 | ||
242 | (pass-if-parse via "xyzzy" '("xyzzy")) | |
243 | ||
244 | (pass-if-parse warning "123 foo \"core breach imminent\"" | |
245 | '((123 "foo" "core breach imminent" #f))) | |
246 | (pass-if-parse | |
247 | warning | |
248 | "123 foo \"core breach imminent\" \"Tue, 15 Nov 1994 08:12:31 GMT\"" | |
249 | `((123 "foo" "core breach imminent" | |
250 | ,(string->date "Tue, 15 Nov 1994 08:12:31 +0000" | |
251 | "~a, ~d ~b ~Y ~H:~M:~S ~z"))))) | |
252 | ||
253 | (with-test-prefix "entity headers" | |
94f16a5b | 254 | (pass-if-parse allow "foo, bar" '(foo bar)) |
6f4cc6a3 AW |
255 | (pass-if-parse content-disposition "form-data; name=\"file\"; filename=\"q.go\"" |
256 | '(form-data (name . "file") (filename . "q.go"))) | |
94f16a5b | 257 | (pass-if-parse content-encoding "qux, baz" '(qux baz)) |
440840c1 AW |
258 | (pass-if-parse content-language "qux, baz" '("qux" "baz")) |
259 | (pass-if-parse content-length "100" 100) | |
260 | (pass-if-parse content-length "0" 0) | |
261 | (pass-if-parse content-length "010" 10) | |
262 | (pass-if-parse content-location "http://foo/" | |
263 | (build-uri 'http #:host "foo" #:path "/")) | |
264 | (pass-if-parse content-range "bytes 10-20/*" '(bytes (10 . 20) *)) | |
265 | (pass-if-parse content-range "bytes */*" '(bytes * *)) | |
266 | (pass-if-parse content-range "bytes */30" '(bytes * 30)) | |
0acc595b AW |
267 | (pass-if-parse content-type "foo/bar" '(foo/bar)) |
268 | (pass-if-parse content-type "foo/bar; baz=qux" '(foo/bar (baz . "qux"))) | |
440840c1 AW |
269 | (pass-if-parse expires "Tue, 15 Nov 1994 08:12:31 GMT" |
270 | (string->date "Tue, 15 Nov 1994 08:12:31 +0000" | |
271 | "~a, ~d ~b ~Y ~H:~M:~S ~z")) | |
272 | (pass-if-parse last-modified "Tue, 15 Nov 1994 08:12:31 GMT" | |
273 | (string->date "Tue, 15 Nov 1994 08:12:31 +0000" | |
274 | "~a, ~d ~b ~Y ~H:~M:~S ~z"))) | |
275 | ||
440840c1 AW |
276 | (with-test-prefix "request headers" |
277 | (pass-if-parse accept "text/*;q=0.3, text/html;q=0.7, text/html;level=1" | |
0acc595b AW |
278 | '((text/* (q . 300)) |
279 | (text/html (q . 700)) | |
280 | (text/html (level . "1")))) | |
440840c1 AW |
281 | (pass-if-parse accept-charset "iso-8859-5, unicode-1-1;q=0.8" |
282 | '((1000 . "iso-8859-5") (800 . "unicode-1-1"))) | |
283 | (pass-if-parse accept-encoding "gzip;q=1.0, identity; q=0.5, *;q=0" | |
284 | '((1000 . "gzip") | |
285 | (500 . "identity") | |
286 | (0 . "*"))) | |
287 | (pass-if-parse accept-language "da, en-gb;q=0.8, en;q=0.7" | |
288 | '((1000 . "da") (800 . "en-gb") (700 . "en"))) | |
9eed1010 AW |
289 | ;; Allow nonstandard .2 to mean 0.2 |
290 | (pass-if-parse accept-language "en-gb;q=.2" '((200 . "en-gb"))) | |
ecfb7167 AW |
291 | (pass-if-parse authorization "Basic foooo" '(basic . "foooo")) |
292 | (pass-if-parse authorization "Digest foooo" '(digest foooo)) | |
293 | (pass-if-parse authorization "Digest foo=bar,baz=qux" | |
294 | '(digest (foo . "bar") (baz . "qux"))) | |
d0d8c872 MW |
295 | (pass-if-round-trip "Authorization: basic foooo\r\n") |
296 | (pass-if-round-trip "Authorization: digest foooo\r\n") | |
297 | (pass-if-round-trip "Authorization: digest foo=bar, baz=qux\r\n") | |
0acc595b | 298 | (pass-if-parse expect "100-continue, foo" '((100-continue) (foo))) |
440840c1 AW |
299 | (pass-if-parse from "foo@bar" "foo@bar") |
300 | (pass-if-parse host "qux" '("qux" . #f)) | |
301 | (pass-if-parse host "qux:80" '("qux" . 80)) | |
b1c46fd3 DH |
302 | (pass-if-parse host "[2001:db8::1]" '("2001:db8::1" . #f)) |
303 | (pass-if-parse host "[2001:db8::1]:80" '("2001:db8::1" . 80)) | |
304 | (pass-if-parse host "[::ffff:192.0.2.1]" '("::ffff:192.0.2.1" . #f)) | |
305 | (pass-if-round-trip "Host: [2001:db8::1]\r\n") | |
440840c1 AW |
306 | (pass-if-parse if-match "\"xyzzy\", W/\"qux\"" |
307 | '(("xyzzy" . #t) ("qux" . #f))) | |
308 | (pass-if-parse if-match "*" '*) | |
309 | (pass-if-parse if-modified-since "Tue, 15 Nov 1994 08:12:31 GMT" | |
310 | (string->date "Tue, 15 Nov 1994 08:12:31 +0000" | |
311 | "~a, ~d ~b ~Y ~H:~M:~S ~z")) | |
312 | (pass-if-parse if-none-match "\"xyzzy\", W/\"qux\"" | |
313 | '(("xyzzy" . #t) ("qux" . #f))) | |
314 | (pass-if-parse if-none-match "*" '*) | |
315 | (pass-if-parse if-range "\"foo\"" '("foo" . #t)) | |
316 | (pass-if-parse if-range "Tue, 15 Nov 1994 08:12:31 GMT" | |
317 | (string->date "Tue, 15 Nov 1994 08:12:31 +0000" | |
318 | "~a, ~d ~b ~Y ~H:~M:~S ~z")) | |
319 | (pass-if-parse if-unmodified-since "Tue, 15 Nov 1994 08:12:31 GMT" | |
320 | (string->date "Tue, 15 Nov 1994 08:12:31 +0000" | |
321 | "~a, ~d ~b ~Y ~H:~M:~S ~z")) | |
322 | (pass-if-parse max-forwards "10" 10) | |
323 | (pass-if-parse max-forwards "00" 0) | |
ecfb7167 AW |
324 | (pass-if-parse proxy-authorization "Basic foooo" '(basic . "foooo")) |
325 | (pass-if-parse proxy-authorization "Digest foooo" '(digest foooo)) | |
326 | (pass-if-parse proxy-authorization "Digest foo=bar,baz=qux" | |
327 | '(digest (foo . "bar") (baz . "qux"))) | |
440840c1 AW |
328 | (pass-if-parse range "bytes=10-20" '(bytes (10 . 20))) |
329 | (pass-if-parse range "bytes=10-" '(bytes (10 . #f))) | |
330 | (pass-if-parse range "bytes=-20" '(bytes (#f . 20))) | |
331 | (pass-if-parse range "bytes=-20,-30" '(bytes (#f . 20) (#f . 30))) | |
332 | (pass-if-parse referer "http://foo/bar?baz" | |
333 | (build-uri 'http #:host "foo" #:path "/bar" #:query "baz")) | |
334 | (pass-if-parse te "trailers" '((trailers))) | |
0acc595b | 335 | (pass-if-parse te "trailers,foo" '((trailers) (foo))) |
440840c1 AW |
336 | (pass-if-parse user-agent "guile" "guile")) |
337 | ||
338 | ||
339 | ;; Response headers | |
340 | ;; | |
341 | (with-test-prefix "response headers" | |
94f16a5b | 342 | (pass-if-parse accept-ranges "foo,bar" '(foo bar)) |
440840c1 AW |
343 | (pass-if-parse age "30" 30) |
344 | (pass-if-parse etag "\"foo\"" '("foo" . #t)) | |
345 | (pass-if-parse etag "W/\"foo\"" '("foo" . #f)) | |
346 | (pass-if-parse location "http://other-place" | |
347 | (build-uri 'http #:host "other-place")) | |
ecfb7167 AW |
348 | (pass-if-parse proxy-authenticate "Basic realm=\"guile\"" |
349 | '((basic (realm . "guile")))) | |
440840c1 AW |
350 | (pass-if-parse retry-after "Tue, 15 Nov 1994 08:12:31 GMT" |
351 | (string->date "Tue, 15 Nov 1994 08:12:31 +0000" | |
352 | "~a, ~d ~b ~Y ~H:~M:~S ~z")) | |
353 | (pass-if-parse retry-after "20" 20) | |
354 | (pass-if-parse server "guile!" "guile!") | |
355 | (pass-if-parse vary "*" '*) | |
be1be3e5 | 356 | (pass-if-parse vary "foo, bar" '(foo bar)) |
ecfb7167 AW |
357 | (pass-if-parse www-authenticate "Basic realm=\"guile\"" |
358 | '((basic (realm . "guile"))))) | |
312e79f8 IP |
359 | |
360 | (with-test-prefix "chunked encoding" | |
361 | (let* ((s "5\r\nFirst\r\nA\r\n line\n Sec\r\n8\r\nond line\r\n0\r\n") | |
362 | (p (make-chunked-input-port (open-input-string s)))) | |
363 | (pass-if (equal? "First line\n Second line" | |
364 | (get-string-all p))) | |
365 | (pass-if (port-eof? (make-chunked-input-port (open-input-string "0\r\n"))))) | |
366 | (pass-if | |
367 | (equal? (call-with-output-string | |
368 | (lambda (out-raw) | |
369 | (let ((out-chunked (make-chunked-output-port out-raw | |
370 | #:keep-alive? #t))) | |
371 | (display "First chunk" out-chunked) | |
372 | (force-output out-chunked) | |
373 | (display "Second chunk" out-chunked) | |
374 | (force-output out-chunked) | |
375 | (display "Third chunk" out-chunked) | |
376 | (close-port out-chunked)))) | |
377 | "b\r\nFirst chunk\r\nc\r\nSecond chunk\r\nb\r\nThird chunk\r\n0\r\n"))) |