services: rsync: Allow configuring several rsync "modules".

Until now the rsync service would export a single module, named
"files".  This allows users to specify as many modules as they want, in
line with rsyncd.conf(5).

* gnu/services/rsync.scm (warn-share-field-deprecation): New procedure.
(<rsync-configuration>)[modules]: New field.
[share-path, share-comment, read-only?, timeout]: Mark as deprecated.
(<rsync-module>): New record type.
(%default-modules): New variable.
(rsync-configuration-modules): New procedure.
(rsync-activation): Create the directory of each module.
(rsync-config-file): Generate configuration for each module.
(rsync-service-type)[description]: New field.
* doc/guix.texi (Networking Services): Adjust documentation.  Augment
example.

1 files changed, 123 insertions, 47 deletions

diff --git a/gnu/services/rsync.scm b/gnu/services/rsync.scm
index 6e27edde25..d456911563 100644
--- a/gnu/services/rsync.scm
+++ b/gnu/services/rsync.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Oleg Pykhalov <go.wigust@gmail.com>
+;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,11 +26,23 @@
   #:use-module (gnu packages admin)
   #:use-module (guix records)
   #:use-module (guix gexp)
+  #:use-module (guix diagnostics)
+  #:use-module (guix i18n)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:export (rsync-configuration
             rsync-configuration?
+            rsync-configuration-modules
+
+            rsync-module
+            rsync-module?
+            rsync-module-name
+            rsync-module-file-name
+            rsync-module-comment
+            rsync-module-read-only
+            rsync-module-timeout
+
             rsync-service-type))
 
 ;;;; Commentary:
@@ -39,6 +52,13 @@
 ;;;
 ;;;; Code:
 
+(define-with-syntax-properties (warn-share-field-deprecation (value properties))
+  (unless (unspecified? value)
+    (warning (source-properties->location properties)
+             (G_ "the 'share-path' and 'share-comment' fields is deprecated, \
+please use 'modules' instead~%")))
+  value)
+
 (define-record-type* <rsync-configuration>
   rsync-configuration
   make-rsync-configuration
@@ -56,15 +76,22 @@
   (log-file      rsync-configuration-log-file             ; string
                  (default "/var/log/rsyncd.log"))
   (use-chroot?   rsync-configuration-use-chroot?          ; boolean
-                 (default #t))
+                 (sanitize warn-share-field-deprecation)
+                 (default *unspecified*))
+  (modules       rsync-configuration-actual-modules ;list of <rsync-module>
+                 (default %default-modules))  ;TODO: eventually remove default
   (share-path    rsync-configuration-share-path           ; string
-                 (default "/srv/rsyncd"))
+                 (sanitize warn-share-field-deprecation)
+                 (default *unspecified*))
   (share-comment rsync-configuration-share-comment        ; string
-                 (default "Rsync share"))
+                 (sanitize warn-share-field-deprecation)
+                 (default *unspecified*))
   (read-only?    rsync-configuration-read-only?           ; boolean
-                 (default #f))
+                 (sanitize warn-share-field-deprecation)
+                 (default *unspecified*))
   (timeout       rsync-configuration-timeout              ; integer
-                 (default 300))
+                 (sanitize warn-share-field-deprecation)
+                 (default *unspecified*))
   (user          rsync-configuration-user                 ; string
                  (default "root"))
   (group         rsync-configuration-group                ; string
@@ -74,6 +101,45 @@
   (gid           rsync-configuration-gid                  ; string
                  (default "rsyncd")))
 
+;; Rsync "module": a directory exported the rsync protocol.
+(define-record-type* <rsync-module>
+  rsync-module make-rsync-module
+  rsync-module?
+  (name          rsync-module-name)               ;string
+  (file-name     rsync-module-file-name)          ;string
+  (comment       rsync-module-comment             ;string
+                 (default ""))
+  (read-only?    rsync-module-read-only?          ;boolean
+                 (default #t))
+  (chroot?       rsync-module-chroot?             ;boolean
+                 (default #t))
+  (timeout       rsync-module-timeout             ;integer
+                 (default 300)))
+
+(define %default-modules
+  ;; Default modules, provided for backward compatibility.
+  (list (rsync-module (name "files")
+                      (file-name "/srv/rsyncd")
+                      (comment "Rsync share")
+                      (read-only? #f))))          ;yes, that was the default
+
+(define (rsync-configuration-modules config)
+  (match-record config <rsync-configuration>
+    (modules
+     share-path share-comment use-chroot? read-only? timeout) ;deprecated
+    (if (unspecified? share-path)
+        (rsync-configuration-actual-modules config)
+        (list (rsync-module                       ;backward compatibility
+               (name "files")
+               (file-name share-path)
+               (comment "Rsync share")
+               (chroot?
+                (if (unspecified? use-chroot?) #t use-chroot?))
+               (read-only?
+                (if (unspecified? read-only?) #f read-only?))
+               (timeout
+                (if (unspecified? timeout) 300 timeout)))))))
+
 (define (rsync-account config)
   "Return the user accounts and user groups for CONFIG."
   (let ((rsync-user (if (rsync-configuration-uid config)
@@ -96,55 +162,62 @@
   "Return the activation GEXP for CONFIG."
   (with-imported-modules '((guix build utils))
     #~(begin
-        (let ((share-directory  #$(rsync-configuration-share-path config))
-              (user  (getpw (if #$(rsync-configuration-uid config)
+        (let ((user  (getpw (if #$(rsync-configuration-uid config)
                                 #$(rsync-configuration-uid config)
                                 #$(rsync-configuration-user config))))
               (group (getpw (if #$(rsync-configuration-gid config)
                                 #$(rsync-configuration-gid config)
                                 #$(rsync-configuration-group config)))))
           (mkdir-p (dirname #$(rsync-configuration-pid-file config)))
-          (and=> share-directory mkdir-p)
-          (chown share-directory
-                 (passwd:uid user)
-                 (group:gid group))))))
+          (for-each (lambda (directory)
+                      (mkdir-p directory)
+                      (chown directory (passwd:uid user) (group:gid group)))
+                    '#$(map rsync-module-file-name
+                            (rsync-configuration-modules config)))))))
 
-(define rsync-config-file
+(define (rsync-config-file config)
   ;; Return the rsync configuration file corresponding to CONFIG.
-  (match-lambda
-    (($ <rsync-configuration> package address port-number pid-file lock-file log-file
-                              use-chroot? share-path share-comment read-only?
-                              timeout user group uid gid)
-     (if (not (string=? user "root"))
-         (cond
-          ((<= port-number 1024)
-           (error (string-append "rsync-service: to run on port "
-                                 (number->string port-number)
-                                 ", user must be root.")))
-          (use-chroot?
-           (error (string-append "rsync-service: to run in a chroot"
-                                 ", user must be root.")))
-          (uid
-           (error "rsync-service: to use uid, user must be root."))
-          (gid
-           (error "rsync-service: to use gid, user must be root."))))
-     (mixed-text-file
-      "rsync.conf"
-      "# Generated by 'rsync-service'.\n\n"
-      "pid file = " pid-file "\n"
-      "lock file = " lock-file "\n"
-      "log file = " log-file "\n"
-      (if address (string-append "address = " address "\n") "")
-      "port = " (number->string port-number) "\n"
-      "use chroot = " (if use-chroot? "true" "false") "\n"
-      (if uid (string-append "uid = " uid "\n") "")
-      "gid = " (if gid gid "nogroup") "\n" ; no group nobody
-      "\n"
-      "[files]\n"
-      "path = " share-path "\n"
-      "comment = " share-comment "\n"
-      "read only = " (if read-only? "true" "false") "\n"
-      "timeout = " (number->string timeout) "\n"))))
+  (define (module-config module)
+    (match-record module <rsync-module>
+      (name file-name comment chroot? read-only? timeout)
+      (list "[" name "]\n"
+            "  path = " file-name "\n"
+            "  use chroot = " (if chroot? "true" "false") "\n"
+            "  comment = " comment "\n"
+            "  read only = " (if read-only? "true" "false") "\n"
+            "  timeout = " (number->string timeout) "\n")))
+
+  (define modules
+    (rsync-configuration-modules config))
+
+  (match-record config <rsync-configuration>
+    (package address port-number pid-file lock-file log-file
+             user group uid gid)
+    (unless (string=? user "root")
+      (cond
+       ((<= port-number 1024)
+        (error (string-append "rsync-service: to run on port "
+                              (number->string port-number)
+                              ", user must be root.")))
+       ((find rsync-module-chroot? modules)
+        (error (string-append "rsync-service: to run in a chroot"
+                              ", user must be root.")))
+       (uid
+        (error "rsync-service: to use uid, user must be root."))
+       (gid
+        (error "rsync-service: to use gid, user must be root."))))
+
+    (apply mixed-text-file "rsync.conf"
+           "# Generated by 'rsync-service'.\n\n"
+           "pid file = " pid-file "\n"
+           "lock file = " lock-file "\n"
+           "log file = " log-file "\n"
+           (if address (string-append "address = " address "\n") "")
+           "port = " (number->string port-number) "\n"
+           (if uid (string-append "uid = " uid "\n") "")
+           "gid = " (if gid gid "nogroup") "\n"   ; no group nobody
+           "\n\n"
+           (append-map module-config modules))))
 
 (define (rsync-shepherd-service config)
   "Return a <shepherd-service> for rsync with CONFIG."
@@ -172,4 +245,7 @@
     (list (service-extension shepherd-root-service-type rsync-shepherd-service)
           (service-extension account-service-type rsync-account)
           (service-extension activation-service-type rsync-activation)))
-   (default-value (rsync-configuration))))
+   (default-value (rsync-configuration))
+   (description
+    "Run the rsync file copying tool in daemon mode.  This allows remote hosts
+to keep synchronized copies of the files exported by rsync.")))