web-request.test 3.2 KB

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