[jackhill/guix/guix.git] / tests / accounts.scm

;;; 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"))

\f
(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))))

\f
(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")
                                       (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 "/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")
                                       (shell "/bin/sh") ;ignored
                                       (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")
                                         (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")
Commit	Line	Data
ec600e45 LC	1	;;; GNU Guix --- Functional package management for GNU
	2	;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
	19	(define-module (test-accounts)
	20	#:use-module (gnu build accounts)
	21	#:use-module (gnu system accounts)
	22	#:use-module (srfi srfi-19)
	23	#:use-module (srfi srfi-64)
	24	#:use-module (ice-9 vlist)
	25	#:use-module (ice-9 match))
	26
	27	(define %passwd-sample
	28	"\
	29	root:x:0:0:Admin:/root:/bin/sh
	30	charlie:x:1000:998:Charlie:/home/charlie:/bin/sh\n")
	31
	32	(define %group-sample
	33	"\
	34	root:x:0:
	35	wheel:x:999:alice,bob
	36	hackers:x:65000:alice,charlie\n")
	37
	38	(define %shadow-sample
	39	(string-append "\
	40	root:" (crypt "secret" "$6$abc") ":17169::::::
	41	charlie:" (crypt "hey!" "$6$abc") ":17169::::::
	42	nobody:!:0::::::\n"))
	43
	44	\f
	45	(test-begin "accounts")
	46
	47	(test-equal "write-passwd"
	48	%passwd-sample
	49	(call-with-output-string
	50	(lambda (port)
	51	(write-passwd (list (password-entry
	52	(name "root")
	53	(uid 0) (gid 0)
	54	(real-name "Admin")
	55	(directory "/root")
	56	(shell "/bin/sh"))
	57	(password-entry
	58	(name "charlie")
	59	(uid 1000) (gid 998)
	60	(real-name "Charlie")
	61	(directory "/home/charlie")
	62	(shell "/bin/sh")))
	63	port))))
	64
65	(test-equal "read-passwd + write-passwd"
66	%passwd-sample
67	(call-with-output-string
68	(lambda (port)
69	(write-passwd (call-with-input-string %passwd-sample
70	read-passwd)
71	port))))
72
73	(test-equal "write-group"
74	%group-sample
75	(call-with-output-string
76	(lambda (port)
77	(write-group (list (group-entry
78	(name "root") (gid 0))
79	(group-entry
80	(name "wheel") (gid 999)
81	(members '("alice" "bob")))
82	(group-entry
83	(name "hackers") (gid 65000)
84	(members '("alice" "charlie"))))
85	port))))
86
87	(test-equal "read-group + write-group"
88	%group-sample
89	(call-with-output-string
90	(lambda (port)
91	(write-group (call-with-input-string %group-sample
92	read-group)
93	port))))
94
95	(test-equal "write-shadow"
96	%shadow-sample
97	(call-with-output-string
98	(lambda (port)
99	(write-shadow (list (shadow-entry
100	(name "root")
101	(password (crypt "secret" "$6$abc"))
102	(last-change 17169))
103	(shadow-entry
104	(name "charlie")
105	(password (crypt "hey!" "$6$abc"))
106	(last-change 17169))
107	(shadow-entry
108	(name "nobody")))
109	port))))
110
111	(test-equal "read-shadow + write-shadow"
112	%shadow-sample
113	(call-with-output-string
114	(lambda (port)
115	(write-shadow (call-with-input-string %shadow-sample
116	read-shadow)
117	port))))
118
119	\f
120	(define allocate-groups (@@ (gnu build accounts) allocate-groups))
121	(define allocate-passwd (@@ (gnu build accounts) allocate-passwd))
122
123	(test-equal "allocate-groups"
124	;; Allocate GIDs in a stateless fashion.
125	(list (group-entry (name "s") (gid %system-id-max))
126	(group-entry (name "x") (gid 900))
127	(group-entry (name "t") (gid 899))
128	(group-entry (name "a") (gid %id-min) (password "foo")
129	(members '("alice" "bob")))
130	(group-entry (name "b") (gid (+ %id-min 1))
131	(members '("charlie"))))
132	(allocate-groups (list (user-group (name "s") (system? #t))
133	(user-group (name "x") (id 900))
134	(user-group (name "t") (system? #t))
135	(user-group (name "a") (password "foo"))
136	(user-group (name "b")))
137	(alist->vhash `(("a" . "bob")
138	("a" . "alice")
139	("b" . "charlie")))))
140
141	(test-equal "allocate-groups with requested GIDs"
142	;; Make sure the requested GID for "b" is honored.
143	(list (group-entry (name "a") (gid (+ 1 %id-min)))
144	(group-entry (name "b") (gid %id-min))
145	(group-entry (name "c") (gid (+ 2 %id-min))))
146	(allocate-groups (list (user-group (name "a"))
147	(user-group (name "b") (id %id-min))
148	(user-group (name "c")))
149	vlist-null))
150
151	(test-equal "allocate-groups with previous state"
152	;; Make sure bits of state are preserved: password, GID, no reuse of
153	;; previously-used GIDs.
154	(list (group-entry (name "s") (gid (- %system-id-max 1)))
155	(group-entry (name "t") (gid (- %system-id-max 2)))
156	(group-entry (name "a") (gid 30000) (password #f)
157	(members '("alice" "bob")))
158	(group-entry (name "b") (gid 30001) (password "bar")
159	(members '("charlie"))))
160	(allocate-groups (list (user-group (name "s") (system? #t))
161	(user-group (name "t") (system? #t))
162	(user-group (name "a") (password "foo"))
163	(user-group (name "b")))
164	(alist->vhash `(("a" . "bob")
165	("a" . "alice")
166	("b" . "charlie")))
167	(list (group-entry (name "a") (gid 30000))
168	(group-entry (name "b") (gid 30001)
169	(password "bar"))
170	(group-entry (name "removed")
171	(gid %system-id-max)))))
172
173	(test-equal "allocate-groups with previous state, looping"
174	;; Check that allocation starts after the highest previously-used GID, and
175	;; loops back to the lowest GID.
176	(list (group-entry (name "a") (gid (- %id-max 1)))
177	(group-entry (name "b") (gid %id-min))
178	(group-entry (name "c") (gid (+ 1 %id-min))))
179	(allocate-groups (list (user-group (name "a"))
180	(user-group (name "b"))
181	(user-group (name "c")))
182	vlist-null
183	(list (group-entry (name "d")
184	(gid (- %id-max 2))))))
185
186	(test-equal "allocate-passwd"
187	;; Allocate UIDs in a stateless fashion.
188	(list (password-entry (name "alice") (uid %id-min) (gid 1000)
189	(real-name "Alice") (shell "/bin/sh")
190	(directory "/home/alice"))
191	(password-entry (name "bob") (uid (+ 1 %id-min)) (gid 1001)
192	(real-name "Bob") (shell "/bin/gash")
193	(directory "/home/bob"))
194	(password-entry (name "sshd") (uid %system-id-max) (gid 500)
195	(real-name "sshd") (shell "/nologin")
196	(directory "/var/empty"))
197	(password-entry (name "guix") (uid 30000) (gid 499)
198	(real-name "Guix") (shell "/nologin")
199	(directory "/var/empty")))
200	(allocate-passwd (list (user-account (name "alice")
201	(comment "Alice")
ec600e45 LC	202	(shell "/bin/sh")
	203	(group "users"))
	204	(user-account (name "bob")
	205	(comment "Bob")
ec600e45 LC	206	(shell "/bin/gash")
	207	(group "wheel"))
	208	(user-account (name "sshd") (system? #t)
	209	(comment "sshd")
	210	(home-directory "/var/empty")
	211	(shell "/nologin")
	212	(group "sshd"))
	213	(user-account (name "guix") (system? #t)
	214	(comment "Guix")
	215	(home-directory "/var/empty")
	216	(shell "/nologin")
	217	(group "guix")
	218	(uid 30000)))
	219	(list (group-entry (name "users") (gid 1000))
	220	(group-entry (name "wheel") (gid 1001))
	221	(group-entry (name "sshd") (gid 500))
	222	(group-entry (name "guix") (gid 499)))))
	223
	224	(test-equal "allocate-passwd with previous state"
	225	;; Make sure bits of state are preserved: UID, no reuse of previously-used
	226	;; UIDs, and shell.
	227	(list (password-entry (name "alice") (uid 1234) (gid 1000)
	228	(real-name "Alice Smith") (shell "/gnu/.../bin/gash")
	229	(directory "/home/alice"))
	230	(password-entry (name "charlie") (uid 1236) (gid 1000)
	231	(real-name "Charlie") (shell "/bin/sh")
	232	(directory "/home/charlie")))
	233	(allocate-passwd (list (user-account (name "alice")
	234	(comment "Alice")
ec600e45 LC	235	(shell "/bin/sh") ;ignored
	236	(group "users"))
	237	(user-account (name "charlie")
	238	(comment "Charlie")
ec600e45 LC	239	(shell "/bin/sh")
	240	(group "users")))
	241	(list (group-entry (name "users") (gid 1000)))
	242	(list (password-entry (name "alice") (uid 1234) (gid 9999)
	243	(real-name "Alice Smith")
	244	(shell "/gnu/.../bin/gash")
	245	(directory "/home/alice"))
	246	(password-entry (name "bob") (uid 1235) (gid 1001)
	247	(real-name "Bob") (shell "/bin/sh")
	248	(directory "/home/bob")))))
	249
	250	(test-equal "user+group-databases"
	251	;; The whole shebang.
	252	(list (list (group-entry (name "a") (gid %id-min)
	253	(members '("bob")))
	254	(group-entry (name "b") (gid (+ 1 %id-min))
	255	(members '("alice")))
	256	(group-entry (name "s") (gid %system-id-max)))
	257	(list (password-entry (name "alice") (real-name "Alice")
	258	(uid %id-min) (gid %id-min)
	259	(directory "/a"))
	260	(password-entry (name "bob") (real-name "Bob")
	261	(uid (+ 1 %id-min)) (gid (+ 1 %id-min))
	262	(directory "/b"))
	263	(password-entry (name "nobody")
	264	(uid 65534) (gid %system-id-max)
	265	(directory "/var/empty")))
	266	(list (shadow-entry (name "alice") (last-change 100)
	267	(password (crypt "initial pass" "$6$")))
	268	(shadow-entry (name "bob") (last-change 50)
	269	(password (crypt "foo" "$6$")))
	270	(shadow-entry (name "nobody") (last-change 100))))
	271	(call-with-values
	272	(lambda ()
	273	(user+group-databases (list (user-account
	274	(name "alice")
	275	(comment "Alice")
	276	(home-directory "/a")
	277	(group "a")
	278	(supplementary-groups '("b"))
	279	(password (crypt "initial pass" "$6$")))
	280	(user-account
	281	(name "bob")
	282	(comment "Bob")
	283	(home-directory "/b")
	284	(group "b")
	285	(supplementary-groups '("a")))
	286	(user-account
	287	(name "nobody")
	288	(group "s")
	289	(uid 65534)
	290	(home-directory "/var/empty")))
	291	(list (user-group (name "a"))
	292	(user-group (name "b"))
	293	(user-group (name "s") (system? #t)))
	294	#:current-passwd '()
	295	#:current-shadow
	296	(list (shadow-entry (name "bob")
	297	(password (crypt "foo" "$6$"))
	298	(last-change 50)))
	299	#:current-groups '()
	300	#:current-time
	301	(lambda (type)
	302	(make-time type 0 (* 24 3600 100)))))
303	list))
304
305	(test-end "accounts")