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