Merge branch 'master' into staging

7 files changed, 229 insertions, 58 deletions

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index d58afb27e3..27eae75c46 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -300,27 +300,36 @@ system objects.")))
              ;; Return #f if successfully stopped.
              (sync)
 
-             (call-with-blocked-asyncs
-              (lambda ()
-                (let ((null (%make-void-port "w")))
-                  ;; Close 'shepherd.log'.
-                  (display "closing log\n")
-                  ((@ (shepherd comm) stop-logging))
-
-                  ;; Redirect the default output ports..
-                  (set-current-output-port null)
-                  (set-current-error-port null)
-
-                  ;; Close /dev/console.
-                  (for-each close-fdes '(0 1 2))
-
-                  ;; At this point, there are no open files left, so the
-                  ;; root file system can be re-mounted read-only.
-                  (mount #f "/" #f
-                         (logior MS_REMOUNT MS_RDONLY)
-                         #:update-mtab? #f)
-
-                  #f)))))
+             (let ((null (%make-void-port "w")))
+               ;; Close 'shepherd.log'.
+               (display "closing log\n")
+               ((@ (shepherd comm) stop-logging))
+
+               ;; Redirect the default output ports..
+               (set-current-output-port null)
+               (set-current-error-port null)
+
+               ;; Close /dev/console.
+               (for-each close-fdes '(0 1 2))
+
+               ;; At this point, there should be no open files left so the
+               ;; root file system can be re-mounted read-only.
+               (let loop ((n 10))
+                 (unless (catch 'system-error
+                           (lambda ()
+                             (mount #f "/" #f
+                                    (logior MS_REMOUNT MS_RDONLY)
+                                    #:update-mtab? #f)
+                             #t)
+                           (const #f))
+                   (unless (zero? n)
+                     ;; Yield to the other fibers.  That gives logging fibers
+                     ;; an opportunity to close log files so the 'mount' call
+                     ;; doesn't fail with EBUSY.
+                     ((@ (fibers) sleep) 1)
+                     (loop (- n 1)))))
+
+               #f)))
    (respawn? #f)))
 
 (define root-file-system-service-type
@@ -2912,8 +2921,12 @@ to handle."
 (define %greetd-accounts
   (list (user-account
          (name "greeter")
-         (group "wheel")
-         (supplementary-groups '("users" "tty" "input" "video" "audio"))
+         (group "greeter")
+         ;; video group is required for graphical greeters.
+         (supplementary-groups '("video"))
+         (system? #t))
+        (user-group
+         (name "greeter")
          (system? #t))))
 
 (define %greetd-file-systems
diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm
index f6b20fb82b..e3c101d042 100644
--- a/gnu/services/configuration.scm
+++ b/gnu/services/configuration.scm
@@ -27,7 +27,8 @@
   #:use-module (guix records)
   #:use-module (guix gexp)
   #:use-module ((guix utils) #:select (source-properties->location))
-  #:use-module ((guix diagnostics) #:select (formatted-message location-file))
+  #:use-module ((guix diagnostics)
+                #:select (formatted-message location-file &error-location))
   #:use-module ((guix modules) #:select (file-name->module-name))
   #:use-module (guix i18n)
   #:autoload   (texinfo) (texi-fragment->stexi)
@@ -56,7 +57,6 @@
             serialize-configuration
             define-maybe
             define-maybe/no-serialization
-            validate-configuration
             generate-documentation
             configuration->documentation
             empty-serializer
@@ -87,9 +87,17 @@
 (define (configuration-error message)
   (raise (condition (&message (message message))
                     (&configuration-error))))
-(define (configuration-field-error field val)
-  (configuration-error
-   (format #f "Invalid value for field ~a: ~s" field val)))
+(define (configuration-field-error loc field value)
+  (raise (apply
+          make-compound-condition
+          (formatted-message (G_ "invalid value ~s for field '~a'")
+                             value field)
+          (condition (&configuration-error))
+          (if loc
+              (list (condition
+                     (&error-location (location loc))))
+              '()))))
+
 (define (configuration-missing-field kind field)
   (configuration-error
    (format #f "~a configuration missing required field ~a" kind field)))
@@ -116,14 +124,6 @@ does not have a default value" field kind)))
                 ((configuration-field-getter field) config)))
              fields)))
 
-(define (validate-configuration config fields)
-  (for-each (lambda (field)
-              (let ((val ((configuration-field-getter field) config)))
-                (unless ((configuration-field-predicate field) val)
-                  (configuration-field-error
-                   (configuration-field-name field) val))))
-            fields))
-
 (define-syntax-rule (id ctx parts ...)
   "Assemble PARTS into a raw (unhygienic) identifier."
   (datum->syntax ctx (symbol-append (syntax->datum parts) ...)))
@@ -210,9 +210,33 @@ does not have a default value" field kind)))
                                 (id #'stem #'serialize- type))))))
                   #'(field-type ...)
                   #'((custom-serializer ...) ...))))
+         (define (field-sanitizer name pred)
+           ;; Define a macro for use as a record field sanitizer, where NAME
+           ;; is the name of the field and PRED is the predicate that tells
+           ;; whether a value is valid for this field.
+           #`(define-syntax #,(id #'stem #'validate- #'stem #'- name)
+               (lambda (s)
+                 ;; Make sure the given VALUE, for field NAME, passes PRED.
+                 (syntax-case s ()
+                   ((_ value)
+                    (with-syntax ((name #'#,name)
+                                  (pred #'#,pred)
+                                  (loc (datum->syntax #'value
+                                                      (syntax-source #'value))))
+                      #'(if (pred value)
+                            value
+                            (configuration-field-error
+                             (and=> 'loc source-properties->location)
+                             'name value))))))))
+
          #`(begin
+             ;; Define field validation macros.
+             #,@(map field-sanitizer
+                     #'(field ...)
+                     #'(field-predicate ...))
+
              (define-record-type* #,(id #'stem #'< #'stem #'>)
-               #,(id #'stem #'% #'stem)
+               stem
                #,(id #'stem #'make- #'stem)
                #,(id #'stem #'stem #'?)
                (%location #,(id #'stem #'stem #'-location)
@@ -220,10 +244,13 @@ does not have a default value" field kind)))
                                           source-properties->location))
                           (innate))
                #,@(map (lambda (name getter def)
-                         #`(#,name #,getter (default #,def)))
+                         #`(#,name #,getter (default #,def)
+                                   (sanitize
+                                    #,(id #'stem #'validate- #'stem #'- name))))
                        #'(field ...)
                        #'(field-getter ...)
                        #'(field-default ...)))
+
              (define #,(id #'stem #'stem #'-fields)
                (list (configuration-field
                       (name 'field)
@@ -240,12 +267,7 @@ does not have a default value" field kind)))
                                '#,(id #'stem #'% #'stem) 'field)
                               field-default)))
                       (documentation doc))
-                     ...))
-             (define-syntax-rule (stem arg (... ...))
-               (let ((conf (#,(id #'stem #'% #'stem) arg (... ...))))
-                 (validate-configuration conf
-                                         #,(id #'stem #'stem #'-fields))
-                 conf))))))))
+                     ...))))))))
 
 (define no-serialization         ;syntactic keyword for 'define-configuration'
   '(no serialization))
diff --git a/gnu/services/guix.scm b/gnu/services/guix.scm
index ad7b020b69..338e027245 100644
--- a/gnu/services/guix.scm
+++ b/gnu/services/guix.scm
@@ -46,6 +46,7 @@
             guix-build-coordinator-configuration-client-communication-uri-string
             guix-build-coordinator-configuration-allocation-strategy
             guix-build-coordinator-configuration-hooks
+            guix-build-coordinator-configuration-parallel-hooks
             guix-build-coordinator-configuration-guile
 
             guix-build-coordinator-service-type
@@ -155,6 +156,8 @@
    (default #~basic-build-allocation-strategy))
   (hooks                           guix-build-coordinator-configuration-hooks
                                    (default '()))
+  (parallel-hooks                  guix-build-coordinator-configuration-parallel-hooks
+                                   (default '()))
   (guile                           guix-build-coordinator-configuration-guile
                                    (default guile-3.0-latest)))
 
@@ -246,6 +249,7 @@
                                                    agent-communication-uri-string
                                                    client-communication-uri-string
                                                    (hooks '())
+                                                   (parallel-hooks '())
                                                    (guile guile-3.0))
   (program-file
    "start-guix-build-coordinator"
@@ -304,7 +308,11 @@
             #:agent-communication-uri (string->uri
                                        #$agent-communication-uri-string)
             #:client-communication-uri (string->uri
-                                        #$client-communication-uri-string)))))
+                                        #$client-communication-uri-string)
+            #:parallel-hooks (list #$@(map (match-lambda
+                                             ((name . val)
+                                              #~(cons '#$name #$val)))
+                                           parallel-hooks))))))
    #:guile guile))
 
 (define (guix-build-coordinator-shepherd-services config)
@@ -314,6 +322,7 @@
              client-communication-uri-string
              allocation-strategy
              hooks
+             parallel-hooks
              guile)
     (list
      (shepherd-service
@@ -331,6 +340,7 @@
                          #:client-communication-uri-string
                          client-communication-uri-string
                          #:hooks hooks
+                         #:parallel-hooks parallel-hooks
                          #:guile guile))
                 #:user #$user
                 #:group #$group
diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm
index d99743ac31..10e6523861 100644
--- a/gnu/services/mail.scm
+++ b/gnu/services/mail.scm
@@ -285,7 +285,7 @@ the section name.")
     (serialize-fifo-listener-configuration field-name val))
    ((inet-listener-configuration? val)
     (serialize-inet-listener-configuration field-name val))
-   (else (configuration-field-error field-name val))))
+   (else (configuration-field-error #f field-name val))))
 (define (listener-configuration-list? val)
   (and (list? val) (and-map listener-configuration? val)))
 (define (serialize-listener-configuration-list field-name val)
@@ -1610,10 +1610,6 @@ POP3, IMAP, and LMTP.  @var{config} should be a configuration object created
 by @code{dovecot-configuration}.  @var{config} may also be created by
 @code{opaque-dovecot-configuration}, which allows specification of the
 @code{dovecot.conf} as a string."
-  (validate-configuration config
-                          (if (opaque-dovecot-configuration? config)
-                              opaque-dovecot-configuration-fields
-                              dovecot-configuration-fields))
   (service dovecot-service-type config))
 
 ;; A little helper to make it easier to document all those fields.
diff --git a/gnu/services/ssh.scm b/gnu/services/ssh.scm
index 57d3ad218c..72e7183590 100644
--- a/gnu/services/ssh.scm
+++ b/gnu/services/ssh.scm
@@ -536,6 +536,15 @@ of user-name/file-like tuples."
     #~(and (defined? 'make-inetd-constructor)
            (not (string=? (@ (shepherd config) Version) "0.9.0"))))
 
+  (define ipv6-support?
+    ;; Expression that returns true if IPv6 support is available.
+    #~(catch 'system-error
+        (lambda ()
+          (let ((sock (socket AF_INET6 SOCK_STREAM 0)))
+            (close-port sock)
+            #t))
+        (const #f)))
+
   (list (shepherd-service
          (documentation "OpenSSH server.")
          (requirement '(syslogd loopback))
@@ -544,12 +553,15 @@ of user-name/file-like tuples."
          (start #~(if #$inetd-style?
                       (make-inetd-constructor
                        (append #$openssh-command '("-i"))
-                       (list (endpoint
+                       (cons (endpoint
                               (make-socket-address AF_INET INADDR_ANY
                                                    #$port-number))
-                             (endpoint
-                              (make-socket-address AF_INET6 IN6ADDR_ANY
-                                                   #$port-number)))
+                             (if #$ipv6-support?
+                                 (list
+                                  (endpoint
+                                   (make-socket-address AF_INET6 IN6ADDR_ANY
+                                                        #$port-number)))
+                                 '()))
                        #:max-connections #$max-connections)
                       (make-forkexec-constructor #$openssh-command
                                                  #:pid-file #$pid-file)))
diff --git a/gnu/services/vpn.scm b/gnu/services/vpn.scm
index 6a289d357a..82ff05b351 100644
--- a/gnu/services/vpn.scm
+++ b/gnu/services/vpn.scm
@@ -540,11 +540,9 @@ is truncated and rewritten every minute.")
 to an existing @acronym{VPN, virtual private network}.")))
 
 (define* (openvpn-client-service #:key (config (openvpn-client-configuration)))
-  (validate-configuration config openvpn-client-configuration-fields)
   (service openvpn-client-service-type config))
 
 (define* (openvpn-server-service #:key (config (openvpn-server-configuration)))
-  (validate-configuration config openvpn-server-configuration-fields)
   (service openvpn-server-service-type config))
 
 (define (generate-openvpn-server-documentation)
diff --git a/gnu/services/web.scm b/gnu/services/web.scm
index 4f06d4e0bb..f0c7e90cbf 100644
--- a/gnu/services/web.scm
+++ b/gnu/services/web.scm
@@ -9,7 +9,7 @@
 ;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr>
 ;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com>
 ;;; Copyright © 2019, 2020 Florian Pelz <pelzflorian@pelzflorian.de>
-;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2020, 2022 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
 ;;; Copyright © 2020 Oleg Pykhalov <go.wigust@gmail.com>
@@ -120,6 +120,7 @@
             nginx-upstream-configuration?
             nginx-upstream-configuration-name
             nginx-upstream-configuration-servers
+            nginx-upstream-configuration-extra-content
 
             nginx-location-configuration
             nginx-location-configuration?
@@ -204,6 +205,21 @@
 
             tailon-service-type
 
+            anonip-configuration
+            anonip-configuration?
+            anonip-configuration-anonip
+            anonip-configuration-input
+            anonip-configuration-output
+            anonip-configuration-skip-private?
+            anonip-configuration-column
+            anonip-configuration-replacement
+            anonip-configuration-ipv4mask
+            anonip-configuration-ipv6mask
+            anonip-configuration-increment
+            anonip-configuration-delimiter
+            anonip-configuration-regex
+            anonip-service-type
+
             varnish-configuration
             varnish-configuration?
             varnish-configuration-package
@@ -517,7 +533,9 @@
   nginx-upstream-configuration make-nginx-upstream-configuration
   nginx-upstream-configuration?
   (name                nginx-upstream-configuration-name)
-  (servers             nginx-upstream-configuration-servers))
+  (servers             nginx-upstream-configuration-servers)
+  (extra-content       nginx-upstream-configuration-extra-content
+                       (default '())))
 
 (define-record-type* <nginx-location-configuration>
   nginx-location-configuration make-nginx-location-configuration
@@ -643,6 +661,15 @@ of index files."
    (map (lambda (server)
           (simple-format #f "      server ~A;\n" server))
         (nginx-upstream-configuration-servers upstream))
+   (let ((extra-content
+          (nginx-upstream-configuration-extra-content upstream)))
+     (if (and extra-content (not (null? extra-content)))
+         (cons
+          "\n"
+          (map (lambda (line)
+                 (simple-format #f "      ~A\n" line))
+               (flatten extra-content)))
+         '()))
    "    }\n"))
 
 (define (flatten . lst)
@@ -1343,6 +1370,99 @@ files.")
                                  files))))))))
    (default-value (tailon-configuration))))
 
+
+
+;;;
+;;; Log anonymization
+;;;
+
+(define-record-type* <anonip-configuration>
+  anonip-configuration make-anonip-configuration
+  anonip-configuration?
+  (anonip            anonip-configuration-anonip       ;file-like
+                     (default anonip))
+  (input             anonip-configuration-input)       ;string
+  (output            anonip-configuration-output)      ;string
+  (skip-private?     anonip-configuration-skip-private? ;boolean
+                     (default #f))
+  (column            anonip-configuration-column       ;number
+                     (default #f))
+  (replacement       anonip-configuration-replacement  ;string
+                     (default #f))
+  (ipv4mask          anonip-configuration-ipv4mask     ;number
+                     (default #f)) 
+  (ipv6mask          anonip-configuration-ipv6mask     ;number
+                     (default #f))
+  (increment         anonip-configuration-increment    ;number
+                     (default #f))
+  (delimiter         anonip-configuration-delimiter    ;string
+                     (default #f))
+  (regex             anonip-configuration-regex        ;string
+                     (default #f)))
+
+(define (anonip-activation config)
+  (with-imported-modules '((guix build utils))
+    #~(begin
+        (use-modules (guix build utils))
+        (for-each
+         (lambda (directory)
+           (mkdir-p directory)
+           (chmod directory #o755))
+         (list (dirname #$(anonip-configuration-input config))
+               (dirname #$(anonip-configuration-output config)))))))
+
+(define (anonip-shepherd-service config)
+  (let ((input (anonip-configuration-input config))
+        (output (anonip-configuration-output config))
+        (optional
+         (lambda (accessor option)
+           (or (and=> (accessor config)
+                      (lambda (value)
+                        (list
+                         (format #false "~a=~a"
+                                 option value))))
+               (list)))))
+    (list (shepherd-service
+           (provision (list (symbol-append 'anonip- (string->symbol output))))
+           (requirement '(user-processes))
+           (documentation "Anonimyze the given log file location with anonip.")
+           (start #~(lambda _
+                      (unless (file-exists? #$input)
+                          (mknod #$input 'fifo #o600 0))
+                      (let ((pid (fork+exec-command
+                                  (append
+                                      (list #$(file-append (anonip-configuration-anonip config)
+                                                           "/bin/anonip")
+                                            (string-append "--input=" #$input)
+                                            (string-append "--output=" #$output))
+                                      (if #$(anonip-configuration-skip-private? config)
+                                          '("--skip-private") (list))
+                                    '#$(optional anonip-configuration-column "--column")
+                                    '#$(optional anonip-configuration-ipv4mask "--ipv4mask")
+                                    '#$(optional anonip-configuration-ipv6mask "--ipv6mask")
+                                    '#$(optional anonip-configuration-increment "--increment")
+                                    '#$(optional anonip-configuration-replacement "--replacement")
+                                    '#$(optional anonip-configuration-delimiter "--delimiter")
+                                    '#$(optional anonip-configuration-regex "--regex"))
+                                  ;; Run in a UTF-8 locale
+                                  #:environment-variables
+                                  (list (string-append "GUIX_LOCPATH=" #$glibc-utf8-locales
+                                                       "/lib/locale")
+                                        "LC_ALL=en_US.utf8"))))
+                        pid)))
+           (stop #~(make-kill-destructor))))))
+
+(define anonip-service-type
+  (service-type
+   (name 'anonip)
+   (extensions
+    (list (service-extension shepherd-root-service-type
+                             anonip-shepherd-service)
+          (service-extension activation-service-type
+                             anonip-activation)))
+   (description
+    "Provide web server log anonymization with @command{anonip}.")))
+
 
 ;;;
 ;;; Varnish