Semi-graceful error handling

1 files changed, 37 insertions, 15 deletions

diff --git a/weeb/main.scm b/weeb/main.scm
index b6e47ec..d9f5bdf 100644
--- a/weeb/main.scm
+++ b/weeb/main.scm
@@ -29,7 +29,11 @@
   #:use-module (weeb router)
   #:use-module (weeb struct)
   #:use-module (weeb sxml)
-  #:export (run-server))
+  #:export (%enable-web-console
+            run-server))
+
+(define %enable-web-console
+  (make-parameter #f))
 
 (define status-codes
   '((100 . "Continue")
@@ -134,21 +138,39 @@
          (uri    (strip-query-string (getenv "REQUEST_URI"))))
     (make-struct <request> method uri query headers (fcgi-read))))
 
+(define (render-generic-500)
+  (sxml->html
+   `(html
+     (body
+      (h1 "Error")))))
+
+(define (render-web-console stack)
+  (sxml->html
+   `(html
+     (body
+      (h1 "Error")
+      (pre ,(call-with-output-string (cut display-backtrace stack <>)))))))
+
 (define (handle-errors thunk)
-  (catch #t
-    (lambda ()
-      (with-exception-handler
-          (lambda (exn)
-            (let ((captured-stack (make-stack #t)))
-              (throw 'custom-error-key exn captured-stack)))
-        thunk
-        #:unwind? #f))
-    (lambda (key exn captured-stack)
-      (let ((stack-trace (call-with-output-string (cut display-backtrace captured-stack <>))))
-        (list 500 stack-trace)))))
+  (let ((stack #f))
+    (call-with-error-handling
+     thunk
+     #:pass-keys '(quit interrupt)
+     #:on-error
+     (begin
+       (set! stack (make-stack #t))
+       'pass)
+     #:post-error
+     (lambda _
+       (list 500 (if (%enable-web-console)
+                     (render-web-console stack)
+                     (render-generic-500)))))))
 
 (define (run-server router)
   (while (zero? (fcgi-accept))
-    (let* ((request (receive-request))
-           (response (iter-routes request router)))
-      (write-response (any->response response)))))
+    (write-response
+     (any->response
+      (handle-errors
+       (lambda ()
+         (let* ((request (receive-request)))
+           (iter-routes request router))))))))