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.

.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

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,9 +182,13 @@
       (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)
+  (define (controller-thunk)
     (match method-and-path-components
       (('GET "assets" rest ...)
        (or (handle-static-assets (string-join rest "/")
@@ -244,6 +237,15 @@
                                                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

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")
+          (h1 "An error occurred")
-          (p "An error occurred.  Sorry about that!")
+          (p "Sorry about that!")
-          ,message
+          ,@(if error
-          (p (a (@ (href "/")) "Try something else?"))))))
+                (match error
+                  ((key . args)
+                   `((b ,key)
+                     (pre ,args))))
+                '())))))

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)