1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
|
;;;; web-request.test --- HTTP requests -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite web-request)
#:use-module (web uri)
#:use-module (web request)
#:use-module (test-suite lib))
;; The newlines are equivalent to \n.
(define example-1
"GET /qux HTTP/1.1\r
Host: localhost:8080\r
User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; en-us) AppleWebKit/531.2+ (KHTML, like Gecko) Safari/531.2+ Epiphany/2.30.2\r
Accept: application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5\r
Accept-Encoding: gzip\r
Accept-Language: en-gb, en;q=0.9\r
\r
")
(define (requests-equal? r1 r2)
(and (equal? (request-method r1) (request-method r2))
(equal? (request-uri r1) (request-uri r2))
(equal? (request-version r1) (request-version r2))
(equal? (request-headers r1) (request-headers r2))))
(with-test-prefix "example-1"
(let ((r #f))
(pass-if "read-request"
(begin
(set! r (read-request (open-input-string example-1)))
(request? r)))
(pass-if (equal?
(request-host (build-request (string->uri "http://www.gnu.org/")))
'("www.gnu.org" . #f)))
(pass-if (equal? (request-method r) 'GET))
(pass-if (equal? (request-uri r)
(build-uri-reference #:path "/qux")))
(pass-if (equal? (read-request-body r) #f))
(pass-if "checking all headers"
(equal?
(request-headers r)
'((host . ("localhost" . 8080))
(user-agent . "Mozilla/5.0 (X11; U; Linux x86_64; en-us) AppleWebKit/531.2+ (KHTML, like Gecko) Safari/531.2+ Epiphany/2.30.2")
(accept . ((application/xml)
(application/xhtml+xml)
(text/html (q . 900))
(text/plain (q . 800))
(image/png)
(*/* (q . 500))))
(accept-encoding . ((1000 . "gzip")))
(accept-language . ((1000 . "en-gb") (900 . "en"))))))
;; works because there is no body
(pass-if "write then read"
(requests-equal? (with-input-from-string
(with-output-to-string
(lambda ()
(write-request r (current-output-port))))
(lambda ()
(read-request (current-input-port))))
r))
(pass-if "by accessor"
(equal? (request-accept-encoding r) '((1000 . "gzip"))))))
|
