;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(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 (guix hash)
+ #:use-module ((gcrypt hash) #:prefix gcrypt:)
+ #:use-module ((gcrypt pk-crypto) #:prefix gcrypt:)
+ #:use-module (guix pki)
#:use-module (guix base32)
#:use-module (guix packages)
#:use-module (guix derivations)
#:use-module (gnu packages)
#:use-module (gnu packages bootstrap)
#:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (web uri)
(define %store
(open-connection-for-tests))
+(define %shell
+ (or (getenv "SHELL") (getenv "CONFIG_SHELL") "/bin/sh"))
+
\f
(test-begin "store")
(test-equal "connection handshake error"
EPROTO
(let ((port (%make-void-port "rw")))
- (guard (c ((nix-connection-error? c)
- (and (eq? port (nix-connection-error-file c))
- (nix-connection-error-code c))))
+ (guard (c ((store-connection-error? c)
+ (and (eq? port (store-connection-error-file c))
+ (store-connection-error-code c))))
(open-connection #f #:port port)
'broken)))
"/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile")))
(not (direct-store-path? (%store-prefix)))))
-(test-skip (if %store 0 13))
+(test-skip (if %store 0 15))
+
+(test-equal "profiles/per-user exists and is not writable"
+ #o755
+ (stat:perms (stat (string-append %state-directory "/profiles/per-user"))))
+
+(test-equal "profiles/per-user/$USER exists"
+ (list (getuid) #o755)
+ (let ((s (stat (string-append %state-directory "/profiles/per-user/"
+ (passwd:name (getpwuid (getuid)))))))
+ (list (stat:uid s) (stat:perms s))))
+
+(test-equal "add-to-store"
+ '("sha1" "sha256" "sha512" "sha3-256" "sha3-512" "blake2s-256")
+ (let* ((file (search-path %load-path "guix.scm"))
+ (content (call-with-input-file file get-bytevector-all)))
+ (map (lambda (hash-algo)
+ (let ((file (add-to-store %store "guix.scm" #f hash-algo file)))
+ (and (direct-store-path? file)
+ (bytevector=? (call-with-input-file file get-bytevector-all)
+ content)
+ hash-algo)))
+ '("sha1" "sha256" "sha512" "sha3-256" "sha3-512" "blake2s-256"))))
(test-equal "add-data-to-store"
#vu8(1 2 3 4 5)
(string-append (%store-prefix) "/"
(make-string 32 #\e) "-foobar"))))
+(test-equal "with-store, multiple values" ;<https://bugs.gnu.org/42912>
+ '(1 2 3)
+ (call-with-values
+ (lambda ()
+ (with-store s
+ (add-text-to-store s "foo" "bar")
+ (values 1 2 3)))
+ list))
+
(test-assert "valid-path? error"
(with-store s
- (guard (c ((nix-protocol-error? c) #t))
+ (guard (c ((store-protocol-error? c) #t))
(valid-path? s "foo")
#f)))
(with-store s
(let-syntax ((true-if-error (syntax-rules ()
((_ exp)
- (guard (c ((nix-protocol-error? c) #t))
+ (guard (c ((store-protocol-error? c) #t))
exp #f)))))
(and (true-if-error (valid-path? s "foo"))
(true-if-error (valid-path? s "bar"))
;; (valid-path? %store p1)
;; (member (pk p2) (live-paths %store)))))
+(test-assert "add-indirect-root and find-roots"
+ (call-with-temporary-directory
+ (lambda (directory)
+ (let* ((item (add-text-to-store %store "something" (random-text)))
+ (root (string-append directory "/gc-root")))
+ (symlink item root)
+ (add-indirect-root %store root)
+ (let ((result (member (cons root item) (find-roots %store))))
+ (delete-file root)
+ result)))))
+
(test-assert "permanent root"
(let* ((p (with-store store
(let ((p (add-text-to-store store "random-text"
;;(> freed 0)
(not (file-exists? p))))))
-(test-assert "add-text-to-store vs. delete-paths"
- ;; Before, 'add-text-to-store' would return PATH2 without noticing that it
- ;; is no longer valid.
+(test-assert "add-text-to-store/add-to-store vs. delete-paths"
+ ;; Before, 'add-text-to-store' and 'add-to-store' would return the same
+ ;; store item without noticing that it is no longer valid.
(with-store store
(let* ((text (random-text))
- (path (add-text-to-store store "delete-me" text))
- (deleted (delete-paths store (list path)))
- (path2 (add-text-to-store store "delete-me" text)))
- (and (string=? path path2)
- (equal? deleted (list path))
- (valid-path? store path)
- (file-exists? path)))))
-
-(test-assert "add-to-store vs. delete-paths"
- ;; Same as above.
- (with-store store
- (let* ((file (search-path %load-path "guix.scm"))
- (path (add-to-store store "delete-me" #t "sha256" file))
- (deleted (delete-paths store (list path)))
- (path2 (add-to-store store "delete-me" #t "sha256" file)))
- (and (string=? path path2)
- (equal? deleted (list path))
- (valid-path? store path)
- (file-exists? path)))))
+ (file (search-path %load-path "guix.scm"))
+ (path1 (add-text-to-store store "delete-me" text))
+ (path2 (add-to-store store "delete-me" #t "sha256" file))
+ (deleted (delete-paths store (list path1 path2))))
+ (and (string=? path1 (add-text-to-store store "delete-me" text))
+ (string=? path2 (add-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"
(null? (references %store t1))
(null? (referrers %store t2)))))
-(test-assert "references/substitutes missing reference info"
- (with-store s
- (set-build-options s #:use-substitutes? #f)
- (guard (c ((nix-protocol-error? c) #t))
- (let* ((b (add-to-store s "bash" #t "sha256"
- (search-bootstrap-binary "bash"
- (%current-system))))
- (d (derivation s "the-thing" b '("--help")
- #:inputs `((,b)))))
- (references/substitutes s (list (derivation->output-path d) b))
- #f))))
-
-(test-assert "references/substitutes with substitute info"
- (with-store s
- (set-build-options s #:use-substitutes? #t)
- (let* ((t1 (add-text-to-store s "random1" (random-text)))
- (t2 (add-text-to-store s "random2" (random-text)
- (list t1)))
- (t3 (add-text-to-store s "build" "echo -n $t2 > $out"))
- (b (add-to-store s "bash" #t "sha256"
- (search-bootstrap-binary "bash"
- (%current-system))))
- (d (derivation s "the-thing" b `("-e" ,t3)
- #:inputs `((,b) (,t3) (,t2))
- #:env-vars `(("t2" . ,t2))))
- (o (derivation->output-path d)))
- (with-derivation-narinfo d
- (sha256 => (sha256 (string->utf8 t2)))
- (references => (list t2))
-
- (equal? (references/substitutes s (list o t3 t2 t1))
- `((,t2) ;refs of O
- () ;refs of T3
- (,t1) ;refs of T2
- ())))))) ;refs of T1
-
(test-equal "substitutable-path-info when substitutes are turned off"
'()
(with-store s
(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-equal "map/accumulate-builds cutoff" ;https://issues.guix.gnu.org/50264
+ (iota 20)
+
+ ;; Make sure that, when the cutoff is reached, 'map/accumulate-builds' still
+ ;; returns the right result and calls the build handler by batches.
+ (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 (map (lambda (i)
+ (derivation %store (string-append "the-thing-"
+ (number->string i))
+ s `("-e" ,b)
+ #:env-vars `(("foo" . ,(random-text)))
+ #:sources (list b s)
+ #:properties `((n . ,i))))
+ (iota 20)))
+ (calls '()))
+ (define lst
+ (with-build-handler (lambda (continue store things mode)
+ (set! calls (cons things calls))
+ (continue #f))
+ (map/accumulate-builds %store
+ (lambda (d)
+ (build-derivations %store (list d))
+ (assq-ref (derivation-properties d) 'n))
+ d
+ #:cutoff 7)))
+
+ (match (reverse calls)
+ (((batch1 ...) (batch2 ...) (batch3 ...))
+ (and (equal? (map derivation-file-name (take d 8)) batch1)
+ (equal? (map derivation-file-name (take (drop d 8) 8)) batch2)
+ (equal? (map derivation-file-name (drop d 16)) batch3)
+ lst)))))
+
+(test-equal "map/accumulate-builds and different store"
+ '(d2) ;see <https://issues.guix.gnu.org/46756>
+ (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 "first"
+ s `("-e" ,b)
+ #:env-vars `(("foo" . ,(random-text)))
+ #:sources (list b s)))
+ (d2 (derivation %store "second"
+ s `("-e" ,b)
+ #:env-vars `(("foo" . ,(random-text))
+ ("bar" . "baz"))
+ #:sources (list b s))))
+ (with-store alternate-store
+ (with-build-handler (lambda (continue store things mode)
+ ;; If this handler is called, it means that
+ ;; 'map/accumulate-builds' triggered a build,
+ ;; which it shouldn't since the inner
+ ;; 'build-derivations' call is for another store.
+ 'failed)
+ (map/accumulate-builds %store
+ (lambda (drv)
+ (build-derivations alternate-store (list d2))
+ 'd2)
+ (list d1))))))
+
+(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)))
(d (build-expression->derivation
%store "foo" `(display ,s)
#:guile-for-build
- (package-derivation s %bootstrap-guile (%current-system)))))
- (guard (c ((nix-protocol-error? c) #t))
+ (package-derivation %store %bootstrap-guile
+ (%current-system)))))
+ (guard (c ((store-protocol-error? c) #t))
(build-derivations %store (list d))))))))
"Here’s a Greek letter: λ."))
(display "lambda: λ\n"))
#:guile-for-build
(package-derivation %store %bootstrap-guile))))
- (guard (c ((nix-protocol-error? c) #t))
+ (guard (c ((store-protocol-error? c) #t))
(build-derivations %store (list d))))))))
- (cond-expand
- (guile-2.2 "garbage: �lambda: λ")
- (else "garbage: ?lambda: λ"))))
+ "garbage: �lambda: λ"))
(test-assert "log-file, derivation"
(let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
#: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
(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"
#:fallback? #f
#:substitute-urls (%test-substitute-urls))
(and (has-substitutes? s o)
- (guard (c ((nix-protocol-error? c)
+ (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? (nix-protocol-error-status 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
(set-build-options s #:use-substitutes? #t
#:substitute-urls (%test-substitute-urls))
(and (has-substitutes? s o)
- (guard (c ((nix-protocol-error? c)
+ (guard (c ((store-protocol-error? c)
;; The substituter failed as expected. Now make
;; sure that #:fallback? #t works correctly.
(set-build-options s
(dump (call-with-bytevector-output-port
(cute export-paths %store (list file2) <>))))
(delete-paths %store (list file0 file1 file2))
- (guard (c ((nix-protocol-error? c)
- (and (not (zero? (nix-protocol-error-status c)))
- (string-contains (nix-protocol-error-message c)
+ (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.
(foldm %store-monad
(lambda (item result)
(define ref-hash
- (let-values (((port get) (open-sha256-port)))
+ (let-values (((port get) (gcrypt:open-sha256-port)))
(write-file item port)
(close-port port)
(get)))
(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))
(bytevector-u8-set! dump index (logxor #xff byte)))
(and (not (file-exists? file))
- (guard (c ((nix-protocol-error? c)
+ (guard (c ((store-protocol-error? c)
(pk 'c c)
- (and (not (zero? (nix-protocol-error-status c)))
- (string-contains (nix-protocol-error-message 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)))
(begin
(write (random-text) entropy-port)
(force-output entropy-port)
- (guard (c ((nix-protocol-error? c)
+ (guard (c ((store-protocol-error? c)
(pk 'determinism-exception c)
- (and (not (zero? (nix-protocol-error-status c)))
- (string-contains (nix-protocol-error-message 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-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.
#:guile-for-build
(package-derivation store %bootstrap-guile (%current-system))))
(file (derivation->output-path drv)))
- (guard (c ((nix-protocol-error? c)
+ (guard (c ((store-protocol-error? c)
(pk 'multiple-build c)
- (and (not (zero? (nix-protocol-error-status c)))
- (string-contains (nix-protocol-error-message 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))
(info (query-path-info %store item)))
(and (equal? (path-info-references info) (list ref))
(equal? (path-info-hash info)
- (sha256
+ (gcrypt:sha256
(string->utf8
(call-with-output-string (cut write-file item <>))))))))
(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")