tests/profiles.scm

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