tests/packages.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19
  20 (define-module (test-packages)
  21   #:use-module (guix store)
  22   #:use-module (guix utils)
  23   #:use-module (guix derivations)
  24   #:use-module (guix packages)
  25   #:use-module (guix build-system trivial)
  26   #:use-module (guix build-system gnu)
  27   #:use-module (gnu packages)
  28   #:use-module (gnu packages base)
  29   #:use-module (gnu packages bootstrap)
  30   #:use-module (srfi srfi-11)
  31   #:use-module (srfi srfi-26)
  32   #:use-module (srfi srfi-64)
  33   #:use-module (rnrs io ports)
  34   #:use-module (ice-9 match))
  35
  36 ;; Test the high-level packaging layer.
  37
  38 (define %store
  39   (false-if-exception (open-connection)))
  40
  41 (when %store
  42   ;; Make sure we build everything by ourselves.
  43   (set-build-options %store #:use-substitutes? #f))
  44
  45 \f
  46 (test-begin "packages")
  47
  48 (define-syntax-rule (dummy-package name* extra-fields ...)
  49   (package (name name*) (version "0") (source #f)
  50            (build-system gnu-build-system)
  51            (synopsis #f) (description #f)
  52            (home-page #f) (license #f)
  53            extra-fields ...))
  54
  55 (test-assert "package-field-location"
  56   (let ()
  57     (define (goto port line column)
  58       (unless (and (= (port-column port) (- column 1))
  59                    (= (port-line port) (- line 1)))
  60         (unless (eof-object? (get-char port))
  61           (goto port line column))))
  62
  63     (define read-at
  64       (match-lambda
  65        (($ <location> file line column)
  66         (call-with-input-file (search-path %load-path file)
  67           (lambda (port)
  68             (goto port line column)
  69             (read port))))))
  70
  71     (and (equal? (read-at (package-field-location %bootstrap-guile 'name))
  72                  (package-name %bootstrap-guile))
  73          (equal? (read-at (package-field-location %bootstrap-guile 'version))
  74                  (package-version %bootstrap-guile))
  75          (not (package-field-location %bootstrap-guile 'does-not-exist)))))
  76
  77 (test-assert "package-transitive-inputs"
  78   (let* ((a (dummy-package "a"))
  79          (b (dummy-package "b"
  80               (propagated-inputs `(("a" ,a)))))
  81          (c (dummy-package "c"
  82               (inputs `(("a" ,a)))))
  83          (d (dummy-package "d"
  84               (propagated-inputs `(("x" "something.drv")))))
  85          (e (dummy-package "e"
  86               (inputs `(("b" ,b) ("c" ,c) ("d" ,d))))))
  87     (and (null? (package-transitive-inputs a))
  88          (equal? `(("a" ,a)) (package-transitive-inputs b))
  89          (equal? `(("a" ,a)) (package-transitive-inputs c))
  90          (equal? (package-propagated-inputs d)
  91                  (package-transitive-inputs d))
  92          (equal? `(("b" ,b) ("b/a" ,a) ("c" ,c)
  93                    ("d" ,d) ("d/x" "something.drv"))
  94                  (pk 'x (package-transitive-inputs e))))))
  95
  96 (test-skip (if (not %store) 4 0))
  97
  98 (test-assert "return values"
  99   (let-values (((drv-path drv)
 100                 (package-derivation %store (dummy-package "p"))))
 101     (and (derivation-path? drv-path)
 102          (derivation? drv))))
 103
 104 (test-assert "package-output"
 105   (let* ((package  (dummy-package "p"))
 106          (drv-path (package-derivation %store package)))
 107     (and (derivation-path? drv-path)
 108          (string=? (derivation-path->output-path drv-path)
 109                    (package-output %store package "out")))))
 110
 111 (test-assert "trivial"
 112   (let* ((p (package (inherit (dummy-package "trivial"))
 113               (build-system trivial-build-system)
 114               (source #f)
 115               (arguments
 116                `(#:guile ,%bootstrap-guile
 117                  #:builder
 118                  (begin
 119                    (mkdir %output)
 120                    (call-with-output-file (string-append %output "/test")
 121                      (lambda (p)
 122                        (display '(hello guix) p))))))))
 123          (d (package-derivation %store p)))
 124     (and (build-derivations %store (list d))
 125          (let ((p (pk 'drv d (derivation-path->output-path d))))
 126            (equal? '(hello guix)
 127                    (call-with-input-file (string-append p "/test") read))))))
 128
 129 (test-assert "trivial with local file as input"
 130   (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
 131          (p (package (inherit (dummy-package "trivial-with-input-file"))
 132               (build-system trivial-build-system)
 133               (source #f)
 134               (arguments
 135                `(#:guile ,%bootstrap-guile
 136                  #:builder (copy-file (assoc-ref %build-inputs "input")
 137                                       %output)))
 138               (inputs `(("input" ,i)))))
 139          (d (package-derivation %store p)))
 140     (and (build-derivations %store (list d))
 141          (let ((p (pk 'drv d (derivation-path->output-path d))))
 142            (equal? (call-with-input-file p get-bytevector-all)
 143                    (call-with-input-file i get-bytevector-all))))))
 144
 145 (test-assert "trivial with system-dependent input"
 146   (let* ((p (package (inherit (dummy-package "trivial-system-dependent-input"))
 147               (build-system trivial-build-system)
 148               (source #f)
 149               (arguments
 150                `(#:guile ,%bootstrap-guile
 151                  #:builder
 152                  (let ((out  (assoc-ref %outputs "out"))
 153                        (bash (assoc-ref %build-inputs "bash")))
 154                    (zero? (system* bash "-c"
 155                                    (format #f "echo hello > ~a" out))))))
 156               (inputs `(("bash" ,(search-bootstrap-binary "bash"
 157                                                           (%current-system)))))))
 158          (d (package-derivation %store p)))
 159     (and (build-derivations %store (list d))
 160          (let ((p (pk 'drv d (derivation-path->output-path d))))
 161            (eq? 'hello (call-with-input-file p read))))))
 162
 163 (unless (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))
 164   (test-skip 1))
 165 (test-assert "GNU Make, bootstrap"
 166   ;; GNU Make is the first program built during bootstrap; we choose it
 167   ;; here so that the test doesn't last for too long.
 168   (let ((gnu-make (@@ (gnu packages base) gnu-make-boot0)))
 169     (and (package? gnu-make)
 170          (or (location? (package-location gnu-make))
 171              (not (package-location gnu-make)))
 172          (let* ((drv (package-derivation %store gnu-make))
 173                 (out (derivation-path->output-path drv)))
 174            (and (build-derivations %store (list drv))
 175                 (file-exists? (string-append out "/bin/make")))))))
 176
 177 (test-eq "fold-packages" hello
 178   (fold-packages (lambda (p r)
 179                    (if (string=? (package-name p) "hello")
 180                        p
 181                        r))
 182                  #f))
 183
 184 (test-assert "find-packages-by-name"
 185   (match (find-packages-by-name "hello")
 186     (((? (cut eq? hello <>))) #t)
 187     (wrong (pk 'find-packages-by-name wrong #f))))
 188
 189 (test-assert "find-packages-by-name with version"
 190   (match (find-packages-by-name "hello" (package-version hello))
 191     (((? (cut eq? hello <>))) #t)
 192     (wrong (pk 'find-packages-by-name wrong #f))))
 193
 194 (test-end "packages")
 195
 196 \f
 197 (exit (= (test-runner-fail-count (test-runner-current)) 0))
 198
 199 ;;; Local Variables:
 200 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
 201 ;;; End: