1;;;; web-request.test --- HTTP requests       -*- mode: scheme; coding: utf-8; -*-
2;;;;
3;;;; 	Copyright (C) 2010, 2011, 2013 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-request)
21  #:use-module (web uri)
22  #:use-module (web request)
23  #:use-module (test-suite lib))
24
25
26;; The newlines are equivalent to \n.
27(define example-1
28  "GET /qux HTTP/1.1\r
29Host: localhost:8080\r
30User-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
31Accept: application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5\r
32Accept-Encoding: gzip\r
33Accept-Language: en-gb, en;q=0.9\r
34\r
35")
36
37(define (requests-equal? r1 r2)
38  (and (equal? (request-method r1) (request-method r2))
39       (equal? (request-uri r1) (request-uri r2))
40       (equal? (request-version r1) (request-version r2))
41       (equal? (request-headers r1) (request-headers r2))))
42
43(with-test-prefix "example-1"
44  (let ((r #f))
45    (pass-if "read-request"
46      (begin
47        (set! r (read-request (open-input-string example-1)))
48        (request? r)))
49
50    (pass-if (equal?
51              (request-host (build-request (string->uri "http://www.gnu.org/")))
52              '("www.gnu.org" . #f)))
53
54    (pass-if (equal? (request-method r) 'GET))
55
56    (pass-if (equal? (request-uri r)
57                     (build-uri-reference #:path "/qux")))
58
59    (pass-if (equal? (read-request-body r) #f))
60
61    (pass-if "checking all headers"
62      (equal?
63       (request-headers r)
64       '((host . ("localhost" . 8080))
65         (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")
66         (accept . ((application/xml)
67                    (application/xhtml+xml)
68                    (text/html (q . 900))
69                    (text/plain (q . 800))
70                    (image/png)
71                    (*/* (q . 500))))
72         (accept-encoding . ((1000 . "gzip")))
73         (accept-language . ((1000 . "en-gb") (900 . "en"))))))
74
75    ;; works because there is no body
76    (pass-if "write then read"
77      (requests-equal? (with-input-from-string
78                           (with-output-to-string
79                             (lambda ()
80                               (write-request r (current-output-port))))
81                         (lambda ()
82                           (read-request (current-input-port))))
83                       r))
84
85    (pass-if "by accessor"
86      (equal? (request-accept-encoding r) '((1000 . "gzip"))))))
87