@@ -41582,6 +41582,177 @@ Miscellaneous Services
@end deftp
+@c %end of fragment
+
+@cindex Subids
+@subsubheading Subid Service
+
+The @code{(gnu system shadow)} module exposes the
+@code{subids-service-type}, its configuration record
+@code{subids-configuration} and its extension record
+@code{subids-extension}.
+
+With @code{subids-service-type}, subuids and subgids ranges can be reserved for
+users that desire so:
+
+@lisp
+(use-modules (gnu system shadow) ;for 'subids-service-type'
+ (gnu system accounts) ;for 'subid-range'
+ @dots{})
+
+(operating-system
+ ;; @dots{}
+ (services
+ (list
+ (simple-service 'alice-bob-subids
+ subids-service-type
+ (subids-extension
+ (subgids
+ (list
+ (subid-range (name "alice"))))
+ (subuids
+ (list
+ (subid-range (name "alice"))
+ (subid-range (name "bob")
+ (start 100700)))))))))
+@end lisp
+
+Users (definitely other services), usually, are supposed to extend the service
+instead of adding subids directly to @code{subids-configuration}, unless the
+want to change the default behavior for root. With default settings the
+@code{subids-service-type} adds, if it's not already there, a configuration
+for the root account to both @code{/etc/subuid} and @code{/etc/subgid}, possibly
+starting at the minimum possible subid. Otherwise the root subuids and subgids
+ranges are fitted wherever possible.
+
+The above configuration will yield the following:
+
+@example
+# cat /etc/subgid
+root:100000:65536
+alice:165536:65536
+# cat /etc/subuid
+root:100000:700
+bob:100700:65536
+alice:166236:65536
+@end example
+
+@c %start of fragment
+
+@deftp {Data Type} subids-configuration
+
+With default settings the
+@code{subids-service-type} adds, if it's not already there, a configuration
+for the root account to both @code{/etc/subuid} and @code{/etc/subgid}, possibly
+starting at the minimum possible subid. To disable the default behavior and
+provide your own definition for the root subid ranges you can set to @code{#f}
+the @code{add-root?} field:
+
+@lisp
+(use-modules (gnu system shadow) ;for 'subids-service-type'
+ (gnu system accounts) ;for 'subid-range'
+ @dots{})
+
+(operating-system
+ ;; @dots{}
+ (services
+ (list
+ (service subids-service-type
+ (subids-configuration
+ (add-root? #f)
+ (subgids
+ (subid-range (name "root")
+ (start 120000)
+ (count 100)))
+ (subuids
+ (subid-range (name "root")
+ (start 120000)
+ (count 100)))))
+ (simple-service 'alice-bob-subids
+ subids-service-type
+ (subids-extension
+ (subgids
+ (list
+ (subid-range (name "alice"))))
+ (subuids
+ (list
+ (subid-range (name "alice"))
+ (subid-range (name "bob")
+ (start 100700)))))))))
+@end lisp
+
+Available @code{subids-configuration} fields are:
+
+@table @asis
+@item @code{add-root?} (default: @code{#t}) (type: boolean)
+Whether to automatically configure subuids and subgids for root.
+
+@item @code{subgids} (default: @code{'()}) (type: list-of-subid-ranges)
+The list of @code{subid-range}s that will be serialized to @code{/etc/subgid}.
+If a range doesn't specify a start it will be fitted based on its number of
+requrested subids. If a range doesn't specify a count the default size
+of 65536 will be assumed.
+
+@item @code{subuids} (default: @code{'()}) (type: list-of-subid-ranges)
+The list of @code{subid-range}s that will be serialized to @code{/etc/subuid}.
+If a range doesn't specify a start it will be fitted based on its number of
+requrested subids. If a range doesn't specify a count the default size
+of 65536 will be assumed.
+
+@end table
+
+@end deftp
+
+@c %end of fragment
+
+@c %start of fragment
+
+@deftp {Data Type} subids-extension
+
+Available @code{subids-extension} fields are:
+
+@table @asis
+
+@item @code{subgids} (default: @code{'()}) (type: list-of-subid-ranges)
+The list of @code{subid-range}s that will be appended to
+@code{subids-configuration-subgids}. Entries with the same name are deduplicated
+upon merging.
+
+@item @code{subuids} (default: @code{'()}) (type: list-of-subid-ranges)
+The list of @code{subid-range}s that will be appended to
+@code{subids-configuration-subuids}. Entries with the same name are deduplicated
+upon merging.
+
+@end table
+
+@end deftp
+
+@c %end of fragment
+
+@c %start of fragment
+
+@deftp {Data Type} subid-range
+
+The @code{subid-range} record is defined at @code{(gnu system accounts)}.
+Available fields are:
+
+@table @asis
+
+@item @code{name} (type: string)
+The name of the user or group that will own this range.
+
+@item @code{start} (default: @code{#f}) (type: integer)
+The first requested subid. When false the first available subid with enough
+contiguous subids will be assigned.
+
+@item @code{count} (default: @code{#f}) (type: integer)
+The number of total allocated subids. When #f the default of 65536 will be
+assumed .
+
+@end table
+
+@end deftp
+
@c %end of fragment
@node Setuid Programs
@@ -9,6 +9,7 @@
;;; Copyright © 2020 Christine Lemmer-Webber <cwebber@dustycloud.org>
;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
+;;; Copyright © 2024 Giacomo Leidi <goodoldpaul@autistici.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -39,6 +40,7 @@ (define-module (gnu build activation)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:export (activate-users+groups
+ activate-subuids+subgids
activate-user-home
activate-etc
activate-setuid-programs
@@ -202,6 +204,23 @@ (define (activate-users+groups users groups)
(chmod directory #o555))
(duplicates (map user-account-home-directory system-accounts))))
+(define (activate-subuids+subgids subuids subgids)
+ "Make sure SUBUIDS (a list of subid range records) and SUBGIDS (a list of
+subid range records) are all available."
+
+ ;; Take same lock as Shadow while we read
+ ;; and write the databases. This ensures there's no race condition with
+ ;; other tools that might be accessing it at the same time.
+ (with-file-lock "/etc/subgid.lock"
+ (let-values (((subuid subgid)
+ (subuid+subgid-databases subuids subgids)))
+ (write-subgid subgid)))
+
+ (with-file-lock "/etc/subuid.lock"
+ (let-values (((subuid subgid)
+ (subuid+subgid-databases subuids subgids)))
+ (write-subuid subuid))))
+
(define (activate-user-home users)
"Create and populate the home directory of USERS, a list of tuples, unless
they already exist."
@@ -835,6 +835,7 @@ GNU_SYSTEM_MODULES = \
%D%/tests/samba.scm \
%D%/tests/security.scm \
%D%/tests/security-token.scm \
+ %D%/tests/shadow.scm \
%D%/tests/singularity.scm \
%D%/tests/ssh.scm \
%D%/tests/telephony.scm \
@@ -51,6 +51,7 @@ (define-module (gnu system accounts)
sexp->user-account
sexp->user-group
+ sexp->subid-range
default-shell))
@@ -159,3 +160,12 @@ (define (sexp->user-account sexp)
(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)))))
@@ -4,6 +4,7 @@
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2020, 2023 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2024 Giacomo Leidi <goodoldpaul@autistici.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -77,7 +78,20 @@ (define-module (gnu system shadow)
%base-user-accounts
account-service-type
- account-service))
+ account-service
+
+ subids-configuration
+ subids-configuration?
+ subids-configuration-add-root?
+ subids-configuration-subgids
+ subids-configuration-subuids
+
+ subids-extension
+ subids-extension?
+ subids-extension-subgids
+ subids-extension-subuids
+
+ subids-service-type))
;;; Commentary:
;;;
@@ -380,7 +394,7 @@ (define (assert-valid-users/groups users groups)
;;;
-;;; Service.
+;;; Accounts Service.
;;;
(define (user-group->gexp group)
@@ -521,4 +535,193 @@ (define (account-service accounts+groups skeletons)
(service account-service-type
(append skeletons accounts+groups)))
+
+;;;
+;;; Subids Service.
+;;;
+
+(define %sub-id-min
+ (@@ (gnu build accounts) %sub-id-min))
+(define %sub-id-max
+ (@@ (gnu build accounts) %sub-id-max))
+(define %sub-id-count
+ (@@ (gnu build accounts) %sub-id-count))
+
+(define* (%root-subid #:optional (start %sub-id-min) (count %sub-id-count))
+ (subid-range
+ (name "root")
+ (start start)
+ (count count)))
+
+(define-record-type* <subids-configuration>
+ subids-configuration make-subids-configuration
+ subids-configuration?
+ this-subids-configuration
+
+ (add-root? subids-configuration-add-root? ; boolean
+ (default #t))
+ (subgids subids-configuration-subgids ; list of <subid-range>
+ (default '()))
+ (subuids subids-configuration-subuids ; list of <subid-range>
+ (default '())))
+
+(define (subid-range->gexp range)
+ "Turn RANGE, a <subid-range> object, into a list-valued gexp suitable for
+'activate-subuids+subgids'."
+ (define count (subid-range-count range))
+ #~`(#$(subid-range-name range)
+ #$(subid-range-start range)
+ #$(if (and (number? count)
+ (> count 0))
+ count
+ %sub-id-count)))
+
+(define (assert-valid-subids ranges)
+ (cond ((>= (fold + 0 (map subid-range-count ranges))
+ (- %sub-id-max %sub-id-min -1))
+ (raise
+ (string-append
+ "The configured ranges are more than the "
+ (- %sub-id-max %sub-id-min -1) " max allowed.")))
+ ((any (lambda (r)
+ (define start (subid-range-start r))
+ (and start
+ (< start %sub-id-min)))
+ ranges)
+ (raise
+ (string-append
+ "One subid-range starts before the minimum allowed sub id "
+ %sub-id-min ".")))
+ ((any (lambda (r)
+ (define end (subid-range-end r))
+ (and end
+ (> end %sub-id-max)))
+ ranges)
+ (raise
+ (string-append
+ "One subid-range ends after the maximum allowed sub id "
+ %sub-id-max ".")))
+ ((any (compose null? subid-range-name)
+ ranges)
+ (raise
+ "One subid-range has a null name."))
+ ((any (compose string-null? subid-range-name)
+ ranges)
+ (raise
+ "One subid-range has a name equal to the empty string."))
+ (else #t)))
+
+(define (delete-duplicate-ranges ranges)
+ (delete-duplicates ranges
+ (lambda args
+ (apply string=? (map subid-range-name ranges)))))
+
+(define (subids-activation config)
+ "Return a gexp that activates SUBUIDS+SUBGIDS, a list of <subid-range>
+objects."
+ (define (add-root-when-missing ranges)
+ (define sorted-ranges
+ (sort-list ranges subid-range-less))
+ (define root-missing?
+ (not
+ (find (lambda (r)
+ (string=? "root"
+ (subid-range-name r)))
+ sorted-ranges)))
+ (define first-start
+ (and (> (length sorted-ranges) 0)
+ (subid-range-start (first sorted-ranges))))
+ (define first-has-start?
+ (number? first-start))
+ (define root-start
+ (if first-has-start?
+ (and
+ (> first-start %sub-id-min)
+ %sub-id-min)
+ %sub-id-min))
+ (define root-count
+ (if first-has-start?
+ (- first-start %sub-id-min)
+ %sub-id-count))
+ (if (and root-missing?
+ (subids-configuration-add-root? config))
+ (append (list (%root-subid root-start root-count))
+ sorted-ranges)
+ sorted-ranges))
+
+ (define subuids
+ (delete-duplicate-ranges (subids-configuration-subuids config)))
+
+ (define subuids-specs
+ (map subid-range->gexp (add-root-when-missing subuids)))
+
+ (define subgids
+ (delete-duplicate-ranges (subids-configuration-subgids config)))
+
+ (define subgids-specs
+ (map subid-range->gexp (add-root-when-missing subgids)))
+
+ (assert-valid-subids subgids)
+ (assert-valid-subids subuids)
+
+ ;; Add subuids and subgids.
+ (with-imported-modules (source-module-closure '((gnu system accounts)))
+ #~(begin
+ (use-modules (gnu system accounts))
+
+ (activate-subuids+subgids (map sexp->subid-range (list #$@subuids-specs))
+ (map sexp->subid-range (list #$@subgids-specs))))))
+
+(define-record-type* <subids-extension>
+ subids-extension make-subids-extension
+ subids-extension?
+ this-subids-extension
+
+ (subgids subids-extension-subgids ; list of <subid-range>
+ (default '()))
+ (subuids subids-extension-subuids ; list of <subid-range>
+ (default '())))
+
+(define append-subid-ranges
+ (lambda args
+ (delete-duplicate-ranges
+ (apply append args))))
+
+(define (subids-extension-merge a b)
+ (subids-extension
+ (subgids (append-subid-ranges
+ (subids-extension-subgids a)
+ (subids-extension-subgids b)))
+ (subuids (append-subid-ranges
+ (subids-extension-subuids a)
+ (subids-extension-subuids b)))))
+
+(define subids-service-type
+ (service-type (name 'subids)
+ ;; Concatenate <subid-range> lists.
+ (compose (lambda (args)
+ (fold subids-extension-merge
+ (subids-extension)
+ args)))
+ (extend
+ (lambda (config extension)
+ (subids-configuration
+ (inherit config)
+ (subgids
+ (append-subid-ranges
+ (subids-configuration-subgids config)
+ (subids-extension-subgids extension)))
+ (subuids
+ (append-subid-ranges
+ (subids-configuration-subuids config)
+ (subids-extension-subuids extension))))))
+ (extensions
+ (list (service-extension activation-service-type
+ subids-activation)))
+ (default-value
+ (subids-configuration))
+ (description
+ "Ensure the specified sub UIDs and sub GIDs exist in
+/etc/subuid and /etc/subgid.")))
+
;;; shadow.scm ends here
new file mode 100644
@@ -0,0 +1,128 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; 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 tests shadow)
+ #:use-module (gnu packages base)
+ #:use-module (gnu tests)
+ #:use-module (gnu services)
+ #:use-module (gnu system)
+ #:use-module (gnu system accounts)
+ #:use-module (gnu system shadow)
+ #:use-module (gnu system vm)
+ #:use-module (guix gexp)
+ #:export (%test-subids))
+
+
+(define %subids-os
+ (simple-operating-system
+ (simple-service
+ 'simple-subids
+ subids-service-type
+ (subids-extension
+ (subgids
+ (list
+ (subid-range
+ (name "alice"))
+ (subid-range
+ (name "bob")
+ (start 100700))))
+ (subuids
+ (list
+ (subid-range
+ (name "alice"))))))))
+
+(define (run-subids-test)
+ "Run IMAGE as an OCI backed Shepherd service, inside OS."
+
+ (define os
+ (marionette-operating-system
+ (operating-system-with-gc-roots
+ %subids-os
+ (list))
+ #:imported-modules '((gnu services herd)
+ (guix combinators))))
+
+ (define vm
+ (virtual-machine
+ (operating-system os)
+ (volatile? #f)
+ (memory-size 1024)
+ (disk-image-size (* 3000 (expt 2 20)))
+ (port-forwardings '())))
+
+ (define test
+ (with-imported-modules '((gnu build marionette))
+ #~(begin
+ (use-modules (srfi srfi-11) (srfi srfi-64)
+ (gnu build marionette))
+
+ (define marionette
+ ;; Relax timeout to accommodate older systems and
+ ;; allow for pulling the image.
+ (make-marionette (list #$vm) #:timeout 60))
+
+ (test-runner-current (system-test-runner #$output))
+ (test-begin "subids")
+
+ (test-equal "/etc/subid and /etc/subgid are created and their content is sound"
+ '("root:100000:700\nbob:100700:65536\nalice:166236:65536"
+ "root:100000:65536\nalice:165536:65536")
+ (marionette-eval
+ `(begin
+ (use-modules (ice-9 popen)
+ (ice-9 match)
+ (ice-9 rdelim))
+
+ (define (read-lines file-or-port)
+ (define (loop-lines port)
+ (let loop ((lines '()))
+ (match (read-line port)
+ ((? eof-object?)
+ (reverse lines))
+ (line
+ (loop (cons line lines))))))
+
+ (if (port? file-or-port)
+ (loop-lines file-or-port)
+ (call-with-input-file file-or-port
+ loop-lines)))
+
+ (define slurp
+ (lambda args
+ (let* ((port (apply open-pipe* OPEN_READ args))
+ (output (read-lines port))
+ (status (close-pipe port)))
+ output)))
+ (let* ((response1 (slurp
+ ,(string-append #$coreutils "/bin/cat")
+ "/etc/subgid"))
+ (response2 (slurp
+ ,(string-append #$coreutils "/bin/cat")
+ "/etc/subuid")))
+ (list (string-join response1 "\n") (string-join response2 "\n"))))
+ marionette))
+
+ (test-end))))
+
+ (gexp->derivation "subids-test" test))
+
+(define %test-subids
+ (system-test
+ (name "subids")
+ (description "Test sub UIDs and sub GIDs provisioning service.")
+ (value (run-subids-test))))