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

