test-suite/tests/web-http.test

   1 ;;;; web-uri.test --- URI library          -*- mode: scheme; coding: utf-8; -*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2010, 2011, 2014 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 io ports)
  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)
  45        (and (equal? (parse-header 'sym str)
  46                     val)
  47             (valid-header? 'sym val))))))
  48
  49 (define-syntax pass-if-round-trip
  50   (syntax-rules ()
  51     ((_ str)
  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)))))))))
  60
  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 ()
  67               (parse-header 'sym str)
  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 ()
  80            (parse-header 'sym str)
  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
  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))
 176   (pass-if-write-request-line "GET /?foo HTTP/1.1"
 177                               GET
 178                               (build-uri 'http #:query "foo")
 179                               (1 . 1))
 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
 199 (with-test-prefix "general headers"
 200
 201   (pass-if-parse cache-control "no-transform" '(no-transform))
 202   (pass-if-parse cache-control "no-transform,foo" '(no-transform foo))
 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\""
 207                  '((private . (foo))))
 208   (pass-if-parse cache-control "no-cache,max-age=10"
 209                  '(no-cache (max-age . 10)))
 210   (pass-if-parse cache-control "max-stale" '(max-stale))
 211   (pass-if-parse cache-control "max-stale=10" '((max-stale . 10)))
 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")
 216
 217   (pass-if-parse connection "close" '(close))
 218   (pass-if-parse connection "Content-Encoding" '(content-encoding))
 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"))
 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"))
 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"))
 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))
 233   (pass-if-parse pragma "no-cache, foo" '(no-cache foo))
 234
 235   (pass-if-parse trailer "foo, bar" '(foo bar))
 236   (pass-if-parse trailer "connection, bar" '(connection bar))
 237
 238   (pass-if-parse transfer-encoding "foo, chunked" '((foo) (chunked)))
 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"
 254   (pass-if-parse allow "foo, bar" '(foo bar))
 255   (pass-if-parse content-disposition "form-data; name=\"file\"; filename=\"q.go\""
 256                  '(form-data (name . "file") (filename . "q.go")))
 257   (pass-if-parse content-encoding "qux, baz" '(qux baz))
 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))
 267   (pass-if-parse content-type "foo/bar" '(foo/bar))
 268   (pass-if-parse content-type "foo/bar; baz=qux" '(foo/bar (baz . "qux")))
 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
 276 (with-test-prefix "request headers"
 277   (pass-if-parse accept "text/*;q=0.3, text/html;q=0.7, text/html;level=1"
 278                  '((text/* (q . 300))
 279                    (text/html (q . 700))
 280                    (text/html (level . "1"))))
 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")))
 289   ;; Allow nonstandard .2 to mean 0.2
 290   (pass-if-parse accept-language "en-gb;q=.2" '((200 . "en-gb")))
 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")))
 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")
 298   (pass-if-parse expect "100-continue, foo" '((100-continue) (foo)))
 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))
 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")
 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)
 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")))
 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)))
 335   (pass-if-parse te "trailers,foo" '((trailers) (foo)))
 336   (pass-if-parse user-agent "guile" "guile"))
 337
 338
 339 ;; Response headers
 340 ;;
 341 (with-test-prefix "response headers"
 342   (pass-if-parse accept-ranges "foo,bar" '(foo bar))
 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"))
 348   (pass-if-parse location "#foo"
 349                  (build-uri-reference #:fragment "foo"))
 350   (pass-if-parse location "/#foo"
 351                  (build-uri-reference #:path "/" #:fragment "foo"))
 352   (pass-if-parse location "/foo"
 353                  (build-uri-reference #:path "/foo"))
 354   (pass-if-parse location "//server/foo"
 355                  (build-uri-reference #:host "server" #:path "/foo"))
 356   (pass-if-parse proxy-authenticate "Basic realm=\"guile\""
 357                  '((basic (realm . "guile"))))
 358   (pass-if-parse retry-after "Tue, 15 Nov 1994 08:12:31 GMT"
 359                  (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
 360                          "~a, ~d ~b ~Y ~H:~M:~S ~z"))
 361   (pass-if-parse retry-after "20" 20)
 362   (pass-if-parse server "guile!" "guile!")
 363   (pass-if-parse vary "*" '*)
 364   (pass-if-parse vary "foo, bar" '(foo bar))
 365   (pass-if-parse www-authenticate "Basic realm=\"guile\""
 366                  '((basic (realm . "guile")))))
 367
 368 (with-test-prefix "chunked encoding"
 369   (let* ((s "5\r\nFirst\r\nA\r\n line\n Sec\r\n8\r\nond line\r\n0\r\n")
 370          (p (make-chunked-input-port (open-input-string s))))
 371     (pass-if (equal? "First line\n Second line"
 372                      (get-string-all p)))
 373     (pass-if (port-eof? (make-chunked-input-port (open-input-string "0\r\n")))))
 374   (pass-if
 375       (equal? (call-with-output-string
 376                (lambda (out-raw)
 377                  (let ((out-chunked (make-chunked-output-port out-raw
 378                                                               #:keep-alive? #t)))
 379                    (display "First chunk" out-chunked)
 380                    (force-output out-chunked)
 381                    (display "Second chunk" out-chunked)
 382                    (force-output out-chunked)
 383                    (display "Third chunk" out-chunked)
 384                    (close-port out-chunked))))
 385               "b\r\nFirst chunk\r\nc\r\nSecond chunk\r\nb\r\nThird chunk\r\n0\r\n")))