1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
5 ;;; This file is part of GNU Guix.
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.
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.
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/>.
20 (define-module (test-profiles)
21 #:use-module (guix tests)
22 #:use-module (guix profiles)
23 #:use-module (guix store)
24 #:use-module (guix monads)
25 #:use-module (guix grafts)
26 #:use-module (guix packages)
27 #:use-module (guix derivations)
28 #:use-module (guix build-system trivial)
29 #:use-module (gnu packages bootstrap)
30 #:use-module ((gnu packages base) #:prefix packages:)
31 #:use-module ((gnu packages guile) #:prefix packages:)
32 #:use-module (ice-9 match)
33 #:use-module (ice-9 regex)
34 #:use-module (ice-9 popen)
35 #:use-module (rnrs io ports)
36 #:use-module (srfi srfi-1)
37 #:use-module (srfi srfi-11)
38 #:use-module (srfi srfi-34)
39 #:use-module (srfi srfi-64))
41 ;; Test the (guix profiles) module.
44 (open-connection-for-tests))
46 ;; Globally disable grafts because they can trigger early builds.
49 (define-syntax-rule (test-assertm name exp)
51 (run-with-store %store exp
52 #:guile-for-build (%guile-for-build))))
54 (define-syntax-rule (test-equalm name value exp)
57 (run-with-store %store exp
58 #:guile-for-build (%guile-for-build))))
60 ;; Example manifest entries.
66 (item "/gnu/store/...")
73 (item "/gnu/store/...")
76 (define guile-2.0.9:debug
77 (manifest-entry (inherit guile-2.0.9)
84 (item "/gnu/store/...")
88 (test-begin "profiles")
90 (test-assert "manifest-installed?"
91 (let ((m (manifest (list guile-2.0.9 guile-2.0.9:debug))))
92 (and (manifest-installed? m (manifest-pattern (name "guile")))
93 (manifest-installed? m (manifest-pattern
94 (name "guile") (output "debug")))
95 (manifest-installed? m (manifest-pattern
96 (name "guile") (output "out")
98 (not (manifest-installed?
99 m (manifest-pattern (name "guile") (version "1.8.8"))))
100 (not (manifest-installed?
101 m (manifest-pattern (name "guile") (output "foobar")))))))
103 (test-assert "manifest-matching-entries"
104 (let* ((e (list guile-2.0.9 guile-2.0.9:debug))
106 (and (null? (manifest-matching-entries m
107 (list (manifest-pattern
110 (manifest-matching-entries m
111 (list (manifest-pattern
114 (equal? (list guile-2.0.9)
115 (manifest-matching-entries m
116 (list (manifest-pattern
118 (version "2.0.9"))))))))
120 (test-assert "manifest-remove"
121 (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
122 (m1 (manifest-remove m0
123 (list (manifest-pattern (name "guile")))))
124 (m2 (manifest-remove m1
125 (list (manifest-pattern (name "guile"))))) ; same
126 (m3 (manifest-remove m2
127 (list (manifest-pattern
128 (name "guile") (output "debug")))))
129 (m4 (manifest-remove m3
130 (list (manifest-pattern (name "guile"))))))
131 (match (manifest-entries m2)
132 ((($ <manifest-entry> "guile" "2.0.9" "debug"))
134 (null? (manifest-entries m3))
135 (null? (manifest-entries m4)))))))
137 (test-assert "manifest-add"
138 (let* ((m0 (manifest '()))
139 (m1 (manifest-add m0 (list guile-1.8.8)))
140 (m2 (manifest-add m1 (list guile-2.0.9)))
141 (m3 (manifest-add m2 (list guile-2.0.9:debug)))
142 (m4 (manifest-add m3 (list guile-2.0.9:debug))))
143 (and (match (manifest-entries m1)
144 ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
146 (match (manifest-entries m2)
147 ((($ <manifest-entry> "guile" "2.0.9" "out")) #t)
151 (test-equal "manifest-add removes duplicates" ;<https://bugs.gnu.org/30569>
153 (manifest-entries (manifest-add (manifest '())
154 (list guile-2.0.9 guile-2.0.9))))
156 (test-assert "manifest-perform-transaction"
157 (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
158 (t1 (manifest-transaction
159 (install (list guile-1.8.8))
160 (remove (list (manifest-pattern (name "guile")
161 (output "debug"))))))
162 (t2 (manifest-transaction
163 (remove (list (manifest-pattern (name "guile")
166 (m1 (manifest-perform-transaction m0 t1))
167 (m2 (manifest-perform-transaction m1 t2))
168 (m3 (manifest-perform-transaction m0 t2)))
169 (and (match (manifest-entries m1)
170 ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
173 (null? (manifest-entries m3)))))
175 (test-assert "manifest-transaction-effects"
176 (let* ((m0 (manifest (list guile-1.8.8)))
177 (t (manifest-transaction
178 (install (list guile-2.0.9 glibc))
179 (remove (list (manifest-pattern (name "coreutils")))))))
180 (let-values (((remove install upgrade downgrade)
181 (manifest-transaction-effects m0 t)))
182 (and (null? remove) (null? downgrade)
183 (equal? (list glibc) install)
184 (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
186 (test-assert "manifest-transaction-effects and downgrades"
187 (let* ((m0 (manifest (list guile-2.0.9)))
188 (t (manifest-transaction (install (list guile-1.8.8)))))
189 (let-values (((remove install upgrade downgrade)
190 (manifest-transaction-effects m0 t)))
191 (and (null? remove) (null? install) (null? upgrade)
192 (equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade)))))
194 (test-assert "manifest-transaction-effects and pseudo-upgrades"
195 (let* ((m0 (manifest (list guile-2.0.9)))
196 (t (manifest-transaction (install (list guile-2.0.9)))))
197 (let-values (((remove install upgrade downgrade)
198 (manifest-transaction-effects m0 t)))
199 (and (null? remove) (null? install) (null? downgrade)
200 (equal? (list (cons guile-2.0.9 guile-2.0.9)) upgrade)))))
202 (test-assert "manifest-transaction-null?"
203 (manifest-transaction-null? (manifest-transaction)))
205 (test-assert "manifest-transaction-removal-candidate?"
206 (let ((m (manifest (list guile-2.0.9)))
207 (t (manifest-transaction
208 (remove (list (manifest-pattern (name "guile")))))))
209 (and (manifest-transaction-removal-candidate? guile-2.0.9 t)
210 (not (manifest-transaction-removal-candidate? glibc t)))))
212 (test-assertm "profile-derivation"
214 ((entry -> (package->manifest-entry %bootstrap-guile))
215 (guile (package->derivation %bootstrap-guile))
216 (drv (profile-derivation (manifest (list entry))
219 (profile -> (derivation->output-path drv))
220 (bindir -> (string-append profile "/bin"))
221 (_ (built-derivations (list drv))))
222 (return (and (file-exists? (string-append bindir "/guile"))
223 (string=? (dirname (readlink bindir))
224 (derivation->output-path guile))))))
226 (test-assertm "profile-derivation, inputs"
228 ((entry -> (package->manifest-entry packages:glibc "debug"))
229 (drv (profile-derivation (manifest (list entry))
232 (return (derivation-inputs drv))))
234 (test-assertm "profile-derivation, cross-compilation"
236 ((manifest -> (packages->manifest (list packages:sed packages:grep)))
237 (target -> "arm-linux-gnueabihf")
238 (grep (package->cross-derivation packages:grep target))
239 (sed (package->cross-derivation packages:sed target))
240 (locales (package->derivation packages:glibc-utf8-locales))
241 (drv (profile-derivation manifest
245 (define (find-input package)
246 (let ((name (string-append (package-full-name package "-") ".drv")))
248 (let ((input (derivation-input-path input)))
249 (and (string-suffix? name input) input)))
250 (derivation-inputs drv))))
252 ;; The inputs for grep and sed should be cross-build derivations, but that
253 ;; for the glibc-utf8-locales should be a native build.
254 (return (and (string=? (derivation-system drv) (%current-system))
255 (string=? (find-input packages:grep)
256 (derivation-file-name grep))
257 (string=? (find-input packages:sed)
258 (derivation-file-name sed))
259 (string=? (find-input packages:glibc-utf8-locales)
260 (derivation-file-name locales))))))
262 (test-assert "package->manifest-entry defaults to \"out\""
263 (let ((outputs (package-outputs packages:glibc)))
264 (equal? (manifest-entry-output
265 (package->manifest-entry (package
266 (inherit packages:glibc)
267 (outputs (reverse outputs)))))
268 (manifest-entry-output
269 (package->manifest-entry packages:glibc))
272 (test-assertm "profile-manifest, search-paths"
275 (inherit %bootstrap-guile)
277 (package-native-search-paths packages:guile-2.0))))
278 (entry -> (package->manifest-entry guile))
279 (drv (profile-derivation (manifest (list entry))
282 (profile -> (derivation->output-path drv)))
284 (built-derivations (list drv))
286 ;; Read the manifest back and make sure search paths are preserved.
287 (let ((manifest (profile-manifest profile)))
288 (match (manifest-entries manifest)
290 (return (equal? (manifest-entry-search-paths result)
291 (manifest-entry-search-paths entry)
292 (package-native-search-paths
293 packages:guile-2.0)))))))))
295 (test-assert "package->manifest-entry, search paths"
296 ;; See <http://bugs.gnu.org/22073>.
297 (let ((mpl (@ (gnu packages python) python2-matplotlib)))
299 (package-transitive-native-search-paths mpl)
300 (manifest-entry-search-paths
301 (package->manifest-entry mpl)))))
303 (test-equal "packages->manifest, propagated inputs"
306 (list (package-name package) (package-version package)
308 (package-propagated-inputs packages:guile-2.2))
310 (list (manifest-entry-name entry)
311 (manifest-entry-version entry)
312 (manifest-entry-item entry)))
313 (manifest-entry-dependencies
314 (package->manifest-entry packages:guile-2.2))))
316 (test-assert "manifest-entry-parent"
317 (let ((entry (package->manifest-entry packages:guile-2.2)))
318 (match (manifest-entry-dependencies entry)
320 (and (every (lambda (parent)
321 (eq? entry (force parent)))
322 (map manifest-entry-parent dependencies))
323 (not (force (manifest-entry-parent entry))))))))
325 (test-assertm "read-manifest"
326 (mlet* %store-monad ((manifest -> (packages->manifest
328 (inherit %bootstrap-guile)
330 (package-native-search-paths
331 packages:guile-2.0))))))
332 (drv (profile-derivation manifest
335 (out -> (derivation->output-path drv)))
336 (define (entry->sexp entry)
337 (list (manifest-entry-name entry)
338 (manifest-entry-version entry)
339 (manifest-entry-search-paths entry)
340 (manifest-entry-dependencies entry)
341 (force (manifest-entry-parent entry))))
344 (built-derivations (list drv))
345 (let ((manifest2 (profile-manifest out)))
346 (return (equal? (map entry->sexp (manifest-entries manifest))
347 (map entry->sexp (manifest-entries manifest2))))))))
349 (test-equal "collision"
350 '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
351 (guard (c ((profile-collision-error? c)
352 (let ((entry1 (profile-collision-error-entry c))
353 (entry2 (profile-collision-error-conflict c)))
354 (list (list (manifest-entry-name entry1)
355 (manifest-entry-version entry1))
356 (list (manifest-entry-name entry2)
357 (manifest-entry-version entry2))))))
358 (run-with-store %store
359 (mlet* %store-monad ((p0 -> (package
360 (inherit %bootstrap-guile)
362 (p1 -> (dummy-package "p1"
363 (propagated-inputs `(("p0" ,p0)))))
364 (manifest -> (packages->manifest
365 (list %bootstrap-guile p1)))
366 (drv (profile-derivation manifest
371 (test-equal "collision of propagated inputs"
372 '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
373 (guard (c ((profile-collision-error? c)
374 (let ((entry1 (profile-collision-error-entry c))
375 (entry2 (profile-collision-error-conflict c)))
376 (list (list (manifest-entry-name entry1)
377 (manifest-entry-version entry1))
378 (list (manifest-entry-name entry2)
379 (manifest-entry-version entry2))))))
380 (run-with-store %store
381 (mlet* %store-monad ((p0 -> (package
382 (inherit %bootstrap-guile)
384 (p1 -> (dummy-package "p1"
386 `(("guile" ,%bootstrap-guile)))))
387 (p2 -> (dummy-package "p2"
390 (manifest -> (packages->manifest (list p1 p2)))
391 (drv (profile-derivation manifest
396 (test-assertm "no collision"
397 ;; Here we have an entry that is "lowered" (its 'item' field is a store file
398 ;; name) and another entry (its 'item' field is a package) that is
400 (mlet* %store-monad ((p -> (dummy-package "p"
402 `(("guile" ,%bootstrap-guile)))))
403 (guile (package->derivation %bootstrap-guile))
404 (entry -> (manifest-entry
405 (inherit (package->manifest-entry
407 (item (derivation->output-path guile))))
408 (manifest -> (manifest
410 (package->manifest-entry p))))
411 (drv (profile-derivation manifest)))
412 (return (->bool drv))))
414 (test-assertm "etc/profile"
415 ;; Make sure we get an 'etc/profile' file that at least defines $PATH.
418 (inherit %bootstrap-guile)
420 (package-native-search-paths packages:guile-2.0))))
421 (entry -> (package->manifest-entry guile))
422 (drv (profile-derivation (manifest (list entry))
425 (profile -> (derivation->output-path drv)))
427 (built-derivations (list drv))
428 (let* ((pipe (open-input-pipe
429 (string-append "unset GUIX_PROFILE; "
430 ;; 'source' is a Bashism; use '.' (dot).
431 ". " profile "/etc/profile; "
432 ;; Don't try to parse set(1) output because
433 ;; it differs among shells; just use echo.
435 (path (get-string-all pipe)))
437 (and (zero? (close-pipe pipe))
438 (string-contains path (string-append profile "/bin"))))))))
440 (test-assertm "etc/profile when etc/ already exists"
441 ;; Here 'union-build' makes the profile's etc/ a symlink to the package's
442 ;; etc/ directory, which makes it read-only. Make sure the profile build
445 ((thing -> (dummy-package "dummy"
446 (build-system trivial-build-system)
448 `(#:guile ,%bootstrap-guile
450 (let ((out (assoc-ref %outputs "out")))
452 (mkdir (string-append out "/etc"))
453 (call-with-output-file (string-append out "/etc/foo")
455 (display "foo!" port))))))))
456 (entry -> (package->manifest-entry thing))
457 (drv (profile-derivation (manifest (list entry))
460 (profile -> (derivation->output-path drv)))
462 (built-derivations (list drv))
463 (return (and (file-exists? (string-append profile "/etc/profile"))
464 (string=? (call-with-input-file
465 (string-append profile "/etc/foo")
469 (test-assertm "etc/profile when etc/ is a symlink"
470 ;; When etc/ is a symlink, the unsymlink code in 0.8.2 would fail
471 ;; gracelessly because 'scandir' would return #f.
473 ((thing -> (dummy-package "dummy"
474 (build-system trivial-build-system)
476 `(#:guile ,%bootstrap-guile
478 (let ((out (assoc-ref %outputs "out")))
480 (mkdir (string-append out "/foo"))
481 (symlink "foo" (string-append out "/etc"))
482 (call-with-output-file (string-append out "/etc/bar")
484 (display "foo!" port))))))))
485 (entry -> (package->manifest-entry thing))
486 (drv (profile-derivation (manifest (list entry))
489 (profile -> (derivation->output-path drv)))
491 (built-derivations (list drv))
492 (return (and (file-exists? (string-append profile "/etc/profile"))
493 (string=? (call-with-input-file
494 (string-append profile "/etc/bar")
498 (test-equalm "union vs. dangling symlink" ;<https://bugs.gnu.org/26949>
501 ((thing1 -> (dummy-package "dummy"
502 (build-system trivial-build-system)
504 `(#:guile ,%bootstrap-guile
506 (let ((out (assoc-ref %outputs "out")))
508 (symlink "does-not-exist"
509 (string-append out "/dangling"))
511 (thing2 -> (package (inherit thing1) (name "dummy2")))
512 (drv (profile-derivation (packages->manifest
513 (list thing1 thing2))
516 (profile -> (derivation->output-path drv)))
518 (built-derivations (list drv))
519 (return (readlink (readlink (string-append profile "/dangling")))))))
521 (test-end "profiles")
524 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)