tests/derivations.scm

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