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