Improve handling of errors

Adjust the previously unused error page code, and start to use it. Only show
the error if configured to do so, to avoid leaking secret information.

4 files changed, 88 insertions, 68 deletions

diff --git a/.envrc b/.envrc
index 94e9705..7b32f77 100644
--- a/.envrc
+++ b/.envrc
@@ -8,6 +8,8 @@ export GUILE_LOAD_COMPILED_PATH="$PWD:$PWD/tests:$GUILE_LOAD_COMPILED_PATH"
 export GUILE_LOAD_PATH="$PWD:$GUILE_LOAD_PATH"
 export PATH="$PWD/scripts:$PATH"
 
+export GUIX_DATA_SERVICE_SHOW_ERROR_DETAILS=true
+
 if [ -f .local.envrc ]; then
   source_env .local.envrc
 fi
diff --git a/guix-data-service/web/controller.scm b/guix-data-service/web/controller.scm
index 111c2e5..6fb24fd 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -25,6 +25,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
+  #:use-module (system repl error-handling)
   #:use-module (web request)
   #:use-module (web response)
   #:use-module (web uri)
@@ -63,7 +64,8 @@
   #:use-module (guix-data-service web compare controller)
   #:use-module (guix-data-service web revision controller)
   #:use-module (guix-data-service web repository controller)
-  #:export (controller))
+  #:export (%show-error-details
+            controller))
 
 (define cache-control-default-max-age
   (* 60 60 24)) ; One day
@@ -78,19 +80,6 @@
         target
         (list functions ...)))
 
-(define (render-with-error-handling page message)
-  (apply render-html (page))
-  ;; (catch #t
-  ;;   (lambda ()
-  ;;     (receive (sxml headers)
-  ;;         (pretty-print (page))
-  ;;       (render-html sxml headers)))
-  ;;   (lambda (key . args)
-  ;;     (format #t "ERROR: ~a ~a\n"
-  ;;             key args)
-  ;;     (render-html (error-page message))))
-  )
-
 (define (render-derivation conn derivation-file-name)
   (let ((derivation (select-derivation-by-file-name conn
                                                     derivation-file-name)))
@@ -193,57 +182,70 @@
       (static-asset-from-store-renderer)
       render-static-asset))
 
+(define %show-error-details
+  (make-parameter #f))
+
 (define (controller request method-and-path-components
                     mime-types body
                     secret-key-base)
-  (match method-and-path-components
-    (('GET "assets" rest ...)
-     (or (handle-static-assets (string-join rest "/")
-                               (request-headers request))
-         (not-found (request-uri request))))
-    (('GET "healthcheck")
-     (let ((database-status
-            (catch
-              #t
-              (lambda ()
-                (with-postgresql-connection
-                 "web healthcheck"
-                 (lambda (conn)
-                   (number?
-                    (string->number
-                     (first
-                      (count-guix-revisions conn)))))))
-              (lambda (key . args)
-                #f))))
-       (render-json
-        `((status . ,(if database-status
-                         "ok"
-                         "not ok")))
-        #:code (if (eq? database-status
-                        #t)
-                   200
-                   500))))
-    (('GET "README")
-     (let ((filename (string-append (%config 'doc-dir) "/README.html")))
-       (if (file-exists? filename)
-           (render-html
-            #:sxml (readme (call-with-input-file filename
-                             get-string-all)))
-           (render-html
-            #:sxml (general-not-found
-                    "README not found"
-                    "The README.html file does not exist")
-            #:code 404))))
-    (_
-     (with-postgresql-connection
-      "web"
-      (lambda (conn)
-        (controller-with-database-connection request
-                                             method-and-path-components
-                                             mime-types
-                                             body
-                                             conn
-                                             secret-key-base))))))
+  (define (controller-thunk)
+    (match method-and-path-components
+      (('GET "assets" rest ...)
+       (or (handle-static-assets (string-join rest "/")
+                                 (request-headers request))
+           (not-found (request-uri request))))
+      (('GET "healthcheck")
+       (let ((database-status
+              (catch
+                #t
+                (lambda ()
+                  (with-postgresql-connection
+                   "web healthcheck"
+                   (lambda (conn)
+                     (number?
+                      (string->number
+                       (first
+                        (count-guix-revisions conn)))))))
+                (lambda (key . args)
+                  #f))))
+         (render-json
+          `((status . ,(if database-status
+                           "ok"
+                           "not ok")))
+          #:code (if (eq? database-status
+                          #t)
+                     200
+                     500))))
+      (('GET "README")
+       (let ((filename (string-append (%config 'doc-dir) "/README.html")))
+         (if (file-exists? filename)
+             (render-html
+              #:sxml (readme (call-with-input-file filename
+                               get-string-all)))
+             (render-html
+              #:sxml (general-not-found
+                      "README not found"
+                      "The README.html file does not exist")
+              #:code 404))))
+      (_
+       (with-postgresql-connection
+        "web"
+        (lambda (conn)
+          (controller-with-database-connection request
+                                               method-and-path-components
+                                               mime-types
+                                               body
+                                               conn
+                                               secret-key-base))))))
+  (call-with-error-handling
+   controller-thunk
+   #:on-error 'backtrace
+   #:post-error (lambda args
+                  (render-html #:sxml (error-page
+                                       (if (%show-error-details)
+                                           args
+                                           #f))
+                               #:code 500))))
 
 (define (controller-with-database-connection request
                                              method-and-path-components
diff --git a/guix-data-service/web/view/html.scm b/guix-data-service/web/view/html.scm
index e45a67a..0f003ec 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -949,12 +949,16 @@
       (h1 ,header-text)
       (p ,body)))))
 
-(define (error-page message)
+(define* (error-page #:optional error)
   (layout
    #:body
    `(,(header)
      (div (@ (class "container"))
-          (h1 "Error")
-          (p "An error occurred.  Sorry about that!")
-          ,message
-          (p (a (@ (href "/")) "Try something else?"))))))
+          (h1 "An error occurred")
+          (p "Sorry about that!")
+          ,@(if error
+                (match error
+                  ((key . args)
+                   `((b ,key)
+                     (pre ,args))))
+                '())))))
diff --git a/scripts/guix-data-service.in b/scripts/guix-data-service.in
index 5822b52..b1946a5 100644
--- a/scripts/guix-data-service.in
+++ b/scripts/guix-data-service.in
@@ -25,12 +25,14 @@
 
 (use-modules (srfi srfi-1)
              (srfi srfi-37)
+             (ice-9 match)
              (ice-9 textual-ports)
              (system repl server)
              (gcrypt pk-crypto)
              (guix pki)
              (guix-data-service config)
              (guix-data-service web server)
+             (guix-data-service web controller)
              (guix-data-service web nar controller))
 
 (define %default-repl-server-port
@@ -68,6 +70,9 @@
         (option '("update-database") #f #f
                 (lambda (opt name _ result)
                   (alist-cons 'update-database #t result)))
+        (option '("show-error-details") #f #f
+                (lambda (opt name _ result)
+                  (alist-cons 'show-error-details #t result)))
         (option '("port") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'port
@@ -86,6 +91,11 @@
     (narinfo-signing-public-key           . ,%public-key-file)
     (narinfo-signing-private-key          . ,%private-key-file)
     (update-database                      . #f)
+    (show-error-details
+     . ,(match (getenv "GUIX_DATA_SERVICE_SHOW_ERROR_DETAILS")
+          (#f #f)
+          ("" #f)
+          (_ #t)))
     (port                                 . 8765)
     (host                                 . "0.0.0.0")))
 
@@ -170,7 +180,9 @@
                                      key args)
                       (display "warning: not signing narinfo files\n"
                                (current-error-port))
-                      #f))))
+                      #f)))
+                 (%show-error-details
+                  (assoc-ref opts 'show-error-details)))
 
     (start-guix-data-service-web-server (assq-ref opts 'port)
                                         (assq-ref opts 'host)