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