From 40cf026ea4df3733eebeb5cd37524c2a6d225e4b Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Mon, 3 Feb 2025 11:19:52 +0100
Subject: [PATCH] Rework exception handling in the web server

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

diff --git a/knots/web-server.scm b/knots/web-server.scm
index 392a5ff..4a9bc0e 100644
--- a/knots/web-server.scm
+++ b/knots/web-server.scm
@@ -18,6 +18,7 @@
 (define-module (knots web-server)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-71)
+  #:use-module (ice-9 control)
   #:use-module (fibers)
   #:use-module (fibers timers)
   #:use-module (fibers operations)
@@ -30,6 +31,7 @@
   #:use-module (ice-9 exceptions)
   #:use-module ((srfi srfi-9 gnu) #:select (set-field))
   #:use-module (system repl error-handling)
+  #:use-module (web uri)
   #:use-module (web http)
   #:use-module (web request)
   #:use-module (web response)
@@ -167,6 +169,24 @@ on the procedure being called at any particular time."
   #f)
 
 (define (default-exception-handler exn request)
+  (let* ((stack (make-stack #t))
+         (error-string
+          (call-with-output-string
+            (lambda (port)
+              (simple-format
+               port
+               "exception when processing: ~A ~A\n"
+               (request-method request)
+               (uri-path (request-uri request)))
+              (display-backtrace stack port 4)
+              (print-exception
+               port
+               (stack-ref stack 4)
+               '%exception
+               (list exn))))))
+    (display error-string
+             (current-error-port)))
+
   (values (build-response #:code 500)
           ;; TODO Make this configurable
           (string->utf8
@@ -192,47 +212,37 @@ on the procedure being called at any particular time."
                                      #:headers '((content-length . 0)))
                      #vu8()))
             (else
-             (with-exception-handler
-                 (lambda (exn)
-                   (exception-handler exn request))
-               (lambda ()
-                 (call-with-values (lambda ()
-                                     (with-stack-and-prompt
-                                      (lambda ()
-                                        (with-throw-handler #t
-                                          (lambda ()
-                                            (handler request))
-                                          (lambda (key . args)
-                                            (let ((stack (make-stack #t)))
-                                              (print-exception
-                                               (current-error-port)
-                                               (stack-ref stack 2)
-                                               key
-                                               args)
-                                              (display-backtrace
-                                               stack
-                                               (current-error-port)
-                                               2)))))))
-                   (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))))))
-               #:unwind? #t)))))
+             (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)))))))))
       (with-exception-handler
           (lambda (exn)
             (write-response-exception-handler exn request))