[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
03/03: Handle migrations and server startup better
|
From: |
Christopher Baines |
|
Subject: |
03/03: Handle migrations and server startup better |
|
Date: |
Fri, 17 Jun 2022 08:14:31 -0400 (EDT) |
cbaines pushed a commit to branch master
in repository data-service.
commit 8e23d38660eb3939f54f47b0a1f371bd78c58165
Author: Christopher Baines <mail@cbaines.net>
AuthorDate: Fri Jun 17 12:55:05 2022 +0100
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.
---
guix-data-service/web/controller.scm | 255 +++++++++++++++++++----------------
guix-data-service/web/server.scm | 21 ++-
guix-data-service/web/view/html.scm | 11 +-
scripts/guix-data-service.in | 158 ++++++++++++----------
4 files changed, 250 insertions(+), 195 deletions(-)
diff --git a/guix-data-service/web/controller.scm
b/guix-data-service/web/controller.scm
index b344101..b6ecfa7 100644
--- a/guix-data-service/web/controller.scm
+++ b/guix-data-service/web/controller.scm
@@ -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,75 +578,124 @@
"README not found"
"The README.html file does not exist")
#:code 404))))
- (('GET "builds")
- (delegate-to build-controller))
- (('GET "statistics")
- (letpar& ((guix-revisions-count
- (with-thread-postgresql-connection count-guix-revisions))
- (count-derivations
- (with-thread-postgresql-connection count-derivations)))
-
- (render-html
- #:sxml (view-statistics guix-revisions-count
- count-derivations))))
- (('GET "metrics")
- (render-metrics))
- (('GET "revision" args ...)
- (delegate-to revision-controller))
- (('GET "repositories")
- (delegate-to repository-controller))
- (('GET "repository" _ ...)
- (delegate-to repository-controller))
- (('GET "package" _ ...)
- (delegate-to package-controller))
- (('GET "gnu" "store" filename)
- ;; These routes are a little special, as the extensions aren't used for
- ;; content negotiation, so just use the path from the request
- (let ((path (uri-path (request-uri request))))
- (if (string-suffix? ".drv" path)
- (render-derivation (uri-decode path))
- (render-store-item (uri-decode path)))))
- (('GET "gnu" "store" filename "formatted")
- (if (string-suffix? ".drv" filename)
- (render-formatted-derivation (string-append "/gnu/store/" filename))
- (render-html
- #:sxml (general-not-found
- "Not a derivation"
- "The formatted display is only for derivations, where the
filename ends in .drv")
- #:code 404)))
- (('GET "gnu" "store" filename "plain")
- (if (string-suffix? ".drv" filename)
- (let ((raw-drv
- (parallel-via-thread-pool-channel
- (with-thread-postgresql-connection
- (lambda (conn)
- (select-serialized-derivation-by-file-name
- conn
- (string-append "/gnu/store/" filename)))))))
- (if raw-drv
- (render-text raw-drv)
- (not-found (request-uri request))))
- (not-found (request-uri request))))
- (('GET "gnu" "store" filename "narinfos")
- (render-narinfos filename))
- (('GET "gnu" "store" filename "json")
- (if (string-suffix? ".drv" filename)
- (render-json-derivation (string-append "/gnu/store/" filename))
- (render-json-store-item (string-append "/gnu/store/" filename))))
- (('GET "build-servers")
- (delegate-to-with-secret-key-base build-server-controller))
- (('GET "dumps" _ ...)
- (delegate-to dumps-controller))
- (((or 'GET 'POST) "build-server" _ ...)
- (delegate-to-with-secret-key-base build-server-controller))
- (('GET "compare" _ ...) (delegate-to compare-controller))
- (('GET "compare-by-datetime" _ ...) (delegate-to compare-controller))
- (('GET "jobs" _ ...) (delegate-to jobs-controller))
- (('GET "job" job-id) (delegate-to jobs-controller))
- (('GET _ ...) (delegate-to nar-controller))
- ((method path ...)
- (render-html
- #:sxml (general-not-found
- "Page not found"
- "")
- #: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")
+ (letpar& ((guix-revisions-count
+ (with-thread-postgresql-connection count-guix-revisions))
+ (count-derivations
+ (with-thread-postgresql-connection count-derivations)))
+
+ (render-html
+ #:sxml (view-statistics guix-revisions-count
+ count-derivations))))
+ (('GET "metrics")
+ (render-metrics))
+ (('GET "revision" args ...)
+ (delegate-to revision-controller))
+ (('GET "repositories")
+ (delegate-to repository-controller))
+ (('GET "repository" _ ...)
+ (delegate-to repository-controller))
+ (('GET "package" _ ...)
+ (delegate-to package-controller))
+ (('GET "gnu" "store" filename)
+ ;; These routes are a little special, as the extensions aren't used for
+ ;; content negotiation, so just use the path from the request
+ (let ((path (uri-path (request-uri request))))
+ (if (string-suffix? ".drv" path)
+ (render-derivation (uri-decode path))
+ (render-store-item (uri-decode path)))))
+ (('GET "gnu" "store" filename "formatted")
+ (if (string-suffix? ".drv" filename)
+ (render-formatted-derivation (string-append "/gnu/store/" filename))
+ (render-html
+ #:sxml (general-not-found
+ "Not a derivation"
+ "The formatted display is only for derivations, where the
filename ends in .drv")
+ #:code 404)))
+ (('GET "gnu" "store" filename "plain")
+ (if (string-suffix? ".drv" filename)
+ (let ((raw-drv
+ (parallel-via-thread-pool-channel
+ (with-thread-postgresql-connection
+ (lambda (conn)
+ (select-serialized-derivation-by-file-name
+ conn
+ (string-append "/gnu/store/" filename)))))))
+ (if raw-drv
+ (render-text raw-drv)
+ (not-found (request-uri request))))
+ (not-found (request-uri request))))
+ (('GET "gnu" "store" filename "narinfos")
+ (render-narinfos filename))
+ (('GET "gnu" "store" filename "json")
+ (if (string-suffix? ".drv" filename)
+ (render-json-derivation (string-append "/gnu/store/" filename))
+ (render-json-store-item (string-append "/gnu/store/" filename))))
+ (('GET "build-servers")
+ (delegate-to-with-secret-key-base build-server-controller))
+ (('GET "dumps" _ ...)
+ (delegate-to dumps-controller))
+ (((or 'GET 'POST) "build-server" _ ...)
+ (delegate-to-with-secret-key-base build-server-controller))
+ (('GET "compare" _ ...) (delegate-to compare-controller))
+ (('GET "compare-by-datetime" _ ...) (delegate-to compare-controller))
+ (('GET "jobs" _ ...) (delegate-to jobs-controller))
+ (('GET "job" job-id) (delegate-to jobs-controller))
+ (('GET _ ...) (delegate-to nar-controller))
+ ((method path ...)
+ (render-html
+ #:sxml (general-not-found
+ "Page not found"
+ "")
+ #:code 404)))))
diff --git a/guix-data-service/web/server.scm b/guix-data-service/web/server.scm
index 05c0a58..599288c 100644
--- a/guix-data-service/web/server.scm
+++ b/guix-data-service/web/server.scm
@@ -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
diff --git a/guix-data-service/web/view/html.scm
b/guix-data-service/web/view/html.scm
index 3f2c2ae..db1cdc4 100644
--- a/guix-data-service/web/view/html.scm
+++ b/guix-data-service/web/view/html.scm
@@ -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.")))))
diff --git a/scripts/guix-data-service.in b/scripts/guix-data-service.in
index 3e80f03..e0b35c6 100644
--- a/scripts/guix-data-service.in
+++ b/scripts/guix-data-service.in
@@ -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,63 +139,6 @@
(when repl-port
(spawn-server (make-tcp-server-socket #:port repl-port))))
- (when (assoc-ref opts 'update-database)
- (let ((command
- (list (%config 'sqitch)
- "deploy"
- "--db-client" (%config 'sqitch-psql)
- ;; For some reason, sqitch behaves differently when the
- ;; guix-data-service is packaged, and when it's not, so try
- ;; and hack around this here.
- "--chdir" (let ((base (dirname (%config 'sqitch-plan))))
- (if (string-prefix? "/gnu" (%config 'sqitch-plan))
- base
- (dirname base)))
- "--plan-file" (%config 'sqitch-plan)
- "--mode" "change" ; this helps when migrations don't
- ; have the revert bit implemented
- (let* ((database-config (get-database-config))
- (params (string-join
- (map
- (match-lambda
- ((key . val)
- (string-append key "=" val)))
- (filter
- (match-lambda
- ((key . _)
- (not (member key '("user"
- "host"
- "dbname")))))
- database-config))
- "&")))
- (string-append "db:pg://"
- (assoc-ref database-config "user")
- "@"
- (if (string=? (assoc-ref database-config
"host")
- "localhost")
- "" ; This means the unix socket
- ; connection will be used
- (assoc-ref database-config "host"))
- "/"
- (assoc-ref database-config "dbname")
- (if (string-null? params)
- ""
- "?")
- params)))))
- (simple-format #t "running command: ~A\n"
- (string-join command))
- (unless (zero? (apply system* command))
- (simple-format
- (current-error-port)
- "error: sqitch command failed\n")
- (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
@@ -228,20 +173,91 @@
(%show-error-details
(assoc-ref opts 'show-error-details)))
- (start-substitute-query-thread)
+ (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))
- ;; 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";
+ (start-guix-data-service-web-server
+ (assq-ref opts 'port)
(assq-ref opts 'host)
- (assq-ref opts 'port))
+ (assq-ref opts 'secret-key-base)
+ startup-completed))
+ #:statement-timeout
+ (assq-ref opts 'postgresql-statement-timeout)))))
- (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))))
+ (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)
+ "deploy"
+ "--db-client" (%config 'sqitch-psql)
+ ;; For some reason, sqitch behaves differently when the
+ ;; guix-data-service is packaged, and when it's not, so
try
+ ;; and hack around this here.
+ "--chdir" (let ((base (dirname (%config 'sqitch-plan))))
+ (if (string-prefix? "/gnu" (%config
'sqitch-plan))
+ base
+ (dirname base)))
+ "--plan-file" (%config 'sqitch-plan)
+ "--mode" "change" ; this helps when migrations don't
+ ; have the revert bit implemented
+ (let* ((database-config (get-database-config))
+ (params (string-join
+ (map
+ (match-lambda
+ ((key . val)
+ (string-append key "=" val)))
+ (filter
+ (match-lambda
+ ((key . _)
+ (not (member key '("user"
+ "host"
+
"dbname")))))
+ database-config))
+ "&")))
+ (string-append "db:pg://"
+ (assoc-ref database-config "user")
+ "@"
+ (if (string=? (assoc-ref database-config
"host")
+ "localhost")
+ "" ; This means the unix socket
+ ; connection will be used
+ (assoc-ref database-config "host"))
+ "/"
+ (assoc-ref database-config "dbname")
+ (if (string-null? params)
+ ""
+ "?")
+ params)))))
+ (simple-format #t "running command: ~A\n"
+ (string-join command))
+ (unless (zero? (apply system* command))
+ (simple-format
+ (current-error-port)
+ "error: sqitch command failed\n")
+ (exit 1))
+
+ (atomic-box-set! startup-completed #t)))
+
+ (start-substitute-query-thread)
+
+ (join-thread server-thread))))