Stop using the knots web-server exception handler

As I want to remove this.

1 files changed, 58 insertions, 40 deletions

diff --git a/guix-data-service/web/server.scm b/guix-data-service/web/server.scm
index 88f7b1a..2e76a72 100644
--- a/guix-data-service/web/server.scm
+++ b/guix-data-service/web/server.scm
@@ -31,6 +31,7 @@
   #:use-module (fibers channels)
   #:use-module (fibers scheduler)
   #:use-module (fibers conditions)
+  #:use-module (knots)
   #:use-module (knots web-server)
   #:use-module (knots resource-pool)
   #:use-module ((guix build syscalls)
@@ -242,49 +243,66 @@ port. Also, the port used can be changed by passing the --port option.\n"
                   (let ((render-metrics (make-render-metrics registry)))
                     (run-knots-web-server
                      (lambda (request)
-                       (metric-increment requests-metric)
+                       (with-exception-handler
+                           (lambda (exn)
+                             (when (resource-pool-timeout-error? exn)
+                               (spawn-fiber
+                                (lambda ()
+                                  (let* ((pool (resource-pool-timeout-error-pool exn))
+                                         (stats (resource-pool-stats pool)))
+                                    (simple-format (current-error-port)
+                                                   "resource pool timeout error: ~A, ~A\n"
+                                                   pool
+                                                   stats)))))
 
-                       (let ((body (read-request-body request)))
-                         (handler request finished? body controller
-                                  secret-key-base
-                                  startup-completed
-                                  render-metrics)))
-                     #:exception-handler
-                     (lambda (exn request)
-                       (when (resource-pool-timeout-error? exn)
-                         (spawn-fiber
-                          (lambda ()
-                            (let* ((pool (resource-pool-timeout-error-pool exn))
-                                   (stats (resource-pool-stats pool)))
-                              (simple-format (current-error-port)
-                                             "resource pool timeout error: ~A, ~A\n"
-                                             pool
-                                             stats)))))
+                             (let ((path-components
+                                    mime-types
+                                    (request->path-components-and-mime-type request)))
+                               (case (most-appropriate-mime-type
+                                      mime-types
+                                      '(text/html application/json))
+                                 ((application/json)
+                                  (apply
+                                   values
+                                   (render-json `((error . ,(if (%show-error-details)
+                                                                (simple-format #f "~A" exn)
+                                                                #f)))
+                                                #:code 500)))
+                                 (else
+                                  (apply
+                                   values
+                                   (render-html #:sxml (error-page
+                                                        (if (%show-error-details)
+                                                            exn
+                                                            #f))
+                                                #:code 500))))))
+                         (lambda ()
+                           (with-exception-handler
+                               (lambda (exn)
+                                 (let* ((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)))
+                                             (print-backtrace-and-exception/knots
+                                              exn
+                                              #:port port)))))
+                                   (display error-string
+                                            (current-error-port)))
 
-                       ;; Use the error output from the default exception handler
-                       (default-exception-handler exn request)
+                                 (raise-exception exn))
+                             (lambda ()
+                               (metric-increment requests-metric)
 
-                       (let ((path-components
-                              mime-types
-                              (request->path-components-and-mime-type request)))
-                         (case (most-appropriate-mime-type
-                                mime-types
-                                '(text/html application/json))
-                           ((application/json)
-                            (apply
-                             values
-                             (render-json `((error . ,(if (%show-error-details)
-                                                          (simple-format #f "~A" exn)
-                                                          #f)))
-                                          #:code 500)))
-                           (else
-                            (apply
-                             values
-                             (render-html #:sxml (error-page
-                                                  (if (%show-error-details)
-                                                      exn
-                                                      #f))
-                                          #:code 500))))))
+                               (let ((body (read-request-body request)))
+                                 (handler request finished? body controller
+                                          secret-key-base
+                                          startup-completed
+                                          render-metrics)))))
+                         #:unwind? #t))
                      #:connection-buffer-size (expt 2 16)
                      #:host host
                      #:port port)))