[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#49981] wip: Introduce unit-tests.
|
From: |
Mathieu Othacehe |
|
Subject: |
[bug#49981] wip: Introduce unit-tests. |
|
Date: |
Tue, 10 Aug 2021 17:04:20 +0200 |
|
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/27.2 (gnu/linux) |
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 <unit-test> 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 <othacehe@gnu.org>
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 <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(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 <http://www.gnu.org/licenses/>.
-(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> 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) ;<location>
+ (default (and=> (current-source-location)
+ source-properties->location))))
+
+(define (write-unit-test test port)
+ (match test
+ (($ <unit-test> name _ _ ($ <location> file line))
+ (format port "#<unit-test ~a ~a:~a ~a>"
+ name file line
+ (number->string (object-address test) 16)))
+ (($ <unit-test> name)
+ (format port "#<unit-test ~a ~a>" name
+ (number->string (object-address test) 16)))))
+
+(set-record-type-printer! <unit-test> write-unit-test)
+
+(define-gexp-compiler (compile-unit-test (test <unit-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
- [bug#49981] wip: Introduce unit-tests.,
Mathieu Othacehe <=