aboutsummaryrefslogtreecommitdiff
;;; 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)))

(define (sexp->user-group sexp)
  "Take SEXP, a tuple as returned by 'user-group->gexp', and turn it into a
user-group record."
  (match sexp
    ((name password id system?)
     (user-group (name name)
                 (password password)
                 (id id)
                 (system? system?)))))

(define (sexp->user-account sexp)
  "Take SEXP, a tuple as returned by 'user-account->gexp', and turn it into a
user-account record."
  (match sexp
    ((name uid group supplementary-groups comment home-directory
           create-home-directory? shell password system?)
     (user-account (name name) (uid uid) (group group)
                   (supplementary-groups supplementary-groups)
                   (comment comment)
                   (home-directory home-directory)
                   (create-home-directory? create-home-directory?)
                   (shell shell) (password password)
                   (system? system?)))))

(define (sexp->subid-range sexp)
  "Take SEXP, a tuple as returned by 'subid-range->gexp', and turn it into a
subid-range record."
  (match sexp
    ((name start count)
     (subid-range (name name)
                  (start start)
                  (count count)))))
generated by cgit
(false-if-exception (readlink "/var/run/dbus")))) (unless (equal? existing-name "/run/dbus") ;; Move the content of /var/run/dbus to /run/dbus, and ;; retry. (let ((dir (opendir "/var/run/dbus"))) (let loop ((next (readdir dir))) (cond ((eof-object? next) (closedir dir)) ((member next '("." "..")) (loop (readdir dir))) (else (begin (rename-file (string-append "/var/run/dbus/" next) (string-append "/run/dbus/" next)) (loop (readdir dir))))))) (rmdir "/var/run/dbus") (symlink "/run/dbus" "/var/run/dbus")))) (else (format (current-error-port) "Failed to symlink /run/dbus to /var/run/dbus: ~s~%" (strerror errno)) (error "cannot create /var/run/dbus")))))) (unless (file-exists? "/etc/machine-id") (format #t "creating /etc/machine-id...~%") (invoke (string-append #$(dbus-configuration-dbus config) "/bin/dbus-uuidgen") "--ensure=/etc/machine-id"))))) (define dbus-shepherd-service (match-lambda (($ <dbus-configuration> dbus _ verbose?) (list (shepherd-service (documentation "Run the D-Bus system daemon.") (provision '(dbus-system)) (requirement '(user-processes syslogd)) (start #~(make-forkexec-constructor (list (string-append #$dbus "/bin/dbus-daemon") "--nofork" "--system") #:log-file "/var/log/dbus-daemon.log" #$@(if verbose? ;; Since the verbose output goes to the console, ;; not syslog, add a log file to capture it. '(#:environment-variables '("DBUS_VERBOSE=1")) '()) #:pid-file "/run/dbus/pid")) (stop #~(make-kill-destructor))))))) (define dbus-root-service-type (service-type (name 'dbus) (extensions (list (service-extension shepherd-root-service-type dbus-shepherd-service) (service-extension activation-service-type dbus-activation) (service-extension etc-service-type dbus-etc-files) (service-extension account-service-type (const %dbus-accounts)) (service-extension privileged-program-service-type dbus-privileged-programs))) ;; Extensions consist of lists of packages (representing D-Bus ;; services) that we just concatenate. (compose concatenate) ;; The service's parameters field is extended by augmenting ;; its <dbus-configuration> 'services' field. (extend (lambda (config services) (dbus-configuration (inherit config) (services (append (dbus-configuration-services config) services))))) (default-value (dbus-configuration)) (description "Run the system-wide D-Bus inter-process message bus. It allows programs and daemons to communicate and is also responsible for spawning (@dfn{activating}) D-Bus services on demand."))) (define-deprecated (dbus-service #:key (dbus dbus) (services '()) verbose?) dbus-root-service-type "Return a service that runs the \"system bus\", using @var{dbus}, with support for @var{services}. When @var{verbose?} is true, it causes the @samp{DBUS_VERBOSE} environment variable to be set to @samp{1}; a verbose-enabled D-Bus package such as @code{dbus-verbose} should be provided as @var{dbus} in this scenario. @uref{http://dbus.freedesktop.org/, D-Bus} is an inter-process communication facility. Its system bus is used to allow system services to communicate and be notified of system-wide events. @var{services} must be a list of packages that provide an @file{etc/dbus-1/system.d} directory containing additional D-Bus configuration and policy files. For example, to allow avahi-daemon to use the system bus, @var{services} must be equal to @code{(list avahi)}." (service dbus-root-service-type (dbus-configuration (dbus dbus) (services services) (verbose? verbose?)))) (define (wrapped-dbus-service service program variables) "Return a wrapper for @var{service}, a package containing a D-Bus service, where @var{program} is wrapped such that @var{variables}, a list of name/value tuples, are all set as environment variables when the bus daemon launches it." (define wrapper (program-file (string-append (package-name service) "-program-wrapper") #~(begin (use-modules (ice-9 match)) (for-each (match-lambda ((variable value) (setenv variable value))) '#$variables) (apply execl (string-append #$service "/" #$program) (string-append #$service "/" #$program) (cdr (command-line)))))) (define build (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils)) (define service-directory "/share/dbus-1/system-services") (mkdir-p (dirname (string-append #$output service-directory))) (copy-recursively (string-append #$service service-directory) (string-append #$output service-directory)) (symlink (string-append #$service "/etc") ;for etc/dbus-1 (string-append #$output "/etc")) (for-each (lambda (file) (substitute* file (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$" _ original-program arguments) (string-append "Exec=" #$wrapper arguments "\n")))) (find-files #$output "\\.service$"))))) (computed-file (string-append (package-name service) "-wrapper") build)) ;;; ;;; Polkit privilege management service. ;;; (define-record-type* <polkit-configuration> polkit-configuration make-polkit-configuration polkit-configuration? (polkit polkit-configuration-polkit ;file-like (default polkit)) (actions polkit-configuration-actions ;list of file-like (default '()))) (define %polkit-accounts (list (user-group (name "polkitd") (system? #t)) (user-account (name "polkitd") (group "polkitd") (system? #t) (comment "Polkit daemon user") (home-directory "/var/empty") (shell "/run/current-system/profile/sbin/nologin")))) (define %polkit-pam-services (list (unix-pam-service "polkit-1"))) (define (polkit-directory packages) "Return a directory containing an @file{actions} and possibly a @file{rules.d} sub-directory, for use as @file{/etc/polkit-1}." (with-imported-modules '((guix build union)) (computed-file "etc-polkit-1" #~(begin (use-modules (guix build union) (srfi srfi-26)) (union-build #$output (map (cut string-append <> "/share/polkit-1") (list #$@packages))))))) (define polkit-etc-files (match-lambda (($ <polkit-configuration> polkit packages) `(("polkit-1" ,(polkit-directory (cons polkit packages))))))) (define polkit-privileged-programs (match-lambda (($ <polkit-configuration> polkit) (map file-like->setuid-program (list (file-append polkit "/lib/polkit-1/polkit-agent-helper-1") (file-append polkit "/bin/pkexec")))))) (define polkit-service-type (service-type (name 'polkit) (extensions (list (service-extension account-service-type (const %polkit-accounts)) (service-extension pam-root-service-type (const %polkit-pam-services)) (service-extension dbus-root-service-type (compose list polkit-configuration-polkit)) (service-extension etc-service-type polkit-etc-files) (service-extension privileged-program-service-type polkit-privileged-programs))) ;; Extensions are lists of packages that provide polkit rules ;; or actions under share/polkit-1/{actions,rules.d}. (compose concatenate) (extend (lambda (config actions) (polkit-configuration (inherit config) (actions (append (polkit-configuration-actions config) actions))))) (default-value (polkit-configuration)) (description "Run the @uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege management service}, which allows system administrators to grant access to privileged operations in a structured way. Polkit is a requirement for most desktop environments, such as GNOME."))) (define-deprecated (polkit-service #:key (polkit polkit)) polkit-service-type "Return a service that runs the @uref{http://www.freedesktop.org/wiki/Software/polkit/, Polkit privilege management service}, which allows system administrators to grant access to privileged operations in a structured way. By querying the Polkit service, a privileged system component can know when it should grant additional capabilities to ordinary users. For example, an ordinary user can be granted the capability to suspend the system if the user is logged in locally." (service polkit-service-type (polkit-configuration (polkit polkit)))) ;;; dbus.scm ends here
generated by cgit