tests/profiles.scm

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