cbaines/guix-data-service
1
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Improve handling of errors

Browse source 
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.
This commit is contained in:
Christopher Baines 2020-03-14 12:46:02 +00:00
parent 33958eac79
commit a03e1601de
4 changed files with 88 additions and 68 deletions
Download patch file Download diff file Expand all files Collapse all files

2
.envrc
View file

@ -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

126
guix-data-service/web/controller.scm
View file

@ -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

14
guix-data-service/web/view/html.scm
View file

@ -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))))
'())))))

14
scripts/guix-data-service.in
View file

@ -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)