;;; 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 utils)
#:use-module (guix monads)
#: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")
;; (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 => (gcrypt: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
(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))))
(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))
(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))
HCoop / jackhill / guix / guix.git / blobdiff