From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp1 ([2001:41d0:8:6d80::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms0.migadu.com with LMTPS id KMawLqqVEmEnnwAAgWs5BA (envelope-from ) for ; Tue, 10 Aug 2021 17:05:14 +0200 Received: from aspmx1.migadu.com ([2001:41d0:8:6d80::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp1 with LMTPS id gIMxKqqVEmFUSQAAbx9fmQ (envelope-from ) for ; Tue, 10 Aug 2021 15:05:14 +0000 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 D21E22C90F for ; Tue, 10 Aug 2021 17:05:13 +0200 (CEST) Received: from localhost ([::1]:33188 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1mDTJY-0002re-Jl for larch@yhetil.org; Tue, 10 Aug 2021 11:05:12 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:37056) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1mDTJO-0002rB-U9 for guix-patches@gnu.org; Tue, 10 Aug 2021 11:05:02 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:48764) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1mDTJO-000893-NJ for guix-patches@gnu.org; Tue, 10 Aug 2021 11:05:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1mDTJO-0007Pt-It for guix-patches@gnu.org; Tue, 10 Aug 2021 11:05:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#49981] wip: Introduce unit-tests. Resent-From: Mathieu Othacehe Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 10 Aug 2021 15:05:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 49981 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: To: 49981@debbugs.gnu.org X-Debbugs-Original-To: guix-patches@gnu.org Received: via spool by submit@debbugs.gnu.org id=B.162860786728454 (code B ref -1); Tue, 10 Aug 2021 15:05:02 +0000 Received: (at submit) by debbugs.gnu.org; 10 Aug 2021 15:04:27 +0000 Received: from localhost ([127.0.0.1]:60310 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mDTIn-0007Oo-Nw for submit@debbugs.gnu.org; Tue, 10 Aug 2021 11:04:27 -0400 Received: from lists.gnu.org ([209.51.188.17]:46936) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mDTIk-0007Of-EB for submit@debbugs.gnu.org; Tue, 10 Aug 2021 11:04:24 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:36826) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1mDTIk-0001Uu-87 for guix-patches@gnu.org; Tue, 10 Aug 2021 11:04:22 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:52506) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1mDTIk-0007cC-1V for guix-patches@gnu.org; Tue, 10 Aug 2021 11:04:22 -0400 Received: from [2a01:e0a:19b:d9a0:f2f7:a404:c3d3:f8b4] (port=44394 helo=meije) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1mDTIj-0008BD-KW for guix-patches@gnu.org; Tue, 10 Aug 2021 11:04:21 -0400 From: Mathieu Othacehe Date: Tue, 10 Aug 2021 17:04:20 +0200 Message-ID: <87o8a5734b.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.2 (gnu/linux) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" 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: , Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: "Guix-patches" X-Migadu-Flow: FLOW_IN ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1628607914; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:mime-version:mime-version: content-type:content-type:resent-cc:resent-from:resent-sender: resent-message-id:list-id:list-help:list-unsubscribe:list-subscribe: list-post; bh=JzsW783ajFXTgOQGjUpfo9L5qiZ49bbEN+pI7bWwzZ4=; b=s/tRyv97iI4Xjbdv52AQgzyFoRcvcJu7Yvnl5zAALyKGwq5/HZtVEqXWJM00PMas52YKfN Hm+vM60TN8kQV/sAZVrhfQ0DTVZmYPu3fW8phTS8g1fyBwJz9i5B67acYdqmJWR3NmXujL geWuWNZ7MIM6sSyRadT8lGtgiqaekdCpkqrrog8zpoeOS0+Jagf7LfzoLVrQdAmIMkfxB7 1a2HOVEUOA0NJ1jm5WzYx6n210I5M86s7rSAsuTexEUC2W+yJlzqr1gosYsOLRLsFhSfOb MxgmLgFAMreNECvScB8WhtSyJartR1A6ZXWWNmWUcAIuXUVBzaDUKXvNYCirmw== ARC-Seal: i=1; s=key1; d=yhetil.org; t=1628607914; a=rsa-sha256; cv=none; b=YjkS9JTYD7sR15DhjZ7HeZPXA9PpFu6LUT3gslgkh86GZzCvy5RJm4axQqtExryH0VWZt6 FgSZU8m6/jAOcO7LFfg0FGg78jOMfq5ZQjCyvCmV7JM9fLY8JtTtyTROxfiOg63PwZ+3tY fVsnt0JA2K0OEe0yMOwoWhAVlGDKW99L4yCZZAUJMeSjVCxoRV9nInUnv3lYrlt+/P2Xa4 Gat7zpYY2CQsb2HHIuWHFoN5UnTj7LhIKQ9y48dImIz9GmMvU+o/hkVHYbAwCyrheXDAz1 SdnMEgIzl5h6il5O8o6L0cLuRPgBpXafFfmoYzKJMFDqdRTBGg+rCs1Igkm3rQ== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=none; spf=pass (aspmx1.migadu.com: domain of guix-patches-bounces@gnu.org designates 209.51.188.17 as permitted sender) smtp.mailfrom=guix-patches-bounces@gnu.org X-Migadu-Spam-Score: -2.91 Authentication-Results: aspmx1.migadu.com; dkim=none; dmarc=pass (policy=none) header.from=gnu.org; spf=pass (aspmx1.migadu.com: domain of guix-patches-bounces@gnu.org designates 209.51.188.17 as permitted sender) smtp.mailfrom=guix-patches-bounces@gnu.org X-Migadu-Queue-Id: D21E22C90F X-Spam-Score: -2.91 X-Migadu-Scanner: scn1.migadu.com X-TUID: 5vi8qOwMdh1V --=-=-= Content-Type: text/plain Hello, I would like to convert the Guix tests in the "tests/" directory to derivations, in the exact same way as for the system tests in the "gnu/tests/" directory. For that, I propose to introduce a new record. This would allow us to select all the unit tests using the "all-unit-tests" procedure, and add them to the (gnu ci) module. This way, we could have a Cuirass specification for the unit tests, as we already have for the system tests, to spot regressions early on. Here's a patch that translates the "account.scm" test module to the new proposed mechanism. If there are no objections, I plan to convert all the remaining tests. Thanks, Mathieu --=-=-= Content-Type: text/x-patch; charset=utf-8 Content-Disposition: inline; filename=0001-wip-Introduce-unit-tests.patch Content-Transfer-Encoding: quoted-printable >From eecedc74d8a3fa1a4dc1b99879def3571c9667cf Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 10 Aug 2021 16:56:38 +0200 Subject: [PATCH] wip: Introduce unit-tests. --- Makefile.am | 1 + etc/unit-tests.scm | 98 ++++++++ tests/accounts.scm | 545 +++++++++++++++++++++++---------------------- unit-tests.scm | 69 ++++++ 4 files changed, 442 insertions(+), 271 deletions(-) create mode 100644 etc/unit-tests.scm create mode 100644 unit-tests.scm diff --git a/Makefile.am b/Makefile.am index 5542aa1c56..a5517f10d5 100644 --- a/Makefile.am +++ b/Makefile.am @@ -431,6 +431,7 @@ TEST_EXTENSIONS =3D .scm .sh if CAN_RUN_TESTS =20 SCM_TESTS =3D \ + unit-tests.scm \ tests/accounts.scm \ tests/base16.scm \ tests/base32.scm \ diff --git a/etc/unit-tests.scm b/etc/unit-tests.scm new file mode 100644 index 0000000000..3daf69df3d --- /dev/null +++ b/etc/unit-tests.scm @@ -0,0 +1,98 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright =C2=A9 2016, 2018, 2019, 2020 Ludovic Court=C3=A8s +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(use-modules (unit-tests) + (gnu packages package-management) + ((gnu ci) #:select (channel-source->package)) + ((guix git-download) #:select (git-predicate)) + ((guix utils) #:select (current-source-directory)) + (git) + (ice-9 match)) + +(define (source-commit directory) + "Return the commit of the head of DIRECTORY or #f if it could not be +determined." + (let ((repository #f)) + (catch 'git-error + (lambda () + (set! repository (repository-open directory)) + (let* ((head (repository-head repository)) + (target (reference-target head)) + (commit (oid->string target))) + (repository-close! repository) + commit)) + (lambda _ + (when repository + (repository-close! repository)) + #f)))) + +(define (tests-for-current-guix source commit) + "Return a list of tests for perform, using Guix built from SOURCE, a cha= nnel +instance." + ;; Honor the 'TESTS' environment variable so that one can select a subset + ;; of tests to run in the usual way: + ;; + ;; make check TESTS=3Daccounts + (parameterize ((current-guix-package + (channel-source->package source #:commit commit))) + (match (getenv "TESTS") + (#f + (all-unit-tests)) + ((=3D string-tokenize (tests ...)) + (filter (lambda (test) + (member (unit-test-name test) tests)) + (all-unit-tests)))))) + +(define (unit-test->manifest-entry test) + "Return a manifest entry for TEST, a unit test." + (manifest-entry + (name (string-append "test." (unit-test-name test))) + (version "0") + (item test))) + +(define (unit-test-manifest) + "Return a manifest containing all the unit tests, or all those selected = by +the 'TESTS' environment variable." + (define source + (string-append (current-source-directory) "/..")) + + (define commit + ;; Fetch the current commit ID so we can potentially build the same + ;; derivation as ci.guix.gnu.org. + (source-commit source)) + + ;; Intern SOURCE so that 'build-from-source' in (guix channels) sees + ;; "fresh" file names and thus doesn't find itself loading .go files + ;; from ~/.cache/guile when it loads 'build-aux/build-self.scm'. + (let* ((source (local-file source + (if commit + (string-append "guix-" + (string-take commit 7)) + "guix-source") + #:recursive? #t + #:select? + (or (git-predicate source) + (const #t)))) + (tests (tests-for-current-guix source commit))) + (format (current-error-port) "Selected ~a unit tests...~%" + (length tests)) + + (manifest (map unit-test->manifest-entry tests)))) + +;; Return the manifest. +(unit-test-manifest) diff --git a/tests/accounts.scm b/tests/accounts.scm index 78136390bb..302fcff567 100644 --- a/tests/accounts.scm +++ b/tests/accounts.scm @@ -16,13 +16,11 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . =20 -(define-module (test-accounts) - #:use-module (gnu build accounts) - #:use-module (gnu system accounts) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-64) - #:use-module (ice-9 vlist) - #:use-module (ice-9 match)) +(define-module (tests accounts) + #:use-module (unit-tests) + #:use-module (guix gexp) + #:use-module (guix modules) + #:export (%test-accounts)) =20 (define %passwd-sample "\ @@ -42,283 +40,288 @@ charlie:" (crypt "hey!" "$6$abc") ":17169:::::: nobody:!:0::::::\n")) =20 -(test-begin "accounts") =20 -(test-equal "write-passwd" - %passwd-sample - (call-with-output-string - (lambda (port) - (write-passwd (list (password-entry - (name "root") - (uid 0) (gid 0) - (real-name "Admin") - (directory "/root") - (shell "/bin/sh")) - (password-entry - (name "charlie") - (uid 1000) (gid 998) - (real-name "Charlie") - (directory "/home/charlie") - (shell "/bin/sh"))) - port)))) +(define (run-accounts-test) + (define test + (with-imported-modules + (source-module-closure '((gnu build accounts) + (gnu system accounts))) + #~(begin + (use-modules (srfi srfi-19) + (srfi srfi-64) + (ice-9 vlist) + (ice-9 match) + (gnu build accounts) + (gnu system accounts)) =20 -(test-equal "write-passwd with duplicate entry" - %passwd-sample - (call-with-output-string - (lambda (port) - (let ((charlie (password-entry - (name "charlie") - (uid 1000) (gid 998) - (real-name "Charlie") - (directory "/home/charlie") - (shell "/bin/sh")))) - (write-passwd (list (password-entry - (name "root") - (uid 0) (gid 0) - (real-name "Admin") - (directory "/root") - (shell "/bin/sh")) - charlie charlie) - port))))) + (mkdir #$output) + (chdir #$output) =20 -(test-equal "read-passwd + write-passwd" - %passwd-sample - (call-with-output-string - (lambda (port) - (write-passwd (call-with-input-string %passwd-sample - read-passwd) - port)))) + (test-begin "accounts") =20 -(test-equal "write-group" - %group-sample - (call-with-output-string - (lambda (port) - (write-group (list (group-entry - (name "root") (gid 0)) - (group-entry - (name "wheel") (gid 999) - (members '("alice" "bob"))) - (group-entry - (name "hackers") (gid 65000) - (members '("alice" "charlie")))) - port)))) + (test-equal "write-passwd" + #$%passwd-sample + (call-with-output-string + (lambda (port) + (write-passwd (list (password-entry + (name "root") + (uid 0) (gid 0) + (real-name "Admin") + (directory "/root") + (shell "/bin/sh")) + (password-entry + (name "charlie") + (uid 1000) (gid 998) + (real-name "Charlie") + (directory "/home/charlie") + (shell "/bin/sh"))) + port)))) =20 -(test-equal "read-group + write-group" - %group-sample - (call-with-output-string - (lambda (port) - (write-group (call-with-input-string %group-sample - read-group) - port)))) + (test-equal "read-passwd + write-passwd" + #$%passwd-sample + (call-with-output-string + (lambda (port) + (write-passwd (call-with-input-string #$%passwd-sample + read-passwd) + port)))) =20 -(test-equal "write-shadow" - %shadow-sample - (call-with-output-string - (lambda (port) - (write-shadow (list (shadow-entry - (name "root") - (password (crypt "secret" "$6$abc")) - (last-change 17169)) - (shadow-entry - (name "charlie") - (password (crypt "hey!" "$6$abc")) - (last-change 17169)) - (shadow-entry - (name "nobody"))) - port)))) + (test-equal "write-group" + #$%group-sample + (call-with-output-string + (lambda (port) + (write-group (list (group-entry + (name "root") (gid 0)) + (group-entry + (name "wheel") (gid 999) + (members '("alice" "bob"))) + (group-entry + (name "hackers") (gid 65000) + (members '("alice" "charlie")))) + port)))) =20 -(test-equal "read-shadow + write-shadow" - %shadow-sample - (call-with-output-string - (lambda (port) - (write-shadow (call-with-input-string %shadow-sample - read-shadow) - port)))) + (test-equal "read-group + write-group" + #$%group-sample + (call-with-output-string + (lambda (port) + (write-group (call-with-input-string #$%group-sample + read-group) + port)))) =20 - -(define allocate-groups (@@ (gnu build accounts) allocate-groups)) -(define allocate-passwd (@@ (gnu build accounts) allocate-passwd)) + (test-equal "write-shadow" + #$%shadow-sample + (call-with-output-string + (lambda (port) + (write-shadow (list (shadow-entry + (name "root") + (password (crypt "secret" "$6$abc")) + (last-change 17169)) + (shadow-entry + (name "charlie") + (password (crypt "hey!" "$6$abc")) + (last-change 17169)) + (shadow-entry + (name "nobody"))) + port)))) + + (test-equal "read-shadow + write-shadow" + #$%shadow-sample + (call-with-output-string + (lambda (port) + (write-shadow (call-with-input-string #$%shadow-sample + read-shadow) + port)))) + + (define allocate-groups (@@ (gnu build accounts) allocate-groups= )) + (define allocate-passwd (@@ (gnu build accounts) allocate-passwd= )) + + (test-equal "allocate-groups" + ;; Allocate GIDs in a stateless fashion. + (list (group-entry (name "s") (gid %system-id-max)) + (group-entry (name "x") (gid 900)) + (group-entry (name "t") (gid 899)) + (group-entry (name "a") (gid %id-min) (password "foo") + (members '("alice" "bob"))) + (group-entry (name "b") (gid (+ %id-min 1)) + (members '("charlie")))) + (allocate-groups (list (user-group (name "s") (system? #t)) + (user-group (name "x") (id 900)) + (user-group (name "t") (system? #t)) + (user-group (name "a") (password "foo")) + (user-group (name "b"))) + (alist->vhash `(("a" . "bob") + ("a" . "alice") + ("b" . "charlie"))))) =20 -(test-equal "allocate-groups" - ;; Allocate GIDs in a stateless fashion. - (list (group-entry (name "s") (gid %system-id-max)) - (group-entry (name "x") (gid 900)) - (group-entry (name "t") (gid 899)) - (group-entry (name "a") (gid %id-min) (password "foo") - (members '("alice" "bob"))) - (group-entry (name "b") (gid (+ %id-min 1)) - (members '("charlie")))) - (allocate-groups (list (user-group (name "s") (system? #t)) - (user-group (name "x") (id 900)) - (user-group (name "t") (system? #t)) - (user-group (name "a") (password "foo")) - (user-group (name "b"))) - (alist->vhash `(("a" . "bob") - ("a" . "alice") - ("b" . "charlie"))))) + (test-equal "allocate-groups with requested GIDs" + ;; Make sure the requested GID for "b" is honored. + (list (group-entry (name "a") (gid (+ 1 %id-min))) + (group-entry (name "b") (gid %id-min)) + (group-entry (name "c") (gid (+ 2 %id-min)))) + (allocate-groups (list (user-group (name "a")) + (user-group (name "b") (id %id-min)) + (user-group (name "c"))) + vlist-null)) =20 -(test-equal "allocate-groups with requested GIDs" - ;; Make sure the requested GID for "b" is honored. - (list (group-entry (name "a") (gid (+ 1 %id-min))) - (group-entry (name "b") (gid %id-min)) - (group-entry (name "c") (gid (+ 2 %id-min)))) - (allocate-groups (list (user-group (name "a")) - (user-group (name "b") (id %id-min)) - (user-group (name "c"))) - vlist-null)) + (test-equal "allocate-groups with previous state" + ;; Make sure bits of state are preserved: password, GID, no re= use of + ;; previously-used GIDs. + (list (group-entry (name "s") (gid (- %system-id-max 1))) + (group-entry (name "t") (gid (- %system-id-max 2))) + (group-entry (name "a") (gid 30000) (password #f) + (members '("alice" "bob"))) + (group-entry (name "b") (gid 30001) (password "bar") + (members '("charlie")))) + (allocate-groups (list (user-group (name "s") (system? #t)) + (user-group (name "t") (system? #t)) + (user-group (name "a") (password "foo")) + (user-group (name "b"))) + (alist->vhash `(("a" . "bob") + ("a" . "alice") + ("b" . "charlie"))) + (list (group-entry (name "a") (gid 30000)) + (group-entry (name "b") (gid 30001) + (password "bar")) + (group-entry (name "removed") + (gid %system-id-max))))) =20 -(test-equal "allocate-groups with previous state" - ;; Make sure bits of state are preserved: password, GID, no reuse of - ;; previously-used GIDs. - (list (group-entry (name "s") (gid (- %system-id-max 1))) - (group-entry (name "t") (gid (- %system-id-max 2))) - (group-entry (name "a") (gid 30000) (password #f) - (members '("alice" "bob"))) - (group-entry (name "b") (gid 30001) (password "bar") - (members '("charlie")))) - (allocate-groups (list (user-group (name "s") (system? #t)) - (user-group (name "t") (system? #t)) - (user-group (name "a") (password "foo")) - (user-group (name "b"))) - (alist->vhash `(("a" . "bob") - ("a" . "alice") - ("b" . "charlie"))) - (list (group-entry (name "a") (gid 30000)) - (group-entry (name "b") (gid 30001) - (password "bar")) - (group-entry (name "removed") - (gid %system-id-max))))) + (test-equal "allocate-groups with previous state, looping" + ;; Check that allocation starts after the highest previously-u= sed GID, and + ;; loops back to the lowest GID. + (list (group-entry (name "a") (gid (- %id-max 1))) + (group-entry (name "b") (gid %id-min)) + (group-entry (name "c") (gid (+ 1 %id-min)))) + (allocate-groups (list (user-group (name "a")) + (user-group (name "b")) + (user-group (name "c"))) + vlist-null + (list (group-entry (name "d") + (gid (- %id-max 2)))))) =20 -(test-equal "allocate-groups with previous state, looping" - ;; Check that allocation starts after the highest previously-used GID, a= nd - ;; loops back to the lowest GID. - (list (group-entry (name "a") (gid (- %id-max 1))) - (group-entry (name "b") (gid %id-min)) - (group-entry (name "c") (gid (+ 1 %id-min)))) - (allocate-groups (list (user-group (name "a")) - (user-group (name "b")) - (user-group (name "c"))) - vlist-null - (list (group-entry (name "d") - (gid (- %id-max 2)))))) + (test-equal "allocate-passwd" + ;; Allocate UIDs in a stateless fashion. + (list (password-entry (name "alice") (uid %id-min) (gid 1000) + (real-name "Alice") (shell "/bin/sh") + (directory "/home/alice")) + (password-entry (name "bob") (uid (+ 1 %id-min)) (gid 10= 01) + (real-name "Bob") (shell "/bin/gash") + (directory "/home/bob")) + (password-entry (name "sshd") (uid %system-id-max) (gid = 500) + (real-name "sshd") (shell "/nologin") + (directory "/var/empty")) + (password-entry (name "guix") (uid 30000) (gid 499) + (real-name "Guix") (shell "/nologin") + (directory "/var/empty"))) + (allocate-passwd (list (user-account (name "alice") + (comment "Alice") + (shell "/bin/sh") + (group "users")) + (user-account (name "bob") + (comment "Bob") + (shell "/bin/gash") + (group "wheel")) + (user-account (name "sshd") (system? #t) + (comment "sshd") + (home-directory "/var/emp= ty") + (shell "/nologin") + (group "sshd")) + (user-account (name "guix") (system? #t) + (comment "Guix") + (home-directory "/var/emp= ty") + (shell "/nologin") + (group "guix") + (uid 30000))) + (list (group-entry (name "users") (gid 1000)) + (group-entry (name "wheel") (gid 1001)) + (group-entry (name "sshd") (gid 500)) + (group-entry (name "guix") (gid 499))))) =20 -(test-equal "allocate-passwd" - ;; Allocate UIDs in a stateless fashion. - (list (password-entry (name "alice") (uid %id-min) (gid 1000) - (real-name "Alice") (shell "/bin/sh") - (directory "/home/alice")) - (password-entry (name "bob") (uid (+ 1 %id-min)) (gid 1001) - (real-name "Bob") (shell "/bin/gash") - (directory "/home/bob")) - (password-entry (name "sshd") (uid %system-id-max) (gid 500) - (real-name "sshd") (shell "/nologin") - (directory "/var/empty")) - (password-entry (name "guix") (uid 30000) (gid 499) - (real-name "Guix") (shell "/nologin") - (directory "/var/empty"))) - (allocate-passwd (list (user-account (name "alice") - (comment "Alice") - (shell "/bin/sh") - (group "users")) - (user-account (name "bob") - (comment "Bob") - (shell "/bin/gash") - (group "wheel")) - (user-account (name "sshd") (system? #t) - (comment "sshd") - (home-directory "/var/empty") - (shell "/nologin") - (group "sshd")) - (user-account (name "guix") (system? #t) - (comment "Guix") - (home-directory "/var/empty") - (shell "/nologin") - (group "guix") - (uid 30000))) - (list (group-entry (name "users") (gid 1000)) - (group-entry (name "wheel") (gid 1001)) - (group-entry (name "sshd") (gid 500)) - (group-entry (name "guix") (gid 499))))) + (test-equal "allocate-passwd with previous state" + ;; Make sure bits of state are preserved: UID, no reuse of pre= viously-used + ;; UIDs, and shell. + (list (password-entry (name "alice") (uid 1234) (gid 1000) + (real-name "Alice Smith") (shell "/bin/s= h") + (directory "/home/alice")) + (password-entry (name "charlie") (uid 1236) (gid 1000) + (real-name "Charlie") (shell "/bin/sh") + (directory "/home/charlie"))) + (allocate-passwd (list (user-account (name "alice") + (comment "Alice") + (shell "/bin/sh") ;honored + (group "users")) + (user-account (name "charlie") + (comment "Charlie") + (shell "/bin/sh") + (group "users"))) + (list (group-entry (name "users") (gid 1000))) + (list (password-entry (name "alice") (uid 123= 4) (gid 9999) + (real-name "Alice Smith= ") + (shell "/gnu/.../bin/ga= sh") ;ignored + (directory "/home/alice= ")) + (password-entry (name "bob") (uid 1235)= (gid 1001) + (real-name "Bob") (shel= l "/bin/sh") + (directory "/home/bob")= )))) =20 -(test-equal "allocate-passwd with previous state" - ;; Make sure bits of state are preserved: UID, no reuse of previously-us= ed - ;; UIDs, and shell. - (list (password-entry (name "alice") (uid 1234) (gid 1000) - (real-name "Alice Smith") (shell "/bin/sh") - (directory "/home/alice")) - (password-entry (name "charlie") (uid 1236) (gid 1000) - (real-name "Charlie") (shell "/bin/sh") - (directory "/home/charlie"))) - (allocate-passwd (list (user-account (name "alice") - (comment "Alice") - (shell "/bin/sh") ;honored - (group "users")) - (user-account (name "charlie") - (comment "Charlie") - (shell "/bin/sh") - (group "users"))) - (list (group-entry (name "users") (gid 1000))) - (list (password-entry (name "alice") (uid 1234) (gid 99= 99) - (real-name "Alice Smith") - (shell "/gnu/.../bin/gash") ;igno= red - (directory "/home/alice")) - (password-entry (name "bob") (uid 1235) (gid 1001) - (real-name "Bob") (shell "/bin/sh= ") - (directory "/home/bob"))))) + (test-equal "user+group-databases" + ;; The whole shebang. + (list (list (group-entry (name "a") (gid %id-min) + (members '("bob"))) + (group-entry (name "b") (gid (+ 1 %id-min)) + (members '("alice"))) + (group-entry (name "s") (gid %system-id-max))) + (list (password-entry (name "alice") (real-name "Alice") + (uid %id-min) (gid %id-min) + (directory "/a")) + (password-entry (name "bob") (real-name "Bob") + (uid (+ 1 %id-min)) (gid (+ 1 %id-= min)) + (directory "/b")) + (password-entry (name "nobody") + (uid 65534) (gid %system-id-max) + (directory "/var/empty"))) + (list (shadow-entry (name "alice") (last-change 100) + (password (crypt "initial pass" "$6$= "))) + (shadow-entry (name "bob") (last-change 50) + (password (crypt "foo" "$6$"))) + (shadow-entry (name "nobody") (last-change 100)))) + (call-with-values + (lambda () + (user+group-databases (list (user-account + (name "alice") + (comment "Alice") + (home-directory "/a") + (group "a") + (supplementary-groups '("b"= )) + (password (crypt "initial p= ass" "$6$"))) + (user-account + (name "bob") + (comment "Bob") + (home-directory "/b") + (group "b") + (supplementary-groups '("a"= ))) + (user-account + (name "nobody") + (group "s") + (uid 65534) + (home-directory "/var/empty= "))) + (list (user-group (name "a")) + (user-group (name "b")) + (user-group (name "s") (syst= em? #t))) + #:current-passwd '() + #:current-shadow + (list (shadow-entry (name "bob") + (password (cry= pt "foo" "$6$")) + (last-change 5= 0))) + #:current-groups '() + #:current-time + (lambda (type) + (make-time type 0 (* 24 3600 100= ))))) + list)) + (test-end "accounts") + (exit (=3D (test-runner-fail-count (test-runner-current)) 0))))) =20 -(test-equal "user+group-databases" - ;; The whole shebang. - (list (list (group-entry (name "a") (gid %id-min) - (members '("bob"))) - (group-entry (name "b") (gid (+ 1 %id-min)) - (members '("alice"))) - (group-entry (name "s") (gid %system-id-max))) - (list (password-entry (name "alice") (real-name "Alice") - (uid %id-min) (gid %id-min) - (directory "/a")) - (password-entry (name "bob") (real-name "Bob") - (uid (+ 1 %id-min)) (gid (+ 1 %id-min)) - (directory "/b")) - (password-entry (name "nobody") - (uid 65534) (gid %system-id-max) - (directory "/var/empty"))) - (list (shadow-entry (name "alice") (last-change 100) - (password (crypt "initial pass" "$6$"))) - (shadow-entry (name "bob") (last-change 50) - (password (crypt "foo" "$6$"))) - (shadow-entry (name "nobody") (last-change 100)))) - (call-with-values - (lambda () - (user+group-databases (list (user-account - (name "alice") - (comment "Alice") - (home-directory "/a") - (group "a") - (supplementary-groups '("b")) - (password (crypt "initial pass" "$6$"= ))) - (user-account - (name "bob") - (comment "Bob") - (home-directory "/b") - (group "b") - (supplementary-groups '("a"))) - (user-account - (name "nobody") - (group "s") - (uid 65534) - (home-directory "/var/empty"))) - (list (user-group (name "a")) - (user-group (name "b")) - (user-group (name "s") (system? #t))) - #:current-passwd '() - #:current-shadow - (list (shadow-entry (name "bob") - (password (crypt "foo" "= $6$")) - (last-change 50))) - #:current-groups '() - #:current-time - (lambda (type) - (make-time type 0 (* 24 3600 100))))) - list)) + (gexp->derivation "accounts-test" test)) =20 -(test-end "accounts") +(define %test-accounts + (unit-test + (name "accounts") + (description "Run the accounts unit tests.") + (value (run-accounts-test)))) diff --git a/unit-tests.scm b/unit-tests.scm new file mode 100644 index 0000000000..2c4474b19d --- /dev/null +++ b/unit-tests.scm @@ -0,0 +1,69 @@ +(define-module (unit-tests) + #:use-module (guix gexp) + #:use-module (guix diagnostics) + #:use-module (guix records) + #:use-module ((guix ui) #:select (warn-about-load-error)) + #:use-module (guix discovery) + #:use-module (srfi srfi-9 gnu) + #:use-module (ice-9 match) + #:export (unit-test + unit-test? + unit-test-name + unit-test-value + unit-test-description + unit-test-location + + fold-unit-tests + all-unit-tests)) + + +;;; +;;; Unit tests. +;;; + +(define-record-type* unit-test make-unit-test + unit-test? + (name unit-test-name) ;string + (value unit-test-value) ;%STORE-MONAD value + (description unit-test-description) ;string + (location unit-test-location (innate) ; + (default (and=3D> (current-source-location) + source-properties->location)))) + +(define (write-unit-test test port) + (match test + (($ name _ _ ($ file line)) + (format port "#" + name file line + (number->string (object-address test) 16))) + (($ name) + (format port "#" name + (number->string (object-address test) 16))))) + +(set-record-type-printer! write-unit-test) + +(define-gexp-compiler (compile-unit-test (test ) + unit target) + "Compile TEST to a derivation." + ;; XXX: UNIT and TARGET are ignored. + (unit-test-value test)) + +(define (test-modules) + "Return the list of modules that define unit tests." + (scheme-modules (dirname (search-path %load-path "guix.scm")) + "tests" + #:warn warn-about-load-error)) + +(define (fold-unit-tests proc seed) + "Invoke PROC on each unit test, passing it the test and the previous +result." + (fold-module-public-variables (lambda (obj result) + (if (unit-test? obj) + (cons obj result) + result)) + '() + (test-modules))) + +(define (all-unit-tests) + "Return the list of unit tests." + (reverse (fold-unit-tests cons '()))) --=20 2.32.0 --=-=-=--