1 files changed, 60 insertions, 0 deletions
diff --git a/guix-data-service/database.scm b/guix-data-service/database.scm
index 8ed87de..d087e60 100644
--- a/guix-data-service/database.scm
+++ b/guix-data-service/database.scm
@@ -25,6 +25,8 @@
   #:export (get-database-config
             %database-metrics-registry
 
+            run-sqitch
+
             with-postgresql-connection
 
             with-postgresql-connection-per-thread
@@ -110,6 +112,64 @@
 
     conn))
 
+(define (run-sqitch)
+  (with-postgresql-connection
+   "sqitch"
+   (lambda (conn)
+     (with-advisory-session-lock
+      conn
+      'sqitch
+      (lambda ()
+        (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))))))))
+
 (define* (with-postgresql-connection name f #:key (statement-timeout #f))
   (let ((conn (open-postgresql-connection name statement-timeout)))
     (with-throw-handler