tests/profiles.scm

   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>
   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-34)
  39   #:use-module (srfi srfi-64))
  40
  41 ;; Test the (guix profiles) module.
  42
  43 (define %store
  44   (open-connection-for-tests))
  45
  46 ;; Globally disable grafts because they can trigger early builds.
  47 (%graft? #f)
  48
  49 (define-syntax-rule (test-assertm name exp)
  50   (test-assert name
  51     (run-with-store %store exp
  52                     #:guile-for-build (%guile-for-build))))
  53
  54 (define-syntax-rule (test-equalm name value exp)
  55   (test-equal name
  56     value
  57     (run-with-store %store exp
  58                     #:guile-for-build (%guile-for-build))))
  59
  60 ;; Example manifest entries.
  61
  62 (define guile-1.8.8
  63   (manifest-entry
  64     (name "guile")
  65     (version "1.8.8")
  66     (item "/gnu/store/...")
  67     (output "out")))
  68
  69 (define guile-2.0.9
  70   (manifest-entry
  71     (name "guile")
  72     (version "2.0.9")
  73     (item "/gnu/store/...")
  74     (output "out")))
  75
  76 (define guile-2.0.9:debug
  77   (manifest-entry (inherit guile-2.0.9)
  78     (output "debug")))
  79
  80 (define glibc
  81   (manifest-entry
  82     (name "glibc")
  83     (version "2.19")
  84     (item "/gnu/store/...")
  85     (output "out")))
  86
  87 \f
  88 (test-begin "profiles")
  89
  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")
  97                                   (version "2.0.9")))
  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")))))))
 102
 103 (test-assert "manifest-matching-entries"
 104   (let* ((e (list guile-2.0.9 guile-2.0.9:debug))
 105          (m (manifest e)))
 106     (and (null? (manifest-matching-entries m
 107                                            (list (manifest-pattern
 108                                                    (name "python")))))
 109          (equal? e
 110                  (manifest-matching-entries m
 111                                             (list (manifest-pattern
 112                                                     (name "guile")
 113                                                     (output #f)))))
 114          (equal? (list guile-2.0.9)
 115                  (manifest-matching-entries m
 116                                             (list (manifest-pattern
 117                                                     (name "guile")
 118                                                     (version "2.0.9"))))))))
 119
 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"))
 133        (and (equal? m1 m2)
 134             (null? (manifest-entries m3))
 135             (null? (manifest-entries m4)))))))
 136
 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)
 145            (_ #f))
 146          (match (manifest-entries m2)
 147            ((($ <manifest-entry> "guile" "2.0.9" "out")) #t)
 148            (_ #f))
 149          (equal? m3 m4))))
 150
 151 (test-equal "manifest-add removes duplicates"    ;<https://bugs.gnu.org/30569>
 152   (list guile-2.0.9)
 153   (manifest-entries (manifest-add (manifest '())
 154                                   (list guile-2.0.9 guile-2.0.9))))
 155
 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")
 164                                               (version "2.0.9")
 165                                               (output #f))))))
 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)
 171            (_ #f))
 172          (equal? m1 m2)
 173          (null? (manifest-entries m3)))))
 174
 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)))))
 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, inputs"
 227   (mlet* %store-monad
 228       ((entry ->   (package->manifest-entry packages:glibc "debug"))
 229        (drv        (profile-derivation (manifest (list entry))
 230                                        #:hooks '()
 231                                        #:locales? #f)))
 232     (return (derivation-inputs drv))))
 233
 234 (test-assertm "profile-derivation, cross-compilation"
 235   (mlet* %store-monad
 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
 242                                         #:hooks '()
 243                                         #:locales? #t
 244                                         #:target target)))
 245     (define (find-input name)
 246       (let ((name (string-append name ".drv")))
 247         (any (lambda (input)
 248                (let ((input (derivation-input-path input)))
 249                  (and (string-suffix? name input) input)))
 250              (derivation-inputs drv))))
 251
 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 (package-full-name packages:grep))
 256                            (derivation-file-name grep))
 257                  (string=? (find-input (package-full-name packages:sed))
 258                            (derivation-file-name sed))
 259                  (string=? (find-input
 260                             (package-full-name packages:glibc-utf8-locales))
 261                            (derivation-file-name locales))))))
 262
 263 (test-assert "package->manifest-entry defaults to \"out\""
 264   (let ((outputs (package-outputs packages:glibc)))
 265     (equal? (manifest-entry-output
 266              (package->manifest-entry (package
 267                                         (inherit packages:glibc)
 268                                         (outputs (reverse outputs)))))
 269             (manifest-entry-output
 270              (package->manifest-entry packages:glibc))
 271             "out")))
 272
 273 (test-assertm "profile-manifest, search-paths"
 274   (mlet* %store-monad
 275       ((guile ->   (package
 276                      (inherit %bootstrap-guile)
 277                      (native-search-paths
 278                       (package-native-search-paths packages:guile-2.0))))
 279        (entry ->   (package->manifest-entry guile))
 280        (drv        (profile-derivation (manifest (list entry))
 281                                        #:hooks '()
 282                                        #:locales? #f))
 283        (profile -> (derivation->output-path drv)))
 284     (mbegin %store-monad
 285       (built-derivations (list drv))
 286
 287       ;; Read the manifest back and make sure search paths are preserved.
 288       (let ((manifest (profile-manifest profile)))
 289         (match (manifest-entries manifest)
 290           ((result)
 291            (return (equal? (manifest-entry-search-paths result)
 292                            (manifest-entry-search-paths entry)
 293                            (package-native-search-paths
 294                             packages:guile-2.0)))))))))
 295
 296 (test-assert "package->manifest-entry, search paths"
 297   ;; See <http://bugs.gnu.org/22073>.
 298   (let ((mpl (@ (gnu packages python) python2-matplotlib)))
 299     (lset= eq?
 300            (package-transitive-native-search-paths mpl)
 301            (manifest-entry-search-paths
 302             (package->manifest-entry mpl)))))
 303
 304 (test-equal "packages->manifest, propagated inputs"
 305   (map (match-lambda
 306          ((label package)
 307           (list (package-name package) (package-version package)
 308                 package)))
 309        (package-propagated-inputs packages:guile-2.2))
 310   (map (lambda (entry)
 311          (list (manifest-entry-name entry)
 312                (manifest-entry-version entry)
 313                (manifest-entry-item entry)))
 314        (manifest-entry-dependencies
 315         (package->manifest-entry packages:guile-2.2))))
 316
 317 (test-assert "manifest-entry-parent"
 318   (let ((entry (package->manifest-entry packages:guile-2.2)))
 319     (match (manifest-entry-dependencies entry)
 320       ((dependencies ..1)
 321        (and (every (lambda (parent)
 322                      (eq? entry (force parent)))
 323                    (map manifest-entry-parent dependencies))
 324             (not (force (manifest-entry-parent entry))))))))
 325
 326 (test-assertm "read-manifest"
 327   (mlet* %store-monad ((manifest -> (packages->manifest
 328                                      (list (package
 329                                              (inherit %bootstrap-guile)
 330                                              (native-search-paths
 331                                               (package-native-search-paths
 332                                                packages:guile-2.0))))))
 333                        (drv (profile-derivation manifest
 334                                                 #:hooks '()
 335                                                 #:locales? #f))
 336                        (out -> (derivation->output-path drv)))
 337     (define (entry->sexp entry)
 338       (list (manifest-entry-name entry)
 339             (manifest-entry-version entry)
 340             (manifest-entry-search-paths entry)
 341             (manifest-entry-dependencies entry)
 342             (force (manifest-entry-parent entry))))
 343
 344     (mbegin %store-monad
 345       (built-derivations (list drv))
 346       (let ((manifest2 (profile-manifest out)))
 347         (return (equal? (map entry->sexp (manifest-entries manifest))
 348                         (map entry->sexp (manifest-entries manifest2))))))))
 349
 350 (test-equal "collision"
 351   '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
 352   (guard (c ((profile-collision-error? c)
 353              (let ((entry1 (profile-collision-error-entry c))
 354                    (entry2 (profile-collision-error-conflict c)))
 355                (list (list (manifest-entry-name entry1)
 356                            (manifest-entry-version entry1))
 357                      (list (manifest-entry-name entry2)
 358                            (manifest-entry-version entry2))))))
 359     (run-with-store %store
 360       (mlet* %store-monad ((p0 -> (package
 361                                     (inherit %bootstrap-guile)
 362                                     (version "42")))
 363                            (p1 -> (dummy-package "p1"
 364                                     (propagated-inputs `(("p0" ,p0)))))
 365                            (manifest -> (packages->manifest
 366                                          (list %bootstrap-guile p1)))
 367                            (drv (profile-derivation manifest
 368                                                     #:hooks '()
 369                                                     #:locales? #f)))
 370         (return #f)))))
 371
 372 (test-equal "collision of propagated inputs"
 373   '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
 374   (guard (c ((profile-collision-error? c)
 375              (let ((entry1 (profile-collision-error-entry c))
 376                    (entry2 (profile-collision-error-conflict c)))
 377                (list (list (manifest-entry-name entry1)
 378                            (manifest-entry-version entry1))
 379                      (list (manifest-entry-name entry2)
 380                            (manifest-entry-version entry2))))))
 381     (run-with-store %store
 382       (mlet* %store-monad ((p0 -> (package
 383                                     (inherit %bootstrap-guile)
 384                                     (version "42")))
 385                            (p1 -> (dummy-package "p1"
 386                                     (propagated-inputs
 387                                      `(("guile" ,%bootstrap-guile)))))
 388                            (p2 -> (dummy-package "p2"
 389                                     (propagated-inputs
 390                                      `(("guile" ,p0)))))
 391                            (manifest -> (packages->manifest (list p1 p2)))
 392                            (drv (profile-derivation manifest
 393                                                     #:hooks '()
 394                                                     #:locales? #f)))
 395         (return #f)))))
 396
 397 (test-assertm "no collision"
 398   ;; Here we have an entry that is "lowered" (its 'item' field is a store file
 399   ;; name) and another entry (its 'item' field is a package) that is
 400   ;; equivalent.
 401   (mlet* %store-monad ((p -> (dummy-package "p"
 402                                (propagated-inputs
 403                                 `(("guile" ,%bootstrap-guile)))))
 404                        (guile    (package->derivation %bootstrap-guile))
 405                        (entry -> (manifest-entry
 406                                    (inherit (package->manifest-entry
 407                                              %bootstrap-guile))
 408                                    (item (derivation->output-path guile))))
 409                        (manifest -> (manifest
 410                                      (list entry
 411                                            (package->manifest-entry p))))
 412                        (drv (profile-derivation manifest)))
 413     (return (->bool drv))))
 414
 415 (test-assertm "etc/profile"
 416   ;; Make sure we get an 'etc/profile' file that at least defines $PATH.
 417   (mlet* %store-monad
 418       ((guile ->   (package
 419                      (inherit %bootstrap-guile)
 420                      (native-search-paths
 421                       (package-native-search-paths packages:guile-2.0))))
 422        (entry ->   (package->manifest-entry guile))
 423        (drv        (profile-derivation (manifest (list entry))
 424                                        #:hooks '()
 425                                        #:locales? #f))
 426        (profile -> (derivation->output-path drv)))
 427     (mbegin %store-monad
 428       (built-derivations (list drv))
 429       (let* ((pipe (open-input-pipe
 430                     (string-append "unset GUIX_PROFILE; "
 431                                    ;; 'source' is a Bashism; use '.' (dot).
 432                                    ". " profile "/etc/profile; "
 433                                    ;; Don't try to parse set(1) output because
 434                                    ;; it differs among shells; just use echo.
 435                                    "echo $PATH")))
 436              (path (get-string-all pipe)))
 437         (return
 438          (and (zero? (close-pipe pipe))
 439               (string-contains path (string-append profile "/bin"))))))))
 440
 441 (test-assertm "etc/profile when etc/ already exists"
 442   ;; Here 'union-build' makes the profile's etc/ a symlink to the package's
 443   ;; etc/ directory, which makes it read-only.  Make sure the profile build
 444   ;; handles that.
 445   (mlet* %store-monad
 446       ((thing ->   (dummy-package "dummy"
 447                      (build-system trivial-build-system)
 448                      (arguments
 449                       `(#:guile ,%bootstrap-guile
 450                         #:builder
 451                         (let ((out (assoc-ref %outputs "out")))
 452                           (mkdir out)
 453                           (mkdir (string-append out "/etc"))
 454                           (call-with-output-file (string-append out "/etc/foo")
 455                             (lambda (port)
 456                               (display "foo!" port)))
 457                           #t)))))
 458        (entry ->   (package->manifest-entry thing))
 459        (drv        (profile-derivation (manifest (list entry))
 460                                        #:hooks '()
 461                                        #:locales? #f))
 462        (profile -> (derivation->output-path drv)))
 463     (mbegin %store-monad
 464       (built-derivations (list drv))
 465       (return (and (file-exists? (string-append profile "/etc/profile"))
 466                    (string=? (call-with-input-file
 467                                  (string-append profile "/etc/foo")
 468                                get-string-all)
 469                              "foo!"))))))
 470
 471 (test-assertm "etc/profile when etc/ is a symlink"
 472   ;; When etc/ is a symlink, the unsymlink code in 0.8.2 would fail
 473   ;; gracelessly because 'scandir' would return #f.
 474   (mlet* %store-monad
 475       ((thing ->   (dummy-package "dummy"
 476                      (build-system trivial-build-system)
 477                      (arguments
 478                       `(#:guile ,%bootstrap-guile
 479                         #:builder
 480                         (let ((out (assoc-ref %outputs "out")))
 481                           (mkdir out)
 482                           (mkdir (string-append out "/foo"))
 483                           (symlink "foo" (string-append out "/etc"))
 484                           (call-with-output-file (string-append out "/etc/bar")
 485                             (lambda (port)
 486                               (display "foo!" port)))
 487                           #t)))))
 488        (entry ->   (package->manifest-entry thing))
 489        (drv        (profile-derivation (manifest (list entry))
 490                                        #:hooks '()
 491                                        #:locales? #f))
 492        (profile -> (derivation->output-path drv)))
 493     (mbegin %store-monad
 494       (built-derivations (list drv))
 495       (return (and (file-exists? (string-append profile "/etc/profile"))
 496                    (string=? (call-with-input-file
 497                                  (string-append profile "/etc/bar")
 498                                get-string-all)
 499                              "foo!"))))))
 500
 501 (test-equalm "union vs. dangling symlink"        ;<https://bugs.gnu.org/26949>
 502   "does-not-exist"
 503   (mlet* %store-monad
 504       ((thing1 ->  (dummy-package "dummy"
 505                      (build-system trivial-build-system)
 506                      (arguments
 507                       `(#:guile ,%bootstrap-guile
 508                         #:builder
 509                         (let ((out (assoc-ref %outputs "out")))
 510                           (mkdir out)
 511                           (symlink "does-not-exist"
 512                                    (string-append out "/dangling"))
 513                           #t)))))
 514        (thing2 ->  (package (inherit thing1) (name "dummy2")))
 515        (drv        (profile-derivation (packages->manifest
 516                                         (list thing1 thing2))
 517                                        #:hooks '()
 518                                        #:locales? #f))
 519        (profile -> (derivation->output-path drv)))
 520     (mbegin %store-monad
 521       (built-derivations (list drv))
 522       (return (readlink (readlink (string-append profile "/dangling")))))))
 523
 524 (test-end "profiles")
 525
 526 ;;; Local Variables:
 527 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
 528 ;;; End: