| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
| 3 | ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> |
| 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-profiles) |
| 21 | #:use-module (guix tests) |
| 22 | #:use-module (guix profiles) |
| 23 | #:use-module (guix gexp) |
| 24 | #:use-module (guix store) |
| 25 | #:use-module (guix monads) |
| 26 | #:use-module (guix grafts) |
| 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 | \f |
| 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-assert "manifest-perform-transaction" |
| 158 | (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug))) |
| 159 | (t1 (manifest-transaction |
| 160 | (install (list guile-1.8.8)) |
| 161 | (remove (list (manifest-pattern (name "guile") |
| 162 | (output "debug")))))) |
| 163 | (t2 (manifest-transaction |
| 164 | (remove (list (manifest-pattern (name "guile") |
| 165 | (version "2.0.9") |
| 166 | (output #f)))))) |
| 167 | (m1 (manifest-perform-transaction m0 t1)) |
| 168 | (m2 (manifest-perform-transaction m1 t2)) |
| 169 | (m3 (manifest-perform-transaction m0 t2))) |
| 170 | (and (match (manifest-entries m1) |
| 171 | ((($ <manifest-entry> "guile" "1.8.8" "out")) #t) |
| 172 | (_ #f)) |
| 173 | (equal? m1 m2) |
| 174 | (null? (manifest-entries m3))))) |
| 175 | |
| 176 | (test-assert "manifest-transaction-effects" |
| 177 | (let* ((m0 (manifest (list guile-1.8.8))) |
| 178 | (t (manifest-transaction |
| 179 | (install (list guile-2.0.9 glibc))))) |
| 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))))) |
| 185 | |
| 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))))) |
| 193 | |
| 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))))) |
| 201 | |
| 202 | (test-assert "manifest-transaction-null?" |
| 203 | (manifest-transaction-null? (manifest-transaction))) |
| 204 | |
| 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))))) |
| 211 | |
| 212 | (test-assertm "profile-derivation" |
| 213 | (mlet* %store-monad |
| 214 | ((entry -> (package->manifest-entry %bootstrap-guile)) |
| 215 | (guile (package->derivation %bootstrap-guile)) |
| 216 | (drv (profile-derivation (manifest (list entry)) |
| 217 | #:hooks '() |
| 218 | #:locales? #f)) |
| 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)))))) |
| 225 | |
| 226 | (test-assertm "profile-derivation relative symlinks, one entry" |
| 227 | (mlet* %store-monad |
| 228 | ((entry -> (package->manifest-entry %bootstrap-guile)) |
| 229 | (guile (package->derivation %bootstrap-guile)) |
| 230 | (drv (profile-derivation (manifest (list entry)) |
| 231 | #:relative-symlinks? #t |
| 232 | #:hooks '() |
| 233 | #:locales? #f)) |
| 234 | (profile -> (derivation->output-path drv)) |
| 235 | (bindir -> (string-append profile "/bin")) |
| 236 | (_ (built-derivations (list drv)))) |
| 237 | (return (and (file-exists? (string-append bindir "/guile")) |
| 238 | (string=? (readlink bindir) |
| 239 | (string-append "../" |
| 240 | (basename |
| 241 | (derivation->output-path guile)) |
| 242 | "/bin")))))) |
| 243 | |
| 244 | (unless (network-reachable?) (test-skip 1)) |
| 245 | (test-assertm "profile-derivation relative symlinks, two entries" |
| 246 | (mlet* %store-monad |
| 247 | ((manifest -> (packages->manifest |
| 248 | (list %bootstrap-guile gnu-make-for-tests))) |
| 249 | (guile (package->derivation %bootstrap-guile)) |
| 250 | (make (package->derivation gnu-make-for-tests)) |
| 251 | (drv (profile-derivation manifest |
| 252 | #:relative-symlinks? #t |
| 253 | #:hooks '() |
| 254 | #:locales? #f)) |
| 255 | (profile -> (derivation->output-path drv)) |
| 256 | (bindir -> (string-append profile "/bin")) |
| 257 | (_ (built-derivations (list drv)))) |
| 258 | (return (and (file-exists? (string-append bindir "/guile")) |
| 259 | (file-exists? (string-append bindir "/make")) |
| 260 | (string=? (readlink (string-append bindir "/guile")) |
| 261 | (string-append "../../" |
| 262 | (basename |
| 263 | (derivation->output-path guile)) |
| 264 | "/bin/guile")) |
| 265 | (string=? (readlink (string-append bindir "/make")) |
| 266 | (string-append "../../" |
| 267 | (basename |
| 268 | (derivation->output-path make)) |
| 269 | "/bin/make")))))) |
| 270 | |
| 271 | (test-assertm "profile-derivation, inputs" |
| 272 | (mlet* %store-monad |
| 273 | ((entry -> (package->manifest-entry packages:glibc "debug")) |
| 274 | (drv (profile-derivation (manifest (list entry)) |
| 275 | #:hooks '() |
| 276 | #:locales? #f))) |
| 277 | (return (derivation-inputs drv)))) |
| 278 | |
| 279 | (test-assertm "profile-derivation, cross-compilation" |
| 280 | (mlet* %store-monad |
| 281 | ((manifest -> (packages->manifest (list packages:sed packages:grep))) |
| 282 | (target -> "arm-linux-gnueabihf") |
| 283 | (grep (package->cross-derivation packages:grep target)) |
| 284 | (sed (package->cross-derivation packages:sed target)) |
| 285 | (locales (package->derivation packages:glibc-utf8-locales)) |
| 286 | (drv (profile-derivation manifest |
| 287 | #:hooks '() |
| 288 | #:locales? #t |
| 289 | #:target target))) |
| 290 | (define (find-input package) |
| 291 | (let ((name (string-append (package-full-name package "-") ".drv"))) |
| 292 | (any (lambda (input) |
| 293 | (let ((input (derivation-input-path input))) |
| 294 | (and (string-suffix? name input) input))) |
| 295 | (derivation-inputs drv)))) |
| 296 | |
| 297 | ;; The inputs for grep and sed should be cross-build derivations, but that |
| 298 | ;; for the glibc-utf8-locales should be a native build. |
| 299 | (return (and (string=? (derivation-system drv) (%current-system)) |
| 300 | (string=? (find-input packages:grep) |
| 301 | (derivation-file-name grep)) |
| 302 | (string=? (find-input packages:sed) |
| 303 | (derivation-file-name sed)) |
| 304 | (string=? (find-input packages:glibc-utf8-locales) |
| 305 | (derivation-file-name locales)))))) |
| 306 | |
| 307 | (test-assert "package->manifest-entry defaults to \"out\"" |
| 308 | (let ((outputs (package-outputs packages:glibc))) |
| 309 | (equal? (manifest-entry-output |
| 310 | (package->manifest-entry (package |
| 311 | (inherit packages:glibc) |
| 312 | (outputs (reverse outputs))))) |
| 313 | (manifest-entry-output |
| 314 | (package->manifest-entry packages:glibc)) |
| 315 | "out"))) |
| 316 | |
| 317 | (test-assertm "profile-manifest, search-paths" |
| 318 | (mlet* %store-monad |
| 319 | ((guile -> (package |
| 320 | (inherit %bootstrap-guile) |
| 321 | (native-search-paths |
| 322 | (package-native-search-paths packages:guile-2.0)))) |
| 323 | (entry -> (package->manifest-entry guile)) |
| 324 | (drv (profile-derivation (manifest (list entry)) |
| 325 | #:hooks '() |
| 326 | #:locales? #f)) |
| 327 | (profile -> (derivation->output-path drv))) |
| 328 | (mbegin %store-monad |
| 329 | (built-derivations (list drv)) |
| 330 | |
| 331 | ;; Read the manifest back and make sure search paths are preserved. |
| 332 | (let ((manifest (profile-manifest profile))) |
| 333 | (match (manifest-entries manifest) |
| 334 | ((result) |
| 335 | (return (equal? (manifest-entry-search-paths result) |
| 336 | (manifest-entry-search-paths entry) |
| 337 | (package-native-search-paths |
| 338 | packages:guile-2.0))))))))) |
| 339 | |
| 340 | (test-assert "package->manifest-entry, search paths" |
| 341 | ;; See <http://bugs.gnu.org/22073>. |
| 342 | (let ((mpl (@ (gnu packages python-xyz) python2-matplotlib))) |
| 343 | (lset= eq? |
| 344 | (package-transitive-native-search-paths mpl) |
| 345 | (manifest-entry-search-paths |
| 346 | (package->manifest-entry mpl))))) |
| 347 | |
| 348 | (test-equal "packages->manifest, propagated inputs" |
| 349 | (map (match-lambda |
| 350 | ((label package) |
| 351 | (list (package-name package) (package-version package) |
| 352 | package))) |
| 353 | (package-propagated-inputs packages:guile-2.2)) |
| 354 | (map (lambda (entry) |
| 355 | (list (manifest-entry-name entry) |
| 356 | (manifest-entry-version entry) |
| 357 | (manifest-entry-item entry))) |
| 358 | (manifest-entry-dependencies |
| 359 | (package->manifest-entry packages:guile-2.2)))) |
| 360 | |
| 361 | (test-assert "manifest-entry-parent" |
| 362 | (let ((entry (package->manifest-entry packages:guile-2.2))) |
| 363 | (match (manifest-entry-dependencies entry) |
| 364 | ((dependencies ..1) |
| 365 | (and (every (lambda (parent) |
| 366 | (eq? entry (force parent))) |
| 367 | (map manifest-entry-parent dependencies)) |
| 368 | (not (force (manifest-entry-parent entry)))))))) |
| 369 | |
| 370 | (test-assertm "read-manifest" |
| 371 | (mlet* %store-monad ((manifest -> (packages->manifest |
| 372 | (list (package |
| 373 | (inherit %bootstrap-guile) |
| 374 | (native-search-paths |
| 375 | (package-native-search-paths |
| 376 | packages:guile-2.0)))))) |
| 377 | (drv (profile-derivation manifest |
| 378 | #:hooks '() |
| 379 | #:locales? #f)) |
| 380 | (out -> (derivation->output-path drv))) |
| 381 | (define (entry->sexp entry) |
| 382 | (list (manifest-entry-name entry) |
| 383 | (manifest-entry-version entry) |
| 384 | (manifest-entry-search-paths entry) |
| 385 | (manifest-entry-dependencies entry) |
| 386 | (force (manifest-entry-parent entry)))) |
| 387 | |
| 388 | (mbegin %store-monad |
| 389 | (built-derivations (list drv)) |
| 390 | (let ((manifest2 (profile-manifest out))) |
| 391 | (return (equal? (map entry->sexp (manifest-entries manifest)) |
| 392 | (map entry->sexp (manifest-entries manifest2)))))))) |
| 393 | |
| 394 | (test-equal "collision" |
| 395 | '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42")) |
| 396 | (guard (c ((profile-collision-error? c) |
| 397 | (let ((entry1 (profile-collision-error-entry c)) |
| 398 | (entry2 (profile-collision-error-conflict c))) |
| 399 | (list (list (manifest-entry-name entry1) |
| 400 | (manifest-entry-version entry1)) |
| 401 | (list (manifest-entry-name entry2) |
| 402 | (manifest-entry-version entry2)))))) |
| 403 | (run-with-store %store |
| 404 | (mlet* %store-monad ((p0 -> (package |
| 405 | (inherit %bootstrap-guile) |
| 406 | (version "42"))) |
| 407 | (p1 -> (dummy-package "p1" |
| 408 | (propagated-inputs `(("p0" ,p0))))) |
| 409 | (manifest -> (packages->manifest |
| 410 | (list %bootstrap-guile p1))) |
| 411 | (drv (profile-derivation manifest |
| 412 | #:hooks '() |
| 413 | #:locales? #f))) |
| 414 | (return #f))))) |
| 415 | |
| 416 | (test-equal "collision of propagated inputs" |
| 417 | '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42")) |
| 418 | (guard (c ((profile-collision-error? c) |
| 419 | (let ((entry1 (profile-collision-error-entry c)) |
| 420 | (entry2 (profile-collision-error-conflict c))) |
| 421 | (list (list (manifest-entry-name entry1) |
| 422 | (manifest-entry-version entry1)) |
| 423 | (list (manifest-entry-name entry2) |
| 424 | (manifest-entry-version entry2)))))) |
| 425 | (run-with-store %store |
| 426 | (mlet* %store-monad ((p0 -> (package |
| 427 | (inherit %bootstrap-guile) |
| 428 | (version "42"))) |
| 429 | (p1 -> (dummy-package "p1" |
| 430 | (propagated-inputs |
| 431 | `(("guile" ,%bootstrap-guile))))) |
| 432 | (p2 -> (dummy-package "p2" |
| 433 | (propagated-inputs |
| 434 | `(("guile" ,p0))))) |
| 435 | (manifest -> (packages->manifest (list p1 p2))) |
| 436 | (drv (profile-derivation manifest |
| 437 | #:hooks '() |
| 438 | #:locales? #f))) |
| 439 | (return #f))))) |
| 440 | |
| 441 | (test-assertm "no collision" |
| 442 | ;; Here we have an entry that is "lowered" (its 'item' field is a store file |
| 443 | ;; name) and another entry (its 'item' field is a package) that is |
| 444 | ;; equivalent. |
| 445 | (mlet* %store-monad ((p -> (dummy-package "p" |
| 446 | (propagated-inputs |
| 447 | `(("guile" ,%bootstrap-guile))))) |
| 448 | (guile (package->derivation %bootstrap-guile)) |
| 449 | (entry -> (manifest-entry |
| 450 | (inherit (package->manifest-entry |
| 451 | %bootstrap-guile)) |
| 452 | (item (derivation->output-path guile)))) |
| 453 | (manifest -> (manifest |
| 454 | (list entry |
| 455 | (package->manifest-entry p)))) |
| 456 | (drv (profile-derivation manifest))) |
| 457 | (return (->bool drv)))) |
| 458 | |
| 459 | (test-assertm "etc/profile" |
| 460 | ;; Make sure we get an 'etc/profile' file that at least defines $PATH. |
| 461 | (mlet* %store-monad |
| 462 | ((guile -> (package |
| 463 | (inherit %bootstrap-guile) |
| 464 | (native-search-paths |
| 465 | (package-native-search-paths packages:guile-2.0)))) |
| 466 | (entry -> (package->manifest-entry guile)) |
| 467 | (drv (profile-derivation (manifest (list entry)) |
| 468 | #:hooks '() |
| 469 | #:locales? #f)) |
| 470 | (profile -> (derivation->output-path drv))) |
| 471 | (mbegin %store-monad |
| 472 | (built-derivations (list drv)) |
| 473 | (let* ((pipe (open-input-pipe |
| 474 | (string-append "unset GUIX_PROFILE; " |
| 475 | ;; 'source' is a Bashism; use '.' (dot). |
| 476 | ". " profile "/etc/profile; " |
| 477 | ;; Don't try to parse set(1) output because |
| 478 | ;; it differs among shells; just use echo. |
| 479 | "echo $PATH"))) |
| 480 | (path (get-string-all pipe))) |
| 481 | (return |
| 482 | (and (zero? (close-pipe pipe)) |
| 483 | (string-contains path (string-append profile "/bin")))))))) |
| 484 | |
| 485 | (test-assertm "etc/profile when etc/ already exists" |
| 486 | ;; Here 'union-build' makes the profile's etc/ a symlink to the package's |
| 487 | ;; etc/ directory, which makes it read-only. Make sure the profile build |
| 488 | ;; handles that. |
| 489 | (mlet* %store-monad |
| 490 | ((thing -> (dummy-package "dummy" |
| 491 | (build-system trivial-build-system) |
| 492 | (arguments |
| 493 | `(#:guile ,%bootstrap-guile |
| 494 | #:builder |
| 495 | (let ((out (assoc-ref %outputs "out"))) |
| 496 | (mkdir out) |
| 497 | (mkdir (string-append out "/etc")) |
| 498 | (call-with-output-file (string-append out "/etc/foo") |
| 499 | (lambda (port) |
| 500 | (display "foo!" port))) |
| 501 | #t))))) |
| 502 | (entry -> (package->manifest-entry thing)) |
| 503 | (drv (profile-derivation (manifest (list entry)) |
| 504 | #:hooks '() |
| 505 | #:locales? #f)) |
| 506 | (profile -> (derivation->output-path drv))) |
| 507 | (mbegin %store-monad |
| 508 | (built-derivations (list drv)) |
| 509 | (return (and (file-exists? (string-append profile "/etc/profile")) |
| 510 | (string=? (call-with-input-file |
| 511 | (string-append profile "/etc/foo") |
| 512 | get-string-all) |
| 513 | "foo!")))))) |
| 514 | |
| 515 | (test-assertm "etc/profile when etc/ is a symlink" |
| 516 | ;; When etc/ is a symlink, the unsymlink code in 0.8.2 would fail |
| 517 | ;; gracelessly because 'scandir' would return #f. |
| 518 | (mlet* %store-monad |
| 519 | ((thing -> (dummy-package "dummy" |
| 520 | (build-system trivial-build-system) |
| 521 | (arguments |
| 522 | `(#:guile ,%bootstrap-guile |
| 523 | #:builder |
| 524 | (let ((out (assoc-ref %outputs "out"))) |
| 525 | (mkdir out) |
| 526 | (mkdir (string-append out "/foo")) |
| 527 | (symlink "foo" (string-append out "/etc")) |
| 528 | (call-with-output-file (string-append out "/etc/bar") |
| 529 | (lambda (port) |
| 530 | (display "foo!" port))) |
| 531 | #t))))) |
| 532 | (entry -> (package->manifest-entry thing)) |
| 533 | (drv (profile-derivation (manifest (list entry)) |
| 534 | #:hooks '() |
| 535 | #:locales? #f)) |
| 536 | (profile -> (derivation->output-path drv))) |
| 537 | (mbegin %store-monad |
| 538 | (built-derivations (list drv)) |
| 539 | (return (and (file-exists? (string-append profile "/etc/profile")) |
| 540 | (string=? (call-with-input-file |
| 541 | (string-append profile "/etc/bar") |
| 542 | get-string-all) |
| 543 | "foo!")))))) |
| 544 | |
| 545 | (test-assertm "profile-derivation when etc/ is a relative symlink" |
| 546 | ;; See <https://bugs.gnu.org/32686>. |
| 547 | (mlet* %store-monad |
| 548 | ((etc (gexp->derivation |
| 549 | "etc" |
| 550 | #~(begin |
| 551 | (mkdir #$output) |
| 552 | (call-with-output-file (string-append #$output "/foo") |
| 553 | (lambda (port) |
| 554 | (display "Heya!" port)))))) |
| 555 | (thing -> (dummy-package "dummy" |
| 556 | (build-system trivial-build-system) |
| 557 | (inputs |
| 558 | `(("etc" ,etc))) |
| 559 | (arguments |
| 560 | `(#:guile ,%bootstrap-guile |
| 561 | #:builder |
| 562 | (let ((out (assoc-ref %outputs "out")) |
| 563 | (etc (assoc-ref %build-inputs "etc"))) |
| 564 | (mkdir out) |
| 565 | (symlink etc (string-append out "/etc")) |
| 566 | #t))))) |
| 567 | (entry -> (package->manifest-entry thing)) |
| 568 | (drv (profile-derivation (manifest (list entry)) |
| 569 | #:relative-symlinks? #t |
| 570 | #:hooks '() |
| 571 | #:locales? #f)) |
| 572 | (profile -> (derivation->output-path drv))) |
| 573 | (mbegin %store-monad |
| 574 | (built-derivations (list drv)) |
| 575 | (return (string=? (call-with-input-file |
| 576 | (string-append profile "/etc/foo") |
| 577 | get-string-all) |
| 578 | "Heya!"))))) |
| 579 | |
| 580 | (test-equalm "union vs. dangling symlink" ;<https://bugs.gnu.org/26949> |
| 581 | "does-not-exist" |
| 582 | (mlet* %store-monad |
| 583 | ((thing1 -> (dummy-package "dummy" |
| 584 | (build-system trivial-build-system) |
| 585 | (arguments |
| 586 | `(#:guile ,%bootstrap-guile |
| 587 | #:builder |
| 588 | (let ((out (assoc-ref %outputs "out"))) |
| 589 | (mkdir out) |
| 590 | (symlink "does-not-exist" |
| 591 | (string-append out "/dangling")) |
| 592 | #t))))) |
| 593 | (thing2 -> (package (inherit thing1) (name "dummy2"))) |
| 594 | (drv (profile-derivation (packages->manifest |
| 595 | (list thing1 thing2)) |
| 596 | #:hooks '() |
| 597 | #:locales? #f)) |
| 598 | (profile -> (derivation->output-path drv))) |
| 599 | (mbegin %store-monad |
| 600 | (built-derivations (list drv)) |
| 601 | (return (readlink (readlink (string-append profile "/dangling"))))))) |
| 602 | |
| 603 | (test-equalm "profile in profile" |
| 604 | '("foo" "0") |
| 605 | |
| 606 | ;; Make sure we can build a profile that has another profile has one of its |
| 607 | ;; entries. The new profile's /manifest and /etc/profile must override the |
| 608 | ;; other's. |
| 609 | (mlet* %store-monad |
| 610 | ((prof0 (profile-derivation |
| 611 | (manifest |
| 612 | (list (package->manifest-entry %bootstrap-guile))) |
| 613 | #:hooks '() |
| 614 | #:locales? #f)) |
| 615 | (prof1 (profile-derivation |
| 616 | (manifest (list (manifest-entry |
| 617 | (name "foo") |
| 618 | (version "0") |
| 619 | (item prof0)))) |
| 620 | #:hooks '() |
| 621 | #:locales? #f))) |
| 622 | (mbegin %store-monad |
| 623 | (built-derivations (list prof1)) |
| 624 | (let ((out (derivation->output-path prof1))) |
| 625 | (return (and (file-exists? |
| 626 | (string-append out "/bin/guile")) |
| 627 | (let ((manifest (profile-manifest out))) |
| 628 | (match (manifest-entries manifest) |
| 629 | ((entry) |
| 630 | (list (manifest-entry-name entry) |
| 631 | (manifest-entry-version entry))))))))))) |
| 632 | |
| 633 | (test-end "profiles") |
| 634 | |
| 635 | ;;; Local Variables: |
| 636 | ;;; eval: (put 'dummy-package 'scheme-indent-function 1) |
| 637 | ;;; End: |