[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
03/06: Improve handling of errors
|
From: |
Christopher Baines |
|
Subject: |
03/06: Improve handling of errors |
|
Date: |
Sat, 14 Mar 2020 09:15:26 -0400 (EDT) |
cbaines pushed a commit to branch master
in repository data-service.
commit a03e1601deda589d5b11a8472438e6fe60c39666
Author: Christopher Baines <address@hidden>
AuthorDate: Sat Mar 14 12:46:02 2020 +0000
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 | 2 +
guix-data-service/web/controller.scm | 126 ++++++++++++++++++-----------------
guix-data-service/web/view/html.scm | 14 ++--
scripts/guix-data-service.in | 14 +++-
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)
- branch master updated (baeae56 -> ded4df6), Christopher Baines, 2020/03/14
- 02/06: Increase the batch size for fetching builds/narinfo files, Christopher Baines, 2020/03/14
- 01/06: Set an order for select-outputs-without-known-nar-entries, Christopher Baines, 2020/03/14
- 04/06: Improve the 404 pages, Christopher Baines, 2020/03/14
- 05/06: Provide more information if the server can't bind the port, Christopher Baines, 2020/03/14
- 06/06: Move and improve the "starting the server" message, Christopher Baines, 2020/03/14
- 03/06: Improve handling of errors,
Christopher Baines <=