system: Allow adding elsewhere-defined system users to extra groups.

* gnu/system.scm (define-module): Export `operating-system-extra-groups`.
(<operating-system>)[extra-groups]: New field.
(operating-system-default-essential-services): Also pass extra groups to
account-service.
(hurd-default-essential-services): Same here.
* gnu/system/accounts.scm (define-module): Use (ice-9 vlist), (srfi srfi-8)
and (srfi srfi-26). Export `user-extra-groups`* and `merge-extra-groups-data`.
(<user-extra-groups>): New record type.
(user-account-extend): New procedure.
(merge-extra-groups-data): New procedure.
* gnu/system/shadow.scm (define-module): Re-export `user-extra-groups`*.
(account-service-type)[extend]: Handle <user-extra-groups> records, move field
intializer upward to be able to use `compose`.

Change-Id: I3f489ac794d342267b7627db1d28315ea4b69db2

3 files changed, 57 insertions, 6 deletions

diff --git a/gnu/system.scm b/gnu/system.scm
index cb6e719ca6..5334fffc17 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -111,6 +111,7 @@
             operating-system-initrd
             operating-system-users
             operating-system-groups
+            operating-system-extra-groups
             operating-system-issue
             operating-system-timezone
             operating-system-locale
@@ -270,6 +271,8 @@ VERSION is the target version of the boot-parameters record."
          (default %base-user-accounts))
   (groups operating-system-groups                 ; list of user groups
           (default %base-groups))
+  (extra-groups operating-system-extra-groups     ; list of extra membership
+                (default '()))
 
   (skeletons operating-system-skeletons           ; list of name/file-like value
              (default (default-skeletons)))
@@ -799,7 +802,8 @@ bookkeeping."
 
            (pam-root-service (operating-system-pam-services os))
            (account-service (append (operating-system-accounts os)
-                                    (operating-system-groups os))
+                                    (operating-system-groups os)
+                                    (operating-system-extra-groups os))
                             (operating-system-skeletons os))
            (operating-system-etc-service os)
            ;; XXX: hosts-file is deprecated
@@ -839,7 +843,8 @@ bookkeeping."
 
           (service user-processes-service-type)
           (account-service (append (operating-system-accounts os)
-                                   (operating-system-groups os))
+                                   (operating-system-groups os)
+                                   (operating-system-extra-groups os))
                            (operating-system-skeletons os))
           (root-file-system-service)
           (service file-system-service-type '())
diff --git a/gnu/system/accounts.scm b/gnu/system/accounts.scm
index 586cff1842..d045dfd17b 100644
--- a/gnu/system/accounts.scm
+++ b/gnu/system/accounts.scm
@@ -1,5 +1,8 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2024 Wojtek Kosior <koszko@koszko.org>
+;;; Additions and modifications by Wojtek Kosior are additionally
+;;; dual-licensed under the Creative Commons Zero v1.0.
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,6 +22,9 @@
 (define-module (gnu system accounts)
   #:use-module (guix records)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 vlist)
+  #:use-module (srfi srfi-8)
+  #:use-module (srfi srfi-26)
   #:export (user-account
             user-account?
             user-account-name
@@ -39,6 +45,13 @@
             user-group-id
             user-group-system?
 
+            user-extra-groups
+            user-extra-groups?
+            user-extra-groups-user
+            user-extra-groups-groups
+
+            merge-extra-groups-data
+
             sexp->user-account
             sexp->user-group
 
@@ -85,6 +98,34 @@
   (system?        user-group-system?              ; Boolean
                   (default #f)))
 
+(define-record-type* <user-extra-groups> user-extra-groups
+  make-user-extra-groups
+  user-extra-groups?
+  (user           user-extra-groups-user)
+  (groups         user-extra-groups-groups))      ; list of strings
+
+(define (user-account-extend account extra-groups)
+  (match-record account <user-account> (name supplementary-groups)
+    (user-account
+     (inherit account)
+     (supplementary-groups (apply append supplementary-groups
+                                  (vhash-fold* cons '()
+                                               name extra-groups))))))
+
+(define (merge-extra-groups-data accounts-data)
+  (let* ((extra-groups-alist (map (match-record-lambda <user-extra-groups>
+                                      (user groups)
+                                    (cons user groups))
+                                  (filter user-extra-groups? accounts-data)))
+         (extra-groups (alist->vhash extra-groups-alist))
+         (user-accounts (map (cut user-account-extend <> extra-groups)
+                             (filter user-account? accounts-data)))
+         (other-records (filter (lambda (record)
+                                  (not (or (user-account? record)
+                                           (user-extra-groups? record))))
+                                accounts-data)))
+    (append other-records user-accounts)))
+
 (define (default-home-directory account)
   "Return the default home directory for ACCOUNT."
   (string-append "/home/" (user-account-name account)))
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index d9f13271d8..699331e911 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -61,7 +61,12 @@
                user-group-name
                user-group-password
                user-group-id
-               user-group-system?)
+               user-group-system?
+
+               user-extra-groups
+               user-extra-groups?
+               user-extra-groups-user
+               user-extra-groups-groups)
 
   #:export (%default-bashrc
             %default-bash-profile
@@ -493,10 +498,10 @@ the /etc/skel directory for those."
 (define account-service-type
   (service-type (name 'account)
 
-                ;; Concatenate <user-account>, <user-group>, and skeleton
-                ;; lists.
+                ;; Concatenate <user-account>, <user-group>,
+                ;; <user-extra-groups> and skeleton lists.
+                (extend (compose merge-extra-groups-data append))
                 (compose concatenate)
-                (extend append)
 
                 (extensions
                  (list (service-extension activation-service-type