summaryrefslogtreecommitdiff
path: root/module/web/server.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-04-11 23:30:52 +0200
committerAndy Wingo <wingo@pobox.com>2011-04-11 23:30:52 +0200
commit21c05db45b69f8a62b84c36abc86cb935fa967d7 (patch)
tree743df01da540e7fd628f54894e7d5fbe94b03996 /module/web/server.scm
parent4db853d747ac115f799c93e2de93f5159ad84109 (diff)
parentc89b45299329d034875429804f18768c1ea96713 (diff)
downloadguile-21c05db45b69f8a62b84c36abc86cb935fa967d7.tar.gz
Merge remote branch 'origin/stable-2.0'
Conflicts: GUILE-VERSION test-suite/tests/srfi-4.test
Diffstat (limited to 'module/web/server.scm')
-rw-r--r--module/web/server.scm33
1 files changed, 24 insertions, 9 deletions
diff --git a/module/web/server.scm b/module/web/server.scm
index 4715cae69..c5e623a19 100644
--- a/module/web/server.scm
+++ b/module/web/server.scm
@@ -75,7 +75,7 @@
(define-module (web server)
#:use-module (srfi srfi-9)
#:use-module (rnrs bytevectors)
- #:use-module (rnrs io ports)
+ #:use-module (ice-9 binary-ports)
#:use-module (web request)
#:use-module (web response)
#:use-module (system repl error-handling)
@@ -167,18 +167,33 @@ values."
(warn "Error while accepting client" k args)
(values #f #f #f))))
+;; like call-with-output-string, but actually closes the port (doh)
+(define (call-with-output-string* proc)
+ (let ((port (open-output-string)))
+ (proc port)
+ (let ((str (get-output-string port)))
+ (close-port port)
+ str)))
+
+(define (call-with-output-bytevector* proc)
+ (call-with-values
+ (lambda ()
+ (open-bytevector-output-port))
+ (lambda (port get-bytevector)
+ (proc port)
+ (let ((bv (get-bytevector)))
+ (close-port port)
+ bv))))
+
(define (call-with-encoded-output-string charset proc)
(if (string-ci=? charset "utf-8")
;; I don't know why, but this appears to be faster; at least for
;; examples/debug-sxml.scm (1464 reqs/s versus 850 reqs/s).
- (string->utf8 (call-with-output-string proc))
- (call-with-values
- (lambda ()
- (open-bytevector-output-port))
- (lambda (port get-bytevector)
- (set-port-encoding! port charset)
- (proc port)
- (get-bytevector)))))
+ (string->utf8 (call-with-output-string* proc))
+ (call-with-output-bytevector*
+ (lambda (port)
+ (set-port-encoding! port charset)
+ (proc port)))))
(define (encode-string str charset)
(if (string-ci=? charset "utf-8")