[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-31-gd4
From: |
Andy Wingo |
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-31-gd41c62f |
Date: |
Fri, 05 Nov 2010 23:43:39 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=d41c62f579f9a820874c1316bea36ea7befadcbe
The branch, master has been updated
via d41c62f579f9a820874c1316bea36ea7befadcbe (commit)
from a4e472294423bb796db3132c73027384fdfff820 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit d41c62f579f9a820874c1316bea36ea7befadcbe
Author: Andy Wingo <address@hidden>
Date: Sat Nov 6 00:36:45 2010 +0100
fix up toy-server error handling
* module/web/toy-server.scm (serve-client): Fix up error handling, so we
catch errors when reading, handling, and writing. If we run
interactively, an error will enter the debugger.
-----------------------------------------------------------------------
Summary of changes:
module/web/toy-server.scm | 80 ++++++++++++++++++++++++++++-----------------
1 files changed, 50 insertions(+), 30 deletions(-)
diff --git a/module/web/toy-server.scm b/module/web/toy-server.scm
index cfef455..bf182fe 100644
--- a/module/web/toy-server.scm
+++ b/module/web/toy-server.scm
@@ -23,6 +23,8 @@
#:use-module (rnrs bytevectors)
#:use-module (web request)
#:use-module (web response)
+ #:use-module (system repl error-handling)
+ #:use-module (ice-9 control)
#:export (run-server simple-get-handler))
(define (make-default-socket family addr port)
@@ -80,35 +82,54 @@
bv))
(build-response #:code 405))))
-;; This abuses the definition of "toy", because it's really
-;; terrible. Not even fit for children. The FIXME is to handle errors
-;; while reading the request and writing the response, not only errors
-;; in the handler.
-;;
+(define (with-stack-and-prompt thunk)
+ (call-with-prompt (default-prompt-tag)
+ (lambda () (start-stack #t (thunk)))
+ (lambda (k proc)
+ (with-stack-and-prompt (lambda () (proc k))))))
+
(define (serve-client handler sock addr)
- (let* ((req (read-request sock))
- (body-str (read-request-body/latin-1 req)))
- (call-with-values (lambda ()
- (catch #t
- (lambda ()
- (handler req body-str))
- (lambda (k . args)
- (if (eq? k 'interrupt)
- (apply throw k args)
- (begin
- (warn "Error while serving client" k args)
- (build-response #:code 500))))))
- (lambda* (response #:optional body)
- (let ((response (write-response response sock)))
- (cond
- ((not body)) ; pass
- ((string? body)
- (write-response-body/latin-1 response body))
- ((bytevector? body)
- (write-response-body/bytevector response body))
- (else
- (error "Expected a string or bytevector for body" body)))))))
- (close-port sock)) ; FIXME: keep socket alive. requires select?
+ (define *on-toy-server-error* (if (batch-mode?) 'pass 'debug))
+ (define *on-handler-error* (if (batch-mode?) 'pass 'debug))
+
+ (call-with-values
+ (lambda ()
+ (call-with-error-handling
+ (lambda ()
+ (let* ((req (read-request sock))
+ (body-str (read-request-body/latin-1 req)))
+ (call-with-error-handling
+ (lambda ()
+ (with-stack-and-prompt
+ (lambda ()
+ (handler req body-str))))
+ #:pass-keys '(quit interrupt)
+ #:on-error *on-handler-error*
+ #:post-error
+ (lambda (k . args)
+ (warn "Error while serving client" k args)
+ (build-response #:code 500)))))
+ #:pass-keys '(quit interrupt)
+ #:on-error *on-toy-server-error*
+ #:post-error
+ (lambda (k . args)
+ (warn "Error reading request" k args)
+ (build-response #:code 400))))
+ (lambda* (response #:optional body)
+ (call-with-error-handling
+ (lambda ()
+ (let ((response (write-response response sock)))
+ (cond
+ ((not body)) ; pass
+ ((string? body)
+ (write-response-body/latin-1 response body))
+ ((bytevector? body)
+ (write-response-body/bytevector response body))
+ (else
+ (error "Expected a string or bytevector for body" body)))))
+ #:on-error *on-toy-server-error*
+ #:pass-keys '(quit interrupt))))
+ (close-port sock)) ; FIXME: keep socket alive. requires select?
(define* (run-server handler
#:key
@@ -132,6 +153,5 @@
(serve-client handler client-socket client-addr))))
(lambda (k . args)
(warn "Interrupt while serving client")
- (close-port client-socket)
- #f))
+ (close-port client-socket)))
(lp (accept-new-client server-socket))))))
hooks/post-receive
--
GNU Guile
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-13-31-gd41c62f,
Andy Wingo <=