projects/guix·blob javascript-team · refs

209 lines · 8.3 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2016, 2018, 2022, 2026 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 packages linux) #:select (util-linux))
23 #:use-module ((gnu services) #:select (service-value))
24 #:use-module ((guix derivations) #:select (derivation-file-name))
25 #:use-module (guix store)
26 #:use-module (guix monads)
27 #:use-module ((guix gexp) #:select (lower-object))
28 #:use-module ((guix utils) #:select (%current-system))
29 #:use-module ((guix combinators) #:select (given))
30 #:use-module ((guix transformations) #:select (options->transformation))
31 #:use-module (guix packages)
32 #:use-module ((guix tests) #:select (test-assertm))
33 #:use-module (srfi srfi-1)
34 #:use-module (srfi srfi-64))
35
36;; Test the (gnu system) module.
37
38(define %root-fs
39 (file-system
40 (device (file-system-label "my-root"))
41 (mount-point "/")
42 (type "ext4")))
43
44(define %os
45 (operating-system
46 (host-name "komputilo")
47 (timezone "Europe/Berlin")
48 (locale "en_US.utf8")
49 (bootloader (bootloader-configuration
50 (bootloader grub-bootloader)
51 (targets '("/dev/sdX"))))
52 (file-systems (cons %root-fs %base-file-systems))
53
54 (users %base-user-accounts)))
55
56(define %luks-device
57 (mapped-device
58 (source "/dev/foo") (target "my-luks-device")
59 (type luks-device-mapping)))
60
61(define %os-with-mapped-device
62 (operating-system
63 (host-name "komputilo")
64 (timezone "Europe/Berlin")
65 (locale "en_US.utf8")
66 (bootloader (bootloader-configuration
67 (bootloader grub-bootloader)
68 (targets '("/dev/sdX"))))
69 (mapped-devices (list %luks-device))
70 (file-systems (cons (file-system
71 (inherit %root-fs)
72 (dependencies (list %luks-device)))
73 %base-file-systems))
74 (users %base-user-accounts)))
75
76(%graft? #f)
77
78
79(test-begin "system")
80
81(test-assert "operating-system-store-file-system"
82 ;; %BASE-FILE-SYSTEMS defines a bind-mount for /gnu/store, but this
83 ;; shouldn't be a problem.
84 (eq? %root-fs
85 (operating-system-store-file-system %os)))
86
87(test-assert "operating-system-store-file-system, prefix"
88 (let* ((gnu (file-system
89 (device "foobar")
90 (mount-point (dirname (%store-prefix)))
91 (type "ext5")))
92 (os (operating-system
93 (inherit %os)
94 (file-systems (cons* gnu %root-fs
95 %base-file-systems)))))
96 (eq? gnu (operating-system-store-file-system os))))
97
98(test-assert "operating-system-store-file-system, store"
99 (let* ((gnu (file-system
100 (device "foobar")
101 (mount-point (%store-prefix))
102 (type "ext5")))
103 (os (operating-system
104 (inherit %os)
105 (file-systems (cons* gnu %root-fs
106 %base-file-systems)))))
107 (eq? gnu (operating-system-store-file-system os))))
108
109(test-equal "operating-system-user-mapped-devices"
110 '()
111 (operating-system-user-mapped-devices %os-with-mapped-device))
112
113(test-equal "operating-system-boot-mapped-devices"
114 (list %luks-device)
115 (operating-system-boot-mapped-devices %os-with-mapped-device))
116
117(test-equal "operating-system-boot-mapped-devices, implicit dependency"
118 (list %luks-device)
119
120 ;; Here we expect the implicit dependency between "/" and
121 ;; "/dev/mapper/my-luks-device" to be found, in spite of the lack of a
122 ;; 'dependencies' field in the root file system.
123 (operating-system-boot-mapped-devices
124 (operating-system
125 (inherit %os-with-mapped-device)
126 (file-systems (cons (file-system
127 (device "/dev/mapper/my-luks-device")
128 (mount-point "/")
129 (type "ext4"))
130 %base-file-systems)))))
131
132(test-equal "non-boot-file-system-service"
133 '()
134
135 ;; Make sure that mapped devices with at least one needed-for-boot user are
136 ;; handled exclusively from the initrd. See <https://bugs.gnu.org/31889>.
137 (append-map file-system-dependencies
138 (service-value
139 ((@@ (gnu system) non-boot-file-system-service)
140 (operating-system
141 (inherit %os-with-mapped-device)
142 (file-systems
143 (list (file-system
144 (mount-point "/foo/bar")
145 (device "qux:baz")
146 (type "none")
147 (dependencies (list %luks-device)))
148 (file-system
149 (device (file-system-label "my-root"))
150 (mount-point "/")
151 (type "ext4")
152 (dependencies (list %luks-device))))))))))
153
154(test-assert "lower-object, %current-system sensitivity"
155 ;; Make sure that 'lower-object' returns the same derivation, no matter what
156 ;; '%current-system' is. See <https://issues.guix.gnu.org/55951>.
157 (let ((drv1 (with-store store
158 (parameterize ((%current-system "x86_64-linux"))
159 (run-with-store store
160 (lower-object %os "aarch64-linux")))))
161 (drv2 (with-store store
162 (parameterize ((%current-system "aarch64-linux"))
163 (run-with-store store
164 (lower-object %os "aarch64-linux"))))))
165 (eq? drv1 drv2)))
166
167(test-assertm "transformation, no effect"
168 (mlet %store-monad ((drv1 (operating-system-derivation %os))
169 (drv2 (operating-system-derivation
170 (operating-system
171 (inherit %os)
172 (transformation
173 (options->transformation
174 '((with-input
175 . "libreoffice=abiword"))))))))
176 (return (string=? (derivation-file-name drv1)
177 (derivation-file-name drv2)))))
178
179(test-assertm "transformation, package-input-rewriting"
180 (mlet* %store-monad ((coreutils -> (canonical-package coreutils))
181 (my-coreutils -> (package
182 (inherit coreutils)
183 (name "my-coreutils")
184 (version "42.0")))
185 (drv1 (operating-system-derivation %os))
186 (drv2 (operating-system-derivation
187 (operating-system
188 (inherit %os)
189 (host-name "transformed")
190 (privileged-programs '())
191 (transformation
192 (given
193 package?
194 (package-input-rewriting
195 `((,coreutils
196 . ,my-coreutils))))))))
197 (old (lower-object coreutils))
198 (new (lower-object my-coreutils))
199 (requisites -> (store-lift requisites))
200 (req1 (requisites (list (derivation-file-name drv1))))
201 (req2 (requisites (list (derivation-file-name drv2)))))
202 (let ((old (derivation-file-name old))
203 (new (derivation-file-name new)))
204 ;; The transformed OS is expected to not contain any reference to the
205 ;; original 'coreutils' derivation.
206 (return (and (member old req1) (not (member new req1))
207 (member new req2) (not (member old req2)))))))
208
209(test-end)