[bug#72337] [PATCH v3 3/3] system: Add /etc/subuid and /etc/subgid support.

[Giacomo Leidi via Guix-patches via <guix-patches@gnu.org>]

This commit adds a Guix System service to handle allocation of subuid
and subgid requests.  Users that don't care can just add themselves as a
subid-range and don't need to specify anything but their user name.
Users that care about specific ranges, such as possibly LXD, can specify
a start and a count.

* doc/guix.texi: Document the new service.
* gnu/build/activation.scm (activate-subuids+subgids): New variable.
* gnu/local.mk: Add gnu/tests/shadow.scm.
* gnu/system/accounts.scm (sexp->subid-range): New variable.
* gnu/system/shadow.scm (%root-subid): New variable;
(subids-configuration): new record;
(subid-range->gexp): new variable;
(assert-valid-subids): new variable;
(delete-duplicate-ranges): new variable;
(subids-activation): new variable;
(subids-extension): new record;
(append-subid-ranges): new variable;
(subids-extension-merge): new variable;
(subids-service-type): new variable.
* gnu/tests/shadow.scm (subids): New system test.

Change-Id: I3755e1c75771220c74fe8ae5de1a7d90f2376635
---
 doc/guix.texi            | 171 ++++++++++++++++++++++++++++++++
 gnu/build/activation.scm |  19 ++++
 gnu/local.mk             |   1 +
 gnu/system/accounts.scm  |  10 ++
 gnu/system/shadow.scm    | 208 ++++++++++++++++++++++++++++++++++++++-
 gnu/tests/shadow.scm     | 128 ++++++++++++++++++++++++
 6 files changed, 535 insertions(+), 2 deletions(-)
 create mode 100644 gnu/tests/shadow.scm

diff --git a/doc/guix.texi b/doc/guix.texi
index 0e1e253b02..a799342769 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -41647,6 +41647,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 Privileged Programs
diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index a57ca78a86..91662fe0fd 100644
--- a/gnu/build/activation.scm
+++ b/gnu/build/activation.scm
@@ -10,6 +10,7 @@
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;; Copyright © 2022 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr>
+;;; Copyright © 2024 Giacomo Leidi <goodoldpaul@autistici.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -40,6 +41,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-privileged-programs
@@ -203,6 +205,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."
diff --git a/gnu/local.mk b/gnu/local.mk
index 3b0a3858f7..88467e3d42 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -839,6 +839,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		        \
diff --git a/gnu/system/accounts.scm b/gnu/system/accounts.scm
index 1b88ca301f..f63d7f96bd 100644
--- a/gnu/system/accounts.scm
+++ b/gnu/system/accounts.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)))))
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index d9f13271d8..f0129afe8e 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -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)
 
 \f
 ;;;
-;;; Service.
+;;; Accounts Service.
 ;;;
 
 (define (user-group->gexp group)
@@ -521,4 +535,194 @@ (define (account-service accounts+groups skeletons)
   (service account-service-type
            (append skeletons accounts+groups)))
 
+\f
+;;;
+;;; 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 "
+           (number->string
+            (- %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 "
+           (number->string %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 "
+           (number->string %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
diff --git a/gnu/tests/shadow.scm b/gnu/tests/shadow.scm
new file mode 100644
index 0000000000..1e755b5438
--- /dev/null
+++ b/gnu/tests/shadow.scm
@@ -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))
+
+\f
+(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))))
-- 
2.45.2