| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2013, 2014, 2015, 2016, 2017 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 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-64)) |
| 39 | |
| 40 | ;; Test the (guix profiles) module. |
| 41 | |
| 42 | (define %store |
| 43 | (open-connection-for-tests)) |
| 44 | |
| 45 | ;; Globally disable grafts because they can trigger early builds. |
| 46 | (%graft? #f) |
| 47 | |
| 48 | (define-syntax-rule (test-assertm name exp) |
| 49 | (test-assert name |
| 50 | (run-with-store %store exp |
| 51 | #:guile-for-build (%guile-for-build)))) |
| 52 | |
| 53 | (define-syntax-rule (test-equalm name value exp) |
| 54 | (test-equal name |
| 55 | value |
| 56 | (run-with-store %store exp |
| 57 | #:guile-for-build (%guile-for-build)))) |
| 58 | |
| 59 | ;; Example manifest entries. |
| 60 | |
| 61 | (define guile-1.8.8 |
| 62 | (manifest-entry |
| 63 | (name "guile") |
| 64 | (version "1.8.8") |
| 65 | (item "/gnu/store/...") |
| 66 | (output "out"))) |
| 67 | |
| 68 | (define guile-2.0.9 |
| 69 | (manifest-entry |
| 70 | (name "guile") |
| 71 | (version "2.0.9") |
| 72 | (item "/gnu/store/...") |
| 73 | (output "out"))) |
| 74 | |
| 75 | (define guile-2.0.9:debug |
| 76 | (manifest-entry (inherit guile-2.0.9) |
| 77 | (output "debug"))) |
| 78 | |
| 79 | (define glibc |
| 80 | (manifest-entry |
| 81 | (name "glibc") |
| 82 | (version "2.19") |
| 83 | (item "/gnu/store/...") |
| 84 | (output "out"))) |
| 85 | |
| 86 | \f |
| 87 | (test-begin "profiles") |
| 88 | |
| 89 | (test-assert "manifest-installed?" |
| 90 | (let ((m (manifest (list guile-2.0.9 guile-2.0.9:debug)))) |
| 91 | (and (manifest-installed? m (manifest-pattern (name "guile"))) |
| 92 | (manifest-installed? m (manifest-pattern |
| 93 | (name "guile") (output "debug"))) |
| 94 | (manifest-installed? m (manifest-pattern |
| 95 | (name "guile") (output "out") |
| 96 | (version "2.0.9"))) |
| 97 | (not (manifest-installed? |
| 98 | m (manifest-pattern (name "guile") (version "1.8.8")))) |
| 99 | (not (manifest-installed? |
| 100 | m (manifest-pattern (name "guile") (output "foobar"))))))) |
| 101 | |
| 102 | (test-assert "manifest-matching-entries" |
| 103 | (let* ((e (list guile-2.0.9 guile-2.0.9:debug)) |
| 104 | (m (manifest e))) |
| 105 | (and (null? (manifest-matching-entries m |
| 106 | (list (manifest-pattern |
| 107 | (name "python"))))) |
| 108 | (equal? e |
| 109 | (manifest-matching-entries m |
| 110 | (list (manifest-pattern |
| 111 | (name "guile") |
| 112 | (output #f))))) |
| 113 | (equal? (list guile-2.0.9) |
| 114 | (manifest-matching-entries m |
| 115 | (list (manifest-pattern |
| 116 | (name "guile") |
| 117 | (version "2.0.9")))))))) |
| 118 | |
| 119 | (test-assert "manifest-remove" |
| 120 | (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug))) |
| 121 | (m1 (manifest-remove m0 |
| 122 | (list (manifest-pattern (name "guile"))))) |
| 123 | (m2 (manifest-remove m1 |
| 124 | (list (manifest-pattern (name "guile"))))) ; same |
| 125 | (m3 (manifest-remove m2 |
| 126 | (list (manifest-pattern |
| 127 | (name "guile") (output "debug"))))) |
| 128 | (m4 (manifest-remove m3 |
| 129 | (list (manifest-pattern (name "guile")))))) |
| 130 | (match (manifest-entries m2) |
| 131 | ((($ <manifest-entry> "guile" "2.0.9" "debug")) |
| 132 | (and (equal? m1 m2) |
| 133 | (null? (manifest-entries m3)) |
| 134 | (null? (manifest-entries m4))))))) |
| 135 | |
| 136 | (test-assert "manifest-add" |
| 137 | (let* ((m0 (manifest '())) |
| 138 | (m1 (manifest-add m0 (list guile-1.8.8))) |
| 139 | (m2 (manifest-add m1 (list guile-2.0.9))) |
| 140 | (m3 (manifest-add m2 (list guile-2.0.9:debug))) |
| 141 | (m4 (manifest-add m3 (list guile-2.0.9:debug)))) |
| 142 | (and (match (manifest-entries m1) |
| 143 | ((($ <manifest-entry> "guile" "1.8.8" "out")) #t) |
| 144 | (_ #f)) |
| 145 | (match (manifest-entries m2) |
| 146 | ((($ <manifest-entry> "guile" "2.0.9" "out")) #t) |
| 147 | (_ #f)) |
| 148 | (equal? m3 m4)))) |
| 149 | |
| 150 | (test-assert "manifest-perform-transaction" |
| 151 | (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug))) |
| 152 | (t1 (manifest-transaction |
| 153 | (install (list guile-1.8.8)) |
| 154 | (remove (list (manifest-pattern (name "guile") |
| 155 | (output "debug")))))) |
| 156 | (t2 (manifest-transaction |
| 157 | (remove (list (manifest-pattern (name "guile") |
| 158 | (version "2.0.9") |
| 159 | (output #f)))))) |
| 160 | (m1 (manifest-perform-transaction m0 t1)) |
| 161 | (m2 (manifest-perform-transaction m1 t2)) |
| 162 | (m3 (manifest-perform-transaction m0 t2))) |
| 163 | (and (match (manifest-entries m1) |
| 164 | ((($ <manifest-entry> "guile" "1.8.8" "out")) #t) |
| 165 | (_ #f)) |
| 166 | (equal? m1 m2) |
| 167 | (null? (manifest-entries m3))))) |
| 168 | |
| 169 | (test-assert "manifest-transaction-effects" |
| 170 | (let* ((m0 (manifest (list guile-1.8.8))) |
| 171 | (t (manifest-transaction |
| 172 | (install (list guile-2.0.9 glibc)) |
| 173 | (remove (list (manifest-pattern (name "coreutils"))))))) |
| 174 | (let-values (((remove install upgrade downgrade) |
| 175 | (manifest-transaction-effects m0 t))) |
| 176 | (and (null? remove) (null? downgrade) |
| 177 | (equal? (list glibc) install) |
| 178 | (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade))))) |
| 179 | |
| 180 | (test-assert "manifest-transaction-effects and downgrades" |
| 181 | (let* ((m0 (manifest (list guile-2.0.9))) |
| 182 | (t (manifest-transaction (install (list guile-1.8.8))))) |
| 183 | (let-values (((remove install upgrade downgrade) |
| 184 | (manifest-transaction-effects m0 t))) |
| 185 | (and (null? remove) (null? install) (null? upgrade) |
| 186 | (equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade))))) |
| 187 | |
| 188 | (test-assert "manifest-transaction-effects and pseudo-upgrades" |
| 189 | (let* ((m0 (manifest (list guile-2.0.9))) |
| 190 | (t (manifest-transaction (install (list guile-2.0.9))))) |
| 191 | (let-values (((remove install upgrade downgrade) |
| 192 | (manifest-transaction-effects m0 t))) |
| 193 | (and (null? remove) (null? install) (null? downgrade) |
| 194 | (equal? (list (cons guile-2.0.9 guile-2.0.9)) upgrade))))) |
| 195 | |
| 196 | (test-assert "manifest-transaction-null?" |
| 197 | (manifest-transaction-null? (manifest-transaction))) |
| 198 | |
| 199 | (test-assertm "profile-derivation" |
| 200 | (mlet* %store-monad |
| 201 | ((entry -> (package->manifest-entry %bootstrap-guile)) |
| 202 | (guile (package->derivation %bootstrap-guile)) |
| 203 | (drv (profile-derivation (manifest (list entry)) |
| 204 | #:hooks '() |
| 205 | #:locales? #f)) |
| 206 | (profile -> (derivation->output-path drv)) |
| 207 | (bindir -> (string-append profile "/bin")) |
| 208 | (_ (built-derivations (list drv)))) |
| 209 | (return (and (file-exists? (string-append bindir "/guile")) |
| 210 | (string=? (dirname (readlink bindir)) |
| 211 | (derivation->output-path guile)))))) |
| 212 | |
| 213 | (test-assertm "profile-derivation, inputs" |
| 214 | (mlet* %store-monad |
| 215 | ((entry -> (package->manifest-entry packages:glibc "debug")) |
| 216 | (drv (profile-derivation (manifest (list entry)) |
| 217 | #:hooks '() |
| 218 | #:locales? #f))) |
| 219 | (return (derivation-inputs drv)))) |
| 220 | |
| 221 | (test-assertm "profile-derivation, cross-compilation" |
| 222 | (mlet* %store-monad |
| 223 | ((manifest -> (packages->manifest (list packages:sed packages:grep))) |
| 224 | (target -> "arm-linux-gnueabihf") |
| 225 | (grep (package->cross-derivation packages:grep target)) |
| 226 | (sed (package->cross-derivation packages:sed target)) |
| 227 | (locales (package->derivation packages:glibc-utf8-locales)) |
| 228 | (drv (profile-derivation manifest |
| 229 | #:hooks '() |
| 230 | #:locales? #t |
| 231 | #:target target))) |
| 232 | (define (find-input name) |
| 233 | (let ((name (string-append name ".drv"))) |
| 234 | (any (lambda (input) |
| 235 | (let ((input (derivation-input-path input))) |
| 236 | (and (string-suffix? name input) input))) |
| 237 | (derivation-inputs drv)))) |
| 238 | |
| 239 | ;; The inputs for grep and sed should be cross-build derivations, but that |
| 240 | ;; for the glibc-utf8-locales should be a native build. |
| 241 | (return (and (string=? (derivation-system drv) (%current-system)) |
| 242 | (string=? (find-input (package-full-name packages:grep)) |
| 243 | (derivation-file-name grep)) |
| 244 | (string=? (find-input (package-full-name packages:sed)) |
| 245 | (derivation-file-name sed)) |
| 246 | (string=? (find-input |
| 247 | (package-full-name packages:glibc-utf8-locales)) |
| 248 | (derivation-file-name locales)))))) |
| 249 | |
| 250 | (test-assert "package->manifest-entry defaults to \"out\"" |
| 251 | (let ((outputs (package-outputs packages:glibc))) |
| 252 | (equal? (manifest-entry-output |
| 253 | (package->manifest-entry (package |
| 254 | (inherit packages:glibc) |
| 255 | (outputs (reverse outputs))))) |
| 256 | (manifest-entry-output |
| 257 | (package->manifest-entry packages:glibc)) |
| 258 | "out"))) |
| 259 | |
| 260 | (test-assertm "profile-manifest, search-paths" |
| 261 | (mlet* %store-monad |
| 262 | ((guile -> (package |
| 263 | (inherit %bootstrap-guile) |
| 264 | (native-search-paths |
| 265 | (package-native-search-paths packages:guile-2.0)))) |
| 266 | (entry -> (package->manifest-entry guile)) |
| 267 | (drv (profile-derivation (manifest (list entry)) |
| 268 | #:hooks '() |
| 269 | #:locales? #f)) |
| 270 | (profile -> (derivation->output-path drv))) |
| 271 | (mbegin %store-monad |
| 272 | (built-derivations (list drv)) |
| 273 | |
| 274 | ;; Read the manifest back and make sure search paths are preserved. |
| 275 | (let ((manifest (profile-manifest profile))) |
| 276 | (match (manifest-entries manifest) |
| 277 | ((result) |
| 278 | (return (equal? (manifest-entry-search-paths result) |
| 279 | (manifest-entry-search-paths entry) |
| 280 | (package-native-search-paths |
| 281 | packages:guile-2.0))))))))) |
| 282 | |
| 283 | (test-assert "package->manifest-entry, search paths" |
| 284 | ;; See <http://bugs.gnu.org/22073>. |
| 285 | (let ((mpl (@ (gnu packages python) python2-matplotlib))) |
| 286 | (lset= eq? |
| 287 | (package-transitive-native-search-paths mpl) |
| 288 | (manifest-entry-search-paths |
| 289 | (package->manifest-entry mpl))))) |
| 290 | |
| 291 | (test-assertm "etc/profile" |
| 292 | ;; Make sure we get an 'etc/profile' file that at least defines $PATH. |
| 293 | (mlet* %store-monad |
| 294 | ((guile -> (package |
| 295 | (inherit %bootstrap-guile) |
| 296 | (native-search-paths |
| 297 | (package-native-search-paths packages:guile-2.0)))) |
| 298 | (entry -> (package->manifest-entry guile)) |
| 299 | (drv (profile-derivation (manifest (list entry)) |
| 300 | #:hooks '() |
| 301 | #:locales? #f)) |
| 302 | (profile -> (derivation->output-path drv))) |
| 303 | (mbegin %store-monad |
| 304 | (built-derivations (list drv)) |
| 305 | (let* ((pipe (open-input-pipe |
| 306 | (string-append "unset GUIX_PROFILE; " |
| 307 | ;; 'source' is a Bashism; use '.' (dot). |
| 308 | ". " profile "/etc/profile; " |
| 309 | ;; Don't try to parse set(1) output because |
| 310 | ;; it differs among shells; just use echo. |
| 311 | "echo $PATH"))) |
| 312 | (path (get-string-all pipe))) |
| 313 | (return |
| 314 | (and (zero? (close-pipe pipe)) |
| 315 | (string-contains path (string-append profile "/bin")))))))) |
| 316 | |
| 317 | (test-assertm "etc/profile when etc/ already exists" |
| 318 | ;; Here 'union-build' makes the profile's etc/ a symlink to the package's |
| 319 | ;; etc/ directory, which makes it read-only. Make sure the profile build |
| 320 | ;; handles that. |
| 321 | (mlet* %store-monad |
| 322 | ((thing -> (dummy-package "dummy" |
| 323 | (build-system trivial-build-system) |
| 324 | (arguments |
| 325 | `(#:guile ,%bootstrap-guile |
| 326 | #:builder |
| 327 | (let ((out (assoc-ref %outputs "out"))) |
| 328 | (mkdir out) |
| 329 | (mkdir (string-append out "/etc")) |
| 330 | (call-with-output-file (string-append out "/etc/foo") |
| 331 | (lambda (port) |
| 332 | (display "foo!" port)))))))) |
| 333 | (entry -> (package->manifest-entry thing)) |
| 334 | (drv (profile-derivation (manifest (list entry)) |
| 335 | #:hooks '() |
| 336 | #:locales? #f)) |
| 337 | (profile -> (derivation->output-path drv))) |
| 338 | (mbegin %store-monad |
| 339 | (built-derivations (list drv)) |
| 340 | (return (and (file-exists? (string-append profile "/etc/profile")) |
| 341 | (string=? (call-with-input-file |
| 342 | (string-append profile "/etc/foo") |
| 343 | get-string-all) |
| 344 | "foo!")))))) |
| 345 | |
| 346 | (test-assertm "etc/profile when etc/ is a symlink" |
| 347 | ;; When etc/ is a symlink, the unsymlink code in 0.8.2 would fail |
| 348 | ;; gracelessly because 'scandir' would return #f. |
| 349 | (mlet* %store-monad |
| 350 | ((thing -> (dummy-package "dummy" |
| 351 | (build-system trivial-build-system) |
| 352 | (arguments |
| 353 | `(#:guile ,%bootstrap-guile |
| 354 | #:builder |
| 355 | (let ((out (assoc-ref %outputs "out"))) |
| 356 | (mkdir out) |
| 357 | (mkdir (string-append out "/foo")) |
| 358 | (symlink "foo" (string-append out "/etc")) |
| 359 | (call-with-output-file (string-append out "/etc/bar") |
| 360 | (lambda (port) |
| 361 | (display "foo!" port)))))))) |
| 362 | (entry -> (package->manifest-entry thing)) |
| 363 | (drv (profile-derivation (manifest (list entry)) |
| 364 | #:hooks '() |
| 365 | #:locales? #f)) |
| 366 | (profile -> (derivation->output-path drv))) |
| 367 | (mbegin %store-monad |
| 368 | (built-derivations (list drv)) |
| 369 | (return (and (file-exists? (string-append profile "/etc/profile")) |
| 370 | (string=? (call-with-input-file |
| 371 | (string-append profile "/etc/bar") |
| 372 | get-string-all) |
| 373 | "foo!")))))) |
| 374 | |
| 375 | (test-equalm "union vs. dangling symlink" ;<https://bugs.gnu.org/26949> |
| 376 | "does-not-exist" |
| 377 | (mlet* %store-monad |
| 378 | ((thing1 -> (dummy-package "dummy" |
| 379 | (build-system trivial-build-system) |
| 380 | (arguments |
| 381 | `(#:guile ,%bootstrap-guile |
| 382 | #:builder |
| 383 | (let ((out (assoc-ref %outputs "out"))) |
| 384 | (mkdir out) |
| 385 | (symlink "does-not-exist" |
| 386 | (string-append out "/dangling")) |
| 387 | #t))))) |
| 388 | (thing2 -> (package (inherit thing1) (name "dummy2"))) |
| 389 | (drv (profile-derivation (packages->manifest |
| 390 | (list thing1 thing2)) |
| 391 | #:hooks '() |
| 392 | #:locales? #f)) |
| 393 | (profile -> (derivation->output-path drv))) |
| 394 | (mbegin %store-monad |
| 395 | (built-derivations (list drv)) |
| 396 | (return (readlink (readlink (string-append profile "/dangling"))))))) |
| 397 | |
| 398 | (test-end "profiles") |
| 399 | |
| 400 | ;;; Local Variables: |
| 401 | ;;; eval: (put 'dummy-package 'scheme-indent-function 1) |
| 402 | ;;; End: |