[bug#49814] [PATCH] accounts: Add <group-membership>.

[Brice Waegeneire]

Support adding supplementary groups to defined users by extending
'account-service-type'.

* gnu/system/accounts.scm (group-membership): New record.
  (additional-group-members): New procedure.
* gnu/system/shadow.scm (group-memberships->users-groups): New
  procedure.
  (account-activation accounts+groups): Add additional group memberships
  to the defined users.
---
 gnu/system/accounts.scm | 19 +++++++++++++++++++
 gnu/system/shadow.scm   | 30 +++++++++++++++++++++++++++++-
 2 files changed, 48 insertions(+), 1 deletion(-)

As I was answerd on IRC, it's already possible to add groups to an already
defined 'operating-system' by modifying it's 'user' field.  However this isn't
that practical in my point of view.

I would prefer to do such change from a service to be able to keep a potential
new group and its members in proximity in the code.  For example when adding a
sgid dumpcap binary to be used by the wireshark group members, it makes sense
to keep the membership of that group close to the definition of the new group
and its sgid binary:

--8<---------------cut here---------------start------------->8---
(simple-service 'wireshark-account account-service-type
                (list (user-group (name "wireshark") (system? #t))
                      (additional-group-members "wireshark" %sysadmins)))
(simple-service 'wireshark-dumpcap setuid-program-service-type
                (list (setuid-program
                       (program (file-append wireshark "/bin/dumpcap"))
                       (setuid? #f)
                       (setgid? #t)
                       (group "wireshark"))))
--8<---------------cut here---------------end--------------->8---

This patch add a new <group-membership> record to be used as as some of the
values for the 'account-service-type' which already support 3 other different
types.

diff --git a/gnu/system/accounts.scm b/gnu/system/accounts.scm
index 586cff1842..c12f5644d0 100644
--- a/gnu/system/accounts.scm
+++ b/gnu/system/accounts.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès 
<ludo@gnu.org>
+;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -39,6 +40,12 @@
             user-group-id
             user-group-system?
 
+            group-membership
+            group-membership?
+            group-membership-name
+            group-membership-additional-members
+            additional-group-members
+
             sexp->user-account
             sexp->user-group
 
@@ -85,6 +92,12 @@
   (system?        user-group-system?              ; Boolean
                   (default #f)))
 
+(define-record-type* <group-membership>
+  group-membership make-group-membership
+  group-membership?
+  (name                 group-membership-name)                  ; string
+  (additional-members   group-membership-additional-members))   ; list of 
strings
+
 (define (default-home-directory account)
   "Return the default home directory for ACCOUNT."
   (string-append "/home/" (user-account-name account)))
@@ -112,3 +125,9 @@ user-account record."
                    (create-home-directory? create-home-directory?)
                    (shell shell) (password password)
                    (system? system?)))))
+
+(define (additional-group-members group members)
+  "Return a <group-membership> object with name GROUPS and additional
+MEMEBERS."
+  (group-membership (name group)
+                    (additional-members members)))
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index 7c57222716..273c1f6d87 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -316,12 +317,39 @@ of user '~a' is undeclared")
       #$(user-account-password account)
       #$(user-account-system? account)))
 
+(define (group-memberships->users-groups groups-memberships)
+  "Turn GROUP-MEMBERSHIPS, a list of <group-membership> object, into an alist
+of users with additional group membership."
+  (let ((users (delete-duplicates (append-map 
group-membership-additional-members
+                                              groups-memberships))))
+    (map (lambda (user)
+           (cons user
+                 (filter-map
+                  (lambda (group)
+                    (and (member user (group-membership-additional-members 
group))
+                         (group-membership-name group)))
+                  groups-memberships)))
+         users)))
+
 (define (account-activation accounts+groups)
   "Return a gexp that activates ACCOUNTS+GROUPS, a list of <user-account> and
 <user-group> objects.  Raise an error if a user account refers to a undefined
 group."
+  (define users-additional-groups
+    (group-memberships->users-groups (filter group-membership? 
accounts+groups)))
+
   (define accounts
-    (delete-duplicates (filter user-account? accounts+groups) eq?))
+    (map (lambda (user)
+           (let ((additional-groups (assoc-ref users-additional-groups
+                                               (user-account-name user))))
+             (if additional-groups
+                 (user-account
+                  (inherit user)
+                  (supplementary-groups
+                   (delete-duplicates (append 
(user-account-supplementary-groups user)
+                                              additional-groups))))
+                 user)))
+         (delete-duplicates (filter user-account? accounts+groups) eq?)))
 
   (define user-specs
     (map user-account->gexp accounts))
-- 
2.32.0