1;;;; web-http.test --- HTTP library        -*- mode: scheme; coding: utf-8; -*-
2;;;;
3;;;; 	Copyright (C) 2010-2011, 2014-2017 Free Software Foundation, Inc.
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)
23  #:use-module (rnrs bytevectors)
24  #:use-module (rnrs io ports)
25  #:use-module (ice-9 regex)
26  #:use-module (ice-9 control)
27  #:use-module (srfi srfi-19)
28  #:use-module (test-suite lib))
29
30
31(define-syntax pass-if-named-exception
32  (syntax-rules ()
33    ((_ name k pat exp)
34     (pass-if name
35       (catch 'k
36         (lambda () exp (error "expected exception" 'k))
37         (lambda (k message args)
38           (if (string-match pat message)
39               #t
40               (error "unexpected exception" message args))))))))
41
42(define-syntax pass-if-only-parse
43  (syntax-rules ()
44    ((_ sym str val)
45     (pass-if (format #f "~a: ~s -> ~s" 'sym str val)
46       (and (equal? (parse-header 'sym str)
47                    val)
48            (valid-header? 'sym val))))))
49
50(define-syntax-rule (pass-if-reparse sym val)
51  (pass-if-equal (format #f "~a: ~s reparse" 'sym val) val
52    (let ((str (call-with-output-string
53                 (lambda (port)
54                   (write-header 'sym val port)))))
55      (call-with-values (lambda () (read-header (open-input-string str)))
56        (lambda (sym* val*)
57          (unless (eq? 'sym sym*) (error "unexpected header"))
58          val*)))))
59
60(define-syntax pass-if-parse
61  (syntax-rules ()
62    ((_ sym str val)
63     (begin
64       (pass-if-only-parse sym str val)
65       (pass-if-reparse sym val)))))
66
67(define-syntax pass-if-round-trip
68  (syntax-rules ()
69    ((_ str)
70     (pass-if-equal (format #f "~s round trip" str)
71         str
72       (call-with-output-string
73        (lambda (port)
74          (call-with-values
75              (lambda () (read-header (open-input-string str)))
76            (lambda (sym val)
77              (write-header sym val port)))))))))
78
79(define-syntax pass-if-any-error
80  (syntax-rules ()
81    ((_ sym str)
82     (pass-if (format #f "~a: ~s -> any error" 'sym str)
83       (% (catch #t
84            (lambda ()
85              (parse-header 'sym str)
86              (abort (lambda () (error "expected exception"))))
87            (lambda (k . args)
88              #t))
89          (lambda (k thunk)
90            (thunk)))))))
91
92(define-syntax pass-if-parse-error
93  (syntax-rules ()
94    ((_ sym str expected-component)
95     (pass-if (format #f "~a: ~s -> ~a error" 'sym str 'expected-component)
96       (catch 'bad-header
97         (lambda ()
98           (parse-header 'sym str)
99           (error "expected exception" 'expected-component))
100         (lambda (k component arg)
101           (if (or (not 'expected-component)
102                   (eq? 'expected-component component))
103               #t
104               (error "unexpected exception" component arg))))))))
105
106(define-syntax pass-if-read-request-line
107  (syntax-rules ()
108    ((_ str expected-method expected-uri expected-version)
109     (pass-if str
110       (equal? (call-with-values
111                   (lambda ()
112                     (read-request-line (open-input-string
113                                         (string-append str "\r\n"))))
114                 list)
115               (list 'expected-method
116                     expected-uri
117                     'expected-version))))))
118
119(define-syntax pass-if-write-request-line
120  (syntax-rules ()
121    ((_ expected-str method uri version)
122     (pass-if expected-str
123       (equal? (string-append expected-str "\r\n")
124               (call-with-output-string
125                (lambda (port)
126                  (write-request-line 'method uri 'version port))))))))
127
128(define-syntax pass-if-read-response-line
129  (syntax-rules ()
130    ((_ str expected-version expected-code expected-phrase)
131     (pass-if str
132       (equal? (call-with-values
133                   (lambda ()
134                     (read-response-line (open-input-string
135                                          (string-append str "\r\n"))))
136                 list)
137               (list 'expected-version
138                     expected-code
139                     expected-phrase))))))
140
141(define-syntax pass-if-write-response-line
142  (syntax-rules ()
143    ((_ expected-str version code phrase)
144     (pass-if expected-str
145       (equal? (string-append expected-str "\r\n")
146               (call-with-output-string
147                (lambda (port)
148                  (write-response-line 'version code phrase port))))))))
149
150(with-test-prefix "read-request-line"
151  (pass-if-read-request-line "GET / HTTP/1.1"
152                             GET
153                             (build-uri-reference
154                              #:path "/")
155                             (1 . 1))
156  (pass-if-read-request-line "GET http://www.w3.org/pub/WWW/TheProject.html HTTP/1.1"
157                             GET
158                             (build-uri-reference
159                              #:scheme 'http
160                              #:host "www.w3.org"
161                              #:path "/pub/WWW/TheProject.html")
162                             (1 . 1))
163  (pass-if-read-request-line "GET /pub/WWW/TheProject.html HTTP/1.1"
164                             GET
165                             (build-uri-reference
166                              #:path "/pub/WWW/TheProject.html")
167                             (1 . 1))
168  (pass-if-read-request-line "HEAD /etc/hosts?foo=bar HTTP/1.1"
169                             HEAD
170                             (build-uri-reference
171                              #:path "/etc/hosts"
172                              #:query "foo=bar")
173                             (1 . 1)))
174
175(with-test-prefix "write-request-line"
176  (pass-if-write-request-line "GET / HTTP/1.1"
177                              GET
178                              (build-uri-reference
179                               #:path "/")
180                              (1 . 1))
181  ;;; FIXME: Test fails due to scheme, host always being removed.
182  ;;; However, it should be supported to request these be present, and
183  ;;; that is possible with absolute/relative URI support.
184  ;; (pass-if-write-request-line "GET http://www.w3.org/pub/WWW/TheProject.html HTTP/1.1"
185  ;;                             GET
186  ;;                             (build-uri 'http
187  ;;                                        #:host "www.w3.org"
188  ;;                                        #:path "/pub/WWW/TheProject.html")
189  ;;                             (1 . 1))
190  (pass-if-write-request-line "GET /pub/WWW/TheProject.html HTTP/1.1"
191                              GET
192                              (build-uri-reference
193                               #:path "/pub/WWW/TheProject.html")
194                              (1 . 1))
195  (pass-if-write-request-line "GET /?foo HTTP/1.1"
196                              GET
197                              (build-uri 'http #:query "foo")
198                              (1 . 1))
199  (pass-if-write-request-line "HEAD /etc/hosts?foo=bar HTTP/1.1"
200                              HEAD
201                              (build-uri-reference
202                               #:path "/etc/hosts"
203                               #:query "foo=bar")
204                              (1 . 1)))
205
206(with-test-prefix "read-response-line"
207  (pass-if-exception "missing CR/LF"
208      `(bad-header . "")
209    (call-with-input-string "HTTP/1.1 200 Almost okay"
210      (lambda (port)
211        (read-response-line port))))
212  (pass-if-read-response-line "HTTP/1.0 404 Not Found"
213                              (1 . 0) 404 "Not Found")
214  (pass-if-read-response-line "HTTP/1.1 200 OK"
215                              (1 . 1) 200 "OK")
216
217  ;; Empty reason phrases are valid; see <http://bugs.gnu.org/22273>.
218  (pass-if-read-response-line "HTTP/1.1 302 "
219                              (1 . 1) 302 ""))
220
221(with-test-prefix "write-response-line"
222  (pass-if-write-response-line "HTTP/1.0 404 Not Found"
223                               (1 . 0) 404 "Not Found")
224  (pass-if-write-response-line "HTTP/1.1 200 OK"
225                               (1 . 1) 200 "OK"))
226
227(with-test-prefix "general headers"
228
229  (pass-if-parse cache-control "no-transform" '(no-transform))
230  (pass-if-parse cache-control "no-transform,foo" '(no-transform foo))
231  (pass-if-parse cache-control "no-cache" '(no-cache))
232  (pass-if-parse cache-control "no-cache=\"Authorization, Date\""
233                 '((no-cache . (authorization date))))
234  (pass-if-parse cache-control "private=\"Foo\""
235                 '((private . (foo))))
236  (pass-if-parse cache-control "no-cache,max-age=10"
237                 '(no-cache (max-age . 10)))
238  (pass-if-parse cache-control "max-stale" '(max-stale))
239  (pass-if-parse cache-control "max-stale=10" '((max-stale . 10)))
240  (pass-if-round-trip "Cache-Control: acme-cache-extension\r\n")
241  (pass-if-round-trip "Cache-Control: acme-cache-extension=20\r\n")
242  (pass-if-round-trip "Cache-Control: acme-cache-extension=100 quux\r\n")
243  (pass-if-round-trip "Cache-Control: acme-cache-extension=\"100, quux\"\r\n")
244
245  (pass-if-parse connection "close" '(close))
246  (pass-if-parse connection "Content-Encoding" '(content-encoding))
247
248  (pass-if-parse date "Tue, 15 Nov 1994 08:12:31 GMT"
249                 (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
250                               "~a, ~d ~b ~Y ~H:~M:~S ~z"))
251  (pass-if-parse date "Tue, 15 Nov 1994 16:12:31 +0800"
252                 (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
253                               "~a, ~d ~b ~Y ~H:~M:~S ~z"))
254  (pass-if-parse date "Wed, 7 Sep 2011 11:25:00 GMT"
255                 (string->date "Wed, 7 Sep 2011 11:25:00 +0000"
256                               "~a,~e ~b ~Y ~H:~M:~S ~z"))
257
258  ;; This is a non-conforming date (lack of leading zero for the hours)
259  ;; that some HTTP servers provide.  See <http://bugs.gnu.org/23421>.
260  (pass-if-parse date "Sun, 06 Nov 1994  8:49:37 GMT"
261                 (string->date "Sun, 6 Nov 1994 08:49:37 +0000"
262                               "~a,~e ~b ~Y ~H:~M:~S ~z"))
263  (pass-if-parse date "Sun, 6 Nov 1994  8:49:37 GMT"
264                 (string->date "Sun, 6 Nov 1994 08:49:37 +0000"
265                               "~a,~e ~b ~Y ~H:~M:~S ~z"))
266
267  (pass-if-parse-error date "Tue, 15 Nov 1994 08:12:31 EST" date)
268  (pass-if-any-error date "Tue, 15 Qux 1994 08:12:31 EST")
269
270  (pass-if-parse pragma "no-cache" '(no-cache))
271  (pass-if-parse pragma "no-cache, foo" '(no-cache foo))
272
273  (pass-if-parse trailer "foo, bar" '(foo bar))
274  (pass-if-parse trailer "connection, bar" '(connection bar))
275
276  (pass-if-parse transfer-encoding "foo, chunked" '((foo) (chunked)))
277
278  (pass-if-parse upgrade "qux" '("qux"))
279
280  (pass-if-parse via "xyzzy" '("xyzzy"))
281
282  (pass-if-parse warning "123 foo \"core breach imminent\""
283                 '((123 "foo" "core breach imminent" #f)))
284  (pass-if-parse
285   warning
286   "123 foo \"core breach imminent\" \"Tue, 15 Nov 1994 08:12:31 GMT\""
287   `((123 "foo" "core breach imminent"
288          ,(string->date "Tue, 15 Nov 1994 08:12:31 +0000"
289                         "~a, ~d ~b ~Y ~H:~M:~S ~z")))))
290
291(with-test-prefix "entity headers"
292  (pass-if-parse allow "foo, bar" '(foo bar))
293  (pass-if-parse content-disposition "form-data; name=\"file\"; filename=\"q.go\""
294                 '(form-data (name . "file") (filename . "q.go")))
295  (pass-if-parse content-encoding "qux, baz" '(qux baz))
296  (pass-if-parse content-language "qux, baz" '("qux" "baz"))
297  (pass-if-parse content-length "100" 100)
298  (pass-if-parse content-length "0" 0)
299  (pass-if-parse content-length "010" 10)
300  (pass-if-parse content-location "http://foo/"
301                 (build-uri 'http #:host "foo" #:path "/"))
302  (pass-if-parse content-location "//foo/"
303                 (build-uri-reference #:host "foo" #:path "/"))
304  (pass-if-parse content-location "/etc/foo"
305                 (build-uri-reference #:path "/etc/foo"))
306  (pass-if-parse content-location "foo"
307                 (build-uri-reference #:path "foo"))
308  (pass-if-parse content-range "bytes 10-20/*" '(bytes (10 . 20) *))
309  (pass-if-parse content-range "bytes */*" '(bytes * *))
310  (pass-if-parse content-range "bytes */30" '(bytes * 30))
311  (pass-if-parse content-type "foo/bar" '(foo/bar))
312  (pass-if-parse content-type "foo/bar; baz=qux" '(foo/bar (baz . "qux")))
313  (pass-if-parse expires "Tue, 15 Nov 1994 08:12:31 GMT"
314                 (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
315                         "~a, ~d ~b ~Y ~H:~M:~S ~z"))
316  (pass-if-parse last-modified "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
320(with-test-prefix "request headers"
321  (pass-if-parse accept "text/*;q=0.3, text/html;q=0.7, text/html;level=1"
322                 '((text/* (q . 300))
323                   (text/html (q . 700))
324                   (text/html (level . "1"))))
325  (pass-if-parse accept-charset "iso-8859-5, unicode-1-1;q=0.8"
326                 '((1000 . "iso-8859-5") (800 . "unicode-1-1")))
327  (pass-if-parse accept-encoding "gzip;q=1.0, identity; q=0.5, *;q=0"
328                 '((1000 . "gzip")
329                   (500 . "identity")
330                   (0 . "*")))
331  (pass-if-parse accept-language "da, en-gb;q=0.8, en;q=0.7"
332                 '((1000 . "da") (800 . "en-gb") (700 . "en")))
333  ;; Allow nonstandard .2 to mean 0.2
334  (pass-if-parse accept-language "en-gb;q=.2" '((200 . "en-gb")))
335  (pass-if-parse authorization "Basic foooo" '(basic . "foooo"))
336  (pass-if-parse authorization "Digest foooo" '(digest foooo))
337  (pass-if-parse authorization "Digest foo=bar,baz=qux"
338                 '(digest (foo . "bar") (baz . "qux")))
339  (pass-if-round-trip "Authorization: basic foooo\r\n")
340  (pass-if-round-trip "Authorization: digest foooo\r\n")
341  (pass-if-round-trip "Authorization: digest foo=bar, baz=qux\r\n")
342  (pass-if-parse expect "100-continue, foo" '((100-continue) (foo)))
343  (pass-if-parse from "foo@bar" "foo@bar")
344  (pass-if-parse host "qux" '("qux" . #f))
345  (pass-if-parse host "qux:80" '("qux" . 80))
346  (pass-if-parse host "[2001:db8::1]" '("2001:db8::1" . #f))
347  (pass-if-parse host "[2001:db8::1]:80" '("2001:db8::1" . 80))
348  (pass-if-parse host "[::ffff:192.0.2.1]" '("::ffff:192.0.2.1" . #f))
349  (pass-if-round-trip "Host: [2001:db8::1]\r\n")
350  (pass-if-parse if-match "\"xyzzy\", W/\"qux\""
351                 '(("xyzzy" . #t) ("qux" . #f)))
352  (pass-if-parse if-match "*" '*)
353  (pass-if-parse if-modified-since "Tue, 15 Nov 1994 08:12:31 GMT"
354                 (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
355                         "~a, ~d ~b ~Y ~H:~M:~S ~z"))
356  (pass-if-parse if-none-match "\"xyzzy\", W/\"qux\""
357                 '(("xyzzy" . #t) ("qux" . #f)))
358  (pass-if-parse if-none-match "xyzzy, W/\"qux\""
359                 '(("xyzzy" . #t) ("qux" . #f)))
360  (pass-if-parse if-none-match "*" '*)
361  (pass-if-parse if-range "\"foo\"" '("foo" . #t))
362  (pass-if-parse if-range  "Tue, 15 Nov 1994 08:12:31 GMT"
363                 (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
364                         "~a, ~d ~b ~Y ~H:~M:~S ~z"))
365  (pass-if-parse if-unmodified-since "Tue, 15 Nov 1994 08:12:31 GMT"
366                 (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
367                         "~a, ~d ~b ~Y ~H:~M:~S ~z"))
368  (pass-if-parse max-forwards "10" 10)
369  (pass-if-parse max-forwards "00" 0)
370  (pass-if-parse proxy-authorization "Basic foooo" '(basic . "foooo"))
371  (pass-if-parse proxy-authorization "Digest foooo" '(digest foooo))
372  (pass-if-parse proxy-authorization "Digest foo=bar,baz=qux"
373                 '(digest (foo . "bar") (baz . "qux")))
374  (pass-if-parse range "bytes=10-20" '(bytes (10 . 20)))
375  (pass-if-parse range "bytes=10-" '(bytes (10 . #f)))
376  (pass-if-parse range "bytes=-20" '(bytes (#f . 20)))
377  (pass-if-parse range "bytes=-20,-30" '(bytes (#f . 20) (#f . 30)))
378  (pass-if-parse referer "http://foo/bar?baz"
379                 (build-uri 'http #:host "foo" #:path "/bar" #:query "baz"))
380  (pass-if-parse referer "//foo/bar?baz"
381                 (build-uri-reference #:host "foo"
382                                      #:path "/bar"
383                                      #:query "baz"))
384  (pass-if-parse referer "/etc/foo"
385                 (build-uri-reference #:path "/etc/foo"))
386  (pass-if-parse referer "foo"
387                 (build-uri-reference #:path "foo"))
388  (pass-if-parse te "trailers" '((trailers)))
389  (pass-if-parse te "trailers,foo" '((trailers) (foo)))
390  (pass-if-parse user-agent "guile" "guile"))
391
392
393;; Response headers
394;;
395(with-test-prefix "response headers"
396  (pass-if-parse accept-ranges "foo,bar" '(foo bar))
397  (pass-if-parse age "30" 30)
398  (pass-if-parse etag "\"foo\"" '("foo" . #t))
399  (pass-if-parse etag "W/\"foo\"" '("foo" . #f))
400  (pass-if-parse etag "foo" '("foo" . #t))
401  (pass-if-parse location "http://other-place"
402                 (build-uri 'http #:host "other-place"))
403  (pass-if-only-parse location "#foo"
404                      (build-uri-reference #:fragment "foo"))
405  (pass-if-only-parse location "/#foo"
406                      (build-uri-reference #:path "/" #:fragment "foo"))
407  (pass-if-parse location "/foo"
408                 (build-uri-reference #:path "/foo"))
409  (pass-if-parse location "//server/foo"
410                 (build-uri-reference #:host "server" #:path "/foo"))
411  (pass-if-parse proxy-authenticate "Basic realm=\"guile\""
412                 '((basic (realm . "guile"))))
413  (pass-if-parse retry-after "Tue, 15 Nov 1994 08:12:31 GMT"
414                 (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
415                         "~a, ~d ~b ~Y ~H:~M:~S ~z"))
416  (pass-if-parse retry-after "20" 20)
417  (pass-if-parse server "guile!" "guile!")
418  (pass-if-parse vary "*" '*)
419  (pass-if-parse vary "foo, bar" '(foo bar))
420  (pass-if-parse www-authenticate "Basic realm=\"guile\""
421                 '((basic (realm . "guile")))))
422
423(with-test-prefix "chunked encoding"
424  (let* ((s "5\r\nFirst\r\nA\r\n line\n Sec\r\n8\r\nond line\r\n0\r\n")
425         (p (make-chunked-input-port (open-input-string s))))
426    (pass-if-equal
427        "First line\n Second line"
428        (get-string-all p))
429    (pass-if (port-eof? (make-chunked-input-port (open-input-string "0\r\n"))))
430
431    (pass-if-equal "reads chunks without buffering"
432        ;; Make sure the chunked input port does not read more than what
433        ;; the client asked.  See <http://bugs.gnu.org/19939>
434        `("First " "chunk." "Second " "chunk."
435          (1 1 1 6 6 1 1
436           1 1 1 7 6 1 1))
437      (let* ((str      "C\r\nFirst chunk.\r\nD\r\nSecond chunk.\r\n")
438             (requests '())
439             (read!    (let ((port (open-input-string str)))
440                         (lambda (bv index count)
441                           (set! requests (cons count requests))
442                           (let ((n (get-bytevector-n! port bv index
443                                                       count)))
444                             (if (eof-object? n) 0 n)))))
445             (input    (make-custom-binary-input-port "chunky" read!
446                                                      #f #f #f))
447             (port     (make-chunked-input-port input)))
448        (setvbuf input 'none)
449        (setvbuf port 'none)
450        (list (utf8->string (get-bytevector-n port 6))
451              (utf8->string (get-bytevector-n port 6))
452              (utf8->string (get-bytevector-n port 7))
453              (utf8->string (get-bytevector-n port 6))
454              (reverse requests))))
455
456    (pass-if-equal "reads across chunk boundaries"
457        ;; Same, but read across chunk boundaries.
458        `("First " "chunk.Second " "chunk."
459          (1 1 1 6 6 1 1
460           1 1 1 7 6 1 1))
461      (let* ((str      "C\r\nFirst chunk.\r\nD\r\nSecond chunk.\r\n")
462             (requests '())
463             (read!    (let ((port (open-input-string str)))
464                         (lambda (bv index count)
465                           (set! requests (cons count requests))
466                           (let ((n (get-bytevector-n! port bv index
467                                                       count)))
468                             (if (eof-object? n) 0 n)))))
469             (input    (make-custom-binary-input-port "chunky" read!
470                                                      #f #f #f))
471             (port     (make-chunked-input-port input)))
472        (setvbuf input 'none)
473        (setvbuf port 'none)
474        (list (utf8->string (get-bytevector-n port 6))
475              (utf8->string (get-bytevector-n port 13))
476              (utf8->string (get-bytevector-n port 6))
477              (reverse requests)))))
478
479  (pass-if-equal "EOF instead of chunk header"
480      "Only chunk."
481    ;; Omit the second chunk header, leading to a premature EOF.  This
482    ;; used to cause 'read-chunk-header' to throw to wrong-type-arg.
483    ;; See the backtrace at
484    ;; <http://debbugs.gnu.org/cgi/bugreport.cgi?bug=19976#5>.
485    (let* ((str  "B\r\nOnly chunk.")
486           (port (make-chunked-input-port (open-input-string str))))
487      (get-string-all port)))
488
489  (pass-if-equal
490      (call-with-output-string
491       (lambda (out-raw)
492         (let ((out-chunked (make-chunked-output-port out-raw
493                                                      #:keep-alive? #t)))
494           (display "First chunk" out-chunked)
495           (force-output out-chunked)
496           (display "Second chunk" out-chunked)
497           (force-output out-chunked)
498           (display "Third chunk" out-chunked)
499           (close-port out-chunked))))
500      "b\r\nFirst chunk\r\nc\r\nSecond chunk\r\nb\r\nThird chunk\r\n0\r\n"))
501