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 (gnu packages bootstrap)
  28   #:use-module ((gnu packages base) #:prefix packages:)
  29   #:use-module (ice-9 match)
  30   #:use-module (ice-9 regex)
  31   #:use-module (srfi srfi-11)
  32   #:use-module (srfi srfi-64))
  33
  34 ;; Test the (guix profiles) module.
  35
  36 (define %store
  37   (open-connection-for-tests))
  38
  39 (define-syntax-rule (test-assertm name exp)
  40   (test-assert name
  41     (run-with-store %store exp
  42                     #:guile-for-build (%guile-for-build))))
  43
  44 ;; Example manifest entries.
  45
  46 (define guile-1.8.8
  47   (manifest-entry
  48     (name "guile")
  49     (version "1.8.8")
  50     (item "/gnu/store/...")
  51     (output "out")))
  52
  53 (define guile-2.0.9
  54   (manifest-entry
  55     (name "guile")
  56     (version "2.0.9")
  57     (item "/gnu/store/...")
  58     (output "out")))
  59
  60 (define guile-2.0.9:debug
  61   (manifest-entry (inherit guile-2.0.9)
  62     (output "debug")))
  63
  64 (define glibc
  65   (manifest-entry
  66     (name "glibc")
  67     (version "2.19")
  68     (item "/gnu/store/...")
  69     (output "out")))
  70
  71 \f
  72 (test-begin "profiles")
  73
  74 (test-assert "manifest-installed?"
  75   (let ((m (manifest (list guile-2.0.9 guile-2.0.9:debug))))
  76     (and (manifest-installed? m (manifest-pattern (name "guile")))
  77          (manifest-installed? m (manifest-pattern
  78                                   (name "guile") (output "debug")))
  79          (manifest-installed? m (manifest-pattern
  80                                   (name "guile") (output "out")
  81                                   (version "2.0.9")))
  82          (not (manifest-installed?
  83                m (manifest-pattern (name "guile") (version "1.8.8"))))
  84          (not (manifest-installed?
  85                m (manifest-pattern (name "guile") (output "foobar")))))))
  86
  87 (test-assert "manifest-matching-entries"
  88   (let* ((e (list guile-2.0.9 guile-2.0.9:debug))
  89          (m (manifest e)))
  90     (and (null? (manifest-matching-entries m
  91                                            (list (manifest-pattern
  92                                                    (name "python")))))
  93          (equal? e
  94                  (manifest-matching-entries m
  95                                             (list (manifest-pattern
  96                                                     (name "guile")
  97                                                     (output #f)))))
  98          (equal? (list guile-2.0.9)
  99                  (manifest-matching-entries m
 100                                             (list (manifest-pattern
 101                                                     (name "guile")
 102                                                     (version "2.0.9"))))))))
 103
 104 (test-assert "manifest-remove"
 105   (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
 106          (m1 (manifest-remove m0
 107                               (list (manifest-pattern (name "guile")))))
 108          (m2 (manifest-remove m1
 109                               (list (manifest-pattern (name "guile"))))) ; same
 110          (m3 (manifest-remove m2
 111                               (list (manifest-pattern
 112                                       (name "guile") (output "debug")))))
 113          (m4 (manifest-remove m3
 114                               (list (manifest-pattern (name "guile"))))))
 115     (match (manifest-entries m2)
 116       ((($ <manifest-entry> "guile" "2.0.9" "debug"))
 117        (and (equal? m1 m2)
 118             (null? (manifest-entries m3))
 119             (null? (manifest-entries m4)))))))
 120
 121 (test-assert "manifest-add"
 122   (let* ((m0 (manifest '()))
 123          (m1 (manifest-add m0 (list guile-1.8.8)))
 124          (m2 (manifest-add m1 (list guile-2.0.9)))
 125          (m3 (manifest-add m2 (list guile-2.0.9:debug)))
 126          (m4 (manifest-add m3 (list guile-2.0.9:debug))))
 127     (and (match (manifest-entries m1)
 128            ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
 129            (_ #f))
 130          (match (manifest-entries m2)
 131            ((($ <manifest-entry> "guile" "2.0.9" "out")) #t)
 132            (_ #f))
 133          (equal? m3 m4))))
 134
 135 (test-assert "manifest-perform-transaction"
 136   (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
 137          (t1 (manifest-transaction
 138               (install (list guile-1.8.8))
 139               (remove (list (manifest-pattern (name "guile")
 140                                               (output "debug"))))))
 141          (t2 (manifest-transaction
 142               (remove (list (manifest-pattern (name "guile")
 143                                               (version "2.0.9")
 144                                               (output #f))))))
 145          (m1 (manifest-perform-transaction m0 t1))
 146          (m2 (manifest-perform-transaction m1 t2))
 147          (m3 (manifest-perform-transaction m0 t2)))
 148     (and (match (manifest-entries m1)
 149            ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
 150            (_ #f))
 151          (equal? m1 m2)
 152          (null? (manifest-entries m3)))))
 153
 154 (test-assert "manifest-transaction-effects"
 155   (let* ((m0 (manifest (list guile-1.8.8)))
 156          (t  (manifest-transaction
 157               (install (list guile-2.0.9 glibc))
 158               (remove (list (manifest-pattern (name "coreutils")))))))
 159     (let-values (((remove install upgrade downgrade)
 160                   (manifest-transaction-effects m0 t)))
 161       (and (null? remove) (null? downgrade)
 162            (equal? (list glibc) install)
 163            (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
 164
 165 (test-assert "manifest-transaction-effects and downgrades"
 166   (let* ((m0 (manifest (list guile-2.0.9)))
 167          (t  (manifest-transaction (install (list guile-1.8.8)))))
 168     (let-values (((remove install upgrade downgrade)
 169                   (manifest-transaction-effects m0 t)))
 170       (and (null? remove) (null? install) (null? upgrade)
 171            (equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade)))))
 172
 173 (test-assert "manifest-transaction-effects and pseudo-upgrades"
 174   (let* ((m0 (manifest (list guile-2.0.9)))
 175          (t  (manifest-transaction (install (list guile-2.0.9)))))
 176     (let-values (((remove install upgrade downgrade)
 177                   (manifest-transaction-effects m0 t)))
 178       (and (null? remove) (null? install) (null? downgrade)
 179            (equal? (list (cons guile-2.0.9 guile-2.0.9)) upgrade)))))
 180
 181 (test-assertm "profile-derivation"
 182   (mlet* %store-monad
 183       ((entry ->   (package->manifest-entry %bootstrap-guile))
 184        (guile      (package->derivation %bootstrap-guile))
 185        (drv        (profile-derivation (manifest (list entry))
 186                                        #:info-dir? #f
 187                                        #:ca-certificate-bundle? #f))
 188        (profile -> (derivation->output-path drv))
 189        (bindir ->  (string-append profile "/bin"))
 190        (_          (built-derivations (list drv))))
 191     (return (and (file-exists? (string-append bindir "/guile"))
 192                  (string=? (dirname (readlink bindir))
 193                            (derivation->output-path guile))))))
 194
 195 (test-assertm "profile-derivation, inputs"
 196   (mlet* %store-monad
 197       ((entry ->   (package->manifest-entry packages:glibc "debug"))
 198        (drv        (profile-derivation (manifest (list entry))
 199                                        #:info-dir? #f
 200                                        #:ca-certificate-bundle? #f)))
 201     (return (derivation-inputs drv))))
 202
 203 (test-end "profiles")
 204
 205 \f
 206 (exit (= (test-runner-fail-count (test-runner-current)) 0))
 207
 208 ;;; Local Variables:
 209 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
 210 ;;; End: