tests/store.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 (define-module (test-store)
  20   #:use-module (guix tests)
  21   #:use-module (guix config)
  22   #:use-module (guix store)
  23   #:use-module (guix utils)
  24   #:use-module (guix monads)
  25   #:use-module (gcrypt hash)
  26   #:use-module (guix base32)
  27   #:use-module (guix packages)
  28   #:use-module (guix derivations)
  29   #:use-module (guix serialization)
  30   #:use-module (guix build utils)
  31   #:use-module (guix gexp)
  32   #:use-module (gnu packages)
  33   #:use-module (gnu packages bootstrap)
  34   #:use-module (ice-9 match)
  35   #:use-module (ice-9 regex)
  36   #:use-module (rnrs bytevectors)
  37   #:use-module (rnrs io ports)
  38   #:use-module (web uri)
  39   #:use-module (srfi srfi-1)
  40   #:use-module (srfi srfi-11)
  41   #:use-module (srfi srfi-26)
  42   #:use-module (srfi srfi-34)
  43   #:use-module (srfi srfi-64))
  44
  45 ;; Test the (guix store) module.
  46
  47 (define %store
  48   (open-connection-for-tests))
  49
  50 (define %shell
  51   (or (getenv "SHELL") (getenv "CONFIG_SHELL")))
  52
  53 \f
  54 (test-begin "store")
  55
  56 (test-assert "open-connection with file:// URI"
  57   (let ((store (open-connection (string-append "file://"
  58                                                (%daemon-socket-uri)))))
  59     (and (add-text-to-store store "foo" "bar")
  60          (begin
  61            (close-connection store)
  62            #t))))
  63
  64 (test-equal "connection handshake error"
  65   EPROTO
  66   (let ((port (%make-void-port "rw")))
  67     (guard (c ((store-connection-error? c)
  68                (and (eq? port (store-connection-error-file c))
  69                     (store-connection-error-code c))))
  70       (open-connection #f #:port port)
  71       'broken)))
  72
  73 (test-equal "store-path-hash-part"
  74   "283gqy39v3g9dxjy26rynl0zls82fmcg"
  75   (store-path-hash-part
  76    (string-append (%store-prefix)
  77                   "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
  78
  79 (test-equal "store-path-hash-part #f"
  80   #f
  81   (store-path-hash-part
  82    (string-append (%store-prefix)
  83                   "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
  84
  85 (test-equal "store-path-package-name"
  86   "guile-2.0.7"
  87   (store-path-package-name
  88    (string-append (%store-prefix)
  89                   "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
  90
  91 (test-equal "store-path-package-name #f"
  92   #f
  93   (store-path-package-name
  94    "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))
  95
  96 (test-assert "direct-store-path?"
  97   (and (direct-store-path?
  98         (string-append (%store-prefix)
  99                        "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))
 100        (not (direct-store-path?
 101              (string-append
 102               (%store-prefix)
 103               "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile")))
 104        (not (direct-store-path? (%store-prefix)))))
 105
 106 (test-skip (if %store 0 15))
 107
 108 (test-equal "profiles/per-user exists and is not writable"
 109   #o755
 110   (stat:perms (stat (string-append %state-directory "/profiles/per-user"))))
 111
 112 (test-equal "profiles/per-user/$USER exists"
 113   (list (getuid) #o755)
 114   (let ((s (stat (string-append %state-directory "/profiles/per-user/"
 115                                 (passwd:name (getpwuid (getuid)))))))
 116     (list (stat:uid s) (stat:perms s))))
 117
 118 (test-equal "add-data-to-store"
 119   #vu8(1 2 3 4 5)
 120   (call-with-input-file (add-data-to-store %store "data" #vu8(1 2 3 4 5))
 121     get-bytevector-all))
 122
 123 (test-assert "valid-path? live"
 124   (let ((p (add-text-to-store %store "hello" "hello, world")))
 125     (valid-path? %store p)))
 126
 127 (test-assert "valid-path? false"
 128   (not (valid-path? %store
 129                     (string-append (%store-prefix) "/"
 130                                    (make-string 32 #\e) "-foobar"))))
 131
 132 (test-assert "valid-path? error"
 133   (with-store s
 134     (guard (c ((store-protocol-error? c) #t))
 135       (valid-path? s "foo")
 136       #f)))
 137
 138 (test-assert "valid-path? recovery"
 139   ;; Prior to Nix commit 51800e0 (18 Mar. 2014), the daemon would immediately
 140   ;; close the connection after receiving a 'valid-path?' RPC with a non-store
 141   ;; file name.  See
 142   ;; <http://article.gmane.org/gmane.linux.distributions.nixos/12411> for
 143   ;; details.
 144   (with-store s
 145     (let-syntax ((true-if-error (syntax-rules ()
 146                                   ((_ exp)
 147                                    (guard (c ((store-protocol-error? c) #t))
 148                                      exp #f)))))
 149       (and (true-if-error (valid-path? s "foo"))
 150            (true-if-error (valid-path? s "bar"))
 151            (true-if-error (valid-path? s "baz"))
 152            (true-if-error (valid-path? s "chbouib"))
 153            (valid-path? s (add-text-to-store s "valid" "yeah"))))))
 154
 155 (test-assert "hash-part->path"
 156   (let ((p (add-text-to-store %store "hello" "hello, world")))
 157     (equal? (hash-part->path %store (store-path-hash-part p))
 158             p)))
 159
 160 (test-assert "dead-paths"
 161   (let ((p (add-text-to-store %store "random-text" (random-text))))
 162     (->bool (member p (dead-paths %store)))))
 163
 164 ;; FIXME: Find a test for `live-paths'.
 165 ;;
 166 ;; (test-assert "temporary root is in live-paths"
 167 ;;   (let* ((p1 (add-text-to-store %store "random-text"
 168 ;;                                 (random-text) '()))
 169 ;;          (b  (add-text-to-store %store "link-builder"
 170 ;;                                 (format #f "echo ~a > $out" p1)
 171 ;;                                 '()))
 172 ;;          (d1 (derivation %store "link"
 173 ;;                          "/bin/sh" `("-e" ,b)
 174 ;;                          #:inputs `((,b) (,p1))))
 175 ;;          (p2 (derivation->output-path d1)))
 176 ;;     (and (add-temp-root %store p2)
 177 ;;          (build-derivations %store (list d1))
 178 ;;          (valid-path? %store p1)
 179 ;;          (member (pk p2) (live-paths %store)))))
 180
 181 (test-assert "permanent root"
 182   (let* ((p  (with-store store
 183                (let ((p (add-text-to-store store "random-text"
 184                                            (random-text))))
 185                  (add-permanent-root p)
 186                  (add-permanent-root p)           ; should not throw
 187                  p))))
 188     (and (member p (live-paths %store))
 189          (begin
 190            (remove-permanent-root p)
 191            (->bool (member p (dead-paths %store)))))))
 192
 193 (test-assert "dead path can be explicitly collected"
 194   (let ((p (add-text-to-store %store "random-text"
 195                               (random-text) '())))
 196     (let-values (((paths freed) (delete-paths %store (list p))))
 197       (and (equal? paths (list p))
 198            ;; XXX: On some file systems (notably Btrfs), freed
 199            ;; may return 0.  See <https://bugs.gnu.org/29363>.
 200            ;;(> freed 0)
 201            (not (file-exists? p))))))
 202
 203 (test-assert "add-text-to-store vs. delete-paths"
 204   ;; Before, 'add-text-to-store' would return PATH2 without noticing that it
 205   ;; is no longer valid.
 206   (with-store store
 207     (let* ((text    (random-text))
 208            (path    (add-text-to-store store "delete-me" text))
 209            (deleted (delete-paths store (list path)))
 210            (path2   (add-text-to-store store "delete-me" text)))
 211       (and (string=? path path2)
 212            (equal? deleted (list path))
 213            (valid-path? store path)
 214            (file-exists? path)))))
 215
 216 (test-assert "add-to-store vs. delete-paths"
 217   ;; Same as above.
 218   (with-store store
 219     (let* ((file    (search-path %load-path "guix.scm"))
 220            (path    (add-to-store store "delete-me" #t "sha256" file))
 221            (deleted (delete-paths store (list path)))
 222            (path2   (add-to-store store "delete-me" #t "sha256" file)))
 223       (and (string=? path path2)
 224            (equal? deleted (list path))
 225            (valid-path? store path)
 226            (file-exists? path)))))
 227
 228 (test-equal "add-file-tree-to-store"
 229   `(42
 230     ("." directory #t)
 231     ("./bar" directory #t)
 232     ("./foo" directory #t)
 233     ("./foo/a" regular "file a")
 234     ("./foo/b" symlink "a")
 235     ("./foo/c" directory #t)
 236     ("./foo/c/p" regular "file p")
 237     ("./foo/c/q" directory #t)
 238     ("./foo/c/q/x" regular
 239      ,(string-append "#!" %shell "\nexit 42"))
 240     ("./foo/c/q/y" symlink "..")
 241     ("./foo/c/q/z" directory #t))
 242   (let* ((tree  `("file-tree" directory
 243                   ("foo" directory
 244                    ("a" regular (data "file a"))
 245                    ("b" symlink "a")
 246                    ("c" directory
 247                     ("p" regular (data ,(string->utf8 "file p")))
 248                     ("q" directory
 249                      ("x" executable
 250                       (data ,(string-append "#!" %shell "\nexit 42")))
 251                      ("y" symlink "..")
 252                      ("z" directory))))
 253                   ("bar" directory)))
 254          (result (add-file-tree-to-store %store tree)))
 255     (cons (status:exit-val (system* (string-append result "/foo/c/q/x")))
 256           (with-directory-excursion result
 257             (map (lambda (file)
 258                    (let ((type (stat:type (lstat file))))
 259                      `(,file ,type
 260                              ,(match type
 261                                 ((or 'regular 'executable)
 262                                  (call-with-input-file file
 263                                    get-string-all))
 264                                 ('symlink (readlink file))
 265                                 ('directory #t)))))
 266                  (find-files "." #:directories? #t))))))
 267
 268 (test-equal "add-file-tree-to-store, flat"
 269   "Hello, world!"
 270   (let* ((tree   `("flat-file" regular (data "Hello, world!")))
 271          (result (add-file-tree-to-store %store tree)))
 272     (and (file-exists? result)
 273          (call-with-input-file result get-string-all))))
 274
 275 (test-assert "references"
 276   (let* ((t1 (add-text-to-store %store "random1"
 277                                 (random-text)))
 278          (t2 (add-text-to-store %store "random2"
 279                                 (random-text) (list t1))))
 280     (and (equal? (list t1) (references %store t2))
 281          (equal? (list t2) (referrers %store t1))
 282          (null? (references %store t1))
 283          (null? (referrers %store t2)))))
 284
 285 (test-assert "references/substitutes missing reference info"
 286   (with-store s
 287     (set-build-options s #:use-substitutes? #f)
 288     (guard (c ((store-protocol-error? c) #t))
 289       (let* ((b  (add-to-store s "bash" #t "sha256"
 290                                (search-bootstrap-binary "bash"
 291                                                         (%current-system))))
 292              (d  (derivation s "the-thing" b '("--help")
 293                              #:inputs `((,b)))))
 294         (references/substitutes s (list (derivation->output-path d) b))
 295         #f))))
 296
 297 (test-assert "references/substitutes with substitute info"
 298   (with-store s
 299     (set-build-options s #:use-substitutes? #t)
 300     (let* ((t1 (add-text-to-store s "random1" (random-text)))
 301            (t2 (add-text-to-store s "random2" (random-text)
 302                                   (list t1)))
 303            (t3 (add-text-to-store s "build" "echo -n $t2 > $out"))
 304            (b  (add-to-store s "bash" #t "sha256"
 305                              (search-bootstrap-binary "bash"
 306                                                       (%current-system))))
 307            (d  (derivation s "the-thing" b `("-e" ,t3)
 308                            #:inputs `((,b) (,t3) (,t2))
 309                            #:env-vars `(("t2" . ,t2))))
 310            (o  (derivation->output-path d)))
 311       (with-derivation-narinfo d
 312         (sha256 => (sha256 (string->utf8 t2)))
 313         (references => (list t2))
 314
 315         (equal? (references/substitutes s (list o t3 t2 t1))
 316                 `((,t2)                           ;refs of O
 317                   ()                              ;refs of T3
 318                   (,t1)                           ;refs of T2
 319                   ()))))))                        ;refs of T1
 320
 321 (test-equal "substitutable-path-info when substitutes are turned off"
 322   '()
 323   (with-store s
 324     (set-build-options s #:use-substitutes? #f)
 325     (let* ((b  (add-to-store s "bash" #t "sha256"
 326                              (search-bootstrap-binary "bash"
 327                                                       (%current-system))))
 328            (d  (derivation s "the-thing" b '("--version")
 329                            #:inputs `((,b))))
 330            (o  (derivation->output-path d)))
 331       (with-derivation-narinfo d
 332         (substitutable-path-info s (list o))))))
 333
 334 (test-equal "substitutable-paths when substitutes are turned off"
 335   '()
 336   (with-store s
 337     (set-build-options s #:use-substitutes? #f)
 338     (let* ((b  (add-to-store s "bash" #t "sha256"
 339                              (search-bootstrap-binary "bash"
 340                                                       (%current-system))))
 341            (d  (derivation s "the-thing" b '("--version")
 342                            #:inputs `((,b))))
 343            (o  (derivation->output-path d)))
 344       (with-derivation-narinfo d
 345         (substitutable-paths s (list o))))))
 346
 347 (test-assert "requisites"
 348   (let* ((t1 (add-text-to-store %store "random1"
 349                                 (random-text) '()))
 350          (t2 (add-text-to-store %store "random2"
 351                                 (random-text) (list t1)))
 352          (t3 (add-text-to-store %store "random3"
 353                                 (random-text) (list t2)))
 354          (t4 (add-text-to-store %store "random4"
 355                                 (random-text) (list t1 t3))))
 356     (define (same? x y)
 357       (and (= (length x) (length y))
 358            (lset= equal? x y)))
 359
 360     (and (same? (requisites %store (list t1)) (list t1))
 361          (same? (requisites %store (list t2)) (list t1 t2))
 362          (same? (requisites %store (list t3)) (list t1 t2 t3))
 363          (same? (requisites %store (list t4)) (list t1 t2 t3 t4))
 364          (same? (requisites %store (list t1 t2 t3 t4))
 365                 (list t1 t2 t3 t4)))))
 366
 367 (test-assert "derivers"
 368   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
 369          (s (add-to-store %store "bash" #t "sha256"
 370                           (search-bootstrap-binary "bash"
 371                                                    (%current-system))))
 372          (d (derivation %store "the-thing"
 373                         s `("-e" ,b)
 374                         #:env-vars `(("foo" . ,(random-text)))
 375                         #:inputs `((,b) (,s))))
 376          (o (derivation->output-path d)))
 377     (and (build-derivations %store (list d))
 378          (equal? (query-derivation-outputs %store (derivation-file-name d))
 379                  (list o))
 380          (equal? (valid-derivers %store o)
 381                  (list (derivation-file-name d))))))
 382
 383 (test-equal "with-build-handler"
 384   'success
 385   (let* ((b  (add-text-to-store %store "build" "echo $foo > $out" '()))
 386          (s  (add-to-store %store "bash" #t "sha256"
 387                            (search-bootstrap-binary "bash"
 388                                                     (%current-system))))
 389          (d1 (derivation %store "the-thing"
 390                          s `("-e" ,b)
 391                          #:env-vars `(("foo" . ,(random-text)))
 392                          #:sources (list b s)))
 393          (d2 (derivation %store "the-thing"
 394                          s `("-e" ,b)
 395                          #:env-vars `(("foo" . ,(random-text))
 396                                       ("bar" . "baz"))
 397                          #:sources (list b s)))
 398          (o1 (derivation->output-path d1))
 399          (o2 (derivation->output-path d2)))
 400     (with-build-handler
 401         (let ((counter 0))
 402           (lambda (continue store things mode)
 403             (match things
 404               ((drv)
 405                (set! counter (+ 1 counter))
 406                (if (string=? drv (derivation-file-name d1))
 407                    (continue #t)
 408                    (and (string=? drv (derivation-file-name d2))
 409                         (= counter 2)
 410                         'success))))))
 411       (build-derivations %store (list d1))
 412       (build-derivations %store (list d2))
 413       'fail)))
 414
 415 (test-equal "with-build-handler + with-store"
 416   'success
 417   ;; Check that STORE remains valid when the build handler invokes CONTINUE,
 418   ;; even though 'with-build-handler' is outside the dynamic extent of
 419   ;; 'with-store'.
 420   (with-build-handler (lambda (continue store things mode)
 421                         (match things
 422                           ((drv)
 423                            (and (string-suffix? "thingie.drv" drv)
 424                                 (not (port-closed?
 425                                       (store-connection-socket store)))
 426                                 (continue #t)))))
 427     (with-store store
 428       (let* ((b (add-text-to-store store "build" "echo $foo > $out" '()))
 429              (s (add-to-store store "bash" #t "sha256"
 430                               (search-bootstrap-binary "bash"
 431                                                        (%current-system))))
 432              (d (derivation store "thingie"
 433                             s `("-e" ,b)
 434                             #:env-vars `(("foo" . ,(random-text)))
 435                             #:sources (list b s))))
 436         (build-derivations store (list d))
 437
 438         ;; Here STORE's socket should still be open.
 439         (and (valid-path? store (derivation->output-path d))
 440              'success)))))
 441
 442 (test-assert "map/accumulate-builds"
 443   (let* ((b  (add-text-to-store %store "build" "echo $foo > $out" '()))
 444          (s  (add-to-store %store "bash" #t "sha256"
 445                            (search-bootstrap-binary "bash"
 446                                                     (%current-system))))
 447          (d1 (derivation %store "the-thing"
 448                          s `("-e" ,b)
 449                          #:env-vars `(("foo" . ,(random-text)))
 450                          #:sources (list b s)))
 451          (d2 (derivation %store "the-thing"
 452                          s `("-e" ,b)
 453                          #:env-vars `(("foo" . ,(random-text))
 454                                       ("bar" . "baz"))
 455                          #:sources (list b s))))
 456     (with-build-handler (lambda (continue store things mode)
 457                           (equal? (map derivation-file-name (list d1 d2))
 458                                   things))
 459       (map/accumulate-builds %store
 460                              (lambda (drv)
 461                                (build-derivations %store (list drv))
 462                                (add-to-store %store "content-addressed"
 463                                              #t "sha256"
 464                                              (derivation->output-path drv)))
 465                              (list d1 d2)))))
 466
 467 (test-assert "mapm/accumulate-builds"
 468   (let* ((d1 (run-with-store %store
 469                (gexp->derivation "foo" #~(mkdir #$output))))
 470          (d2 (run-with-store %store
 471                (gexp->derivation "bar" #~(mkdir #$output)))))
 472     (with-build-handler (lambda (continue store things mode)
 473                           (equal? (map derivation-file-name (pk 'zz (list d1 d2)))
 474                                   (pk 'XX things)))
 475       (run-with-store %store
 476         (mapm/accumulate-builds built-derivations `((,d1) (,d2)))))))
 477
 478 (test-assert "topologically-sorted, one item"
 479   (let* ((a (add-text-to-store %store "a" "a"))
 480          (b (add-text-to-store %store "b" "b" (list a)))
 481          (c (add-text-to-store %store "c" "c" (list b)))
 482          (d (add-text-to-store %store "d" "d" (list c)))
 483          (s (topologically-sorted %store (list d))))
 484     (equal? s (list a b c d))))
 485
 486 (test-assert "topologically-sorted, several items"
 487   (let* ((a  (add-text-to-store %store "a" "a"))
 488          (b  (add-text-to-store %store "b" "b" (list a)))
 489          (c  (add-text-to-store %store "c" "c" (list b)))
 490          (d  (add-text-to-store %store "d" "d" (list c)))
 491          (s1 (topologically-sorted %store (list d a c b)))
 492          (s2 (topologically-sorted %store (list b d c a b d))))
 493     (equal? s1 s2 (list a b c d))))
 494
 495 (test-assert "topologically-sorted, more difficult"
 496   (let* ((a  (add-text-to-store %store "a" "a"))
 497          (b  (add-text-to-store %store "b" "b" (list a)))
 498          (c  (add-text-to-store %store "c" "c" (list b)))
 499          (d  (add-text-to-store %store "d" "d" (list c)))
 500          (w  (add-text-to-store %store "w" "w"))
 501          (x  (add-text-to-store %store "x" "x" (list w)))
 502          (y  (add-text-to-store %store "y" "y" (list x d)))
 503          (s1 (topologically-sorted %store (list y)))
 504          (s2 (topologically-sorted %store (list c y)))
 505          (s3 (topologically-sorted %store (cons y (references %store y)))))
 506     ;; The order in which 'references' returns the references of Y is
 507     ;; unspecified, so accommodate.
 508     (let* ((x-then-d? (equal? (references %store y) (list x d))))
 509       (and (equal? s1
 510                    (if x-then-d?
 511                        (list w x a b c d y)
 512                        (list a b c d w x y)))
 513            (equal? s2
 514                    (if x-then-d?
 515                        (list a b c w x d y)
 516                        (list a b c d w x y)))
 517            (lset= string=? s1 s3)))))
 518
 519 (test-assert "current-build-output-port, UTF-8"
 520   ;; Are UTF-8 strings in the build log properly interpreted?
 521   (string-contains
 522    (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
 523      (call-with-output-string
 524       (lambda (port)
 525         (parameterize ((current-build-output-port port))
 526           (let* ((s "Here’s a Greek letter: λ.")
 527                  (d (build-expression->derivation
 528                      %store "foo" `(display ,s)
 529                      #:guile-for-build
 530                      (package-derivation s %bootstrap-guile (%current-system)))))
 531             (guard (c ((store-protocol-error? c) #t))
 532               (build-derivations %store (list d))))))))
 533    "Here’s a Greek letter: λ."))
 534
 535 (test-assert "current-build-output-port, UTF-8 + garbage"
 536   ;; What about a mixture of UTF-8 + garbage?
 537   (string-contains
 538    (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
 539      (call-with-output-string
 540       (lambda (port)
 541         (parameterize ((current-build-output-port port))
 542           (let ((d (build-expression->derivation
 543                     %store "foo"
 544                     `(begin
 545                        (use-modules (rnrs io ports))
 546                        (display "garbage: ")
 547                        (put-bytevector (current-output-port) #vu8(128))
 548                        (display "lambda: λ\n"))
 549                      #:guile-for-build
 550                      (package-derivation %store %bootstrap-guile))))
 551             (guard (c ((store-protocol-error? c) #t))
 552               (build-derivations %store (list d))))))))
 553    "garbage: �lambda: λ"))
 554
 555 (test-assert "log-file, derivation"
 556   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
 557          (s (add-to-store %store "bash" #t "sha256"
 558                           (search-bootstrap-binary "bash"
 559                                                    (%current-system))))
 560          (d (derivation %store "the-thing"
 561                         s `("-e" ,b)
 562                         #:env-vars `(("foo" . ,(random-text)))
 563                         #:inputs `((,b) (,s)))))
 564     (and (build-derivations %store (list d))
 565          (file-exists? (pk (log-file %store (derivation-file-name d)))))))
 566
 567 (test-assert "log-file, output file name"
 568   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
 569          (s (add-to-store %store "bash" #t "sha256"
 570                           (search-bootstrap-binary "bash"
 571                                                    (%current-system))))
 572          (d (derivation %store "the-thing"
 573                         s `("-e" ,b)
 574                         #:env-vars `(("foo" . ,(random-text)))
 575                         #:inputs `((,b) (,s))))
 576          (o (derivation->output-path d)))
 577     (and (build-derivations %store (list d))
 578          (file-exists? (pk (log-file %store o)))
 579          (string=? (log-file %store (derivation-file-name d))
 580                    (log-file %store o)))))
 581
 582 (test-assert "no substitutes"
 583   (with-store s
 584     (let* ((d1 (package-derivation s %bootstrap-guile (%current-system)))
 585            (d2 (package-derivation s %bootstrap-glibc (%current-system)))
 586            (o  (map derivation->output-path (list d1 d2))))
 587       (set-build-options s #:use-substitutes? #f)
 588       (and (not (has-substitutes? s (derivation-file-name d1)))
 589            (not (has-substitutes? s (derivation-file-name d2)))
 590            (null? (substitutable-paths s o))
 591            (null? (substitutable-path-info s o))))))
 592
 593 (test-assert "build-things with output path"
 594   (with-store s
 595     (let* ((c   (random-text))                    ;contents of the output
 596            (d   (build-expression->derivation
 597                  s "substitute-me"
 598                  `(call-with-output-file %output
 599                     (lambda (p)
 600                       (display ,c p)))
 601                  #:guile-for-build
 602                  (package-derivation s %bootstrap-guile (%current-system))))
 603            (o   (derivation->output-path d)))
 604       (set-build-options s #:use-substitutes? #f)
 605
 606       ;; Pass 'build-things' the output file name, O.  However, since there
 607       ;; are no substitutes for O, it will just do nothing.
 608       (build-things s (list o))
 609       (not (valid-path? s o)))))
 610
 611 (test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))
 612
 613 (test-assert "substitute query"
 614   (with-store s
 615     (let* ((d (package-derivation s %bootstrap-guile (%current-system)))
 616            (o (derivation->output-path d)))
 617       ;; Create fake substituter data, to be read by 'guix substitute'.
 618       (with-derivation-narinfo d
 619         ;; Remove entry from the local cache.
 620         (false-if-exception
 621          (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
 622                                                  "/guix/substitute")))
 623
 624         ;; Make sure 'guix substitute' correctly communicates the above
 625         ;; data.
 626         (set-build-options s #:use-substitutes? #t
 627                            #:substitute-urls (%test-substitute-urls))
 628         (and (has-substitutes? s o)
 629              (equal? (list o) (substitutable-paths s (list o)))
 630              (match (pk 'spi (substitutable-path-info s (list o)))
 631                (((? substitutable? s))
 632                 (and (string=? (substitutable-deriver s)
 633                                (derivation-file-name d))
 634                      (null? (substitutable-references s))
 635                      (equal? (substitutable-nar-size s) 1234)))))))))
 636
 637 (test-assert "substitute query, alternating URLs"
 638   (let* ((d (with-store s
 639               (package-derivation s %bootstrap-guile (%current-system))))
 640          (o (derivation->output-path d)))
 641     (with-derivation-narinfo d
 642       ;; Remove entry from the local cache.
 643       (false-if-exception
 644        (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
 645                                                "/guix/substitute")))
 646
 647       ;; Note: We reconnect to the daemon to force a new instance of 'guix
 648       ;; substitute' to be used; otherwise the #:substitute-urls of
 649       ;; 'set-build-options' would have no effect.
 650
 651       (and (with-store s                        ;the right substitute URL
 652              (set-build-options s #:use-substitutes? #t
 653                                 #:substitute-urls (%test-substitute-urls))
 654              (has-substitutes? s o))
 655            (with-store s                        ;the wrong one
 656              (set-build-options s #:use-substitutes? #t
 657                                 #:substitute-urls (list
 658                                                    "http://does-not-exist"))
 659              (not (has-substitutes? s o)))
 660            (with-store s                        ;the right one again
 661              (set-build-options s #:use-substitutes? #t
 662                                 #:substitute-urls (%test-substitute-urls))
 663              (has-substitutes? s o))
 664            (with-store s                        ;empty list of URLs
 665              (set-build-options s #:use-substitutes? #t
 666                                 #:substitute-urls '())
 667              (not (has-substitutes? s o)))))))
 668
 669 (test-assert "substitute"
 670   (with-store s
 671     (let* ((c   (random-text))                     ; contents of the output
 672            (d   (build-expression->derivation
 673                  s "substitute-me"
 674                  `(call-with-output-file %output
 675                     (lambda (p)
 676                       (exit 1)                     ; would actually fail
 677                       (display ,c p)))
 678                  #:guile-for-build
 679                  (package-derivation s %bootstrap-guile (%current-system))))
 680            (o   (derivation->output-path d)))
 681       (with-derivation-substitute d c
 682         (set-build-options s #:use-substitutes? #t
 683                            #:substitute-urls (%test-substitute-urls))
 684         (and (has-substitutes? s o)
 685              (build-derivations s (list d))
 686              (equal? c (call-with-input-file o get-string-all)))))))
 687
 688 (test-assert "substitute + build-things with output path"
 689   (with-store s
 690     (let* ((c   (random-text))                    ;contents of the output
 691            (d   (build-expression->derivation
 692                  s "substitute-me"
 693                  `(call-with-output-file %output
 694                     (lambda (p)
 695                       (exit 1)                    ;would actually fail
 696                       (display ,c p)))
 697                  #:guile-for-build
 698                  (package-derivation s %bootstrap-guile (%current-system))))
 699            (o   (derivation->output-path d)))
 700       (with-derivation-substitute d c
 701         (set-build-options s #:use-substitutes? #t
 702                            #:substitute-urls (%test-substitute-urls))
 703         (and (has-substitutes? s o)
 704              (build-things s (list o))            ;give the output path
 705              (valid-path? s o)
 706              (equal? c (call-with-input-file o get-string-all)))))))
 707
 708 (test-assert "substitute + build-things with specific output"
 709   (with-store s
 710     (let* ((c   (random-text))                    ;contents of the output
 711            (d   (build-expression->derivation
 712                  s "substitute-me" `(begin ,c (exit 1)) ;would fail
 713                  #:outputs '("out" "one" "two")
 714                  #:guile-for-build
 715                  (package-derivation s %bootstrap-guile (%current-system))))
 716            (o   (derivation->output-path d)))
 717       (with-derivation-substitute d c
 718         (set-build-options s #:use-substitutes? #t
 719                            #:substitute-urls (%test-substitute-urls))
 720         (and (has-substitutes? s o)
 721
 722              ;; Ask for nothing but the "out" output of D.
 723              (build-things s `((,(derivation-file-name d) . "out")))
 724
 725              (valid-path? s o)
 726              (equal? c (call-with-input-file o get-string-all)))))))
 727
 728 (test-assert "substitute, corrupt output hash"
 729   ;; Tweak the substituter into installing a substitute whose hash doesn't
 730   ;; match the one announced in the narinfo.  The daemon must notice this and
 731   ;; raise an error.
 732   (with-store s
 733     (let* ((c   "hello, world")                    ; contents of the output
 734            (d   (build-expression->derivation
 735                  s "corrupt-substitute"
 736                  `(mkdir %output)
 737                  #:guile-for-build
 738                  (package-derivation s %bootstrap-guile (%current-system))))
 739            (o   (derivation->output-path d)))
 740       (with-derivation-substitute d c
 741         (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C
 742
 743         ;; Make sure we use 'guix substitute'.
 744         (set-build-options s
 745                            #:use-substitutes? #t
 746                            #:fallback? #f
 747                            #:substitute-urls (%test-substitute-urls))
 748         (and (has-substitutes? s o)
 749              (guard (c ((store-protocol-error? c)
 750                         ;; XXX: the daemon writes "hash mismatch in downloaded
 751                         ;; path", but the actual error returned to the client
 752                         ;; doesn't mention that.
 753                         (pk 'corrupt c)
 754                         (not (zero? (store-protocol-error-status c)))))
 755                (build-derivations s (list d))
 756                #f))))))
 757
 758 (test-assert "substitute --fallback"
 759   (with-store s
 760     (let* ((t   (random-text))                    ; contents of the output
 761            (d   (build-expression->derivation
 762                  s "substitute-me-not"
 763                  `(call-with-output-file %output
 764                     (lambda (p)
 765                       (display ,t p)))
 766                  #:guile-for-build
 767                  (package-derivation s %bootstrap-guile (%current-system))))
 768            (o   (derivation->output-path d)))
 769       ;; Create fake substituter data, to be read by 'guix substitute'.
 770       (with-derivation-narinfo d
 771         ;; Make sure we use 'guix substitute'.
 772         (set-build-options s #:use-substitutes? #t
 773                            #:substitute-urls (%test-substitute-urls))
 774         (and (has-substitutes? s o)
 775              (guard (c ((store-protocol-error? c)
 776                         ;; The substituter failed as expected.  Now make
 777                         ;; sure that #:fallback? #t works correctly.
 778                         (set-build-options s
 779                                            #:use-substitutes? #t
 780                                            #:substitute-urls
 781                                              (%test-substitute-urls)
 782                                            #:fallback? #t)
 783                         (and (build-derivations s (list d))
 784                              (equal? t (call-with-input-file o
 785                                          get-string-all)))))
 786                ;; Should fail.
 787                (build-derivations s (list d))
 788                #f))))))
 789
 790 (test-assert "export/import several paths"
 791   (let* ((texts (unfold (cut >= <> 10)
 792                         (lambda _ (random-text))
 793                         1+
 794                         0))
 795          (files (map (cut add-text-to-store %store "text" <>) texts))
 796          (dump  (call-with-bytevector-output-port
 797                  (cut export-paths %store files <>))))
 798     (delete-paths %store files)
 799     (and (every (negate file-exists?) files)
 800          (let* ((source   (open-bytevector-input-port dump))
 801                 (imported (import-paths %store source)))
 802            (and (equal? imported files)
 803                 (every file-exists? files)
 804                 (equal? texts
 805                         (map (lambda (file)
 806                                (call-with-input-file file
 807                                  get-string-all))
 808                              files)))))))
 809
 810 (test-assert "export/import paths, ensure topological order"
 811   (let* ((file0 (add-text-to-store %store "baz" (random-text)))
 812          (file1 (add-text-to-store %store "foo" (random-text)
 813                                    (list file0)))
 814          (file2 (add-text-to-store %store "bar" (random-text)
 815                                    (list file1)))
 816          (files (list file1 file2))
 817          (dump1 (call-with-bytevector-output-port
 818                  (cute export-paths %store (list file1 file2) <>)))
 819          (dump2 (call-with-bytevector-output-port
 820                  (cute export-paths %store (list file2 file1) <>))))
 821     (delete-paths %store files)
 822     (and (every (negate file-exists?) files)
 823          (bytevector=? dump1 dump2)
 824          (let* ((source   (open-bytevector-input-port dump1))
 825                 (imported (import-paths %store source)))
 826            ;; DUMP1 should contain exactly FILE1 and FILE2, not FILE0.
 827            (and (equal? imported (list file1 file2))
 828                 (every file-exists? files)
 829                 (equal? (list file0) (references %store file1))
 830                 (equal? (list file1) (references %store file2)))))))
 831
 832 (test-assert "export/import incomplete"
 833   (let* ((file0 (add-text-to-store %store "baz" (random-text)))
 834          (file1 (add-text-to-store %store "foo" (random-text)
 835                                    (list file0)))
 836          (file2 (add-text-to-store %store "bar" (random-text)
 837                                    (list file1)))
 838          (dump  (call-with-bytevector-output-port
 839                  (cute export-paths %store (list file2) <>))))
 840     (delete-paths %store (list file0 file1 file2))
 841     (guard (c ((store-protocol-error? c)
 842                (and (not (zero? (store-protocol-error-status c)))
 843                     (string-contains (store-protocol-error-message c)
 844                                      "not valid"))))
 845       ;; Here we get an exception because DUMP does not include FILE0 and
 846       ;; FILE1, which are dependencies of FILE2.
 847       (import-paths %store (open-bytevector-input-port dump)))))
 848
 849 (test-assert "export/import recursive"
 850   (let* ((file0 (add-text-to-store %store "baz" (random-text)))
 851          (file1 (add-text-to-store %store "foo" (random-text)
 852                                    (list file0)))
 853          (file2 (add-text-to-store %store "bar" (random-text)
 854                                    (list file1)))
 855          (dump  (call-with-bytevector-output-port
 856                  (cute export-paths %store (list file2) <>
 857                        #:recursive? #t))))
 858     (delete-paths %store (list file0 file1 file2))
 859     (let ((imported (import-paths %store (open-bytevector-input-port dump))))
 860       (and (equal? imported (list file0 file1 file2))
 861            (every file-exists? (list file0 file1 file2))
 862            (equal? (list file0) (references %store file1))
 863            (equal? (list file1) (references %store file2))))))
 864
 865 (test-assert "write-file & export-path yield the same result"
 866   ;; Here we compare 'write-file' and the daemon's own implementation.
 867   ;; 'write-file' is the reference because we know it sorts file
 868   ;; deterministically.  Conversely, the daemon uses 'readdir' and the entries
 869   ;; currently happen to be sorted as a side-effect of some unrelated
 870   ;; operation (search for 'unhacked' in archive.cc.)  Make sure we detect any
 871   ;; changes there.
 872   (run-with-store %store
 873     (mlet* %store-monad ((drv1 (package->derivation %bootstrap-guile))
 874                          (out1 -> (derivation->output-path drv1))
 875                          (data -> (unfold (cut >= <> 26)
 876                                           (lambda (i)
 877                                             (random-bytevector 128))
 878                                           1+ 0))
 879                          (build
 880                           -> #~(begin
 881                                  (use-modules (rnrs io ports) (srfi srfi-1))
 882                                  (let ()
 883                                    (define letters
 884                                      (map (lambda (i)
 885                                             (string
 886                                              (integer->char
 887                                               (+ i (char->integer #\a)))))
 888                                           (iota 26)))
 889                                    (define (touch file data)
 890                                      (call-with-output-file file
 891                                        (lambda (port)
 892                                          (put-bytevector port data))))
 893
 894                                    (mkdir #$output)
 895                                    (chdir #$output)
 896
 897                                    ;; The files must be different so they have
 898                                    ;; different inode numbers, and the inode
 899                                    ;; order must differ from the lexicographic
 900                                    ;; order.
 901                                    (for-each touch
 902                                              (append (drop letters 10)
 903                                                      (take letters 10))
 904                                              (list #$@data))
 905                                    #t)))
 906                          (drv2 (gexp->derivation "bunch" build))
 907                          (out2 -> (derivation->output-path drv2))
 908                          (item-info -> (store-lift query-path-info)))
 909       (mbegin %store-monad
 910         (built-derivations (list drv1 drv2))
 911         (foldm %store-monad
 912                (lambda (item result)
 913                  (define ref-hash
 914                    (let-values (((port get) (open-sha256-port)))
 915                      (write-file item port)
 916                      (close-port port)
 917                      (get)))
 918
 919                  ;; 'query-path-info' returns a hash produced by using the
 920                  ;; daemon's C++ 'dump' function, which is the implementation
 921                  ;; under test.
 922                  (>>= (item-info item)
 923                       (lambda (info)
 924                         (return
 925                          (and result
 926                               (bytevector=? (path-info-hash info) ref-hash))))))
 927                #t
 928                (list out1 out2))))
 929     #:guile-for-build (%guile-for-build)))
 930
 931 (test-assert "import corrupt path"
 932   (let* ((text (random-text))
 933          (file (add-text-to-store %store "text" text))
 934          (dump (call-with-bytevector-output-port
 935                 (cut export-paths %store (list file) <>))))
 936     (delete-paths %store (list file))
 937
 938     ;; Flip a bit in the stream's payload.  INDEX here falls in the middle of
 939     ;; the file contents in DUMP, regardless of the store prefix.
 940     (let* ((index #x70)
 941            (byte  (bytevector-u8-ref dump index)))
 942       (bytevector-u8-set! dump index (logxor #xff byte)))
 943
 944     (and (not (file-exists? file))
 945          (guard (c ((store-protocol-error? c)
 946                     (pk 'c c)
 947                     (and (not (zero? (store-protocol-error-status c)))
 948                          (string-contains (store-protocol-error-message c)
 949                                           "corrupt"))))
 950            (let* ((source   (open-bytevector-input-port dump))
 951                   (imported (import-paths %store source)))
 952              (pk 'corrupt-imported imported)
 953              #f)))))
 954
 955 (test-assert "verify-store"
 956   (let* ((text  (random-text))
 957          (file1 (add-text-to-store %store "foo" text))
 958          (file2 (add-text-to-store %store "bar" (random-text)
 959                                    (list file1))))
 960     (and (pk 'verify1 (verify-store %store))    ;hopefully OK ;
 961          (begin
 962            (delete-file file1)
 963            (not (pk 'verify2 (verify-store %store)))) ;bad! ;
 964          (begin
 965            ;; Using 'add-text-to-store' here wouldn't work: It would succeed ;
 966            ;; without actually creating the file. ;
 967            (call-with-output-file file1
 968              (lambda (port)
 969                (display text port)))
 970            (pk 'verify3 (verify-store %store)))))) ;OK again
 971
 972 (test-assert "verify-store + check-contents"
 973   ;; XXX: This test is I/O intensive.
 974   (with-store s
 975     (let* ((text (random-text))
 976            (drv  (build-expression->derivation
 977                   s "corrupt"
 978                   `(let ((out (assoc-ref %outputs "out")))
 979                      (call-with-output-file out
 980                        (lambda (port)
 981                          (display ,text port)))
 982                      #t)
 983                   #:guile-for-build
 984                   (package-derivation s %bootstrap-guile (%current-system))))
 985            (file (derivation->output-path drv)))
 986       (with-derivation-substitute drv text
 987         (and (build-derivations s (list drv))
 988              (verify-store s #:check-contents? #t) ;should be OK
 989              (begin
 990                (chmod file #o644)
 991                (call-with-output-file file
 992                  (lambda (port)
 993                    (display "corrupt!" port)))
 994                #t)
 995
 996              ;; Make sure the corruption is detected.  We don't test repairing
 997              ;; because only "trusted" users are allowed to do it, but we
 998              ;; don't expose that notion of trusted users that nix-daemon
 999              ;; supports because it seems dubious and redundant with what the
1000              ;; OS provides (in Nix "trusted" users have additional
1001              ;; privileges, such as overriding the set of substitute URLs, but
1002              ;; we instead want to allow anyone to modify them, provided
1003              ;; substitutes are signed by a root-approved key.)
1004              (not (verify-store s #:check-contents? #t))
1005
1006              ;; Delete the corrupt item to leave the store in a clean state.
1007              (delete-paths s (list file)))))))
1008
1009 (test-assert "build-things, check mode"
1010   (with-store store
1011     (call-with-temporary-output-file
1012      (lambda (entropy entropy-port)
1013        (write (random-text) entropy-port)
1014        (force-output entropy-port)
1015        (let* ((drv  (build-expression->derivation
1016                      store "non-deterministic"
1017                      `(begin
1018                         (use-modules (rnrs io ports))
1019                         (let ((out (assoc-ref %outputs "out")))
1020                           (call-with-output-file out
1021                             (lambda (port)
1022                               ;; Rely on the fact that tests do not use the
1023                               ;; chroot, and thus ENTROPY is readable.
1024                               (display (call-with-input-file ,entropy
1025                                          get-string-all)
1026                                        port)))
1027                           #t))
1028                      #:guile-for-build
1029                      (package-derivation store %bootstrap-guile (%current-system))))
1030               (file (derivation->output-path drv)))
1031          (and (build-things store (list (derivation-file-name drv)))
1032               (begin
1033                 (write (random-text) entropy-port)
1034                 (force-output entropy-port)
1035                 (guard (c ((store-protocol-error? c)
1036                            (pk 'determinism-exception c)
1037                            (and (not (zero? (store-protocol-error-status c)))
1038                                 (string-contains (store-protocol-error-message c)
1039                                                  "deterministic"))))
1040                   ;; This one will produce a different result.  Since we're in
1041                   ;; 'check' mode, this must fail.
1042                   (build-things store (list (derivation-file-name drv))
1043                                 (build-mode check))
1044                   #f))))))))
1045
1046 (test-assert "build-succeeded trace in check mode"
1047   (string-contains
1048    (call-with-output-string
1049      (lambda (port)
1050        (let ((d (build-expression->derivation
1051                  %store "foo" '(mkdir (assoc-ref %outputs "out"))
1052                  #:guile-for-build
1053                  (package-derivation %store %bootstrap-guile))))
1054          (build-derivations %store (list d))
1055          (parameterize ((current-build-output-port port))
1056            (build-derivations %store (list d) (build-mode check))))))
1057    "@ build-succeeded"))
1058
1059 (test-assert "build multiple times"
1060   (with-store store
1061     ;; Ask to build twice.
1062     (set-build-options store #:rounds 2 #:use-substitutes? #f)
1063
1064     (call-with-temporary-output-file
1065      (lambda (entropy entropy-port)
1066        (write (random-text) entropy-port)
1067        (force-output entropy-port)
1068        (let* ((drv  (build-expression->derivation
1069                      store "non-deterministic"
1070                      `(begin
1071                         (use-modules (rnrs io ports))
1072                         (let ((out (assoc-ref %outputs "out")))
1073                           (call-with-output-file out
1074                             (lambda (port)
1075                               ;; Rely on the fact that tests do not use the
1076                               ;; chroot, and thus ENTROPY is accessible.
1077                               (display (call-with-input-file ,entropy
1078                                          get-string-all)
1079                                        port)
1080                               (call-with-output-file ,entropy
1081                                 (lambda (port)
1082                                   (write 'foobar port)))))
1083                           #t))
1084                      #:guile-for-build
1085                      (package-derivation store %bootstrap-guile (%current-system))))
1086               (file (derivation->output-path drv)))
1087          (guard (c ((store-protocol-error? c)
1088                     (pk 'multiple-build c)
1089                     (and (not (zero? (store-protocol-error-status c)))
1090                          (string-contains (store-protocol-error-message c)
1091                                           "deterministic"))))
1092            ;; This one will produce a different result on the second run.
1093            (current-build-output-port (current-error-port))
1094            (build-things store (list (derivation-file-name drv)))
1095            #f))))))
1096
1097 (test-equal "store-lower"
1098   "Lowered."
1099   (let* ((add  (store-lower text-file))
1100          (file (add %store "foo" "Lowered.")))
1101     (call-with-input-file file get-string-all)))
1102
1103 (test-equal "current-system"
1104   "bar"
1105   (parameterize ((%current-system "frob"))
1106     (run-with-store %store
1107       (mbegin %store-monad
1108         (set-current-system "bar")
1109         (current-system))
1110       #:system "foo")))
1111
1112 (test-assert "query-path-info"
1113   (let* ((ref (add-text-to-store %store "ref" "foo"))
1114          (item (add-text-to-store %store "item" "bar" (list ref)))
1115          (info (query-path-info %store item)))
1116     (and (equal? (path-info-references info) (list ref))
1117          (equal? (path-info-hash info)
1118                  (sha256
1119                   (string->utf8
1120                    (call-with-output-string (cut write-file item <>))))))))
1121
1122 (test-assert "path-info-deriver"
1123   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
1124          (s (add-to-store %store "bash" #t "sha256"
1125                           (search-bootstrap-binary "bash"
1126                                                    (%current-system))))
1127          (d (derivation %store "the-thing"
1128                         s `("-e" ,b)
1129                         #:env-vars `(("foo" . ,(random-text)))
1130                         #:inputs `((,b) (,s))))
1131          (o (derivation->output-path d)))
1132     (and (build-derivations %store (list d))
1133          (not (path-info-deriver (query-path-info %store b)))
1134          (string=? (derivation-file-name d)
1135                    (path-info-deriver (query-path-info %store o))))))
1136
1137 (test-equal "build-cores"
1138   (list 0 42)
1139   (with-store store
1140     (let* ((build  (add-text-to-store store "build.sh"
1141                                       "echo $NIX_BUILD_CORES > $out"))
1142            (bash   (add-to-store store "bash" #t "sha256"
1143                                  (search-bootstrap-binary "bash"
1144                                                           (%current-system))))
1145            (drv1   (derivation store "the-thing" bash
1146                                `("-e" ,build)
1147                                #:inputs `((,bash) (,build))
1148                                #:env-vars `(("x" . ,(random-text)))))
1149            (drv2   (derivation store "the-thing" bash
1150                                `("-e" ,build)
1151                                #:inputs `((,bash) (,build))
1152                                #:env-vars `(("x" . ,(random-text))))))
1153       (and (build-derivations store (list drv1))
1154            (begin
1155              (set-build-options store #:build-cores 42)
1156              (build-derivations store (list drv2)))
1157            (list (call-with-input-file (derivation->output-path drv1)
1158                    read)
1159                  (call-with-input-file (derivation->output-path drv2)
1160                    read))))))
1161
1162 (test-equal "multiplexed-build-output"
1163   '("Hello from first." "Hello from second.")
1164   (with-store store
1165     (let* ((build  (add-text-to-store store "build.sh"
1166                                       "echo Hello from $NAME.; echo > $out"))
1167            (bash   (add-to-store store "bash" #t "sha256"
1168                                  (search-bootstrap-binary "bash"
1169                                                           (%current-system))))
1170            (drv1   (derivation store "one" bash
1171                                `("-e" ,build)
1172                                #:inputs `((,bash) (,build))
1173                                #:env-vars `(("NAME" . "first")
1174                                             ("x" . ,(random-text)))))
1175            (drv2   (derivation store "two" bash
1176                                `("-e" ,build)
1177                                #:inputs `((,bash) (,build))
1178                                #:env-vars `(("NAME" . "second")
1179                                             ("x" . ,(random-text))))))
1180       (set-build-options store
1181                          #:print-build-trace #t
1182                          #:multiplexed-build-output? #t
1183                          #:max-build-jobs 10)
1184       (let ((port (open-output-string)))
1185         ;; Send the build log to PORT.
1186         (parameterize ((current-build-output-port port))
1187           (build-derivations store (list drv1 drv2)))
1188
1189         ;; Retrieve the build log; make sure it contains valid "@ build-log"
1190         ;; traces that allow us to retrieve each builder's output (we assume
1191         ;; there's exactly one "build-output" trace for each builder, which is
1192         ;; reasonable.)
1193         (let* ((log     (get-output-string port))
1194                (started (fold-matches
1195                          (make-regexp "@ build-started ([^ ]+) - ([^ ]+) ([^ ]+) ([0-9]+)")
1196                          log '() cons))
1197                (done    (fold-matches
1198                          (make-regexp "@ build-succeeded (.*) - (.*) (.*) (.*)")
1199                          log '() cons))
1200                (output  (fold-matches
1201                          (make-regexp "@ build-log ([[:digit:]]+) ([[:digit:]]+)\n([A-Za-z .*]+)\n")
1202                          log '() cons))
1203                (drv-pid (lambda (name)
1204                           (lambda (m)
1205                             (let ((drv (match:substring m 1))
1206                                   (pid (string->number
1207                                         (match:substring m 4))))
1208                               (and (string-suffix? name drv) pid)))))
1209                (pid-log (lambda (pid)
1210                           (lambda (m)
1211                             (let ((n   (string->number
1212                                         (match:substring m 1)))
1213                                   (len (string->number
1214                                         (match:substring m 2)))
1215                                   (str (match:substring m 3)))
1216                               (and (= pid n)
1217                                    (= (string-length str) (- len 1))
1218                                    str)))))
1219                (pid1    (any (drv-pid "one.drv") started))
1220                (pid2    (any (drv-pid "two.drv") started)))
1221           (list (any (pid-log pid1) output)
1222                 (any (pid-log pid2) output)))))))
1223
1224 (test-end "store")