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