Commit | Line | Data |
---|---|---|
a9eeb2f4 AW |
1 | ;;;; web-response.test --- HTTP responses -*- mode: scheme; coding: utf-8; -*- |
2 | ;;;; | |
802a25b1 | 3 | ;;;; Copyright (C) 2010, 2011, 2012, 2014 Free Software Foundation, Inc. |
a9eeb2f4 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-response) | |
21 | #:use-module (web uri) | |
22 | #:use-module (web response) | |
3475fbb5 | 23 | #:use-module (rnrs bytevectors) |
75d6c59f | 24 | #:use-module (rnrs io ports) |
a9eeb2f4 AW |
25 | #:use-module (srfi srfi-19) |
26 | #:use-module (test-suite lib)) | |
27 | ||
28 | ||
29 | ;; The newlines are equivalent to \n. From www.gnu.org. | |
30 | (define example-1 | |
31 | "HTTP/1.1 200 OK\r | |
32 | Date: Wed, 03 Nov 2010 22:27:07 GMT\r | |
33 | Server: Apache/2.0.55\r | |
34 | Accept-Ranges: bytes\r | |
35 | Cache-Control: max-age=543234\r | |
36 | Expires: Thu, 28 Oct 2010 15:33:13 GMT\r | |
37 | Vary: Accept-Encoding\r | |
38 | Content-Encoding: gzip\r | |
39 | Content-Length: 36\r | |
7aa54882 | 40 | Content-Type: text/html; charset=utf-8\r |
a9eeb2f4 | 41 | \r |
802a25b1 LC |
42 | abcdefghijklmnopqrstuvwxyz0123456789 |
43 | -> Here is trailing garbage that should be ignored because it is | |
44 | beyond Content-Length.") | |
a9eeb2f4 | 45 | |
312e79f8 IP |
46 | (define example-2 |
47 | "HTTP/1.1 200 OK\r | |
48 | Transfer-Encoding: chunked\r | |
49 | Content-Type: text/plain | |
50 | \r | |
51 | 1c\r | |
52 | Lorem ipsum dolor sit amet, \r | |
53 | 1d\r | |
54 | consectetur adipisicing elit,\r | |
55 | 43\r | |
56 | sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.\r | |
57 | 0\r\n") | |
58 | ||
a9eeb2f4 AW |
59 | (define (responses-equal? r1 body1 r2 body2) |
60 | (and (equal? (response-version r1) (response-version r2)) | |
61 | (equal? (response-code r1) (response-code r2)) | |
62 | (equal? (response-reason-phrase r1) (response-reason-phrase r2)) | |
63 | (equal? (response-headers r1) (response-headers r2)) | |
64 | (equal? body1 body2))) | |
65 | ||
66 | (with-test-prefix "example-1" | |
67 | (let ((r #f) (body #f)) | |
68 | (pass-if "read-response" | |
69 | (begin | |
70 | (set! r (read-response (open-input-string example-1))) | |
71 | (response? r))) | |
cb17c442 | 72 | |
3475fbb5 | 73 | (pass-if "read-response-body" |
a9eeb2f4 | 74 | (begin |
3475fbb5 | 75 | (set! body (read-response-body r)) |
a9eeb2f4 | 76 | #t)) |
cb17c442 LC |
77 | |
78 | (pass-if-equal '(1 . 1) (response-version r)) | |
79 | (pass-if-equal 200 (response-code r)) | |
80 | (pass-if-equal "OK" (response-reason-phrase r)) | |
81 | ||
82 | (pass-if-equal (string->utf8 "abcdefghijklmnopqrstuvwxyz0123456789") | |
83 | body) | |
84 | ||
85 | (pass-if-equal "checking all headers" | |
86 | `((date . ,(string->date "Wed, 03 Nov 2010 22:27:07 +0000" | |
87 | "~a, ~d ~b ~Y ~H:~M:~S ~z")) | |
88 | (server . "Apache/2.0.55") | |
89 | (accept-ranges . (bytes)) | |
90 | (cache-control . ((max-age . 543234))) | |
91 | (expires . ,(string->date "Thu, 28 Oct 2010 15:33:13 GMT +0000" | |
92 | "~a, ~d ~b ~Y ~H:~M:~S ~z")) | |
93 | (vary . (accept-encoding)) | |
94 | (content-encoding . (gzip)) | |
95 | (content-length . 36) | |
96 | (content-type . (text/html (charset . "utf-8")))) | |
97 | (response-headers r)) | |
98 | ||
a9eeb2f4 AW |
99 | (pass-if "write then read" |
100 | (call-with-values | |
101 | (lambda () | |
102 | (with-input-from-string | |
103 | (with-output-to-string | |
104 | (lambda () | |
105 | (let ((r (write-response r (current-output-port)))) | |
3475fbb5 | 106 | (write-response-body r body)))) |
a9eeb2f4 AW |
107 | (lambda () |
108 | (let ((r (read-response (current-input-port)))) | |
3475fbb5 | 109 | (values r (read-response-body r)))))) |
a9eeb2f4 AW |
110 | (lambda (r* body*) |
111 | (responses-equal? r body r* body*)))) | |
112 | ||
cb17c442 LC |
113 | (pass-if-equal "by accessor" |
114 | '(gzip) | |
75d6c59f LC |
115 | (response-content-encoding r)) |
116 | ||
117 | (pass-if-equal "response-body-port" | |
118 | `("utf-8" ,body) | |
119 | (with-fluids ((%default-port-encoding #f)) | |
120 | (let* ((r (read-response (open-input-string example-1))) | |
121 | (p (response-body-port r))) | |
122 | (list (port-encoding p) (get-bytevector-all p))))))) | |
312e79f8 IP |
123 | |
124 | (with-test-prefix "example-2" | |
cb17c442 LC |
125 | (let* ((r (read-response (open-input-string example-2))) |
126 | (b (read-response-body r))) | |
127 | (pass-if-equal '((chunked)) | |
128 | (response-transfer-encoding r)) | |
129 | (pass-if-equal | |
130 | (string->utf8 | |
131 | (string-append | |
132 | "Lorem ipsum dolor sit amet, consectetur adipisicing elit," | |
133 | " sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.")) | |
75d6c59f LC |
134 | b) |
135 | (pass-if-equal "response-body-port" | |
136 | `("ISO-8859-1" ,(utf8->string b)) ; no `charset', hence ISO-8859-1 | |
137 | (with-fluids ((%default-port-encoding #f)) | |
138 | (let* ((r (read-response (open-input-string example-2))) | |
139 | (p (response-body-port r))) | |
140 | (list (port-encoding p) (get-string-all p))))))) |