From 87703b749631acd8ddc2b9eeb36a5be7189a019b Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Thu, 14 Jan 2021 14:13:30 +0100
Subject: [PATCH] Improve PostgreSQL service.

Merge <postgresql-configuration> and <postgresql-config-file> records,
sanitize parameters convertion and logging.

* gnu/services/databases.scm (postgresql-config-file,
postgresql-config-file?, postgresql-config-file-log-destination,
postgresql-config-file-hba-file, postgresql-config-file-ident-file,
postgresql-config-file-extra-config, postgresql-configuration): Remove them.
(postgresql-configuration-log-destination,
postgresql-configuration-hba-file,
postgresql-configuration-ident-file,
postgresql-configuration-socket-directory,
postgresql-configuration-extra-config,
postgresql-configuration-extension-packages): New exported procedures.
(<postgresql-config-file>): Merge it with ...
(<postgresql-configuration>): ... this record, and add a "socket-directory"
field.
(postgresql-config-file-compiler): Replace it with ...
(postgresql-config-file): ... this procedure.
(postgresql-activation): Use "match-record" instead of "match". Create the
"socket-directory" if needed.
(postgresql-shepherd-service): Use "match-record" intead of "match". Pass the
"log-destination" argument to "pg_ctl" if needed.
(postgresql-service): Remove it.
* gnu/tests/databases.scm (%postgresql-log-directory): New variable.
(%postgresql-os): Pass "log-destination" and "extra-config" fields.
(log-file): New test case.
* gnu/tests/guix.scm (%guix-data-service-os): Adapt accordingly.
* doc/guix.texi (Database Services): Ditto.
---
 doc/guix.texi              |  89 +++++-----
 gnu/services/databases.scm | 332 +++++++++++++++++++------------------
 gnu/tests/databases.scm    |  30 +++-
 gnu/tests/guix.scm         |  10 +-
 4 files changed, 245 insertions(+), 216 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index f38e018dff..7fb7652166 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -19302,14 +19302,41 @@ Port on which PostgreSQL should listen.
 @item @code{locale} (default: @code{"en_US.utf8"})
 Locale to use as the default when creating the database cluster.
 
-@item @code{config-file} (default: @code{(postgresql-config-file)})
-The configuration file to use when running PostgreSQL.  The default
-behaviour uses the postgresql-config-file record with the default values
-for the fields.
-
 @item @code{data-directory} (default: @code{"/var/lib/postgresql/data"})
 Directory in which to store the data.
 
+@item @code{log-destination} (default: @code{'syslog})
+The logging method to use for PostgreSQL.  It can be set to a directory,
+such as @code{"/var/log/postgresql"}.  In that case, PostgreSQL will
+write log files to that directory.  The @command{pg_ctl} output will
+also be written to a file named @code{"pg_ctl.log"} in that very
+directory.  This file can be useful to debug PostgreSQL configuration
+errors for instance.
+
+@item @code{hba-file} (default: @code{%default-postgres-hba})
+Filename or G-expression for the host-based authentication
+configuration.
+
+@item @code{ident-file} (default: @code{%default-postgres-ident})
+Filename or G-expression for the user name mapping configuration.
+
+@item @code{socket-directory} (default: @code{"/var/lib/postgresql"})
+Specifies the directory of the Unix-domain socket(s) on which PostgreSQL
+is to listen for connections from client applications.  If set to
+@code{#false} PostgreSQL does not listen on any Unix-domain sockets, in
+which case only TCP/IP sockets can be used to connect to the server.
+
+@item @code{extra-config} (default: @code{'()})
+List of additional keys and values to include in the PostgreSQL config
+file.  Each entry in the list should be a list where the first element
+is the key, and the remaining elements are the values.
+
+The values can be numbers, booleans or strings and will be mapped to
+PostgreSQL parameters types @code{Boolean}, @code{String},
+@code{Numeric}, @code{Numeric with Unit} and @code{Enumerated} described
+@uref{https://www.postgresql.org/docs/current/config-setting.html,
+here}.
+
 @item @code{extension-packages} (default: @code{'()})
 @cindex postgresql extension-packages
 Additional extensions are loaded from packages listed in
@@ -19351,54 +19378,28 @@ dblink as they are already loadable by postgresql.  This field is only
 required to add extensions provided by other packages.
 
 @end table
-@end deftp
 
-@deftp {Data Type} postgresql-config-file
-Data type representing the PostgreSQL configuration file.  As shown in
-the following example, this can be used to customize the configuration
-of PostgreSQL.  Note that you can use any G-expression or filename in
-place of this record, if you already have a configuration file you'd
-like to use for example.
+Here is an example of PostgreSQL configuration, with the log destination
+set to @code{"/var/log/postgresql"} directory.  A few random extra
+config parameters types are passed.
 
 @lisp
 (service postgresql-service-type
          (postgresql-configuration
-          (config-file
-           (postgresql-config-file
-            (log-destination "stderr")
-            (hba-file
-             (plain-file "pg_hba.conf"
-                         "
+          (log-destination "/var/log/postgresql")
+          (hba-file
+           (plain-file "pg_hba.conf"
+                       "
 local	all	all			trust
 host	all	all	127.0.0.1/32 	md5
 host	all	all	::1/128 	md5"))
-            (extra-config
-             '(("session_preload_libraries"     "'auto_explain'")
-               ("random_page_cost"              "2")
-               ("auto_explain.log_min_duration" "'100ms'")
-               ("work_mem"                      "'500MB'")
-               ("logging_collector"             "on")
-               ("log_directory"                 "'/var/log/postgresql'")))))))
+          (extra-config
+           '(("session_preload_libraries"     "auto_explain")
+             ("random_page_cost"              2)
+             ("auto_explain.log_min_duration" "100 ms")
+             ("work_mem"                      "500 MB")
+             ("debug_print_plan"              #t)))))
 @end lisp
-
-@table @asis
-@item @code{log-destination} (default: @code{"syslog"})
-The logging method to use for PostgreSQL.  Multiple values are accepted,
-separated by commas.
-
-@item @code{hba-file} (default: @code{%default-postgres-hba})
-Filename or G-expression for the host-based authentication
-configuration.
-
-@item @code{ident-file} (default: @code{%default-postgres-ident})
-Filename or G-expression for the user name mapping configuration.
-
-@item @code{extra-config} (default: @code{'()})
-List of additional keys and values to include in the PostgreSQL config
-file.  Each entry in the list should be a list where the first element
-is the key, and the remaining elements are the values.
-
-@end table
 @end deftp
 
 @subsubheading MariaDB/MySQL
diff --git a/gnu/services/databases.scm b/gnu/services/databases.scm
index d2dc5f0da8..013ca97227 100644
--- a/gnu/services/databases.scm
+++ b/gnu/services/databases.scm
@@ -38,22 +38,19 @@
   #:use-module (guix gexp)
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
-  #:export (postgresql-config-file
-            postgresql-config-file?
-            postgresql-config-file-log-destination
-            postgresql-config-file-hba-file
-            postgresql-config-file-ident-file
-            postgresql-config-file-extra-config
-
-            postgresql-configuration
+  #:export (postgresql-configuration
             postgresql-configuration?
             postgresql-configuration-postgresql
             postgresql-configuration-port
             postgresql-configuration-locale
-            postgresql-configuration-file
             postgresql-configuration-data-directory
+            postgresql-configuration-log-destination
+            postgresql-configuration-hba-file
+            postgresql-configuration-ident-file
+            postgresql-configuration-socket-directory
+            postgresql-configuration-extra-config
+            postgresql-configuration-extension-packages
 
-            postgresql-service
             postgresql-service-type
 
             memcached-service-type
@@ -98,49 +95,6 @@ host	all	all	::1/128 	md5"))
   (plain-file "pg_ident.conf"
               "# MAPNAME       SYSTEM-USERNAME         PG-USERNAME"))
 
-(define-record-type* <postgresql-config-file>
-  postgresql-config-file make-postgresql-config-file
-  postgresql-config-file?
-  (log-destination postgresql-config-file-log-destination
-                   (default "syslog"))
-  (hba-file        postgresql-config-file-hba-file
-                   (default %default-postgres-hba))
-  (ident-file      postgresql-config-file-ident-file
-                   (default %default-postgres-ident))
-  (extra-config    postgresql-config-file-extra-config
-                   (default '())))
-
-(define-gexp-compiler (postgresql-config-file-compiler
-                       (file <postgresql-config-file>) system target)
-  (match file
-    (($ <postgresql-config-file> log-destination hba-file
-                                 ident-file extra-config)
-     (define (single-quote string)
-       (if string
-           (list "'" string "'")
-           '()))
-
-     (define contents
-       (append-map
-        (match-lambda
-          ((key) '())
-          ((key . #f) '())
-          ((key values ...) `(,key " = " ,@values "\n")))
-
-        `(("log_destination" ,@(single-quote log-destination))
-          ("hba_file" ,@(single-quote hba-file))
-          ("ident_file" ,@(single-quote ident-file))
-          ,@extra-config)))
-
-     (gexp->derivation
-      "postgresql.conf"
-      #~(call-with-output-file (ungexp output "out")
-          (lambda (port)
-            (display
-             (string-append #$@contents)
-             port)))
-      #:local-build? #t))))
-
 (define-record-type* <postgresql-configuration>
   postgresql-configuration make-postgresql-configuration
   postgresql-configuration?
@@ -149,13 +103,59 @@ host	all	all	::1/128 	md5"))
                       (default 5432))
   (locale             postgresql-configuration-locale
                       (default "en_US.utf8"))
-  (config-file        postgresql-configuration-file
-                      (default (postgresql-config-file)))
   (data-directory     postgresql-configuration-data-directory
                       (default "/var/lib/postgresql/data"))
+  (log-destination    postgresql-configuration-log-destination
+                      (default 'syslog))
+  (hba-file           postgresql-configuration-hba-file
+                      (default %default-postgres-hba))
+  (ident-file         postgresql-configuration-ident-file
+                      (default %default-postgres-ident))
+  (socket-directory   postgresql-configuration-socket-directory
+                      (default "/var/run/postgresql"))
+  (extra-config       postgresql-configuration-extra-config
+                      (default '()))
   (extension-packages postgresql-configuration-extension-packages
                       (default '())))
 
+(define (postgresql-config-file config)
+  (match-record config <postgresql-configuration>
+    (log-destination hba-file ident-file socket-directory extra-config)
+    ;; See: https://www.postgresql.org/docs/current/config-setting.html.
+    (define (format-value value)
+      (cond
+       ((boolean? value)
+        (list (if value "on" "off")))
+       ((number? value)
+        (list (number->string value)))
+       (else
+        (list "'" value "'"))))
+
+    (define contents
+      (append-map
+       (match-lambda
+         ((key) '())
+         ((key . #f) '())
+         ((key values ...)
+          `(,key " = " ,@(append-map format-value values) "\n")))
+
+       `(,@(cond
+            ((eq? log-destination 'syslog)
+             '(("log_destination" "syslog")))
+            ((string? log-destination)
+             `(("log_destination" "stderr")
+               ("logging_collector" #t)
+               ("log_directory" ,log-destination)))
+            (else '()))
+         ("hba_file" ,hba-file)
+         ("ident_file" ,ident-file)
+         ,@(if socket-directory
+               `(("unix_socket_directories" ,socket-directory))
+               '())
+         ,@extra-config)))
+
+    (apply mixed-text-file "postgresql.conf" contents)))
+
 (define %postgresql-accounts
   (list (user-group (name "postgres") (system? #t))
         (user-account
@@ -178,124 +178,126 @@ host	all	all	::1/128 	md5"))
          #:builder
          (begin
            (use-modules (guix build utils) (guix build union) (srfi srfi-26))
-           (union-build (assoc-ref %outputs "out") (map (lambda (input) (cdr input)) %build-inputs))
+           (union-build (assoc-ref %outputs "out")
+                        (map (lambda (input) (cdr input)) %build-inputs))
            #t)))
       (inputs
        `(("postgresql" ,postgresql)
          ,@(map (lambda (extension) (list "extension" extension))
                 extension-packages))))))
 
-(define postgresql-activation
-  (match-lambda
-    (($ <postgresql-configuration> postgresql port locale config-file data-directory
-        extension-packages)
-     #~(begin
-         (use-modules (guix build utils)
-                      (ice-9 match))
-
-         (let ((user (getpwnam "postgres"))
-               (initdb (string-append #$(final-postgresql postgresql extension-packages)
-                                      "/bin/initdb"))
-               (initdb-args
-                (append
-                 (if #$locale
-                     (list (string-append "--locale=" #$locale))
-                     '()))))
-           ;; Create db state directory.
-           (mkdir-p #$data-directory)
-           (chown #$data-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)
-             (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))
-                  (primitive-exit
-                   (apply system*
-                          initdb
-                          "-D"
-                          #$data-directory
-                          initdb-args)))
-                (lambda ()
-                  (primitive-exit 1))))
-             (pid (waitpid pid))))))))
-
-(define postgresql-shepherd-service
-  (match-lambda
-    (($ <postgresql-configuration> postgresql port locale config-file data-directory
-        extension-packages)
-     (let* ((pg_ctl-wrapper
-             ;; Wrapper script that switches to the 'postgres' user before
-             ;; launching daemon.
-             (program-file
-              "pg_ctl-wrapper"
-              #~(begin
-                  (use-modules (ice-9 match)
-                               (ice-9 format))
-                  (match (command-line)
-                    ((_ mode)
-                     (let ((user (getpwnam "postgres"))
-                           (pg_ctl #$(file-append (final-postgresql postgresql extension-packages)
-                                                  "/bin/pg_ctl"))
-                           (options (format #f "--config-file=~a -p ~d"
-                                            #$config-file #$port)))
-                       (setgid (passwd:gid user))
-                       (setuid (passwd:uid user))
-                       (execl pg_ctl pg_ctl "-D" #$data-directory "-o" options
-                              mode)))))))
-            (pid-file (in-vicinity data-directory "postmaster.pid"))
-            (action (lambda args
-                      #~(lambda _
-                          (invoke #$pg_ctl-wrapper #$@args)
-                          (match '#$args
-                            (("start")
-                             (call-with-input-file #$pid-file read))
-                            (_ #t))))))
-       (list (shepherd-service
-              (provision '(postgres))
-              (documentation "Run the PostgreSQL daemon.")
-              (requirement '(user-processes loopback syslogd))
-              (modules `((ice-9 match)
-                         ,@%default-modules))
-              (start (action "start"))
-              (stop (action "stop"))))))))
+(define (postgresql-activation config)
+  (match-record config <postgresql-configuration>
+    (postgresql port locale data-directory log-destination socket-directory
+                extension-packages)
+    #~(begin
+        (use-modules (guix build utils)
+                     (ice-9 match))
+
+        (let ((user (getpwnam "postgres"))
+              (initdb (string-append
+                       #$(final-postgresql postgresql extension-packages)
+                       "/bin/initdb"))
+              (initdb-args
+               (append
+                (if #$locale
+                    (list (string-append "--locale=" #$locale))
+                    '()))))
+          ;; Create db state directory.
+          (mkdir-p #$data-directory)
+          (chown #$data-directory (passwd:uid user) (passwd:gid user))
+
+          (when (string? #$socket-directory)
+            (mkdir-p #$socket-directory)
+            (chown #$socket-directory (passwd:uid user) (passwd:gid user)))
+
+          (when (string? #$log-destination)
+            (mkdir-p #$log-destination)
+            (chown #$log-destination (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)
+            (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))
+                 (primitive-exit
+                  (apply system*
+                         initdb
+                         "-D"
+                         #$data-directory
+                         initdb-args)))
+               (lambda ()
+                 (primitive-exit 1))))
+            (pid (waitpid pid)))))))
+
+(define (postgresql-shepherd-service config)
+  (match-record config <postgresql-configuration>
+    (postgresql port locale data-directory log-destination extension-packages)
+    (let* ((config-file (postgresql-config-file config))
+           (pg_ctl-wrapper
+            ;; Wrapper script that switches to the 'postgres' user before
+            ;; launching daemon.
+            (program-file
+             "pg_ctl-wrapper"
+             #~(begin
+                 (use-modules (ice-9 match)
+                              (ice-9 format))
+                 (match (command-line)
+                   ((_ mode)
+                    (let ((user (getpwnam "postgres"))
+                          (pg_ctl #$(file-append
+                                     (final-postgresql postgresql
+                                                       extension-packages)
+                                     "/bin/pg_ctl"))
+                          (options
+                           (format #f "--config-file=~a -p ~d"
+                                   #$config-file
+                                   #$port)))
+                      (setgid (passwd:gid user))
+                      (setuid (passwd:uid user))
+                      (execl pg_ctl pg_ctl "-D" #$data-directory
+                             #$@(if (string? log-destination)
+                                    (list "-l"
+                                          (string-append log-destination
+                                                         "/pg_ctl.log"))
+                                    '())
+                             "-o" options
+                             mode)))))))
+           (pid-file (in-vicinity data-directory "postmaster.pid"))
+           (action (lambda args
+                     #~(lambda _
+                         (invoke #$pg_ctl-wrapper #$@args)
+                         (match '#$args
+                           (("start")
+                            (call-with-input-file #$pid-file read))
+                           (_ #t))))))
+      (list (shepherd-service
+             (provision '(postgres))
+             (documentation "Run the PostgreSQL daemon.")
+             (requirement '(user-processes loopback syslogd))
+             (modules `((ice-9 match)
+                        ,@%default-modules))
+             (start (action "start"))
+             (stop (action "stop")))))))
 
 (define postgresql-service-type
-  (service-type (name 'postgresql)
-                (extensions
-                 (list (service-extension shepherd-root-service-type
-                                          postgresql-shepherd-service)
-                       (service-extension activation-service-type
-                                          postgresql-activation)
-                       (service-extension account-service-type
-                                          (const %postgresql-accounts))
-                       (service-extension profile-service-type
-                                          (compose list postgresql-configuration-postgresql))))))
-
-(define-deprecated (postgresql-service #:key (postgresql postgresql)
-                                       (port 5432)
-                                       (locale "en_US.utf8")
-                                       (config-file (postgresql-config-file))
-                                       (data-directory "/var/lib/postgresql/data")
-                                       (extension-packages '()))
-  postgresql-service-type
-  "Return a service that runs @var{postgresql}, the PostgreSQL database server.
-
-The PostgreSQL daemon loads its runtime configuration from @var{config-file}
-and stores the database cluster in @var{data-directory}."
-  (service postgresql-service-type
-           (postgresql-configuration
-            (postgresql postgresql)
-            (port port)
-            (locale locale)
-            (config-file config-file)
-            (data-directory data-directory)
-            (extension-packages extension-packages))))
+  (service-type
+   (name 'postgresql)
+   (extensions
+    (list (service-extension shepherd-root-service-type
+                             postgresql-shepherd-service)
+          (service-extension activation-service-type
+                             postgresql-activation)
+          (service-extension account-service-type
+                             (const %postgresql-accounts))
+          (service-extension
+           profile-service-type
+           (compose list postgresql-configuration-postgresql))))))
 
 
 ;;;
diff --git a/gnu/tests/databases.scm b/gnu/tests/databases.scm
index 31d5ae4c6a..499ab8c9d1 100644
--- a/gnu/tests/databases.scm
+++ b/gnu/tests/databases.scm
@@ -24,6 +24,7 @@
   #:use-module (gnu system shadow)
   #:use-module (gnu system vm)
   #:use-module (gnu services)
+  #:use-module (gnu services base)
   #:use-module (gnu services databases)
   #:use-module (gnu services networking)
   #:use-module (gnu packages databases)
@@ -214,11 +215,21 @@
 ;;; The PostgreSQL service.
 ;;;
 
+(define %postgresql-log-directory
+  "/var/log/postgresql")
+
 (define %postgresql-os
   (simple-operating-system
    (service postgresql-service-type
             (postgresql-configuration
-             (postgresql postgresql-10)))))
+             (postgresql postgresql-10)
+             (log-destination %postgresql-log-directory)
+             (extra-config
+              '(("session_preload_libraries" "auto_explain")
+                ("random_page_cost" 2)
+                ("auto_explain.log_min_duration" "100 ms")
+                ("work_mem" "500 MB")
+                ("debug_print_plan" #t)))))))
 
 (define (run-postgresql-test)
   "Run tests in %POSTGRESQL-OS."
@@ -254,6 +265,23 @@
                 (start-service 'postgres))
              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
+                       (string-append #$%postgresql-log-directory
+                                      "/pg_ctl.log")))
+                  (and (file-exists? server-log-file)
+                       (display
+                        (call-with-input-file server-log-file
+                          get-string-all)))
+                  #t))
+             marionette))
+
           (test-end)
           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 
diff --git a/gnu/tests/guix.scm b/gnu/tests/guix.scm
index af7d8f0b21..4446c4e36b 100644
--- a/gnu/tests/guix.scm
+++ b/gnu/tests/guix.scm
@@ -157,14 +157,12 @@
    (service postgresql-service-type
             (postgresql-configuration
              (postgresql postgresql-10)
-             (config-file
-              (postgresql-config-file
-               (hba-file
-                (plain-file "pg_hba.conf"
-                            "
+             (hba-file
+              (plain-file "pg_hba.conf"
+                          "
 local	all	all			trust
 host	all	all	127.0.0.1/32 	trust
-host	all	all	::1/128 	trust"))))))
+host	all	all	::1/128 	trust"))))
    (service guix-data-service-type
             (guix-data-service-configuration
              (host "0.0.0.0")))
-- 
2.29.2

