tests/derivations.scm

   1 ;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
   2 ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of Guix.
   5 ;;;
   6 ;;; 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 ;;; 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 Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19
  20 (define-module (test-derivations)
  21   #:use-module (guix derivations)
  22   #:use-module (guix store)
  23   #:use-module (guix utils)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-11)
  26   #:use-module (srfi srfi-26)
  27   #:use-module (srfi srfi-34)
  28   #:use-module (srfi srfi-64)
  29   #:use-module (rnrs io ports)
  30   #:use-module (rnrs bytevectors)
  31   #:use-module (ice-9 rdelim)
  32   #:use-module (ice-9 ftw)
  33   #:use-module (ice-9 match))
  34
  35 (define %store
  36   (false-if-exception (open-connection)))
  37
  38 (define (directory-contents dir)
  39   "Return an alist representing the contents of DIR."
  40   (define prefix-len (string-length dir))
  41   (sort (file-system-fold (const #t)                   ; enter?
  42                           (lambda (path stat result)   ; leaf
  43                             (alist-cons (string-drop path prefix-len)
  44                                         (call-with-input-file path
  45                                           get-bytevector-all)
  46                                         result))
  47                           (lambda (path stat result) result)      ; down
  48                           (lambda (path stat result) result)      ; up
  49                           (lambda (path stat result) result)      ; skip
  50                           (lambda (path stat errno result) result) ; error
  51                           '()
  52                           dir)
  53         (lambda (e1 e2)
  54           (string<? (car e1) (car e2)))))
  55
  56 (test-begin "derivations")
  57
  58 (test-assert "parse & export"
  59   (let* ((f  (search-path %load-path "tests/test.drv"))
  60          (b1 (call-with-input-file f get-bytevector-all))
  61          (d1 (read-derivation (open-bytevector-input-port b1)))
  62          (b2 (call-with-bytevector-output-port (cut write-derivation d1 <>)))
  63          (d2 (read-derivation (open-bytevector-input-port b2))))
  64     (and (equal? b1 b2)
  65          (equal? d1 d2))))
  66
  67 (test-skip (if %store 0 4))
  68
  69 (test-assert "add-to-store, flat"
  70   (let* ((file (search-path %load-path "language/tree-il/spec.scm"))
  71          (drv  (add-to-store %store "flat-test" #t #f "sha256" file)))
  72     (and (eq? 'regular (stat:type (stat drv)))
  73          (equal? (call-with-input-file file get-bytevector-all)
  74                  (call-with-input-file drv get-bytevector-all)))))
  75
  76 (test-assert "add-to-store, recursive"
  77   (let* ((dir (dirname (search-path %load-path "language/tree-il/spec.scm")))
  78          (drv (add-to-store %store "dir-tree-test" #t #t "sha256" dir)))
  79     (and (eq? 'directory (stat:type (stat drv)))
  80          (equal? (directory-contents dir)
  81                  (directory-contents drv)))))
  82
  83 (test-assert "derivation with no inputs"
  84   (let ((builder (add-text-to-store %store "my-builder.sh"
  85                                     "#!/bin/sh\necho hello, world\n"
  86                                     '())))
  87     (store-path? (derivation %store "foo" (%current-system) builder
  88                              '() '(("HOME" . "/homeless")) '()))))
  89
  90 (test-assert "build derivation with 1 source"
  91   (let*-values (((builder)
  92                  (add-text-to-store %store "my-builder.sh"
  93                                     "echo hello, world > \"$out\"\n"
  94                                     '()))
  95                 ((drv-path drv)
  96                  (derivation %store "foo" (%current-system)
  97                              "/bin/sh" `(,builder)
  98                              '(("HOME" . "/homeless")
  99                                ("zzz"  . "Z!")
 100                                ("AAA"  . "A!"))
 101                              `((,builder))))
 102                 ((succeeded?)
 103                  (build-derivations %store (list drv-path))))
 104     (and succeeded?
 105          (let ((path (derivation-output-path
 106                       (assoc-ref (derivation-outputs drv) "out"))))
 107            (string=? (call-with-input-file path read-line)
 108                      "hello, world")))))
 109
 110 (test-assert "fixed-output derivation"
 111   (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
 112                                         "echo -n hello > $out" '()))
 113          (hash       (sha256 (string->utf8 "hello")))
 114          (drv-path   (derivation %store "fixed" (%current-system)
 115                                  "/bin/sh" `(,builder)
 116                                  '() `((,builder))
 117                                  #:hash hash #:hash-algo 'sha256))
 118          (succeeded? (build-derivations %store (list drv-path))))
 119     (and succeeded?
 120          (let ((p (derivation-path->output-path drv-path)))
 121            (equal? (string->utf8 "hello")
 122                    (call-with-input-file p get-bytevector-all))))))
 123
 124 (test-assert "multiple-output derivation"
 125   (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
 126                                         "echo one > $out ; echo two > $second"
 127                                         '()))
 128          (drv-path   (derivation %store "fixed" (%current-system)
 129                                  "/bin/sh" `(,builder)
 130                                  '(("HOME" . "/homeless")
 131                                    ("zzz"  . "Z!")
 132                                    ("AAA"  . "A!"))
 133                                  `((,builder))
 134                                  #:outputs '("out" "second")))
 135          (succeeded? (build-derivations %store (list drv-path))))
 136     (and succeeded?
 137          (let ((one (derivation-path->output-path drv-path "out"))
 138                (two (derivation-path->output-path drv-path "second")))
 139            (and (eq? 'one (call-with-input-file one read))
 140                 (eq? 'two (call-with-input-file two read)))))))
 141
 142 \f
 143 (define %coreutils
 144   (false-if-exception (nixpkgs-derivation "coreutils")))
 145
 146 (test-skip (if %coreutils 0 1))
 147
 148 (test-assert "build derivation with coreutils"
 149   (let* ((builder
 150           (add-text-to-store %store "build-with-coreutils.sh"
 151                              "echo $PATH ; mkdir --version ; mkdir $out ; touch $out/good"
 152                              '()))
 153          (drv-path
 154           (derivation %store "foo" (%current-system)
 155                       "/bin/sh" `(,builder)
 156                       `(("PATH" .
 157                          ,(string-append
 158                            (derivation-path->output-path %coreutils)
 159                            "/bin")))
 160                       `((,builder)
 161                         (,%coreutils))))
 162          (succeeded?
 163           (build-derivations %store (list drv-path))))
 164     (and succeeded?
 165          (let ((p (derivation-path->output-path drv-path)))
 166            (file-exists? (string-append p "/good"))))))
 167
 168 (test-skip (if (%guile-for-build) 0 4))
 169
 170 (test-assert "build-expression->derivation without inputs"
 171   (let* ((builder    '(begin
 172                         (mkdir %output)
 173                         (call-with-output-file (string-append %output "/test")
 174                           (lambda (p)
 175                             (display '(hello guix) p)))))
 176          (drv-path   (build-expression->derivation %store "goo" (%current-system)
 177                                                    builder '()))
 178          (succeeded? (build-derivations %store (list drv-path))))
 179     (and succeeded?
 180          (let ((p (derivation-path->output-path drv-path)))
 181            (equal? '(hello guix)
 182                    (call-with-input-file (string-append p "/test") read))))))
 183
 184 (test-assert "build-expression->derivation with two outputs"
 185   (let* ((builder    '(begin
 186                         (call-with-output-file (assoc-ref %outputs "out")
 187                           (lambda (p)
 188                             (display '(hello) p)))
 189                         (call-with-output-file (assoc-ref %outputs "second")
 190                           (lambda (p)
 191                             (display '(world) p)))))
 192          (drv-path   (build-expression->derivation %store "double"
 193                                                    (%current-system)
 194                                                    builder '()
 195                                                    #:outputs '("out"
 196                                                                "second")))
 197          (succeeded? (build-derivations %store (list drv-path))))
 198     (and succeeded?
 199          (let ((one (derivation-path->output-path drv-path))
 200                (two (derivation-path->output-path drv-path "second")))
 201            (and (equal? '(hello) (call-with-input-file one read))
 202                 (equal? '(world) (call-with-input-file two read)))))))
 203
 204 (test-assert "build-expression->derivation with one input"
 205   (let* ((builder    '(call-with-output-file %output
 206                         (lambda (p)
 207                           (let ((cu (assoc-ref %build-inputs "cu")))
 208                             (close 1)
 209                             (dup2 (port->fdes p) 1)
 210                             (execl (string-append cu "/bin/uname")
 211                                    "uname" "-a")))))
 212          (drv-path   (build-expression->derivation %store "uname" (%current-system)
 213                                                    builder
 214                                                    `(("cu" . ,%coreutils))))
 215          (succeeded? (build-derivations %store (list drv-path))))
 216     (and succeeded?
 217          (let ((p (derivation-path->output-path drv-path)))
 218            (string-contains (call-with-input-file p read-line) "GNU")))))
 219
 220 (test-assert "imported-files"
 221   (let* ((files    `(("x"     . ,(search-path %load-path "ice-9/q.scm"))
 222                      ("a/b/c" . ,(search-path %load-path
 223                                               "guix/derivations.scm"))
 224                      ("p/q"   . ,(search-path %load-path "guix.scm"))
 225                      ("p/z"   . ,(search-path %load-path "guix/store.scm"))))
 226          (drv-path (imported-files %store files)))
 227     (and (build-derivations %store (list drv-path))
 228          (let ((dir (derivation-path->output-path drv-path)))
 229            (every (match-lambda
 230                    ((path . source)
 231                     (equal? (call-with-input-file (string-append dir "/" path)
 232                               get-bytevector-all)
 233                             (call-with-input-file source
 234                               get-bytevector-all))))
 235                   files)))))
 236
 237 (test-skip (if (false-if-exception (getaddrinfo "ftp.gnu.org" "http"))
 238                0
 239                1))
 240
 241 (test-assert "build-expression->derivation for fixed-output derivation"
 242   (let* ((url         "http://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz")
 243          (builder
 244           `(begin
 245              (use-modules (web client) (web uri)
 246                           (rnrs io ports) (srfi srfi-11))
 247              (let-values (((resp bv)
 248                            (http-get (string->uri ,url) #:decode-body? #f)))
 249                (call-with-output-file %output
 250                  (lambda (p)
 251                    (put-bytevector p bv))))))
 252          (drv-path    (build-expression->derivation
 253                        %store "hello-2.8.tar.gz" (%current-system) builder '()
 254                        #:hash (nix-base32-string->bytevector
 255                                "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6")
 256                        #:hash-algo 'sha256))
 257          (succeeded?  (build-derivations %store (list drv-path))))
 258     (and succeeded?
 259          (file-exists? (derivation-path->output-path drv-path)))))
 260
 261 (test-end)
 262
 263 \f
 264 (exit (= (test-runner-fail-count (test-runner-current)) 0))
 265
 266 ;;; Local Variables:
 267 ;;; eval: (put 'test-assert 'scheme-indent-function 1)
 268 ;;; End: