Fix content-length to use byte count instead of char count on C66.5

Also, default to utf-8 charsets in default mime type map and default
response headers and when sending status responses and in the simple
directory handler.

3 files changed, 25 insertions, 11 deletions

diff --git a/simple-directory-handler.scm b/simple-directory-handler.scm
index 47dbea9..68b93e8 100644
--- a/simple-directory-handler.scm
+++ b/simple-directory-handler.scm
@@ -41,9 +41,14 @@
         (only srfi-14 char-set-complement char-set-delete))
 
 (cond-expand
-  (chicken-6 (import (scheme base))) ; For make-parameter, which moved from (chicken base)
+  (chicken-6 (import (scheme base) (chicken memory representation))) ; For make-parameter, which moved from (chicken base)
   (else))
 
+(define (string-byte-length s)
+  (cond-expand
+    (chicken-6 (number-of-bytes s))
+    (else (string-length s))))
+
 (define (encode-path p)
   (let ((cs (char-set-delete (char-set-complement char-set:uri-unreserved) #\/)))
     (uri-encode-string p cs)))
@@ -108,8 +113,8 @@
                     ((exn i/o file) str))))
               ""
               dir)))))
-    (with-headers `((content-type text/html)
-                    (content-length ,(string-length str)))
+    (with-headers `((content-type #(text/html ((charset . utf-8))))
+                    (content-length ,(string-byte-length str)))
       (lambda ()
        (write-logged-response)
        (unless (eq? 'HEAD (request-method (current-request)))
diff --git a/spiffy.scm b/spiffy.scm
index 8768d5f..54fb8c9 100644
--- a/spiffy.scm
+++ b/spiffy.scm
@@ -58,9 +58,14 @@
         uri-common sendfile (rename intarweb (headers intarweb:headers)))
 
 (cond-expand
-  (chicken-6 (import (scheme base))) ; For make-parameter, which moved from (chicken base)
+  (chicken-6 (import (scheme base) (chicken memory representation))) ; For make-parameter, which moved from (chicken base)
   (else))
 
+(define (string-byte-length s)
+  (cond-expand
+    (chicken-6 (number-of-bytes s))
+    (else (string-length s))))
+
 (define version 6)
 (define release 4)
 
@@ -88,10 +93,10 @@
 ;; with links to RFCs describing the gory details.
 (define mime-type-map
   (make-parameter
-   '(("html" . text/html)
+   '(("html" . #(text/html ((charset . utf-8))))
      ("xhtml" . application/xhtml+xml)
      ("js"  . application/javascript)
-     ("css" . text/css)
+     ("css" . #(text/css ((charset . utf-8))))
      ("png" . image/png)
      ;; A charset parameter is STRONGLY RECOMMENDED by RFC 3023 but it overrides
      ;; document declarations, so don't supply it (assume nothing about files)
@@ -104,7 +109,7 @@
      ("gif" . image/gif)
      ("ico" . image/vnd.microsoft.icon)
      ("svg" . image/svg+xml)
-     ("txt" . text/plain))))
+     ("txt" . #(text/plain ((charset . utf-8)))))))
 (define default-mime-type (make-parameter 'application/octet-stream))
 (define file-extension-handlers (make-parameter '()))
 (define default-host    (make-parameter "localhost")) ;; XXX Can we do without?
@@ -290,7 +295,7 @@
               "  </body>\n"
               "</html>\n")))
     (send-response code: code reason: reason
-                   body: output headers: '((content-type text/html)))))
+                   body: output headers: '((content-type #(text/html ((charset . utf-8))))))))
 
 (define (call-with-input-file* file proc)
   (call-with-input-file file (lambda (p)
@@ -300,7 +305,7 @@
                         #:binary))
 
 (define (send-response #!key code reason status body (headers '()))
-  (let* ((new-headers (cons `(content-length ,(if body (string-length body) 0))
+  (let* ((new-headers (cons `(content-length ,(if body (string-byte-length body) 0))
                             headers))
          (h (intarweb:headers new-headers (response-headers (current-response))))
          (resp (if (and status (not code) (not reason))
@@ -505,7 +510,7 @@
                            (make-response
                             port: out
                             headers: (intarweb:headers
-                                      `((content-type text/html)
+                                      `((content-type #(text/html ((charset . utf-8))))
                                         (server ,(server-software))))))
                           (request-restarter cont))
              (debug! "Handling request from ~A" (remote-address))
diff --git a/tests/run.scm b/tests/run.scm
index d7e3d27..6e6062d 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -1,5 +1,5 @@
 (import test (chicken irregex) (chicken time) (chicken time posix)
-        (chicken file) intarweb)
+        (chicken file) (chicken bytevector) intarweb)
 
 ;; Change this to (use spiffy) when compiling tests
 (load "../spiffy.scm")
@@ -49,6 +49,8 @@
                                     (let ((p (response-port (current-response))))
                                       (display "foo" p)
                                       (close-output-port p))))
+        ("utf8-literal-host" . ,(lambda (continue)
+                                  (send-response body: "Multi-byte 😎")))
         ("subdir-host" . ,(lambda (continue)
                             (parameterize ((root-path "./testweb/subdir"))
                               (continue))))
@@ -225,6 +227,8 @@
                (200 "10.0.0.1")
                "/whats-my-ip" "ip-host"
                send-headers: `((x-forwarded-for "10.0.0.1")))
+(test-response "Multi-byte response content-length ok" (200 (string->utf8 "Multi-byte 😎"))
+               "/whatever" "utf8-literal-host" binary: #t)
 (test-end "miscellaneous")
 
 (test-begin "Caching and other efficiency support")