@@ -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:
+
+;;;
+;;; General utilities.
+;;;
+
+(define (list-set lst el k)
+ (if (>= k (length lst))
+ `(,@lst ,el)
+ `(,@(list-head lst k)
+ ,el
+ ,@(list-tail lst k))))
+
;;;
;;; 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,156 @@ (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 " range-start " to " range-end
+ " spans over illegal subids. Max allowed is "
+ %sub-id-max ", min is " %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 +716,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 +816,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))
@@ -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)))
@@ -193,6 +193,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 +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")