Add (gnu build accounts).

* gnu/build/accounts.scm, tests/accounts.scm: New files.
* Makefile.am (SCM_TESTS): Add tests/accounts.scm.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add build/accounts.scm.

1 files changed, 309 insertions, 0 deletions

diff --git a/tests/accounts.scm b/tests/accounts.scm
new file mode 100644
index 0000000000..127861042d
--- /dev/null
+++ b/tests/accounts.scm
@@ -0,0 +1,309 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 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/>.
+
+(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 %passwd-sample
+  "\
+root:x:0:0:Admin:/root:/bin/sh
+charlie:x:1000:998:Charlie:/home/charlie:/bin/sh\n")
+
+(define %group-sample
+  "\
+root:x:0:
+wheel:x:999:alice,bob
+hackers:x:65000:alice,charlie\n")
+
+(define %shadow-sample
+  (string-append "\
+root:" (crypt "secret" "$6$abc") ":17169::::::
+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))))
+
+(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-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-group + write-group"
+  %group-sample
+  (call-with-output-string
+    (lambda (port)
+      (write-group (call-with-input-string %group-sample
+                     read-group)
+                   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 "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 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, 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")
+                                       (home-directory "/home/alice")
+                                       (shell "/bin/sh")
+                                       (group "users"))
+                         (user-account (name "bob")
+                                       (comment "Bob")
+                                       (home-directory "/home/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 "/gnu/.../bin/gash")
+                        (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")
+                                       (home-directory "/home/alice")
+                                       (shell "/bin/sh") ;ignored
+                                       (group "users"))
+                         (user-account (name "charlie")
+                                       (comment "Charlie")
+                                       (home-directory "/home/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")
+                                         (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")