tests/store.scm

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