projects/guix·blob ruby-team · refs

522 lines · 22.1 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2025 Ludovic Courtès <[email protected]>
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 (gnu tests foreign)
20 #:use-module (guix download)
21 #:use-module (guix gexp)
22 #:use-module (guix modules)
23 #:use-module (guix monads)
24 #:use-module (guix packages)
25 #:use-module (guix profiles)
26 #:autoload (guix store) (%store-prefix %store-monad %graft?)
27 #:use-module (gnu compression)
28 #:use-module (gnu tests)
29 #:use-module ((gnu tests base)
30 #:select (%hello-dependencies-manifest
31 guix-daemon-test-cases))
32 #:use-module (gnu packages admin)
33 #:use-module (gnu packages base)
34 #:use-module (gnu packages linux)
35 #:use-module (gnu packages bootstrap)
36 #:use-module (gnu packages guile)
37 #:use-module (gnu packages make-bootstrap)
38 #:use-module (gnu packages package-management)
39 #:use-module (gnu packages virtualization)
40 #:use-module (gnu system vm)
41 #:use-module ((guix scripts pack) #:prefix pack:)
42 #:use-module (srfi srfi-9)
43 #:export (%test-debian-install
44 %test-archlinux-install
45 %test-ubuntu-install
46 %test-fedora-install))
47
48(define marionette-systemd-service
49 ;; Definition of the marionette service for systemd.
50 (plain-file "marionette.service" "
51[Unit]
52Description=Guix marionette service
53
54[Install]
55WantedBy=multi-user.target
56
57[Service]
58ExecStart=/opt/guix/bin/guile --no-auto-compile \\
59 /opt/guix/share/guix/marionette-repl.scm\n"))
60
61(define* (qcow-image-with-marionette image
62 #:key
63 (name "image-with-marionette.qcow2")
64 (device "/dev/vdb1")
65 (resize-image #f)
66 (resize-proc #~(const #f)))
67 "Instrument IMAGE, returning a new image that contains a statically-linked
68Guile under /opt/guix and a marionette systemd service. The relevant file
69system is expected to be on DEVICE. When RESIZE-IMAGE is not #f, it is
70supplied as an argument to qemu-img resize as new size of the image, eg.
71\"+1G\" to add 1 GiB to the partition and its file system. RESIZE-PROC is a
72gexp evaluating to a two-argument procedure. The two arguments are device and
73marionette. This procedure will be called from within a VM and it should
74resize the partition and file system, if appropriate."
75 (define vm
76 (virtual-machine
77 (marionette-operating-system %simple-os)))
78
79 (define build
80 (with-imported-modules (source-module-closure
81 '((guix build utils)
82 (gnu build marionette)))
83 #~(begin
84 (use-modules (guix build utils)
85 (gnu build marionette))
86
87 (define target-image
88 #$output)
89
90 (invoke #+(file-append qemu "/bin/qemu-img")
91 "create" "-b" #$image
92 "-F" "qcow2" "-f" "qcow2" target-image)
93
94 (when #$resize-image
95 (invoke (string-append #+qemu "/bin/qemu-img")
96 "resize" target-image #$resize-image))
97
98 ;; Run a VM that will mount IMAGE and populate it. This is somewhat
99 ;; more convenient to set up than 'guestfish' from libguestfs.
100 (let ((marionette
101 (make-marionette
102 (list #$vm "-drive"
103 (string-append "file=" target-image
104 ",format=qcow2,if=virtio,"
105 "cache=writeback,werror=report,readonly=off")))))
106
107 (#$resize-proc #$device marionette)
108
109 (unless (zero? (marionette-eval '(system* "mount" #$device "/mnt")
110 marionette))
111 (error "failed to mount foreign distro image" #$device))
112
113 ;; Make newly copied files relabeled for SELinux-enabled distributions
114 (marionette-eval '(system* "touch" "/mnt/.autorelabel") marionette)
115
116 (marionette-eval '(system* "ls" "-la" "/mnt")
117 marionette)
118 (marionette-eval '(begin
119 (use-modules (guix build utils))
120 (mkdir-p "/mnt/opt/guix")
121 (copy-recursively #$%guile-static-initrd
122 "/mnt/opt/guix"
123 #:log (%make-void-port "w")
124 #:keep-mtime? #t))
125 marionette)
126 (marionette-eval '(system* "/mnt/opt/guix/bin/guile" "--version")
127 marionette)
128 (unless (= 42 (status:exit-val
129 (marionette-eval '(system* "/mnt/opt/guix/bin/guile"
130 "-c" "(exit 42)")
131 marionette)))
132 (error "statically-linked Guile is broken"))
133
134 ;; Install the marionette systemd service and activate it.
135 (marionette-eval '(begin
136 (mkdir-p "/mnt/opt/guix/share/guix")
137 (copy-file #$(marionette-program)
138 "/mnt/opt/guix/share/guix/marionette-repl.scm")
139
140 (mkdir-p "/mnt/etc/systemd/system")
141 (copy-file #$marionette-systemd-service
142 "/mnt/etc/systemd/system/marionette.service")
143
144 ;; Activate the service, as per 'systemctl
145 ;; enable marionette.service'.
146 (symlink
147 "/etc/systemd/system/marionette.service"
148 "/mnt/etc/systemd/system/multi-user.target.wants/marionette.service"))
149 marionette)
150
151 (unless (zero? (marionette-eval '(system* "umount" "/mnt")
152 marionette))
153 (error "failed to unmount device"))))))
154
155 (computed-file name build))
156
157(define resize-ext4-partition
158;; Gexp evaluating to a two-argument procedure, taking DEVICE and
159;; MARIONETTE. It will grow the given device and its file system to 100 %
160;; of the empty space on the image.
161 #~(lambda (device marionette)
162 (unless (zero? (marionette-eval
163 `(system*
164 #$(file-append cloud-utils "/bin/growpart")
165 (string-take ,device (- (string-length ,device) 1))
166 (string-take-right ,device 1))
167 marionette))
168 (error "failed to grow the partition"))
169
170 ;; ;; resize2fs will refuse operation when e2fsck is not ran.
171 (unless (zero? (marionette-eval
172 `(system* #$(file-append e2fsprogs "/sbin/e2fsck")
173 "-fy" ,device)
174 marionette))
175 (error "failed to repair the file system"))
176
177 (unless (zero? (marionette-eval
178 `(system* #$(file-append e2fsprogs "/sbin/resize2fs")
179 ,device)
180 marionette))
181 (error "failed to grow the file system"))))
182
183(define resize-lvm-xfs-partition
184 ;; Gexp evaluating to a two-argument procedure, taking DEVICE and
185 ;; MARIONETTE. It will grow the given device and its file system to 100 %
186 ;; of the empty space on the image.
187 #~(lambda (device marionette)
188
189 (unless (zero? (marionette-eval `(begin
190 (system* #$(file-append lvm2 "/sbin/pvscan"))
191 (system* #$(file-append lvm2 "/sbin/vgscan"))
192 (system* #$(file-append lvm2 "/sbin/vgchange") "-a" "y")
193 (system* #$(file-append lvm2 "/sbin/lvscan"))
194 (system* #$(file-append lvm2 "/sbin/lvextend") "-l" "+100%FREE" ,device))
195 marionette))
196 `(error "failed to extend logical volume" ,device))
197
198 (unless (zero? (marionette-eval `(system* "mount" ,device "/mnt")
199 marionette))
200 `(error "failed to mount foreign distro image" ,device))
201
202 (unless (zero? (marionette-eval
203 `(system* #$(file-append xfsprogs "/sbin/xfs_growfs")
204 ,device)
205 marionette))
206 (error "failed to grow the file system"))
207
208 (unless (zero? (marionette-eval '(system* "umount" "/mnt")
209 marionette))
210 (error "failed to unmount device"))))
211
212(define (manifest-entry-without-grafts entry)
213 "Return ENTRY with grafts disabled on its contents."
214 (manifest-entry
215 (inherit entry)
216 (item (with-parameters ((%graft? #f))
217 (manifest-entry-item entry)))))
218
219(define %installation-tarball-manifest
220 ;; Manifest of the Guix installation tarball.
221 (concatenate-manifests
222 (list (packages->manifest (list guix))
223 %hello-dependencies-manifest)))
224
225(define %guix-install-script
226 ;; The 'guix-install.sh' script.
227 ;;
228 ;; To test local changes, replace the expression below with:
229 ;;
230 ;; (local-file "../../etc/guix-install.sh")
231 ;;
232 ;; This cannot be done unconditionally since that file does not exists in
233 ;; inferiors.
234 (file-append (package-source guix) "/etc/guix-install.sh"))
235
236(define* (run-foreign-install-test image name
237 #:key
238 (device "/dev/vdb1")
239 (deb-files '())
240 (resize-image #f)
241 (resize-proc #~(const #f)))
242 "Run an installation of Guix in IMAGE, the QCOW2 image of a systemd-based
243GNU/Linux distro, and check that the installation is functional. The root
244partition of IMAGE is expected to be on DEVICE. Prior to that, install all of
245DEB-FILES with 'dpkg -i'. When RESIZE-IMAGE is not #f, it is supplied as an
246argument to qemu-img resize as new size of the image, eg. \"+1G\" to add 1
247GiB to the partition and its file system. RESIZE-PROC is a gexp evaluating to
248a two-argument procedure. The two arguments are device and marionette. This
249procedure will be called from within a VM and it should resize the partition
250and file system, if appropriate."
251 (define instrumented-image
252 (qcow-image-with-marionette image
253 #:name (string-append name ".qcow2")
254 #:device device
255 #:resize-image resize-image
256 #:resize-proc resize-proc))
257
258 (define (test tarball)
259 (with-imported-modules (source-module-closure
260 '((gnu build marionette)
261 (gnu system file-systems)))
262 #~(begin
263 (use-modules (gnu build marionette)
264 (gnu system file-systems)
265 (srfi srfi-64)
266 (ice-9 match))
267
268 (define marionette
269 (make-marionette
270 (list (string-append #$qemu-minimal "/bin/" (qemu-command))
271 #$@(common-qemu-options instrumented-image
272 (list (%store-prefix))
273 #:image-format "qcow2"
274 #:rw-image? #t)
275 "-m" "1024"
276 "-snapshot")))
277
278 (test-runner-current (system-test-runner #$output))
279 (test-begin "foreign-install")
280
281 (test-equal "marionette works"
282 "Linux"
283 (marionette-eval '(utsname:sysname (uname))
284 marionette))
285
286 (test-assert "/etc/os-release"
287 (marionette-eval '(begin
288 (use-modules (ice-9 textual-ports))
289 (call-with-input-file "/etc/os-release"
290 get-string-all))
291 marionette))
292
293 (test-equal "mount host file store"
294 0
295 (marionette-eval
296 '(begin
297 (mkdir "/host")
298 (system* "mount" "-t" "9p"
299 "-o" "trans=virtio,cache=loose,ro"
300 #$(file-system->mount-tag (%store-prefix))
301 "/host"))
302 marionette))
303
304 (test-assert "screenshot before"
305 (marionette-control (string-append "screendump " #$output
306 "/before-install.ppm")
307 marionette))
308
309 (test-assert "install fake dependencies"
310 ;; The installation script insists on checking for the
311 ;; availability of 'wget' and 'gpg' but does not actually use them
312 ;; when 'GUIX_BINARY_FILE_NAME' is set. Provide fake binaries
313 ;; that always succeed.
314 (marionette-eval '(begin
315 (false-if-exception
316 (delete-file "/bin/wget"))
317 (symlink "/bin/true" "/bin/wget")
318 (false-if-exception
319 (delete-file "/bin/gpg"))
320 (symlink "/bin/true" "/bin/gpg")
321 #t)
322 marionette))
323
324 (test-assert "install extra .deb packages"
325 (marionette-eval
326 '(and #$@(map (lambda (deb)
327 #~(system* "dpkg" "-i"
328 (in-vicinity "/host" (basename #$deb))))
329 deb-files))
330 marionette))
331
332 (test-assert "run install script"
333 (marionette-eval '(system
334 (string-append
335 "yes '' | GUIX_BINARY_FILE_NAME="
336 (in-vicinity "/host"
337 (basename #$tarball))
338 " sh "
339 (in-vicinity
340 "/host"
341 (string-drop #$%guix-install-script
342 #$(string-length
343 (%store-prefix))))))
344 marionette))
345
346 (test-equal "create user account"
347 0
348 (marionette-eval '(system* "useradd" "-d" "/home/user" "-m"
349 "user")
350 marionette))
351
352 #$(guix-daemon-test-cases #~marionette)
353
354 ;; NOTE: There was a bug where the service couldn't be restarted,
355 ;; because the store would be captured as read-only when creating
356 ;; the private mount namespace.
357 ;; See <https://codeberg.org/guix/guix/issues/4744>.
358 ;; So we try restarting it here.
359 (test-equal "restart guix-daemon.service"
360 0
361 (marionette-eval '(system* "systemctl" "restart"
362 "guix-daemon.service")
363 marionette))
364
365 (test-equal "guix build hello after guix-daemon.service restart"
366 0
367 (marionette-eval '(system* "guix" "build"
368 "hello" "--no-grafts"
369 "--check")
370 marionette))
371
372 (test-equal "guix gc after guix-daemon.service"
373 0
374 (marionette-eval '(system* "guix" "gc")
375 marionette))
376
377 ;; NOTE: Since the fix of the bug meant stopping gnu-store.mount
378 ;; during startup of guix-daemon service, check that it's started.
379 ;; Check only after some time, because the service might not be
380 ;; up yet right after the restart.
381 (test-equal "gnu-store.mount is active after guix-daemon restart"
382 0
383 (marionette-eval '(system* "systemctl" "is-active"
384 "gnu-store.mount")
385 marionette))
386
387 (test-assert "screenshot after"
388 (marionette-control (string-append "screendump " #$output
389 "/after-install.ppm")
390 marionette))
391
392 (test-end))))
393
394 (mlet* %store-monad ((profile (profile-derivation
395 %installation-tarball-manifest))
396 (tarball (pack:self-contained-tarball
397 "guix-binary" profile
398 #:compressor (lookup-compressor "zstd")
399 #:profile-name "current-guix"
400 #:localstatedir? #t)))
401 (gexp->derivation name (test tarball))))
402
403(define debian-13-qcow2
404 ;; Image taken from <https://www.debian.org/distrib/>.
405 ;; XXX: Those images are periodically removed from debian.org.
406 (let ((image-date "20260112-2355"))
407 (origin
408 (uri (string-append "https://cloud.debian.org/images/cloud/trixie/"
409 image-date "/debian-13-nocloud-amd64-"
410 image-date ".qcow2"))
411 (method url-fetch)
412 (file-name "debian-13-nocloud-amd64.qcow2")
413 (sha256
414 (base32
415 "0nrc2mgnlzxa48vj0mdkwm2llf1pg4xj4idab1xd123d6p8ggvms")))))
416
417(define debian-uidmap-deb-file
418 ;; This package provides 'newgidmap' & co., used by the unprivileged daemon.
419 (origin
420 (uri
421 "mirror://debian/pool/main/s/shadow/uidmap_4.13+dfsg1-1+deb12u2_amd64.deb")
422 (method url-fetch)
423 (sha256
424 (base32
425 "0imc6d6q6hzbfksmm9ibsc0wiqjhggvxv1zhvwvvsmy45ipxris5"))))
426
427;; This test starts failing when derivations in repo for GNU Hello and its dependencies
428;; differs from versions in current Guix package. The simple way to fix it is to update
429;; Guix package version.
430(define %test-debian-install
431 (system-test
432 (name "debian-install")
433 (description
434 "Test installation of Guix on Debian using the @file{guix-install.sh}
435script.")
436 (value (run-foreign-install-test debian-13-qcow2 name
437 #:deb-files (list debian-uidmap-deb-file)))))
438
439(define archlinux-qcow2
440 ;; Images generated by <https://gitlab.archlinux.org/archlinux/arch-boxes>;
441 ;; using default mirror mentioned in README there.
442 ;; XXX: These images are removed every ~90 days
443 (origin
444 (uri "https://geo.mirror.pkgbuild.com/images/v20251015.435734/Arch-Linux-x86_64-basic.qcow2")
445 (method url-fetch)
446 (sha256
447 (base32
448 "0mlvfsw9ak9b6cl5h0mhs90vqkqd3ha3lx4rv9xg2b510q6656li"))))
449
450;; This test starts failing when derivations in repo for GNU Hello and its dependencies
451;; differs from versions in current Guix package. The simple way to fix it is to update
452;; Guix package version.
453(define %test-archlinux-install
454 (system-test
455 (name "archlinux-install")
456 (description
457 "Test installation of Guix on Arch Linux using the @file{guix-install.sh}
458script.")
459 (value (run-foreign-install-test archlinux-qcow2 name
460 #:device "/dev/vdb3"))))
461
462(define ubuntu-qcow2
463 (let ((filename "noble-server-cloudimg-amd64.img"))
464 (origin
465 (uri (string-append "https://cloud-images.ubuntu.com/noble/20251213/" filename))
466 (method url-fetch)
467 (sha256
468 (base32
469 "07zbqlxg8524p7igwrpwrf5kwc6qam78f7023ihfy38qx3zr0prb")))))
470
471(define ubuntu-libsuid4-deb-file
472 ;; This package is a dependency of uidmap that's missing in the image.
473 (origin
474 (uri
475 "https://archive.ubuntu.com/ubuntu/pool/main/s/shadow/libsubid4_4.13+dfsg1-4ubuntu3_amd64.deb")
476 (method url-fetch)
477 (sha256
478 (base32
479 "1g2rypacgc0gp55wy3lxsa454m072c21cgzdzaf8zlpg4dv9k08l"))))
480
481(define ubuntu-uidmap-deb-file
482 ;; This package provides 'newgidmap' & co., used by the unprivileged daemon.
483 (origin
484 (uri
485 "https://archive.ubuntu.com/ubuntu/pool/main/s/shadow/uidmap_4.13+dfsg1-4ubuntu3_amd64.deb")
486 (method url-fetch)
487 (sha256
488 (base32
489 "1y8sw1shsxaan2icl6ajr2mwm6n69mvqzxmjl98sj4i82hdlm6nw"))))
490
491(define %test-ubuntu-install
492 (system-test
493 (name "ubuntu-install")
494 (description
495 "Test installation of Guix on Ubuntu using the @file{guix-install.sh}
496script.")
497 (value (run-foreign-install-test ubuntu-qcow2 name
498 #:deb-files (list ubuntu-libsuid4-deb-file
499 ubuntu-uidmap-deb-file)
500 #:resize-image "+1G"
501 #:resize-proc resize-ext4-partition))))
502(define fedora-qcow2
503 (origin
504 (uri "https://download.fedoraproject.org/pub/fedora/linux/releases/43/Server/x86_64/images/Fedora-Server-Guest-Generic-43-1.6.x86_64.qcow2")
505 (method url-fetch)
506 (sha256
507 (base32
508 "0j142kbrfcv9fwds4bw57dqhnjvpzd6d6m15ar3sgf1yw9dq0pac"))))
509
510;; This test starts failing when derivations in repo for GNU Hello and its dependencies
511;; differs from versions in current Guix package. The simple way to fix it is to update
512;; Guix package version.
513(define %test-fedora-install
514 (system-test
515 (name "fedora-install")
516 (description
517 "Test installation of Guix on Fedora Linux using the @file{guix-install.sh}
518script.")
519 (value (run-foreign-install-test fedora-qcow2 name
520 #:device "/dev/systemVG/LVRoot"
521 #:resize-image "+1G"
522 #:resize-proc resize-lvm-xfs-partition))))