tests/store.scm

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