test-suite/tests/web-request.test

   1 ;;;; web-request.test --- HTTP requests       -*- mode: scheme; coding: utf-8; -*-
   2 ;;;;
   3 ;;;;    Copyright (C) 2010, 2011 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
  29 Host: localhost:8080\r
  30 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
  31 Accept: application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5\r
  32 Accept-Encoding: gzip\r
  33 Accept-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) (build-uri 'http #:path "/qux")))
  57
  58     (pass-if (equal? (read-request-body r) #f))
  59
  60     (pass-if "checking all headers"
  61       (equal?
  62        (request-headers r)
  63        '((host . ("localhost" . 8080))
  64          (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")
  65          (accept . ((application/xml)
  66                     (application/xhtml+xml)
  67                     (text/html (q . 900))
  68                     (text/plain (q . 800))
  69                     (image/png)
  70                     (*/* (q . 500))))
  71          (accept-encoding . ((1000 . "gzip")))
  72          (accept-language . ((1000 . "en-gb") (900 . "en"))))))
  73
  74     ;; works because there is no body
  75     (pass-if "write then read"
  76       (requests-equal? (with-input-from-string
  77                            (with-output-to-string
  78                              (lambda ()
  79                                (write-request r (current-output-port))))
  80                          (lambda ()
  81                            (read-request (current-input-port))))
  82                        r))
  83
  84     (pass-if "by accessor"
  85       (equal? (request-accept-encoding r) '((1000 . "gzip"))))))