From b0bb65dbedc35ea885579fe43a8b3b7059417dd0 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Fri, 7 Feb 2025 10:54:59 +0000
Subject: [PATCH] Tweak some web server exception handling

---
 knots/web-server.scm | 111 ++++++++++++++++++++-----------------------
 1 file changed, 51 insertions(+), 60 deletions(-)

diff --git a/knots/web-server.scm b/knots/web-server.scm
index 6e57b12..463578c 100644
--- a/knots/web-server.scm
+++ b/knots/web-server.scm
@@ -252,37 +252,32 @@ on the procedure being called at any particular time."
                                      #:headers '((content-length . 0)))
                      #vu8()))
             (else
-             (call-with-values
-                 (lambda ()
-                   (call-with-escape-continuation
-                    (lambda (return)
-                      (with-exception-handler
-                          (lambda (exn)
-                            (call-with-values
-                                (lambda ()
-                                  (exception-handler exn request))
-                              return))
-                        (lambda ()
-                          (start-stack #t (handler request)))))))
-               (match-lambda*
-                 ((response body)
-                  (sanitize-response request response body))
-                 (other
-                  (let ((stack (make-stack #t))
-                        (exception
-                         (make-exception-with-irritants
-                          (list (make-exception-with-message
-                                 (simple-format
-                                  #f
-                                  "wrong number of values returned from handler, expecting 2, got ~A"
-                                  (length other)))
-                                handler))))
-                    (print-exception
-                     (current-error-port)
-                     (stack-ref stack 2)
-                     '%exception
-                     (list exception))
-                    (raise-exception exception)))))))))
+             (call-with-escape-continuation
+              (lambda (return)
+                (with-exception-handler
+                    (lambda (exn)
+                      (call-with-values
+                          (lambda ()
+                            (exception-handler exn request))
+                        return))
+                  (lambda ()
+                    (start-stack
+                     #t
+                     (call-with-values
+                         (lambda ()
+                           (handler request))
+                       (match-lambda*
+                         ((response body)
+                          (sanitize-response request response body))
+                         (other
+                          (raise-exception
+                           (make-exception-with-irritants
+                            (list (make-exception-with-message
+                                   (simple-format
+                                    #f
+                                    "wrong number of values returned from handler, expecting 2, got ~A"
+                                    (length other)))
+                                  handler)))))))))))))))
       (with-exception-handler
           (lambda (exn)
             (write-response-exception-handler exn request))
@@ -346,35 +341,31 @@ on the procedure being called at any particular time."
   ;; out.
   (setvbuf client 'block buffer-size)
   (setsockopt client IPPROTO_TCP TCP_NODELAY 1)
-  (with-throw-handler #t
-    (lambda ()
-      (let loop ()
-        (cond
-         ((catch #t
-            (lambda ()
-              (or
-               (if (eq? #f connection-idle-timeout)
-                   #f
-                   (perform-operation
-                    (choice-operation (wrap-operation
-                                       (wait-until-port-readable-operation client)
-                                       (const #f))
-                                      (wrap-operation
-                                       (sleep-operation connection-idle-timeout)
-                                       (const #t)))))
-               (eof-object? (lookahead-u8 client))))
-            (lambda _ #t))
-          (close-port client))
-         (else
-          (let ((keep-alive? (handle-request handler client
-                                             read-request-exception-handler
-                                             write-response-exception-handler
-                                             exception-handler)))
-            (if keep-alive?
-                (loop)
-                (close-port client)))))))
-    (lambda (k . args)
-      (close-port client))))
+  (let loop ()
+    (cond
+     ((with-exception-handler
+          (lambda _ #t)
+        (lambda ()
+          (or
+           (if (eq? #f connection-idle-timeout)
+               #f
+               (perform-operation
+                (choice-operation (wrap-operation
+                                   (wait-until-port-readable-operation client)
+                                   (const #f))
+                                  (wrap-operation
+                                   (sleep-operation connection-idle-timeout)
+                                   (const #t)))))
+           (eof-object? (lookahead-u8 client)))))
+      (close-port client))
+     (else
+      (let ((keep-alive? (handle-request handler client
+                                         read-request-exception-handler
+                                         write-response-exception-handler
+                                         exception-handler)))
+        (if keep-alive?
+            (loop)
+            (close-port client)))))))
 
 (define-record-type <web-server>
   (make-web-server socket port)