diff options
| -rw-r--r-- | gnu/build/accounts.scm | 319 | ||||
| -rw-r--r-- | gnu/system/accounts.scm | 30 | ||||
| -rw-r--r-- | tests/accounts.scm | 134 |
3 files changed, 481 insertions, 2 deletions
diff --git a/gnu/build/accounts.scm b/gnu/build/accounts.scm index ea8c69f205..74f49ff9b4 100644 --- a/gnu/build/accounts.scm +++ b/gnu/build/accounts.scm @@ -25,8 +25,11 @@ #: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 receive) #:use-module (ice-9 rdelim) #:export (password-entry password-entry? @@ -74,8 +77,27 @@ %id-max %system-id-min %system-id-max - - user+group-databases)) + %subordinate-id-min + %subordinate-id-max + %subordinate-id-count + + &subordinate-id-error + subordinate-id-error? + &subordinate-id-overflow-error + subordinate-id-overflow-error? + subordinate-id-overflow-error-range + &invalid-subid-range-error + invalid-subid-range-error? + invalid-subid-range-error-range + &specific-subid-range-expected-error + specific-subid-range-expected-error? + specific-subid-range-expected-error-range + &generic-subid-range-expected-error + generic-subid-range-expected-error? + generic-subid-range-expected-error-range + + user+group-databases + subuid+subgid-databases)) ;;; Commentary: ;;; @@ -331,6 +353,18 @@ to it atomically and set the appropriate permissions." (next-id allocation-next-id (default %id-min)) (next-system-id allocation-next-system-id (default %system-id-max))) +(define-record-type* <unused-subid-range> + unused-subid-range make-unused-subid-range + unused-subid-range? + (left unused-subid-range-left ;previous unused subuid range or #f + (default #f)) + (min unused-subid-range-min ;lower bound of this unused subuid range + (default %subordinate-id-min)) + (max unused-subid-range-max ;upper bound + (default %subordinate-id-max)) + (right unused-subid-range-right ;next unused subuid range or #f + (default #f))) + ;; Trick to avoid name clashes... (define-syntax %allocation (identifier-syntax allocation)) @@ -342,6 +376,27 @@ to it atomically and set the appropriate permissions." (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-overflow-error &subordinate-id-error + subordinate-id-overflow-error? + (range subordinate-id-overflow-error)) +(define-condition-type &invalid-subid-range-error &subordinate-id-error + invalid-subid-range-error? + (range invalid-subid-range-error-range)) +(define-condition-type &specific-subid-range-expected-error &subordinate-id-error + specific-subid-range-expected-error? + (range specific-subid-range-expected-error-range)) +(define-condition-type &generic-subid-range-expected-error &subordinate-id-error + generic-subid-range-expected-error? + (range generic-subid-range-expected-error-range)) + (define (system-id? id) (and (> id %system-id-min) (<= id %system-id-max))) @@ -350,6 +405,10 @@ to it atomically and set the appropriate permissions." (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 +464,194 @@ a system ID allocation) number among IDS." (allocation-ids allocation) ids)))) +(define (within-interval? allocation range) + "Returns #t when RANGE is included in the ALLOCATION. +Both ends of the ALLOCATION are included in the comparison." + (define allocation-start + (unused-subid-range-min allocation)) + (define allocation-end + (unused-subid-range-max allocation)) + (unless (subid-range-has-start? range) + (raise + (condition + (&specific-subid-range-expected-error + (range range))))) + (and (<= allocation-start + (subid-range-start range)) + (<= (subid-range-end range) + allocation-end))) + +(define (allocate-unused-range allocation actual-range) + "Allocates RANGE inside ALLOCATION. RANGE is assumed to be +@code{within-interval?} of ALLOCATION, a new @code{unused-subid-range} record is +returned with all the subids contained in RANGE marked as used." + (define allocation-start + (unused-subid-range-min allocation)) + (define allocation-end + (unused-subid-range-max allocation)) + (define allocation-left + (unused-subid-range-left allocation)) + (define allocation-right + (unused-subid-range-left allocation)) + (define range-start + (subid-range-start actual-range)) + (define range-end + (subid-range-end actual-range)) + (define new-start + (+ 1 range-end)) + (define new-end + (- range-start 1)) + (if (or (= allocation-start range-start) + (= allocation-end range-end)) + (unused-subid-range + (inherit allocation) + (min (if (= allocation-start range-start) + new-start + allocation-start)) + (max (if (= allocation-end range-end) + new-end + allocation-end))) + (let* ((left-child? + (<= (- range-start allocation-start) + (- allocation-end range-end))) + (child + (unused-subid-range + (min allocation-start) + (max new-end) + (left + (and left-child? + allocation-left)) + (right + (and (not left-child?) + allocation-right))))) + (unused-subid-range + (inherit allocation) + (min new-start) + (max allocation-end) + (left + (if left-child? + child + allocation-left)) + (right + (if left-child? + allocation-right + child)))))) + +(define (allocate-generic-range allocation range) + "Allocates a range of subids in ALLOCATION, based on RANGE. RANGE is expected +to be a generic range i.e. to not have an explicit start subordinate id. All +nodes in ALLOCATION are visited and the first where RANGE is +@code{within-interval?} will be selected, the subordinate ids contained in RANGE +will be marked as used in it." + (when (subid-range-has-start? range) + (raise + (condition + (&generic-subid-range-expected-error + (ranges range))))) + (define left (unused-subid-range-left allocation)) + (define right (unused-subid-range-right allocation)) + (define allocation-start + (unused-subid-range-min allocation)) + (define actual-range + (subid-range + (inherit range) + (start allocation-start))) + + (if (within-interval? allocation actual-range) + (values + (allocate-unused-range allocation actual-range) + actual-range) + (if left + (let-values (((new-left new-range) + (allocate-generic-range left range))) + (values (unused-subid-range + (inherit allocation) + (left new-left)) + new-range)) + (if right + (let-values (((new-right new-range) + (allocate-generic-range right range))) + (values (unused-subid-range + (inherit allocation) + (left new-right)) + new-range)) + (raise + (condition + (&subordinate-id-overflow-error + (range range)))))))) + +(define (allocate-specific-range allocation range) + "Allocates a range of subids in ALLOCATION, based on RANGE. RANGE is expected +to be a specific range i.e. to have an explicit start subordinate id. ALLOCATION +is visited to find the best unused range that can hold RANGE." + (unless (subid-range-has-start? range) + (raise + (condition + (&specific-subid-range-expected-error + (range range))))) + (define allocation-left + (unused-subid-range-left allocation)) + (define allocation-right + (unused-subid-range-right allocation)) + (define allocation-start + (unused-subid-range-min allocation)) + (define allocation-end + (unused-subid-range-max allocation)) + + (define range-start + (subid-range-start range)) + (define range-end + (subid-range-end range)) + + (unless (and (subordinate-id? range-start) + (subordinate-id? range-end)) + (raise + (condition + (&invalid-subid-range-error + (range range))))) + + (define less? + (< range-end allocation-start)) + (define more? + (> range-start allocation-end)) + + (cond ((within-interval? allocation range) + (values (allocate-unused-range allocation range) + range)) + ((and allocation-left less?) + (let-values (((new-left _) + (allocate-specific-range allocation-left range))) + (values (unused-subid-range + (inherit allocation) + (left new-left)) + range))) + ((and allocation-right more?) + (let-values (((new-right _) + (allocate-specific-range allocation-right range))) + (values (unused-subid-range + (inherit allocation) + (right new-right)) + range))) + (else + (raise + (condition + (&subordinate-id-overflow-error + (range range))))))) + +(define* (reserve-subids allocation ranges) + "Mark the subid ranges listed in RANGES as reserved in ALLOCATION." + (fold (lambda (range state) + (define-values (new-allocation actual-range) + ((if (subid-range-has-start? range) + allocate-specific-range + allocate-generic-range) + (first state) + range)) + (list new-allocation + (cons actual-range + (second state)))) + (list 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 +787,48 @@ new UIDs." 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>. IDs +found in CURRENT-RANGES, a list of subid entries, are reused." + (let ((generic (any (compose not subid-range-has-start?) current-ranges))) + (when generic + (raise + (condition + (&specific-subid-range-expected-error + (range generic)))))) + (define sorted-ranges + (stable-sort ranges + subid-range-less)) + (define current-allocation+subids + (reserve-subids (unused-subid-range) + current-ranges)) + (define subids + ;; Reserve first specific subid-ranges + ;; and later generic ones. + (second + (reserve-subids (first + current-allocation+subids) + sorted-ranges))) + + (map range->entry + ;; Produce deterministic subid collections. + (stable-sort + (append (second current-allocation+subids) + subids) + subid-range-less))) + (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 +904,29 @@ CURRENT-SHADOW: UIDs, GIDs, passwords, user shells, etc." #: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 @@ 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 @@ ; 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..9df93e64d4 100644 --- a/tests/accounts.scm +++ b/tests/accounts.scm @@ -21,6 +21,7 @@ #: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 @@ ada:100600:300\n") (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,94 @@ ada:100600:300\n") (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))))) + +(test-assert "allocate-subids, impossible allocations - ranges must have start" + (guard (c ((specific-subid-range-expected-error? c) + #t)) + (allocate-subids (list (subid-range (name "m"))) (list (subid-range (name "x")))) + #f)) + +(test-assert "allocate-subids, impossible allocations - ranges must fall within allowed max min subids" + (guard (c ((invalid-subid-range-error? c) + #t)) + (allocate-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)))) + #f)) + +(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 "m") (start (+ %subordinate-id-min 201)) (count 27)) + (subid-entry (name "root") (start (+ %subordinate-id-min 231)) (count 100)) + (subid-entry (name "i") (start (+ %subordinate-id-min 331)) (count 2)) + (subid-entry (name "l") (start (+ %subordinate-id-min 333)) (count 1))) + (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))))) + +(test-assert "allocate-subids with interleaving, impossible interleaving - before" + (guard (c ((subordinate-id-overflow-error? c) + #t)) + (allocate-subids + (list (subid-range (name "m") (start %subordinate-id-min) (count 16))) + (list + (subid-range (name "x") (start (+ 15 %subordinate-id-min)) (count 150)))) + #f)) + +(test-assert "allocate-subids with interleaving, impossible interleaving - after" + (guard (c ((subordinate-id-overflow-error? c) + #t)) + (allocate-subids + (list (subid-range (name "m") (start %subordinate-id-min) (count 30))) + (list + (subid-range (name "x") (start (+ 29 %subordinate-id-min)) (count 150)))) + #f)) + +(test-assert "allocate-subids with interleaving, impossible interleaving - between" + (guard (c ((subordinate-id-overflow-error? c) + #t)) + (allocate-subids + (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)))) + #f)) + (test-equal "allocate-passwd" ;; Allocate UIDs in a stateless fashion. (list (password-entry (name "alice") (uid %id-min) (gid 1000) @@ -376,4 +466,48 @@ ada:100600:300\n") (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))) + #:current-subuids '())) + list)) + (test-end "accounts") |