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 "references/substitutes missing reference info"
 200   (with-store s
 201     (set-build-options s #:use-substitutes? #f)
 202     (guard (c ((nix-protocol-error? c) #t))
 203       (let* ((b  (add-to-store s "bash" #t "sha256"
 204                                (search-bootstrap-binary "bash"
 205                                                         (%current-system))))
 206              (d  (derivation s "the-thing" b '("--help")
 207                              #:inputs `((,b)))))
 208         (references/substitutes s (list (derivation->output-path d) b))))))
 209
 210 (test-assert "references/substitutes with substitute info"
 211   (with-store s
 212     (set-build-options s #:use-substitutes? #t)
 213     (let* ((t1 (add-text-to-store s "random1" (random-text)))
 214            (t2 (add-text-to-store s "random2" (random-text)
 215                                   (list t1)))
 216            (t3 (add-text-to-store s "build" "echo -n $t2 > $out"))
 217            (b  (add-to-store s "bash" #t "sha256"
 218                              (search-bootstrap-binary "bash"
 219                                                       (%current-system))))
 220            (d  (derivation s "the-thing" b `("-e" ,t3)
 221                            #:inputs `((,b) (,t3) (,t2))
 222                            #:env-vars `(("t2" . ,t2))))
 223            (o  (derivation->output-path d)))
 224       (with-derivation-narinfo d
 225         (sha256 => (sha256 (string->utf8 t2)))
 226         (references => (list t2))
 227
 228         (equal? (references/substitutes s (list o t3 t2 t1))
 229                 `((,t2)                           ;refs of O
 230                   ()                              ;refs of T3
 231                   (,t1)                           ;refs of T2
 232                   ()))))))                        ;refs of T1
 233
 234 (test-assert "requisites"
 235   (let* ((t1 (add-text-to-store %store "random1"
 236                                 (random-text) '()))
 237          (t2 (add-text-to-store %store "random2"
 238                                 (random-text) (list t1)))
 239          (t3 (add-text-to-store %store "random3"
 240                                 (random-text) (list t2)))
 241          (t4 (add-text-to-store %store "random4"
 242                                 (random-text) (list t1 t3))))
 243     (define (same? x y)
 244       (and (= (length x) (length y))
 245            (lset= equal? x y)))
 246
 247     (and (same? (requisites %store t1) (list t1))
 248          (same? (requisites %store t2) (list t1 t2))
 249          (same? (requisites %store t3) (list t1 t2 t3))
 250          (same? (requisites %store t4) (list t1 t2 t3 t4)))))
 251
 252 (test-assert "derivers"
 253   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
 254          (s (add-to-store %store "bash" #t "sha256"
 255                           (search-bootstrap-binary "bash"
 256                                                    (%current-system))))
 257          (d (derivation %store "the-thing"
 258                         s `("-e" ,b)
 259                         #:env-vars `(("foo" . ,(random-text)))
 260                         #:inputs `((,b) (,s))))
 261          (o (derivation->output-path d)))
 262     (and (build-derivations %store (list d))
 263          (equal? (query-derivation-outputs %store (derivation-file-name d))
 264                  (list o))
 265          (equal? (valid-derivers %store o)
 266                  (list (derivation-file-name d))))))
 267
 268 (test-assert "topologically-sorted, one item"
 269   (let* ((a (add-text-to-store %store "a" "a"))
 270          (b (add-text-to-store %store "b" "b" (list a)))
 271          (c (add-text-to-store %store "c" "c" (list b)))
 272          (d (add-text-to-store %store "d" "d" (list c)))
 273          (s (topologically-sorted %store (list d))))
 274     (equal? s (list a b c d))))
 275
 276 (test-assert "topologically-sorted, several items"
 277   (let* ((a  (add-text-to-store %store "a" "a"))
 278          (b  (add-text-to-store %store "b" "b" (list a)))
 279          (c  (add-text-to-store %store "c" "c" (list b)))
 280          (d  (add-text-to-store %store "d" "d" (list c)))
 281          (s1 (topologically-sorted %store (list d a c b)))
 282          (s2 (topologically-sorted %store (list b d c a b d))))
 283     (equal? s1 s2 (list a b c d))))
 284
 285 (test-assert "topologically-sorted, more difficult"
 286   (let* ((a  (add-text-to-store %store "a" "a"))
 287          (b  (add-text-to-store %store "b" "b" (list a)))
 288          (c  (add-text-to-store %store "c" "c" (list b)))
 289          (d  (add-text-to-store %store "d" "d" (list c)))
 290          (w  (add-text-to-store %store "w" "w"))
 291          (x  (add-text-to-store %store "x" "x" (list w)))
 292          (y  (add-text-to-store %store "y" "y" (list x d)))
 293          (s1 (topologically-sorted %store (list y)))
 294          (s2 (topologically-sorted %store (list c y)))
 295          (s3 (topologically-sorted %store (cons y (references %store y)))))
 296     ;; The order in which 'references' returns the references of Y is
 297     ;; unspecified, so accommodate.
 298     (let* ((x-then-d? (equal? (references %store y) (list x d))))
 299       (and (equal? s1
 300                    (if x-then-d?
 301                        (list w x a b c d y)
 302                        (list a b c d w x y)))
 303            (equal? s2
 304                    (if x-then-d?
 305                        (list a b c w x d y)
 306                        (list a b c d w x y)))
 307            (lset= string=? s1 s3)))))
 308
 309 (test-assert "current-build-output-port, UTF-8"
 310   ;; Are UTF-8 strings in the build log properly interpreted?
 311   (string-contains
 312    (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
 313      (call-with-output-string
 314       (lambda (port)
 315         (parameterize ((current-build-output-port port))
 316           (let* ((s "Here’s a Greek letter: λ.")
 317                  (d (build-expression->derivation
 318                      %store "foo" `(display ,s)
 319                      #:guile-for-build
 320                      (package-derivation s %bootstrap-guile (%current-system)))))
 321             (guard (c ((nix-protocol-error? c) #t))
 322               (build-derivations %store (list d))))))))
 323    "Here’s a Greek letter: λ."))
 324
 325 (test-assert "current-build-output-port, UTF-8 + garbage"
 326   ;; What about a mixture of UTF-8 + garbage?
 327   (string-contains
 328    (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port
 329      (call-with-output-string
 330       (lambda (port)
 331         (parameterize ((current-build-output-port port))
 332           (let ((d (build-expression->derivation
 333                     %store "foo"
 334                     `(begin
 335                        (use-modules (rnrs io ports))
 336                        (display "garbage: ")
 337                        (put-bytevector (current-output-port) #vu8(128))
 338                        (display "lambda: λ\n"))
 339                      #:guile-for-build
 340                      (package-derivation %store %bootstrap-guile))))
 341             (guard (c ((nix-protocol-error? c) #t))
 342               (build-derivations %store (list d))))))))
 343    "garbage: ?lambda: λ"))
 344
 345 (test-assert "log-file, derivation"
 346   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
 347          (s (add-to-store %store "bash" #t "sha256"
 348                           (search-bootstrap-binary "bash"
 349                                                    (%current-system))))
 350          (d (derivation %store "the-thing"
 351                         s `("-e" ,b)
 352                         #:env-vars `(("foo" . ,(random-text)))
 353                         #:inputs `((,b) (,s)))))
 354     (and (build-derivations %store (list d))
 355          (file-exists? (pk (log-file %store (derivation-file-name d)))))))
 356
 357 (test-assert "log-file, output file name"
 358   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
 359          (s (add-to-store %store "bash" #t "sha256"
 360                           (search-bootstrap-binary "bash"
 361                                                    (%current-system))))
 362          (d (derivation %store "the-thing"
 363                         s `("-e" ,b)
 364                         #:env-vars `(("foo" . ,(random-text)))
 365                         #:inputs `((,b) (,s))))
 366          (o (derivation->output-path d)))
 367     (and (build-derivations %store (list d))
 368          (file-exists? (pk (log-file %store o)))
 369          (string=? (log-file %store (derivation-file-name d))
 370                    (log-file %store o)))))
 371
 372 (test-assert "no substitutes"
 373   (with-store s
 374     (let* ((d1 (package-derivation s %bootstrap-guile (%current-system)))
 375            (d2 (package-derivation s %bootstrap-glibc (%current-system)))
 376            (o  (map derivation->output-path (list d1 d2))))
 377       (set-build-options s #:use-substitutes? #f)
 378       (and (not (has-substitutes? s (derivation-file-name d1)))
 379            (not (has-substitutes? s (derivation-file-name d2)))
 380            (null? (substitutable-paths s o))
 381            (null? (substitutable-path-info s o))))))
 382
 383 (test-assert "build-things with output path"
 384   (with-store s
 385     (let* ((c   (random-text))                    ;contents of the output
 386            (d   (build-expression->derivation
 387                  s "substitute-me"
 388                  `(call-with-output-file %output
 389                     (lambda (p)
 390                       (display ,c p)))
 391                  #:guile-for-build
 392                  (package-derivation s %bootstrap-guile (%current-system))))
 393            (o   (derivation->output-path d)))
 394       (set-build-options s #:use-substitutes? #f)
 395
 396       ;; Pass 'build-things' the output file name, O.  However, since there
 397       ;; are no substitutes for O, it will just do nothing.
 398       (build-things s (list o))
 399       (not (valid-path? s o)))))
 400
 401 (test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))
 402
 403 (test-assert "substitute query"
 404   (with-store s
 405     (let* ((d (package-derivation s %bootstrap-guile (%current-system)))
 406            (o (derivation->output-path d)))
 407       ;; Create fake substituter data, to be read by 'guix substitute'.
 408       (with-derivation-narinfo d
 409         ;; Remove entry from the local cache.
 410         (false-if-exception
 411          (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
 412                                                  "/guix/substitute")))
 413
 414         ;; Make sure 'guix substitute' correctly communicates the above
 415         ;; data.
 416         (set-build-options s #:use-substitutes? #t
 417                            #:substitute-urls (%test-substitute-urls))
 418         (and (has-substitutes? s o)
 419              (equal? (list o) (substitutable-paths s (list o)))
 420              (match (pk 'spi (substitutable-path-info s (list o)))
 421                (((? substitutable? s))
 422                 (and (string=? (substitutable-deriver s)
 423                                (derivation-file-name d))
 424                      (null? (substitutable-references s))
 425                      (equal? (substitutable-nar-size s) 1234)))))))))
 426
 427 (test-assert "substitute query, alternating URLs"
 428   (let* ((d (with-store s
 429               (package-derivation s %bootstrap-guile (%current-system))))
 430          (o (derivation->output-path d)))
 431     (with-derivation-narinfo d
 432       ;; Remove entry from the local cache.
 433       (false-if-exception
 434        (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME")
 435                                                "/guix/substitute")))
 436
 437       ;; Note: We reconnect to the daemon to force a new instance of 'guix
 438       ;; substitute' to be used; otherwise the #:substitute-urls of
 439       ;; 'set-build-options' would have no effect.
 440
 441       (and (with-store s                        ;the right substitute URL
 442              (set-build-options s #:use-substitutes? #t
 443                                 #:substitute-urls (%test-substitute-urls))
 444              (has-substitutes? s o))
 445            (with-store s                        ;the wrong one
 446              (set-build-options s #:use-substitutes? #t
 447                                 #:substitute-urls (list
 448                                                    "http://does-not-exist"))
 449              (not (has-substitutes? s o)))
 450            (with-store s                        ;the right one again
 451              (set-build-options s #:use-substitutes? #t
 452                                 #:substitute-urls (%test-substitute-urls))
 453              (has-substitutes? s o))
 454            (with-store s                        ;empty list of URLs
 455              (set-build-options s #:use-substitutes? #t
 456                                 #:substitute-urls '())
 457              (not (has-substitutes? s o)))))))
 458
 459 (test-assert "substitute"
 460   (with-store s
 461     (let* ((c   (random-text))                     ; contents of the output
 462            (d   (build-expression->derivation
 463                  s "substitute-me"
 464                  `(call-with-output-file %output
 465                     (lambda (p)
 466                       (exit 1)                     ; would actually fail
 467                       (display ,c p)))
 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         (set-build-options s #:use-substitutes? #t
 473                            #:substitute-urls (%test-substitute-urls))
 474         (and (has-substitutes? s o)
 475              (build-derivations s (list d))
 476              (equal? c (call-with-input-file o get-string-all)))))))
 477
 478 (test-assert "substitute + build-things with output path"
 479   (with-store s
 480     (let* ((c   (random-text))                    ;contents of the output
 481            (d   (build-expression->derivation
 482                  s "substitute-me"
 483                  `(call-with-output-file %output
 484                     (lambda (p)
 485                       (exit 1)                    ;would actually fail
 486                       (display ,c p)))
 487                  #:guile-for-build
 488                  (package-derivation s %bootstrap-guile (%current-system))))
 489            (o   (derivation->output-path d)))
 490       (with-derivation-substitute d c
 491         (set-build-options s #:use-substitutes? #t
 492                            #:substitute-urls (%test-substitute-urls))
 493         (and (has-substitutes? s o)
 494              (build-things s (list o))            ;give the output path
 495              (valid-path? s o)
 496              (equal? c (call-with-input-file o get-string-all)))))))
 497
 498 (test-assert "substitute, corrupt output hash"
 499   ;; Tweak the substituter into installing a substitute whose hash doesn't
 500   ;; match the one announced in the narinfo.  The daemon must notice this and
 501   ;; raise an error.
 502   (with-store s
 503     (let* ((c   "hello, world")                    ; contents of the output
 504            (d   (build-expression->derivation
 505                  s "corrupt-substitute"
 506                  `(mkdir %output)
 507                  #:guile-for-build
 508                  (package-derivation s %bootstrap-guile (%current-system))))
 509            (o   (derivation->output-path d)))
 510       (with-derivation-substitute d c
 511         (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C
 512
 513         ;; Make sure we use 'guix substitute'.
 514         (set-build-options s
 515                            #:use-substitutes? #t
 516                            #:fallback? #f
 517                            #:substitute-urls (%test-substitute-urls))
 518         (and (has-substitutes? s o)
 519              (guard (c ((nix-protocol-error? c)
 520                         ;; XXX: the daemon writes "hash mismatch in downloaded
 521                         ;; path", but the actual error returned to the client
 522                         ;; doesn't mention that.
 523                         (pk 'corrupt c)
 524                         (not (zero? (nix-protocol-error-status c)))))
 525                (build-derivations s (list d))
 526                #f))))))
 527
 528 (test-assert "substitute --fallback"
 529   (with-store s
 530     (let* ((t   (random-text))                    ; contents of the output
 531            (d   (build-expression->derivation
 532                  s "substitute-me-not"
 533                  `(call-with-output-file %output
 534                     (lambda (p)
 535                       (display ,t p)))
 536                  #:guile-for-build
 537                  (package-derivation s %bootstrap-guile (%current-system))))
 538            (o   (derivation->output-path d)))
 539       ;; Create fake substituter data, to be read by 'guix substitute'.
 540       (with-derivation-narinfo d
 541         ;; Make sure we use 'guix substitute'.
 542         (set-build-options s #:use-substitutes? #t
 543                            #:substitute-urls (%test-substitute-urls))
 544         (and (has-substitutes? s o)
 545              (guard (c ((nix-protocol-error? c)
 546                         ;; The substituter failed as expected.  Now make
 547                         ;; sure that #:fallback? #t works correctly.
 548                         (set-build-options s
 549                                            #:use-substitutes? #t
 550                                            #:substitute-urls
 551                                              (%test-substitute-urls)
 552                                            #:fallback? #t)
 553                         (and (build-derivations s (list d))
 554                              (equal? t (call-with-input-file o
 555                                          get-string-all)))))
 556                ;; Should fail.
 557                (build-derivations s (list d))
 558                #f))))))
 559
 560 (test-assert "export/import several paths"
 561   (let* ((texts (unfold (cut >= <> 10)
 562                         (lambda _ (random-text))
 563                         1+
 564                         0))
 565          (files (map (cut add-text-to-store %store "text" <>) texts))
 566          (dump  (call-with-bytevector-output-port
 567                  (cut export-paths %store files <>))))
 568     (delete-paths %store files)
 569     (and (every (negate file-exists?) files)
 570          (let* ((source   (open-bytevector-input-port dump))
 571                 (imported (import-paths %store source)))
 572            (and (equal? imported files)
 573                 (every file-exists? files)
 574                 (equal? texts
 575                         (map (lambda (file)
 576                                (call-with-input-file file
 577                                  get-string-all))
 578                              files)))))))
 579
 580 (test-assert "export/import paths, ensure topological order"
 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          (files (list file1 file2))
 587          (dump1 (call-with-bytevector-output-port
 588                  (cute export-paths %store (list file1 file2) <>)))
 589          (dump2 (call-with-bytevector-output-port
 590                  (cute export-paths %store (list file2 file1) <>))))
 591     (delete-paths %store files)
 592     (and (every (negate file-exists?) files)
 593          (bytevector=? dump1 dump2)
 594          (let* ((source   (open-bytevector-input-port dump1))
 595                 (imported (import-paths %store source)))
 596            ;; DUMP1 should contain exactly FILE1 and FILE2, not FILE0.
 597            (and (equal? imported (list file1 file2))
 598                 (every file-exists? files)
 599                 (equal? (list file0) (references %store file1))
 600                 (equal? (list file1) (references %store file2)))))))
 601
 602 (test-assert "export/import incomplete"
 603   (let* ((file0 (add-text-to-store %store "baz" (random-text)))
 604          (file1 (add-text-to-store %store "foo" (random-text)
 605                                    (list file0)))
 606          (file2 (add-text-to-store %store "bar" (random-text)
 607                                    (list file1)))
 608          (dump  (call-with-bytevector-output-port
 609                  (cute export-paths %store (list file2) <>))))
 610     (delete-paths %store (list file0 file1 file2))
 611     (guard (c ((nix-protocol-error? c)
 612                (and (not (zero? (nix-protocol-error-status c)))
 613                     (string-contains (nix-protocol-error-message c)
 614                                      "not valid"))))
 615       ;; Here we get an exception because DUMP does not include FILE0 and
 616       ;; FILE1, which are dependencies of FILE2.
 617       (import-paths %store (open-bytevector-input-port dump)))))
 618
 619 (test-assert "export/import recursive"
 620   (let* ((file0 (add-text-to-store %store "baz" (random-text)))
 621          (file1 (add-text-to-store %store "foo" (random-text)
 622                                    (list file0)))
 623          (file2 (add-text-to-store %store "bar" (random-text)
 624                                    (list file1)))
 625          (dump  (call-with-bytevector-output-port
 626                  (cute export-paths %store (list file2) <>
 627                        #:recursive? #t))))
 628     (delete-paths %store (list file0 file1 file2))
 629     (let ((imported (import-paths %store (open-bytevector-input-port dump))))
 630       (and (equal? imported (list file0 file1 file2))
 631            (every file-exists? (list file0 file1 file2))
 632            (equal? (list file0) (references %store file1))
 633            (equal? (list file1) (references %store file2))))))
 634
 635 (test-assert "write-file & export-path yield the same result"
 636   ;; Here we compare 'write-file' and the daemon's own implementation.
 637   ;; 'write-file' is the reference because we know it sorts file
 638   ;; deterministically.  Conversely, the daemon uses 'readdir' and the entries
 639   ;; currently happen to be sorted as a side-effect of some unrelated
 640   ;; operation (search for 'unhacked' in archive.cc.)  Make sure we detect any
 641   ;; changes there.
 642   (run-with-store %store
 643     (mlet* %store-monad ((drv1 (package->derivation %bootstrap-guile))
 644                          (out1 -> (derivation->output-path drv1))
 645                          (data -> (unfold (cut >= <> 26)
 646                                           (lambda (i)
 647                                             (random-bytevector 128))
 648                                           1+ 0))
 649                          (build
 650                           -> #~(begin
 651                                  (use-modules (rnrs io ports) (srfi srfi-1))
 652                                  (let ()
 653                                    (define letters
 654                                      (map (lambda (i)
 655                                             (string
 656                                              (integer->char
 657                                               (+ i (char->integer #\a)))))
 658                                           (iota 26)))
 659                                    (define (touch file data)
 660                                      (call-with-output-file file
 661                                        (lambda (port)
 662                                          (put-bytevector port data))))
 663
 664                                    (mkdir #$output)
 665                                    (chdir #$output)
 666
 667                                    ;; The files must be different so they have
 668                                    ;; different inode numbers, and the inode
 669                                    ;; order must differ from the lexicographic
 670                                    ;; order.
 671                                    (for-each touch
 672                                              (append (drop letters 10)
 673                                                      (take letters 10))
 674                                              (list #$@data))
 675                                    #t)))
 676                          (drv2 (gexp->derivation "bunch" build))
 677                          (out2 -> (derivation->output-path drv2))
 678                          (item-info -> (store-lift query-path-info)))
 679       (mbegin %store-monad
 680         (built-derivations (list drv1 drv2))
 681         (foldm %store-monad
 682                (lambda (item result)
 683                  (define ref-hash
 684                    (let-values (((port get) (open-sha256-port)))
 685                      (write-file item port)
 686                      (close-port port)
 687                      (get)))
 688
 689                  ;; 'query-path-info' returns a hash produced by using the
 690                  ;; daemon's C++ 'dump' function, which is the implementation
 691                  ;; under test.
 692                  (>>= (item-info item)
 693                       (lambda (info)
 694                         (return
 695                          (and result
 696                               (bytevector=? (path-info-hash info) ref-hash))))))
 697                #t
 698                (list out1 out2))))
 699     #:guile-for-build (%guile-for-build)))
 700
 701 (test-assert "import corrupt path"
 702   (let* ((text (random-text))
 703          (file (add-text-to-store %store "text" text))
 704          (dump (call-with-bytevector-output-port
 705                 (cut export-paths %store (list file) <>))))
 706     (delete-paths %store (list file))
 707
 708     ;; Flip a bit in the stream's payload.
 709     (let* ((index (quotient (bytevector-length dump) 4))
 710            (byte  (bytevector-u8-ref dump index)))
 711       (bytevector-u8-set! dump index (logxor #xff byte)))
 712
 713     (and (not (file-exists? file))
 714          (guard (c ((nix-protocol-error? c)
 715                     (pk 'c c)
 716                     (and (not (zero? (nix-protocol-error-status c)))
 717                          (string-contains (nix-protocol-error-message c)
 718                                           "corrupt"))))
 719            (let* ((source   (open-bytevector-input-port dump))
 720                   (imported (import-paths %store source)))
 721              (pk 'corrupt-imported imported)
 722              #f)))))
 723
 724 (test-assert "register-path"
 725   (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f)
 726                              "-fake")))
 727     (when (valid-path? %store file)
 728       (delete-paths %store (list file)))
 729     (false-if-exception (delete-file file))
 730
 731     (let ((ref (add-text-to-store %store "ref-of-fake" (random-text)))
 732           (drv (string-append file ".drv")))
 733       (call-with-output-file file
 734         (cut display "This is a fake store item.\n" <>))
 735       (register-path file
 736                      #:references (list ref)
 737                      #:deriver drv)
 738
 739       (and (valid-path? %store file)
 740            (equal? (references %store file) (list ref))
 741            (null? (valid-derivers %store file))
 742            (null? (referrers %store file))))))
 743
 744 (test-assert "verify-store"
 745   (let* ((text  (random-text))
 746          (file1 (add-text-to-store %store "foo" text))
 747          (file2 (add-text-to-store %store "bar" (random-text)
 748                                    (list file1))))
 749     (and (pk 'verify1 (verify-store %store))    ;hopefully OK ;
 750          (begin
 751            (delete-file file1)
 752            (not (pk 'verify2 (verify-store %store)))) ;bad! ;
 753          (begin
 754            ;; Using 'add-text-to-store' here wouldn't work: It would succeed ;
 755            ;; without actually creating the file. ;
 756            (call-with-output-file file1
 757              (lambda (port)
 758                (display text port)))
 759            (pk 'verify3 (verify-store %store)))))) ;OK again
 760
 761 (test-assert "verify-store + check-contents"
 762   ;; XXX: This test is I/O intensive.
 763   (with-store s
 764     (let* ((text (random-text))
 765            (drv  (build-expression->derivation
 766                   s "corrupt"
 767                   `(let ((out (assoc-ref %outputs "out")))
 768                      (call-with-output-file out
 769                        (lambda (port)
 770                          (display ,text port)))
 771                      #t)
 772                   #:guile-for-build
 773                   (package-derivation s %bootstrap-guile (%current-system))))
 774            (file (derivation->output-path drv)))
 775       (with-derivation-substitute drv text
 776         (and (build-derivations s (list drv))
 777              (verify-store s #:check-contents? #t) ;should be OK
 778              (begin
 779                (chmod file #o644)
 780                (call-with-output-file file
 781                  (lambda (port)
 782                    (display "corrupt!" port)))
 783                #t)
 784
 785              ;; Make sure the corruption is detected.  We don't test repairing
 786              ;; because only "trusted" users are allowed to do it, but we
 787              ;; don't expose that notion of trusted users that nix-daemon
 788              ;; supports because it seems dubious and redundant with what the
 789              ;; OS provides (in Nix "trusted" users have additional
 790              ;; privileges, such as overriding the set of substitute URLs, but
 791              ;; we instead want to allow anyone to modify them, provided
 792              ;; substitutes are signed by a root-approved key.)
 793              (not (verify-store s #:check-contents? #t))
 794
 795              ;; Delete the corrupt item to leave the store in a clean state.
 796              (delete-paths s (list file)))))))
 797
 798 (test-assert "build-things, check mode"
 799   (with-store store
 800     (call-with-temporary-output-file
 801      (lambda (entropy entropy-port)
 802        (write (random-text) entropy-port)
 803        (force-output entropy-port)
 804        (let* ((drv  (build-expression->derivation
 805                      store "non-deterministic"
 806                      `(begin
 807                         (use-modules (rnrs io ports))
 808                         (let ((out (assoc-ref %outputs "out")))
 809                           (call-with-output-file out
 810                             (lambda (port)
 811                               ;; Rely on the fact that tests do not use the
 812                               ;; chroot, and thus ENTROPY is readable.
 813                               (display (call-with-input-file ,entropy
 814                                          get-string-all)
 815                                        port)))
 816                           #t))
 817                      #:guile-for-build
 818                      (package-derivation store %bootstrap-guile (%current-system))))
 819               (file (derivation->output-path drv)))
 820          (and (build-things store (list (derivation-file-name drv)))
 821               (begin
 822                 (write (random-text) entropy-port)
 823                 (force-output entropy-port)
 824                 (guard (c ((nix-protocol-error? c)
 825                            (pk 'determinism-exception 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.  Since we're in
 830                   ;; 'check' mode, this must fail.
 831                   (build-things store (list (derivation-file-name drv))
 832                                 (build-mode check))
 833                   #f))))))))
 834
 835 (test-assert "build multiple times"
 836   (with-store store
 837     ;; Ask to build twice.
 838     (set-build-options store #:rounds 2 #:use-substitutes? #f)
 839
 840     (call-with-temporary-output-file
 841      (lambda (entropy entropy-port)
 842        (write (random-text) entropy-port)
 843        (force-output entropy-port)
 844        (let* ((drv  (build-expression->derivation
 845                      store "non-deterministic"
 846                      `(begin
 847                         (use-modules (rnrs io ports))
 848                         (let ((out (assoc-ref %outputs "out")))
 849                           (call-with-output-file out
 850                             (lambda (port)
 851                               ;; Rely on the fact that tests do not use the
 852                               ;; chroot, and thus ENTROPY is accessible.
 853                               (display (call-with-input-file ,entropy
 854                                          get-string-all)
 855                                        port)
 856                               (call-with-output-file ,entropy
 857                                 (lambda (port)
 858                                   (write 'foobar port)))))
 859                           #t))
 860                      #:guile-for-build
 861                      (package-derivation store %bootstrap-guile (%current-system))))
 862               (file (derivation->output-path drv)))
 863          (guard (c ((nix-protocol-error? c)
 864                     (pk 'multiple-build c)
 865                     (and (not (zero? (nix-protocol-error-status c)))
 866                          (string-contains (nix-protocol-error-message c)
 867                                           "deterministic"))))
 868            ;; This one will produce a different result on the second run.
 869            (current-build-output-port (current-error-port))
 870            (build-things store (list (derivation-file-name drv)))
 871            #f))))))
 872
 873 (test-equal "store-lower"
 874   "Lowered."
 875   (let* ((add  (store-lower text-file))
 876          (file (add %store "foo" "Lowered.")))
 877     (call-with-input-file file get-string-all)))
 878
 879 (test-equal "current-system"
 880   "bar"
 881   (parameterize ((%current-system "frob"))
 882     (run-with-store %store
 883       (mbegin %store-monad
 884         (set-current-system "bar")
 885         (current-system))
 886       #:system "foo")))
 887
 888 (test-assert "query-path-info"
 889   (let* ((ref (add-text-to-store %store "ref" "foo"))
 890          (item (add-text-to-store %store "item" "bar" (list ref)))
 891          (info (query-path-info %store item)))
 892     (and (equal? (path-info-references info) (list ref))
 893          (equal? (path-info-hash info)
 894                  (sha256
 895                   (string->utf8
 896                    (call-with-output-string (cut write-file item <>))))))))
 897
 898 (test-assert "path-info-deriver"
 899   (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
 900          (s (add-to-store %store "bash" #t "sha256"
 901                           (search-bootstrap-binary "bash"
 902                                                    (%current-system))))
 903          (d (derivation %store "the-thing"
 904                         s `("-e" ,b)
 905                         #:env-vars `(("foo" . ,(random-text)))
 906                         #:inputs `((,b) (,s))))
 907          (o (derivation->output-path d)))
 908     (and (build-derivations %store (list d))
 909          (not (path-info-deriver (query-path-info %store b)))
 910          (string=? (derivation-file-name d)
 911                    (path-info-deriver (query-path-info %store o))))))
 912
 913 (test-end "store")