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 hash)
  24   #:use-module (guix derivations)
  25   #:use-module (guix packages)
  26   #:use-module (guix build-system)
  27   #:use-module (guix build-system trivial)
  28   #:use-module (guix build-system gnu)
  29   #:use-module (gnu packages)
  30   #:use-module (gnu packages base)
  31   #:use-module (gnu packages bootstrap)
  32   #:use-module (srfi srfi-11)
  33   #:use-module (srfi srfi-26)
  34   #:use-module (srfi srfi-34)
  35   #:use-module (srfi srfi-64)
  36   #:use-module (rnrs io ports)
  37   #:use-module (ice-9 match))
  38
  39 ;; Test the high-level packaging layer.
  40
  41 (define %store
  42   (false-if-exception (open-connection)))
  43
  44 (when %store
  45   ;; Make sure we build everything by ourselves.
  46   (set-build-options %store #:use-substitutes? #f))
  47
  48 \f
  49 (test-begin "packages")
  50
  51 (define-syntax-rule (dummy-package name* extra-fields ...)
  52   (package (name name*) (version "0") (source #f)
  53            (build-system gnu-build-system)
  54            (synopsis #f) (description #f)
  55            (home-page #f) (license #f)
  56            extra-fields ...))
  57
  58 (test-assert "package-field-location"
  59   (let ()
  60     (define (goto port line column)
  61       (unless (and (= (port-column port) (- column 1))
  62                    (= (port-line port) (- line 1)))
  63         (unless (eof-object? (get-char port))
  64           (goto port line column))))
  65
  66     (define read-at
  67       (match-lambda
  68        (($ <location> file line column)
  69         (call-with-input-file (search-path %load-path file)
  70           (lambda (port)
  71             (goto port line column)
  72             (read port))))))
  73
  74     ;; Until Guile 2.0.6 included, source properties were added only to pairs.
  75     ;; Thus, check against both VALUE and (FIELD VALUE).
  76     (and (member (read-at (package-field-location %bootstrap-guile 'name))
  77                  (let ((name (package-name %bootstrap-guile)))
  78                    (list name `(name ,name))))
  79          (member (read-at (package-field-location %bootstrap-guile 'version))
  80                  (let ((version (package-version %bootstrap-guile)))
  81                    (list version `(version ,version))))
  82          (not (package-field-location %bootstrap-guile 'does-not-exist)))))
  83
  84 (test-assert "package-transitive-inputs"
  85   (let* ((a (dummy-package "a"))
  86          (b (dummy-package "b"
  87               (propagated-inputs `(("a" ,a)))))
  88          (c (dummy-package "c"
  89               (inputs `(("a" ,a)))))
  90          (d (dummy-package "d"
  91               (propagated-inputs `(("x" "something.drv")))))
  92          (e (dummy-package "e"
  93               (inputs `(("b" ,b) ("c" ,c) ("d" ,d))))))
  94     (and (null? (package-transitive-inputs a))
  95          (equal? `(("a" ,a)) (package-transitive-inputs b))
  96          (equal? `(("a" ,a)) (package-transitive-inputs c))
  97          (equal? (package-propagated-inputs d)
  98                  (package-transitive-inputs d))
  99          (equal? `(("b" ,b) ("b/a" ,a) ("c" ,c)
 100                    ("d" ,d) ("d/x" "something.drv"))
 101                  (pk 'x (package-transitive-inputs e))))))
 102
 103 (test-skip (if (not %store) 8 0))
 104
 105 (test-assert "package-source-derivation, file"
 106   (let* ((file    (search-path %load-path "guix.scm"))
 107          (package (package (inherit (dummy-package "p"))
 108                     (source file)))
 109          (source  (package-source-derivation %store
 110                                              (package-source package))))
 111     (and (store-path? source)
 112          (valid-path? %store source)
 113          (equal? (call-with-input-file source get-bytevector-all)
 114                  (call-with-input-file file get-bytevector-all)))))
 115
 116 (test-assert "package-source-derivation, store path"
 117   (let* ((file    (add-to-store %store "guix.scm" #t "sha256"
 118                                 (search-path %load-path "guix.scm")))
 119          (package (package (inherit (dummy-package "p"))
 120                     (source file)))
 121          (source  (package-source-derivation %store
 122                                              (package-source package))))
 123     (string=? file source)))
 124
 125 (test-equal "package-source-derivation, snippet"
 126   "OK"
 127   (let* ((file   (search-bootstrap-binary "guile-2.0.9.tar.xz"
 128                                           (%current-system)))
 129          (sha256 (call-with-input-file file port-sha256))
 130          (fetch  (lambda* (store url hash-algo hash
 131                            #:optional name #:key system)
 132                    (pk 'fetch url hash-algo hash name system)
 133                    (add-to-store store (basename url) #f "sha256" url)))
 134          (source (bootstrap-origin
 135                   (origin
 136                     (method fetch)
 137                     (uri file)
 138                     (sha256 sha256)
 139                     (patch-inputs
 140                      `(("tar" ,%bootstrap-coreutils&co)
 141                        ("xz" ,%bootstrap-coreutils&co)
 142                        ("patch" ,%bootstrap-coreutils&co)))
 143                     (patch-guile %bootstrap-guile)
 144                     (modules '((guix build utils)))
 145                     (imported-modules modules)
 146                     (snippet '(begin
 147                                 ;; We end up in 'bin', because it's the first
 148                                 ;; directory, alphabetically.  Not a very good
 149                                 ;; example but hey.
 150                                 (chmod "." #o777)
 151                                 (symlink "guile" "guile-rocks")
 152                                 (copy-recursively "../share/guile/2.0/scripts"
 153                                                   "scripts")
 154
 155                                 ;; These variables must exist.
 156                                 (pk %build-inputs %outputs))))))
 157          (package (package (inherit (dummy-package "with-snippet"))
 158                     (source source)
 159                     (build-system trivial-build-system)
 160                     (inputs
 161                      `(("tar" ,(search-bootstrap-binary "tar"
 162                                                         (%current-system)))
 163                        ("xz"  ,(search-bootstrap-binary "xz"
 164                                                         (%current-system)))))
 165                     (arguments
 166                      `(#:guile ,%bootstrap-guile
 167                        #:builder
 168                        (let ((tar    (assoc-ref %build-inputs "tar"))
 169                              (xz     (assoc-ref %build-inputs "xz"))
 170                              (source (assoc-ref %build-inputs "source")))
 171                          (and (zero? (system* tar "xvf" source
 172                                               "--use-compress-program" xz))
 173                               (string=? "guile" (readlink "bin/guile-rocks"))
 174                               (file-exists? "bin/scripts/compile.scm")
 175                               (let ((out (assoc-ref %outputs "out")))
 176                                 (call-with-output-file out
 177                                   (lambda (p)
 178                                     (display "OK" p))))))))))
 179          (drv    (package-derivation %store package))
 180          (out    (derivation->output-path drv)))
 181     (and (build-derivations %store (list (pk 'snippet-drv drv)))
 182          (call-with-input-file out get-string-all))))
 183
 184 (test-assert "return value"
 185   (let ((drv (package-derivation %store (dummy-package "p"))))
 186     (and (derivation? drv)
 187          (file-exists? (derivation-file-name drv)))))
 188
 189 (test-assert "package-output"
 190   (let* ((package  (dummy-package "p"))
 191          (drv      (package-derivation %store package)))
 192     (and (derivation? drv)
 193          (string=? (derivation->output-path drv)
 194                    (package-output %store package "out")))))
 195
 196 (test-assert "trivial"
 197   (let* ((p (package (inherit (dummy-package "trivial"))
 198               (build-system trivial-build-system)
 199               (source #f)
 200               (arguments
 201                `(#:guile ,%bootstrap-guile
 202                  #:builder
 203                  (begin
 204                    (mkdir %output)
 205                    (call-with-output-file (string-append %output "/test")
 206                      (lambda (p)
 207                        (display '(hello guix) p))))))))
 208          (d (package-derivation %store p)))
 209     (and (build-derivations %store (list d))
 210          (let ((p (pk 'drv d (derivation->output-path d))))
 211            (equal? '(hello guix)
 212                    (call-with-input-file (string-append p "/test") read))))))
 213
 214 (test-assert "trivial with local file as input"
 215   (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
 216          (p (package (inherit (dummy-package "trivial-with-input-file"))
 217               (build-system trivial-build-system)
 218               (source #f)
 219               (arguments
 220                `(#:guile ,%bootstrap-guile
 221                  #:builder (copy-file (assoc-ref %build-inputs "input")
 222                                       %output)))
 223               (inputs `(("input" ,i)))))
 224          (d (package-derivation %store p)))
 225     (and (build-derivations %store (list d))
 226          (let ((p (pk 'drv d (derivation->output-path d))))
 227            (equal? (call-with-input-file p get-bytevector-all)
 228                    (call-with-input-file i get-bytevector-all))))))
 229
 230 (test-assert "trivial with source"
 231   (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
 232          (p (package (inherit (dummy-package "trivial-with-source"))
 233               (build-system trivial-build-system)
 234               (source i)
 235               (arguments
 236                `(#:guile ,%bootstrap-guile
 237                  #:builder (copy-file (assoc-ref %build-inputs "source")
 238                                       %output)))))
 239          (d (package-derivation %store p)))
 240     (and (build-derivations %store (list d))
 241          (let ((p (derivation->output-path d)))
 242            (equal? (call-with-input-file p get-bytevector-all)
 243                    (call-with-input-file i get-bytevector-all))))))
 244
 245 (test-assert "trivial with system-dependent input"
 246   (let* ((p (package (inherit (dummy-package "trivial-system-dependent-input"))
 247               (build-system trivial-build-system)
 248               (source #f)
 249               (arguments
 250                `(#:guile ,%bootstrap-guile
 251                  #:builder
 252                  (let ((out  (assoc-ref %outputs "out"))
 253                        (bash (assoc-ref %build-inputs "bash")))
 254                    (zero? (system* bash "-c"
 255                                    (format #f "echo hello > ~a" out))))))
 256               (inputs `(("bash" ,(search-bootstrap-binary "bash"
 257                                                           (%current-system)))))))
 258          (d (package-derivation %store p)))
 259     (and (build-derivations %store (list d))
 260          (let ((p (pk 'drv d (derivation->output-path d))))
 261            (eq? 'hello (call-with-input-file p read))))))
 262
 263 (test-assert "search paths"
 264   (let* ((p (make-prompt-tag "return-search-paths"))
 265          (s (build-system
 266              (name "raw")
 267              (description "Raw build system with direct store access")
 268              (build (lambda* (store name source inputs
 269                                     #:key outputs system search-paths)
 270                       search-paths))))
 271          (x (list (search-path-specification
 272                    (variable "GUILE_LOAD_PATH")
 273                    (directories '("share/guile/site/2.0")))
 274                   (search-path-specification
 275                    (variable "GUILE_LOAD_COMPILED_PATH")
 276                    (directories '("share/guile/site/2.0")))))
 277          (a (package (inherit (dummy-package "guile"))
 278               (build-system s)
 279               (native-search-paths x)))
 280          (b (package (inherit (dummy-package "guile-foo"))
 281               (build-system s)
 282               (inputs `(("guile" ,a)))))
 283          (c (package (inherit (dummy-package "guile-bar"))
 284               (build-system s)
 285               (inputs `(("guile" ,a)
 286                         ("guile-foo" ,b))))))
 287     (let-syntax ((collect (syntax-rules ()
 288                             ((_ body ...)
 289                              (call-with-prompt p
 290                                (lambda ()
 291                                  body ...)
 292                                (lambda (k search-paths)
 293                                  search-paths))))))
 294       (and (null? (collect (package-derivation %store a)))
 295            (equal? x (collect (package-derivation %store b)))
 296            (equal? x (collect (package-derivation %store c)))))))
 297
 298 (test-assert "package-cross-derivation"
 299   (let ((drv (package-cross-derivation %store (dummy-package "p")
 300                                        "mips64el-linux-gnu")))
 301     (and (derivation? drv)
 302          (file-exists? (derivation-file-name drv)))))
 303
 304 (test-assert "package-cross-derivation, trivial-build-system"
 305   (let ((p (package (inherit (dummy-package "p"))
 306              (build-system trivial-build-system)
 307              (arguments '(#:builder (exit 1))))))
 308     (let ((drv (package-cross-derivation %store p "mips64el-linux-gnu")))
 309       (derivation? drv))))
 310
 311 (test-assert "package-cross-derivation, no cross builder"
 312   (let* ((b (build-system (inherit trivial-build-system)
 313               (cross-build #f)))
 314          (p (package (inherit (dummy-package "p"))
 315               (build-system b))))
 316     (guard (c ((package-cross-build-system-error? c)
 317                (eq? (package-error-package c) p)))
 318       (package-cross-derivation %store p "mips64el-linux-gnu")
 319       #f)))
 320
 321 (unless (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))
 322   (test-skip 1))
 323 (test-assert "GNU Make, bootstrap"
 324   ;; GNU Make is the first program built during bootstrap; we choose it
 325   ;; here so that the test doesn't last for too long.
 326   (let ((gnu-make (@@ (gnu packages base) gnu-make-boot0)))
 327     (and (package? gnu-make)
 328          (or (location? (package-location gnu-make))
 329              (not (package-location gnu-make)))
 330          (let* ((drv (package-derivation %store gnu-make))
 331                 (out (derivation->output-path drv)))
 332            (and (build-derivations %store (list drv))
 333                 (file-exists? (string-append out "/bin/make")))))))
 334
 335 (test-eq "fold-packages" hello
 336   (fold-packages (lambda (p r)
 337                    (if (string=? (package-name p) "hello")
 338                        p
 339                        r))
 340                  #f))
 341
 342 (test-assert "find-packages-by-name"
 343   (match (find-packages-by-name "hello")
 344     (((? (cut eq? hello <>))) #t)
 345     (wrong (pk 'find-packages-by-name wrong #f))))
 346
 347 (test-assert "find-packages-by-name with version"
 348   (match (find-packages-by-name "hello" (package-version hello))
 349     (((? (cut eq? hello <>))) #t)
 350     (wrong (pk 'find-packages-by-name wrong #f))))
 351
 352 (test-end "packages")
 353
 354 \f
 355 (exit (= (test-runner-fail-count (test-runner-current)) 0))
 356
 357 ;;; Local Variables:
 358 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
 359 ;;; End: