From edc8a2e5ae3c89b78fb837d4351f0ddfab8fe474 Mon Sep 17 00:00:00 2001
From: Marius Bakke <marius@gnu.org>
Date: Thu, 16 Jun 2022 22:46:01 +0200
Subject: [PATCH] services: Shepherd can backup and restore PostgreSQL
 databases.

* gnu/services/databases.scm (<postgresql-configuration>)[backup-directory]:
New field.
(postgresql-activation): Create it.
(postgresql-backup-action, postgresql-list-backups-action,
postgresql-restore-action): New variables.
(postgresql-shepherd-service)[actions]: Register them.
* gnu/tests/databases.scm (%postgresql-backup-directory): New variable.
(run-postgresql-test): Trim unused module imports from existing tests.  Add
"insert test data", "backup database", "list backups", "drop database",
"restore database", "update test data", "restore again", and "verify restore"
tests.
---
 gnu/services/databases.scm | 169 ++++++++++++++++++++++++++++++++++++-
 gnu/tests/databases.scm    | 117 ++++++++++++++++++++++++-
 2 files changed, 278 insertions(+), 8 deletions(-)

diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm
index fb3cd3c478..e3e8cc724e 100644
--- a/gnu/services/databases.scm
+++ b/gnu/services/databases.scm
@@ -6,7 +6,7 @@
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2018 Julien Lepiller <julien@lepiller.eu>
 ;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net>
-;;; Copyright © 2020 Marius Bakke <marius@gnu.org>
+;;; Copyright © 2020, 2022 Marius Bakke <marius@gnu.org>
 ;;; Copyright © 2021 David Larsson <david.larsson@selfhosted.xyz>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -176,6 +176,8 @@ (define-record-type* <postgresql-configuration>
                       (default "/var/log/postgresql"))
   (data-directory     postgresql-configuration-data-directory
                       (default "/var/lib/postgresql/data"))
+  (backup-directory   postgresql-configuration-backup-directory
+                      (default "/var/lib/postgresql/backup"))
   (extension-packages postgresql-configuration-extension-packages
                       (default '())))
 
@@ -213,7 +215,7 @@ (define (final-postgresql postgresql extension-packages)
 (define postgresql-activation
   (match-lambda
     (($ <postgresql-configuration> postgresql port locale config-file
-                                   log-directory data-directory
+                                   log-directory data-directory backup-directory
                                    extension-packages)
      #~(begin
          (use-modules (guix build utils)
@@ -245,6 +247,11 @@ (define postgresql-activation
              (mkdir-p #$log-directory)
              (chown #$log-directory (passwd:uid user) (passwd:gid user)))
 
+           ;; Create the backup directory.
+           (when (string? #$backup-directory)
+             (mkdir-p #$backup-directory)
+             (chown #$backup-directory (passwd:uid user) (passwd:gid user)))
+
            ;; Drop privileges and init state directory in a new
            ;; process.  Wait for it to finish before proceeding.
            (match (primitive-fork)
@@ -265,10 +272,155 @@ (define postgresql-activation
                   (primitive-exit 1))))
              (pid (waitpid pid))))))))
 
+(define (postgresql-backup-action postgresql backup-directory)
+  (shepherd-action
+   (name 'backup)
+   (documentation
+    "Back up a database on the running PostgreSQL server.")
+   (procedure
+    #~(lambda* (pid #:optional database #:rest rest)
+        (use-modules (guix build utils)
+                     (ice-9 match)
+                     (srfi srfi-19))
+        (if database
+            (let* ((user (getpwnam "postgres"))
+                   (pg_dump #$(file-append postgresql "/bin/pg_dump"))
+                   (options '("--create" "--clean" "--if-exists"
+                              "--format=d"))
+                   (start-time (current-time))
+                   (date (time-utc->date start-time))
+                   (date-stamp (date->string date "~1_~H-~M-~S"))
+                   (file-name (string-append #$backup-directory "/"
+                                             database "@" date-stamp)))
+              ;; Fork so we can drop privileges.
+              (match (primitive-fork)
+                (0
+                 ;; Exit with a non-zero status code if an exception is thrown.
+                 (dynamic-wind
+                   (const #t)
+                   (lambda ()
+                     (setgid (passwd:gid user))
+                     (setuid (passwd:uid user))
+                     (umask #o027)
+                     (format (current-output-port)
+                             "postgres: creating backup ~a.~%"
+                             (basename file-name))
+                     (mkdir-p (dirname file-name))
+                     (let* ((result (apply system* pg_dump database
+                                           "-f" file-name
+                                           options))
+                            (exit-value (status:exit-val result)))
+                       (if (= 0 exit-value)
+                           (format (current-output-port)
+                                   "postgres: backup of ~a completed successfully.~%"
+                                   database)
+                           (format (current-output-port)
+                                   "postgres: backup of ~a completed with errors.~%"
+                                   database))
+                       (primitive-exit exit-value)))
+                   (lambda ()
+                     (format (current-output-port)
+                             "postgres: backup of ~a failed.~%")
+                     (primitive-exit 1))))
+                (pid (waitpid pid))))
+            (begin
+              (format #t "usage: herd backup postgres DATABASE~%")
+              #f))))))
+
+(define (postgresql-list-backups-action backup-directory)
+  (shepherd-action
+   (name 'list-backups)
+   (documentation
+    "List available PostgreSQL backups.")
+   (procedure
+    #~(lambda* (pid #:optional database #:rest rest)
+        (use-modules (ice-9 ftw)
+                     (srfi srfi-26))
+        (if (file-exists? #$backup-directory)
+            (for-each (cut format #t "~a~%" <>)
+                      (scandir #$backup-directory
+                               (if database
+                                   (cut string-prefix? database <>)
+                                   (negate (cut member <> '("." ".."))))))
+            #f)))))
+
+(define (postgresql-restore-action postgresql backup-directory)
+  (shepherd-action
+   (name 'restore)
+   (documentation
+    "Restore a PostgreSQL backup.")
+   (procedure
+    #~(lambda* (pid #:optional file #:rest rest)
+        (use-modules (ice-9 match)
+                     (ice-9 popen)
+                     (ice-9 rdelim))
+
+        ;; The pg_restore arguments varies slightly if the database is
+        ;; missing vs already present, hence this procedure.
+        (define (database-exists? db)
+          (let* ((psql #$(file-append postgresql "/bin/psql"))
+                 (separator "%")
+                 (port (open-input-pipe (string-append psql " -lqtA"
+                                                       " -F " separator))))
+            (let loop ((line (read-line port)))
+              (cond
+               ((eof-object? line)
+                (close-port port)
+                #f)
+               ((string-prefix? (string-append db separator) line)
+                (close-port port)
+                #t)
+               (else (loop (read-line port)))))))
+
+        (let ((user (getpwnam "postgres"))
+              (pg_restore #$(file-append postgresql "/bin/pg_restore")))
+          (if (and (string? file)
+                   (file-exists? (string-append #$backup-directory "/" file)))
+              (match (primitive-fork)
+                (0
+                 (dynamic-wind
+                   (const #t)
+                   (lambda ()
+                     (setgid (passwd:gid user))
+                     (setuid (passwd:uid user))
+                     (let* ((backup-file (string-append #$backup-directory
+                                                        "/" file))
+                            (database (match (string-split file #\@)
+                                        ((name date) name)))
+                            (create? (not (database-exists? database)))
+                            (options (list "--clean" "--if-exists"
+                                           (if create?
+                                               "--create"
+                                               "--single-transaction"))))
+                       (format (current-output-port)
+                               "postgres: restoring ~a.~%" file)
+                       (let* ((result (apply system* pg_restore backup-file
+                                             "-d" (if create? "postgres" database)
+                                             options))
+                              (exit-value (status:exit-val result)))
+                         (if (= 0 exit-value)
+                             (format (current-output-port)
+                                     "postgres: restore of ~a completed \
+successfully.~%"
+                                     database)
+                             (format (current-output-port)
+                                     "postgres: restore of ~a completed \
+with errors.~%"
+                                     database))
+                         (primitive-exit exit-value))))
+                   (lambda ()
+                     (format #t "postgres: could not restore ~a.~%" file)
+                     (primitive-exit 1))))
+                (pid (waitpid pid)))
+              (begin
+                (format #t "usage: herd restore postgres BACKUP~%")
+                (format #t "hint: see 'herd list-backups postgres'~%")
+                #f)))))))
+
 (define postgresql-shepherd-service
   (match-lambda
     (($ <postgresql-configuration> postgresql port locale config-file
-                                   log-directory data-directory
+                                   log-directory data-directory backup-directory
                                    extension-packages)
      (let* ((pg_ctl-wrapper
              ;; Wrapper script that switches to the 'postgres' user before
@@ -309,8 +461,17 @@ (define postgresql-shepherd-service
               (provision '(postgres))
               (documentation "Run the PostgreSQL daemon.")
               (requirement '(user-processes loopback syslogd))
-              (modules `((ice-9 match)
+              (modules `((ice-9 ftw)
+                         (ice-9 match)
+                         (ice-9 popen)
+                         (ice-9 rdelim)
+                         (srfi srfi-19)
+                         (srfi srfi-26)
                          ,@%default-modules))
+              (actions (list
+                        (postgresql-backup-action postgresql backup-directory)
+                        (postgresql-list-backups-action backup-directory)
+                        (postgresql-restore-action postgresql backup-directory)))
               (start (action "start"))
               (stop (action "stop"))))))))
 
diff --git a/gnu/tests/databases.scm b/gnu/tests/databases.scm
index 296d91d118..4210054d9e 100644
--- a/gnu/tests/databases.scm
+++ b/gnu/tests/databases.scm
@@ -134,6 +134,9 @@ (define %test-memcached
 ;;; The PostgreSQL service.
 ;;;
 
+(define %postgresql-backup-directory
+  "/var/lib/postgresql/backup")
+
 (define %postgresql-log-directory
   "/var/log/postgresql")
 
@@ -195,8 +198,6 @@ (define marionette
           (test-assert "log-file"
             (marionette-eval
              '(begin
-                (use-modules (ice-9 ftw)
-                             (ice-9 match))
                 (current-output-port
                  (open-file "/dev/console" "w0"))
                 (let ((server-log-file
@@ -227,8 +228,7 @@ (define marionette
           (test-assert "database creation"
             (marionette-eval
              '(begin
-                (use-modules (gnu services herd)
-                             (ice-9 popen))
+                (use-modules (ice-9 popen))
                 (current-output-port
                  (open-file "/dev/console" "w0"))
                 (let* ((port (open-pipe*
@@ -241,6 +241,115 @@ (define marionette
                   (string-contains output "1")))
              marionette))
 
+          (test-eq "insert test data"
+            0
+            (marionette-eval
+             '(begin
+                (current-output-port
+                 (open-file "/dev/console" "w0"))
+                (let ((result (system*
+                               #$(file-append postgresql "/bin/psql")
+                               "-tA" "-c" "CREATE TABLE test (name VARCHAR,
+                                                              status VARCHAR);
+INSERT INTO TEST VALUES ('backup', 'pending');"
+                               "root")))
+                       (status:exit-val result)))
+             marionette))
+
+          (test-assert "backup database"
+            (marionette-eval
+             '(with-shepherd-action 'postgres ('backup "root")
+                                    result
+                result)
+             marionette))
+
+          (test-assert "list backups"
+            (marionette-eval
+             '(with-shepherd-action 'postgres ('list-backups)
+                                    result
+                result)
+             marionette))
+
+          (test-eq "drop database"
+            0
+            (marionette-eval
+             '(begin
+                (current-output-port
+                 (open-file "/dev/console" "w0"))
+                (let ((result (system*
+                               #$(file-append postgresql "/bin/psql")
+                               "-tA" "-c" "DROP DATABASE root"
+                               "postgres")))
+                       (status:exit-val result)))
+             marionette))
+
+          (test-assert "restore database"
+            (let ((file-name (marionette-eval
+                              '(begin
+                                 (use-modules (ice-9 ftw)
+                                              (srfi srfi-26))
+                                 (car (scandir #$%postgresql-backup-directory
+                                               (negate (cut member <>
+                                                            '("." ".."))))))
+                              marionette)))
+              (marionette-eval
+               `(with-shepherd-action 'postgres ('restore ,file-name)
+                                      result
+                  result)
+               marionette)))
+
+          (test-equal "update test data"
+            "completed"
+            (marionette-eval
+             '(begin
+                (use-modules (ice-9 popen))
+                (current-output-port
+                 (open-file "/dev/console" "w0"))
+                (let* ((port (open-pipe*
+                              OPEN_READ
+                              #$(file-append postgresql "/bin/psql")
+                              "-tA" "-c" "
+UPDATE test SET status='completed' WHERE name='backup';
+SELECT status FROM test WHERE name='backup';"
+                              "root"))
+                       (output (get-string-all port)))
+                  (close-pipe port)
+                  (string-trim-right output)))
+             marionette))
+
+          (test-assert "restore again"
+            (let ((file-name (marionette-eval
+                              '(begin
+                                 (use-modules (ice-9 ftw)
+                                              (srfi srfi-26))
+                                 (car (scandir #$%postgresql-backup-directory
+                                               (negate (cut member <>
+                                                            '("." ".."))))))
+                              marionette)))
+              (marionette-eval
+               `(with-shepherd-action 'postgres ('restore ,file-name)
+                                      result
+                  result)
+               marionette)))
+
+          (test-equal "verify restore"
+            "pending"
+            (marionette-eval
+             '(begin
+                (use-modules (ice-9 popen))
+                (current-output-port
+                 (open-file "/dev/console" "w0"))
+                (let* ((port (open-pipe*
+                              OPEN_READ
+                              #$(file-append postgresql "/bin/psql")
+                              "-tA" "-c" "
+SELECT status FROM test WHERE name='backup'"
+                              "root"))
+                       (output (get-string-all port)))
+                  (close-pipe port)
+                  (string-trim-right output)))
+             marionette))
+
           (test-end))))
 
   (gexp->derivation "postgresql-test" test))
-- 
2.36.1

