;;; 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.
;;; Copyright © 2024 Giacomo Leidi <goodoldpaul@autistici.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(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
user-account-password
user-account-uid
user-account-group
user-account-supplementary-groups
user-account-comment
user-account-home-directory
user-account-create-home-directory?
user-account-shell
user-account-system?
user-group
user-group?
user-group-name
user-group-password
user-group-id
user-group-system?
user-extra-groups
user-extra-groups?
user-extra-groups-user
user-extra-groups-groups
merge-extra-groups-data
subid-range
subid-range?
subid-range-name
subid-range-start
subid-range-count
subid-range-end
subid-range-has-start?
subid-range-less
sexp->user-account
sexp->user-group
sexp->subid-range
default-shell))
;;; Commentary:
;;;
;;; Data structures representing user accounts and user groups. This is meant
;;; to be used both on the host side and at run time--e.g., in activation
;;; snippets.
;;;
;;; Code:
(define default-shell
;; Default shell for user accounts (a string or string-valued gexp).
(make-parameter "/bin/sh"))
(define-record-type* <user-account>
user-account make-user-account
user-account?
(name user-account-name)
(password user-account-password (default #f))
(uid user-account-uid (default #f))
(group user-account-group) ; number | string
(supplementary-groups user-account-supplementary-groups
(default '())) ; list of strings
(comment user-account-comment (default ""))
(home-directory user-account-home-directory (thunked)
(default (default-home-directory this-record)))
(create-home-directory? user-account-create-home-directory? ;Boolean
(default #t))
(shell user-account-shell ; gexp
(default (default-shell)))
(system? user-account-system? ; Boolean
(default #f)))
(define-record-type* <user-group>
user-group make-user-group
user-group?
(name user-group-name)
(password user-group-password (default #f))
(id user-group-id (default #f))
(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-record-type* <subid-range>
subid-range make-subid-range
subid-range?
(name subid-range-name)
(start subid-range-start (default #f)) ; number
(count subid-range-count ; number
; from find_new_sub_gids.c and
; find_new_sub_uids.c
(default 65536)))
(define (subid-range-end range)
"Returns the last subid referenced in RANGE."
(and
(subid-range-has-start? range)
(+ (subid-range-start range)
(subid-range-count range)
-1)))
(define (subid-range-has-start? range)
"Returns #t when RANGE's start is a number."
(number? (subid-range-start range)))
(define (subid-range-less a b)
"Returns #t when subid range A either starts before, or is more specific
than B. When it is not possible to determine whether a range is more specific
w.r.t. another range their names are compared alphabetically."
(define start-a (subid-range-start a))
(define start-b (subid-range-start b))
(cond ((and (not start-a) (not start-b))
(string< (subid-range-name a)
(subid-range-name b)))
((and start-a start-b)
(< start-a start-b))
(else
(and start-a
(not start-b)))))
(define (default-home-directory account)
"Return the default home directory for ACCOUNT."
(string-append "/home/" (user-account-name account))| 2021-08-10 | etc/committer: Pass command-line arguments to main....* etc/committer.scm.in: Call main with command line arguments.
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
| Sarah Morgensen |
| 2021-08-10 | etc/committer: Support custom commit messages....Allow custom change commit messages by supplying a commit message and
optionally a changelog message as arguments.
* etc/committer.scm.in (break-string-with-newlines)
(custom-commit-message): New procedures.
(main)[change-commit-message*]: New sub-procedure. Use them.
(main): Use it.
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
| Sarah Morgensen |
| 2021-08-07 | etc: committer: Support reading G-expressions....Some package definitions use G-expressions (see, e.g., chez-scheme).
Import (guix gexp) such that Guile knows how to read those.
Otherwise, an exception such as the following might be raised:
ERROR: In procedure read:
In procedure scm_lreadr: gnu/services/networking.scm:480:16 |
