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