tests/store.scm

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