tests/store.scm

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