tests/store.scm

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