tests/store.scm

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