From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp1.migadu.com ([2001:41d0:403:4876::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms13.migadu.com with LMTPS id sOpeFctjBGdfFwEA62LTzQ:P1 (envelope-from ) for ; Mon, 07 Oct 2024 22:42:19 +0000 Received: from aspmx1.migadu.com ([2001:41d0:403:4876::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp1.migadu.com with LMTPS id sOpeFctjBGdfFwEA62LTzQ (envelope-from ) for ; Tue, 08 Oct 2024 00:42:19 +0200 X-Envelope-To: larch@yhetil.org Authentication-Results: aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=debbugs.gnu.org header.s=debbugs-gnu-org header.b=PpHFasNt; dkim=fail ("body hash did not verify") header.d=autistici.org header.s=stigmate header.b=GQhn4lCw; dmarc=pass (policy=none) header.from=gnu.org; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org" ARC-Seal: i=1; s=key1; d=yhetil.org; t=1728340939; a=rsa-sha256; cv=none; b=Srbqn5oTTDBwbBEukY3nFYYADz1KDyUcTt7MylCQOTF6AZ5ESzvZfSRIV87Xcm1/hC+7hb HFu3b2+d/PzTmktsfCeNf9QCga4aorPfawJahQaWNS7+A3GiAo6oo+rut7L3cGTjlHd57E lesvos2CDuhjgYcFGsGEFyWZI5g3a8gUktMdh3AmECvPlEMki84G4lfSYexMZsv7Sfjmcb G7G9vmRZMoqkFVMjjIdt+0nxPFEUai73A8ect6Jop4Jg31Cp1OJPUddr25osUse7SJ1AU0 ewFZfa3CyfJtFig8r7lQYSJ/pc0OGpBDDebPTjYzc217C5oe6cx4F7232aTYLw== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=debbugs.gnu.org header.s=debbugs-gnu-org header.b=PpHFasNt; dkim=fail ("body hash did not verify") header.d=autistici.org header.s=stigmate header.b=GQhn4lCw; dmarc=pass (policy=none) header.from=gnu.org; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org" ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1728340939; h=from:from:sender:sender:reply-to:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:cc:mime-version:mime-version: content-type:content-type: content-transfer-encoding:content-transfer-encoding:resent-cc: resent-from:resent-sender:resent-message-id:in-reply-to:in-reply-to: references:references:list-id:list-help:list-unsubscribe: list-subscribe:list-post:dkim-signature; bh=sU1ut0+SZP2ev5MOYrqgBqE2g4kBFkjZQxY+C9kY3wo=; b=XjCXzIZtRDsmH1Cmx7K3rpyWNHH6pghDGdenV5Wgt+/fcVKyvZ2Jl7EaZmdZ/JSr6uYb25 RJs+Q3O5J9bL6U2JIo5wqynT5tjnIoFwm8fk0scxZmh63j8h0MqHSFZdC1XZlA1kMIAiag yd8bmDcKuxOAFphCSvI5nft7DtUWeHl+zoXYSSVLHhkbl7xe3jRid+0OMWel+bwfyN2cGK drHOheooogQ+RDLJyc46Y8u2rwgmNX3OkyBm4ldQY+HPUy/BzbUHgrRFULxj2uh2P6b10J 59w+GsX3M/h7UTUKqfNvh7gxYdxwNp6t/oTEsw4ApgG2YQdgztnxGiGujQLD6Q== Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id C2F6072383 for ; Tue, 08 Oct 2024 00:42:18 +0200 (CEST) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1sxwQP-0005DJ-0F; Mon, 07 Oct 2024 18:41:57 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1sxwQM-0005Cd-UB for guix-patches@gnu.org; Mon, 07 Oct 2024 18:41:54 -0400 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1sxwQM-0002Mm-K2 for guix-patches@gnu.org; Mon, 07 Oct 2024 18:41:54 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:References:In-Reply-To:Date:From:To:Subject; bh=0LM/X9oUHI3PC8uhGvWBHGBGVue+8vJdzE6cw0LYRyM=; b=PpHFasNtVrId80elawntRem/vrVHtM84MtHnr4NGXl1//TtSipM/sa4ne68rzcNh7HFl3SzhlkvInUmojxpdbK9cQwb93ST1vPlFlJrMOYWnLGBvdYbNbci7zPJK+ARZfgGCqDF8+McY8HVfmKXXKsHYNr6SnpBY0j3TNLmRCDwUX30+Gfr25XCnbmX7wOz3YPebrip1ePdgINrMH3EsCcDjhsx1Yv0aSe8ODsxi4WoY8yFdE2cMp/RFSrbgkP71hk5ijD8JDG0xNDJqWZdz3ml7fANcYMDmiqF/CyNHj+/erm9x8ZUFnYpGSWmFdCbl50ZBNKLWVCj8Y1ZoQC4j4g==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1sxwQT-0001Qf-VM for guix-patches@gnu.org; Mon, 07 Oct 2024 18:42:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#72337] [PATCH v5 2/3] account: Add /etc/subid and /etc/subgid allocation logic. Resent-From: Giacomo Leidi Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Mon, 07 Oct 2024 22:42:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 72337 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: To: 72337@debbugs.gnu.org Cc: Giacomo Leidi , Ludovic =?UTF-8?Q?Court=C3=A8s?= Received: via spool by 72337-submit@debbugs.gnu.org id=B72337.17283408725407 (code B ref 72337); Mon, 07 Oct 2024 22:42:01 +0000 Received: (at 72337) by debbugs.gnu.org; 7 Oct 2024 22:41:12 +0000 Received: from localhost ([127.0.0.1]:49274 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1sxwPf-0001P8-G8 for submit@debbugs.gnu.org; Mon, 07 Oct 2024 18:41:12 -0400 Received: from confino.investici.org ([93.190.126.19]:60741) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1sxwPc-0001Ot-SQ for 72337@debbugs.gnu.org; Mon, 07 Oct 2024 18:41:10 -0400 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=autistici.org; s=stigmate; t=1728340860; bh=0LM/X9oUHI3PC8uhGvWBHGBGVue+8vJdzE6cw0LYRyM=; h=From:To:Cc:Subject:Date:In-Reply-To:References:From; b=GQhn4lCwDQ/wV9Tz/SyiICR48GyrqgJwl4Ljfn6EAdTJZBQA/2UoRJlOHEaF7M8Uc tjIuxf2K8DKCFDi8tULMy2jD5jBxchvmUmbiy4IeCxG9pj82ZNtEO2DkG1ePvVSMX4 eS9SOv1XRDGrtF+1nhalH/pSZd7Yd20x1GwFtTU0= Received: from mx1.investici.org (unknown [127.0.0.1]) by confino.investici.org (Postfix) with ESMTP id 4XMvJD3g70z11XH; Mon, 7 Oct 2024 22:41:00 +0000 (UTC) Received: from [93.190.126.19] (mx1.investici.org [93.190.126.19]) (Authenticated sender: goodoldpaul@autistici.org) by localhost (Postfix) with ESMTPSA id 4XMvJD2fLcz11XF; Mon, 7 Oct 2024 22:41:00 +0000 (UTC) Date: Tue, 8 Oct 2024 00:40:27 +0200 Message-ID: X-Mailer: git-send-email 2.46.0 In-Reply-To: References: MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Reply-to: Giacomo Leidi X-ACL-Warn: , Giacomo Leidi via Guix-patches From: Giacomo Leidi via Guix-patches via Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: guix-patches-bounces+larch=yhetil.org@gnu.org X-Migadu-Country: US X-Migadu-Flow: FLOW_IN X-Migadu-Spam-Score: -3.70 X-Spam-Score: -3.70 X-Migadu-Queue-Id: C2F6072383 X-Migadu-Scanner: mx10.migadu.com X-TUID: upR/AFxnkQF4 This commit adds allocation logic for subid ranges. Subid ranges are ranges of contiguous subids that are mapped to a user in the host system. This patch implements a flexible allocation algorithm allowing users that do not want (or need) to specify details of the subid ranges that they are requesting to avoid doing so, while upholding requests of users that need to have specific ranges. * gnu/build/accounts.scm (%subordinate-id-min): New variable; (%subordinate-id-max): new variable; (%subordinate-id-count): new variable; (subordinate-id?): new variable; (&subordinate-id-error): new variable; (&subordinate-id-overflow-error): new variable; (&illegal-subid-range-error): new variable; (&specific-subid-range-expected-error): new variable; (&generic-subid-range-expected-error): new variable; (within-interval?): new variable; (allocate-unused-range): new variable; (allocate-generic-range): new variable; (allocate-specific-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 Co-Authored-By: Ludovic Courtès Signed-off-by: Giacomo Leidi --- gnu/build/accounts.scm | 319 +++++++++++++++++++++++++++++++++++++++- gnu/system/accounts.scm | 30 ++++ 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..be0db27215 100644 --- a/gnu/build/accounts.scm +++ b/gnu/build/accounts.scm @@ -25,8 +25,11 @@ (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 receive) #:use-module (ice-9 rdelim) #:export (password-entry password-entry? @@ -74,8 +77,27 @@ (define-module (gnu build accounts) %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 + &illegal-subid-range-error + illegal-subid-range-error? + illegal-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 @@ (define-record-type* (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 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 @@ (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-overflow-error &subordinate-id-error + subordinate-id-overflow-error? + (range subordinate-id-overflow-error)) +(define-condition-type &illegal-subid-range-error &subordinate-id-error + illegal-subid-range-error? + (range illegal-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 @@ (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 record based on ASSIGNMENT. If SYSTEM? is true, return a system ID." @@ -405,6 +464,194 @@ (define* (reserve-ids allocation ids #:key (skip? #t)) (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 + (&illegal-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 @@ (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 . 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 @@ (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* ; 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..616632edca 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,94 @@ (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))))) + +(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 ((illegal-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 @@ (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))) + #:current-subuids '())) + list)) + (test-end "accounts") -- 2.46.0