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