Toggle diff (472 lines)
diff --git a/gnu/build/accounts.scm b/gnu/build/accounts.scm
index ea8c69f205..be981fca38 100644
--- a/gnu/build/accounts.scm
+++ b/gnu/build/accounts.scm
@@ -25,6 +25,8 @@ (define-module (gnu build accounts)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
#:use-module (ice-9 rdelim)
@@ -74,8 +76,19 @@ (define-module (gnu build accounts)
%id-max
%system-id-min
%system-id-max
+ %subordinate-id-min
+ %subordinate-id-max
+ %subordinate-id-count
- user+group-databases))
+ &subordinate-id-error
+ subordinate-id-error?
+ &subordinate-id-range-error
+ subordinate-id-range-error?
+ subordinate-id-range-error-message
+ subordinate-id-range-error-ranges
+
+ user+group-databases
+ subuid+subgid-databases))
;;; Commentary:
;;;
@@ -91,6 +104,18 @@ (define-module (gnu build accounts)
;;;
;;; Code:
+
+;;;
+;;; General utilities.
+;;;
+
+(define (vlist-set vlst el k)
+ (if (>= k (vlist-length vlst))
+ (vlist-append vlst (vlist-cons el vlist-null))
+ (vlist-append
+ (vlist-take vlst k)
+ (vlist-cons el (vlist-drop vlst k)))))
+
;;;
;;; Machinery to define user and group databases.
@@ -342,6 +367,19 @@ (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 %subordinate-id-min 100000)
+(define %subordinate-id-max 600100000)
+(define %subordinate-id-count 65536)
+
+(define-condition-type &subordinate-id-error &error
+ subordinate-id-error?)
+(define-condition-type &subordinate-id-range-error &subordinate-id-error
+ subordinate-id-range-error?
+ (message subordinate-id-range-error-message)
+ (ranges subordinate-id-range-error-ranges))
+
(define (system-id? id)
(and (> id %system-id-min)
(<= id %system-id-max)))
@@ -350,6 +388,10 @@ (define (user-id? id)
(and (>= id %id-min)
(< id %id-max)))
+(define (subordinate-id? id)
+ (and (>= id %subordinate-id-min)
+ (< id %subordinate-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 +447,90 @@ (define* (reserve-ids allocation ids #:key (skip? #t))
(allocation-ids allocation)
ids))))
+(define (within-interval? start end range)
+ "Returns #t when RANGE is included in the interval
+bounded by START and END. Both ends of the interval
+are included in the comparison."
+ (unless (subid-range-has-start? range)
+ (raise
+ (condition
+ (&subordinate-id-range-error
+ (ranges (list range))
+ (message
+ "Subid ranges should have a start to be tested within
+an interval.")))))
+ (and (<= start
+ (subid-range-start range))
+ (<= (subid-range-end range)
+ end)))
+
+(define (insert-subid-range range vlst)
+ "Allocates a range of subids in VLST, based on RANGE. Ranges
+that do not explicitly specify a start subid are fitted based on
+their size. This procedure assumes VLIST is sorted by SUBID-RANGE-LESS and
+that all VLST members have a start."
+ (define* (actualize r #:key (start %subordinate-id-min))
+ (if (subid-range-has-start? r)
+ r
+ (subid-range
+ (inherit r)
+ (start start))))
+
+ (define vlst-length (vlist-length vlst))
+ (define range-name (subid-range-name range))
+ (define range-start (subid-range-start range))
+ (define range-end (subid-range-end range))
+
+ (when (subid-range-has-start? range)
+ (unless (and (subordinate-id? range-start)
+ (subordinate-id? range-end))
+ (raise
+ (condition
+ (&subordinate-id-range-error
+ (ranges (list range))
+ (message
+ (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 %subordinate-id-max) ", min is "
+ (number->string %subordinate-id-min) ".")))))))
+
+ (let loop ((i 0)
+ (start %subordinate-id-min)
+ (end (if (< vlst-length 1)
+ %subordinate-id-max
+ (- (subid-range-start
+ (vlist-ref vlst 0))
+ 1))))
+ (define actual-range
+ (actualize range #:start start))
+ (cond
+ ((> i vlst-length)
+ (raise
+ (condition
+ (&subordinate-id-range-error
+ (ranges (list range))
+ (message
+ (string-append "Couldn't fit " range-name
+ ", reached end of list."))))))
+ ((within-interval? start end actual-range)
+ (vlist-set vlst actual-range i))
+ (else
+ (loop (+ i 1)
+ (+ 1 (subid-range-end
+ (vlist-ref vlst (if (= i vlst-length) (- i 1) i))))
+ (if (>= i (- vlst-length 1))
+ %subordinate-id-max
+ (- (subid-range-start
+ (vlist-ref vlst (+ i 1)))
+ 1)))))))
+
+(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."
+ (vlist-fold insert-subid-range allocation ranges))
+
(define (allocated? allocation id)
"Return true if ID is already allocated as part of ALLOCATION."
(->bool (vhash-assv id (allocation-ids allocation))))
@@ -540,6 +666,39 @@ (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."
+ (when (any (compose not subid-range-has-start?) current-ranges)
+ (raise
+ (condition
+ (&subordinate-id-range-error
+ (ranges current-ranges)
+ (message "Loaded ranges are supposed to have a start, but at least one does not.")))))
+ (define subids
+ ;; Mark all the currently used IDs and the explicitly requested IDs as
+ ;; reserved.
+ (reserve-subids (reserve-subids vlist-null
+ (list->vlist current-ranges))
+ (list->vlist
+ (stable-sort ranges
+ subid-range-less))))
+
+ (map range->entry (vlist->list 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 +774,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..3d038568df 100644
--- a/tests/accounts.scm
+++ b/tests/accounts.scm
@@ -21,6 +21,7 @@ (define-module (test-accounts)
#:use-module (gnu build accounts)
#:use-module (gnu system accounts)
#:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-34)
#:use-module (srfi srfi-64)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match))
@@ -193,6 +194,7 @@ (define %subgid-sample
(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 +259,112 @@ (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 %subordinate-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")
+ (start %subordinate-id-min)
+ (count 100)))))
+
+(test-equal "allocate-subids with requested IDs ranges"
+ ;; Make sure the requested sub ID for "k" and "root" are honored.
+ (list (subid-entry (name "x") (start %subordinate-id-min) (count 200))
+ (subid-entry (name "k") (start (+ %subordinate-id-min 300)) (count 100))
+ (subid-entry (name "t") (start (+ %subordinate-id-min 500)) (count 899))
+ (subid-entry (name "root") (start (+ %subordinate-id-min 2500)) (count 100)))
+
+ (allocate-subids (list
+ (subid-range (name "root") (start (+ %subordinate-id-min 2500)) (count 100))
+ (subid-range (name "k") (start (+ %subordinate-id-min 300)) (count 100)))
+ (list
+ (subid-range (name "x") (start %subordinate-id-min) (count 200))
+ (subid-range (name "t") (start (+ %subordinate-id-min 500)) (count 899)))))
+
+(let ((inputs+currents
+ (list
+ (list
+ "ranges must have start"
+ (list (subid-range (name "m")))
+ (list (subid-range (name "x")))
+ "Loaded ranges are supposed to have a start, but at least one does not.")
+ (list
+ "ranges must fall within allowed max min subids"
+ (list (subid-range (name "m")
+ (start (- %subordinate-id-min 1))
+ (count
+ (+ %subordinate-id-max %subordinate-id-min))))
+ (list
+ (subid-range (name "root") (start %subordinate-id-min)))
+ "Subid range of m from 99999 to 600299998 spans over illegal subids. Max allowed is 600100000, min is 100000."))))
+
+ ;; Make sure it's impossible to explicitly request impossible allocations
+ (for-each
+ (match-lambda
+ ((test-name ranges current-ranges message)
+ (test-assert (string-append "allocate-subids, impossible allocations - "
+ test-name)
+ (guard (c ((and (subordinate-id-range-error? c)
+ (string=? message (subordinate-id-range-error-message c)))
+ #t))
+ (allocate-subids ranges current-ranges)
+ #f))))
+ inputs+currents))
+
+(test-equal "allocate-subids with interleaving"
+ ;; Make sure the requested sub ID for "m" is honored and
+ ;; for "l" and "i" are correctly deduced.
+ (list (subid-entry (name "x") (start %subordinate-id-min) (count 200))
+ (subid-entry (name "l") (start (+ %subordinate-id-min 200)) (count 1))
+ (subid-entry (name "m") (start (+ %subordinate-id-min 201)) (count 27))
+ (subid-entry (name "i") (start (+ %subordinate-id-min 228)) (count 2))
+ (subid-entry (name "root") (start (+ %subordinate-id-min 231)) (count 100)))
+ (allocate-subids (list
+ (subid-range (name "m") (start (+ %subordinate-id-min 201)) (count 27))
+ (subid-range (name "l") (count 1))
+ (subid-range (name "i") (count 2)))
+ (list
+ (subid-range (name "x") (start %subordinate-id-min) (count 200))
+ (subid-range (name "root") (start (+ %subordinate-id-min 231)) (count 100)))))
+
+(let ((inputs+currents
+ (list
+ ;; Try impossible before
+ (list
+ (list (subid-range (name "m") (start %subordinate-id-min) (count 16)))
+ (list
+ (subid-range (name "x") (start (+ 15 %subordinate-id-min)) (count 150)))
+ "Couldn't fit m, reached end of list.")
+ ;; Try impossible after
+ (list
+ (list (subid-range (name "m") (start %subordinate-id-min) (count 30)))
+ (list
+ (subid-range (name "x") (start (+ 29 %subordinate-id-min)) (count 150)))
+ "Couldn't fit m, reached end of list.")
+ ;; Try impossible between
+ (list
+ (list (subid-range (name "m") (start 100200) (count 500)))
+ (list
+ (subid-range (name "root") (start %subordinate-id-min) (count 100))
+ (subid-range (name "x") (start (+ %subordinate-id-min 500)) (count 100)))
+ "Couldn't fit m, reached end of list."))))
+
+ ;; Make sure it's impossible to explicitly request impossible allocations
+ (for-each
+ (match-lambda
+ ((ranges current-ranges message)
+ (test-assert "allocate-subids with interleaving, impossible interleaving"
+ (guard (c ((and (subordinate-id-range-error? c)
+ (string=? message (subordinate-id-range-error-message c)))
+ #t))
+ (allocate-subids ranges current-ranges)
+ #f))))
+ inputs+currents))
+
(test-equal "allocate-passwd"
;; Allocate UIDs in a stateless fashion.
(list (password-entry (name "alice") (uid %id-min) (gid 1000)
@@ -376,4 +484,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 %subordinate-id-min)
+ (count 100))
+ (subid-entry (name "alice")
+ (start (+ %subordinate-id-min 100))
+ (count 200))
+ (subid-entry (name "bob")
+ (start (+ %subordinate-id-min 100 200))
+ (count 200)))
+ (list
+ (subid-entry (name "root")
+ (start %subordinate-id-min)
+ (count 200))
+ (subid-entry (name "alice")
+ (start (+ %subordinate-id-min 200))
+ (count 400))
+ (subid-entry (name "charlie")
+ (start (+ %subordinate-id-min 200 400))
+ (count 300))))
+ (call-with-values
+ (lambda ()
+ (subuid+subgid-databases
+ (list (subid-range (name "root")
+ (start %subordinate-id-min)
+ (count 100))
+ (subid-range (name "alice")
+ (start (+ %subordinate-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 %subordinate-id-min)
+ (count 200)))
+