guix
/
data-service
mirror of git://git.savannah.gnu.org/guix/data-service.git
2
0
Fork 0
Code Issues Releases Wiki Activity

Handle migrations and server startup better 

The server part of the guix-data-service doesn't work great as a guix service,
since it often fails to start if the migrations take any time at all.

To address this, start the server before running the migrations, and serve the
pages that work without the database, plus a general 503 response. Once the
migrations have completed, switch to the normal behaviour.
This commit is contained in:
Christopher Baines 2022-06-17 12:55:05 +01:00
parent d19eb07138
commit 8e23d38660
4 changed files with 249 additions and 194 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

113
guix-data-service/web/controller.scm
View File

@ -71,6 +71,7 @@
#:use-module (guix-data-service web repository controller)
#:use-module (guix-data-service web package controller)
#:export (%show-error-details
handle-static-assets
controller))
(define cache-control-default-max-age
@ -513,16 +514,26 @@
(define* (controller request method-and-path-components
mime-types body
secret-key-base)
(define (controller-thunk)
secret-key-base
startup-completed?)
(define (running-controller-thunk)
(actual-controller request
method-and-path-components
mime-types
body
secret-key-base))
(define (startup-controller-thunk)
(or
(base-controller request method-and-path-components)
(render-html
#:sxml (server-starting-up-page)
#:code 503)))
(call-with-error-handling
controller-thunk
(if startup-completed?
running-controller-thunk
startup-controller-thunk)
#:on-error 'backtrace
#:post-error (lambda args
(render-html #:sxml (error-page
@ -531,51 +542,8 @@
#f))
#:code 500))))
(define (actual-controller request
method-and-path-components
mime-types
body
secret-key-base)
(define path
(uri-path (request-uri request)))
(define (delegate-to f)
(or (f request
method-and-path-components
mime-types
body)
(render-html
#:sxml (general-not-found
"Page not found"
"")
#:code 404)))
(define (delegate-to-with-secret-key-base f)
(or (f request
method-and-path-components
mime-types
body
secret-key-base)
(render-html
#:sxml (general-not-found
"Page not found"
"")
#:code 404)))
(define (base-controller request method-and-path-components)
(match method-and-path-components
(('GET)
(render-html
#:sxml (index
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(map
(lambda (git-repository-details)
(cons
git-repository-details
(all-branches-with-most-recent-commit
conn (first git-repository-details))))
(all-git-repositories conn))))))))
(('GET "assets" rest ...)
(or (handle-static-assets (string-join rest "/")
(request-headers request))
@ -610,6 +578,55 @@
"README not found"
"The README.html file does not exist")
#:code 404))))
((method path ...) #f)))
(define (actual-controller request
method-and-path-components
mime-types
body
secret-key-base)
(define path
(uri-path (request-uri request)))
(define (delegate-to f)
(or (f request
method-and-path-components
mime-types
body)
(render-html
#:sxml (general-not-found
"Page not found"
"")
#:code 404)))
(define (delegate-to-with-secret-key-base f)
(or (f request
method-and-path-components
mime-types
body
secret-key-base)
(render-html
#:sxml (general-not-found
"Page not found"
"")
#:code 404)))
(or
(base-controller request method-and-path-components)
(match method-and-path-components
(('GET)
(render-html
#:sxml (index
(parallel-via-thread-pool-channel
(with-thread-postgresql-connection
(lambda (conn)
(map
(lambda (git-repository-details)
(cons
git-repository-details
(all-branches-with-most-recent-commit
conn (first git-repository-details))))
(all-git-repositories conn))))))))
(('GET "builds")
(delegate-to build-controller))
(('GET "statistics")
@ -681,4 +698,4 @@
#:sxml (general-not-found
"Page not found"
"")
#:code 404))))
#:code 404)))))

21
guix-data-service/web/server.scm
View File

@ -24,12 +24,22 @@
#:use-module (web request)
#:use-module (web uri)
#:use-module (system repl error-handling)
#:use-module (ice-9 atomic)
#:use-module (fibers web server)
#:use-module (guix-data-service web controller)
#:use-module (guix-data-service web util)
#:export (start-guix-data-service-web-server))
(define (handler request body controller secret-key-base)
(define (check-startup-completed startup-completed)
(if (atomic-box-ref startup-completed)
(begin
;; Just in case this atomic-box-ref is expensive, only do it when
;; necessary
(set! check-startup-completed (const #t))
#t)
#f))
(define (handler request body controller secret-key-base startup-completed)
(display
(format #f "~a ~a\n"
(request-method request)
@ -42,14 +52,17 @@
request-components)
mime-types
body
secret-key-base))))
secret-key-base
(check-startup-completed startup-completed)))))
(define* (start-guix-data-service-web-server port host secret-key-base)
(define* (start-guix-data-service-web-server port host secret-key-base
startup-completed)
(call-with-error-handling
(lambda ()
(run-server (lambda (request body)
(handler request body controller
secret-key-base))
secret-key-base
startup-completed))
#:host host
#:port port))
#:on-error 'backtrace

11
guix-data-service/web/view/html.scm
View File

@ -50,7 +50,8 @@
view-narinfos
view-store-item
view-derivation-source-file
error-page))
error-page
server-starting-up-page))
(define* (header)
`(nav
@ -1004,3 +1005,11 @@
`((b ,key)
(pre ,args))))
'())))))
(define* (server-starting-up-page)
(layout
#:body
`(,(header)
(div (@ (class "container"))
(h1 "Server is starting up")
(p "Database migrations are running, this can take some time.")))))

126
scripts/guix-data-service.in
View File

@ -26,6 +26,8 @@
(use-modules (srfi srfi-1)
(srfi srfi-37)
(ice-9 match)
(ice-9 atomic)
(ice-9 threads)
(ice-9 textual-ports)
(system repl server)
(system repl repl)
@ -137,6 +139,72 @@
(when repl-port
(spawn-server (make-tcp-server-socket #:port repl-port))))
(parameterize ((%narinfo-signing-public-key
(catch
'system-error
(lambda ()
(and=> (assoc-ref opts 'narinfo-signing-public-key)
read-file-sexp))
(lambda (key . args)
(simple-format
(current-error-port)
"warning: failed to load narinfo signing public key from ~A\n"
(assoc-ref opts 'narinfo-signing-private-key))
(simple-format (current-error-port)
" ~A: ~A\n"
key args))))
(%narinfo-signing-private-key
(catch
'system-error
(lambda ()
(and=> (assoc-ref opts 'narinfo-signing-private-key)
read-file-sexp))
(lambda (key . args)
(simple-format
(current-error-port)
"warning: failed to load narinfo signing private key from ~A\n"
(assoc-ref opts 'narinfo-signing-private-key))
(simple-format (current-error-port)
" ~A: ~A\n"
key args)
(display "warning: not signing narinfo files\n"
(current-error-port))
#f)))
(%show-error-details
(assoc-ref opts 'show-error-details)))
(let* ((startup-completed
(make-atomic-box
(if (assoc-ref opts 'update-database)
#f
#t)))
(server-thread
(call-with-new-thread
(lambda ()
(with-postgresql-connection-per-thread
"web"
(lambda ()
;; Provide some visual space between the startup output and the server
;; starting
(simple-format #t "\n\nStarting the server on http://~A:~A/\n\n"
(assq-ref opts 'host)
(assq-ref opts 'port))
(start-guix-data-service-web-server
(assq-ref opts 'port)
(assq-ref opts 'host)
(assq-ref opts 'secret-key-base)
startup-completed))
#:statement-timeout
(assq-ref opts 'postgresql-statement-timeout)))))
(pid-file (assq-ref opts 'pid-file)))
(when pid-file
(call-with-output-file pid-file
(lambda (port)
(simple-format port "~A\n" (getpid)))))
(when (assoc-ref opts 'update-database)
(let ((command
(list (%config 'sqitch)
@ -186,62 +254,10 @@
(simple-format
(current-error-port)
"error: sqitch command failed\n")
(exit 1))))
(exit 1))
(let ((pid-file (assq-ref opts 'pid-file)))
(when pid-file
(call-with-output-file pid-file
(lambda (port)
(simple-format port "~A\n" (getpid))))))
(parameterize ((%narinfo-signing-public-key
(catch
'system-error
(lambda ()
(and=> (assoc-ref opts 'narinfo-signing-public-key)
read-file-sexp))
(lambda (key . args)
(simple-format
(current-error-port)
"warning: failed to load narinfo signing public key from ~A\n"
(assoc-ref opts 'narinfo-signing-private-key))
(simple-format (current-error-port)
" ~A: ~A\n"
key args))))
(%narinfo-signing-private-key
(catch
'system-error
(lambda ()
(and=> (assoc-ref opts 'narinfo-signing-private-key)
read-file-sexp))
(lambda (key . args)
(simple-format
(current-error-port)
"warning: failed to load narinfo signing private key from ~A\n"
(assoc-ref opts 'narinfo-signing-private-key))
(simple-format (current-error-port)
" ~A: ~A\n"
key args)
(display "warning: not signing narinfo files\n"
(current-error-port))
#f)))
(%show-error-details
(assoc-ref opts 'show-error-details)))
(atomic-box-set! startup-completed #t)))
(start-substitute-query-thread)
;; Provide some visual space between the startup output and the server
;; starting
(simple-format #t "\n\nStarting the server on http://~A:~A/\n\n"
(assq-ref opts 'host)
(assq-ref opts 'port))
(with-postgresql-connection-per-thread
"web"
(lambda ()
(start-guix-data-service-web-server
(assq-ref opts 'port)
(assq-ref opts 'host)
(assq-ref opts 'secret-key-base)))
#:statement-timeout
(assq-ref opts 'postgresql-statement-timeout))))
(join-thread server-thread))))