tests/store.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 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") "/bin/sh"))
  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 "add-indirect-root and find-roots"
 205   (call-with-temporary-directory
 206    (lambda (directory)
 207      (let* ((item (add-text-to-store %store "something" (random-text)))
 208             (root (string-append directory "/gc-root")))
 209        (symlink item root)
 210        (add-indirect-root %store root)
 211        (let ((result (member (cons root item) (find-roots %store))))
 212          (delete-file root)
 213          result)))))
 214
 215 (test-assert "permanent root"
 216   (let* ((p  (with-store store
 217                (let ((p (add-text-to-store store "random-text"
 218                                            (random-text))))
 219                  (add-permanent-root p)
 220                  (add-permanent-root p)           ; should not throw
 221                  p))))
 222     (and (member p (live-paths %store))
 223          (begin
 224            (remove-permanent-root p)
 225            (->bool (member p (dead-paths %store)))))))
 226
 227 (test-assert "dead path can be explicitly collected"
 228   (let ((p (add-text-to-store %store "random-text"
 229                               (random-text) '())))
 230     (let-values (((paths freed) (delete-paths %store (list p))))
 231       (and (equal? paths (list p))
 232            ;; XXX: On some file systems (notably Btrfs), freed
 233            ;; may return 0.  See <https://bugs.gnu.org/29363>.
 234            ;;(> freed 0)
 235            (not (file-exists? p))))))
 236
 237 (test-assert "add-text-to-store/add-to-store vs. delete-paths"
 238   ;; Before, 'add-text-to-store' and 'add-to-store' would return the same
 239   ;; store item without noticing that it is no longer valid.
 240   (with-store store
 241     (let* ((text    (random-text))
 242            (file    (search-path %load-path "guix.scm"))
 243            (path1   (add-text-to-store store "delete-me" text))
 244            (path2   (add-to-store store "delete-me" #t "sha256" file))
 245            (deleted (delete-paths store (list path1 path2))))
 246       (and (string=? path1 (add-text-to-store store "delete-me" text))
 247            (string=? path2 (add-to-store store "delete-me" #t "sha256" file))
 248            (lset= string=? deleted (list path1 path2))
 249            (valid-path? store path1)
 250            (valid-path? store path2)
 251            (file-exists? path1)
 252            (file-exists? path2)))))
 253
 254 (test-equal "add-file-tree-to-store"
 255   `(42
 256     ("." directory #t)
 257     ("./bar" directory #t)
 258     ("./foo" directory #t)
 259     ("./foo/a" regular "file a")
 260     ("./foo/b" symlink "a")
 261     ("./foo/c" directory #t)
 262     ("./foo/c/p" regular "file p")
 263     ("./foo/c/q" directory #t)
 264     ("./foo/c/q/x" regular
 265      ,(string-append "#!" %shell "\nexit 42"))
 266     ("./foo/c/q/y" symlink "..")
 267     ("./foo/c/q/z" directory #t))
 268   (let* ((tree  `("file-tree" directory
 269                   ("foo" directory
 270                    ("a" regular (data "file a"))
 271                    ("b" symlink "a")
 272                    ("c" directory
 273                     ("p" regular (data ,(string->utf8 "file p")))
 274                     ("q" directory
 275                      ("x" executable
 276                       (data ,(string-append "#!" %shell "\nexit 42")))
 277                      ("y" symlink "..")
 278                      ("z" directory))))
 279                   ("bar" directory)))
 280          (result (add-file-tree-to-store %store tree)))
 281     (cons (status:exit-val (system* (string-append result "/foo/c/q/x")))
 282           (with-directory-excursion result
 283             (map (lambda (file)
 284                    (let ((type (stat:type (lstat file))))
 285                      `(,file ,type
 286                              ,(match type
 287                                 ((or 'regular 'executable)
 288                                  (call-with-input-file file
 289                                    get-string-all))
 290                                 ('symlink (readlink file))
 291                                 ('directory #t)))))
 292                  (find-files "." #:directories? #t))))))
 293
 294 (test-equal "add-file-tree-to-store, flat"
 295   "Hello, world!"
 296   (let* ((tree   `("flat-file" regular (data "Hello, world!")))
 297          (result (add-file-tree-to-store %store tree)))
 298     (and (file-exists? result)
 299          (call-with-input-file result get-string-all))))
 300
 301 (test-assert "references"
 302   (let* ((t1 (add-text-to-store %store "random1"
 303                                 (random-text)))
 304          (t2 (add-text-to-store %store "random2"
 305                                 (random-text) (list t1))))
 306     (and (equal? (list t1) (references %store t2))
 307          (equal? (list t2) (referrers %store t1))
 308          (null? (references %store t1))
 309          (null? (referrers %store t2)))))
 310
 311 (test-equal "substitutable-path-info when substitutes are turned off"
 312   '()
 313   (with-store s
 314     (set-build-options s #:use-substitutes? #f)
 315     (let* ((b  (add-to-store s "bash" #t "sha256"
 316                              (search-bootstrap-binary "bash"
 317                                                       (%current-system))))
 318            (d  (derivation s "the-thing" b '("--version")
 319                            #:inputs `((,b))))
 320            (o  (derivation->output-path d)))
 321       (with-derivation-narinfo d
 322         (substitutable-path-info s (list o))))))
 323
 324 (test-equal "substitutable-paths when substitutes are turned off"
 325   '()
 326   (with-store s
 327     (set-build-options s #:use-substitutes? #f)
 328     (let* ((b  (add-to-store s "bash" #t "sha256"
 329                              (search-bootstrap-binary "bash"
 330                                                       (%current-system))))
 331            (d  (derivation s "the-thing" b '("--version")
 332                            #:inputs `((,b))))
 333            (o  (derivation->output-path d)))
 334       (with-derivation-narinfo d
 335         (substitutable-paths s (list o))))))
 336
 337 (test-assert "requisites"
 338   (let* ((t1 (add-text-to-store %store "random1"
 339                                 (random-text) '()))
 340          (t2 (add-text-to-store %store "random2"
 341                                 (random-text) (list t1)))
 342          (t3 (add-text-to-store %store "random3"
 343                                 (random-text) (list t2)))
 344          (t4 (add-text-to-store %store "random4"
 345                                 (random-text) (list t1 t3))))
 346     (define (same? x y)
 347       (and (= (length x) (length y))
 348            (lset= equal? x y)))
 349
 350     (and (same? (requisites %store (list t1)) (list t1))
 351          (same? (requisites %store (list t2)) (list t1 t2))
 352          (same? (requisites %store (list t3)) (list t1 t2 t3))
 353          (same? (requisites %store (list t4)) (list t1 t2 t3 t4))
 354          (same? (requisites %store (list t1 t2 t3 t4))
 355                 (list t1 t2 t3 t4)))))
 356
 357 (test-assert "derivers"
 358   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
 359          (s (add-to-store %store "bash" #t "sha256"
 360                           (search-bootstrap-binary "bash"
 361                                                    (%current-system))))
 362          (d (derivation %store "the-thing"
 363                         s `("-e" ,b)
 364                         #:env-vars `(("foo" . ,(random-text)))
 365                         #:inputs `((,b) (,s))))
 366          (o (derivation->output-path d)))
 367     (and (build-derivations %store (list d))
 368          (equal? (query-derivation-outputs %store (derivation-file-name d))
 369                  (list o))
 370          (equal? (valid-derivers %store o)
 371                  (list (derivation-file-name d))))))
 372
 373 (test-equal "with-build-handler"
 374   'success
 375   (let* ((b  (add-text-to-store %store "build" "echo $foo > $out" '()))
 376          (s  (add-to-store %store "bash" #t "sha256"
 377                            (search-bootstrap-binary "bash"
 378                                                     (%current-system))))
 379          (d1 (derivation %store "the-thing"
 380                          s `("-e" ,b)
 381                          #:env-vars `(("foo" . ,(random-text)))
 382                          #:sources (list b s)))
 383          (d2 (derivation %store "the-thing"
 384                          s `("-e" ,b)
 385                          #:env-vars `(("foo" . ,(random-text))
 386                                       ("bar" . "baz"))
 387                          #:sources (list b s)))
 388          (o1 (derivation->output-path d1))
 389          (o2 (derivation->output-path d2)))
 390     (with-build-handler
 391         (let ((counter 0))
 392           (lambda (continue store things mode)
 393             (match things
 394               ((drv)
 395                (set! counter (+ 1 counter))
 396                (if (string=? drv (derivation-file-name d1))
 397                    (continue #t)
 398                    (and (string=? drv (derivation-file-name d2))
 399                         (= counter 2)
 400                         'success))))))
 401       (build-derivations %store (list d1))
 402       (build-derivations %store (list d2))
 403       'fail)))
 404
 405 (test-equal "with-build-handler + with-store"
 406   'success
 407   ;; Check that STORE remains valid when the build handler invokes CONTINUE,
 408   ;; even though 'with-build-handler' is outside the dynamic extent of
 409   ;; 'with-store'.
 410   (with-build-handler (lambda (continue store things mode)
 411                         (match things
 412                           ((drv)
 413                            (and (string-suffix? "thingie.drv" drv)
 414                                 (not (port-closed?
 415                                       (store-connection-socket store)))
 416                                 (continue #t)))))
 417     (with-store store
 418       (let* ((b (add-text-to-store store "build" "echo $foo > $out" '()))
 419              (s (add-to-store store "bash" #t "sha256"
 420                               (search-bootstrap-binary "bash"
 421                                                        (%current-system))))
 422              (d (derivation store "thingie"
 423                             s `("-e" ,b)
 424                             #:env-vars `(("foo" . ,(random-text)))
 425                             #:sources (list b s))))
 426         (build-derivations store (list d))
 427
 428         ;; Here STORE's socket should still be open.
 429         (and (valid-path? store (derivation->output-path d))
 430              'success)))))
 431
 432 (test-assert "map/accumulate-builds"
 433   (let* ((b  (add-text-to-store %store "build" "echo $foo > $out" '()))
 434          (s  (add-to-store %store "bash" #t "sha256"
 435                            (search-bootstrap-binary "bash"
 436                                                     (%current-system))))
 437          (d1 (derivation %store "the-thing"
 438                          s `("-e" ,b)
 439                          #:env-vars `(("foo" . ,(random-text)))
 440                          #:sources (list b s)))
 441          (d2 (derivation %store "the-thing"
 442                          s `("-e" ,b)
 443                          #:env-vars `(("foo" . ,(random-text))
 444                                       ("bar" . "baz"))
 445                          #:sources (list b s))))
 446     (with-build-handler (lambda (continue store things mode)
 447                           (equal? (map derivation-file-name (list d1 d2))
 448                                   things))
 449       (map/accumulate-builds %store
 450                              (lambda (drv)
 451                                (build-derivations %store (list drv))
 452                                (add-to-store %store "content-addressed"
 453                                              #t "sha256"
 454                                              (derivation->output-path drv)))
 455                              (list d1 d2)))))
 456
 457 (test-equal "map/accumulate-builds cutoff" ;https://issues.guix.gnu.org/50264
 458   (iota 20)
 459
 460   ;; Make sure that, when the cutoff is reached, 'map/accumulate-builds' still
 461   ;; returns the right result and calls the build handler by batches.
 462   (let* ((b  (add-text-to-store %store "build" "echo $foo > $out" '()))
 463          (s  (add-to-store %store "bash" #t "sha256"
 464                            (search-bootstrap-binary "bash"
 465                                                     (%current-system))))
 466          (d  (map (lambda (i)
 467                     (derivation %store (string-append "the-thing-"
 468                                                       (number->string i))
 469                                 s `("-e" ,b)
 470                                 #:env-vars `(("foo" . ,(random-text)))
 471                                 #:sources (list b s)
 472                                 #:properties `((n . ,i))))
 473                   (iota 20)))
 474          (calls '()))
 475     (define lst
 476       (with-build-handler (lambda (continue store things mode)
 477                             (set! calls (cons things calls))
 478                             (continue #f))
 479         (map/accumulate-builds %store
 480                                (lambda (d)
 481                                  (build-derivations %store (list d))
 482                                  (assq-ref (derivation-properties d) 'n))
 483                                d
 484                                #:cutoff 7)))
 485
 486     (match (reverse calls)
 487       (((batch1 ...) (batch2 ...) (batch3 ...))
 488        (and (equal? (map derivation-file-name (take d 8)) batch1)
 489             (equal? (map derivation-file-name (take (drop d 8) 8)) batch2)
 490             (equal? (map derivation-file-name (drop d 16)) batch3)
 491             lst)))))
 492
 493 (test-equal "map/accumulate-builds and different store"
 494   '(d2)                               ;see <https://issues.guix.gnu.org/46756>
 495   (let* ((b  (add-text-to-store %store "build" "echo $foo > $out" '()))
 496          (s  (add-to-store %store "bash" #t "sha256"
 497                            (search-bootstrap-binary "bash"
 498                                                     (%current-system))))
 499          (d1 (derivation %store "first"
 500                          s `("-e" ,b)
 501                          #:env-vars `(("foo" . ,(random-text)))
 502                          #:sources (list b s)))
 503          (d2 (derivation %store "second"
 504                          s `("-e" ,b)
 505                          #:env-vars `(("foo" . ,(random-text))
 506                                       ("bar" . "baz"))
 507                          #:sources (list b s))))
 508     (with-store alternate-store
 509       (with-build-handler (lambda (continue store things mode)
 510                             ;; If this handler is called, it means that
 511                             ;; 'map/accumulate-builds' triggered a build,
 512                             ;; which it shouldn't since the inner
 513                             ;; 'build-derivations' call is for another store.
 514                             'failed)
 515         (map/accumulate-builds %store
 516                                (lambda (drv)
 517                                  (build-derivations alternate-store (list d2))
 518                                  'd2)
 519                                (list d1))))))
 520
 521 (test-assert "mapm/accumulate-builds"
 522   (let* ((d1 (run-with-store %store
 523                (gexp->derivation "foo" #~(mkdir #$output))))
 524          (d2 (run-with-store %store
 525                (gexp->derivation "bar" #~(mkdir #$output)))))
 526     (with-build-handler (lambda (continue store things mode)
 527                           (equal? (map derivation-file-name (pk 'zz (list d1 d2)))
 528                                   (pk 'XX things)))
 529       (run-with-store %store
 530         (mapm/accumulate-builds built-derivations `((,d1) (,d2)))))))
 531
 532 (test-equal "mapm/accumulate-builds, %current-target-system"
 533   (make-list 2 '("i586-pc-gnu" "i586-pc-gnu"))
 534   ;; Both the 'mapm' and 'mapm/accumulate-builds' procedures should see the
 535   ;; right #:target.
 536   (run-with-store %store
 537     (mlet %store-monad ((lst1 (mapm %store-monad
 538                                     (lambda _
 539                                       (current-target-system))
 540                                     '(a b)))
 541                         (lst2 (mapm/accumulate-builds
 542                                (lambda _
 543                                  (current-target-system))
 544                                '(a b))))
 545       (return (list lst1 lst2)))
 546     #:system system
 547     #:target "i586-pc-gnu"))
 548
 549 (test-assert "topologically-sorted, one item"
 550   (let* ((a (add-text-to-store %store "a" "a"))
 551          (b (add-text-to-store %store "b" "b" (list a)))
 552          (c (add-text-to-store %store "c" "c" (list b)))
 553          (d (add-text-to-store %store "d" "d" (list c)))
 554          (s (topologically-sorted %store (list d))))
 555     (equal? s (list a b c d))))
 556
 557 (test-assert "topologically-sorted, several items"
 558   (let* ((a  (add-text-to-store %store "a" "a"))
 559          (b  (add-text-to-store %store "b" "b" (list a)))
 560          (c  (add-text-to-store %store "c" "c" (list b)))
 561          (d  (add-text-to-store %store "d" "d" (list c)))
 562          (s1 (topologically-sorted %store (list d a c b)))
 563          (s2 (topologically-sorted %store (list b d c a b d))))
 564     (equal? s1 s2 (list a b c d))))
 565
 566 (test-assert "topologically-sorted, more difficult"
 567   (let* ((a  (add-text-to-store %store "a" "a"))
 568          (b  (add-text-to-store %store "b" "b" (list a)))
 569          (c  (add-text-to-store %store "c" "c" (list b)))
 570          (d  (add-text-to-store %store "d" "d" (list c)))
 571          (w  (add-text-to-store %store "w" "w"))
 572          (x  (add-text-to-store %store "x" "x" (list w)))
 573          (y  (add-text-to-store %store "y" "y" (list x d)))
 574          (s1 (topologically-sorted %store (list y)))
 575          (s2 (topologically-sorted %store (list c y)))
 576          (s3 (topologically-sorted %store (cons y (references %store y)))))
 577     ;; The order in which 'references' returns the references of Y is
 578     ;; unspecified, so accommodate.
 579     (let* ((x-then-d? (equal? (references %store y) (list x d))))
 580       (and (equal? s1
 581                    (if x-then-d?
 582                        (list w x a b c d y)
 583                        (list a b c d w x y)))
 584            (equal? s2
 585                    (if x-then-d?
 586                        (list a b c w x d y)
 587                        (list a b c d w x y)))
 588            (lset= string=? s1 s3)))))
 589
 590 (test-assert "current-build-output-port, UTF-8"
 591   ;; Are UTF-8 strings in the build log properly interpreted?
 592   (string-contains
 593    (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
 594      (call-with-output-string
 595       (lambda (port)
 596         (parameterize ((current-build-output-port port))
 597           (let* ((s "Here’s a Greek letter: λ.")
 598                  (d (build-expression->derivation
 599                      %store "foo" `(display ,s)
 600                      #:guile-for-build
 601                      (package-derivation %store %bootstrap-guile
 602                                          (%current-system)))))
 603             (guard (c ((store-protocol-error? c) #t))
 604               (build-derivations %store (list d))))))))
 605    "Here’s a Greek letter: λ."))
 606
 607 (test-assert "current-build-output-port, UTF-8 + garbage"
 608   ;; What about a mixture of UTF-8 + garbage?
 609   (string-contains
 610    (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
 611      (call-with-output-string
 612       (lambda (port)
 613         (parameterize ((current-build-output-port port))
 614           (let ((d (build-expression->derivation
 615                     %store "foo"
 616                     `(begin
 617                        (use-modules (rnrs io ports))
 618                        (display "garbage: ")
 619                        (put-bytevector (current-output-port) #vu8(128))
 620                        (display "lambda: λ\n"))
 621                      #:guile-for-build
 622                      (package-derivation %store %bootstrap-guile))))
 623             (guard (c ((store-protocol-error? c) #t))
 624               (build-derivations %store (list d))))))))
 625    "garbage: �lambda: λ"))
 626
 627 (test-assert "log-file, derivation"
 628   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
 629          (s (add-to-store %store "bash" #t "sha256"
 630                           (search-bootstrap-binary "bash"
 631                                                    (%current-system))))
 632          (d (derivation %store "the-thing"
 633                         s `("-e" ,b)
 634                         #:env-vars `(("foo" . ,(random-text)))
 635                         #:inputs `((,b) (,s)))))
 636     (and (build-derivations %store (list d))
 637          (file-exists? (pk (log-file %store (derivation-file-name d)))))))
 638
 639 (test-assert "log-file, output file name"
 640   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
 641          (s (add-to-store %store "bash" #t "sha256"
 642                           (search-bootstrap-binary "bash"
 643                                                    (%current-system))))
 644          (d (derivation %store "the-thing"
 645                         s `("-e" ,b)
 646                         #:env-vars `(("foo" . ,(random-text)))
 647                         #:inputs `((,b) (,s))))
 648          (o (derivation->output-path d)))
 649     (and (build-derivations %store (list d))
 650          (file-exists? (pk (log-file %store o)))
 651          (string=? (log-file %store (derivation-file-name d))
 652                    (log-file %store o)))))
 653
 654 (test-assert "no substitutes"
 655   (with-store s
 656     (let* ((d1 (package-derivation s %bootstrap-guile (%current-system)))
 657            (d2 (package-derivation s %bootstrap-glibc (%current-system)))
 658            (o  (map derivation->output-path (list d1 d2))))
 659       (set-build-options s #:use-substitutes? #f)
 660       (and (not (has-substitutes? s (derivation-file-name d1)))
 661            (not (has-substitutes? s (derivation-file-name d2)))
 662            (null? (substitutable-paths s o))
 663            (null? (substitutable-path-info s o))))))
 664
 665 (test-assert "build-things with output path"
 666   (with-store s
 667     (let* ((c   (random-text))                    ;contents of the output
 668            (d   (build-expression->derivation
 669                  s "substitute-me"
 670                  `(call-with-output-file %output
 671                     (lambda (p)
 672                       (display ,c p)))
 673                  #:guile-for-build
 674                  (package-derivation s %bootstrap-guile (%current-system))))
 675            (o   (derivation->output-path d)))
 676       (set-build-options s #:use-substitutes? #f)
 677
 678       ;; Pass 'build-things' the output file name, O.  However, since there
 679       ;; are no substitutes for O, it will just do nothing.
 680       (build-things s (list o))
 681       (not (valid-path? s o)))))
 682
 683 (test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))
 684
 685 (test-assert "substitute query"
 686   (with-store s
 687     (let* ((d (package-derivation s %bootstrap-guile (%current-system)))
 688            (o (derivation->output-path d)))
 689       ;; Create fake substituter data, to be read by 'guix substitute'.
 690       (with-derivation-narinfo d
 691         ;; Remove entry from the local cache.
 692         (false-if-exception
 693          (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
 694                                                  "/guix/substitute")))
 695
 696         ;; Make sure 'guix substitute' correctly communicates the above
 697         ;; data.
 698         (set-build-options s #:use-substitutes? #t
 699                            #:substitute-urls (%test-substitute-urls))
 700         (and (has-substitutes? s o)
 701              (equal? (list o) (substitutable-paths s (list o)))
 702              (match (pk 'spi (substitutable-path-info s (list o)))
 703                (((? substitutable? s))
 704                 (and (string=? (substitutable-deriver s)
 705                                (derivation-file-name d))
 706                      (null? (substitutable-references s))
 707                      (equal? (substitutable-nar-size s) 1234)))))))))
 708
 709 (test-assert "substitute query, alternating URLs"
 710   (let* ((d (with-store s
 711               (package-derivation s %bootstrap-guile (%current-system))))
 712          (o (derivation->output-path d)))
 713     (with-derivation-narinfo d
 714       ;; Remove entry from the local cache.
 715       (false-if-exception
 716        (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
 717                                                "/guix/substitute")))
 718
 719       ;; Note: We reconnect to the daemon to force a new instance of 'guix
 720       ;; substitute' to be used; otherwise the #:substitute-urls of
 721       ;; 'set-build-options' would have no effect.
 722
 723       (and (with-store s                        ;the right substitute URL
 724              (set-build-options s #:use-substitutes? #t
 725                                 #:substitute-urls (%test-substitute-urls))
 726              (has-substitutes? s o))
 727            (with-store s                        ;the wrong one
 728              (set-build-options s #:use-substitutes? #t
 729                                 #:substitute-urls (list
 730                                                    "http://does-not-exist"))
 731              (not (has-substitutes? s o)))
 732            (with-store s                        ;the right one again
 733              (set-build-options s #:use-substitutes? #t
 734                                 #:substitute-urls (%test-substitute-urls))
 735              (has-substitutes? s o))
 736            (with-store s                        ;empty list of URLs
 737              (set-build-options s #:use-substitutes? #t
 738                                 #:substitute-urls '())
 739              (not (has-substitutes? s o)))))))
 740
 741 (test-assert "substitute"
 742   (with-store s
 743     (let* ((c   (random-text))                     ; contents of the output
 744            (d   (build-expression->derivation
 745                  s "substitute-me"
 746                  `(call-with-output-file %output
 747                     (lambda (p)
 748                       (exit 1)                     ; would actually fail
 749                       (display ,c p)))
 750                  #:guile-for-build
 751                  (package-derivation s %bootstrap-guile (%current-system))))
 752            (o   (derivation->output-path d)))
 753       (with-derivation-substitute d c
 754         (set-build-options s #:use-substitutes? #t
 755                            #:substitute-urls (%test-substitute-urls))
 756         (and (has-substitutes? s o)
 757              (build-derivations s (list d))
 758              (canonical-file? o)
 759              (equal? c (call-with-input-file o get-string-all)))))))
 760
 761 (test-assert "substitute, deduplication"
 762   (with-store s
 763     ;; Note: C must be longer than %DEDUPLICATION-MINIMUM-SIZE.
 764     (let* ((c   (string-concatenate
 765                  (make-list 200 (random-text))))  ; contents of the output
 766            (g   (package-derivation s %bootstrap-guile))
 767            (d1  (build-expression->derivation s "substitute-me"
 768                                               `(begin ,c (exit 1))
 769                                               #:guile-for-build g))
 770            (d2  (build-expression->derivation s "build-me"
 771                                               `(call-with-output-file %output
 772                                                  (lambda (p)
 773                                                    (display ,c p)))
 774                                               #:guile-for-build g))
 775            (o1  (derivation->output-path d1))
 776            (o2  (derivation->output-path d2)))
 777       (with-derivation-substitute d1 c
 778         (set-build-options s #:use-substitutes? #t
 779                            #:substitute-urls (%test-substitute-urls))
 780         (and (has-substitutes? s o1)
 781              (build-derivations s (list d2))      ;build
 782              (build-derivations s (list d1))      ;substitute
 783              (canonical-file? o1)
 784              (equal? c (call-with-input-file o1 get-string-all))
 785              (= (stat:ino (stat o1)) (stat:ino (stat o2))))))))
 786
 787 (test-assert "substitute + build-things with output path"
 788   (with-store s
 789     (let* ((c   (random-text))                    ;contents of the output
 790            (d   (build-expression->derivation
 791                  s "substitute-me"
 792                  `(call-with-output-file %output
 793                     (lambda (p)
 794                       (exit 1)                    ;would actually fail
 795                       (display ,c p)))
 796                  #:guile-for-build
 797                  (package-derivation s %bootstrap-guile (%current-system))))
 798            (o   (derivation->output-path d)))
 799       (with-derivation-substitute d c
 800         (set-build-options s #:use-substitutes? #t
 801                            #:substitute-urls (%test-substitute-urls))
 802         (and (has-substitutes? s o)
 803              (build-things s (list o))            ;give the output path
 804              (valid-path? s o)
 805              (canonical-file? o)
 806              (equal? c (call-with-input-file o get-string-all)))))))
 807
 808 (test-assert "substitute + build-things with specific output"
 809   (with-store s
 810     (let* ((c   (random-text))                    ;contents of the output
 811            (d   (build-expression->derivation
 812                  s "substitute-me" `(begin ,c (exit 1)) ;would fail
 813                  #:outputs '("out" "one" "two")
 814                  #:guile-for-build
 815                  (package-derivation s %bootstrap-guile (%current-system))))
 816            (o   (derivation->output-path d)))
 817       (with-derivation-substitute d c
 818         (set-build-options s #:use-substitutes? #t
 819                            #:substitute-urls (%test-substitute-urls))
 820         (and (has-substitutes? s o)
 821
 822              ;; Ask for nothing but the "out" output of D.
 823              (build-things s `((,(derivation-file-name d) . "out")))
 824
 825              (valid-path? s o)
 826              (canonical-file? o)
 827              (equal? c (call-with-input-file o get-string-all)))))))
 828
 829 (test-assert "substitute, corrupt output hash"
 830   ;; Tweak the substituter into installing a substitute whose hash doesn't
 831   ;; match the one announced in the narinfo.  The daemon must notice this and
 832   ;; raise an error.
 833   (with-store s
 834     (let* ((c   "hello, world")                    ; contents of the output
 835            (d   (build-expression->derivation
 836                  s "corrupt-substitute"
 837                  `(mkdir %output)
 838                  #:guile-for-build
 839                  (package-derivation s %bootstrap-guile (%current-system))))
 840            (o   (derivation->output-path d)))
 841       (with-derivation-substitute d c
 842         (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C
 843
 844         ;; Make sure we use 'guix substitute'.
 845         (set-build-options s
 846                            #:use-substitutes? #t
 847                            #:fallback? #f
 848                            #:substitute-urls (%test-substitute-urls))
 849         (and (has-substitutes? s o)
 850              (guard (c ((store-protocol-error? c)
 851                         ;; XXX: the daemon writes "hash mismatch in downloaded
 852                         ;; path", but the actual error returned to the client
 853                         ;; doesn't mention that.
 854                         (pk 'corrupt c)
 855                         (not (zero? (store-protocol-error-status c)))))
 856                (build-derivations s (list d))
 857                #f))))))
 858
 859 (test-assert "substitute, corrupt output hash, build trace"
 860   ;; Likewise, and check the build trace.
 861   (with-store s
 862     (let* ((c   "hello, world")                   ; contents of the output
 863            (d   (build-expression->derivation
 864                  s "corrupt-substitute"
 865                  `(mkdir %output)
 866                  #:guile-for-build
 867                  (package-derivation s %bootstrap-guile (%current-system))))
 868            (o   (derivation->output-path d)))
 869       ;; Make sure we use 'guix substitute'.
 870       (set-build-options s
 871                          #:print-build-trace #t
 872                          #:use-substitutes? #t
 873                          #:fallback? #f
 874                          #:substitute-urls (%test-substitute-urls))
 875
 876       (with-derivation-substitute d c
 877         (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C
 878
 879         (define output
 880           (call-with-output-string
 881             (lambda (port)
 882               (parameterize ((current-build-output-port port))
 883                 (guard (c ((store-protocol-error? c) #t))
 884                   (build-derivations s (list d))
 885                   #f)))))
 886
 887         (define actual-hash
 888           (let-values (((port get-hash)
 889                         (gcrypt:open-hash-port
 890                          (gcrypt:hash-algorithm gcrypt:sha256))))
 891             (write-file-tree "foo" port
 892                              #:file-type+size
 893                              (lambda _
 894                                (values 'regular (string-length c)))
 895                              #:file-port
 896                              (lambda _
 897                                (open-input-string c)))
 898             (close-port port)
 899             (bytevector->nix-base32-string (get-hash))))
 900
 901         (define expected-hash
 902           (bytevector->nix-base32-string (make-bytevector 32 0)))
 903
 904         (define mismatch
 905           (string-append "@ hash-mismatch " o " sha256 "
 906                          expected-hash " " actual-hash "\n"))
 907
 908         (define failure
 909           (string-append "@ substituter-failed " o))
 910
 911         (and (string-contains output mismatch)
 912              (string-contains output failure))))))
 913
 914 (test-assert "substitute --fallback"
 915   (with-store s
 916     (let* ((t   (random-text))                    ; contents of the output
 917            (d   (build-expression->derivation
 918                  s "substitute-me-not"
 919                  `(call-with-output-file %output
 920                     (lambda (p)
 921                       (display ,t p)))
 922                  #:guile-for-build
 923                  (package-derivation s %bootstrap-guile (%current-system))))
 924            (o   (derivation->output-path d)))
 925       ;; Create fake substituter data, to be read by 'guix substitute'.
 926       (with-derivation-narinfo d
 927         ;; Make sure we use 'guix substitute'.
 928         (set-build-options s #:use-substitutes? #t
 929                            #:substitute-urls (%test-substitute-urls))
 930         (and (has-substitutes? s o)
 931              (guard (c ((store-protocol-error? c)
 932                         ;; The substituter failed as expected.  Now make
 933                         ;; sure that #:fallback? #t works correctly.
 934                         (set-build-options s
 935                                            #:use-substitutes? #t
 936                                            #:substitute-urls
 937                                              (%test-substitute-urls)
 938                                            #:fallback? #t)
 939                         (and (build-derivations s (list d))
 940                              (equal? t (call-with-input-file o
 941                                          get-string-all)))))
 942                ;; Should fail.
 943                (build-derivations s (list d))
 944                #f))))))
 945
 946 (test-equal "substitute query and large size"
 947   (+ 100 (expt 2 63))                     ;<https://issues.guix.gnu.org/51983>
 948   (with-store s
 949     (let* ((size (+ 100 (expt 2 63)))      ;does not fit in signed 'long long'
 950            (item (string-append (%store-prefix)
 951                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bad-size")))
 952       ;; Create fake substituter data, to be read by 'guix substitute'.
 953       (call-with-output-file (string-append (%substitute-directory)
 954                                             "/" (store-path-hash-part item)
 955                                             ".narinfo")
 956         (lambda (port)
 957           (format port "StorePath: ~a
 958 URL: http://example.org
 959 Compression: none
 960 NarSize: ~a
 961 NarHash: sha256:0fj9vhblff2997pi7qjj7lhmy7wzhnjwmkm2hmq6gr4fzmg10s0w
 962 References:
 963 System: x86_64-linux~%"
 964                   item size)))
 965
 966       ;; Remove entry from the local cache.
 967       (false-if-exception
 968        (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
 969                                                "/guix/substitute")))
 970
 971       ;; Make sure 'guix substitute' correctly communicates the above
 972       ;; data.
 973       (set-build-options s #:use-substitutes? #t
 974                          #:substitute-urls (%test-substitute-urls))
 975       (match (pk 'spi (substitutable-path-info s (list item)))
 976         (((? substitutable? s))
 977          (and (equal? (substitutable-path s) item)
 978               (substitutable-nar-size s)))))))
 979
 980 (test-equal "substitute and large size"
 981   (+ 100 (expt 2 31))                     ;<https://issues.guix.gnu.org/46212>
 982   (with-store s
 983     (let* ((size (+ 100 (expt 2 31)))            ;does not fit in signed 'int'
 984            (item (string-append (%store-prefix)
 985                                 "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bad-size-"
 986                                 (random-text)))
 987            (nar  (string-append (%substitute-directory) "/nar")))
 988       ;; Create a dummy nar to allow for substitution.
 989       (call-with-output-file nar
 990         (lambda (port)
 991           (write-file-tree (store-path-package-name item) port
 992                            #:file-type+size (lambda _
 993                                               (values 'regular 12))
 994                            #:file-port (lambda _
 995                                          (open-input-string "Hello world.")))))
 996
 997       ;; Create fake substituter data, to be read by 'guix substitute'.
 998       (call-with-output-file (string-append (%substitute-directory)
 999                                             "/" (store-path-hash-part item)
1000                                             ".narinfo")
1001         (lambda (port)
1002           (format port "StorePath: ~a
1003 URL: file://~a
1004 Compression: none
1005 NarSize: ~a
1006 NarHash: sha256:~a
1007 References:
1008 System: x86_64-linux~%"
1009                   item nar size
1010                   (bytevector->nix-base32-string (gcrypt:file-sha256 nar)))))
1011
1012       ;; Remove entry from the local cache.
1013       (false-if-exception
1014        (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
1015                                                "/guix/substitute")))
1016
1017       ;; Make sure 'guix substitute' correctly communicates the above
1018       ;; data.
1019       (set-build-options s #:use-substitutes? #t
1020                          #:substitute-urls (%test-substitute-urls))
1021       (ensure-path s item)
1022       (path-info-nar-size (query-path-info s item)))))
1023
1024 (test-assert "export/import several paths"
1025   (let* ((texts (unfold (cut >= <> 10)
1026                         (lambda _ (random-text))
1027                         1+
1028                         0))
1029          (files (map (cut add-text-to-store %store "text" <>) texts))
1030          (dump  (call-with-bytevector-output-port
1031                  (cut export-paths %store files <>))))
1032     (delete-paths %store files)
1033     (and (every (negate file-exists?) files)
1034          (let* ((source   (open-bytevector-input-port dump))
1035                 (imported (import-paths %store source)))
1036            (and (equal? imported files)
1037                 (every file-exists? files)
1038                 (equal? texts
1039                         (map (lambda (file)
1040                                (call-with-input-file file
1041                                  get-string-all))
1042                              files)))))))
1043
1044 (test-assert "export/import paths, ensure topological order"
1045   (let* ((file0 (add-text-to-store %store "baz" (random-text)))
1046          (file1 (add-text-to-store %store "foo" (random-text)
1047                                    (list file0)))
1048          (file2 (add-text-to-store %store "bar" (random-text)
1049                                    (list file1)))
1050          (files (list file1 file2))
1051          (dump1 (call-with-bytevector-output-port
1052                  (cute export-paths %store (list file1 file2) <>)))
1053          (dump2 (call-with-bytevector-output-port
1054                  (cute export-paths %store (list file2 file1) <>))))
1055     (delete-paths %store files)
1056     (and (every (negate file-exists?) files)
1057          (bytevector=? dump1 dump2)
1058          (let* ((source   (open-bytevector-input-port dump1))
1059                 (imported (import-paths %store source)))
1060            ;; DUMP1 should contain exactly FILE1 and FILE2, not FILE0.
1061            (and (equal? imported (list file1 file2))
1062                 (every file-exists? files)
1063                 (equal? (list file0) (references %store file1))
1064                 (equal? (list file1) (references %store file2)))))))
1065
1066 (test-assert "export/import incomplete"
1067   (let* ((file0 (add-text-to-store %store "baz" (random-text)))
1068          (file1 (add-text-to-store %store "foo" (random-text)
1069                                    (list file0)))
1070          (file2 (add-text-to-store %store "bar" (random-text)
1071                                    (list file1)))
1072          (dump  (call-with-bytevector-output-port
1073                  (cute export-paths %store (list file2) <>))))
1074     (delete-paths %store (list file0 file1 file2))
1075     (guard (c ((store-protocol-error? c)
1076                (and (not (zero? (store-protocol-error-status c)))
1077                     (string-contains (store-protocol-error-message c)
1078                                      "not valid"))))
1079       ;; Here we get an exception because DUMP does not include FILE0 and
1080       ;; FILE1, which are dependencies of FILE2.
1081       (import-paths %store (open-bytevector-input-port dump)))))
1082
1083 (test-assert "export/import recursive"
1084   (let* ((file0 (add-text-to-store %store "baz" (random-text)))
1085          (file1 (add-text-to-store %store "foo" (random-text)
1086                                    (list file0)))
1087          (file2 (add-text-to-store %store "bar" (random-text)
1088                                    (list file1)))
1089          (dump  (call-with-bytevector-output-port
1090                  (cute export-paths %store (list file2) <>
1091                        #:recursive? #t))))
1092     (delete-paths %store (list file0 file1 file2))
1093     (let ((imported (import-paths %store (open-bytevector-input-port dump))))
1094       (and (equal? imported (list file0 file1 file2))
1095            (every file-exists? (list file0 file1 file2))
1096            (equal? (list file0) (references %store file1))
1097            (equal? (list file1) (references %store file2))))))
1098
1099 (test-assert "write-file & export-path yield the same result"
1100   ;; Here we compare 'write-file' and the daemon's own implementation.
1101   ;; 'write-file' is the reference because we know it sorts file
1102   ;; deterministically.  Conversely, the daemon uses 'readdir' and the entries
1103   ;; currently happen to be sorted as a side-effect of some unrelated
1104   ;; operation (search for 'unhacked' in archive.cc.)  Make sure we detect any
1105   ;; changes there.
1106   (run-with-store %store
1107     (mlet* %store-monad ((drv1 (package->derivation %bootstrap-guile))
1108                          (out1 -> (derivation->output-path drv1))
1109                          (data -> (unfold (cut >= <> 26)
1110                                           (lambda (i)
1111                                             (random-bytevector 128))
1112                                           1+ 0))
1113                          (build
1114                           -> #~(begin
1115                                  (use-modules (rnrs io ports) (srfi srfi-1))
1116                                  (let ()
1117                                    (define letters
1118                                      (map (lambda (i)
1119                                             (string
1120                                              (integer->char
1121                                               (+ i (char->integer #\a)))))
1122                                           (iota 26)))
1123                                    (define (touch file data)
1124                                      (call-with-output-file file
1125                                        (lambda (port)
1126                                          (put-bytevector port data))))
1127
1128                                    (mkdir #$output)
1129                                    (chdir #$output)
1130
1131                                    ;; The files must be different so they have
1132                                    ;; different inode numbers, and the inode
1133                                    ;; order must differ from the lexicographic
1134                                    ;; order.
1135                                    (for-each touch
1136                                              (append (drop letters 10)
1137                                                      (take letters 10))
1138                                              (list #$@data))
1139                                    #t)))
1140                          (drv2 (gexp->derivation "bunch" build))
1141                          (out2 -> (derivation->output-path drv2))
1142                          (item-info -> (store-lift query-path-info)))
1143       (mbegin %store-monad
1144         (built-derivations (list drv1 drv2))
1145         (foldm %store-monad
1146                (lambda (item result)
1147                  (define ref-hash
1148                    (let-values (((port get) (gcrypt:open-sha256-port)))
1149                      (write-file item port)
1150                      (close-port port)
1151                      (get)))
1152
1153                  ;; 'query-path-info' returns a hash produced by using the
1154                  ;; daemon's C++ 'dump' function, which is the implementation
1155                  ;; under test.
1156                  (>>= (item-info item)
1157                       (lambda (info)
1158                         (return
1159                          (and result
1160                               (bytevector=? (path-info-hash info) ref-hash))))))
1161                #t
1162                (list out1 out2))))
1163     #:guile-for-build (%guile-for-build)))
1164
1165
1166 (test-assert "import not signed"
1167   (let* ((text (random-text))
1168          (file (add-file-tree-to-store %store
1169                                        `("tree" directory
1170                                          ("text" regular (data ,text))
1171                                          ("link" symlink "text"))))
1172          (dump (call-with-bytevector-output-port
1173                 (lambda (port)
1174                   (write-int 1 port)              ;start
1175
1176                   (write-file file port)          ;contents
1177                   (write-int #x4558494e port)     ;%export-magic
1178                   (write-string file port)        ;store item
1179                   (write-string-list '() port)    ;references
1180                   (write-string "" port)          ;deriver
1181                   (write-int 0 port)              ;not signed
1182
1183                   (write-int 0 port)))))          ;done
1184
1185     ;; Ensure 'import-paths' raises an exception.
1186     (guard (c ((store-protocol-error? c)
1187                (and (not (zero? (store-protocol-error-status c)))
1188                     (string-contains (store-protocol-error-message c)
1189                                      "lacks a signature"))))
1190       (let* ((source   (open-bytevector-input-port dump))
1191              (imported (import-paths %store source)))
1192         (pk 'unsigned-imported imported)
1193         #f))))
1194
1195 (test-assert "import signed by unauthorized key"
1196   (let* ((text (random-text))
1197          (file (add-file-tree-to-store %store
1198                                        `("tree" directory
1199                                          ("text" regular (data ,text))
1200                                          ("link" symlink "text"))))
1201          (key  (gcrypt:generate-key
1202                 (gcrypt:string->canonical-sexp
1203                  "(genkey (ecdsa (curve Ed25519) (flags rfc6979)))")))
1204          (dump (call-with-bytevector-output-port
1205                 (lambda (port)
1206                   (write-int 1 port)              ;start
1207
1208                   (write-file file port)          ;contents
1209                   (write-int #x4558494e port)     ;%export-magic
1210                   (write-string file port)        ;store item
1211                   (write-string-list '() port)    ;references
1212                   (write-string "" port)          ;deriver
1213                   (write-int 1 port)              ;signed
1214                   (write-string (gcrypt:canonical-sexp->string
1215                                  (signature-sexp
1216                                   (gcrypt:bytevector->hash-data
1217                                    (gcrypt:sha256 #vu8(0 1 2))
1218                                    #:key-type 'ecc)
1219                                   (gcrypt:find-sexp-token key 'private-key)
1220                                   (gcrypt:find-sexp-token key 'public-key)))
1221                                 port)
1222
1223                   (write-int 0 port)))))          ;done
1224
1225     ;; Ensure 'import-paths' raises an exception.
1226     (guard (c ((store-protocol-error? c)
1227                (and (not (zero? (store-protocol-error-status c)))
1228                     (string-contains (store-protocol-error-message c)
1229                                      "unauthorized public key"))))
1230       (let* ((source   (open-bytevector-input-port dump))
1231              (imported (import-paths %store source)))
1232         (pk 'unauthorized-imported imported)
1233         #f))))
1234
1235 (test-assert "import corrupt path"
1236   (let* ((text (random-text))
1237          (file (add-text-to-store %store "text" text))
1238          (dump (call-with-bytevector-output-port
1239                 (cut export-paths %store (list file) <>))))
1240     (delete-paths %store (list file))
1241
1242     ;; Flip a bit in the stream's payload.  INDEX here falls in the middle of
1243     ;; the file contents in DUMP, regardless of the store prefix.
1244     (let* ((index #x70)
1245            (byte  (bytevector-u8-ref dump index)))
1246       (bytevector-u8-set! dump index (logxor #xff byte)))
1247
1248     (and (not (file-exists? file))
1249          (guard (c ((store-protocol-error? c)
1250                     (pk 'c c)
1251                     (and (not (zero? (store-protocol-error-status c)))
1252                          (string-contains (store-protocol-error-message c)
1253                                           "corrupt"))))
1254            (let* ((source   (open-bytevector-input-port dump))
1255                   (imported (import-paths %store source)))
1256              (pk 'corrupt-imported imported)
1257              #f)))))
1258
1259 (test-assert "verify-store"
1260   (let* ((text  (random-text))
1261          (file1 (add-text-to-store %store "foo" text))
1262          (file2 (add-text-to-store %store "bar" (random-text)
1263                                    (list file1))))
1264     (and (pk 'verify1 (verify-store %store))    ;hopefully OK ;
1265          (begin
1266            (delete-file file1)
1267            (not (pk 'verify2 (verify-store %store)))) ;bad! ;
1268          (begin
1269            ;; Using 'add-text-to-store' here wouldn't work: It would succeed ;
1270            ;; without actually creating the file. ;
1271            (call-with-output-file file1
1272              (lambda (port)
1273                (display text port)))
1274            (pk 'verify3 (verify-store %store)))))) ;OK again
1275
1276 (test-assert "verify-store + check-contents"
1277   ;; XXX: This test is I/O intensive.
1278   (with-store s
1279     (let* ((text (random-text))
1280            (drv  (build-expression->derivation
1281                   s "corrupt"
1282                   `(let ((out (assoc-ref %outputs "out")))
1283                      (call-with-output-file out
1284                        (lambda (port)
1285                          (display ,text port)))
1286                      #t)
1287                   #:guile-for-build
1288                   (package-derivation s %bootstrap-guile (%current-system))))
1289            (file (derivation->output-path drv)))
1290       (with-derivation-substitute drv text
1291         (and (build-derivations s (list drv))
1292              (verify-store s #:check-contents? #t) ;should be OK
1293              (begin
1294                (chmod file #o644)
1295                (call-with-output-file file
1296                  (lambda (port)
1297                    (display "corrupt!" port)))
1298                #t)
1299
1300              ;; Make sure the corruption is detected.  We don't test repairing
1301              ;; because only "trusted" users are allowed to do it, but we
1302              ;; don't expose that notion of trusted users that nix-daemon
1303              ;; supports because it seems dubious and redundant with what the
1304              ;; OS provides (in Nix "trusted" users have additional
1305              ;; privileges, such as overriding the set of substitute URLs, but
1306              ;; we instead want to allow anyone to modify them, provided
1307              ;; substitutes are signed by a root-approved key.)
1308              (not (verify-store s #:check-contents? #t))
1309
1310              ;; Delete the corrupt item to leave the store in a clean state.
1311              (delete-paths s (list file)))))))
1312
1313 (test-assert "build-things, check mode"
1314   (with-store store
1315     (call-with-temporary-output-file
1316      (lambda (entropy entropy-port)
1317        (write (random-text) entropy-port)
1318        (force-output entropy-port)
1319        (let* ((drv  (build-expression->derivation
1320                      store "non-deterministic"
1321                      `(begin
1322                         (use-modules (rnrs io ports))
1323                         (let ((out (assoc-ref %outputs "out")))
1324                           (call-with-output-file out
1325                             (lambda (port)
1326                               ;; Rely on the fact that tests do not use the
1327                               ;; chroot, and thus ENTROPY is readable.
1328                               (display (call-with-input-file ,entropy
1329                                          get-string-all)
1330                                        port)))
1331                           #t))
1332                      #:guile-for-build
1333                      (package-derivation store %bootstrap-guile (%current-system))))
1334               (file (derivation->output-path drv)))
1335          (and (build-things store (list (derivation-file-name drv)))
1336               (begin
1337                 (write (random-text) entropy-port)
1338                 (force-output entropy-port)
1339                 (guard (c ((store-protocol-error? c)
1340                            (pk 'determinism-exception c)
1341                            (and (not (zero? (store-protocol-error-status c)))
1342                                 (string-contains (store-protocol-error-message c)
1343                                                  "deterministic"))))
1344                   ;; This one will produce a different result.  Since we're in
1345                   ;; 'check' mode, this must fail.
1346                   (build-things store (list (derivation-file-name drv))
1347                                 (build-mode check))
1348                   #f))))))))
1349
1350 (test-assert "build-succeeded trace in check mode"
1351   (string-contains
1352    (call-with-output-string
1353      (lambda (port)
1354        (let ((d (build-expression->derivation
1355                  %store "foo" '(mkdir (assoc-ref %outputs "out"))
1356                  #:guile-for-build
1357                  (package-derivation %store %bootstrap-guile))))
1358          (build-derivations %store (list d))
1359          (parameterize ((current-build-output-port port))
1360            (build-derivations %store (list d) (build-mode check))))))
1361    "@ build-succeeded"))
1362
1363 (test-assert "build multiple times"
1364   (with-store store
1365     ;; Ask to build twice.
1366     (set-build-options store #:rounds 2 #:use-substitutes? #f)
1367
1368     (call-with-temporary-output-file
1369      (lambda (entropy entropy-port)
1370        (write (random-text) entropy-port)
1371        (force-output entropy-port)
1372        (let* ((drv  (build-expression->derivation
1373                      store "non-deterministic"
1374                      `(begin
1375                         (use-modules (rnrs io ports))
1376                         (let ((out (assoc-ref %outputs "out")))
1377                           (call-with-output-file out
1378                             (lambda (port)
1379                               ;; Rely on the fact that tests do not use the
1380                               ;; chroot, and thus ENTROPY is accessible.
1381                               (display (call-with-input-file ,entropy
1382                                          get-string-all)
1383                                        port)
1384                               (call-with-output-file ,entropy
1385                                 (lambda (port)
1386                                   (write 'foobar port)))))
1387                           #t))
1388                      #:guile-for-build
1389                      (package-derivation store %bootstrap-guile (%current-system))))
1390               (file (derivation->output-path drv)))
1391          (guard (c ((store-protocol-error? c)
1392                     (pk 'multiple-build c)
1393                     (and (not (zero? (store-protocol-error-status c)))
1394                          (string-contains (store-protocol-error-message c)
1395                                           "deterministic"))))
1396            ;; This one will produce a different result on the second run.
1397            (current-build-output-port (current-error-port))
1398            (build-things store (list (derivation-file-name drv)))
1399            #f))))))
1400
1401 (test-equal "store-lower"
1402   "Lowered."
1403   (let* ((add  (store-lower text-file))
1404          (file (add %store "foo" "Lowered.")))
1405     (call-with-input-file file get-string-all)))
1406
1407 (test-equal "current-system"
1408   "bar"
1409   (parameterize ((%current-system "frob"))
1410     (run-with-store %store
1411       (mbegin %store-monad
1412         (set-current-system "bar")
1413         (current-system))
1414       #:system "foo")))
1415
1416 (test-assert "query-path-info"
1417   (let* ((ref (add-text-to-store %store "ref" "foo"))
1418          (item (add-text-to-store %store "item" "bar" (list ref)))
1419          (info (query-path-info %store item)))
1420     (and (equal? (path-info-references info) (list ref))
1421          (equal? (path-info-hash info)
1422                  (gcrypt:sha256
1423                   (string->utf8
1424                    (call-with-output-string (cut write-file item <>))))))))
1425
1426 (test-assert "path-info-deriver"
1427   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
1428          (s (add-to-store %store "bash" #t "sha256"
1429                           (search-bootstrap-binary "bash"
1430                                                    (%current-system))))
1431          (d (derivation %store "the-thing"
1432                         s `("-e" ,b)
1433                         #:env-vars `(("foo" . ,(random-text)))
1434                         #:inputs `((,b) (,s))))
1435          (o (derivation->output-path d)))
1436     (and (build-derivations %store (list d))
1437          (not (path-info-deriver (query-path-info %store b)))
1438          (string=? (derivation-file-name d)
1439                    (path-info-deriver (query-path-info %store o))))))
1440
1441 (test-equal "build-cores"
1442   (list 0 42)
1443   (with-store store
1444     (let* ((build  (add-text-to-store store "build.sh"
1445                                       "echo $NIX_BUILD_CORES > $out"))
1446            (bash   (add-to-store store "bash" #t "sha256"
1447                                  (search-bootstrap-binary "bash"
1448                                                           (%current-system))))
1449            (drv1   (derivation store "the-thing" bash
1450                                `("-e" ,build)
1451                                #:inputs `((,bash) (,build))
1452                                #:env-vars `(("x" . ,(random-text)))))
1453            (drv2   (derivation store "the-thing" bash
1454                                `("-e" ,build)
1455                                #:inputs `((,bash) (,build))
1456                                #:env-vars `(("x" . ,(random-text))))))
1457       (and (build-derivations store (list drv1))
1458            (begin
1459              (set-build-options store #:build-cores 42)
1460              (build-derivations store (list drv2)))
1461            (list (call-with-input-file (derivation->output-path drv1)
1462                    read)
1463                  (call-with-input-file (derivation->output-path drv2)
1464                    read))))))
1465
1466 (test-equal "multiplexed-build-output"
1467   '("Hello from first." "Hello from second.")
1468   (with-store store
1469     (let* ((build  (add-text-to-store store "build.sh"
1470                                       "echo Hello from $NAME.; echo > $out"))
1471            (bash   (add-to-store store "bash" #t "sha256"
1472                                  (search-bootstrap-binary "bash"
1473                                                           (%current-system))))
1474            (drv1   (derivation store "one" bash
1475                                `("-e" ,build)
1476                                #:inputs `((,bash) (,build))
1477                                #:env-vars `(("NAME" . "first")
1478                                             ("x" . ,(random-text)))))
1479            (drv2   (derivation store "two" bash
1480                                `("-e" ,build)
1481                                #:inputs `((,bash) (,build))
1482                                #:env-vars `(("NAME" . "second")
1483                                             ("x" . ,(random-text))))))
1484       (set-build-options store
1485                          #:print-build-trace #t
1486                          #:multiplexed-build-output? #t
1487                          #:max-build-jobs 10)
1488       (let ((port (open-output-string)))
1489         ;; Send the build log to PORT.
1490         (parameterize ((current-build-output-port port))
1491           (build-derivations store (list drv1 drv2)))
1492
1493         ;; Retrieve the build log; make sure it contains valid "@ build-log"
1494         ;; traces that allow us to retrieve each builder's output (we assume
1495         ;; there's exactly one "build-output" trace for each builder, which is
1496         ;; reasonable.)
1497         (let* ((log     (get-output-string port))
1498                (started (fold-matches
1499                          (make-regexp "@ build-started ([^ ]+) - ([^ ]+) ([^ ]+) ([0-9]+)")
1500                          log '() cons))
1501                (done    (fold-matches
1502                          (make-regexp "@ build-succeeded (.*) - (.*) (.*) (.*)")
1503                          log '() cons))
1504                (output  (fold-matches
1505                          (make-regexp "@ build-log ([[:digit:]]+) ([[:digit:]]+)\n([A-Za-z .*]+)\n")
1506                          log '() cons))
1507                (drv-pid (lambda (name)
1508                           (lambda (m)
1509                             (let ((drv (match:substring m 1))
1510                                   (pid (string->number
1511                                         (match:substring m 4))))
1512                               (and (string-suffix? name drv) pid)))))
1513                (pid-log (lambda (pid)
1514                           (lambda (m)
1515                             (let ((n   (string->number
1516                                         (match:substring m 1)))
1517                                   (len (string->number
1518                                         (match:substring m 2)))
1519                                   (str (match:substring m 3)))
1520                               (and (= pid n)
1521                                    (= (string-length str) (- len 1))
1522                                    str)))))
1523                (pid1    (any (drv-pid "one.drv") started))
1524                (pid2    (any (drv-pid "two.drv") started)))
1525           (list (any (pid-log pid1) output)
1526                 (any (pid-log pid2) output)))))))
1527
1528 (test-end "store")