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