diff options
| -rw-r--r-- | gnu/system.scm | 9 | ||||
| -rw-r--r-- | gnu/system/accounts.scm | 41 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 13 |
3 files changed, 57 insertions, 6 deletions
diff --git a/gnu/system.scm b/gnu/system.scm index 44f93f91d1..fb41a2f2f4 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -112,6 +112,7 @@ operating-system-initrd operating-system-users operating-system-groups + operating-system-extra-groups operating-system-issue operating-system-timezone operating-system-locale @@ -273,6 +274,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))) @@ -810,7 +813,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 @@ -851,7 +855,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 |