projects/guix·blob python-team · refs

897 lines · 40.0 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2013-2023 Ludovic Courtès <[email protected]>
3;;; Copyright © 2014 Alex Kost <[email protected]>
4;;; Copyright © 2026 Simon Tournier <[email protected]>
5;;;
6;;; This file is part of GNU Guix.
7;;;
8;;; GNU Guix is free software; you can redistribute it and/or modify it
9;;; under the terms of the GNU General Public License as published by
10;;; the Free Software Foundation; either version 3 of the License, or (at
11;;; your option) any later version.
12;;;
13;;; GNU Guix is distributed in the hope that it will be useful, but
14;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16;;; GNU General Public License for more details.
17;;;
18;;; You should have received a copy of the GNU General Public License
19;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20
21(define-module (test-profiles)
22 #:use-module (guix tests)
23 #:use-module (guix profiles)
24 #:use-module (guix gexp)
25 #:use-module (guix store)
26 #:use-module (guix monads)
27 #:use-module (guix packages)
28 #:use-module (guix derivations)
29 #:use-module (guix build-system trivial)
30 #:use-module (gnu packages bootstrap)
31 #:use-module ((gnu packages base) #:prefix packages:)
32 #:use-module ((gnu packages guile) #:prefix packages:)
33 #:use-module (ice-9 match)
34 #:use-module (ice-9 regex)
35 #:use-module (ice-9 popen)
36 #:use-module (rnrs io ports)
37 #:use-module (srfi srfi-1)
38 #:use-module (srfi srfi-11)
39 #:use-module (srfi srfi-34)
40 #:use-module (srfi srfi-64))
41
42;; Test the (guix profiles) module.
43
44(define %store
45 (open-connection-for-tests))
46
47;; Globally disable grafts because they can trigger early builds.
48(%graft? #f)
49
50;; Example manifest entries.
51
52(define guile-1.8.8
53 (manifest-entry
54 (name "guile")
55 (version "1.8.8")
56 (item "/gnu/store/...")
57 (output "out")))
58
59(define guile-2.0.9
60 (manifest-entry
61 (name "guile")
62 (version "2.0.9")
63 (item "/gnu/store/...")
64 (output "out")))
65
66(define guile-2.0.9:debug
67 (manifest-entry (inherit guile-2.0.9)
68 (output "debug")))
69
70(define glibc
71 (manifest-entry
72 (name "glibc")
73 (version "2.19")
74 (item "/gnu/store/...")
75 (output "out")))
76
77
78(test-begin "profiles")
79
80(test-assert "manifest-installed?"
81 (let ((m (manifest (list guile-2.0.9 guile-2.0.9:debug))))
82 (and (manifest-installed? m (manifest-pattern (name "guile")))
83 (manifest-installed? m (manifest-pattern
84 (name "guile") (output "debug")))
85 (manifest-installed? m (manifest-pattern
86 (name "guile") (output "out")
87 (version "2.0.9")))
88 (not (manifest-installed?
89 m (manifest-pattern (name "guile") (version "1.8.8"))))
90 (not (manifest-installed?
91 m (manifest-pattern (name "guile") (output "foobar")))))))
92
93(test-assert "manifest-matching-entries"
94 (let* ((e (list guile-2.0.9 guile-2.0.9:debug))
95 (m (manifest e)))
96 (and (equal? e
97 (manifest-matching-entries m
98 (list (manifest-pattern
99 (name "guile")
100 (output #f)))))
101 (equal? (list guile-2.0.9)
102 (manifest-matching-entries m
103 (list (manifest-pattern
104 (name "guile")
105 (version "2.0.9"))))))))
106
107(test-assert "manifest-matching-entries, no match"
108 (let ((m (manifest (list guile-2.0.9)))
109 (p (manifest-pattern (name "python"))))
110 (guard (c ((unmatched-pattern-error? c)
111 (and (eq? p (unmatched-pattern-error-pattern c))
112 (eq? m (unmatched-pattern-error-manifest c)))))
113 (manifest-matching-entries m (list p))
114 #f)))
115
116(test-equal "concatenate-manifests"
117 (manifest (list guile-2.0.9 glibc))
118 (concatenate-manifests (list (manifest (list guile-2.0.9))
119 (manifest (list glibc)))))
120
121(test-assert "manifest-remove"
122 (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
123 (m1 (manifest-remove m0
124 (list (manifest-pattern (name "guile")))))
125 (m2 (manifest-remove m1
126 (list (manifest-pattern (name "guile"))))) ; same
127 (m3 (manifest-remove m2
128 (list (manifest-pattern
129 (name "guile") (output "debug")))))
130 (m4 (manifest-remove m3
131 (list (manifest-pattern (name "guile"))))))
132 (match (manifest-entries m2)
133 ((($ <manifest-entry> "guile" "2.0.9" "debug"))
134 (and (equal? m1 m2)
135 (null? (manifest-entries m3))
136 (null? (manifest-entries m4)))))))
137
138(test-assert "manifest-add"
139 (let* ((m0 (manifest '()))
140 (m1 (manifest-add m0 (list guile-1.8.8)))
141 (m2 (manifest-add m1 (list guile-2.0.9)))
142 (m3 (manifest-add m2 (list guile-2.0.9:debug)))
143 (m4 (manifest-add m3 (list guile-2.0.9:debug))))
144 (and (match (manifest-entries m1)
145 ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
146 (_ #f))
147 (match (manifest-entries m2)
148 ((($ <manifest-entry> "guile" "2.0.9" "out")) #t)
149 (_ #f))
150 (equal? m3 m4))))
151
152(test-equal "manifest-add removes duplicates" ;<https://bugs.gnu.org/30569>
153 (list guile-2.0.9)
154 (manifest-entries (manifest-add (manifest '())
155 (list guile-2.0.9 guile-2.0.9))))
156
157(test-equal "manifest->code, simple"
158 '(begin
159 (specifications->manifest (list "guile" "guile:debug" "glibc")))
160 (manifest->code (manifest (list guile-2.0.9 guile-2.0.9:debug glibc))))
161
162(test-equal "manifest->code, simple, versions"
163 '(begin
164 (specifications->manifest (list "[email protected]" "[email protected]:debug"
165 "[email protected]")))
166 (manifest->code (manifest (list guile-2.0.9 guile-2.0.9:debug glibc))
167 #:entry-package-version manifest-entry-version))
168
169(test-equal "manifest->code, transformations"
170 '(begin
171 (use-modules (guix transformations))
172
173 (define transform1
174 (options->transformation '((foo . "bar"))))
175
176 (packages->manifest
177 (list (transform1 (specification->package "guile"))
178 (specification->package "glibc"))))
179 (manifest->code (manifest (list (manifest-entry
180 (inherit guile-2.0.9)
181 (properties `((transformations
182 . ((foo . "bar"))))))
183 glibc))))
184
185(test-assert "manifest-perform-transaction"
186 (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
187 (t1 (manifest-transaction
188 (install (list guile-1.8.8))
189 (remove (list (manifest-pattern (name "guile")
190 (output "debug"))))))
191 (t2 (manifest-transaction
192 (remove (list (manifest-pattern (name "guile")
193 (version "2.0.9")
194 (output #f))))))
195 (m1 (manifest-perform-transaction m0 t1))
196 (m2 (manifest-perform-transaction m1 t2))
197 (m3 (manifest-perform-transaction m0 t2)))
198 (and (match (manifest-entries m1)
199 ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
200 (_ #f))
201 (equal? m1 m2)
202 (null? (manifest-entries m3)))))
203
204(test-assert "manifest-transaction-effects"
205 (let* ((m0 (manifest (list guile-1.8.8)))
206 (t (manifest-transaction
207 (install (list guile-2.0.9 glibc)))))
208 (let-values (((remove install upgrade downgrade)
209 (manifest-transaction-effects m0 t)))
210 (and (null? remove) (null? downgrade)
211 (equal? (list glibc) install)
212 (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
213
214(test-assert "manifest-transaction-effects no double install or upgrades"
215 (let* ((m0 (manifest (list guile-1.8.8)))
216 (t (manifest-transaction
217 (install (list guile-2.0.9 glibc glibc)))))
218 (let-values (((remove install upgrade downgrade)
219 (manifest-transaction-effects m0 t)))
220 (and (null? remove) (null? downgrade)
221 (equal? (list glibc) install)
222 (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
223
224(test-assert "manifest-transaction-effects and downgrades"
225 (let* ((m0 (manifest (list guile-2.0.9)))
226 (t (manifest-transaction (install (list guile-1.8.8)))))
227 (let-values (((remove install upgrade downgrade)
228 (manifest-transaction-effects m0 t)))
229 (and (null? remove) (null? install) (null? upgrade)
230 (equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade)))))
231
232(test-assert "manifest-transaction-effects no double downgrade"
233 (let* ((m0 (manifest (list guile-2.0.9)))
234 (t (manifest-transaction (install (list guile-1.8.8 guile-1.8.8)))))
235 (let-values (((remove install upgrade downgrade)
236 (manifest-transaction-effects m0 t)))
237 (and (null? remove) (null? install) (null? upgrade)
238 (equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade)))))
239
240(test-assert "manifest-transaction-effects and pseudo-upgrades"
241 (let* ((m0 (manifest (list guile-2.0.9)))
242 (t (manifest-transaction (install (list guile-2.0.9)))))
243 (let-values (((remove install upgrade downgrade)
244 (manifest-transaction-effects m0 t)))
245 (and (null? remove) (null? install) (null? downgrade)
246 (equal? (list (cons guile-2.0.9 guile-2.0.9)) upgrade)))))
247
248(test-assert "manifest-transaction-null?"
249 (manifest-transaction-null? (manifest-transaction)))
250
251(test-assert "manifest-transaction-removal-candidate?"
252 (let ((m (manifest (list guile-2.0.9)))
253 (t (manifest-transaction
254 (remove (list (manifest-pattern (name "guile")))))))
255 (and (manifest-transaction-removal-candidate? guile-2.0.9 t)
256 (not (manifest-transaction-removal-candidate? glibc t)))))
257
258(test-assert "manifest-transaction-effects no double removal"
259 (let* ((m0 (manifest (list guile-2.0.9)))
260 (t (manifest-transaction
261 (remove (list (manifest-pattern (name "guile")))))))
262 (let-values (((remove install upgrade downgrade)
263 (manifest-transaction-effects m0 t)))
264 (and (= 1 (length remove))
265 (manifest-transaction-removal-candidate? guile-2.0.9 t)
266 (null? install) (null? downgrade) (null? upgrade)))))
267
268(test-assert "package->development-manifest"
269 (let ((manifest (package->development-manifest packages:hello)))
270 (every (lambda (name)
271 (manifest-installed? manifest
272 (manifest-pattern (name name))))
273 '("gcc" "binutils" "glibc" "coreutils" "grep" "sed"))))
274
275(test-assert "build-system->manifest"
276 (let* ((package packages:hello)
277 (development-manifest (package->development-manifest package))
278 (build-system-manifest (build-system->manifest (package-build-system
279 package)))
280 (development-entries (manifest-entries development-manifest))
281 (build-system-entries (manifest-entries build-system-manifest)))
282 (and (eqv? (length development-entries)
283 (length build-system-entries))
284 (null? (lset-difference manifest-entry=?
285 development-entries build-system-entries)))))
286
287(test-assertm "profile-derivation"
288 (mlet* %store-monad
289 ((entry -> (package->manifest-entry %bootstrap-guile))
290 (guile (package->derivation %bootstrap-guile))
291 (drv (profile-derivation (manifest (list entry))
292 #:hooks '()
293 #:locales? #f))
294 (profile -> (derivation->output-path drv))
295 (bindir -> (string-append profile "/bin"))
296 (_ (built-derivations (list drv))))
297 (return (and (file-exists? (string-append bindir "/guile"))
298 (string=? (dirname (readlink bindir))
299 (derivation->output-path guile))))))
300
301(test-assertm "profile-derivation format version 3"
302 ;; Make sure we can create and read a version 3 manifest.
303 (mlet* %store-monad
304 ((entry -> (package->manifest-entry %bootstrap-guile
305 #:properties '((answer . 42))))
306 (manifest -> (manifest (list entry)))
307 (drv1 (profile-derivation manifest
308 #:format-version 3 ;old version
309 #:hooks '()
310 #:locales? #f))
311 (drv2 (profile-derivation manifest
312 #:hooks '()
313 #:locales? #f))
314 (profile1 -> (derivation->output-path drv1))
315 (profile2 -> (derivation->output-path drv2))
316 (_ (built-derivations (list drv1 drv2))))
317 (return (let ((manifest1 (profile-manifest profile1))
318 (manifest2 (profile-manifest profile2)))
319 (match (manifest-entries manifest1)
320 ((entry1)
321 (match (manifest-entries manifest2)
322 ((entry2)
323 (and (manifest-entry=? entry1 entry2)
324 (equal? (manifest-entry-properties entry1)
325 '((answer . 42)))
326 (equal? (manifest-entry-properties entry2)
327 '((answer . 42))))))))))))
328
329(test-assertm "profile-derivation, ordering & collisions"
330 ;; ENTRY1 and ENTRY2 both provide 'bin/guile'--a collision. Make sure
331 ;; ENTRY1 "wins" over ENTRY2. See <https://bugs.gnu.org/49102>.
332 (mlet* %store-monad
333 ((entry1 -> (package->manifest-entry %bootstrap-guile))
334 (entry2 -> (manifest-entry
335 (name "fake-guile")
336 (version "0")
337 (item (computed-file
338 "fake-guile"
339 #~(begin
340 (mkdir #$output)
341 (mkdir (string-append #$output "/bin"))
342 (call-with-output-file
343 (string-append #$output "/bin/guile")
344 (lambda (port)
345 (display "Fake!\n" port))))
346 #:guile %bootstrap-guile))))
347 (guile (package->derivation %bootstrap-guile))
348 (drv (profile-derivation (manifest (list entry1 entry2))
349 #:hooks '()
350 #:locales? #f))
351 (profile -> (derivation->output-path drv))
352 (bindir -> (string-append profile "/bin"))
353 (file -> (string-append bindir "/guile"))
354 (_ (built-derivations (list drv))))
355 (return (string=? (readlink file)
356 (string-append
357 (derivation->output-path guile)
358 "/bin/guile")))))
359
360(test-assertm "load-profile"
361 (mlet* %store-monad
362 ((entry -> (package->manifest-entry %bootstrap-guile))
363 (guile (package->derivation %bootstrap-guile))
364 (drv (profile-derivation (manifest (list entry))
365 #:hooks '()
366 #:locales? #f))
367 (profile -> (derivation->output-path drv))
368 (bindir -> (string-append profile "/bin"))
369 (_ (built-derivations (list drv))))
370 (define-syntax-rule (with-environment-excursion body ...)
371 ;; Save the current environment variables, run BODY..., and restore
372 ;; them.
373 (let ((env (environ)))
374 (dynamic-wind
375 (const #t)
376 (lambda () body ...)
377 (lambda () (environ env)))))
378
379 (return (and (with-environment-excursion
380 (load-profile profile)
381 (and (string-prefix? (string-append bindir ":")
382 (getenv "PATH"))
383 (getenv "GUILE_LOAD_PATH")))
384 (with-environment-excursion
385 (load-profile profile #:pure? #t #:white-list '())
386 (equal? (list (string-append "PATH=" bindir))
387 (environ)))))))
388
389(test-assertm "<profile>"
390 (mlet* %store-monad
391 ((entry -> (package->manifest-entry %bootstrap-guile))
392 (profile -> (profile (hooks '()) (locales? #f)
393 (content (manifest (list entry)))))
394 (drv (lower-object profile))
395 (profile -> (derivation->output-path drv))
396 (bindir -> (string-append profile "/bin"))
397 (_ (built-derivations (list drv))))
398 (return (file-exists? (string-append bindir "/guile")))))
399
400(test-assertm "profile-derivation, #:system, and hooks"
401 ;; Make sure all the profile hooks are built for the system specified with
402 ;; #:system, even if that does not match (%current-system).
403 ;; See <https://issues.guix.gnu.org/65225>.
404 (mlet* %store-monad
405 ((system -> (if (string=? (%current-system) "riscv64-linux")
406 "x86_64-linux"
407 "riscv64-linux"))
408 (entry -> (package->manifest-entry packages:coreutils))
409 (_ (set-guile-for-build (default-guile) system))
410 (drv (profile-derivation (manifest (list entry))
411 #:system system))
412 (refs (references* (derivation-file-name drv))))
413 (return (and (string=? (derivation-system drv) system)
414 (pair? refs)
415 (every (lambda (ref)
416 (or (not (string-suffix? ".drv" ref))
417 (let ((drv (read-derivation-from-file ref)))
418 (string=? (derivation-system drv)
419 system))))
420 refs)))))
421
422(test-assertm "profile-derivation relative symlinks, one entry"
423 (mlet* %store-monad
424 ((entry -> (package->manifest-entry %bootstrap-guile))
425 (guile (package->derivation %bootstrap-guile))
426 (drv (profile-derivation (manifest (list entry))
427 #:relative-symlinks? #t
428 #:hooks '()
429 #:locales? #f))
430 (profile -> (derivation->output-path drv))
431 (bindir -> (string-append profile "/bin"))
432 (_ (built-derivations (list drv))))
433 (return (and (file-exists? (string-append bindir "/guile"))
434 (string=? (readlink bindir)
435 (string-append "../"
436 (basename
437 (derivation->output-path guile))
438 "/bin"))))))
439
440(unless (network-reachable?) (test-skip 1))
441(test-assertm "profile-derivation relative symlinks, two entries"
442 (mlet* %store-monad
443 ((manifest -> (packages->manifest
444 (list %bootstrap-guile gnu-make-for-tests)))
445 (guile (package->derivation %bootstrap-guile))
446 (make (package->derivation gnu-make-for-tests))
447 (drv (profile-derivation manifest
448 #:relative-symlinks? #t
449 #:hooks '()
450 #:locales? #f))
451 (profile -> (derivation->output-path drv))
452 (bindir -> (string-append profile "/bin"))
453 (_ (built-derivations (list drv))))
454 (return (and (file-exists? (string-append bindir "/guile"))
455 (file-exists? (string-append bindir "/make"))
456 (string=? (readlink (string-append bindir "/guile"))
457 (string-append "../../"
458 (basename
459 (derivation->output-path guile))
460 "/bin/guile"))
461 (string=? (readlink (string-append bindir "/make"))
462 (string-append "../../"
463 (basename
464 (derivation->output-path make))
465 "/bin/make"))))))
466
467(test-assertm "profile-derivation, inputs"
468 (mlet* %store-monad
469 ((entry -> (package->manifest-entry packages:glibc "debug"))
470 (drv (profile-derivation (manifest (list entry))
471 #:hooks '()
472 #:locales? #f)))
473 (return (derivation-inputs drv))))
474
475(test-assertm "profile-derivation, cross-compilation"
476 (mlet* %store-monad
477 ((manifest -> (packages->manifest (list packages:sed packages:grep)))
478 (target -> "arm-linux-gnueabihf")
479 (grep (package->cross-derivation packages:grep target))
480 (sed (package->cross-derivation packages:sed target))
481 (drv (profile-derivation manifest
482 #:hooks '()
483 #:locales? #t
484 #:target target)))
485 (define (find-input package)
486 (let ((name (string-append (package-full-name package "-") ".drv")))
487 (any (lambda (input)
488 (let ((input (derivation-input-path input)))
489 (and (string-suffix? name input) input)))
490 (derivation-inputs drv))))
491
492 (return (and (string=? (derivation-system drv) (%current-system))
493 (string=? (find-input packages:grep)
494 (derivation-file-name grep))
495 (string=? (find-input packages:sed)
496 (derivation-file-name sed))))))
497
498(test-assert "package->manifest-entry defaults to \"out\""
499 (let ((outputs (package-outputs packages:glibc)))
500 (equal? (manifest-entry-output
501 (package->manifest-entry (package
502 (inherit packages:glibc)
503 (outputs (reverse outputs)))))
504 (manifest-entry-output
505 (package->manifest-entry packages:glibc))
506 "out")))
507
508(test-assertm "profile-manifest, search-paths"
509 (mlet* %store-monad
510 ((guile -> (package
511 (inherit %bootstrap-guile)
512 (native-search-paths
513 (package-native-search-paths packages:guile-2.0))))
514 (entry -> (package->manifest-entry guile))
515 (drv (profile-derivation (manifest (list entry))
516 #:hooks '()
517 #:locales? #f))
518 (profile -> (derivation->output-path drv)))
519 (mbegin %store-monad
520 (built-derivations (list drv))
521
522 ;; Read the manifest back and make sure search paths are preserved.
523 (let ((manifest (profile-manifest profile)))
524 (match (manifest-entries manifest)
525 ((result)
526 (return (equal? (manifest-entry-search-paths result)
527 (manifest-entry-search-paths entry)
528 (package-native-search-paths
529 packages:guile-2.0)))))))))
530
531(test-assert "package->manifest-entry, search paths"
532 ;; See <http://bugs.gnu.org/22073>.
533 (let ((mpl (@ (gnu packages python-xyz) python-matplotlib)))
534 (lset= eq?
535 (package-transitive-native-search-paths mpl)
536 (manifest-entry-search-paths
537 (package->manifest-entry mpl)))))
538
539(test-assert "package->manifest-entry, origin in propagated inputs"
540 ;; See <https://codeberg.org/guix/guix/pulls/969>
541 (let ((p1 (dummy-package "pkg"))
542 (p2 (dummy-package "pkg"
543 (propagated-inputs
544 (list (package-source %bootstrap-guile)))))
545 (package->manifest-entry-dependencies
546 (compose manifest-entry-dependencies package->manifest-entry)))
547 (and (null? (package->manifest-entry-dependencies p1))
548 (null? (package->manifest-entry-dependencies p2)))))
549
550(test-assert "packages->manifest, no duplicates"
551 (let ((expected
552 (manifest
553 (list
554 (package->manifest-entry packages:guile-2.2))))
555 (manifest (packages->manifest
556 (list packages:guile-2.2 packages:guile-2.2))))
557 (every manifest-entry=? (manifest-entries expected)
558 (manifest-entries manifest))))
559
560(test-equal "packages->manifest, propagated inputs"
561 (map (match-lambda
562 ((label package)
563 (list (package-name package) (package-version package)
564 package)))
565 (package-propagated-inputs packages:guile-2.2))
566 (map (lambda (entry)
567 (list (manifest-entry-name entry)
568 (manifest-entry-version entry)
569 (manifest-entry-item entry)))
570 (manifest-entry-dependencies
571 (package->manifest-entry packages:guile-2.2))))
572
573(test-assert "manifest-entry-parent"
574 (let ((entry (package->manifest-entry packages:guile-2.2)))
575 (match (manifest-entry-dependencies entry)
576 ((dependencies ..1)
577 (and (every (lambda (parent)
578 (eq? entry (force parent)))
579 (map manifest-entry-parent dependencies))
580 (not (force (manifest-entry-parent entry))))))))
581
582(test-assertm "read-manifest"
583 (mlet* %store-monad ((manifest -> (packages->manifest
584 (list (package
585 (inherit %bootstrap-guile)
586 (native-search-paths
587 (package-native-search-paths
588 packages:guile-2.0))))))
589 (drv (profile-derivation manifest
590 #:hooks '()
591 #:locales? #f))
592 (out -> (derivation->output-path drv)))
593 (define (entry->sexp entry)
594 (list (manifest-entry-name entry)
595 (manifest-entry-version entry)
596 (manifest-entry-search-paths entry)
597 (manifest-entry-dependencies entry)
598 (force (manifest-entry-parent entry))))
599
600 (mbegin %store-monad
601 (built-derivations (list drv))
602 (let ((manifest2 (profile-manifest out)))
603 (return (equal? (map entry->sexp (manifest-entries manifest))
604 (map entry->sexp (manifest-entries manifest2))))))))
605
606(test-equal "collision"
607 '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
608 (guard (c ((profile-collision-error? c)
609 (let ((entry1 (profile-collision-error-entry c))
610 (entry2 (profile-collision-error-conflict c)))
611 (list (list (manifest-entry-name entry1)
612 (manifest-entry-version entry1))
613 (list (manifest-entry-name entry2)
614 (manifest-entry-version entry2))))))
615 (run-with-store %store
616 (mlet* %store-monad ((p0 -> (package
617 (inherit %bootstrap-guile)
618 (version "42")))
619 (p1 -> (dummy-package "p1"
620 (propagated-inputs `(("p0" ,p0)))))
621 (manifest -> (packages->manifest
622 (list %bootstrap-guile p1)))
623 (drv (profile-derivation manifest
624 #:hooks '()
625 #:locales? #f)))
626 (return #f)))))
627
628(test-equal "collision of propagated inputs"
629 '(("guile-bootstrap" "2.0") "p1"
630 <> ("guile-bootstrap" "42") "p2")
631 (guard (c ((profile-collision-error? c)
632 (let ((entry1 (profile-collision-error-entry c))
633 (entry2 (profile-collision-error-conflict c)))
634 (list (list (manifest-entry-name entry1)
635 (manifest-entry-version entry1))
636 (manifest-entry-name
637 (force (manifest-entry-parent entry1)))
638 '<>
639 (list (manifest-entry-name entry2)
640 (manifest-entry-version entry2))
641 (manifest-entry-name
642 (force (manifest-entry-parent entry2)))))))
643 (run-with-store %store
644 (mlet* %store-monad ((p0 -> (package
645 (inherit %bootstrap-guile)
646 (version "42")))
647 (p1 -> (dummy-package "p1"
648 (propagated-inputs
649 `(("guile" ,%bootstrap-guile)))))
650 (p2 -> (dummy-package "p2"
651 (propagated-inputs
652 `(("guile" ,p0)))))
653 (manifest -> (packages->manifest (list p1 p2)))
654 (drv (profile-derivation manifest
655 #:hooks '()
656 #:locales? #f)))
657 (return #f)))))
658
659(test-assertm "deduplication of repeated entries"
660 ;; Make sure the 'manifest' file does not duplicate identical entries.
661 ;; See <https://issues.guix.gnu.org/55499>.
662 (mlet* %store-monad ((p0 -> (dummy-package "p0"
663 (build-system trivial-build-system)
664 (arguments
665 `(#:guile ,%bootstrap-guile
666 #:builder (mkdir (assoc-ref %outputs "out"))))
667 (propagated-inputs
668 `(("guile" ,%bootstrap-guile)))))
669 (p1 -> (package
670 (inherit p0)
671 (name "p1")))
672 (drv (profile-derivation (packages->manifest
673 (list p0 p1))
674 #:hooks '()
675 #:locales? #f)))
676 (mbegin %store-monad
677 (built-derivations (list drv))
678 (let ((file (string-append (derivation->output-path drv)
679 "/manifest"))
680 (manifest (profile-manifest (derivation->output-path drv))))
681 (define (contains-repeated? sexp)
682 (match sexp
683 (('repeated _ ...) #t)
684 ((lst ...) (any contains-repeated? sexp))
685 (_ #f)))
686
687 (return (and (contains-repeated? (call-with-input-file file read))
688
689 ;; MANIFEST has two entries for %BOOTSTRAP-GUILE since
690 ;; it's propagated both from P0 and from P1. When
691 ;; reading a 'repeated' node, 'read-manifest' should
692 ;; reuse the previously-read entry so the two
693 ;; %BOOTSTRAP-GUILE entries must be 'eq?'.
694 (match (manifest-entries manifest)
695 (((= manifest-entry-dependencies (dep0))
696 (= manifest-entry-dependencies (dep1)))
697 (and (string=? (manifest-entry-name dep0)
698 (package-name %bootstrap-guile))
699 (eq? dep0 dep1))))))))))
700
701(test-assertm "no collision"
702 ;; Here we have an entry that is "lowered" (its 'item' field is a store file
703 ;; name) and another entry (its 'item' field is a package) that is
704 ;; equivalent.
705 (mlet* %store-monad ((p -> (dummy-package "p"
706 (propagated-inputs
707 `(("guile" ,%bootstrap-guile)))))
708 (guile (package->derivation %bootstrap-guile))
709 (entry -> (manifest-entry
710 (inherit (package->manifest-entry
711 %bootstrap-guile))
712 (item (derivation->output-path guile))))
713 (manifest -> (manifest
714 (list entry
715 (package->manifest-entry p))))
716 (drv (profile-derivation manifest)))
717 (return (->bool drv))))
718
719(test-assertm "etc/profile"
720 ;; Make sure we get an 'etc/profile' file that at least defines $PATH.
721 (mlet* %store-monad
722 ((guile -> (package
723 (inherit %bootstrap-guile)
724 (native-search-paths
725 (package-native-search-paths packages:guile-2.0))))
726 (entry -> (package->manifest-entry guile))
727 (drv (profile-derivation (manifest (list entry))
728 #:hooks '()
729 #:locales? #f))
730 (profile -> (derivation->output-path drv)))
731 (mbegin %store-monad
732 (built-derivations (list drv))
733 (let* ((pipe (open-input-pipe
734 (string-append "unset GUIX_PROFILE; "
735 ;; 'source' is a Bashism; use '.' (dot).
736 ". " profile "/etc/profile; "
737 ;; Don't try to parse set(1) output because
738 ;; it differs among shells; just use echo.
739 "echo $PATH")))
740 (path (get-string-all pipe)))
741 (return
742 (and (zero? (close-pipe pipe))
743 (string-contains path (string-append profile "/bin"))))))))
744
745(test-assertm "etc/profile when etc/ already exists"
746 ;; Here 'union-build' makes the profile's etc/ a symlink to the package's
747 ;; etc/ directory, which makes it read-only. Make sure the profile build
748 ;; handles that.
749 (mlet* %store-monad
750 ((thing -> (dummy-package "dummy"
751 (build-system trivial-build-system)
752 (arguments
753 `(#:guile ,%bootstrap-guile
754 #:builder
755 (let ((out (assoc-ref %outputs "out")))
756 (mkdir out)
757 (mkdir (string-append out "/etc"))
758 (call-with-output-file (string-append out "/etc/foo")
759 (lambda (port)
760 (display "foo!" port)))
761 #t)))))
762 (entry -> (package->manifest-entry thing))
763 (drv (profile-derivation (manifest (list entry))
764 #:hooks '()
765 #:locales? #f))
766 (profile -> (derivation->output-path drv)))
767 (mbegin %store-monad
768 (built-derivations (list drv))
769 (return (and (file-exists? (string-append profile "/etc/profile"))
770 (string=? (call-with-input-file
771 (string-append profile "/etc/foo")
772 get-string-all)
773 "foo!"))))))
774
775(test-assertm "etc/profile when etc/ is a symlink"
776 ;; When etc/ is a symlink, the unsymlink code in 0.8.2 would fail
777 ;; gracelessly because 'scandir' would return #f.
778 (mlet* %store-monad
779 ((thing -> (dummy-package "dummy"
780 (build-system trivial-build-system)
781 (arguments
782 `(#:guile ,%bootstrap-guile
783 #:builder
784 (let ((out (assoc-ref %outputs "out")))
785 (mkdir out)
786 (mkdir (string-append out "/foo"))
787 (symlink "foo" (string-append out "/etc"))
788 (call-with-output-file (string-append out "/etc/bar")
789 (lambda (port)
790 (display "foo!" port)))
791 #t)))))
792 (entry -> (package->manifest-entry thing))
793 (drv (profile-derivation (manifest (list entry))
794 #:hooks '()
795 #:locales? #f))
796 (profile -> (derivation->output-path drv)))
797 (mbegin %store-monad
798 (built-derivations (list drv))
799 (return (and (file-exists? (string-append profile "/etc/profile"))
800 (string=? (call-with-input-file
801 (string-append profile "/etc/bar")
802 get-string-all)
803 "foo!"))))))
804
805(test-assertm "profile-derivation when etc/ is a relative symlink"
806 ;; See <https://bugs.gnu.org/32686>.
807 (mlet* %store-monad
808 ((etc (gexp->derivation
809 "etc"
810 #~(begin
811 (mkdir #$output)
812 (call-with-output-file (string-append #$output "/foo")
813 (lambda (port)
814 (display "Heya!" port))))))
815 (thing -> (dummy-package "dummy"
816 (build-system trivial-build-system)
817 (inputs
818 `(("etc" ,etc)))
819 (arguments
820 `(#:guile ,%bootstrap-guile
821 #:builder
822 (let ((out (assoc-ref %outputs "out"))
823 (etc (assoc-ref %build-inputs "etc")))
824 (mkdir out)
825 (symlink etc (string-append out "/etc"))
826 #t)))))
827 (entry -> (package->manifest-entry thing))
828 (drv (profile-derivation (manifest (list entry))
829 #:relative-symlinks? #t
830 #:hooks '()
831 #:locales? #f))
832 (profile -> (derivation->output-path drv)))
833 (mbegin %store-monad
834 (built-derivations (list drv))
835 (return (string=? (call-with-input-file
836 (string-append profile "/etc/foo")
837 get-string-all)
838 "Heya!")))))
839
840(test-equalm "union vs. dangling symlink" ;<https://bugs.gnu.org/26949>
841 "does-not-exist"
842 (mlet* %store-monad
843 ((thing1 -> (dummy-package "dummy"
844 (build-system trivial-build-system)
845 (arguments
846 `(#:guile ,%bootstrap-guile
847 #:builder
848 (let ((out (assoc-ref %outputs "out")))
849 (mkdir out)
850 (symlink "does-not-exist"
851 (string-append out "/dangling"))
852 #t)))))
853 (thing2 -> (package (inherit thing1) (name "dummy2")))
854 (drv (profile-derivation (packages->manifest
855 (list thing1 thing2))
856 #:hooks '()
857 #:locales? #f))
858 (profile -> (derivation->output-path drv)))
859 (mbegin %store-monad
860 (built-derivations (list drv))
861 (return (readlink (readlink (string-append profile "/dangling")))))))
862
863(test-equalm "profile in profile"
864 '("foo" "0")
865
866 ;; Make sure we can build a profile that has another profile has one of its
867 ;; entries. The new profile's /manifest and /etc/profile must override the
868 ;; other's.
869 (mlet* %store-monad
870 ((prof0 (profile-derivation
871 (manifest
872 (list (package->manifest-entry %bootstrap-guile)))
873 #:hooks '()
874 #:locales? #f))
875 (prof1 (profile-derivation
876 (manifest (list (manifest-entry
877 (name "foo")
878 (version "0")
879 (item prof0))))
880 #:hooks '()
881 #:locales? #f)))
882 (mbegin %store-monad
883 (built-derivations (list prof1))
884 (let ((out (derivation->output-path prof1)))
885 (return (and (file-exists?
886 (string-append out "/bin/guile"))
887 (let ((manifest (profile-manifest out)))
888 (match (manifest-entries manifest)
889 ((entry)
890 (list (manifest-entry-name entry)
891 (manifest-entry-version entry)))))))))))
892
893(test-end "profiles")
894
895;;; Local Variables:
896;;; eval: (put 'dummy-package 'scheme-indent-function 1)
897;;; End: