tests/store.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015 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 hash)
  24   #:use-module (guix base32)
  25   #:use-module (guix packages)
  26   #:use-module (guix derivations)
  27   #:use-module (guix serialization)
  28   #:use-module (guix gexp)
  29   #:use-module (gnu packages)
  30   #:use-module (gnu packages bootstrap)
  31   #:use-module (ice-9 match)
  32   #:use-module (rnrs bytevectors)
  33   #:use-module (rnrs io ports)
  34   #:use-module (web uri)
  35   #:use-module (srfi srfi-1)
  36   #:use-module (srfi srfi-11)
  37   #:use-module (srfi srfi-26)
  38   #:use-module (srfi srfi-34)
  39   #:use-module (srfi srfi-64))
  40
  41 ;; Test the (guix store) module.
  42
  43 (define %store
  44   (open-connection-for-tests))
  45
  46 \f
  47 (test-begin "store")
  48
  49 (test-equal "store-path-hash-part"
  50   "283gqy39v3g9dxjy26rynl0zls82fmcg"
  51   (store-path-hash-part
  52    (string-append (%store-prefix)
  53                   "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
  54
  55 (test-equal "store-path-hash-part #f"
  56   #f
  57   (store-path-hash-part
  58    (string-append (%store-prefix)
  59                   "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
  60
  61 (test-equal "store-path-package-name"
  62   "guile-2.0.7"
  63   (store-path-package-name
  64    (string-append (%store-prefix)
  65                   "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7")))
  66
  67 (test-equal "store-path-package-name #f"
  68   #f
  69   (store-path-package-name
  70    "/foo/bar/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))
  71
  72 (test-assert "direct-store-path?"
  73   (and (direct-store-path?
  74         (string-append (%store-prefix)
  75                        "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7"))
  76        (not (direct-store-path?
  77              (string-append
  78               (%store-prefix)
  79               "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile")))
  80        (not (direct-store-path? (%store-prefix)))))
  81
  82 (test-skip (if %store 0 13))
  83
  84 (test-assert "valid-path? live"
  85   (let ((p (add-text-to-store %store "hello" "hello, world")))
  86     (valid-path? %store p)))
  87
  88 (test-assert "valid-path? false"
  89   (not (valid-path? %store
  90                     (string-append (%store-prefix) "/"
  91                                    (make-string 32 #\e) "-foobar"))))
  92
  93 (test-assert "valid-path? error"
  94   (with-store s
  95     (guard (c ((nix-protocol-error? c) #t))
  96       (valid-path? s "foo")
  97       #f)))
  98
  99 (test-assert "valid-path? recovery"
 100   ;; Prior to Nix commit 51800e0 (18 Mar. 2014), the daemon would immediately
 101   ;; close the connection after receiving a 'valid-path?' RPC with a non-store
 102   ;; file name.  See
 103   ;; <http://article.gmane.org/gmane.linux.distributions.nixos/12411> for
 104   ;; details.
 105   (with-store s
 106     (let-syntax ((true-if-error (syntax-rules ()
 107                                   ((_ exp)
 108                                    (guard (c ((nix-protocol-error? c) #t))
 109                                      exp #f)))))
 110       (and (true-if-error (valid-path? s "foo"))
 111            (true-if-error (valid-path? s "bar"))
 112            (true-if-error (valid-path? s "baz"))
 113            (true-if-error (valid-path? s "chbouib"))
 114            (valid-path? s (add-text-to-store s "valid" "yeah"))))))
 115
 116 (test-assert "hash-part->path"
 117   (let ((p (add-text-to-store %store "hello" "hello, world")))
 118     (equal? (hash-part->path %store (store-path-hash-part p))
 119             p)))
 120
 121 (test-assert "dead-paths"
 122   (let ((p (add-text-to-store %store "random-text" (random-text))))
 123     (->bool (member p (dead-paths %store)))))
 124
 125 ;; FIXME: Find a test for `live-paths'.
 126 ;;
 127 ;; (test-assert "temporary root is in live-paths"
 128 ;;   (let* ((p1 (add-text-to-store %store "random-text"
 129 ;;                                 (random-text) '()))
 130 ;;          (b  (add-text-to-store %store "link-builder"
 131 ;;                                 (format #f "echo ~a > $out" p1)
 132 ;;                                 '()))
 133 ;;          (d1 (derivation %store "link"
 134 ;;                          "/bin/sh" `("-e" ,b)
 135 ;;                          #:inputs `((,b) (,p1))))
 136 ;;          (p2 (derivation->output-path d1)))
 137 ;;     (and (add-temp-root %store p2)
 138 ;;          (build-derivations %store (list d1))
 139 ;;          (valid-path? %store p1)
 140 ;;          (member (pk p2) (live-paths %store)))))
 141
 142 (test-assert "permanent root"
 143   (let* ((p  (with-store store
 144                (let ((p (add-text-to-store store "random-text"
 145                                            (random-text))))
 146                  (add-permanent-root p)
 147                  (add-permanent-root p)           ; should not throw
 148                  p))))
 149     (and (member p (live-paths %store))
 150          (begin
 151            (remove-permanent-root p)
 152            (->bool (member p (dead-paths %store)))))))
 153
 154 (test-assert "dead path can be explicitly collected"
 155   (let ((p (add-text-to-store %store "random-text"
 156                               (random-text) '())))
 157     (let-values (((paths freed) (delete-paths %store (list p))))
 158       (and (equal? paths (list p))
 159            (> freed 0)
 160            (not (file-exists? p))))))
 161
 162 (test-assert "add-text-to-store vs. delete-paths"
 163   ;; Before, 'add-text-to-store' would return PATH2 without noticing that it
 164   ;; is no longer valid.
 165   (with-store store
 166     (let* ((text    (random-text))
 167            (path    (add-text-to-store store "delete-me" text))
 168            (deleted (delete-paths store (list path)))
 169            (path2   (add-text-to-store store "delete-me" text)))
 170       (and (string=? path path2)
 171            (equal? deleted (list path))
 172            (valid-path? store path)
 173            (file-exists? path)))))
 174
 175 (test-assert "add-to-store vs. delete-paths"
 176   ;; Same as above.
 177   (with-store store
 178     (let* ((file    (search-path %load-path "guix.scm"))
 179            (path    (add-to-store store "delete-me" #t "sha256" file))
 180            (deleted (delete-paths store (list path)))
 181            (path2   (add-to-store store "delete-me" #t "sha256" file)))
 182       (and (string=? path path2)
 183            (equal? deleted (list path))
 184            (valid-path? store path)
 185            (file-exists? path)))))
 186
 187 (test-assert "references"
 188   (let* ((t1 (add-text-to-store %store "random1"
 189                                 (random-text)))
 190          (t2 (add-text-to-store %store "random2"
 191                                 (random-text) (list t1))))
 192     (and (equal? (list t1) (references %store t2))
 193          (equal? (list t2) (referrers %store t1))
 194          (null? (references %store t1))
 195          (null? (referrers %store t2)))))
 196
 197 (test-assert "requisites"
 198   (let* ((t1 (add-text-to-store %store "random1"
 199                                 (random-text) '()))
 200          (t2 (add-text-to-store %store "random2"
 201                                 (random-text) (list t1)))
 202          (t3 (add-text-to-store %store "random3"
 203                                 (random-text) (list t2)))
 204          (t4 (add-text-to-store %store "random4"
 205                                 (random-text) (list t1 t3))))
 206     (define (same? x y)
 207       (and (= (length x) (length y))
 208            (lset= equal? x y)))
 209
 210     (and (same? (requisites %store t1) (list t1))
 211          (same? (requisites %store t2) (list t1 t2))
 212          (same? (requisites %store t3) (list t1 t2 t3))
 213          (same? (requisites %store t4) (list t1 t2 t3 t4)))))
 214
 215 (test-assert "derivers"
 216   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
 217          (s (add-to-store %store "bash" #t "sha256"
 218                           (search-bootstrap-binary "bash"
 219                                                    (%current-system))))
 220          (d (derivation %store "the-thing"
 221                         s `("-e" ,b)
 222                         #:env-vars `(("foo" . ,(random-text)))
 223                         #:inputs `((,b) (,s))))
 224          (o (derivation->output-path d)))
 225     (and (build-derivations %store (list d))
 226          (equal? (query-derivation-outputs %store (derivation-file-name d))
 227                  (list o))
 228          (equal? (valid-derivers %store o)
 229                  (list (derivation-file-name d))))))
 230
 231 (test-assert "topologically-sorted, one item"
 232   (let* ((a (add-text-to-store %store "a" "a"))
 233          (b (add-text-to-store %store "b" "b" (list a)))
 234          (c (add-text-to-store %store "c" "c" (list b)))
 235          (d (add-text-to-store %store "d" "d" (list c)))
 236          (s (topologically-sorted %store (list d))))
 237     (equal? s (list a b c d))))
 238
 239 (test-assert "topologically-sorted, several items"
 240   (let* ((a  (add-text-to-store %store "a" "a"))
 241          (b  (add-text-to-store %store "b" "b" (list a)))
 242          (c  (add-text-to-store %store "c" "c" (list b)))
 243          (d  (add-text-to-store %store "d" "d" (list c)))
 244          (s1 (topologically-sorted %store (list d a c b)))
 245          (s2 (topologically-sorted %store (list b d c a b d))))
 246     (equal? s1 s2 (list a b c d))))
 247
 248 (test-assert "topologically-sorted, more difficult"
 249   (let* ((a  (add-text-to-store %store "a" "a"))
 250          (b  (add-text-to-store %store "b" "b" (list a)))
 251          (c  (add-text-to-store %store "c" "c" (list b)))
 252          (d  (add-text-to-store %store "d" "d" (list c)))
 253          (w  (add-text-to-store %store "w" "w"))
 254          (x  (add-text-to-store %store "x" "x" (list w)))
 255          (y  (add-text-to-store %store "y" "y" (list x d)))
 256          (s1 (topologically-sorted %store (list y)))
 257          (s2 (topologically-sorted %store (list c y)))
 258          (s3 (topologically-sorted %store (cons y (references %store y)))))
 259     ;; The order in which 'references' returns the references of Y is
 260     ;; unspecified, so accommodate.
 261     (let* ((x-then-d? (equal? (references %store y) (list x d))))
 262       (and (equal? s1
 263                    (if x-then-d?
 264                        (list w x a b c d y)
 265                        (list a b c d w x y)))
 266            (equal? s2
 267                    (if x-then-d?
 268                        (list a b c w x d y)
 269                        (list a b c d w x y)))
 270            (lset= string=? s1 s3)))))
 271
 272 (test-assert "current-build-output-port, UTF-8"
 273   ;; Are UTF-8 strings in the build log properly interpreted?
 274   (string-contains
 275    (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
 276      (call-with-output-string
 277       (lambda (port)
 278         (parameterize ((current-build-output-port port))
 279           (let* ((s "Here’s a Greek letter: λ.")
 280                  (d (build-expression->derivation
 281                      %store "foo" `(display ,s)
 282                      #:guile-for-build
 283                      (package-derivation s %bootstrap-guile (%current-system)))))
 284             (guard (c ((nix-protocol-error? c) #t))
 285               (build-derivations %store (list d))))))))
 286    "Here’s a Greek letter: λ."))
 287
 288 (test-assert "current-build-output-port, UTF-8 + garbage"
 289   ;; What about a mixture of UTF-8 + garbage?
 290   (string-contains
 291    (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
 292      (call-with-output-string
 293       (lambda (port)
 294         (parameterize ((current-build-output-port port))
 295           (let ((d (build-expression->derivation
 296                     %store "foo"
 297                     `(begin
 298                        (use-modules (rnrs io ports))
 299                        (display "garbage: ")
 300                        (put-bytevector (current-output-port) #vu8(128))
 301                        (display "lambda: λ\n"))
 302                      #:guile-for-build
 303                      (package-derivation %store %bootstrap-guile))))
 304             (guard (c ((nix-protocol-error? c) #t))
 305               (build-derivations %store (list d))))))))
 306    "garbage: ?lambda: λ"))
 307
 308 (test-assert "log-file, derivation"
 309   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
 310          (s (add-to-store %store "bash" #t "sha256"
 311                           (search-bootstrap-binary "bash"
 312                                                    (%current-system))))
 313          (d (derivation %store "the-thing"
 314                         s `("-e" ,b)
 315                         #:env-vars `(("foo" . ,(random-text)))
 316                         #:inputs `((,b) (,s)))))
 317     (and (build-derivations %store (list d))
 318          (file-exists? (pk (log-file %store (derivation-file-name d)))))))
 319
 320 (test-assert "log-file, output file name"
 321   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
 322          (s (add-to-store %store "bash" #t "sha256"
 323                           (search-bootstrap-binary "bash"
 324                                                    (%current-system))))
 325          (d (derivation %store "the-thing"
 326                         s `("-e" ,b)
 327                         #:env-vars `(("foo" . ,(random-text)))
 328                         #:inputs `((,b) (,s))))
 329          (o (derivation->output-path d)))
 330     (and (build-derivations %store (list d))
 331          (file-exists? (pk (log-file %store o)))
 332          (string=? (log-file %store (derivation-file-name d))
 333                    (log-file %store o)))))
 334
 335 (test-assert "no substitutes"
 336   (with-store s
 337     (let* ((d1 (package-derivation s %bootstrap-guile (%current-system)))
 338            (d2 (package-derivation s %bootstrap-glibc (%current-system)))
 339            (o  (map derivation->output-path (list d1 d2))))
 340       (set-build-options s #:use-substitutes? #f)
 341       (and (not (has-substitutes? s (derivation-file-name d1)))
 342            (not (has-substitutes? s (derivation-file-name d2)))
 343            (null? (substitutable-paths s o))
 344            (null? (substitutable-path-info s o))))))
 345
 346 (test-assert "build-things with output path"
 347   (with-store s
 348     (let* ((c   (random-text))                    ;contents of the output
 349            (d   (build-expression->derivation
 350                  s "substitute-me"
 351                  `(call-with-output-file %output
 352                     (lambda (p)
 353                       (display ,c p)))
 354                  #:guile-for-build
 355                  (package-derivation s %bootstrap-guile (%current-system))))
 356            (o   (derivation->output-path d)))
 357       (set-build-options s #:use-substitutes? #f)
 358
 359       ;; Pass 'build-things' the output file name, O.  However, since there
 360       ;; are no substitutes for O, it will just do nothing.
 361       (build-things s (list o))
 362       (not (valid-path? s o)))))
 363
 364 (test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))
 365
 366 (test-assert "substitute query"
 367   (with-store s
 368     (let* ((d (package-derivation s %bootstrap-guile (%current-system)))
 369            (o (derivation->output-path d)))
 370       ;; Create fake substituter data, to be read by 'guix substitute'.
 371       (with-derivation-narinfo d
 372         ;; Remove entry from the local cache.
 373         (false-if-exception
 374          (delete-file (string-append (getenv "XDG_CACHE_HOME")
 375                                      "/guix/substitute/"
 376                                      (store-path-hash-part o))))
 377
 378         ;; Make sure 'guix substitute' correctly communicates the above
 379         ;; data.
 380         (set-build-options s #:use-substitutes? #t)
 381         (and (has-substitutes? s o)
 382              (equal? (list o) (substitutable-paths s (list o)))
 383              (match (pk 'spi (substitutable-path-info s (list o)))
 384                (((? substitutable? s))
 385                 (and (string=? (substitutable-deriver s)
 386                                (derivation-file-name d))
 387                      (null? (substitutable-references s))
 388                      (equal? (substitutable-nar-size s) 1234)))))))))
 389
 390 (test-assert "substitute"
 391   (with-store s
 392     (let* ((c   (random-text))                     ; contents of the output
 393            (d   (build-expression->derivation
 394                  s "substitute-me"
 395                  `(call-with-output-file %output
 396                     (lambda (p)
 397                       (exit 1)                     ; would actually fail
 398                       (display ,c p)))
 399                  #:guile-for-build
 400                  (package-derivation s %bootstrap-guile (%current-system))))
 401            (o   (derivation->output-path d)))
 402       (with-derivation-substitute d c
 403         (set-build-options s #:use-substitutes? #t)
 404         (and (has-substitutes? s o)
 405              (build-derivations s (list d))
 406              (equal? c (call-with-input-file o get-string-all)))))))
 407
 408 (test-assert "substitute + build-things with output path"
 409   (with-store s
 410     (let* ((c   (random-text))                    ;contents of the output
 411            (d   (build-expression->derivation
 412                  s "substitute-me"
 413                  `(call-with-output-file %output
 414                     (lambda (p)
 415                       (exit 1)                    ;would actually fail
 416                       (display ,c p)))
 417                  #:guile-for-build
 418                  (package-derivation s %bootstrap-guile (%current-system))))
 419            (o   (derivation->output-path d)))
 420       (with-derivation-substitute d c
 421         (set-build-options s #:use-substitutes? #t)
 422         (and (has-substitutes? s o)
 423              (build-things s (list o))            ;give the output path
 424              (valid-path? s o)
 425              (equal? c (call-with-input-file o get-string-all)))))))
 426
 427 (test-assert "substitute, corrupt output hash"
 428   ;; Tweak the substituter into installing a substitute whose hash doesn't
 429   ;; match the one announced in the narinfo.  The daemon must notice this and
 430   ;; raise an error.
 431   (with-store s
 432     (let* ((c   "hello, world")                    ; contents of the output
 433            (d   (build-expression->derivation
 434                  s "corrupt-substitute"
 435                  `(mkdir %output)
 436                  #:guile-for-build
 437                  (package-derivation s %bootstrap-guile (%current-system))))
 438            (o   (derivation->output-path d)))
 439       (with-derivation-substitute d c
 440         (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C
 441
 442         ;; Make sure we use 'guix substitute'.
 443         (set-build-options s
 444                            #:use-substitutes? #t
 445                            #:fallback? #f)
 446         (and (has-substitutes? s o)
 447              (guard (c ((nix-protocol-error? c)
 448                         ;; XXX: the daemon writes "hash mismatch in downloaded
 449                         ;; path", but the actual error returned to the client
 450                         ;; doesn't mention that.
 451                         (pk 'corrupt c)
 452                         (not (zero? (nix-protocol-error-status c)))))
 453                (build-derivations s (list d))
 454                #f))))))
 455
 456 (test-assert "substitute --fallback"
 457   (with-store s
 458     (let* ((t   (random-text))                    ; contents of the output
 459            (d   (build-expression->derivation
 460                  s "substitute-me-not"
 461                  `(call-with-output-file %output
 462                     (lambda (p)
 463                       (display ,t p)))
 464                  #:guile-for-build
 465                  (package-derivation s %bootstrap-guile (%current-system))))
 466            (o   (derivation->output-path d)))
 467       ;; Create fake substituter data, to be read by 'guix substitute'.
 468       (with-derivation-narinfo d
 469         ;; Make sure we use 'guix substitute'.
 470         (set-build-options s #:use-substitutes? #t)
 471         (and (has-substitutes? s o)
 472              (guard (c ((nix-protocol-error? c)
 473                         ;; The substituter failed as expected.  Now make
 474                         ;; sure that #:fallback? #t works correctly.
 475                         (set-build-options s
 476                                            #:use-substitutes? #t
 477                                            #:fallback? #t)
 478                         (and (build-derivations s (list d))
 479                              (equal? t (call-with-input-file o
 480                                          get-string-all)))))
 481                ;; Should fail.
 482                (build-derivations s (list d))
 483                #f))))))
 484
 485 (test-assert "export/import several paths"
 486   (let* ((texts (unfold (cut >= <> 10)
 487                         (lambda _ (random-text))
 488                         1+
 489                         0))
 490          (files (map (cut add-text-to-store %store "text" <>) texts))
 491          (dump  (call-with-bytevector-output-port
 492                  (cut export-paths %store files <>))))
 493     (delete-paths %store files)
 494     (and (every (negate file-exists?) files)
 495          (let* ((source   (open-bytevector-input-port dump))
 496                 (imported (import-paths %store source)))
 497            (and (equal? imported files)
 498                 (every file-exists? files)
 499                 (equal? texts
 500                         (map (lambda (file)
 501                                (call-with-input-file file
 502                                  get-string-all))
 503                              files)))))))
 504
 505 (test-assert "export/import paths, ensure topological order"
 506   (let* ((file0 (add-text-to-store %store "baz" (random-text)))
 507          (file1 (add-text-to-store %store "foo" (random-text)
 508                                    (list file0)))
 509          (file2 (add-text-to-store %store "bar" (random-text)
 510                                    (list file1)))
 511          (files (list file1 file2))
 512          (dump1 (call-with-bytevector-output-port
 513                  (cute export-paths %store (list file1 file2) <>)))
 514          (dump2 (call-with-bytevector-output-port
 515                  (cute export-paths %store (list file2 file1) <>))))
 516     (delete-paths %store files)
 517     (and (every (negate file-exists?) files)
 518          (bytevector=? dump1 dump2)
 519          (let* ((source   (open-bytevector-input-port dump1))
 520                 (imported (import-paths %store source)))
 521            ;; DUMP1 should contain exactly FILE1 and FILE2, not FILE0.
 522            (and (equal? imported (list file1 file2))
 523                 (every file-exists? files)
 524                 (equal? (list file0) (references %store file1))
 525                 (equal? (list file1) (references %store file2)))))))
 526
 527 (test-assert "export/import incomplete"
 528   (let* ((file0 (add-text-to-store %store "baz" (random-text)))
 529          (file1 (add-text-to-store %store "foo" (random-text)
 530                                    (list file0)))
 531          (file2 (add-text-to-store %store "bar" (random-text)
 532                                    (list file1)))
 533          (dump  (call-with-bytevector-output-port
 534                  (cute export-paths %store (list file2) <>))))
 535     (delete-paths %store (list file0 file1 file2))
 536     (guard (c ((nix-protocol-error? c)
 537                (and (not (zero? (nix-protocol-error-status c)))
 538                     (string-contains (nix-protocol-error-message c)
 539                                      "not valid"))))
 540       ;; Here we get an exception because DUMP does not include FILE0 and
 541       ;; FILE1, which are dependencies of FILE2.
 542       (import-paths %store (open-bytevector-input-port dump)))))
 543
 544 (test-assert "export/import recursive"
 545   (let* ((file0 (add-text-to-store %store "baz" (random-text)))
 546          (file1 (add-text-to-store %store "foo" (random-text)
 547                                    (list file0)))
 548          (file2 (add-text-to-store %store "bar" (random-text)
 549                                    (list file1)))
 550          (dump  (call-with-bytevector-output-port
 551                  (cute export-paths %store (list file2) <>
 552                        #:recursive? #t))))
 553     (delete-paths %store (list file0 file1 file2))
 554     (let ((imported (import-paths %store (open-bytevector-input-port dump))))
 555       (and (equal? imported (list file0 file1 file2))
 556            (every file-exists? (list file0 file1 file2))
 557            (equal? (list file0) (references %store file1))
 558            (equal? (list file1) (references %store file2))))))
 559
 560 (test-assert "import corrupt path"
 561   (let* ((text (random-text))
 562          (file (add-text-to-store %store "text" text))
 563          (dump (call-with-bytevector-output-port
 564                 (cut export-paths %store (list file) <>))))
 565     (delete-paths %store (list file))
 566
 567     ;; Flip a bit in the stream's payload.
 568     (let* ((index (quotient (bytevector-length dump) 4))
 569            (byte  (bytevector-u8-ref dump index)))
 570       (bytevector-u8-set! dump index (logxor #xff byte)))
 571
 572     (and (not (file-exists? file))
 573          (guard (c ((nix-protocol-error? c)
 574                     (pk 'c c)
 575                     (and (not (zero? (nix-protocol-error-status c)))
 576                          (string-contains (nix-protocol-error-message c)
 577                                           "corrupt"))))
 578            (let* ((source   (open-bytevector-input-port dump))
 579                   (imported (import-paths %store source)))
 580              (pk 'corrupt-imported imported)
 581              #f)))))
 582
 583 (test-assert "register-path"
 584   (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f)
 585                              "-fake")))
 586     (when (valid-path? %store file)
 587       (delete-paths %store (list file)))
 588     (false-if-exception (delete-file file))
 589
 590     (let ((ref (add-text-to-store %store "ref-of-fake" (random-text)))
 591           (drv (string-append file ".drv")))
 592       (call-with-output-file file
 593         (cut display "This is a fake store item.\n" <>))
 594       (register-path file
 595                      #:references (list ref)
 596                      #:deriver drv)
 597
 598       (and (valid-path? %store file)
 599            (equal? (references %store file) (list ref))
 600            (null? (valid-derivers %store file))
 601            (null? (referrers %store file))))))
 602
 603 (test-equal "store-lower"
 604   "Lowered."
 605   (let* ((add  (store-lower text-file))
 606          (file (add %store "foo" "Lowered.")))
 607     (call-with-input-file file get-string-all)))
 608
 609 (test-assert "query-path-info"
 610   (let* ((ref (add-text-to-store %store "ref" "foo"))
 611          (item (add-text-to-store %store "item" "bar" (list ref)))
 612          (info (query-path-info %store item)))
 613     (and (equal? (path-info-references info) (list ref))
 614          (equal? (path-info-hash info)
 615                  (sha256
 616                   (string->utf8
 617                    (call-with-output-string (cut write-file item <>))))))))
 618
 619 (test-end "store")
 620
 621 \f
 622 (exit (= (test-runner-fail-count (test-runner-current)) 0))