flonum? returns false for complex number objects.

[bpt/guile.git] / test-suite / tests / web-response.test

diff --git a/test-suite/tests/web-response.test b/test-suite/tests/web-response.test
index 540e16d..f9679f5 100644 (file)
--- a/test-suite/tests/web-response.test
+++ b/test-suite/tests/web-response.test
@@ -1,6 +1,6 @@
 ;;;; web-response.test --- HTTP responses       -*- mode: scheme; coding: utf-8; -*-
 ;;;;
-;;;;   Copyright (C) 2010 Free Software Foundation, Inc.
+;;;;   Copyright (C) 2010, 2011, 2012 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
@@ -20,6 +20,8 @@
 (define-module (test-suite web-response)
   #:use-module (web uri)
   #:use-module (web response)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
   #:use-module (srfi srfi-19)
   #:use-module (test-suite lib))
 
@@ -35,10 +37,23 @@ Expires: Thu, 28 Oct 2010 15:33:13 GMT\r
 Vary: Accept-Encoding\r
 Content-Encoding: gzip\r
 Content-Length: 36\r
-Content-Type: text/html\r
+Content-Type: text/html; charset=utf-8\r
 \r
 abcdefghijklmnopqrstuvwxyz0123456789")
 
+(define example-2
+  "HTTP/1.1 200 OK\r
+Transfer-Encoding: chunked\r
+Content-Type: text/plain
+\r
+1c\r
+Lorem ipsum dolor sit amet, \r
+1d\r
+consectetur adipisicing elit,\r
+43\r
+ sed do eiusmod tempor incididunt ut labore et dolore magna aliqua.\r
+0\r\n")
+
 (define (responses-equal? r1 body1 r2 body2)
   (and (equal? (response-version r1) (response-version r2))
        (equal? (response-code r1) (response-code r2))
@@ -52,35 +67,33 @@ abcdefghijklmnopqrstuvwxyz0123456789")
       (begin
         (set! r (read-response (open-input-string example-1)))
         (response? r)))
-    
-    (pass-if "read-response-body/latin-1"
+
+    (pass-if "read-response-body"
       (begin
-        (set! body (read-response-body/latin-1 r))
+        (set! body (read-response-body r))
         #t))
-    
-    (pass-if (equal? (response-version r) '(1 . 1)))
-    
-    (pass-if (equal? (response-code r) 200))
-    
-    (pass-if (equal? (response-reason-phrase r) "OK"))
-    
-    (pass-if (equal? body "abcdefghijklmnopqrstuvwxyz0123456789"))
-    
-    (pass-if "checking all headers"
-      (equal?
-       (response-headers r)
-       `((date . ,(string->date "Wed, 03 Nov 2010 22:27:07 +0000"
-                                "~a, ~d ~b ~Y ~H:~M:~S ~z"))
-         (server . "Apache/2.0.55")
-         (accept-ranges . ("bytes"))
-         (cache-control . ((max-age . 543234)))
-         (expires . ,(string->date "Thu, 28 Oct 2010 15:33:13 GMT +0000"
-                                   "~a, ~d ~b ~Y ~H:~M:~S ~z"))
-         (vary . ("Accept-Encoding"))
-         (content-encoding . ("gzip"))
-         (content-length . 36)
-         (content-type . ("text" "html")))))
-    
+
+    (pass-if-equal '(1 . 1) (response-version r))
+    (pass-if-equal 200 (response-code r))
+    (pass-if-equal "OK" (response-reason-phrase r))
+
+    (pass-if-equal (string->utf8 "abcdefghijklmnopqrstuvwxyz0123456789")
+        body)
+
+    (pass-if-equal "checking all headers"
+        `((date . ,(string->date "Wed, 03 Nov 2010 22:27:07 +0000"
+                                 "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+          (server . "Apache/2.0.55")
+          (accept-ranges . (bytes))
+          (cache-control . ((max-age . 543234)))
+          (expires . ,(string->date "Thu, 28 Oct 2010 15:33:13 GMT +0000"
+                                    "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+          (vary . (accept-encoding))
+          (content-encoding . (gzip))
+          (content-length . 36)
+          (content-type . (text/html (charset . "utf-8"))))
+      (response-headers r))
+
     (pass-if "write then read"
       (call-with-values
           (lambda ()
@@ -88,12 +101,38 @@ abcdefghijklmnopqrstuvwxyz0123456789")
                 (with-output-to-string
                   (lambda ()
                     (let ((r (write-response r (current-output-port))))
-                      (write-response-body/latin-1 r body))))
+                      (write-response-body r body))))
               (lambda ()
                 (let ((r (read-response (current-input-port))))
-                  (values r (read-response-body/latin-1 r))))))
+                  (values r (read-response-body r))))))
         (lambda (r* body*)
           (responses-equal? r body r* body*))))
 
-    (pass-if "by accessor"
-      (equal? (response-content-encoding r) '("gzip")))))
+    (pass-if-equal "by accessor"
+        '(gzip)
+      (response-content-encoding r))
+
+    (pass-if-equal "response-body-port"
+        `("utf-8" ,body)
+      (with-fluids ((%default-port-encoding #f))
+        (let* ((r (read-response (open-input-string example-1)))
+               (p (response-body-port r)))
+          (list (port-encoding p) (get-bytevector-all p)))))))
+
+(with-test-prefix "example-2"
+  (let* ((r (read-response (open-input-string example-2)))
+         (b (read-response-body r)))
+    (pass-if-equal '((chunked))
+        (response-transfer-encoding r))
+    (pass-if-equal
+        (string->utf8
+         (string-append
+          "Lorem ipsum dolor sit amet, consectetur adipisicing elit,"
+          " sed do eiusmod tempor incididunt ut labore et dolore magna aliqua."))
+        b)
+    (pass-if-equal "response-body-port"
+        `("ISO-8859-1" ,(utf8->string b)) ; no `charset', hence ISO-8859-1
+      (with-fluids ((%default-port-encoding #f))
+        (let* ((r (read-response (open-input-string example-2)))
+               (p (response-body-port r)))
+          (list (port-encoding p) (get-string-all p)))))))