tests/profiles.scm

   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-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-assert "manifest-perform-transaction"
 152   (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
 153          (t1 (manifest-transaction
 154               (install (list guile-1.8.8))
 155               (remove (list (manifest-pattern (name "guile")
 156                                               (output "debug"))))))
 157          (t2 (manifest-transaction
 158               (remove (list (manifest-pattern (name "guile")
 159                                               (version "2.0.9")
 160                                               (output #f))))))
 161          (m1 (manifest-perform-transaction m0 t1))
 162          (m2 (manifest-perform-transaction m1 t2))
 163          (m3 (manifest-perform-transaction m0 t2)))
 164     (and (match (manifest-entries m1)
 165            ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
 166            (_ #f))
 167          (equal? m1 m2)
 168          (null? (manifest-entries m3)))))
 169
 170 (test-assert "manifest-transaction-effects"
 171   (let* ((m0 (manifest (list guile-1.8.8)))
 172          (t  (manifest-transaction
 173               (install (list guile-2.0.9 glibc))
 174               (remove (list (manifest-pattern (name "coreutils")))))))
 175     (let-values (((remove install upgrade downgrade)
 176                   (manifest-transaction-effects m0 t)))
 177       (and (null? remove) (null? downgrade)
 178            (equal? (list glibc) install)
 179            (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
 180
 181 (test-assert "manifest-transaction-effects and downgrades"
 182   (let* ((m0 (manifest (list guile-2.0.9)))
 183          (t  (manifest-transaction (install (list guile-1.8.8)))))
 184     (let-values (((remove install upgrade downgrade)
 185                   (manifest-transaction-effects m0 t)))
 186       (and (null? remove) (null? install) (null? upgrade)
 187            (equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade)))))
 188
 189 (test-assert "manifest-transaction-effects and pseudo-upgrades"
 190   (let* ((m0 (manifest (list guile-2.0.9)))
 191          (t  (manifest-transaction (install (list guile-2.0.9)))))
 192     (let-values (((remove install upgrade downgrade)
 193                   (manifest-transaction-effects m0 t)))
 194       (and (null? remove) (null? install) (null? downgrade)
 195            (equal? (list (cons guile-2.0.9 guile-2.0.9)) upgrade)))))
 196
 197 (test-assert "manifest-transaction-null?"
 198   (manifest-transaction-null? (manifest-transaction)))
 199
 200 (test-assert "manifest-transaction-removal-candidate?"
 201   (let ((m (manifest (list guile-2.0.9)))
 202         (t (manifest-transaction
 203             (remove (list (manifest-pattern (name "guile")))))))
 204     (and (manifest-transaction-removal-candidate? guile-2.0.9 t)
 205          (not (manifest-transaction-removal-candidate? glibc t)))))
 206
 207 (test-assertm "profile-derivation"
 208   (mlet* %store-monad
 209       ((entry ->   (package->manifest-entry %bootstrap-guile))
 210        (guile      (package->derivation %bootstrap-guile))
 211        (drv        (profile-derivation (manifest (list entry))
 212                                        #:hooks '()
 213                                        #:locales? #f))
 214        (profile -> (derivation->output-path drv))
 215        (bindir ->  (string-append profile "/bin"))
 216        (_          (built-derivations (list drv))))
 217     (return (and (file-exists? (string-append bindir "/guile"))
 218                  (string=? (dirname (readlink bindir))
 219                            (derivation->output-path guile))))))
 220
 221 (test-assertm "profile-derivation, inputs"
 222   (mlet* %store-monad
 223       ((entry ->   (package->manifest-entry packages:glibc "debug"))
 224        (drv        (profile-derivation (manifest (list entry))
 225                                        #:hooks '()
 226                                        #:locales? #f)))
 227     (return (derivation-inputs drv))))
 228
 229 (test-assertm "profile-derivation, cross-compilation"
 230   (mlet* %store-monad
 231       ((manifest -> (packages->manifest (list packages:sed packages:grep)))
 232        (target ->   "arm-linux-gnueabihf")
 233        (grep        (package->cross-derivation packages:grep target))
 234        (sed         (package->cross-derivation packages:sed target))
 235        (locales     (package->derivation packages:glibc-utf8-locales))
 236        (drv         (profile-derivation manifest
 237                                         #:hooks '()
 238                                         #:locales? #t
 239                                         #:target target)))
 240     (define (find-input name)
 241       (let ((name (string-append name ".drv")))
 242         (any (lambda (input)
 243                (let ((input (derivation-input-path input)))
 244                  (and (string-suffix? name input) input)))
 245              (derivation-inputs drv))))
 246
 247     ;; The inputs for grep and sed should be cross-build derivations, but that
 248     ;; for the glibc-utf8-locales should be a native build.
 249     (return (and (string=? (derivation-system drv) (%current-system))
 250                  (string=? (find-input (package-full-name packages:grep))
 251                            (derivation-file-name grep))
 252                  (string=? (find-input (package-full-name packages:sed))
 253                            (derivation-file-name sed))
 254                  (string=? (find-input
 255                             (package-full-name packages:glibc-utf8-locales))
 256                            (derivation-file-name locales))))))
 257
 258 (test-assert "package->manifest-entry defaults to \"out\""
 259   (let ((outputs (package-outputs packages:glibc)))
 260     (equal? (manifest-entry-output
 261              (package->manifest-entry (package
 262                                         (inherit packages:glibc)
 263                                         (outputs (reverse outputs)))))
 264             (manifest-entry-output
 265              (package->manifest-entry packages:glibc))
 266             "out")))
 267
 268 (test-assertm "profile-manifest, search-paths"
 269   (mlet* %store-monad
 270       ((guile ->   (package
 271                      (inherit %bootstrap-guile)
 272                      (native-search-paths
 273                       (package-native-search-paths packages:guile-2.0))))
 274        (entry ->   (package->manifest-entry guile))
 275        (drv        (profile-derivation (manifest (list entry))
 276                                        #:hooks '()
 277                                        #:locales? #f))
 278        (profile -> (derivation->output-path drv)))
 279     (mbegin %store-monad
 280       (built-derivations (list drv))
 281
 282       ;; Read the manifest back and make sure search paths are preserved.
 283       (let ((manifest (profile-manifest profile)))
 284         (match (manifest-entries manifest)
 285           ((result)
 286            (return (equal? (manifest-entry-search-paths result)
 287                            (manifest-entry-search-paths entry)
 288                            (package-native-search-paths
 289                             packages:guile-2.0)))))))))
 290
 291 (test-assert "package->manifest-entry, search paths"
 292   ;; See <http://bugs.gnu.org/22073>.
 293   (let ((mpl (@ (gnu packages python) python2-matplotlib)))
 294     (lset= eq?
 295            (package-transitive-native-search-paths mpl)
 296            (manifest-entry-search-paths
 297             (package->manifest-entry mpl)))))
 298
 299 (test-equal "packages->manifest, propagated inputs"
 300   (map (match-lambda
 301          ((label package)
 302           (list (package-name package) (package-version package)
 303                 package)))
 304        (package-propagated-inputs packages:guile-2.2))
 305   (map (lambda (entry)
 306          (list (manifest-entry-name entry)
 307                (manifest-entry-version entry)
 308                (manifest-entry-item entry)))
 309        (manifest-entry-dependencies
 310         (package->manifest-entry packages:guile-2.2))))
 311
 312 (test-assert "manifest-entry-parent"
 313   (let ((entry (package->manifest-entry packages:guile-2.2)))
 314     (match (manifest-entry-dependencies entry)
 315       ((dependencies ..1)
 316        (and (every (lambda (parent)
 317                      (eq? entry (force parent)))
 318                    (map manifest-entry-parent dependencies))
 319             (not (force (manifest-entry-parent entry))))))))
 320
 321 (test-assertm "read-manifest"
 322   (mlet* %store-monad ((manifest -> (packages->manifest
 323                                      (list (package
 324                                              (inherit %bootstrap-guile)
 325                                              (native-search-paths
 326                                               (package-native-search-paths
 327                                                packages:guile-2.0))))))
 328                        (drv (profile-derivation manifest
 329                                                 #:hooks '()
 330                                                 #:locales? #f))
 331                        (out -> (derivation->output-path drv)))
 332     (define (entry->sexp entry)
 333       (list (manifest-entry-name entry)
 334             (manifest-entry-version entry)
 335             (manifest-entry-search-paths entry)
 336             (manifest-entry-dependencies entry)
 337             (force (manifest-entry-parent entry))))
 338
 339     (mbegin %store-monad
 340       (built-derivations (list drv))
 341       (let ((manifest2 (profile-manifest out)))
 342         (return (equal? (map entry->sexp (manifest-entries manifest))
 343                         (map entry->sexp (manifest-entries manifest2))))))))
 344
 345 (test-equal "collision"
 346   '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
 347   (guard (c ((profile-collision-error? c)
 348              (let ((entry1 (profile-collision-error-entry c))
 349                    (entry2 (profile-collision-error-conflict c)))
 350                (list (list (manifest-entry-name entry1)
 351                            (manifest-entry-version entry1))
 352                      (list (manifest-entry-name entry2)
 353                            (manifest-entry-version entry2))))))
 354     (run-with-store %store
 355       (mlet* %store-monad ((p0 -> (package
 356                                     (inherit %bootstrap-guile)
 357                                     (version "42")))
 358                            (p1 -> (dummy-package "p1"
 359                                     (propagated-inputs `(("p0" ,p0)))))
 360                            (manifest -> (packages->manifest
 361                                          (list %bootstrap-guile p1)))
 362                            (drv (profile-derivation manifest
 363                                                     #:hooks '()
 364                                                     #:locales? #f)))
 365         (return #f)))))
 366
 367 (test-equal "collision of propagated inputs"
 368   '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
 369   (guard (c ((profile-collision-error? c)
 370              (let ((entry1 (profile-collision-error-entry c))
 371                    (entry2 (profile-collision-error-conflict c)))
 372                (list (list (manifest-entry-name entry1)
 373                            (manifest-entry-version entry1))
 374                      (list (manifest-entry-name entry2)
 375                            (manifest-entry-version entry2))))))
 376     (run-with-store %store
 377       (mlet* %store-monad ((p0 -> (package
 378                                     (inherit %bootstrap-guile)
 379                                     (version "42")))
 380                            (p1 -> (dummy-package "p1"
 381                                     (propagated-inputs
 382                                      `(("guile" ,%bootstrap-guile)))))
 383                            (p2 -> (dummy-package "p2"
 384                                     (propagated-inputs
 385                                      `(("guile" ,p0)))))
 386                            (manifest -> (packages->manifest (list p1 p2)))
 387                            (drv (profile-derivation manifest
 388                                                     #:hooks '()
 389                                                     #:locales? #f)))
 390         (return #f)))))
 391
 392 (test-assertm "no collision"
 393   ;; Here we have an entry that is "lowered" (its 'item' field is a store file
 394   ;; name) and another entry (its 'item' field is a package) that is
 395   ;; equivalent.
 396   (mlet* %store-monad ((p -> (dummy-package "p"
 397                                (propagated-inputs
 398                                 `(("guile" ,%bootstrap-guile)))))
 399                        (guile    (package->derivation %bootstrap-guile))
 400                        (entry -> (manifest-entry
 401                                    (inherit (package->manifest-entry
 402                                              %bootstrap-guile))
 403                                    (item (derivation->output-path guile))))
 404                        (manifest -> (manifest
 405                                      (list entry
 406                                            (package->manifest-entry p))))
 407                        (drv (profile-derivation manifest)))
 408     (return (->bool drv))))
 409
 410 (test-assertm "etc/profile"
 411   ;; Make sure we get an 'etc/profile' file that at least defines $PATH.
 412   (mlet* %store-monad
 413       ((guile ->   (package
 414                      (inherit %bootstrap-guile)
 415                      (native-search-paths
 416                       (package-native-search-paths packages:guile-2.0))))
 417        (entry ->   (package->manifest-entry guile))
 418        (drv        (profile-derivation (manifest (list entry))
 419                                        #:hooks '()
 420                                        #:locales? #f))
 421        (profile -> (derivation->output-path drv)))
 422     (mbegin %store-monad
 423       (built-derivations (list drv))
 424       (let* ((pipe (open-input-pipe
 425                     (string-append "unset GUIX_PROFILE; "
 426                                    ;; 'source' is a Bashism; use '.' (dot).
 427                                    ". " profile "/etc/profile; "
 428                                    ;; Don't try to parse set(1) output because
 429                                    ;; it differs among shells; just use echo.
 430                                    "echo $PATH")))
 431              (path (get-string-all pipe)))
 432         (return
 433          (and (zero? (close-pipe pipe))
 434               (string-contains path (string-append profile "/bin"))))))))
 435
 436 (test-assertm "etc/profile when etc/ already exists"
 437   ;; Here 'union-build' makes the profile's etc/ a symlink to the package's
 438   ;; etc/ directory, which makes it read-only.  Make sure the profile build
 439   ;; handles that.
 440   (mlet* %store-monad
 441       ((thing ->   (dummy-package "dummy"
 442                      (build-system trivial-build-system)
 443                      (arguments
 444                       `(#:guile ,%bootstrap-guile
 445                         #:builder
 446                         (let ((out (assoc-ref %outputs "out")))
 447                           (mkdir out)
 448                           (mkdir (string-append out "/etc"))
 449                           (call-with-output-file (string-append out "/etc/foo")
 450                             (lambda (port)
 451                               (display "foo!" port))))))))
 452        (entry ->   (package->manifest-entry thing))
 453        (drv        (profile-derivation (manifest (list entry))
 454                                        #:hooks '()
 455                                        #:locales? #f))
 456        (profile -> (derivation->output-path drv)))
 457     (mbegin %store-monad
 458       (built-derivations (list drv))
 459       (return (and (file-exists? (string-append profile "/etc/profile"))
 460                    (string=? (call-with-input-file
 461                                  (string-append profile "/etc/foo")
 462                                get-string-all)
 463                              "foo!"))))))
 464
 465 (test-assertm "etc/profile when etc/ is a symlink"
 466   ;; When etc/ is a symlink, the unsymlink code in 0.8.2 would fail
 467   ;; gracelessly because 'scandir' would return #f.
 468   (mlet* %store-monad
 469       ((thing ->   (dummy-package "dummy"
 470                      (build-system trivial-build-system)
 471                      (arguments
 472                       `(#:guile ,%bootstrap-guile
 473                         #:builder
 474                         (let ((out (assoc-ref %outputs "out")))
 475                           (mkdir out)
 476                           (mkdir (string-append out "/foo"))
 477                           (symlink "foo" (string-append out "/etc"))
 478                           (call-with-output-file (string-append out "/etc/bar")
 479                             (lambda (port)
 480                               (display "foo!" port))))))))
 481        (entry ->   (package->manifest-entry thing))
 482        (drv        (profile-derivation (manifest (list entry))
 483                                        #:hooks '()
 484                                        #:locales? #f))
 485        (profile -> (derivation->output-path drv)))
 486     (mbegin %store-monad
 487       (built-derivations (list drv))
 488       (return (and (file-exists? (string-append profile "/etc/profile"))
 489                    (string=? (call-with-input-file
 490                                  (string-append profile "/etc/bar")
 491                                get-string-all)
 492                              "foo!"))))))
 493
 494 (test-equalm "union vs. dangling symlink"        ;<https://bugs.gnu.org/26949>
 495   "does-not-exist"
 496   (mlet* %store-monad
 497       ((thing1 ->  (dummy-package "dummy"
 498                      (build-system trivial-build-system)
 499                      (arguments
 500                       `(#:guile ,%bootstrap-guile
 501                         #:builder
 502                         (let ((out (assoc-ref %outputs "out")))
 503                           (mkdir out)
 504                           (symlink "does-not-exist"
 505                                    (string-append out "/dangling"))
 506                           #t)))))
 507        (thing2 ->  (package (inherit thing1) (name "dummy2")))
 508        (drv        (profile-derivation (packages->manifest
 509                                         (list thing1 thing2))
 510                                        #:hooks '()
 511                                        #:locales? #f))
 512        (profile -> (derivation->output-path drv)))
 513     (mbegin %store-monad
 514       (built-derivations (list drv))
 515       (return (readlink (readlink (string-append profile "/dangling")))))))
 516
 517 (test-end "profiles")
 518
 519 ;;; Local Variables:
 520 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
 521 ;;; End: