projects/guix·blob sysadmin-team · refs

161 lines · 5.8 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2016, 2018, 2022 Ludovic Courtès <[email protected]>
3;;; Copyright © 2017 Tobias Geerinckx-Rice <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
7;;; GNU Guix is free software; you can redistribute it and/or modify it
8;;; under the terms of the GNU General Public License as published by
9;;; the Free Software Foundation; either version 3 of the License, or (at
10;;; your option) any later version.
11;;;
12;;; GNU Guix is distributed in the hope that it will be useful, but
13;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19
20(define-module (test-system)
21 #:use-module (gnu)
22 #:use-module ((gnu services) #:select (service-value))
23 #:use-module (guix store)
24 #:use-module (guix monads)
25 #:use-module ((guix gexp) #:select (lower-object))
26 #:use-module ((guix utils) #:select (%current-system))
27 #:use-module (srfi srfi-1)
28 #:use-module (srfi srfi-64))
29
30;; Test the (gnu system) module.
31
32(define %root-fs
33 (file-system
34 (device (file-system-label "my-root"))
35 (mount-point "/")
36 (type "ext4")))
37
38(define %os
39 (operating-system
40 (host-name "komputilo")
41 (timezone "Europe/Berlin")
42 (locale "en_US.utf8")
43 (bootloader (bootloader-configuration
44 (bootloader grub-bootloader)
45 (targets '("/dev/sdX"))))
46 (file-systems (cons %root-fs %base-file-systems))
47
48 (users %base-user-accounts)))
49
50(define %luks-device
51 (mapped-device
52 (source "/dev/foo") (target "my-luks-device")
53 (type luks-device-mapping)))
54
55(define %os-with-mapped-device
56 (operating-system
57 (host-name "komputilo")
58 (timezone "Europe/Berlin")
59 (locale "en_US.utf8")
60 (bootloader (bootloader-configuration
61 (bootloader grub-bootloader)
62 (targets '("/dev/sdX"))))
63 (mapped-devices (list %luks-device))
64 (file-systems (cons (file-system
65 (inherit %root-fs)
66 (dependencies (list %luks-device)))
67 %base-file-systems))
68 (users %base-user-accounts)))
69
70(%graft? #f)
71
72
73(test-begin "system")
74
75(test-assert "operating-system-store-file-system"
76 ;; %BASE-FILE-SYSTEMS defines a bind-mount for /gnu/store, but this
77 ;; shouldn't be a problem.
78 (eq? %root-fs
79 (operating-system-store-file-system %os)))
80
81(test-assert "operating-system-store-file-system, prefix"
82 (let* ((gnu (file-system
83 (device "foobar")
84 (mount-point (dirname (%store-prefix)))
85 (type "ext5")))
86 (os (operating-system
87 (inherit %os)
88 (file-systems (cons* gnu %root-fs
89 %base-file-systems)))))
90 (eq? gnu (operating-system-store-file-system os))))
91
92(test-assert "operating-system-store-file-system, store"
93 (let* ((gnu (file-system
94 (device "foobar")
95 (mount-point (%store-prefix))
96 (type "ext5")))
97 (os (operating-system
98 (inherit %os)
99 (file-systems (cons* gnu %root-fs
100 %base-file-systems)))))
101 (eq? gnu (operating-system-store-file-system os))))
102
103(test-equal "operating-system-user-mapped-devices"
104 '()
105 (operating-system-user-mapped-devices %os-with-mapped-device))
106
107(test-equal "operating-system-boot-mapped-devices"
108 (list %luks-device)
109 (operating-system-boot-mapped-devices %os-with-mapped-device))
110
111(test-equal "operating-system-boot-mapped-devices, implicit dependency"
112 (list %luks-device)
113
114 ;; Here we expect the implicit dependency between "/" and
115 ;; "/dev/mapper/my-luks-device" to be found, in spite of the lack of a
116 ;; 'dependencies' field in the root file system.
117 (operating-system-boot-mapped-devices
118 (operating-system
119 (inherit %os-with-mapped-device)
120 (file-systems (cons (file-system
121 (device "/dev/mapper/my-luks-device")
122 (mount-point "/")
123 (type "ext4"))
124 %base-file-systems)))))
125
126(test-equal "non-boot-file-system-service"
127 '()
128
129 ;; Make sure that mapped devices with at least one needed-for-boot user are
130 ;; handled exclusively from the initrd. See <https://bugs.gnu.org/31889>.
131 (append-map file-system-dependencies
132 (service-value
133 ((@@ (gnu system) non-boot-file-system-service)
134 (operating-system
135 (inherit %os-with-mapped-device)
136 (file-systems
137 (list (file-system
138 (mount-point "/foo/bar")
139 (device "qux:baz")
140 (type "none")
141 (dependencies (list %luks-device)))
142 (file-system
143 (device (file-system-label "my-root"))
144 (mount-point "/")
145 (type "ext4")
146 (dependencies (list %luks-device))))))))))
147
148(test-assert "lower-object, %current-system sensitivity"
149 ;; Make sure that 'lower-object' returns the same derivation, no matter what
150 ;; '%current-system' is. See <https://issues.guix.gnu.org/55951>.
151 (let ((drv1 (with-store store
152 (parameterize ((%current-system "x86_64-linux"))
153 (run-with-store store
154 (lower-object %os "aarch64-linux")))))
155 (drv2 (with-store store
156 (parameterize ((%current-system "aarch64-linux"))
157 (run-with-store store
158 (lower-object %os "aarch64-linux"))))))
159 (eq? drv1 drv2)))
160
161(test-end)