From patchwork Tue Aug 10 15:04:20 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Mathieu Othacehe X-Patchwork-Id: 31980 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 9776127BC82; Tue, 10 Aug 2021 16:05:14 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H2,SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id CF61F27BC78 for ; Tue, 10 Aug 2021 16:05:12 +0100 (BST) Received: from localhost ([::1]:33188 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1mDTJX-0002re-Rc for patchwork@mira.cbaines.net; Tue, 10 Aug 2021 11:05:11 -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 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+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches 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 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 = .scm .sh if CAN_RUN_TESTS SCM_TESTS = \ + 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 © 2016, 2018, 2019, 2020 Ludovic Courtès +;;; +;;; 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 channel +instance." + ;; Honor the 'TESTS' environment variable so that one can select a subset + ;; of tests to run in the usual way: + ;; + ;; make check TESTS=accounts + (parameterize ((current-guix-package + (channel-source->package source #:commit commit))) + (match (getenv "TESTS") + (#f + (all-unit-tests)) + ((= 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 . -(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)) (define %passwd-sample "\ @@ -42,283 +40,288 @@ charlie:" (crypt "hey!" "$6$abc") ":17169:::::: nobody:!:0::::::\n")) -(test-begin "accounts") -(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)) -(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) -(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") -(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)))) -(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)))) -(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)))) -(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)))) - -(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"))))) -(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)) -(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 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" - ;; 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-used 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)))))) -(test-equal "allocate-groups with previous state, looping" - ;; Check that allocation starts after the highest previously-used 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)))))) + (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" - ;; 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 previously-used + ;; 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 9999) + (real-name "Alice Smith") + (shell "/gnu/.../bin/gash") ;ignored + (directory "/home/alice")) + (password-entry (name "bob") (uid 1235) (gid 1001) + (real-name "Bob") (shell "/bin/sh") + (directory "/home/bob"))))) -(test-equal "allocate-passwd with previous state" - ;; Make sure bits of state are preserved: UID, no reuse of previously-used - ;; 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 9999) - (real-name "Alice Smith") - (shell "/gnu/.../bin/gash") ;ignored - (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 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)) + (test-end "accounts") + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) -(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)) -(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=> (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 '()))) -- 2.32.0