;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 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.
;;;
#:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix monads)
- #:use-module (gcrypt 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)
(open-connection-for-tests))
(define %shell
- (or (getenv "SHELL") (getenv "CONFIG_SHELL")))
+ (or (getenv "SHELL") (getenv "CONFIG_SHELL") "/bin/sh"))
\f
(test-begin "store")
(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)
(call-with-input-file (add-data-to-store %store "data" #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 ((store-protocol-error? c) #t))
;; (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
(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 ((store-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
(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)))))
+ (package-derivation %store %bootstrap-guile
+ (%current-system)))))
(guard (c ((store-protocol-error? c) #t))
(build-derivations %store (list d))))))))
"Here’s a Greek letter: λ."))
#: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
+ ;; Note: C must be longer than %DEDUPLICATION-MINIMUM-SIZE.
+ (let* ((c (string-concatenate
+ (make-list 200 (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"
(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"
(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
(build-derivations s (list d))
#f))))))
+(test-equal "substitute query and large size"
+ (+ 100 (expt 2 63)) ;<https://issues.guix.gnu.org/51983>
+ (with-store s
+ (let* ((size (+ 100 (expt 2 63))) ;does not fit in signed 'long long'
+ (item (string-append (%store-prefix)
+ "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bad-size")))
+ ;; Create fake substituter data, to be read by 'guix substitute'.
+ (call-with-output-file (string-append (%substitute-directory)
+ "/" (store-path-hash-part item)
+ ".narinfo")
+ (lambda (port)
+ (format port "StorePath: ~a
+URL: http://example.org
+Compression: none
+NarSize: ~a
+NarHash: sha256:0fj9vhblff2997pi7qjj7lhmy7wzhnjwmkm2hmq6gr4fzmg10s0w
+References:
+System: x86_64-linux~%"
+ item size)))
+
+ ;; 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))
+ (match (pk 'spi (substitutable-path-info s (list item)))
+ (((? substitutable? s))
+ (and (equal? (substitutable-path s) item)
+ (substitutable-nar-size s)))))))
+
+(test-equal "substitute and large size"
+ (+ 100 (expt 2 31)) ;<https://issues.guix.gnu.org/46212>
+ (with-store s
+ (let* ((size (+ 100 (expt 2 31))) ;does not fit in signed 'int'
+ (item (string-append (%store-prefix)
+ "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-bad-size-"
+ (random-text)))
+ (nar (string-append (%substitute-directory) "/nar")))
+ ;; Create a dummy nar to allow for substitution.
+ (call-with-output-file nar
+ (lambda (port)
+ (write-file-tree (store-path-package-name item) port
+ #:file-type+size (lambda _
+ (values 'regular 12))
+ #:file-port (lambda _
+ (open-input-string "Hello world.")))))
+
+ ;; Create fake substituter data, to be read by 'guix substitute'.
+ (call-with-output-file (string-append (%substitute-directory)
+ "/" (store-path-hash-part item)
+ ".narinfo")
+ (lambda (port)
+ (format port "StorePath: ~a
+URL: file://~a
+Compression: none
+NarSize: ~a
+NarHash: sha256:~a
+References:
+System: x86_64-linux~%"
+ item nar size
+ (bytevector->nix-base32-string (gcrypt:file-sha256 nar)))))
+
+ ;; 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))
+ (ensure-path s item)
+ (path-info-nar-size (query-path-info s item)))))
+
(test-assert "export/import several paths"
(let* ((texts (unfold (cut >= <> 10)
(lambda _ (random-text))
(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))
(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 <>))))))))