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-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: