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