projects/guix·blob sysadmin-team · refs

545 lines · 25.1 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2017-2021, 2023-2024, 2026 Ludovic Courtès <[email protected]>
3;;; Copyright © 2018 Ricardo Wurmus <[email protected]>
4;;; Copyright © 2021, 2023, 2025 Maxim Cournoyer <[email protected]>
5;;; Copyright © 2023 Oleg Pykhalov <[email protected]>
6;;; Copyright © 2024-2025 Noé Lopez <[email protected]>
7;;;
8;;; This file is part of GNU Guix.
9;;;
10;;; GNU Guix is free software; you can redistribute it and/or modify it
11;;; under the terms of the GNU General Public License as published by
12;;; the Free Software Foundation; either version 3 of the License, or (at
13;;; your option) any later version.
14;;;
15;;; GNU Guix is distributed in the hope that it will be useful, but
16;;; WITHOUT ANY WARRANTY; without even the implied warranty of
17;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;;; GNU General Public License for more details.
19;;;
20;;; You should have received a copy of the GNU General Public License
21;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22
23(define-module (test-pack)
24 #:use-module (guix scripts pack)
25 #:use-module (guix store)
26 #:use-module (guix derivations)
27 #:use-module (guix profiles)
28 #:use-module (guix packages)
29 #:use-module (guix monads)
30 #:use-module (guix tests)
31 #:use-module (guix gexp)
32 #:use-module (guix modules)
33 #:use-module (guix utils)
34 #:use-module ((guix build utils) #:select (%store-directory))
35 #:use-module (gnu packages)
36 #:use-module ((gnu packages base) #:select (libc-utf8-locales-for-target
37 hello glibc))
38 #:use-module (gnu packages bootstrap)
39 #:use-module ((gnu packages package-management) #:select (rpm))
40 #:use-module ((gnu packages compression) #:select (squashfs-tools))
41 #:use-module ((gnu packages debian) #:select (dpkg))
42 #:use-module ((gnu packages guile) #:select (guile-sqlite3 guile-3.0))
43 #:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
44 #:use-module ((gnu packages linux) #:select (fakeroot))
45 #:use-module ((ice-9 textual-ports) #:select (get-string-all))
46 #:use-module (srfi srfi-64))
47
48(define %store
49 (open-connection-for-tests))
50
51;; Globally disable grafts because they can trigger early builds.
52(%graft? #f)
53
54(define %gzip-compressor
55 ;; Compressor that uses the bootstrap 'gzip'.
56 ((@ (guix scripts pack) compressor) "gzip"
57 ".gz"
58 #~(list #+(file-append %bootstrap-coreutils&co "/bin/gzip") "-6n")))
59
60(define %tar-bootstrap %bootstrap-coreutils&co)
61
62(define %ar-bootstrap %bootstrap-binutils)
63
64
65(test-begin "pack")
66
67;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of
68;; commit c45477d2a1a651485feede20fe0f3d15aec48b39 and related changes. Thus,
69;; run it on the user's store, if it's available, on the grounds that these
70;; dependencies may be already there, or we can get substitutes or build them
71;; quite inexpensively; see <https://bugs.gnu.org/32184>.
72(with-external-store store
73 (define-syntax-rule (test-assertm name exp)
74 (test-assert name
75 (let ((guile (package-derivation store %bootstrap-guile)))
76 (run-with-store store exp
77 #:guile-for-build guile))))
78
79 (unless store (test-skip 1))
80 (test-assertm "self-contained-tarball"
81 (mlet* %store-monad
82 ((guile (set-guile-for-build (default-guile)))
83 (profile -> (profile
84 (content (packages->manifest (list %bootstrap-guile)))
85 (hooks '())
86 (locales? #f)))
87 (tarball (self-contained-tarball "pack" profile
88 #:symlinks '(("/bin/Guile"
89 -> "bin/guile"))
90 #:compressor %gzip-compressor
91 #:archiver %tar-bootstrap))
92 (check (gexp->derivation
93 "check-tarball"
94 (with-imported-modules '((guix build utils))
95 #~(begin
96 (use-modules (guix build utils)
97 (srfi srfi-1))
98
99 (define store
100 ;; The unpacked store.
101 (string-append "." (%store-directory) "/"))
102
103 (define (canonical? file)
104 ;; Return #t if FILE is read-only and its mtime is 1.
105 (let ((st (lstat file)))
106 (or (not (string-prefix? store file))
107 (eq? 'symlink (stat:type st))
108 (and (= 1 (stat:mtime st))
109 (zero? (logand #o222
110 (stat:mode st)))))))
111
112 (define bin
113 (string-append "." #$profile "/bin"))
114
115 (setenv "PATH"
116 (string-append #$%tar-bootstrap "/bin"))
117 (system* "tar" "xvf" #$tarball)
118 (mkdir #$output)
119 (exit
120 (and (file-exists? (string-append bin "/guile"))
121 (file-exists? store)
122 (every canonical?
123 (find-files "." (const #t)
124 #:directories? #t))
125 (string=? (string-append #$%bootstrap-guile "/bin")
126 (readlink bin))
127 (string=? (string-append ".." #$profile
128 "/bin/guile")
129 (readlink "bin/Guile")))))))))
130 (built-derivations (list check))))
131
132 (unless store (test-skip 1))
133 (test-assertm "self-contained-tarball + localstatedir"
134 (mlet* %store-monad
135 ((guile (set-guile-for-build (default-guile)))
136 (profile -> (profile
137 (content (packages->manifest (list %bootstrap-guile)))
138 (hooks '())
139 (locales? #f)))
140 (tarball (self-contained-tarball "tar-pack" profile
141 #:localstatedir? #t))
142 (check (gexp->derivation
143 "check-tarball"
144 #~(let ((bin (string-append "." #$profile "/bin")))
145 (setenv "PATH"
146 (string-append #$%tar-bootstrap "/bin"))
147 (system* "tar" "xvf" #$tarball)
148 (mkdir #$output)
149 (exit
150 (and (file-exists? "var/guix/db/db.sqlite")
151 (string=? (string-append #$%bootstrap-guile "/bin")
152 (readlink bin))))))))
153 (built-derivations (list check))))
154
155 (unless store (test-skip 1))
156 (test-assertm "self-contained-tarball + localstatedir, UTF-8 file names"
157 (mlet* %store-monad
158 ((guile (set-guile-for-build (default-guile)))
159 (tree (interned-file-tree
160 `("directory-with-utf8-file-names" directory
161 ("α" regular (data "alpha"))
162 ("λ" regular (data "lambda")))))
163 (tarball (self-contained-tarball "tar-pack" tree
164 #:localstatedir? #t))
165 (check (gexp->derivation
166 "check-tarball"
167 (with-extensions (list guile-sqlite3 guile-gcrypt)
168 (with-imported-modules (source-module-closure
169 '((guix store database)))
170 #~(begin
171 (use-modules (guix store database)
172 (rnrs io ports)
173 (srfi srfi-1))
174
175 (define (valid-file? basename data)
176 (define file
177 (string-append "./" #$tree "/" basename))
178
179 (string=? (call-with-input-file (pk 'file file)
180 get-string-all)
181 data))
182
183 (setenv "PATH"
184 (string-append #$%tar-bootstrap "/bin"))
185 (system* "tar" "xvf" #$tarball)
186
187 (sql-schema
188 #$(local-file (search-path %load-path
189 "guix/store/schema.sql")))
190 (with-database "var/guix/db/db.sqlite" db
191 ;; Make sure non-ASCII file names are properly
192 ;; handled.
193 (setenv "GUIX_LOCPATH"
194 #+(file-append
195 (libc-utf8-locales-for-target)
196 "/lib/locale"))
197 (setlocale LC_ALL "en_US.utf8")
198
199 (mkdir #$output)
200 (exit
201 (and (every valid-file?
202 '("α" "λ")
203 '("alpha" "lambda"))
204 (integer? (valid-path-id db #$tree)))))))))))
205 (built-derivations (list check))))
206
207 (unless store (test-skip 1))
208 (test-assertm "docker-image + localstatedir"
209 (mlet* %store-monad
210 ((guile (set-guile-for-build (default-guile)))
211 (profile -> (profile
212 (content (packages->manifest (list %bootstrap-guile)))
213 (hooks '())
214 (locales? #f)))
215 (tarball (docker-image "docker-pack" profile
216 #:symlinks '(("/bin/Guile" -> "bin/guile"))
217 #:localstatedir? #t))
218 (check (gexp->derivation
219 "check-tarball"
220 (with-imported-modules '((guix build utils))
221 #~(begin
222 (use-modules (guix build utils)
223 (ice-9 match))
224
225 (define bin
226 (string-append "." #$profile "/bin"))
227
228 (setenv "PATH" (string-append #$%tar-bootstrap "/bin"))
229 (mkdir "base")
230 (with-directory-excursion "base"
231 (invoke "tar" "xvf" #$tarball))
232
233 (match (find-files "base" "layer.tar")
234 ((layer)
235 (invoke "tar" "xvf" layer)))
236
237 (when (and (file-exists? (string-append bin "/guile"))
238 (file-exists? "var/guix/db/db.sqlite")
239 (file-is-directory? "tmp")
240 (string=? (string-append #$%bootstrap-guile "/bin")
241 (pk 'binlink (readlink bin)))
242 (string=? (string-append #$profile "/bin/guile")
243 (pk 'guilelink (readlink "bin/Guile"))))
244 (mkdir #$output)))))))
245 (built-derivations (list check))))
246
247 (unless store (test-skip 1))
248 (test-assertm "docker-layered-image + localstatedir"
249 (mlet* %store-monad
250 ((guile (set-guile-for-build (default-guile)))
251 (profile -> (profile
252 (content (packages->manifest (list %bootstrap-guile)))
253 (hooks '())
254 (locales? #f)))
255 (tarball (docker-image "docker-pack" profile
256 #:symlinks '(("/bin/Guile" -> "bin/guile"))
257 #:localstatedir? #t
258 #:max-layers 100))
259 (check (gexp->derivation
260 "check-tarball"
261 (with-imported-modules '((guix build utils))
262 #~(begin
263 (use-modules (guix build utils)
264 (ice-9 match))
265
266 (define bin
267 (string-append "." #$profile "/bin"))
268
269 (define store
270 (string-append "." #$(%store-directory)))
271
272 (setenv "PATH" (string-append #$%tar-bootstrap "/bin"))
273 (mkdir "base")
274 (with-directory-excursion "base"
275 (invoke "tar" "xvf" #$tarball))
276
277 (match (find-files "base" "layer.tar")
278 ((layers ...)
279 (for-each (lambda (layer)
280 (invoke "tar" "xvf" layer)
281 (invoke "chmod" "--recursive" "u+w" store))
282 layers)))
283
284 (when
285 (and (file-exists? (string-append bin "/guile"))
286 (file-exists? "var/guix/db/db.sqlite")
287 (file-is-directory? "tmp")
288 (string=? (string-append #$%bootstrap-guile "/bin")
289 (readlink bin))
290 (string=? (string-append #$profile "/bin/guile")
291 (readlink "bin/Guile")))
292 (mkdir #$output)))))))
293 (built-derivations (list check))))
294
295 (unless store (test-skip 1))
296 (test-assertm "squashfs-image + localstatedir"
297 (mlet* %store-monad
298 ((guile (set-guile-for-build (default-guile)))
299 (profile -> (profile
300 (content (packages->manifest (list %bootstrap-guile)))
301 (hooks '())
302 (locales? #f)))
303 (image (squashfs-image "squashfs-pack" profile
304 #:symlinks '(("/bin" -> "bin"))
305 #:localstatedir? #t))
306 (check (gexp->derivation
307 "check-tarball"
308 (with-imported-modules '((guix build utils))
309 #~(begin
310 (use-modules (guix build utils)
311 (ice-9 match))
312
313 (define bin
314 (string-append "." #$profile "/bin"))
315
316 (setenv "PATH"
317 (string-append #$squashfs-tools "/bin"))
318 (invoke "unsquashfs" #$image)
319 (with-directory-excursion "squashfs-root"
320 (when (and (file-exists? (string-append bin
321 "/guile"))
322 (file-exists? "var/guix/db/db.sqlite")
323 (file-is-directory? "tmp")
324 (string=? (string-append #$%bootstrap-guile "/bin")
325 (pk 'binlink (readlink bin)))
326
327 ;; This is a relative symlink target.
328 (string=? (string-drop
329 (string-append #$profile "/bin")
330 1)
331 (pk 'guilelink (readlink "bin"))))
332 (mkdir #$output))))))))
333 (built-derivations (list check))))
334
335 (unless store (test-skip 1))
336 (test-assertm "appimage"
337 (mlet* %store-monad
338 ((guile (set-guile-for-build (default-guile)))
339 (profile -> (profile
340 ;; When using '--appimage-extract-and-run', the dynamic
341 ;; linker is necessary, hence glibc below.
342 (content (wrapped-manifest
343 (packages->manifest (list hello glibc))))
344 (relative-symlinks? #t)
345 (hooks '())
346 (locales? #f)))
347 (image (self-contained-appimage "hello-appimage" profile
348 #:entry-point "bin/hello"
349 #:extra-options
350 '(#:relocatable? #t)))
351 (check (gexp->derivation
352 "check-appimage"
353 (with-imported-modules '((guix build utils))
354 #~(begin
355 (use-modules (ice-9 popen)
356 (guix build utils))
357 (let ((pipe (open-pipe* OPEN_READ
358 #$image "--appimage-extract-and-run")))
359 (call-with-output-file #$output
360 (lambda (port)
361 (dump-port pipe port)))
362 (exit (status:exit-val (close-pipe pipe)))))))))
363 (mbegin %store-monad
364 (built-derivations (list (pk 'APPIMAGE-drv check)))
365 (return (string=? (call-with-input-file (derivation->output-path check)
366 get-string-all)
367 "Hello, world!\n")))))
368
369 (unless store (test-skip 1))
370 (test-assertm "appimage + localstatedir"
371 (mlet* %store-monad
372 ((guile (set-guile-for-build (default-guile)))
373 (profile -> (profile
374 ;; When using '--appimage-extract-and-run', the dynamic
375 ;; linker is necessary, hence glibc below.
376 (content (wrapped-manifest
377 (packages->manifest (list guile-3.0 glibc))))
378 (relative-symlinks? #t)
379 (hooks '())
380 (locales? #f)))
381 (image (self-contained-appimage "guile-appimage" profile
382 #:entry-point "bin/guile"
383 #:localstatedir? #t
384 #:extra-options
385 '(#:relocatable? #t)))
386 (check (gexp->derivation
387 "check-appimage-with-localstatedir"
388 #~(begin
389 ;; Create a file in $PWD and only then copy it to
390 ;; #$output, because #$output within the image's
391 ;; execution environment refers to its temporary store,
392 ;; not to the "real one".
393 (system* #$image "--appimage-extract-and-run" "-c"
394 (object->string
395 `(call-with-output-file "OUTPUT"
396 (lambda (port)
397 (display "Hello from Guile!\n"
398 port)))))
399 (copy-file "OUTPUT" #$output)
400 (system* #$image "--appimage-extract")
401 (exit (file-exists? "squashfs-root/var/guix/db/db.sqlite"))))))
402 (mbegin %store-monad
403 (built-derivations (list (pk 'APPIMAGE-drv check)))
404 (return (string=? (call-with-input-file (derivation->output-path check)
405 get-string-all)
406 "Hello from Guile!\n")))))
407
408 (unless store (test-skip 1))
409 (test-assertm "deb archive with symlinks and control files"
410 (mlet* %store-monad
411 ((guile (set-guile-for-build (default-guile)))
412 (profile -> (profile
413 (content (packages->manifest (list %bootstrap-guile)))
414 (hooks '())
415 (locales? #f)))
416 (deb (debian-archive
417 "deb-pack" profile
418 #:compressor %gzip-compressor
419 #:symlinks '(("/opt/gnu/bin" -> "bin"))
420 #:archiver %tar-bootstrap
421 #:extra-options
422 (list #:triggers-file
423 (plain-file "triggers"
424 "activate-noawait /usr/share/icons/hicolor\n")
425 #:postinst-file
426 (plain-file "postinst"
427 "echo running configure script\n"))))
428 (check
429 (gexp->derivation
430 "check-deb-pack"
431 (with-imported-modules '((guix build utils))
432 #~(begin
433 (use-modules (guix build utils)
434 (ice-9 match)
435 (ice-9 popen)
436 (ice-9 rdelim)
437 (ice-9 textual-ports)
438 (rnrs base))
439
440 (setenv "PATH" (string-join
441 (list (string-append #+%tar-bootstrap "/bin")
442 (string-append #+dpkg "/bin")
443 (string-append #+%ar-bootstrap "/bin"))
444 ":"))
445
446 ;; Validate the output of 'dpkg --info'.
447 (let* ((port (open-pipe* OPEN_READ "dpkg" "--info" #$deb))
448 (info (get-string-all port))
449 (exit-val (status:exit-val (close-pipe port))))
450 (assert (zero? exit-val))
451
452 (assert (string-contains
453 info
454 (string-append "Package: "
455 #+(package-name %bootstrap-guile))))
456
457 (assert (string-contains
458 info
459 (string-append "Version: "
460 #+(package-version %bootstrap-guile)))))
461
462 ;; Sanity check .deb contents.
463 (invoke "ar" "-xv" #$deb)
464 (assert (file-exists? "debian-binary"))
465 (assert (file-exists? "data.tar.gz"))
466 (assert (file-exists? "control.tar.gz"))
467
468 ;; Verify there are no hard links in data.tar.gz, as hard
469 ;; links would cause dpkg to fail unpacking the archive.
470 (define hard-links
471 (let ((port (open-pipe* OPEN_READ "tar" "-tvf" "data.tar.gz")))
472 (let loop ((hard-links '()))
473 (match (read-line port)
474 ((? eof-object?)
475 (assert (zero? (status:exit-val (close-pipe port))))
476 hard-links)
477 (line
478 (if (string-prefix? "u" line)
479 (loop (cons line hard-links))
480 (loop hard-links)))))))
481
482 (unless (null? hard-links)
483 (error "hard links found in data.tar.gz" hard-links))
484
485 ;; Verify the presence of the control files.
486 (invoke "tar" "-xf" "control.tar.gz")
487 (assert (file-exists? "control"))
488 (assert (and (file-exists? "postinst")
489 (= #o111 ;script is executable
490 (logand #o111 (stat:perms
491 (stat "postinst"))))))
492 (assert (file-exists? "triggers"))
493
494 (mkdir #$output))))))
495 (built-derivations (list check))))
496
497 (unless store (test-skip 1))
498 (test-assertm "rpm archive can be installed/uninstalled"
499 (mlet* %store-monad
500 ((guile (set-guile-for-build (default-guile)))
501 (profile -> (profile
502 (content (packages->manifest (list %bootstrap-guile)))
503 (hooks '())
504 (locales? #f)))
505 (rpm-pack (rpm-archive "rpm-pack" profile
506 #:compressor %gzip-compressor
507 #:symlinks '(("/bin/guile" -> "bin/guile"))
508 #:extra-options '(#:relocatable? #t)))
509 (check
510 (gexp->derivation
511 "check-rpm-pack"
512 (with-imported-modules (source-module-closure
513 '((guix build utils)))
514 #~(begin
515 (use-modules (guix build utils))
516
517 (define fakeroot #+(file-append fakeroot "/bin/fakeroot"))
518 (define rpm #+(file-append rpm "/bin/rpm"))
519 (define dbpath (string-append (getcwd) "/var/lib/rpm"))
520 (mkdir-p dbpath)
521
522 ;; Install the RPM package. This causes RPM to validate the
523 ;; signatures, header as well as the file digests, which
524 ;; makes it a rather thorough test.
525 (mkdir "test-prefix")
526 (invoke fakeroot rpm "--dbpath" dbpath "--install"
527 (string-append "--prefix=" (getcwd) "/test-prefix")
528 #$rpm-pack)
529
530 ;; Invoke the installed Guile command.
531 (invoke "./test-prefix/bin/guile" "--version")
532
533 ;; Uninstall the RPM package.
534 (invoke fakeroot rpm "--dbpath" dbpath
535 "--erase" "guile-bootstrap")
536
537 ;; Required so the above is run.
538 (mkdir #$output))))))
539 (built-derivations (list check)))))
540
541(test-end)
542
543;; Local Variables:
544;; eval: (put 'test-assertm 'scheme-indent-function 2)
545;; End: