;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . (define-module (test-store) #:use-module (guix tests) #:use-module (guix config) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix monads) #:use-module ((gcrypt hash) #:prefix
aboutsummaryrefslogtreecommitdiff
blob: b8d2f8486e9c7fb3775f4741708f98e2da75d319 (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 David Craven <david@craven.ch>
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu services spice)
  #:use-module (gnu packages spice)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (guix deprecation)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:export (spice-vdagent-configuration
            spice-vdagent-configuration?
            spice-vdagent-service-type
            spice-vdagent-service))  ; deprecated

(define-record-type* <spice-vdagent-configuration>
  spice-vdagent-configuration make-spice-vdagent-configuration
  spice-vdagent-configuration?
  (spice-vdagent spice-vdagent-configuration-spice-vdagent
                 (default spice-vdagent)))

(define (spice-vdagent-shepherd-service config)
  "Return a <shepherd-service> for spice-vdagentd with CONFIG."
  (define spice-vdagent (spice-vdagent-configuration-spice-vdagent config))

  (define spice-vdagentd-command
    (list
     (file-append spice-vdagent "/sbin/spice-vdagentd")
     "-x"))

  (list
   (shepherd-service
    (documentation "Spice vdagentd service")
    (requirement '(dbus-system))
    (provision '(spice-vdagentd))
    (start #~(lambda args
               ;; spice-vdagentd supports being activated upon the client
               ;; connecting to its socket; when not using such feature, the
               ;; socket should not exist before vdagentd creates it itself.
               (mkdir-p "/run/spice-vdagentd")
               (false-if-exception
                (delete-file "/run/spice-vdagentd/spice-vdagent-sock"))
               (fork+exec-command '#$spice-vdagentd-command)))
    (stop #~(make-kill-destructor)))))

(define spice-vdagent-profile
  (compose list spice-vdagent-configuration-spice-vdagent))

(define spice-vdagent-service-type
  (service-type
   (name 'spice-vdagent)
   (default-value (spice-vdagent-configuration))
   (extensions
    (list (service-extension shepherd-root-service-type
                             spice-vdagent-shepherd-service)
          (service-extension profile-service-type
                             spice-vdagent-profile)))
   (description "Start the @command{vdagentd} and @command{vdagent} daemons
from the @code{spice-vdagent} package to enable window resizing and clipboard
sharing for @acronym{VM, virtual machine} guests.")))

(define-deprecated (spice-vdagent-service
                    #:optional (config (spice-vdagent-configuration)))
  "Start the @command{vdagentd} and @command{vdagent} daemons
from @var{spice-vdagent} to enable guest window resizing and
clipboard sharing."
  (service spice-vdagent-service-type config))
d-to-store store "delete-me" #t "sha256" file)) (lset= string=? deleted (list path1 path2)) (valid-path? store path1) (valid-path? store path2) (file-exists? path1) (file-exists? path2))))) (test-equal "add-file-tree-to-store" `(42 ("." directory #t) ("./bar" directory #t) ("./foo" directory #t) ("./foo/a" regular "file a") ("./foo/b" symlink "a") ("./foo/c" directory #t) ("./foo/c/p" regular "file p") ("./foo/c/q" directory #t) ("./foo/c/q/x" regular ,(string-append "#!" %shell "\nexit 42")) ("./foo/c/q/y" symlink "..") ("./foo/c/q/z" directory #t)) (let* ((tree `("file-tree" directory ("foo" directory ("a" regular (data "file a")) ("b" symlink "a") ("c" directory ("p" regular (data ,(string->utf8 "file p"))) ("q" directory ("x" executable (data ,(string-append "#!" %shell "\nexit 42"))) ("y" symlink "..") ("z" directory)))) ("bar" directory))) (result (add-file-tree-to-store %store tree))) (cons (status:exit-val (system* (string-append result "/foo/c/q/x"))) (with-directory-excursion result (map (lambda (file) (let ((type (stat:type (lstat file)))) `(,file ,type ,(match type ((or 'regular 'executable) (call-with-input-file file get-string-all)) ('symlink (readlink file)) ('directory #t))))) (find-files "." #:directories? #t)))))) (test-equal "add-file-tree-to-store, flat" "Hello, world!" (let* ((tree `("flat-file" regular (data "Hello, world!"))) (result (add-file-tree-to-store %store tree))) (and (file-exists? result) (call-with-input-file result get-string-all)))) (test-assert "references" (let* ((t1 (add-text-to-store %store "random1" (random-text))) (t2 (add-text-to-store %store "random2" (random-text) (list t1)))) (and (equal? (list t1) (references %store t2)) (equal? (list t2) (referrers %store t1)) (null? (references %store t1)) (null? (referrers %store t2))))) (test-equal "substitutable-path-info when substitutes are turned off" '() (with-store s (set-build-options s #:use-substitutes? #f) (let* ((b (add-to-store s "bash" #t "sha256" (search-bootstrap-binary "bash" (%current-system)))) (d (derivation s "the-thing" b '("--version") #:inputs `((,b)))) (o (derivation->output-path d))) (with-derivation-narinfo d (substitutable-path-info s (list o)))))) (test-equal "substitutable-paths when substitutes are turned off" '() (with-store s (set-build-options s #:use-substitutes? #f) (let* ((b (add-to-store s "bash" #t "sha256" (search-bootstrap-binary "bash" (%current-system)))) (d (derivation s "the-thing" b '("--version") #:inputs `((,b)))) (o (derivation->output-path d))) (with-derivation-narinfo d (substitutable-paths s (list o)))))) (test-assert "requisites" (let* ((t1 (add-text-to-store %store "random1" (random-text) '())) (t2 (add-text-to-store %store "random2" (random-text) (list t1))) (t3 (add-text-to-store %store "random3" (random-text) (list t2))) (t4 (add-text-to-store %store "random4" (random-text) (list t1 t3)))) (define (same? x y) (and (= (length x) (length y)) (lset= equal? x y))) (and (same? (requisites %store (list t1)) (list t1)) (same? (requisites %store (list t2)) (list t1 t2)) (same? (requisites %store (list t3)) (list t1 t2 t3)) (same? (requisites %store (list t4)) (list t1 t2 t3 t4)) (same? (requisites %store (list t1 t2 t3 t4)) (list t1 t2 t3 t4))))) (test-assert "derivers" (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) (s (add-to-store %store "bash" #t "sha256" (search-bootstrap-binary "bash" (%current-system)))) (d (derivation %store "the-thing" s `("-e" ,b) #:env-vars `(("foo" . ,(random-text))) #:inputs `((,b) (,s)))) (o (derivation->output-path d))) (and (build-derivations %store (list d)) (equal? (query-derivation-outputs %store (derivation-file-name d)) (list o)) (equal? (valid-derivers %store o) (list (derivation-file-name d)))))) (test-equal "with-build-handler" 'success (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) (s (add-to-store %store "bash" #t "sha256" (search-bootstrap-binary "bash" (%current-system)))) (d1 (derivation %store "the-thing" s `("-e" ,b) #:env-vars `(("foo" . ,(random-text))) #:sources (list b s))) (d2 (derivation %store "the-thing" s `("-e" ,b) #:env-vars `(("foo" . ,(random-text)) ("bar" . "baz")) #:sources (list b s))) (o1 (derivation->output-path d1)) (o2 (derivation->output-path d2))) (with-build-handler (let ((counter 0)) (lambda (continue store things mode) (match things ((drv) (set! counter (+ 1 counter)) (if (string=? drv (derivation-file-name d1)) (continue #t) (and (string=? drv (derivation-file-name d2)) (= counter 2) 'success)))))) (build-derivations %store (list d1)) (build-derivations %store (list d2)) 'fail))) (test-equal "with-build-handler + with-store" 'success ;; Check that STORE remains valid when the build handler invokes CONTINUE, ;; even though 'with-build-handler' is outside the dynamic extent of ;; 'with-store'. (with-build-handler (lambda (continue store things mode) (match things ((drv) (and (string-suffix? "thingie.drv" drv) (not (port-closed? (store-connection-socket store))) (continue #t))))) (with-store store (let* ((b (add-text-to-store store "build" "echo $foo > $out" '())) (s (add-to-store store "bash" #t "sha256" (search-bootstrap-binary "bash" (%current-system)))) (d (derivation store "thingie" s `("-e" ,b) #:env-vars `(("foo" . ,(random-text))) #:sources (list b s)))) (build-derivations store (list d)) ;; Here STORE's socket should still be open. (and (valid-path? store (derivation->output-path d)) 'success))))) (test-assert "map/accumulate-builds" (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) (s (add-to-store %store "bash" #t "sha256" (search-bootstrap-binary "bash" (%current-system)))) (d1 (derivation %store "the-thing" s `("-e" ,b) #:env-vars `(("foo" . ,(random-text))) #:sources (list b s))) (d2 (derivation %store "the-thing" s `("-e" ,b) #:env-vars `(("foo" . ,(random-text)) ("bar" . "baz")) #:sources (list b s)))) (with-build-handler (lambda (continue store things mode) (equal? (map derivation-file-name (list d1 d2)) things)) (map/accumulate-builds %store (lambda (drv) (build-derivations %store (list drv)) (add-to-store %store "content-addressed" #t "sha256" (derivation->output-path drv))) (list d1 d2))))) (test-assert "mapm/accumulate-builds" (let* ((d1 (run-with-store %store (gexp->derivation "foo" #~(mkdir #$output)))) (d2 (run-with-store %store (gexp->derivation "bar" #~(mkdir #$output))))) (with-build-handler (lambda (continue store things mode) (equal? (map derivation-file-name (pk 'zz (list d1 d2))) (pk 'XX things))) (run-with-store %store (mapm/accumulate-builds built-derivations `((,d1) (,d2))))))) (test-equal "mapm/accumulate-builds, %current-target-system" (make-list 2 '("i586-pc-gnu" "i586-pc-gnu")) ;; Both the 'mapm' and 'mapm/accumulate-builds' procedures should see the ;; right #:target. (run-with-store %store (mlet %store-monad ((lst1 (mapm %store-monad (lambda _ (current-target-system)) '(a b))) (lst2 (mapm/accumulate-builds (lambda _ (current-target-system)) '(a b)))) (return (list lst1 lst2))) #:system system #:target "i586-pc-gnu")) (test-assert "topologically-sorted, one item" (let* ((a (add-text-to-store %store "a" "a")) (b (add-text-to-store %store "b" "b" (list a))) (c (add-text-to-store %store "c" "c" (list b))) (d (add-text-to-store %store "d" "d" (list c))) (s (topologically-sorted %store (list d)))) (equal? s (list a b c d)))) (test-assert "topologically-sorted, several items" (let* ((a (add-text-to-store %store "a" "a")) (b (add-text-to-store %store "b" "b" (list a))) (c (add-text-to-store %store "c" "c" (list b))) (d (add-text-to-store %store "d" "d" (list c))) (s1 (topologically-sorted %store (list d a c b))) (s2 (topologically-sorted %store (list b d c a b d)))) (equal? s1 s2 (list a b c d)))) (test-assert "topologically-sorted, more difficult" (let* ((a (add-text-to-store %store "a" "a")) (b (add-text-to-store %store "b" "b" (list a))) (c (add-text-to-store %store "c" "c" (list b))) (d (add-text-to-store %store "d" "d" (list c))) (w (add-text-to-store %store "w" "w")) (x (add-text-to-store %store "x" "x" (list w))) (y (add-text-to-store %store "y" "y" (list x d))) (s1 (topologically-sorted %store (list y))) (s2 (topologically-sorted %store (list c y))) (s3 (topologically-sorted %store (cons y (references %store y))))) ;; The order in which 'references' returns the references of Y is ;; unspecified, so accommodate. (let* ((x-then-d? (equal? (references %store y) (list x d)))) (and (equal? s1 (if x-then-d? (list w x a b c d y) (list a b c d w x y))) (equal? s2 (if x-then-d? (list a b c w x d y) (list a b c d w x y))) (lset= string=? s1 s3))))) (test-assert "current-build-output-port, UTF-8" ;; Are UTF-8 strings in the build log properly interpreted? (string-contains (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port (call-with-output-string (lambda (port) (parameterize ((current-build-output-port port)) (let* ((s "Here’s a Greek letter: λ.") (d (build-expression->derivation %store "foo" `(display ,s) #:guile-for-build (package-derivation s %bootstrap-guile (%current-system))))) (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list d)))))))) "Here’s a Greek letter: λ.")) (test-assert "current-build-output-port, UTF-8 + garbage" ;; What about a mixture of UTF-8 + garbage? (string-contains (with-fluids ((%default-port-encoding "UTF-8")) ;for the string port (call-with-output-string (lambda (port) (parameterize ((current-build-output-port port)) (let ((d (build-expression->derivation %store "foo" `(begin (use-modules (rnrs io ports)) (display "garbage: ") (put-bytevector (current-output-port) #vu8(128)) (display "lambda: λ\n")) #:guile-for-build (package-derivation %store %bootstrap-guile)))) (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list d)))))))) "garbage: �lambda: λ")) (test-assert "log-file, derivation" (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) (s (add-to-store %store "bash" #t "sha256" (search-bootstrap-binary "bash" (%current-system)))) (d (derivation %store "the-thing" s `("-e" ,b) #:env-vars `(("foo" . ,(random-text))) #:inputs `((,b) (,s))))) (and (build-derivations %store (list d)) (file-exists? (pk (log-file %store (derivation-file-name d))))))) (test-assert "log-file, output file name" (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) (s (add-to-store %store "bash" #t "sha256" (search-bootstrap-binary "bash" (%current-system)))) (d (derivation %store "the-thing" s `("-e" ,b) #:env-vars `(("foo" . ,(random-text))) #:inputs `((,b) (,s)))) (o (derivation->output-path d))) (and (build-derivations %store (list d)) (file-exists? (pk (log-file %store o))) (string=? (log-file %store (derivation-file-name d)) (log-file %store o))))) (test-assert "no substitutes" (with-store s (let* ((d1 (package-derivation s %bootstrap-guile (%current-system))) (d2 (package-derivation s %bootstrap-glibc (%current-system))) (o (map derivation->output-path (list d1 d2)))) (set-build-options s #:use-substitutes? #f) (and (not (has-substitutes? s (derivation-file-name d1))) (not (has-substitutes? s (derivation-file-name d2))) (null? (substitutable-paths s o)) (null? (substitutable-path-info s o)))))) (test-assert "build-things with output path" (with-store s (let* ((c (random-text)) ;contents of the output (d (build-expression->derivation s "substitute-me" `(call-with-output-file %output (lambda (p) (display ,c p))) #:guile-for-build (package-derivation s %bootstrap-guile (%current-system)))) (o (derivation->output-path d))) (set-build-options s #:use-substitutes? #f) ;; Pass 'build-things' the output file name, O. However, since there ;; are no substitutes for O, it will just do nothing. (build-things s (list o)) (not (valid-path? s o))))) (test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1)) (test-assert "substitute query" (with-store s (let* ((d (package-derivation s %bootstrap-guile (%current-system))) (o (derivation->output-path d))) ;; Create fake substituter data, to be read by 'guix substitute'. (with-derivation-narinfo d ;; Remove entry from the local cache. (false-if-exception (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME") "/guix/substitute"))) ;; Make sure 'guix substitute' correctly communicates the above ;; data. (set-build-options s #:use-substitutes? #t #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) (equal? (list o) (substitutable-paths s (list o))) (match (pk 'spi (substitutable-path-info s (list o))) (((? substitutable? s)) (and (string=? (substitutable-deriver s) (derivation-file-name d)) (null? (substitutable-references s)) (equal? (substitutable-nar-size s) 1234))))))))) (test-assert "substitute query, alternating URLs" (let* ((d (with-store s (package-derivation s %bootstrap-guile (%current-system)))) (o (derivation->output-path d))) (with-derivation-narinfo d ;; Remove entry from the local cache. (false-if-exception (delete-file-recursively (string-append (getenv "XDG_CACHE_HOME") "/guix/substitute"))) ;; Note: We reconnect to the daemon to force a new instance of 'guix ;; substitute' to be used; otherwise the #:substitute-urls of ;; 'set-build-options' would have no effect. (and (with-store s ;the right substitute URL (set-build-options s #:use-substitutes? #t #:substitute-urls (%test-substitute-urls)) (has-substitutes? s o)) (with-store s ;the wrong one (set-build-options s #:use-substitutes? #t #:substitute-urls (list "http://does-not-exist")) (not (has-substitutes? s o))) (with-store s ;the right one again (set-build-options s #:use-substitutes? #t #:substitute-urls (%test-substitute-urls)) (has-substitutes? s o)) (with-store s ;empty list of URLs (set-build-options s #:use-substitutes? #t #:substitute-urls '()) (not (has-substitutes? s o))))))) (test-assert "substitute" (with-store s (let* ((c (random-text)) ; contents of the output (d (build-expression->derivation s "substitute-me" `(call-with-output-file %output (lambda (p) (exit 1) ; would actually fail (display ,c p))) #:guile-for-build (package-derivation s %bootstrap-guile (%current-system)))) (o (derivation->output-path d))) (with-derivation-substitute d c (set-build-options s #:use-substitutes? #t #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) (build-derivations s (list d)) (canonical-file? o) (equal? c (call-with-input-file o get-string-all))))))) (test-assert "substitute, deduplication" (with-store s (let* ((c (random-text)) ; contents of the output (g (package-derivation s %bootstrap-guile)) (d1 (build-expression->derivation s "substitute-me" `(begin ,c (exit 1)) #:guile-for-build g)) (d2 (build-expression->derivation s "build-me" `(call-with-output-file %output (lambda (p) (display ,c p))) #:guile-for-build g)) (o1 (derivation->output-path d1)) (o2 (derivation->output-path d2))) (with-derivation-substitute d1 c (set-build-options s #:use-substitutes? #t #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o1) (build-derivations s (list d2)) ;build (build-derivations s (list d1)) ;substitute (canonical-file? o1) (equal? c (call-with-input-file o1 get-string-all)) (= (stat:ino (stat o1)) (stat:ino (stat o2)))))))) (test-assert "substitute + build-things with output path" (with-store s (let* ((c (random-text)) ;contents of the output (d (build-expression->derivation s "substitute-me" `(call-with-output-file %output (lambda (p) (exit 1) ;would actually fail (display ,c p))) #:guile-for-build (package-derivation s %bootstrap-guile (%current-system)))) (o (derivation->output-path d))) (with-derivation-substitute d c (set-build-options s #:use-substitutes? #t #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) (build-things s (list o)) ;give the output path (valid-path? s o) (canonical-file? o) (equal? c (call-with-input-file o get-string-all))))))) (test-assert "substitute + build-things with specific output" (with-store s (let* ((c (random-text)) ;contents of the output (d (build-expression->derivation s "substitute-me" `(begin ,c (exit 1)) ;would fail #:outputs '("out" "one" "two") #:guile-for-build (package-derivation s %bootstrap-guile (%current-system)))) (o (derivation->output-path d))) (with-derivation-substitute d c (set-build-options s #:use-substitutes? #t #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) ;; Ask for nothing but the "out" output of D. (build-things s `((,(derivation-file-name d) . "out"))) (valid-path? s o) (canonical-file? o) (equal? c (call-with-input-file o get-string-all))))))) (test-assert "substitute, corrupt output hash" ;; Tweak the substituter into installing a substitute whose hash doesn't ;; match the one announced in the narinfo. The daemon must notice this and ;; raise an error. (with-store s (let* ((c "hello, world") ; contents of the output (d (build-expression->derivation s "corrupt-substitute" `(mkdir %output) #:guile-for-build (package-derivation s %bootstrap-guile (%current-system)))) (o (derivation->output-path d))) (with-derivation-substitute d c (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C ;; Make sure we use 'guix substitute'. (set-build-options s #:use-substitutes? #t #:fallback? #f #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) (guard (c ((store-protocol-error? c) ;; XXX: the daemon writes "hash mismatch in downloaded ;; path", but the actual error returned to the client ;; doesn't mention that. (pk 'corrupt c) (not (zero? (store-protocol-error-status c))))) (build-derivations s (list d)) #f)))))) (test-assert "substitute, corrupt output hash, build trace" ;; Likewise, and check the build trace. (with-store s (let* ((c "hello, world") ; contents of the output (d (build-expression->derivation s "corrupt-substitute" `(mkdir %output) #:guile-for-build (package-derivation s %bootstrap-guile (%current-system)))) (o (derivation->output-path d))) ;; Make sure we use 'guix substitute'. (set-build-options s #:print-build-trace #t #:use-substitutes? #t #:fallback? #f #:substitute-urls (%test-substitute-urls)) (with-derivation-substitute d c (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C (define output (call-with-output-string (lambda (port) (parameterize ((current-build-output-port port)) (guard (c ((store-protocol-error? c) #t)) (build-derivations s (list d)) #f))))) (define actual-hash (let-values (((port get-hash) (gcrypt:open-hash-port (gcrypt:hash-algorithm gcrypt:sha256)))) (write-file-tree "foo" port #:file-type+size (lambda _ (values 'regular (string-length c))) #:file-port (lambda _ (open-input-string c))) (close-port port) (bytevector->nix-base32-string (get-hash)))) (define expected-hash (bytevector->nix-base32-string (make-bytevector 32 0))) (define mismatch (string-append "@ hash-mismatch " o " sha256 " expected-hash " " actual-hash "\n")) (define failure (string-append "@ substituter-failed " o)) (and (string-contains output mismatch) (string-contains output failure)))))) (test-assert "substitute --fallback" (with-store s (let* ((t (random-text)) ; contents of the output (d (build-expression->derivation s "substitute-me-not" `(call-with-output-file %output (lambda (p) (display ,t p))) #:guile-for-build (package-derivation s %bootstrap-guile (%current-system)))) (o (derivation->output-path d))) ;; Create fake substituter data, to be read by 'guix substitute'. (with-derivation-narinfo d ;; Make sure we use 'guix substitute'. (set-build-options s #:use-substitutes? #t #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) (guard (c ((store-protocol-error? c) ;; The substituter failed as expected. Now make ;; sure that #:fallback? #t works correctly. (set-build-options s #:use-substitutes? #t #:substitute-urls (%test-substitute-urls) #:fallback? #t) (and (build-derivations s (list d)) (equal? t (call-with-input-file o get-string-all))))) ;; Should fail. (build-derivations s (list d)) #f)))))) (test-assert "export/import several paths" (let* ((texts (unfold (cut >= <> 10) (lambda _ (random-text)) 1+ 0)) (files (map (cut add-text-to-store %store "text" <>) texts)) (dump (call-with-bytevector-output-port (cut export-paths %store files <>)))) (delete-paths %store files) (and (every (negate file-exists?) files) (let* ((source (open-bytevector-input-port dump)) (imported (import-paths %store source))) (and (equal? imported files) (every file-exists? files) (equal? texts (map (lambda (file) (call-with-input-file file get-string-all)) files))))))) (test-assert "export/import paths, ensure topological order" (let* ((file0 (add-text-to-store %store "baz" (random-text))) (file1 (add-text-to-store %store "foo" (random-text) (list file0))) (file2 (add-text-to-store %store "bar" (random-text) (list file1))) (files (list file1 file2)) (dump1 (call-with-bytevector-output-port (cute export-paths %store (list file1 file2) <>))) (dump2 (call-with-bytevector-output-port (cute export-paths %store (list file2 file1) <>)))) (delete-paths %store files) (and (every (negate file-exists?) files) (bytevector=? dump1 dump2) (let* ((source (open-bytevector-input-port dump1)) (imported (import-paths %store source))) ;; DUMP1 should contain exactly FILE1 and FILE2, not FILE0. (and (equal? imported (list file1 file2)) (every file-exists? files) (equal? (list file0) (references %store file1)) (equal? (list file1) (references %store file2))))))) (test-assert "export/import incomplete" (let* ((file0 (add-text-to-store %store "baz" (random-text))) (file1 (add-text-to-store %store "foo" (random-text) (list file0))) (file2 (add-text-to-store %store "bar" (random-text) (list file1))) (dump (call-with-bytevector-output-port (cute export-paths %store (list file2) <>)))) (delete-paths %store (list file0 file1 file2)) (guard (c ((store-protocol-error? c) (and (not (zero? (store-protocol-error-status c))) (string-contains (store-protocol-error-message c) "not valid")))) ;; Here we get an exception because DUMP does not include FILE0 and ;; FILE1, which are dependencies of FILE2. (import-paths %store (open-bytevector-input-port dump))))) (test-assert "export/import recursive" (let* ((file0 (add-text-to-store %store "baz" (random-text))) (file1 (add-text-to-store %store "foo" (random-text) (list file0))) (file2 (add-text-to-store %store "bar" (random-text) (list file1))) (dump (call-with-bytevector-output-port (cute export-paths %store (list file2) <> #:recursive? #t)))) (delete-paths %store (list file0 file1 file2)) (let ((imported (import-paths %store (open-bytevector-input-port dump)))) (and (equal? imported (list file0 file1 file2)) (every file-exists? (list file0 file1 file2)) (equal? (list file0) (references %store file1)) (equal? (list file1) (references %store file2)))))) (test-assert "write-file & export-path yield the same result" ;; Here we compare 'write-file' and the daemon's own implementation. ;; 'write-file' is the reference because we know it sorts file ;; deterministically. Conversely, the daemon uses 'readdir' and the entries ;; currently happen to be sorted as a side-effect of some unrelated ;; operation (search for 'unhacked' in archive.cc.) Make sure we detect any ;; changes there. (run-with-store %store (mlet* %store-monad ((drv1 (package->derivation %bootstrap-guile)) (out1 -> (derivation->output-path drv1)) (data -> (unfold (cut >= <> 26) (lambda (i) (random-bytevector 128)) 1+ 0)) (build -> #~(begin (use-modules (rnrs io ports) (srfi srfi-1)) (let () (define letters (map (lambda (i) (string (integer->char (+ i (char->integer #\a))))) (iota 26))) (define (touch file data) (call-with-output-file file (lambda (port) (put-bytevector port data)))) (mkdir #$output) (chdir #$output) ;; The files must be different so they have ;; different inode numbers, and the inode ;; order must differ from the lexicographic ;; order. (for-each touch (append (drop letters 10) (take letters 10)) (list #$@data)) #t))) (drv2 (gexp->derivation "bunch" build)) (out2 -> (derivation->output-path drv2)) (item-info -> (store-lift query-path-info))) (mbegin %store-monad (built-derivations (list drv1 drv2)) (foldm %store-monad (lambda (item result) (define ref-hash (let-values (((port get) (gcrypt:open-sha256-port))) (write-file item port) (close-port port) (get))) ;; 'query-path-info' returns a hash produced by using the ;; daemon's C++ 'dump' function, which is the implementation ;; under test. (>>= (item-info item) (lambda (info) (return (and result (bytevector=? (path-info-hash info) ref-hash)))))) #t (list out1 out2)))) #:guile-for-build (%guile-for-build))) (test-assert "import not signed" (let* ((text (random-text)) (file (add-file-tree-to-store %store `("tree" directory ("text" regular (data ,text)) ("link" symlink "text")))) (dump (call-with-bytevector-output-port (lambda (port) (write-int 1 port) ;start (write-file file port) ;contents (write-int #x4558494e port) ;%export-magic (write-string file port) ;store item (write-string-list '() port) ;references (write-string "" port) ;deriver (write-int 0 port) ;not signed (write-int 0 port))))) ;done ;; Ensure 'import-paths' raises an exception. (guard (c ((store-protocol-error? c) (and (not (zero? (store-protocol-error-status c))) (string-contains (store-protocol-error-message c) "lacks a signature")))) (let* ((source (open-bytevector-input-port dump)) (imported (import-paths %store source))) (pk 'unsigned-imported imported) #f)))) (test-assert "import signed by unauthorized key" (let* ((text (random-text)) (file (add-file-tree-to-store %store `("tree" directory ("text" regular (data ,text)) ("link" symlink "text")))) (key (gcrypt:generate-key (gcrypt:string->canonical-sexp "(genkey (ecdsa (curve Ed25519) (flags rfc6979)))"))) (dump (call-with-bytevector-output-port (lambda (port) (write-int 1 port) ;start (write-file file port) ;contents (write-int #x4558494e port) ;%export-magic (write-string file port) ;store item (write-string-list '() port) ;references (write-string "" port) ;deriver (write-int 1 port) ;signed (write-string (gcrypt:canonical-sexp->string (signature-sexp (gcrypt:bytevector->hash-data (gcrypt:sha256 #vu8(0 1 2)) #:key-type 'ecc) (gcrypt:find-sexp-token key 'private-key) (gcrypt:find-sexp-token key 'public-key))) port) (write-int 0 port))))) ;done ;; Ensure 'import-paths' raises an exception. (guard (c ((store-protocol-error? c) (and (not (zero? (store-protocol-error-status c))) (string-contains (store-protocol-error-message c) "unauthorized public key")))) (let* ((source (open-bytevector-input-port dump)) (imported (import-paths %store source))) (pk 'unauthorized-imported imported) #f)))) (test-assert "import corrupt path" (let* ((text (random-text)) (file (add-text-to-store %store "text" text)) (dump (call-with-bytevector-output-port (cut export-paths %store (list file) <>)))) (delete-paths %store (list file)) ;; Flip a bit in the stream's payload. INDEX here falls in the middle of ;; the file contents in DUMP, regardless of the store prefix. (let* ((index #x70) (byte (bytevector-u8-ref dump index))) (bytevector-u8-set! dump index (logxor #xff byte))) (and (not (file-exists? file)) (guard (c ((store-protocol-error? c) (pk 'c c) (and (not (zero? (store-protocol-error-status c))) (string-contains (store-protocol-error-message c) "corrupt")))) (let* ((source (open-bytevector-input-port dump)) (imported (import-paths %store source))) (pk 'corrupt-imported imported) #f))))) (test-assert "verify-store" (let* ((text (random-text)) (file1 (add-text-to-store %store "foo" text)) (file2 (add-text-to-store %store "bar" (random-text) (list file1)))) (and (pk 'verify1 (verify-store %store)) ;hopefully OK ; (begin (delete-file file1) (not (pk 'verify2 (verify-store %store)))) ;bad! ; (begin ;; Using 'add-text-to-store' here wouldn't work: It would succeed ; ;; without actually creating the file. ; (call-with-output-file file1 (lambda (port) (display text port))) (pk 'verify3 (verify-store %store)))))) ;OK again (test-assert "verify-store + check-contents" ;; XXX: This test is I/O intensive. (with-store s (let* ((text (random-text)) (drv (build-expression->derivation s "corrupt" `(let ((out (assoc-ref %outputs "out"))) (call-with-output-file out (lambda (port) (display ,text port))) #t) #:guile-for-build (package-derivation s %bootstrap-guile (%current-system)))) (file (derivation->output-path drv))) (with-derivation-substitute drv text (and (build-derivations s (list drv)) (verify-store s #:check-contents? #t) ;should be OK (begin (chmod file #o644) (call-with-output-file file (lambda (port) (display "corrupt!" port))) #t) ;; Make sure the corruption is detected. We don't test repairing ;; because only "trusted" users are allowed to do it, but we ;; don't expose that notion of trusted users that nix-daemon ;; supports because it seems dubious and redundant with what the ;; OS provides (in Nix "trusted" users have additional ;; privileges, such as overriding the set of substitute URLs, but ;; we instead want to allow anyone to modify them, provided ;; substitutes are signed by a root-approved key.) (not (verify-store s #:check-contents? #t)) ;; Delete the corrupt item to leave the store in a clean state. (delete-paths s (list file))))))) (test-assert "build-things, check mode" (with-store store (call-with-temporary-output-file (lambda (entropy entropy-port) (write (random-text) entropy-port) (force-output entropy-port) (let* ((drv (build-expression->derivation store "non-deterministic" `(begin (use-modules (rnrs io ports)) (let ((out (assoc-ref %outputs "out"))) (call-with-output-file out (lambda (port) ;; Rely on the fact that tests do not use the ;; chroot, and thus ENTROPY is readable. (display (call-with-input-file ,entropy get-string-all) port))) #t)) #:guile-for-build (package-derivation store %bootstrap-guile (%current-system)))) (file (derivation->output-path drv))) (and (build-things store (list (derivation-file-name drv))) (begin (write (random-text) entropy-port) (force-output entropy-port) (guard (c ((store-protocol-error? c) (pk 'determinism-exception c) (and (not (zero? (store-protocol-error-status c))) (string-contains (store-protocol-error-message c) "deterministic")))) ;; This one will produce a different result. Since we're in ;; 'check' mode, this must fail. (build-things store (list (derivation-file-name drv)) (build-mode check)) #f)))))))) (test-assert "build-succeeded trace in check mode" (string-contains (call-with-output-string (lambda (port) (let ((d (build-expression->derivation %store "foo" '(mkdir (assoc-ref %outputs "out")) #:guile-for-build (package-derivation %store %bootstrap-guile)))) (build-derivations %store (list d)) (parameterize ((current-build-output-port port)) (build-derivations %store (list d) (build-mode check)))))) "@ build-succeeded")) (test-assert "build multiple times" (with-store store ;; Ask to build twice. (set-build-options store #:rounds 2 #:use-substitutes? #f) (call-with-temporary-output-file (lambda (entropy entropy-port) (write (random-text) entropy-port) (force-output entropy-port) (let* ((drv (build-expression->derivation store "non-deterministic" `(begin (use-modules (rnrs io ports)) (let ((out (assoc-ref %outputs "out"))) (call-with-output-file out (lambda (port) ;; Rely on the fact that tests do not use the ;; chroot, and thus ENTROPY is accessible. (display (call-with-input-file ,entropy get-string-all) port) (call-with-output-file ,entropy (lambda (port) (write 'foobar port))))) #t)) #:guile-for-build (package-derivation store %bootstrap-guile (%current-system)))) (file (derivation->output-path drv))) (guard (c ((store-protocol-error? c) (pk 'multiple-build c) (and (not (zero? (store-protocol-error-status c))) (string-contains (store-protocol-error-message c) "deterministic")))) ;; This one will produce a different result on the second run. (current-build-output-port (current-error-port)) (build-things store (list (derivation-file-name drv))) #f)))))) (test-equal "store-lower" "Lowered." (let* ((add (store-lower text-file)) (file (add %store "foo" "Lowered."))) (call-with-input-file file get-string-all))) (test-equal "current-system" "bar" (parameterize ((%current-system "frob")) (run-with-store %store (mbegin %store-monad (set-current-system "bar") (current-system)) #:system "foo"))) (test-assert "query-path-info" (let* ((ref (add-text-to-store %store "ref" "foo")) (item (add-text-to-store %store "item" "bar" (list ref))) (info (query-path-info %store item))) (and (equal? (path-info-references info) (list ref)) (equal? (path-info-hash info) (gcrypt:sha256 (string->utf8 (call-with-output-string (cut write-file item <>)))))))) (test-assert "path-info-deriver" (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) (s (add-to-store %store "bash" #t "sha256" (search-bootstrap-binary "bash" (%current-system)))) (d (derivation %store "the-thing" s `("-e" ,b) #:env-vars `(("foo" . ,(random-text))) #:inputs `((,b) (,s)))) (o (derivation->output-path d))) (and (build-derivations %store (list d)) (not (path-info-deriver (query-path-info %store b))) (string=? (derivation-file-name d) (path-info-deriver (query-path-info %store o)))))) (test-equal "build-cores" (list 0 42) (with-store store (let* ((build (add-text-to-store store "build.sh" "echo $NIX_BUILD_CORES > $out")) (bash (add-to-store store "bash" #t "sha256" (search-bootstrap-binary "bash" (%current-system)))) (drv1 (derivation store "the-thing" bash `("-e" ,build) #:inputs `((,bash) (,build)) #:env-vars `(("x" . ,(random-text))))) (drv2 (derivation store "the-thing" bash `("-e" ,build) #:inputs `((,bash) (,build)) #:env-vars `(("x" . ,(random-text)))))) (and (build-derivations store (list drv1)) (begin (set-build-options store #:build-cores 42) (build-derivations store (list drv2))) (list (call-with-input-file (derivation->output-path drv1) read) (call-with-input-file (derivation->output-path drv2) read)))))) (test-equal "multiplexed-build-output" '("Hello from first." "Hello from second.") (with-store store (let* ((build (add-text-to-store store "build.sh" "echo Hello from $NAME.; echo > $out")) (bash (add-to-store store "bash" #t "sha256" (search-bootstrap-binary "bash" (%current-system)))) (drv1 (derivation store "one" bash `("-e" ,build) #:inputs `((,bash) (,build)) #:env-vars `(("NAME" . "first") ("x" . ,(random-text))))) (drv2 (derivation store "two" bash `("-e" ,build) #:inputs `((,bash) (,build)) #:env-vars `(("NAME" . "second") ("x" . ,(random-text)))))) (set-build-options store #:print-build-trace #t #:multiplexed-build-output? #t #:max-build-jobs 10) (let ((port (open-output-string))) ;; Send the build log to PORT. (parameterize ((current-build-output-port port)) (build-derivations store (list drv1 drv2))) ;; Retrieve the build log; make sure it contains valid "@ build-log" ;; traces that allow us to retrieve each builder's output (we assume ;; there's exactly one "build-output" trace for each builder, which is ;; reasonable.) (let* ((log (get-output-string port)) (started (fold-matches (make-regexp "@ build-started ([^ ]+) - ([^ ]+) ([^ ]+) ([0-9]+)") log '() cons)) (done (fold-matches (make-regexp "@ build-succeeded (.*) - (.*) (.*) (.*)") log '() cons)) (output (fold-matches (make-regexp "@ build-log ([[:digit:]]+) ([[:digit:]]+)\n([A-Za-z .*]+)\n") log '() cons)) (drv-pid (lambda (name) (lambda (m) (let ((drv (match:substring m 1)) (pid (string->number (match:substring m 4)))) (and (string-suffix? name drv) pid))))) (pid-log (lambda (pid) (lambda (m) (let ((n (string->number (match:substring m 1))) (len (string->number (match:substring m 2))) (str (match:substring m 3))) (and (= pid n) (= (string-length str) (- len 1)) str))))) (pid1 (any (drv-pid "one.drv") started)) (pid2 (any (drv-pid "two.drv") started))) (list (any (pid-log pid1) output) (any (pid-log pid2) output))))))) (test-end "store")