Only display backtrace when a `CANTIUS_DEBUG' env var is set.

This is to avoid leaking sensitive information through backtraces and exception
messages.

2 files changed, 29 insertions, 11 deletions

diff --git a/src/guile/cantius.scm b/src/guile/cantius.scm
index 726b371..36aafb7 100644
--- a/src/guile/cantius.scm
+++ b/src/guile/cantius.scm
@@ -615,15 +615,26 @@
                   "Redirect...")
           (let/ec escape
             (with-exception-handler
-                (lambda (ex)
-                  (define msg
-                    (exception->msg ex))
+                (if (getenv "CANTIUS_DEBUG")
 
-                  (display msg (current-error-port))
+                    (lambda (ex)
+                      (define msg
+                        (exception->msg ex))
+
+                      (display msg (current-error-port))
+
+                      (escape (build-response* #:headers *%default-headers
+                                               #:code 500)
+                              (string-append msg "\nBacktrace:\n\n"
+                                             (bt-string))))
+
+                    (lambda (ex)
+                      (display (exception->msg ex) (current-error-port))
+
+                      (escape (build-response* #:headers *%default-headers
+                                               #:code 500)
+                              "Internal server error.")))
 
-                  (escape (build-response* #:headers *%default-headers
-                                           #:code 500)
-                          (string-append msg "\nBacktrace:\n\n" (bt-string))))
               (lambda ()
                 (parameterize ((%current-path path)
                                (%current-path-string path-string))
diff --git a/tests/guile/cantius-test.scm b/tests/guile/cantius-test.scm
index f2d2118..db6b28a 100644
--- a/tests/guile/cantius-test.scm
+++ b/tests/guile/cantius-test.scm
@@ -268,12 +268,19 @@ value
    '("/cool-companies//ms/about" "/cool-companies/ms/about?a=b"))
 
   (tu:test-group "error-500"
-    (define error-500-result
-      (get "/cool-companies/ms/product-list"))
+    (for-each
+     (lambda (debug-on?)
+       (when debug-on?
+         (setenv "CANTIUS_DEBUG" ""))
 
-    (tu:test-eqv 500 (rsp:response-code (car error-500-result)))
+       (define error-500-result
+         (get "/cool-companies/ms/product-list"))
 
-    (tu:test-assert (string-contains (cadr error-500-result) "Backtrace")))
+       (tu:test-eqv 500 (rsp:response-code (car error-500-result)))
+
+       (tu:test-assert ((if debug-on? identity not)
+                        (string-contains (cadr error-500-result) "Backtrace"))))
+     '(#f #t)))
 
   (tu:test-group "error-404"
     (define error-404-result