[bug#72337] [PATCH v3 2/3] account: Add /etc/subid and /etc/subgid allocation logic.

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

* gnu/build/accounts.scm (list-set): New variable;
(%sub-id-min): new variable;
(%sub-id-max): new variable;
(%sub-id-count): new variable;
(sub-id?): new variable;
(subid-range-fits?): new variable;
(subid-range-fits-between?): new variable;
(insert-subid-range): new variable;
(reserve-subids): new variable;
(range->entry): new variable;
(entry->range): new variable;
(allocate-subids): new variable;
(subuid+subgid-databases): new variable.

* gnu/system/accounts.scm (subid-range-end): New variable;
(subid-range-has-start?): new variable;
(subid-range-less): new variable.

* test/accounts.scm: Test them.

Change-Id: I8de1fd7cfe508b9c76408064d6f498471da0752d
---
 gnu/build/accounts.scm  | 231 +++++++++++++++++++++++++++++++++++++++-
 gnu/system/accounts.scm |  30 ++++++
 tests/accounts.scm      | 108 +++++++++++++++++++
 3 files changed, 368 insertions(+), 1 deletion(-)

diff --git a/gnu/build/accounts.scm b/gnu/build/accounts.scm
index ea8c69f205..780cb5f7ff 100644
--- a/gnu/build/accounts.scm
+++ b/gnu/build/accounts.scm
@@ -74,8 +74,12 @@ (define-module (gnu build accounts)
             %id-max
             %system-id-min
             %system-id-max
+            %sub-id-min
+            %sub-id-max
+            %sub-id-count
 
-            user+group-databases))
+            user+group-databases
+            subuid+subgid-databases))
 
 ;;; Commentary:
 ;;;
@@ -91,6 +95,18 @@ (define-module (gnu build accounts)
 ;;;
 ;;; Code:
 
+\f
+;;;
+;;; General utilities.
+;;;
+
+(define (list-set lst el k)
+  (if (>= k (length lst))
+      `(,@lst ,el)
+      `(,@(list-head lst k)
+        ,el
+        ,@(list-tail lst k))))
+
 \f
 ;;;
 ;;; Machinery to define user and group databases.
@@ -342,6 +358,12 @@ (define %id-max 60000)
 (define %system-id-min 100)
 (define %system-id-max 999)
 
+;; According to Shadow's libmisc/find_new_sub_uids.c and
+;; libmisc/find_new_sub_gids.c.
+(define %sub-id-min 100000)
+(define %sub-id-max 600100000)
+(define %sub-id-count 65536)
+
 (define (system-id? id)
   (and (> id %system-id-min)
        (<= id %system-id-max)))
@@ -350,6 +372,10 @@ (define (user-id? id)
   (and (>= id %id-min)
        (< id %id-max)))
 
+(define (sub-id? id)
+  (and (>= id %sub-id-min)
+       (< id %sub-id-max)))
+
 (define* (allocate-id assignment #:key system?)
   "Return two values: a newly allocated ID, and an updated <allocation> record
 based on ASSIGNMENT.  If SYSTEM? is true, return a system ID."
@@ -405,6 +431,158 @@ (define* (reserve-ids allocation ids #:key (skip? #t))
               (allocation-ids allocation)
               ids))))
 
+(define (subid-range-fits? r interval-start interval-end)
+  (and (<= interval-start
+           (subid-range-start r))
+       (<= (subid-range-end r)
+           interval-end)))
+
+(define (subid-range-fits-between? r a b)
+  (subid-range-fits? r
+                     (+ (subid-range-start a) 1)
+                     (- (subid-range-end b) 1)))
+
+(define (insert-subid-range range lst)
+  (define* (actualize r #:key (start %sub-id-min))
+    (if (subid-range-has-start? r)
+        r
+        (subid-range
+         (inherit r)
+         (start start))))
+  (define lst-length (length lst))
+  (define range-name (subid-range-name range))
+  (define range-start (subid-range-start range))
+  (define has-start? (subid-range-has-start? range))
+  (define range-end (subid-range-end range))
+
+  (when has-start?
+    (unless (and (sub-id? range-start)
+                 (sub-id? range-end))
+      (raise
+       (string-append "Subid range of " range-name
+                      " from " (number->string range-start) " to "
+                      (number->string range-end)
+                      " spans over illegal subids.  Max allowed is "
+                      (number->string %sub-id-max) ", min is "
+                      (number->string %sub-id-min) "."))))
+
+  (if (<= lst-length 1)
+      (if (= lst-length 0)
+          (list (actualize range))
+          (if (subid-range-less range (first lst))
+              (list-set lst (actualize range) 0)
+              (list-set lst
+                        (actualize
+                         range
+                         #:start (and (subid-range-has-start? (first lst))
+                                      (+ (subid-range-end (first lst)) 1)))
+                        1)))
+      (let loop ((i 0))
+        (define next-i (+ i 1))
+        (define ith-range
+          (list-ref lst i))
+        (define ith-start
+          (subid-range-start ith-range))
+        (define ith-has-start?
+          (subid-range-has-start? ith-range))
+        (define ith-name
+          (subid-range-name ith-range))
+
+        (if (and
+             (= next-i lst-length)
+             (subid-range-less ith-range range))
+            (let ((actual-range
+                   (actualize
+                    range
+                    #:start (and ith-has-start?
+                                 (+ (subid-range-end ith-range) 1)))))
+              (list-set lst
+                        actual-range
+                        lst-length))
+            (let* ((next-range
+                    (list-ref lst next-i))
+                   (next-has-start?
+                    (subid-range-has-start? next-range)))
+              (cond
+
+               ((and has-start? (= range-start ith-start))
+                (raise
+                 (string-append "Subid range of " range-name
+                                " has same start "
+                                (number->string range-start)
+                                " of the one "
+                                "from " ith-name ".")))
+
+               ((and (= i 0)
+                     (subid-range-less range ith-range)
+                     (or
+                      (and
+                       has-start? ith-has-start?
+                       (subid-range-fits? (actualize range)
+                                          %sub-id-min
+                                          (- (subid-range-start
+                                              (actualize ith-range))
+                                             1)))
+                      (not (and has-start? ith-has-start?))))
+                (list-set lst (actualize range) 0))
+
+               ((subid-range-less range ith-range)
+                (raise
+                 (string-append "Subid range of " range-name
+                                " overlaps with the one of "
+                                ith-name ".")))
+
+               ((and (subid-range-less ith-range range)
+                     (subid-range-less range next-range))
+                (if (or (not (and has-start?
+                                  ith-has-start?
+                                  next-has-start?))
+
+                        (and has-start?
+                             ith-has-start?
+                             next-has-start?
+                             (subid-range-fits-between? range
+                                                        ith-range
+                                                        next-range)))
+                    (list-set lst
+                              (actualize range
+                                         #:start (and ith-has-start?
+                                                      (+ (subid-range-end ith-range) 1)))
+                              next-i)
+                    (if (>= i lst-length)
+                        (if (and (subid-range-less next-range range)
+                                 (let ((actual-next
+                                        (actualize next-range
+                                                   #:start (and ith-has-start?
+                                                                (+ (subid-range-end ith-range) 1)))))
+                                   (or (not (subid-range-has-start? actual-next))
+                                       (subid-range-fits?
+                                        (actualize range
+                                                   #:start (and next-has-start?
+                                                                (+ (subid-range-end next-range) 1)))
+                                        (+ (subid-range-end actual-next) 1)
+                                        %sub-id-max))))
+                            (list-set lst range lst-length)
+                            (raise
+                             (string-append "Couldn't fit " range-name ", reached end of list.")))
+                        (loop next-i))))
+
+               ((or
+                 (not has-start?)
+                 (subid-range-less next-range range))
+                (loop next-i))
+
+               (else
+                (raise (string-append "Couldn't fit " range-name ", this should never happen.")))))))))
+
+(define* (reserve-subids allocation ranges)
+  "Mark the subid ranges listed in RANGES as reserved in ALLOCATION.
+ALLOCATION is supposed to be sorted by SUBID-RANGE-LESS."
+  (fold insert-subid-range
+        allocation
+        (sort-list ranges
+                   subid-range-less)))
+
 (define (allocated? allocation id)
   "Return true if ID is already allocated as part of ALLOCATION."
   (->bool (vhash-assv id (allocation-ids allocation))))
@@ -540,6 +718,31 @@ (define* (allocate-passwd users groups #:optional (current-passwd '()))
           uids
           users)))
 
+(define (range->entry range)
+  (subid-entry
+   (name (subid-range-name range))
+   (start (subid-range-start range))
+   (count (subid-range-count range))))
+
+(define (entry->range entry)
+  (subid-range
+   (name (subid-entry-name entry))
+   (start (subid-entry-start entry))
+   (count (subid-entry-count entry))))
+
+(define* (allocate-subids ranges #:optional (current-ranges '()))
+  "Return a list of subids entries for RANGES, a list of <subid-range>.  Members
+for each group are taken from MEMBERS, a vhash that maps ranges names to member
+names.  IDs found in CURRENT-RANGES, a list of subid entries, are reused."
+  (define subids
+    ;; Mark all the currently used IDs and the explicitly requested IDs as
+    ;; reserved.
+    (reserve-subids (reserve-subids (list)
+                                    current-ranges)
+                    ranges))
+
+  (map range->entry subids))
+
 (define* (days-since-epoch #:optional (current-time current-time))
   "Return the number of days elapsed since the 1st of January, 1970."
   (let* ((now   (current-time time-utc))
@@ -615,3 +818,29 @@ (define* (user+group-databases users groups
                     #:current-time current-time))
 
   (values group-entries passwd-entries shadow-entries))
+
+(define* (subuid+subgid-databases subuids subgids
+                                  #:key
+                                  (current-subuids
+                                   (map entry->range
+                                        (empty-if-not-found read-subuid)))
+                                  (current-subgids
+                                   (map entry->range
+                                        (empty-if-not-found read-subgid))))
+  "Return two values: the list of subgid entries, and the list of subuid entries
+corresponding to SUBUIDS and SUBGIDS.
+Preserve stateful bits from CURRENT-SUBUIDS and CURRENT-SUBGIDS."
+
+  (define (range-eqv? a b)
+    (string=? (subid-range-name a)
+              (subid-range-name b)))
+
+  (define subuid-entries
+    (allocate-subids
+     (lset-difference range-eqv? subuids current-subuids) current-subuids))
+
+  (define subgid-entries
+    (allocate-subids
+     (lset-difference range-eqv? subgids current-subgids) current-subgids))
+
+  (values subuid-entries subgid-entries))
diff --git a/gnu/system/accounts.scm b/gnu/system/accounts.scm
index 9a006c188d..1b88ca301f 100644
--- a/gnu/system/accounts.scm
+++ b/gnu/system/accounts.scm
@@ -45,6 +45,9 @@ (define-module (gnu system accounts)
             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
@@ -102,6 +105,33 @@ (define-record-type* <subid-range>
                   ; 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)))
diff --git a/tests/accounts.scm b/tests/accounts.scm
index 4944c22f49..2fbebfaf56 100644
--- a/tests/accounts.scm
+++ b/tests/accounts.scm
@@ -193,6 +193,7 @@ (define %subgid-sample
 \f
 (define allocate-groups (@@ (gnu build accounts) allocate-groups))
 (define allocate-passwd (@@ (gnu build accounts) allocate-passwd))
+(define allocate-subids (@@ (gnu build accounts) allocate-subids))
 
 (test-equal "allocate-groups"
   ;; Allocate GIDs in a stateless fashion.
@@ -257,6 +258,69 @@ (define allocate-passwd (@@ (gnu build accounts) allocate-passwd))
                    (list (group-entry (name "d")
                                       (gid (- %id-max 2))))))
 
+(test-equal "allocate-subids"
+  ;; Allocate sub IDs in a stateless fashion.
+  (list (subid-entry (name "root") (start %sub-id-min) (count 100))
+        (subid-entry (name "t") (start 100100) (count 899))
+        (subid-entry (name "x") (start 100999) (count 200)))
+  (allocate-subids (list
+                    (subid-range (name "x") (count 200))
+                    (subid-range (name "t") (count 899)))
+                   (list (subid-range (name "root") (count 100)))))
+
+(test-equal "allocate-subids with requested IDs ranges"
+  ;; Make sure the requested sub ID for "t" and "x" are honored.
+  (list (subid-entry (name "x") (start %sub-id-min) (count 200))
+        (subid-entry (name "t") (start 1000000) (count 899))
+        (subid-entry (name "l") (start 1000899) (count 100))
+        (subid-entry (name "root") (start 1000999) (count 100)))
+  (allocate-subids (list
+                    (subid-range (name "root") (count 100))
+                    (subid-range (name "l") (count 100)))
+                   (list
+                    (subid-range (name "x") (start %sub-id-min) (count 200))
+                    (subid-range (name "t") (start 1000000) (count 899)))))
+
+(test-equal "allocate-subids with interleaving"
+  ;; Make sure the requested sub ID for "m" is honored.
+  (list (subid-entry (name "x") (start %sub-id-min) (count 200))
+        (subid-entry (name "t") (start 1000000) (count 899))
+        (subid-entry (name "i") (start 1100000) (count 1))
+        (subid-entry (name "root") (start 1100001) (count 100))
+        (subid-entry (name "m") (start 1200000) (count 27)))
+  (allocate-subids (list (subid-range (name "m") (start 1200000) (count 27)))
+                   (list
+                    (subid-range (name "x") (start %sub-id-min) (count 200))
+                    (subid-range (name "t") (start 1000000) (count 899))
+                    (subid-range (name "i") (start 1100000) (count 1))
+                    (subid-range (name "root") (count 100)))))
+
+(let ((inputs+currents
+       (list
+        ;; Try impossible before
+        (list
+         (list (subid-range (name "m") (start 100100) (count 27)))
+         (list
+          (subid-range (name "x") (start %sub-id-min) (count 150))))
+        ;; Try impossible after
+        (list
+         (list (subid-range (name "m") (start %sub-id-min) (count 30)))
+         (list
+          (subid-range (name "x") (start (+ 29 %sub-id-min)) (count 150))))
+        ;; Try impossible between
+        (list
+         (list (subid-range (name "m") (start 100200) (count 500)))
+         (list
+          (subid-range (name "root") (start %sub-id-min) (count 100))
+          (subid-range (name "x") (start (+ %sub-id-min 500)) (count 100)))))))
+  (test-error "allocate-subids with interleaving, impossible interleaving"
+              "error"
+              ;; Make sure it's impossible to explicitly request impossible allocations
+              (for-each
+               (lambda (lst)
+                 (allocate-subids (first lst) (second lst)))
+               inputs+currents)))
+
 (test-equal "allocate-passwd"
   ;; Allocate UIDs in a stateless fashion.
   (list (password-entry (name "alice") (uid %id-min) (gid 1000)
@@ -376,4 +440,48 @@ (define allocate-passwd (@@ (gnu build accounts) allocate-passwd))
                                 (make-time type 0 (* 24 3600 100)))))
     list))
 
+(test-equal "subuid+subgid-databases"
+  ;; The whole process.
+  (list (list (subid-entry (name "root")
+                           (start %sub-id-min)
+                           (count 100))
+              (subid-entry (name "alice")
+                           (start (+ %sub-id-min 100))
+                           (count 200))
+              (subid-entry (name "bob")
+                           (start (+ %sub-id-min 100 200))
+                           (count 200)))
+        (list
+         (subid-entry (name "root")
+                      (start %sub-id-min)
+                      (count 200))
+         (subid-entry (name "alice")
+                      (start (+ %sub-id-min 200))
+                      (count 400))
+         (subid-entry (name "charlie")
+                      (start (+ %sub-id-min 200 400))
+                      (count 300))))
+  (call-with-values
+      (lambda ()
+        (subuid+subgid-databases
+         (list (subid-range (name "root")
+                            (start %sub-id-min)
+                            (count 100))
+               (subid-range (name "alice")
+                            (start (+ %sub-id-min 100))
+                            (count 200))
+               (subid-range (name "bob")
+                            (count 200)))
+         (list
+          (subid-range (name "alice")
+                       (count 400))
+          (subid-range (name "charlie")
+                       (count 300)))
+         #:current-subgids
+         (list (subid-range (name "root")
+                            (start %sub-id-min)
+                            (count 200)))
+         #:current-subuids '()))
+    list))
+
 (test-end "accounts")
-- 
2.45.2