[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-31-gd41c62f

[Andy Wingo]

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