From 675d8c32589f18758406a7eb1910444e56cb6837 Mon Sep 17 00:00:00 2001
From: Christopher Baines <mail@cbaines.net>
Date: Thu, 23 Jan 2025 19:54:50 +0100
Subject: [PATCH] Make the web server exception handler configurable

---
 knots/web-server.scm | 22 +++++++++++++++-------
 1 file changed, 15 insertions(+), 7 deletions(-)

diff --git a/knots/web-server.scm b/knots/web-server.scm
index 3eb97a2..bd0d9f9 100644
--- a/knots/web-server.scm
+++ b/knots/web-server.scm
@@ -166,8 +166,15 @@ on the procedure being called at any particular time."
   ;; Close the client port
   #f)
 
+(define (default-exception-handler exn)
+  (values (build-response #:code 500)
+          ;; TODO Make this configurable
+          (string->utf8
+           "internal server error")))
+
 (define (handle-request handler client
-                        write-response-exception-handler)
+                        write-response-exception-handler
+                        exception-handler)
   (let ((request
          (catch #t
            (lambda ()
@@ -186,11 +193,7 @@ on the procedure being called at any particular time."
                      #vu8()))
             (else
              (with-exception-handler
-                 (lambda (exn)
-                   (values (build-response #:code 500)
-                           ;; TODO Make this configurable
-                           (string->utf8
-                            "internal server error")))
+                 exception-handler
                (lambda ()
                  (call-with-values (lambda ()
                                      (with-stack-and-prompt
@@ -294,6 +297,7 @@ on the procedure being called at any particular time."
         #:unwind? #t))))
 
 (define* (client-loop client handler
+                      exception-handler
                       write-response-exception-handler
                       connection-idle-timeout)
   ;; Always disable Nagle's algorithm, as we handle buffering
@@ -322,7 +326,8 @@ on the procedure being called at any particular time."
           (close-port client))
          (else
           (let ((keep-alive? (handle-request handler client
-                                             write-response-exception-handler)))
+                                             write-response-exception-handler
+                                             exception-handler)))
             (if keep-alive?
                 (loop)
                 (close-port client)))))))
@@ -343,6 +348,8 @@ on the procedure being called at any particular time."
                                          INADDR_LOOPBACK))
                                (port 8080)
                                (socket (make-default-socket family addr port))
+                               (exception-handler
+                                default-exception-handler)
                                (write-response-exception-handler
                                 default-write-response-exception-handler)
                                (connection-idle-timeout 60))
@@ -378,6 +385,7 @@ before sending back to the client."
          ((client . sockaddr)
           (spawn-fiber (lambda ()
                          (client-loop client handler
+                                      exception-handler
                                       write-response-exception-handler
                                       connection-idle-timeout))
                        #:parallel? #t)