tests/derivations.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 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 (unsetenv "http_proxy")
  20
  21 (define-module (test-derivations)
  22   #:use-module (guix derivations)
  23   #:use-module (guix grafts)
  24   #:use-module (guix store)
  25   #:use-module (guix utils)
  26   #:use-module ((gcrypt hash) #:prefix gcrypt:)
  27   #:use-module (guix base32)
  28   #:use-module (guix tests)
  29   #:use-module (guix tests http)
  30   #:use-module ((guix packages) #:select (package-derivation base32))
  31   #:use-module ((guix build utils) #:select (executable-file?))
  32   #:use-module (gnu packages bootstrap)
  33   #:use-module ((gnu packages guile) #:select (guile-1.8))
  34   #:use-module (srfi srfi-1)
  35   #:use-module (srfi srfi-11)
  36   #:use-module (srfi srfi-26)
  37   #:use-module (srfi srfi-34)
  38   #:use-module (srfi srfi-64)
  39   #:use-module (rnrs io ports)
  40   #:use-module (rnrs bytevectors)
  41   #:use-module (web uri)
  42   #:use-module (ice-9 rdelim)
  43   #:use-module (ice-9 regex)
  44   #:use-module (ice-9 ftw)
  45   #:use-module (ice-9 match))
  46
  47 (define %store
  48   (open-connection-for-tests))
  49
  50 ;; Globally disable grafts because they can trigger early builds.
  51 (%graft? #f)
  52
  53 (define (bootstrap-binary name)
  54   (let ((bin (search-bootstrap-binary name (%current-system))))
  55     (and %store
  56          (add-to-store %store name #t "sha256" bin))))
  57
  58 (define %bash
  59   (bootstrap-binary "bash"))
  60 (define %mkdir
  61   (bootstrap-binary "mkdir"))
  62
  63 (define* (directory-contents dir #:optional (slurp get-bytevector-all))
  64   "Return an alist representing the contents of DIR."
  65   (define prefix-len (string-length dir))
  66   (sort (file-system-fold (const #t)                   ; enter?
  67                           (lambda (path stat result)   ; leaf
  68                             (alist-cons (string-drop path prefix-len)
  69                                         (call-with-input-file path slurp)
  70                                         result))
  71                           (lambda (path stat result) result)      ; down
  72                           (lambda (path stat result) result)      ; up
  73                           (lambda (path stat result) result)      ; skip
  74                           (lambda (path stat errno result) result) ; error
  75                           '()
  76                           dir)
  77         (lambda (e1 e2)
  78           (string<? (car e1) (car e2)))))
  79
  80 ;; Avoid collisions with other tests.
  81 (%http-server-port 10500)
  82
  83 \f
  84 (test-begin "derivations")
  85
  86 (test-assert "parse & export"
  87   (let* ((f  (search-path %load-path "tests/test.drv"))
  88          (b1 (call-with-input-file f get-bytevector-all))
  89          (d1 (read-derivation (open-bytevector-input-port b1)
  90                               identity))
  91          (b2 (call-with-bytevector-output-port (cut write-derivation d1 <>)))
  92          (d2 (read-derivation (open-bytevector-input-port b2)
  93                               identity)))
  94     (and (equal? b1 b2)
  95          (equal? d1 d2))))
  96
  97 (test-skip (if %store 0 12))
  98
  99 (test-assert "add-to-store, flat"
 100   ;; Use 'readlink*' in case spec.scm is a symlink, as is the case when Guile
 101   ;; was installed with Stow.
 102   (let* ((file (readlink*
 103                 (search-path %load-path "language/tree-il/spec.scm")))
 104          (drv  (add-to-store %store "flat-test" #f "sha256" file)))
 105     (and (eq? 'regular (stat:type (stat drv)))
 106          (valid-path? %store drv)
 107          (equal? (call-with-input-file file get-bytevector-all)
 108                  (call-with-input-file drv get-bytevector-all)))))
 109
 110 (test-assert "add-to-store, recursive"
 111   (let* ((dir (dirname
 112                (readlink* (search-path %load-path
 113                                        "language/tree-il/spec.scm"))))
 114          (drv (add-to-store %store "dir-tree-test" #t "sha256" dir)))
 115     (and (eq? 'directory (stat:type (stat drv)))
 116          (valid-path? %store drv)
 117          (equal? (directory-contents dir)
 118                  (directory-contents drv)))))
 119
 120 (test-assert "derivation with no inputs"
 121   (let* ((builder  (add-text-to-store %store "my-builder.sh"
 122                                       "echo hello, world\n"
 123                                       '()))
 124          (drv      (derivation %store "foo"
 125                                %bash `("-e" ,builder)
 126                                #:env-vars '(("HOME" . "/homeless")))))
 127     (and (store-path? (derivation-file-name drv))
 128          (valid-path? %store (derivation-file-name drv)))))
 129
 130 (test-assert "build derivation with 1 source"
 131   (let* ((builder (add-text-to-store %store "my-builder.sh"
 132                                      "echo hello, world > \"$out\"\n"
 133                                      '()))
 134          (drv     (derivation %store "foo"
 135                               %bash `(,builder)
 136                               #:env-vars '(("HOME" . "/homeless")
 137                                            ("zzz"  . "Z!")
 138                                            ("AAA"  . "A!"))
 139                               #:sources `(,%bash ,builder)))
 140          (succeeded?
 141           (build-derivations %store (list drv))))
 142     (and succeeded?
 143          (let ((path (derivation->output-path drv)))
 144            (and (valid-path? %store path)
 145                 (string=? (call-with-input-file path read-line)
 146                           "hello, world"))))))
 147
 148 (test-assert "derivation fails but keep going"
 149   ;; In keep-going mode, 'build-derivations' should fail because of D1, but it
 150   ;; must return only after D2 has succeeded.
 151   (with-store store
 152     (let* ((d1 (derivation %store "fails"
 153                            %bash `("-c" "false")
 154                            #:sources (list %bash)))
 155            (d2 (build-expression->derivation %store "sleep-then-succeed"
 156                                              `(begin
 157                                                 ,(random-text)
 158                                                 ;; XXX: Hopefully that's long
 159                                                 ;; enough that D1 has already
 160                                                 ;; failed.
 161                                                 (sleep 2)
 162                                                 (mkdir %output)))))
 163       (set-build-options %store
 164                          #:use-substitutes? #f
 165                          #:keep-going? #t)
 166       (guard (c ((store-protocol-error? c)
 167                  (and (= 100 (store-protocol-error-status c))
 168                       (string-contains (store-protocol-error-message c)
 169                                        (derivation-file-name d1))
 170                       (not (valid-path? %store (derivation->output-path d1)))
 171                       (valid-path? %store (derivation->output-path d2)))))
 172         (build-derivations %store (list d1 d2))
 173         #f))))
 174
 175 (test-assert "identical files are deduplicated"
 176   (let* ((build1  (add-text-to-store %store "one.sh"
 177                                      "echo hello, world > \"$out\"\n"
 178                                      '()))
 179          (build2  (add-text-to-store %store "two.sh"
 180                                      "# Hey!\necho hello, world > \"$out\"\n"
 181                                      '()))
 182          (drv1    (derivation %store "foo"
 183                               %bash `(,build1)
 184                               #:sources `(,%bash ,build1)))
 185          (drv2    (derivation %store "bar"
 186                               %bash `(,build2)
 187                               #:sources `(,%bash ,build2))))
 188     (and (build-derivations %store (list drv1 drv2))
 189          (let ((file1 (derivation->output-path drv1))
 190                (file2 (derivation->output-path drv2)))
 191            (and (valid-path? %store file1) (valid-path? %store file2)
 192                 (string=? (call-with-input-file file1 get-string-all)
 193                           "hello, world\n")
 194                 (= (stat:ino (lstat file1))
 195                    (stat:ino (lstat file2))))))))
 196
 197 (test-equal "built-in-builders"
 198   '("download")
 199   (built-in-builders %store))
 200
 201 (test-assert "unknown built-in builder"
 202   (let ((drv (derivation %store "ohoh" "builtin:does-not-exist" '())))
 203     (guard (c ((store-protocol-error? c)
 204                (string-contains (store-protocol-error-message c) "failed")))
 205       (build-derivations %store (list drv))
 206       #f)))
 207
 208 (unless (http-server-can-listen?)
 209   (test-skip 1))
 210 (test-assert "'download' built-in builder"
 211   (let ((text (random-text)))
 212     (with-http-server `((200 ,text))
 213       (let* ((drv (derivation %store "world"
 214                               "builtin:download" '()
 215                               #:env-vars `(("url"
 216                                             . ,(object->string (%local-url))))
 217                               #:hash-algo 'sha256
 218                               #:hash (gcrypt:sha256 (string->utf8 text)))))
 219         (and (build-derivations %store (list drv))
 220              (string=? (call-with-input-file (derivation->output-path drv)
 221                          get-string-all)
 222                        text))))))
 223
 224 (unless (http-server-can-listen?)
 225   (test-skip 1))
 226 (test-assert "'download' built-in builder, invalid hash"
 227   (with-http-server `((200 "hello, world!"))
 228     (let* ((drv (derivation %store "world"
 229                             "builtin:download" '()
 230                             #:env-vars `(("url"
 231                                           . ,(object->string (%local-url))))
 232                             #:hash-algo 'sha256
 233                             #:hash (gcrypt:sha256 (random-bytevector 100))))) ;wrong
 234       (guard (c ((store-protocol-error? c)
 235                  (string-contains (store-protocol-error-message c) "failed")))
 236         (build-derivations %store (list drv))
 237         #f))))
 238
 239 (unless (http-server-can-listen?)
 240   (test-skip 1))
 241 (test-assert "'download' built-in builder, not found"
 242   (with-http-server '((404 "not found"))
 243     (let* ((drv (derivation %store "will-never-be-found"
 244                             "builtin:download" '()
 245                             #:env-vars `(("url"
 246                                           . ,(object->string (%local-url))))
 247                             #:hash-algo 'sha256
 248                             #:hash (gcrypt:sha256 (random-bytevector 100)))))
 249       (guard (c ((store-protocol-error? c)
 250                  (string-contains (store-protocol-error-message (pk c)) "failed")))
 251         (build-derivations %store (list drv))
 252         #f))))
 253
 254 (test-assert "'download' built-in builder, not fixed-output"
 255   (let* ((source (add-text-to-store %store "hello" "hi!"))
 256          (url    (string-append "file://" source))
 257          (drv    (derivation %store "world"
 258                              "builtin:download" '()
 259                              #:env-vars `(("url" . ,(object->string url))))))
 260     (guard (c ((store-protocol-error? c)
 261                (string-contains (store-protocol-error-message c) "failed")))
 262       (build-derivations %store (list drv))
 263       #f)))
 264
 265 (unless (http-server-can-listen?)
 266   (test-skip 1))
 267 (test-assert "'download' built-in builder, check mode"
 268   ;; Make sure rebuilding the 'builtin:download' derivation in check mode
 269   ;; works.  See <http://bugs.gnu.org/25089>.
 270   (let* ((text (random-text))
 271          (drv (derivation %store "world"
 272                           "builtin:download" '()
 273                           #:env-vars `(("url"
 274                                         . ,(object->string (%local-url))))
 275                           #:hash-algo 'sha256
 276                           #:hash (gcrypt:sha256 (string->utf8 text)))))
 277     (and (with-http-server `((200 ,text))
 278            (build-derivations %store (list drv)))
 279          (with-http-server `((200 ,text))
 280            (build-derivations %store (list drv)
 281                               (build-mode check)))
 282          (string=? (call-with-input-file (derivation->output-path drv)
 283                      get-string-all)
 284                    text))))
 285
 286 (test-equal "derivation-name"
 287   "foo-0.0"
 288   (let ((drv (derivation %store "foo-0.0" %bash '())))
 289     (derivation-name drv)))
 290
 291 (test-equal "derivation-output-names"
 292   '(("out") ("bar" "chbouib"))
 293   (let ((drv1 (derivation %store "foo-0.0" %bash '()))
 294         (drv2 (derivation %store "foo-0.0" %bash '()
 295                           #:outputs '("bar" "chbouib"))))
 296     (list (derivation-output-names drv1)
 297           (derivation-output-names drv2))))
 298
 299 (test-assert "offloadable-derivation?"
 300   (and (offloadable-derivation? (derivation %store "foo" %bash '()))
 301        (offloadable-derivation?               ;see <http://bugs.gnu.org/18747>
 302         (derivation %store "foo" %bash '()
 303                     #:substitutable? #f))
 304        (not (offloadable-derivation?
 305              (derivation %store "foo" %bash '()
 306                          #:local-build? #t)))))
 307
 308 (test-assert "substitutable-derivation?"
 309   (and (substitutable-derivation? (derivation %store "foo" %bash '()))
 310        (substitutable-derivation?             ;see <http://bugs.gnu.org/18747>
 311         (derivation %store "foo" %bash '()
 312                     #:local-build? #t))
 313        (not (substitutable-derivation?
 314              (derivation %store "foo" %bash '()
 315                          #:substitutable? #f)))))
 316
 317 (test-assert "fixed-output-derivation?"
 318   (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
 319                                         "echo -n hello > $out" '()))
 320          (hash       (gcrypt:sha256 (string->utf8 "hello")))
 321          (drv        (derivation %store "fixed"
 322                                  %bash `(,builder)
 323                                  #:sources (list builder)
 324                                  #:hash hash #:hash-algo 'sha256)))
 325     (fixed-output-derivation? drv)))
 326
 327 (test-equal "fixed-output derivation"
 328   '(sha1 sha256 sha512)
 329   (map (lambda (hash-algorithm)
 330          (let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
 331                                             "echo -n hello > $out" '()))
 332                 (sha256  (gcrypt:sha256 (string->utf8 "hello")))
 333                 (hash    (gcrypt:bytevector-hash
 334                           (string->utf8 "hello")
 335                           (gcrypt:lookup-hash-algorithm hash-algorithm)))
 336                 (drv     (derivation %store
 337                                      (string-append
 338                                       "fixed-" (symbol->string hash-algorithm))
 339                                      %bash `(,builder)
 340                                      #:sources `(,builder) ;optional
 341                                      #:hash hash
 342                                      #:hash-algo hash-algorithm)))
 343            (build-derivations %store (list drv))
 344            (let ((p (derivation->output-path drv)))
 345              (and (bytevector=? (string->utf8 "hello")
 346                                 (call-with-input-file p get-bytevector-all))
 347                   (bytevector? (query-path-hash %store p))
 348                   hash-algorithm))))
 349        '(sha1 sha256 sha512)))
 350
 351 (test-assert "fixed-output derivation: output paths are equal"
 352   (let* ((builder1   (add-text-to-store %store "fixed-builder1.sh"
 353                                         "echo -n hello > $out" '()))
 354          (builder2   (add-text-to-store %store "fixed-builder2.sh"
 355                                         "echo hey; echo -n hello > $out" '()))
 356          (hash       (gcrypt:sha256 (string->utf8 "hello")))
 357          (drv1       (derivation %store "fixed"
 358                                  %bash `(,builder1)
 359                                  #:hash hash #:hash-algo 'sha256))
 360          (drv2       (derivation %store "fixed"
 361                                  %bash `(,builder2)
 362                                  #:hash hash #:hash-algo 'sha256))
 363          (succeeded? (build-derivations %store (list drv1 drv2))))
 364     (and succeeded?
 365          (equal? (derivation->output-path drv1)
 366                  (derivation->output-path drv2)))))
 367
 368 (test-assert "fixed-output derivation, recursive"
 369   (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
 370                                         "echo -n hello > $out" '()))
 371          (hash       (gcrypt:sha256 (string->utf8 "hello")))
 372          (drv        (derivation %store "fixed-rec"
 373                                  %bash `(,builder)
 374                                  #:sources (list builder)
 375                                  #:hash (base32 "0sg9f58l1jj88w6pdrfdpj5x9b1zrwszk84j81zvby36q9whhhqa")
 376                                  #:hash-algo 'sha256
 377                                  #:recursive? #t))
 378          (succeeded? (build-derivations %store (list drv))))
 379     (and succeeded?
 380          (let ((p (derivation->output-path drv)))
 381            (and (equal? (string->utf8 "hello")
 382                         (call-with-input-file p get-bytevector-all))
 383                 (bytevector? (query-path-hash %store p)))))))
 384
 385 (test-assert "derivation with a fixed-output input"
 386   ;; A derivation D using a fixed-output derivation F doesn't has the same
 387   ;; output path when passed F or F', as long as F and F' have the same output
 388   ;; path.
 389   (let* ((builder1   (add-text-to-store %store "fixed-builder1.sh"
 390                                         "echo -n hello > $out" '()))
 391          (builder2   (add-text-to-store %store "fixed-builder2.sh"
 392                                         "echo hey; echo -n hello > $out" '()))
 393          (hash       (gcrypt:sha256 (string->utf8 "hello")))
 394          (fixed1     (derivation %store "fixed"
 395                                  %bash `(,builder1)
 396                                  #:hash hash #:hash-algo 'sha256))
 397          (fixed2     (derivation %store "fixed"
 398                                  %bash `(,builder2)
 399                                  #:hash hash #:hash-algo 'sha256))
 400          (fixed-out  (derivation->output-path fixed1))
 401          (builder3   (add-text-to-store
 402                       %store "final-builder.sh"
 403                       ;; Use Bash hackery to avoid Coreutils.
 404                       "echo $in ; (read -u 3 c; echo $c) 3< $in > $out" '()))
 405          (final1     (derivation %store "final"
 406                                  %bash `(,builder3)
 407                                  #:env-vars `(("in" . ,fixed-out))
 408                                  #:sources (list %bash builder3)
 409                                  #:inputs (list (derivation-input fixed1))))
 410          (final2     (derivation %store "final"
 411                                  %bash `(,builder3)
 412                                  #:env-vars `(("in" . ,fixed-out))
 413                                  #:sources (list %bash builder3)
 414                                  #:inputs (list (derivation-input fixed2))))
 415          (succeeded? (build-derivations %store
 416                                         (list final1 final2))))
 417     (and succeeded?
 418          (equal? (derivation->output-path final1)
 419                  (derivation->output-path final2)))))
 420
 421 (test-assert "derivation with duplicate fixed-output inputs"
 422   ;; Here we create a derivation that has two inputs, both of which are
 423   ;; fixed-output leading to the same result.  This test ensures the hash of
 424   ;; that derivation is correctly computed, namely that duplicate inputs are
 425   ;; coalesced.  See <https://bugs.gnu.org/36777>.
 426   (let* ((builder1   (add-text-to-store %store "fixed-builder1.sh"
 427                                         "echo -n hello > $out" '()))
 428          (builder2   (add-text-to-store %store "fixed-builder2.sh"
 429                                         "echo hey; echo -n hello > $out" '()))
 430          (hash       (gcrypt:sha256 (string->utf8 "hello")))
 431          (fixed1     (derivation %store "fixed"
 432                                  %bash `(,builder1)
 433                                  #:hash hash #:hash-algo 'sha256))
 434          (fixed2     (derivation %store "fixed"
 435                                  %bash `(,builder2)
 436                                  #:hash hash #:hash-algo 'sha256))
 437          (builder3   (add-text-to-store %store "builder.sh"
 438                                         "echo fake builder"))
 439          (final      (derivation %store "final"
 440                                  %bash `(,builder3)
 441                                  #:sources (list %bash builder3)
 442                                  #:inputs (list (derivation-input fixed1)
 443                                                 (derivation-input fixed2)))))
 444     (and (derivation? final)
 445          (match (derivation-inputs final)
 446            (((= derivation-input-derivation one)
 447              (= derivation-input-derivation two))
 448             (and (not (string=? (derivation-file-name one)
 449                                 (derivation-file-name two)))
 450                  (string=? (derivation->output-path one)
 451                            (derivation->output-path two))))))))
 452
 453 (test-assert "multiple-output derivation"
 454   (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
 455                                         "echo one > $out ; echo two > $second"
 456                                         '()))
 457          (drv        (derivation %store "fixed"
 458                                  %bash `(,builder)
 459                                  #:env-vars '(("HOME" . "/homeless")
 460                                               ("zzz"  . "Z!")
 461                                               ("AAA"  . "A!"))
 462                                  #:sources `(,%bash ,builder)
 463                                  #:outputs '("out" "second")))
 464          (succeeded? (build-derivations %store (list drv))))
 465     (and succeeded?
 466          (let ((one (derivation->output-path drv "out"))
 467                (two (derivation->output-path drv "second")))
 468            (and (lset= equal?
 469                        (derivation->output-paths drv)
 470                        `(("out" . ,one) ("second" . ,two)))
 471                 (eq? 'one (call-with-input-file one read))
 472                 (eq? 'two (call-with-input-file two read)))))))
 473
 474 (test-assert "multiple-output derivation, non-alphabetic order"
 475   ;; Here, the outputs are not listed in alphabetic order.  Yet, the store
 476   ;; path computation must reorder them first.
 477   (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
 478                                         "echo one > $out ; echo two > $AAA"
 479                                         '()))
 480          (drv        (derivation %store "fixed"
 481                                  %bash `(,builder)
 482                                  #:sources `(,%bash ,builder)
 483                                  #:outputs '("out" "AAA")))
 484          (succeeded? (build-derivations %store (list drv))))
 485     (and succeeded?
 486          (let ((one (derivation->output-path drv "out"))
 487                (two (derivation->output-path drv "AAA")))
 488            (and (eq? 'one (call-with-input-file one read))
 489                 (eq? 'two (call-with-input-file two read)))))))
 490
 491 (test-assert "read-derivation vs. derivation"
 492   ;; Make sure 'derivation' and 'read-derivation' return objects that are
 493   ;; identical.
 494   (let* ((sources (unfold (cut >= <> 10)
 495                           (lambda (n)
 496                             (add-text-to-store %store
 497                                                (format #f "input~a" n)
 498                                                (random-text)))
 499                           1+
 500                           0))
 501          (inputs  (map (lambda (file)
 502                          (derivation %store "derivation-input"
 503                                      %bash '()
 504                                      #:sources `(,%bash ,file)))
 505                        sources))
 506          (builder (add-text-to-store %store "builder.sh"
 507                                      "echo one > $one ; echo two > $two"
 508                                      '()))
 509          (drv     (derivation %store "derivation"
 510                               %bash `(,builder)
 511                               #:sources `(,%bash ,builder ,@sources)
 512                               #:inputs (map derivation-input inputs)
 513                               #:outputs '("two" "one")))
 514          (drv*    (call-with-input-file (derivation-file-name drv)
 515                     read-derivation)))
 516     (equal? drv* drv)))
 517
 518 (test-assert "multiple-output derivation, derivation-path->output-path"
 519   (let* ((builder    (add-text-to-store %store "builder.sh"
 520                                         "echo one > $out ; echo two > $second"
 521                                         '()))
 522          (drv        (derivation %store "multiple"
 523                                  %bash `(,builder)
 524                                  #:outputs '("out" "second")))
 525          (drv-file   (derivation-file-name drv))
 526          (one        (derivation->output-path drv "out"))
 527          (two        (derivation->output-path drv "second"))
 528          (first      (derivation-path->output-path drv-file "out"))
 529          (second     (derivation-path->output-path drv-file "second")))
 530     (and (not (string=? one two))
 531          (string-suffix? "-second" two)
 532          (string=? first one)
 533          (string=? second two))))
 534
 535 (test-assert "user of multiple-output derivation"
 536   ;; Check whether specifying several inputs coming from the same
 537   ;; multiple-output derivation works.
 538   (let* ((builder1   (add-text-to-store %store "my-mo-builder.sh"
 539                                         "echo one > $out ; echo two > $two"
 540                                         '()))
 541          (mdrv       (derivation %store "multiple-output"
 542                                  %bash `(,builder1)
 543                                  #:sources (list %bash builder1)
 544                                  #:outputs '("out" "two")))
 545          (builder2   (add-text-to-store %store "my-mo-user-builder.sh"
 546                                         "read x < $one;
 547                                          read y < $two;
 548                                          echo \"($x $y)\" > $out"
 549                                         '()))
 550          (udrv       (derivation %store "multiple-output-user"
 551                                  %bash `(,builder2)
 552                                  #:env-vars `(("one"
 553                                                . ,(derivation->output-path
 554                                                    mdrv "out"))
 555                                               ("two"
 556                                                . ,(derivation->output-path
 557                                                    mdrv "two")))
 558                                  #:sources (list %bash builder2)
 559                                  ;; two occurrences of MDRV:
 560                                  #:inputs
 561                                  (list (derivation-input mdrv)
 562                                        (derivation-input mdrv '("two"))))))
 563     (and (build-derivations %store (list (pk 'udrv udrv)))
 564          (let ((p (derivation->output-path udrv)))
 565            (and (valid-path? %store p)
 566                 (equal? '(one two) (call-with-input-file p read)))))))
 567
 568 (test-assert "derivation with #:references-graphs"
 569   (let* ((input1  (add-text-to-store %store "foo" "hello"
 570                                      (list %bash)))
 571          (input2  (add-text-to-store %store "bar"
 572                                      (number->string (random 7777))
 573                                      (list input1)))
 574          (builder (add-text-to-store %store "build-graph"
 575                                      (format #f "
 576 ~a $out
 577  (while read l ; do echo $l ; done) < bash > $out/bash
 578  (while read l ; do echo $l ; done) < input1 > $out/input1
 579  (while read l ; do echo $l ; done) < input2 > $out/input2"
 580                                              %mkdir)
 581                                      (list %mkdir)))
 582          (drv     (derivation %store "closure-graphs"
 583                               %bash `(,builder)
 584                               #:references-graphs
 585                               `(("bash" . ,%bash)
 586                                 ("input1" . ,input1)
 587                                 ("input2" . ,input2))
 588                               #:sources (list %bash builder)))
 589          (out     (derivation->output-path drv)))
 590     (define (deps path . deps)
 591       (let ((count (length deps)))
 592         (string-append path "\n\n" (number->string count) "\n"
 593                        (string-join (sort deps string<?) "\n")
 594                        (if (zero? count) "" "\n"))))
 595
 596     (and (build-derivations %store (list drv))
 597          (equal? (directory-contents out get-string-all)
 598                  `(("/bash"   . ,(string-append %bash "\n\n0\n"))
 599                    ("/input1" . ,(if (string>? input1 %bash)
 600                                      (string-append (deps %bash)
 601                                                     (deps input1 %bash))
 602                                      (string-append (deps input1 %bash)
 603                                                     (deps %bash))))
 604                    ("/input2" . ,(string-concatenate
 605                                   (map cdr
 606                                        (sort
 607                                         (map (lambda (p d)
 608                                                (cons p (apply deps p d)))
 609                                              (list %bash input1 input2)
 610                                              (list '() (list %bash) (list input1)))
 611                                         (lambda (x y)
 612                                           (match x
 613                                             ((p1 . _)
 614                                              (match y
 615                                                ((p2 . _)
 616                                                 (string<? p1 p2)))))))))))))))
 617
 618 (test-assert "derivation #:allowed-references, ok"
 619   (let ((drv (derivation %store "allowed" %bash
 620                          '("-c" "echo hello > $out")
 621                          #:sources (list %bash)
 622                          #:allowed-references '())))
 623     (build-derivations %store (list drv))))
 624
 625 (test-assert "derivation #:allowed-references, not allowed"
 626   (let* ((txt (add-text-to-store %store "foo" "Hello, world."))
 627          (drv (derivation %store "disallowed" %bash
 628                           `("-c" ,(string-append "echo " txt "> $out"))
 629                           #:sources (list %bash txt)
 630                           #:allowed-references '())))
 631     (guard (c ((store-protocol-error? c)
 632                ;; There's no specific error message to check for.
 633                #t))
 634       (build-derivations %store (list drv))
 635       #f)))
 636
 637 (test-assert "derivation #:allowed-references, self allowed"
 638   (let ((drv (derivation %store "allowed" %bash
 639                          '("-c" "echo $out > $out")
 640                          #:sources (list %bash)
 641                          #:allowed-references '("out"))))
 642     (build-derivations %store (list drv))))
 643
 644 (test-assert "derivation #:allowed-references, self not allowed"
 645   (let ((drv (derivation %store "disallowed" %bash
 646                          `("-c" ,"echo $out > $out")
 647                          #:sources (list %bash)
 648                          #:allowed-references '())))
 649     (guard (c ((store-protocol-error? c)
 650                ;; There's no specific error message to check for.
 651                #t))
 652       (build-derivations %store (list drv))
 653       #f)))
 654
 655 (test-assert "derivation #:disallowed-references, ok"
 656   (let ((drv (derivation %store "disallowed" %bash
 657                          '("-c" "echo hello > $out")
 658                          #:sources (list %bash)
 659                          #:disallowed-references '("out"))))
 660     (build-derivations %store (list drv))))
 661
 662 (test-assert "derivation #:disallowed-references, not ok"
 663   (let* ((txt (add-text-to-store %store "foo" "Hello, world."))
 664          (drv (derivation %store "disdisallowed" %bash
 665                           `("-c" ,(string-append "echo " txt "> $out"))
 666                           #:sources (list %bash txt)
 667                           #:disallowed-references (list txt))))
 668     (guard (c ((store-protocol-error? c)
 669                ;; There's no specific error message to check for.
 670                #t))
 671       (build-derivations %store (list drv))
 672       #f)))
 673
 674 ;; Here we should get the value of $GUIX_STATE_DIRECTORY that the daemon sees,
 675 ;; which is a unique value for each test process; this value is the same as
 676 ;; the one we see in the process executing this file since it is set by
 677 ;; 'test-env'.
 678 (test-equal "derivation #:leaked-env-vars"
 679   (getenv "GUIX_STATE_DIRECTORY")
 680   (let* ((value (getenv "GUIX_STATE_DIRECTORY"))
 681          (drv   (derivation %store "leaked-env-vars" %bash
 682                             '("-c" "echo -n $GUIX_STATE_DIRECTORY > $out")
 683                             #:hash (gcrypt:sha256 (string->utf8 value))
 684                             #:hash-algo 'sha256
 685                             #:sources (list %bash)
 686                             #:leaked-env-vars '("GUIX_STATE_DIRECTORY"))))
 687     (and (build-derivations %store (list drv))
 688          (call-with-input-file (derivation->output-path drv)
 689            get-string-all))))
 690
 691 \f
 692 (define %coreutils
 693   (false-if-exception
 694    (and (network-reachable?)
 695         (package-derivation %store %bootstrap-coreutils&co))))
 696
 697 (test-skip (if %coreutils 0 1))
 698
 699 (test-assert "build derivation with coreutils"
 700   (let* ((builder
 701           (add-text-to-store %store "build-with-coreutils.sh"
 702                              "echo $PATH ; mkdir --version ; mkdir $out ; touch $out/good"
 703                              '()))
 704          (drv
 705           (derivation %store "foo"
 706                       %bash `(,builder)
 707                       #:env-vars `(("PATH" .
 708                                     ,(string-append
 709                                       (derivation->output-path %coreutils)
 710                                       "/bin")))
 711                       #:sources (list builder)
 712                       #:inputs (list (derivation-input %coreutils))))
 713          (succeeded?
 714           (build-derivations %store (list drv))))
 715     (and succeeded?
 716          (let ((p (derivation->output-path drv)))
 717            (and (valid-path? %store p)
 718                 (file-exists? (string-append p "/good")))))))
 719
 720 (test-skip (if (%guile-for-build) 0 8))
 721
 722 (test-equal "build-expression->derivation and invalid module name"
 723   '(file-search-error "guix/module/that/does/not/exist.scm")
 724   (guard (c ((file-search-error? c)
 725              (list 'file-search-error
 726                    (file-search-error-file-name c))))
 727     (build-expression->derivation %store "foo" #t
 728                                   #:modules '((guix module that
 729                                                     does not exist)))))
 730
 731 (test-equal "build-expression->derivation and builder encoding"
 732   '("UTF-8" #t)
 733   (let* ((exp '(λ (α) (+ α 1)))
 734          (drv (build-expression->derivation %store "foo" exp)))
 735     (match (derivation-builder-arguments drv)
 736       ((... builder)
 737        (with-fluids ((%default-port-encoding "UTF-8"))
 738          (call-with-input-file builder
 739            (lambda (port)
 740              (list (port-encoding port)
 741                    (->bool
 742                     (string-contains (get-string-all port)
 743                                      "(λ (α) (+ α 1))"))))))))))
 744
 745 (test-assert "build-expression->derivation and derivation-prerequisites"
 746   (let ((drv (build-expression->derivation %store "fail" #f)))
 747     (any (match-lambda
 748           (($ <derivation-input> (= derivation-file-name path))
 749            (string=? path (derivation-file-name (%guile-for-build)))))
 750          (derivation-prerequisites drv))))
 751
 752 (test-assert "derivation-prerequisites and valid-derivation-input?"
 753   (let* ((a (build-expression->derivation %store "a" '(mkdir %output)))
 754          (b (build-expression->derivation %store "b" `(list ,(random-text))))
 755          (c (build-expression->derivation %store "c" `(mkdir %output)
 756                                           #:inputs `(("a" ,a) ("b" ,b)))))
 757     ;; Make sure both A and %BOOTSTRAP-GUILE are built (the latter could have
 758     ;; be removed by tests/guix-gc.sh.)
 759     (build-derivations %store
 760                        (list a (package-derivation %store %bootstrap-guile)))
 761
 762     (match (derivation-prerequisites c
 763                                      (cut valid-derivation-input? %store
 764                                           <>))
 765       ((($ <derivation-input> (= derivation-file-name file) ("out")))
 766        (string=? file (derivation-file-name b)))
 767       (x
 768        (pk 'fail x #f)))))
 769
 770 (test-assert "build-expression->derivation without inputs"
 771   (let* ((builder    '(begin
 772                         (mkdir %output)
 773                         (call-with-output-file (string-append %output "/test")
 774                           (lambda (p)
 775                             (display '(hello guix) p)))))
 776          (drv        (build-expression->derivation %store "goo" builder))
 777          (succeeded? (build-derivations %store (list drv))))
 778     (and succeeded?
 779          (let ((p (derivation->output-path drv)))
 780            (equal? '(hello guix)
 781                    (call-with-input-file (string-append p "/test") read))))))
 782
 783 (test-assert "build-expression->derivation and max-silent-time"
 784   (let* ((store      (let ((s (open-connection)))
 785                        (set-build-options s #:max-silent-time 1)
 786                        s))
 787          (builder    '(begin (sleep 100) (mkdir %output) #t))
 788          (drv        (build-expression->derivation store "silent" builder))
 789          (out-path   (derivation->output-path drv)))
 790     (guard (c ((store-protocol-error? c)
 791                (and (string-contains (store-protocol-error-message c)
 792                                      "failed")
 793                     (not (valid-path? store out-path)))))
 794       (build-derivations store (list drv))
 795       #f)))
 796
 797 (test-assert "build-expression->derivation and timeout"
 798   (let* ((store      (let ((s (open-connection)))
 799                        (set-build-options s #:timeout 1)
 800                        s))
 801          (builder    '(begin (sleep 100) (mkdir %output) #t))
 802          (drv        (build-expression->derivation store "slow" builder))
 803          (out-path   (derivation->output-path drv)))
 804     (guard (c ((store-protocol-error? c)
 805                (and (string-contains (store-protocol-error-message c)
 806                                      "failed")
 807                     (not (valid-path? store out-path)))))
 808       (build-derivations store (list drv))
 809       #f)))
 810
 811 (test-assert "build-derivations with specific output"
 812   (with-store store
 813     (let* ((content (random-text))                ;contents of the output
 814            (drv     (build-expression->derivation
 815                      store "substitute-me"
 816                      `(begin ,content (exit 1))   ;would fail
 817                      #:outputs '("out" "one" "two")
 818                      #:guile-for-build
 819                      (package-derivation store %bootstrap-guile)))
 820            (out     (derivation->output-path drv)))
 821       (with-derivation-substitute drv content
 822         (set-build-options store #:use-substitutes? #t
 823                            #:substitute-urls (%test-substitute-urls))
 824         (and (has-substitutes? store out)
 825
 826              ;; Ask for nothing but the "out" output of DRV.
 827              (build-derivations store `((,drv . "out")))
 828
 829              ;; Synonymous:
 830              (build-derivations store (list (derivation-input drv '("out"))))
 831
 832              (valid-path? store out)
 833              (equal? (pk 'x content)
 834                      (pk 'y (call-with-input-file out get-string-all))))))))
 835
 836 (test-assert "build-expression->derivation and derivation-build-plan"
 837   (let ((drv (build-expression->derivation %store "fail" #f)))
 838     ;; The only direct dependency is (%guile-for-build) and it's already
 839     ;; built.
 840     (null? (derivation-build-plan %store (derivation-inputs drv)))))
 841
 842 (test-assert "derivation-build-plan when outputs already present"
 843   (let* ((builder    `(begin ,(random-text) (mkdir %output) #t))
 844          (input-drv  (build-expression->derivation %store "input" builder))
 845          (input-path (derivation->output-path input-drv))
 846          (drv        (build-expression->derivation %store "something" builder
 847                                                    #:inputs
 848                                                    `(("i" ,input-drv))))
 849          (output     (derivation->output-path drv)))
 850     ;; Assume these things are not already built.
 851     (when (or (valid-path? %store input-path)
 852               (valid-path? %store output))
 853       (error "things already built" input-drv))
 854
 855     (and (lset= equal?
 856                 (map derivation-file-name
 857                      (derivation-build-plan %store
 858                                             (list (derivation-input drv))))
 859                 (list (derivation-file-name input-drv)
 860                       (derivation-file-name drv)))
 861
 862          ;; Build DRV and delete its input.
 863          (build-derivations %store (list drv))
 864          (delete-paths %store (list input-path))
 865          (not (valid-path? %store input-path))
 866
 867          ;; Now INPUT-PATH is missing, yet it shouldn't be listed as a
 868          ;; prerequisite to build because DRV itself is already built.
 869          (null? (derivation-build-plan %store
 870                                        (list (derivation-input drv)))))))
 871
 872 (test-assert "derivation-build-plan and substitutes"
 873   (let* ((store  (open-connection))
 874          (drv    (build-expression->derivation store "prereq-subst"
 875                                                (random 1000)))
 876          (output (derivation->output-path drv)))
 877
 878     ;; Make sure substitutes are usable.
 879     (set-build-options store #:use-substitutes? #t
 880                        #:substitute-urls (%test-substitute-urls))
 881
 882     (with-derivation-narinfo drv
 883       (let-values (((build download)
 884                     (derivation-build-plan store
 885                                            (list (derivation-input drv))))
 886                    ((build* download*)
 887                     (derivation-build-plan store
 888                                            (list (derivation-input drv))
 889                                            #:substitutable-info
 890                                            (const #f))))
 891         (and (null? build)
 892              (equal? (map substitutable-path download) (list output))
 893              (null? download*)
 894              (equal? (list drv) build*))))))
 895
 896 (test-assert "derivation-build-plan and substitutes, non-substitutable build"
 897   (let* ((store  (open-connection))
 898          (drv    (build-expression->derivation store "prereq-no-subst"
 899                                                (random 1000)
 900                                                #:substitutable? #f))
 901          (output (derivation->output-path drv)))
 902
 903     ;; Make sure substitutes are usable.
 904     (set-build-options store #:use-substitutes? #t
 905                        #:substitute-urls (%test-substitute-urls))
 906
 907     (with-derivation-narinfo drv
 908       (let-values (((build download)
 909                     (derivation-build-plan store
 910                                            (list (derivation-input drv)))))
 911         ;; Despite being available as a substitute, DRV will be built locally
 912         ;; due to #:substitutable? #f.
 913         (and (null? download)
 914              (match build
 915                (((= derivation-file-name build))
 916                 (string=? build (derivation-file-name drv)))))))))
 917
 918 (test-assert "derivation-build-plan and substitutes, non-substitutable dep"
 919   (with-store store
 920     (let* ((drv1 (build-expression->derivation store "prereq-no-subst"
 921                                                (random 1000)
 922                                                #:substitutable? #f))
 923            (drv2 (build-expression->derivation store "substitutable"
 924                                                (random 1000)
 925                                                #:inputs `(("dep" ,drv1)))))
 926
 927       ;; Make sure substitutes are usable.
 928       (set-build-options store #:use-substitutes? #t
 929                          #:substitute-urls (%test-substitute-urls))
 930
 931       (with-derivation-narinfo drv2
 932         (sha256 => (make-bytevector 32 0))
 933         (references => (list (derivation->output-path drv1)))
 934
 935         (let-values (((build download)
 936                       (derivation-build-plan store
 937                                              (list (derivation-input drv2)))))
 938           ;; Although DRV2 is available as a substitute, we must build its
 939           ;; dependency, DRV1, due to #:substitutable? #f.
 940           (and (match download
 941                  (((= substitutable-path item))
 942                   (string=? item (derivation->output-path drv2))))
 943                (match build
 944                  (((= derivation-file-name build))
 945                   (string=? build (derivation-file-name drv1))))))))))
 946
 947 (test-assert "derivation-build-plan and substitutes, local build"
 948   (with-store store
 949     (let* ((drv    (build-expression->derivation store "prereq-subst-local"
 950                                                  (random 1000)
 951                                                  #:local-build? #t))
 952            (output (derivation->output-path drv)))
 953
 954       ;; Make sure substitutes are usable.
 955       (set-build-options store #:use-substitutes? #t
 956                          #:substitute-urls (%test-substitute-urls))
 957
 958       (with-derivation-narinfo drv
 959         (let-values (((build download)
 960                       (derivation-build-plan store
 961                                              (list (derivation-input drv)))))
 962           ;; #:local-build? is *not* synonymous with #:substitutable?, so we
 963           ;; must be able to substitute DRV's output.
 964           ;; See <http://bugs.gnu.org/18747>.
 965           (and (null? build)
 966                (match download
 967                  (((= substitutable-path item))
 968                   (string=? item (derivation->output-path drv))))))))))
 969
 970 (test-assert "derivation-build-plan in 'check' mode"
 971   (with-store store
 972     (let* ((dep (build-expression->derivation store "dep"
 973                                               `(begin ,(random-text)
 974                                                       (mkdir %output))))
 975            (drv (build-expression->derivation store "to-check"
 976                                               '(mkdir %output)
 977                                               #:inputs `(("dep" ,dep)))))
 978       (build-derivations store (list drv))
 979       (delete-paths store (list (derivation->output-path dep)))
 980
 981       ;; In 'check' mode, DEP must be rebuilt.
 982       (and (null? (derivation-build-plan store
 983                                          (list (derivation-input drv))))
 984            (lset= equal?
 985                   (derivation-build-plan store
 986                                          (list (derivation-input drv))
 987                                          #:mode (build-mode check))
 988                   (list drv dep))))))
 989
 990 (test-assert "derivation-input-fold"
 991   (let* ((builder (add-text-to-store %store "my-builder.sh"
 992                                      "echo hello, world > \"$out\"\n"
 993                                      '()))
 994          (drv1    (derivation %store "foo"
 995                               %bash `(,builder)
 996                               #:sources `(,%bash ,builder)))
 997          (drv2    (derivation %store "bar"
 998                               %bash `(,builder)
 999                               #:inputs `((,drv1))
1000                               #:sources `(,%bash ,builder))))
1001     (equal? (derivation-input-fold (lambda (input result)
1002                                      (cons (derivation-input-derivation input)
1003                                            result))
1004                                    '()
1005                                    (list (derivation-input drv2)))
1006             (list drv1 drv2))))
1007
1008 (test-assert "substitution-oracle and #:substitute? #f"
1009   (with-store store
1010     (let* ((dep   (build-expression->derivation store "dep"
1011                                                 `(begin ,(random-text)
1012                                                         (mkdir %output))))
1013            (drv   (build-expression->derivation store "not-subst"
1014                                                 `(begin ,(random-text)
1015                                                         (mkdir %output))
1016                                                 #:substitutable? #f
1017                                                 #:inputs `(("dep" ,dep))))
1018            (query #f))
1019       (define (record-substitutable-path-query store paths)
1020         (when query
1021           (error "already called!" query))
1022         (set! query paths)
1023         '())
1024
1025       (mock ((guix store) substitutable-path-info
1026              record-substitutable-path-query)
1027
1028             (let ((pred (substitution-oracle store (list drv))))
1029               (pred (derivation->output-path drv))))
1030
1031       ;; Make sure the oracle didn't try to get substitute info for DRV since
1032       ;; DRV is mark as non-substitutable.  Assume that GUILE-FOR-BUILD is
1033       ;; already in store and thus not part of QUERY.
1034       (equal? (pk 'query query)
1035               (list (derivation->output-path dep))))))
1036
1037 (test-assert "build-expression->derivation with expression returning #f"
1038   (let* ((builder  '(begin
1039                       (mkdir %output)
1040                       #f))                        ; fail!
1041          (drv      (build-expression->derivation %store "fail" builder))
1042          (out-path (derivation->output-path drv)))
1043     (guard (c ((store-protocol-error? c)
1044                ;; Note that the output path may exist at this point, but it
1045                ;; is invalid.
1046                (and (string-match "build .* failed"
1047                                   (store-protocol-error-message c))
1048                     (not (valid-path? %store out-path)))))
1049       (build-derivations %store (list drv))
1050       #f)))
1051
1052 (test-assert "build-expression->derivation with two outputs"
1053   (let* ((builder    '(begin
1054                         (call-with-output-file (assoc-ref %outputs "out")
1055                           (lambda (p)
1056                             (display '(hello) p)))
1057                         (call-with-output-file (assoc-ref %outputs "second")
1058                           (lambda (p)
1059                             (display '(world) p)))))
1060          (drv        (build-expression->derivation %store "double" builder
1061                                                    #:outputs '("out"
1062                                                                "second")))
1063          (succeeded? (build-derivations %store (list drv))))
1064     (and succeeded?
1065          (let ((one (derivation->output-path drv))
1066                (two (derivation->output-path drv "second")))
1067            (and (equal? '(hello) (call-with-input-file one read))
1068                 (equal? '(world) (call-with-input-file two read)))))))
1069
1070 (test-skip (if %coreutils 0 1))
1071 (test-assert "build-expression->derivation with one input"
1072   (let* ((builder    '(call-with-output-file %output
1073                         (lambda (p)
1074                           (let ((cu (assoc-ref %build-inputs "cu")))
1075                             (close 1)
1076                             (dup2 (port->fdes p) 1)
1077                             (execl (string-append cu "/bin/uname")
1078                                    "uname" "-a")))))
1079          (drv        (build-expression->derivation %store "uname" builder
1080                                                    #:inputs
1081                                                    `(("cu" ,%coreutils))))
1082          (succeeded? (build-derivations %store (list drv))))
1083     (and succeeded?
1084          (let ((p (derivation->output-path drv)))
1085            (string-contains (call-with-input-file p read-line) "GNU")))))
1086
1087 (test-assert "build-expression->derivation with modules"
1088   (let* ((builder  `(begin
1089                       (use-modules (guix build utils))
1090                       (let ((out (assoc-ref %outputs "out")))
1091                         (mkdir-p (string-append out "/guile/guix/nix"))
1092                         #t)))
1093          (drv      (build-expression->derivation %store "test-with-modules"
1094                                                  builder
1095                                                  #:modules
1096                                                  '((guix build utils)))))
1097     (and (build-derivations %store (list drv))
1098          (let* ((p (derivation->output-path drv))
1099                 (s (stat (string-append p "/guile/guix/nix"))))
1100            (eq? (stat:type s) 'directory)))))
1101
1102 (test-assert "build-expression->derivation: same fixed-output path"
1103   (let* ((builder1   '(call-with-output-file %output
1104                         (lambda (p)
1105                           (write "hello" p))))
1106          (builder2   '(call-with-output-file (pk 'difference-here! %output)
1107                         (lambda (p)
1108                           (write "hello" p))))
1109          (hash       (gcrypt:sha256 (string->utf8 "hello")))
1110          (input1     (build-expression->derivation %store "fixed" builder1
1111                                                    #:hash hash
1112                                                    #:hash-algo 'sha256))
1113          (input2     (build-expression->derivation %store "fixed" builder2
1114                                                    #:hash hash
1115                                                    #:hash-algo 'sha256))
1116          (succeeded? (build-derivations %store (list input1 input2))))
1117     (and succeeded?
1118          (not (string=? (derivation-file-name input1)
1119                         (derivation-file-name input2)))
1120          (string=? (derivation->output-path input1)
1121                    (derivation->output-path input2)))))
1122
1123 (test-assert "build-expression->derivation with a fixed-output input"
1124   (let* ((builder1   '(call-with-output-file %output
1125                         (lambda (p)
1126                           (write "hello" p))))
1127          (builder2   '(call-with-output-file (pk 'difference-here! %output)
1128                         (lambda (p)
1129                           (write "hello" p))))
1130          (hash       (gcrypt:sha256 (string->utf8 "hello")))
1131          (input1     (build-expression->derivation %store "fixed" builder1
1132                                                    #:hash hash
1133                                                    #:hash-algo 'sha256))
1134          (input2     (build-expression->derivation %store "fixed" builder2
1135                                                    #:hash hash
1136                                                    #:hash-algo 'sha256))
1137          (builder3  '(let ((input (assoc-ref %build-inputs "input")))
1138                        (call-with-output-file %output
1139                          (lambda (out)
1140                            (format #f "My input is ~a.~%" input)))))
1141          (final1    (build-expression->derivation %store "final" builder3
1142                                                   #:inputs
1143                                                   `(("input" ,input1))))
1144          (final2    (build-expression->derivation %store "final" builder3
1145                                                   #:inputs
1146                                                   `(("input" ,input2)))))
1147     (and (string=? (derivation->output-path final1)
1148                    (derivation->output-path final2))
1149          (string=? (derivation->output-path final1)
1150                    (derivation-path->output-path
1151                     (derivation-file-name final1)))
1152          (build-derivations %store (list final1 final2)))))
1153
1154 (test-assert "build-expression->derivation produces recursive fixed-output"
1155   (let* ((builder '(begin
1156                      (use-modules (srfi srfi-26))
1157                      (mkdir %output)
1158                      (chdir %output)
1159                      (call-with-output-file "exe"
1160                        (cut display "executable" <>))
1161                      (chmod "exe" #o777)
1162                      (symlink "exe" "symlink")
1163                      (mkdir "subdir")))
1164          (drv     (build-expression->derivation %store "fixed-rec" builder
1165                                                 #:hash-algo 'sha256
1166                                                 #:hash (base32
1167                                                         "10k1lw41wyrjf9mxydi0is5nkpynlsvgslinics4ppir13g7d74p")
1168                                                 #:recursive? #t)))
1169     (and (build-derivations %store (list drv))
1170          (let* ((dir    (derivation->output-path drv))
1171                 (exe    (string-append dir "/exe"))
1172                 (link   (string-append dir "/symlink"))
1173                 (subdir (string-append dir "/subdir")))
1174            (and (executable-file? exe)
1175                 (string=? "executable"
1176                           (call-with-input-file exe get-string-all))
1177                 (string=? "exe" (readlink link))
1178                 (file-is-directory? subdir))))))
1179
1180 (test-assert "build-expression->derivation uses recursive fixed-output"
1181   (let* ((builder '(call-with-output-file %output
1182                      (lambda (port)
1183                        (display "hello" port))))
1184          (fixed   (build-expression->derivation %store "small-fixed-rec"
1185                                                 builder
1186                                                 #:hash-algo 'sha256
1187                                                 #:hash (base32
1188                                                         "0sg9f58l1jj88w6pdrfdpj5x9b1zrwszk84j81zvby36q9whhhqa")
1189                                                 #:recursive? #t))
1190          (in      (derivation->output-path fixed))
1191          (builder `(begin
1192                      (mkdir %output)
1193                      (chdir %output)
1194                      (symlink ,in "symlink")))
1195          (drv     (build-expression->derivation %store "fixed-rec-user"
1196                                                 builder
1197                                                 #:inputs `(("fixed" ,fixed)))))
1198     (and (build-derivations %store (list drv))
1199          (let ((out (derivation->output-path drv)))
1200            (string=? (readlink (string-append out "/symlink")) in)))))
1201
1202 (test-assert "build-expression->derivation with #:references-graphs"
1203   (let* ((input   (add-text-to-store %store "foo" "hello"
1204                                      (list %bash %mkdir)))
1205          (builder '(copy-file "input" %output))
1206          (drv     (build-expression->derivation %store "references-graphs"
1207                                                 builder
1208                                                 #:references-graphs
1209                                                 `(("input" . ,input))))
1210          (out     (derivation->output-path drv)))
1211     (define (deps path . deps)
1212       (let ((count (length deps)))
1213         (string-append path "\n\n" (number->string count) "\n"
1214                        (string-join (sort deps string<?) "\n")
1215                        (if (zero? count) "" "\n"))))
1216
1217     (and (build-derivations %store (list drv))
1218          (equal? (call-with-input-file out get-string-all)
1219                  (string-concatenate
1220                   (map cdr
1221                        (sort (map (lambda (p d)
1222                                     (cons p (apply deps p d)))
1223                                   (list input %bash %mkdir)
1224                                   (list (list %bash %mkdir)
1225                                         '() '()))
1226                              (lambda (x y)
1227                                (match x
1228                                  ((p1 . _)
1229                                   (match y
1230                                     ((p2 . _)
1231                                      (string<? p1 p2)))))))))))))
1232
1233 (test-equal "derivation-properties"
1234   (list '() '((type . test)))
1235   (let ((drv1 (build-expression->derivation %store "bar"
1236                                             '(mkdir %output)))
1237         (drv2 (build-expression->derivation %store "foo"
1238                                            '(mkdir %output)
1239                                            #:properties '((type . test)))))
1240     (list (derivation-properties drv1)
1241           (derivation-properties drv2))))
1242
1243 (test-equal "map-derivation"
1244   "hello"
1245   (let* ((joke (package-derivation %store guile-1.8))
1246          (good (package-derivation %store %bootstrap-guile))
1247          (drv1 (build-expression->derivation %store "original-drv1"
1248                                              #f   ; systematically fail
1249                                              #:guile-for-build joke))
1250          (drv2 (build-expression->derivation %store "original-drv2"
1251                                              '(call-with-output-file %output
1252                                                 (lambda (p)
1253                                                   (display "hello" p)))))
1254          (drv3 (build-expression->derivation %store "drv-to-remap"
1255                                              '(let ((in (assoc-ref
1256                                                          %build-inputs "in")))
1257                                                 (copy-file in %output))
1258                                              #:inputs `(("in" ,drv1))
1259                                              #:guile-for-build joke))
1260          (drv4 (map-derivation %store drv3 `((,drv1 . ,drv2)
1261                                              (,joke . ,good))))
1262          (out  (derivation->output-path drv4)))
1263     (and (build-derivations %store (list (pk 'remapped drv4)))
1264          (call-with-input-file out get-string-all))))
1265
1266 (test-equal "map-derivation, sources"
1267   "hello"
1268   (let* ((script1   (add-text-to-store %store "fail.sh" "exit 1"))
1269          (script2   (add-text-to-store %store "hi.sh" "echo -n hello > $out"))
1270          (bash-full (package-derivation %store (@ (gnu packages bash) bash)))
1271          (drv1      (derivation %store "drv-to-remap"
1272
1273                                 ;; XXX: This wouldn't work in practice, but if
1274                                 ;; we append "/bin/bash" then we can't replace
1275                                 ;; it with the bootstrap bash, which is a
1276                                 ;; single file.
1277                                 (derivation->output-path bash-full)
1278
1279                                 `("-e" ,script1)
1280                                 #:sources (list script1)
1281                                 #:inputs
1282                                 (list (derivation-input bash-full '("out")))))
1283          (drv2      (map-derivation %store drv1
1284                                     `((,bash-full . ,%bash)
1285                                       (,script1 . ,script2))))
1286          (out       (derivation->output-path drv2)))
1287     (and (build-derivations %store (list (pk 'remapped* drv2)))
1288          (call-with-input-file out get-string-all))))
1289
1290 (test-end)
1291
1292 ;; Local Variables:
1293 ;; eval: (put 'with-http-server 'scheme-indent-function 1)
1294 ;; End: