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.

1 files changed, 87 insertions, 71 deletions

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