summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/boot-parameters.scm23
-rw-r--r--tests/channels.scm60
-rw-r--r--tests/derivations.scm50
-rw-r--r--tests/gexp.scm69
-rw-r--r--tests/git-authenticate.scm150
-rw-r--r--tests/git.scm52
-rw-r--r--tests/guix-build.sh12
-rw-r--r--tests/guix-git-authenticate.sh17
-rw-r--r--tests/guix-home.sh97
-rw-r--r--tests/guix-pack.sh5
-rw-r--r--tests/guix-package.sh13
-rw-r--r--tests/guix-shell.sh5
-rw-r--r--tests/guix-system.sh12
-rw-r--r--tests/home-import.scm31
-rw-r--r--tests/http-client.scm84
-rw-r--r--tests/import-github.scm43
-rw-r--r--tests/lint.scm21
-rw-r--r--tests/packages.scm51
-rw-r--r--tests/publish.scm61
-rw-r--r--tests/substitute.scm25
20 files changed, 795 insertions, 86 deletions
diff --git a/tests/boot-parameters.scm b/tests/boot-parameters.scm
index b2799d0596..8e48e1775e 100644
--- a/tests/boot-parameters.scm
+++ b/tests/boot-parameters.scm
@@ -28,9 +28,11 @@
#:use-module (gnu system)
#:use-module (gnu system file-systems)
#:use-module (gnu system uuid)
+ #:use-module ((guix diagnostics) #:select (formatted-message?))
#:use-module (guix gexp)
#:use-module (guix store)
#:use-module (guix tests)
+ #:use-module (srfi srfi-34)
#:use-module (srfi srfi-64)
#:use-module (rnrs bytevectors))
@@ -101,7 +103,7 @@
;; Call read-boot-parameters with the desired string as input.
(define* (test-read-boot-parameters
#:key
- (version 0)
+ (version %boot-parameters-version)
(bootloader-name 'grub)
(bootloader-menu-entries '())
(label %default-label)
@@ -151,13 +153,18 @@
;; XXX: <warning: unrecognized boot parameters at '#f'>
(test-assert "read, construction, mandatory fields"
- (not (or (test-read-boot-parameters #:version #false)
- (test-read-boot-parameters #:version 'false)
- (test-read-boot-parameters #:version -1)
- (test-read-boot-parameters #:version "0")
- (test-read-boot-parameters #:root-device #false)
- (test-read-boot-parameters #:kernel #false)
- (test-read-boot-parameters #:label #false))))
+ (let-syntax ((test-read-boot-parameters
+ (syntax-rules ()
+ ((_ args ...)
+ (guard (c ((formatted-message? c) #f))
+ (test-read-boot-parameters args ...))))))
+ (not (or (test-read-boot-parameters #:version #false)
+ (test-read-boot-parameters #:version 'false)
+ (test-read-boot-parameters #:version -1)
+ (test-read-boot-parameters #:version "0")
+ (test-read-boot-parameters #:root-device #false)
+ (test-read-boot-parameters #:kernel #false)
+ (test-read-boot-parameters #:label #false)))))
(test-assert "read, construction, optional fields"
(and (test-read-boot-parameters #:bootloader-name #false)
diff --git a/tests/channels.scm b/tests/channels.scm
index d45c450241..0fe870dbaf 100644
--- a/tests/channels.scm
+++ b/tests/channels.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
-;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -526,6 +526,64 @@
'failed))))))
(unless (gpg+git-available?) (test-skip 1))
+(test-equal "authenticate-channel, not a descendant of introductory commit"
+ #t
+ (with-fresh-gnupg-setup (list %ed25519-public-key-file
+ %ed25519-secret-key-file
+ %ed25519-2-public-key-file
+ %ed25519-2-secret-key-file)
+ (with-temporary-git-repository directory
+ `((add ".guix-channel"
+ ,(object->string
+ '(channel (version 0)
+ (keyring-reference "master"))))
+ (add ".guix-authorizations"
+ ,(object->string
+ `(authorizations (version 0)
+ ((,(key-fingerprint
+ %ed25519-public-key-file)
+ (name "Charlie"))))))
+ (add "signer.key" ,(call-with-input-file %ed25519-public-key-file
+ get-string-all))
+ (commit "first commit"
+ (signer ,(key-fingerprint %ed25519-public-key-file)))
+ (branch "alternate-branch")
+ (checkout "alternate-branch")
+ (add "something.txt" ,(random-text))
+ (commit "intro commit"
+ (signer ,(key-fingerprint %ed25519-public-key-file)))
+ (checkout "master")
+ (add "random" ,(random-text))
+ (commit "second commit"
+ (signer ,(key-fingerprint %ed25519-public-key-file))))
+ (with-repository directory repository
+ (let* ((commit1 (find-commit repository "first"))
+ (commit2 (find-commit repository "second"))
+ (commit0 (commit-lookup
+ repository
+ (reference-target
+ (branch-lookup repository "alternate-branch"))))
+ (intro (make-channel-introduction
+ (commit-id-string commit0)
+ (openpgp-public-key-fingerprint
+ (read-openpgp-packet
+ %ed25519-public-key-file))))
+ (channel (channel (name 'example)
+ (url (string-append "file://" directory))
+ (introduction intro))))
+ (guard (c ((formatted-message? c)
+ (and (string-contains (formatted-message-string c)
+ "not a descendant")
+ (equal? (formatted-message-arguments c)
+ (list
+ (oid->string (commit-id commit2))
+ (oid->string (commit-id commit0)))))))
+ (authenticate-channel channel directory
+ (commit-id-string commit2)
+ #:keyring-reference-prefix "")
+ 'failed))))))
+
+(unless (gpg+git-available?) (test-skip 1))
(test-equal "authenticate-channel, .guix-authorizations"
#t
(with-fresh-gnupg-setup (list %ed25519-public-key-file
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 0775719ea3..57d80412dc 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -436,12 +436,48 @@
(derivation-input fixed2)))))
(and (derivation? final)
(match (derivation-inputs final)
- (((= derivation-input-derivation one)
- (= derivation-input-derivation two))
- (and (not (string=? (derivation-file-name one)
- (derivation-file-name two)))
- (string=? (derivation->output-path one)
- (derivation->output-path two))))))))
+ (((= derivation-input-derivation drv))
+ (memq drv (list fixed1 fixed2)))))))
+
+(test-assert "derivation with equivalent fixed-output inputs"
+ ;; Similar as the test above, but indirectly: DRV3A and DRV3B below are
+ ;; equivalent derivations (same output paths) but they depend on
+ ;; different-but-equivalent fixed-output derivations. Thus, DRV3A and DRV3B
+ ;; must be coalesced as inputs of DRV4. See <https://bugs.gnu.org/54209>.
+ (let* ((builder1 (add-text-to-store %store "fixed-builder1.sh"
+ "echo -n hello > $out"
+ '()))
+ (builder2 (add-text-to-store %store "fixed-builder2.sh"
+ "echo -n hello > $out"
+ '()))
+ (builder3 (add-text-to-store %store "user-builder.sh"
+ "echo 1 > $one; echo 2 > $two"
+ '()))
+ (hash (gcrypt:sha256 (string->utf8 "hello")))
+ (drv1 (derivation %store "fixed" %bash (list builder1)
+ #:sources (list builder1)
+ #:hash hash #:hash-algo 'sha256))
+ (drv2 (derivation %store "fixed" %bash (list builder2)
+ #:sources (list builder2)
+ #:hash hash #:hash-algo 'sha256))
+ (drv3a (derivation %store "fixed-user" %bash (list builder3)
+ #:outputs '("one" "two")
+ #:sources (list builder3)
+ #:inputs (list (derivation-input drv1))))
+ (drv3b (derivation %store "fixed-user" %bash (list builder3)
+ #:outputs '("one" "two")
+ #:sources (list builder3)
+ #:inputs (list (derivation-input drv2))))
+ (drv4 (derivation %store "fixed-user-user" %bash (list builder1)
+ #:sources (list builder1)
+ #:inputs (list (derivation-input drv3a '("one"))
+ (derivation-input drv3b '("two"))))))
+ (match (derivation-inputs drv4)
+ ((input)
+ (and (memq (derivation-input-derivation input)
+ (list drv3a drv3b))
+ (lset= string=? (derivation-input-sub-derivations input)
+ '("one" "two")))))))
(test-assert "multiple-output derivation"
(let* ((builder (add-text-to-store %store "my-fixed-builder.sh"
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 390cf7a207..c80ca13fab 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2021-2022 Maxime Devos <maximedevos@telenet.be>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -28,6 +28,7 @@
#:use-module (guix tests)
#:use-module ((guix build utils) #:select (with-directory-excursion))
#:use-module ((guix utils) #:select (call-with-temporary-directory))
+ #:use-module ((guix ui) #:select (load*))
#:use-module (gnu packages)
#:use-module (gnu packages base)
#:use-module (gnu packages bootstrap)
@@ -120,6 +121,19 @@
(let ((inside (file-append coreutils "/bin/hello")))
(gexp->approximate-sexp #~(display '#$inside))))
+;; See <https://issues.guix.gnu.org/54236>.
+(test-equal "unquoted sexp (not a gexp!)"
+ '(list #(foo) (foo) () "foo" foo #xf00)
+ (let ((inside/vector #(foo))
+ (inside/list '(foo))
+ (inside/empty '())
+ (inside/string "foo")
+ (inside/symbol 'foo)
+ (inside/number #xf00))
+ (gexp->approximate-sexp
+ #~(list #$inside/vector #$inside/list #$inside/empty #$inside/string
+ #$inside/symbol #$inside/number))))
+
(test-equal "no refs"
'(display "hello!")
(let ((exp (gexp (display "hello!"))))
@@ -134,6 +148,11 @@
(null? (gexp-inputs exp))
(gexp->sexp* exp))))
+(test-equal "gexp->approximate-sexp, outputs"
+ '(list 'out:foo (*approximate*) 'out:bar (*approximate*))
+ (gexp->approximate-sexp
+ #~(list 'out:foo #$output:foo 'out:bar #$output:bar)))
+
(test-equal "unquote"
'(display `(foo ,(+ 2 3)))
(let ((exp (gexp (display `(foo ,(+ 2 3))))))
@@ -222,6 +241,32 @@
(let ((file (local-file (string-copy "../base32.scm"))))
(local-file-absolute-file-name file)))))
+(test-assert "local-file, relative file name, within gexp"
+ (let* ((file (search-path %load-path "guix/base32.scm"))
+ (interned (add-to-store %store "base32.scm" #f "sha256" file)))
+ (equal? `(the file is ,interned)
+ (gexp->sexp*
+ #~(the file is #$(local-file "../guix/base32.scm"))))))
+
+(test-assert "local-file, relative file name, within gexp, compiled"
+ ;; In Guile 3.0.8, everything read by the #~ and #$ read hash extensions
+ ;; would lack source location info, which in turn would lead
+ ;; (current-source-directory), called by 'local-file', to return #f, thereby
+ ;; breaking 'local-file' resolution. See
+ ;; <https://issues.guix.gnu.org/54003>.
+ (let ((file (tmpnam)))
+ (call-with-output-file file
+ (lambda (port)
+ (display (string-append "#~(this file is #$(local-file \""
+ (basename file) "\" \"t.scm\"))")
+ port)))
+
+ (let* ((interned (add-to-store %store "t.scm" #f "sha256" file))
+ (module (make-fresh-user-module)))
+ (module-use! module (resolve-interface '(guix gexp)))
+ (equal? `(this file is ,interned)
+ (gexp->sexp* (load* file module))))))
+
(test-assertm "local-file, #:select?"
(mlet* %store-monad ((select? -> (lambda (file stat)
(member (basename file)
@@ -1539,6 +1584,28 @@ importing.* \\(guix config\\) from the host"
(cons (derivation-file-name drv)
refs))))))))
+(test-assertm "lower-object, computed-file, #:target"
+ (let* ((target "i586-pc-gnu")
+ (computed (computed-file "computed-cross"
+ #~(symlink #$coreutils output)
+ #:guile (default-guile))))
+ ;; When lowered to TARGET, the derivation of COMPUTED should run natively,
+ ;; using a native Guile, but it should refer to the target COREUTILS.
+ (mlet* %store-monad ((drv (lower-object computed (%current-system)
+ #:target target))
+ (refs (references* (derivation-file-name drv)))
+ (guile (lower-object (default-guile)
+ (%current-system)
+ #:target #f))
+ (cross (lower-object coreutils #:target target))
+ (native (lower-object coreutils #:target #f)))
+ (return (and (string=? (derivation-system (pk 'drv drv)) (%current-system))
+ (string=? (derivation-builder drv)
+ (string-append (derivation->output-path guile)
+ "/bin/guile"))
+ (not (member (derivation-file-name native) refs))
+ (member (derivation-file-name cross) refs))))))
+
(test-assert "lower-object & gexp-input-error?"
(guard (c ((gexp-input-error? c)
(gexp-error-invalid-input c)))
diff --git a/tests/git-authenticate.scm b/tests/git-authenticate.scm
index f66ef191b0..c063920c12 100644
--- a/tests/git-authenticate.scm
+++ b/tests/git-authenticate.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2020, 2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -20,12 +20,17 @@
#:use-module (git)
#:use-module (guix git)
#:use-module (guix git-authenticate)
+ #:use-module ((guix channels) #:select (openpgp-fingerprint))
+ #:use-module ((guix diagnostics)
+ #:select (formatted-message? formatted-message-arguments))
#:use-module (guix openpgp)
+ #:use-module ((guix tests) #:select (random-text))
#:use-module (guix tests git)
#:use-module (guix tests gnupg)
#:use-module (guix build utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-64)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports))
@@ -327,4 +332,147 @@
#:keyring-reference "master")
'failed)))))))
+(unless (gpg+git-available?) (test-skip 1))
+(test-assert "introductory commit, valid signature"
+ (with-fresh-gnupg-setup (list %ed25519-public-key-file
+ %ed25519-secret-key-file)
+ (let ((fingerprint (key-fingerprint %ed25519-public-key-file)))
+ (with-temporary-git-repository directory
+ `((add "signer.key" ,(call-with-input-file %ed25519-public-key-file
+ get-string-all))
+ (add ".guix-authorizations"
+ ,(object->string
+ `(authorizations (version 0)
+ ((,(key-fingerprint
+ %ed25519-public-key-file)
+ (name "Charlie"))))))
+ (commit "zeroth commit" (signer ,fingerprint))
+ (add "a.txt" "A")
+ (commit "first commit" (signer ,fingerprint)))
+ (with-repository directory repository
+ (let ((commit0 (find-commit repository "zero"))
+ (commit1 (find-commit repository "first")))
+ ;; COMMIT0 is signed with the right key, and COMMIT1 is fine.
+ (authenticate-repository repository
+ (commit-id commit0)
+ (openpgp-fingerprint fingerprint)
+ #:keyring-reference "master"
+ #:cache-key (random-text))))))))
+
+(unless (gpg+git-available?) (test-skip 1))
+(test-equal "introductory commit, missing signature"
+ 'intro-lacks-signature
+ (with-fresh-gnupg-setup (list %ed25519-public-key-file
+ %ed25519-secret-key-file)
+ (let ((fingerprint (key-fingerprint %ed25519-public-key-file)))
+ (with-temporary-git-repository directory
+ `((add "signer.key" ,(call-with-input-file %ed25519-public-key-file
+ get-string-all))
+ (add ".guix-authorizations"
+ ,(object->string
+ `(authorizations (version 0)
+ ((,(key-fingerprint
+ %ed25519-public-key-file)
+ (name "Charlie"))))))
+ (commit "zeroth commit") ;unsigned!
+ (add "a.txt" "A")
+ (commit "first commit" (signer ,fingerprint)))
+ (with-repository directory repository
+ (let ((commit0 (find-commit repository "zero")))
+ ;; COMMIT0 is not signed.
+ (guard (c ((formatted-message? c)
+ ;; Message like "commit ~a lacks a signature".
+ (and (equal? (formatted-message-arguments c)
+ (list (oid->string (commit-id commit0))))
+ 'intro-lacks-signature)))
+ (authenticate-repository repository
+ (commit-id commit0)
+ (openpgp-fingerprint fingerprint)
+ #:keyring-reference "master"
+ #:cache-key (random-text)))))))))
+
+(unless (gpg+git-available?) (test-skip 1))
+(test-equal "introductory commit, wrong signature"
+ 'wrong-intro-signing-key
+ (with-fresh-gnupg-setup (list %ed25519-public-key-file
+ %ed25519-secret-key-file
+ %ed25519-2-public-key-file
+ %ed25519-2-secret-key-file)
+ (let ((fingerprint (key-fingerprint %ed25519-public-key-file))
+ (wrong-fingerprint (key-fingerprint %ed25519-2-public-key-file)))
+ (with-temporary-git-repository directory
+ `((add "signer1.key" ,(call-with-input-file %ed25519-public-key-file
+ get-string-all))
+ (add "signer2.key" ,(call-with-input-file %ed25519-2-public-key-file
+ get-string-all))
+ (add ".guix-authorizations"
+ ,(object->string
+ `(authorizations (version 0)
+ ((,(key-fingerprint
+ %ed25519-public-key-file)
+ (name "Charlie"))))))
+ (commit "zeroth commit" (signer ,wrong-fingerprint))
+ (add "a.txt" "A")
+ (commit "first commit" (signer ,fingerprint)))
+ (with-repository directory repository
+ (let ((commit0 (find-commit repository "zero"))
+ (commit1 (find-commit repository "first")))
+ ;; COMMIT0 is signed with the wrong key--not the one passed as the
+ ;; SIGNER argument to 'authenticate-repository'.
+ (guard (c ((formatted-message? c)
+ ;; Message like "commit ~a signed by ~a instead of ~a".
+ (and (equal? (formatted-message-arguments c)
+ (list (oid->string (commit-id commit0))
+ wrong-fingerprint fingerprint))
+ 'wrong-intro-signing-key)))
+ (authenticate-repository repository
+ (commit-id commit0)
+ (openpgp-fingerprint fingerprint)
+ #:keyring-reference "master"
+ #:cache-key (random-text)))))))))
+
+(unless (gpg+git-available?) (test-skip 1))
+(test-equal "authenticate-repository, target not a descendant of intro"
+ 'target-commit-not-a-descendant-of-intro
+ (with-fresh-gnupg-setup (list %ed25519-public-key-file
+ %ed25519-secret-key-file)
+ (let ((fingerprint (key-fingerprint %ed25519-public-key-file)))
+ (with-temporary-git-repository directory
+ `((add "signer.key" ,(call-with-input-file %ed25519-public-key-file
+ get-string-all))
+ (add ".guix-authorizations"
+ ,(object->string
+ `(authorizations (version 0)
+ ((,(key-fingerprint
+ %ed25519-public-key-file)
+ (name "Charlie"))))))
+ (commit "zeroth commit" (signer ,fingerprint))
+ (branch "pre-intro-branch")
+ (checkout "pre-intro-branch")
+ (add "b.txt" "B")
+ (commit "alternate commit" (signer ,fingerprint))
+ (checkout "master")
+ (add "a.txt" "A")
+ (commit "first commit" (signer ,fingerprint))
+ (add "c.txt" "C")
+ (commit "second commit" (signer ,fingerprint)))
+ (with-repository directory repository
+ (let ((commit1 (find-commit repository "first"))
+ (commit-alt
+ (commit-lookup repository
+ (reference-target
+ (branch-lookup repository
+ "pre-intro-branch")))))
+ (guard (c ((formatted-message? c)
+ (and (equal? (formatted-message-arguments c)
+ (list (oid->string (commit-id commit-alt))
+ (oid->string (commit-id commit1))))
+ 'target-commit-not-a-descendant-of-intro)))
+ (authenticate-repository repository
+ (commit-id commit1)
+ (openpgp-fingerprint fingerprint)
+ #:end (commit-id commit-alt)
+ #:keyring-reference "master"
+ #:cache-key (random-text)))))))))
+
(test-end "git-authenticate")
diff --git a/tests/git.scm b/tests/git.scm
index d0646bbc85..ca59d2a33e 100644
--- a/tests/git.scm
+++ b/tests/git.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz
;;;
;;; This file is part of GNU Guix.
@@ -163,6 +163,56 @@
(commit-relation merge master1))))))
(unless (which (git-command)) (test-skip 1))
+(test-equal "commit-descendant?"
+ '((master3 master3 => #t)
+ (master1 master3 => #f)
+ (master3 master1 => #t)
+ (master2 branch1 => #f)
+ (master2 branch1 master1 => #t)
+ (branch1 master2 => #f)
+ (branch1 merge => #f)
+ (merge branch1 => #t)
+ (master1 merge => #f)
+ (merge master1 => #t))
+ (with-temporary-git-repository directory
+ '((add "a.txt" "A")
+ (commit "first commit")
+ (branch "hack")
+ (checkout "hack")
+ (add "1.txt" "1")
+ (commit "branch commit")
+ (checkout "master")
+ (add "b.txt" "B")
+ (commit "second commit")
+ (add "c.txt" "C")
+ (commit "third commit")
+ (merge "hack" "merge"))
+ (with-repository directory repository
+ (let ((master1 (find-commit repository "first"))
+ (master2 (find-commit repository "second"))
+ (master3 (find-commit repository "third"))
+ (branch1 (find-commit repository "branch"))
+ (merge (find-commit repository "merge")))
+ (letrec-syntax ((verify
+ (syntax-rules ()
+ ((_) '())
+ ((_ (new old ...) rest ...)
+ (cons `(new old ... =>
+ ,(commit-descendant? new
+ (list old ...)))
+ (verify rest ...))))))
+ (verify (master3 master3)
+ (master1 master3)
+ (master3 master1)
+ (master2 branch1)
+ (master2 branch1 master1)
+ (branch1 master2)
+ (branch1 merge)
+ (merge branch1)
+ (master1 merge)
+ (merge master1)))))))
+
+(unless (which (git-command)) (test-skip 1))
(test-equal "remote-refs"
'("refs/heads/develop" "refs/heads/master"
"refs/tags/v1.0" "refs/tags/v1.1")
diff --git a/tests/guix-build.sh b/tests/guix-build.sh
index 86e41e2927..9cbf8fe26d 100644
--- a/tests/guix-build.sh
+++ b/tests/guix-build.sh
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2012, 2013, 2014, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2012-2014, 2016-2022 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
# Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
#
@@ -31,6 +31,16 @@ guix build --version
guix build -e '(@ (gnu packages bootstrap) %bootstrap-glibc)' -S
test "`guix build -e '(@ (gnu packages bootstrap) %bootstrap-glibc)' -S`" = ""
+# Warn when attempting to build an unsupported package.
+case "$(guix build intelmetool -s armhf-linux -v0 -n 2>&1)" in
+ *warning:*intelmetool*support*armhf*)
+ true
+ break;;
+ *)
+ false;
+ break;;
+esac
+
# Should pass.
guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' | \
grep -e '-guile-'
diff --git a/tests/guix-git-authenticate.sh b/tests/guix-git-authenticate.sh
index 8ebbea398b..2b90d8a4af 100644
--- a/tests/guix-git-authenticate.sh
+++ b/tests/guix-git-authenticate.sh
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2020, 2022 Ludovic Courtès <ludo@gnu.org>
#
# This file is part of GNU Guix.
#
@@ -34,10 +34,18 @@ intro_signer="BBB0 2DDF 2CEA F6A8 0D1D E643 A2A0 6DF2 A33A 54FA"
cache_key="test-$$"
-guix git authenticate "$intro_commit" "$intro_signer" \
+# This must fail because the end commit is not a descendant of $intro_commit.
+! guix git authenticate "$intro_commit" "$intro_signer" \
--cache-key="$cache_key" --stats \
--end=9549f0283a78fe36f2d4ff2a04ef8ad6b0c02604
+# The v1.2.0 commit is a descendant of $intro_commit and it satisfies the
+# authorization invariant.
+v1_2_0_commit="a099685659b4bfa6b3218f84953cbb7ff9e88063"
+guix git authenticate "$intro_commit" "$intro_signer" \
+ --cache-key="$cache_key" --stats \
+ --end="$v1_2_0_commit"
+
rm "$XDG_CACHE_HOME/guix/authentication/$cache_key"
# Commit and signer of the 'v1.0.0' tag.
@@ -45,6 +53,11 @@ v1_0_0_commit="6298c3ffd9654d3231a6f25390b056483e8f407c"
v1_0_0_signer="3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5" # civodul
v1_0_1_commit="d68de958b60426798ed62797ff7c96c327a672ac"
+# This should succeed because v1.0.0 is an ancestor of $intro_commit.
+guix git authenticate "$intro_commit" "$intro_signer" \
+ --cache-key="$cache_key" --stats \
+ --end="$v1_0_0_commit"
+
# This should fail because these commits lack '.guix-authorizations'.
! guix git authenticate "$v1_0_0_commit" "$v1_0_0_signer" \
--cache-key="$cache_key" --end="$v1_0_1_commit"
diff --git a/tests/guix-home.sh b/tests/guix-home.sh
index e578559c97..0f68484ef4 100644
--- a/tests/guix-home.sh
+++ b/tests/guix-home.sh
@@ -1,7 +1,7 @@
-
# GNU Guix --- Functional package management for GNU
# Copyright © 2021 Andrew Tropin <andrew@trop.in>
# Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com>
+# Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
#
# This file is part of GNU Guix.
#
@@ -26,6 +26,16 @@ set -e
guix home --version
+container_supported ()
+{
+ if guile -c '((@ (guix scripts environment) assert-container-features))'
+ then
+ return 0
+ else
+ return 1
+ fi
+}
+
NIX_STORE_DIR="$(guile -c '(use-modules (guix config))(display %storedir)')"
localstatedir="$(guile -c '(use-modules (guix config))(display %localstatedir)')"
GUIX_DAEMON_SOCKET="$localstatedir/guix/daemon-socket/socket"
@@ -47,15 +57,6 @@ trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT
(
cd "$test_directory" || exit 77
- HOME="$test_directory"
- export HOME
-
- #
- # Test 'guix home reconfigure'.
- #
-
- printf "# dot-bashrc test file for guix home" > "dot-bashrc"
-
cat > "home.scm" <<'EOF'
(use-modules (guix gexp)
(gnu home)
@@ -76,10 +77,7 @@ trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT
(service home-bash-service-type
(home-bash-configuration
(guix-defaults? #t)
- (bashrc
- (list
- (local-file (string-append (dirname (current-filename))
- "/dot-bashrc"))))))
+ (bashrc (list (local-file "dot-bashrc")))))
(simple-service 'home-bash-service-extension-test
home-bash-service-type
@@ -91,6 +89,47 @@ trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT
"# the content of bashrc-test-config.sh"))))))))
EOF
+ echo -n "# dot-bashrc test file for guix home" > "dot-bashrc"
+
+ # Check whether the graph commands work as expected.
+ guix home extension-graph "home.scm" | grep 'label = "home-activation"'
+ guix home extension-graph "home.scm" | grep 'label = "home-symlink-manager"'
+ guix home extension-graph "home.scm" | grep 'label = "home"'
+
+ # There are no Shepherd services so the one below must fail.
+ ! guix home shepherd-graph "home.scm"
+
+ if container_supported
+ then
+ # Run the home in a container.
+ guix home container home.scm -- true
+ ! guix home container home.scm -- false
+ test "$(guix home container home.scm -- echo '$HOME')" = "$HOME"
+ guix home container home.scm -- cat '~/.config/test.conf' | \
+ grep "the content of"
+ guix home container home.scm -- test -h '~/.bashrc'
+ test "$(guix home container home.scm -- id -u)" = 1000
+ ! guix home container home.scm -- test -f '$HOME/sample/home.scm'
+ guix home container home.scm --expose="$PWD=$HOME/sample" -- \
+ test -f '$HOME/sample/home.scm'
+ ! guix home container home.scm --expose="$PWD=$HOME/sample" -- \
+ rm -v '$HOME/sample/home.scm'
+ else
+ echo "'guix home container' test SKIPPED" >&2
+ fi
+
+ HOME="$test_directory"
+ export HOME
+
+ #
+ # Test 'guix home reconfigure'.
+ #
+
+ echo "# This file will be overridden and backed up." > "$HOME/.bashrc"
+ mkdir "$HOME/.config"
+ echo "This file will be overridden too." > "$HOME/.config/test.conf"
+ echo "This file will stay around." > "$HOME/.config/random-file"
+
guix home reconfigure "${test_directory}/home.scm"
test -d "${HOME}/.guix-home"
test -h "${HOME}/.bash_profile"
@@ -100,6 +139,14 @@ EOF
# the content of bashrc-test-config.sh"
grep -q "the content of ~/.config/test.conf" "${HOME}/.config/test.conf"
+ # This one should still be here.
+ grep "stay around" "$HOME/.config/random-file"
+
+ # Make sure preexisting files were backed up.
+ grep "overridden" "$HOME"/*guix-home*backup/.bashrc
+ grep "overridden" "$HOME"/*guix-home*backup/.config/test.conf
+ rm -r "$HOME"/*guix-home*backup
+
#
# Test 'guix home describe'.
#
@@ -123,6 +170,28 @@ EOF
test "$(canonical_file_name)" == "$(readlink "${HOME}/.guix-home")"
#
+ # Configure a new generation.
+ #
+
+ # Change the bashrc snippet content and comment out one service.
+ sed -i "home.scm" -e's/the content of/the NEW content of/g'
+ sed -i "home.scm" -e"s/(simple-service 'test-config/#;(simple-service 'test-config/g"
+
+ guix home reconfigure "${test_directory}/home.scm"
+ test "$(tail -n 2 "${HOME}/.bashrc")" == "\
+# dot-bashrc test file for guix home
+# the NEW content of bashrc-test-config.sh"
+
+ # This file must have been removed and not backed up.
+ ! test -e "$HOME/.config/test.conf"
+ ! test -e "$HOME"/*guix-home*backup/.config/test.conf
+
+ test "$(cat "$(configuration_file)")" == "$(cat home.scm)"
+ test "$(canonical_file_name)" == "$(readlink "${HOME}/.guix-home")"
+
+ test $(guix home list-generations | grep "^Generation" | wc -l) -eq 2
+
+ #
# Test 'guix home search'.
#
diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh
index 0339221ac2..1356a74083 100644
--- a/tests/guix-pack.sh
+++ b/tests/guix-pack.sh
@@ -1,6 +1,6 @@
# GNU Guix --- Functional package management for GNU
# Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
-# Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2018, 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
#
# This file is part of GNU Guix.
#
@@ -36,6 +36,9 @@ export GUIX_BUILD_OPTIONS
test_directory="`mktemp -d`"
trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT
+# Reject unsuppoted packages.
+! guix pack intelmetool -s armhf-linux -n
+
# Compute the derivation of a pack.
drv="`guix pack coreutils -d --no-grafts`"
guix gc -R "$drv" | grep "`guix build coreutils -d --no-grafts`"
diff --git a/tests/guix-package.sh b/tests/guix-package.sh
index 92ab565c5b..d1b383d2ad 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
#
# This file is part of GNU Guix.
@@ -59,6 +59,17 @@ test -L "$profile" && test -L "$profile-1-link"
! test -f "$profile-2-link"
test -f "$profile/bin/guile"
+# Unsupported packages cannot be installed.
+! guix package -e '(begin (use-modules (guix) (gnu packages base)) (package (inherit sed) (supported-systems (list))))' -n
+case $(uname -m) in
+ x86_64|i[3456]86)
+ ! guix package -i novena-eeprom -n
+ break;;
+ *)
+ ! guix package -i intelmetool -n
+ break;;
+esac
+
# Collisions are properly flagged (in this case, 'g-wrap' propagates
# guile@2.2, which conflicts with guile@2.0.)
! guix package --bootstrap -n -p "$profile" -i g-wrap guile@2.0
diff --git a/tests/guix-shell.sh b/tests/guix-shell.sh
index 23ff1c5bcf..6340f90574 100644
--- a/tests/guix-shell.sh
+++ b/tests/guix-shell.sh
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org>
#
# This file is part of GNU Guix.
#
@@ -35,6 +35,9 @@ guix shell --bootstrap --pure guile-bootstrap -- guile --version
# '--ad-hoc' is a thing of the past.
! guix shell --ad-hoc guile-bootstrap
+# Rejecting unsupported packages.
+! guix shell -s armhf-linux intelmetool -n
+
# Ignoring unauthorized files.
cat > "$tmpdir/guix.scm" <<EOF
This is a broken guix.scm file.
diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index 6aab1f380a..044fd131d6 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
# Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
#
@@ -336,11 +336,15 @@ rm "$tmpdir/search"
# Verify that the examples can be built.
for example in gnu/system/examples/*.tmpl; do
if echo "$example" | grep hurd; then
- target="--target=i586-pc-gnu"
+ options="--target=i586-pc-gnu"
+ elif echo "$example" | grep asus; then
+ # 'asus-c201.tmpl' uses 'linux-libre-arm-generic', which is an
+ # ARM-only package.
+ options="--system=armhf-linux"
else
- target=
+ options=""
fi
- guix system -n disk-image $target "$example"
+ guix system -n disk-image $options "$example"
done
# Verify that the images can be built.
diff --git a/tests/home-import.scm b/tests/home-import.scm
index 6d373acf79..ca8aa95431 100644
--- a/tests/home-import.scm
+++ b/tests/home-import.scm
@@ -158,6 +158,29 @@ corresponding file."
('list ('local-file "/tmp/guix-config/.bashrc"
"bashrc"))))))))))
+(define-home-environment-matcher match-home-environment-bash-service-with-alias
+ ('begin
+ ('use-modules
+ ('gnu 'home)
+ ('gnu 'packages)
+ ('gnu 'services)
+ ('guix 'gexp)
+ ('gnu 'home 'services 'shells))
+ ('home-environment
+ ('packages
+ ('map ('compose 'list 'specification->package+output)
+ ('list)))
+ ('services
+ ('list ('service
+ 'home-bash-service-type
+ ('home-bash-configuration
+ ('aliases
+ ('quote (("grep" . "grep --exclude-from=\"$HOME/.grep-exclude\"")
+ ("ls" . "ls -p"))))
+ ('bashrc
+ ('list ('local-file "/tmp/guix-config/.bashrc"
+ "bashrc"))))))))))
+
(test-assert "manifest->code: No services"
(eval-test-with-home-environment
@@ -187,4 +210,12 @@ corresponding file."
(make-manifest '())
match-home-environment-bash-service))
+(test-assert "manifest->code: Bash service with aliases"
+ (eval-test-with-home-environment
+ '((".bashrc"
+ . "# Aliases
+alias ls=\"ls -p\"; alias grep='grep --exclude-from=\"$HOME/.grep-exclude\"'\n"))
+ (make-manifest '())
+ match-home-environment-bash-service-with-alias))
+
(test-end "home-import")
diff --git a/tests/http-client.scm b/tests/http-client.scm
new file mode 100644
index 0000000000..649fa1bfac
--- /dev/null
+++ b/tests/http-client.scm
@@ -0,0 +1,84 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.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 (test-http-client)
+ #:use-module (guix http-client)
+ #:use-module (guix tests http)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-64)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
+ #:use-module (web response)
+ #:use-module (web uri))
+
+(test-begin "http-client")
+
+(test-equal "http-fetch, one request, binary"
+ (string->utf8 "Hello, world.")
+ (with-http-server `((200 "Hello, world."))
+ (let* ((port (http-fetch (%local-url)))
+ (bv (get-bytevector-all port)))
+ (close-port port)
+ bv)))
+
+(test-equal "http-fetch, one request, text"
+ "Hello, world."
+ (with-http-server `((200 "Hello, world."))
+ (let* ((port (http-fetch (%local-url) #:text? #t))
+ (data (get-string-all port)))
+ (close-port port)
+ data)))
+
+(test-equal "http-fetch, redirect"
+ "Hello, world."
+ (with-http-server `((,(build-response
+ #:code 301
+ #:headers
+ `((location
+ . ,(string->uri-reference "/elsewhere")))
+ #:reason-phrase "Moved")
+ "Redirect!")
+ (200 "Hello, world."))
+ (let* ((port (http-fetch (%local-url)))
+ (data (get-string-all port)))
+ (close-port port)
+ data)))
+
+(test-equal "http-fetch, error"
+ 404
+ (with-http-server `((404 "Ne trovita."))
+ (guard (c ((http-get-error? c) (http-get-error-code c)))
+ (http-fetch (%local-url))
+ #f)))
+
+(test-equal "http-fetch, redirect + error"
+ 403
+ (with-http-server `((,(build-response
+ #:code 302
+ #:headers
+ `((location
+ . ,(string->uri-reference "/elsewhere")))
+ #:reason-phrase "Moved")
+ "Redirect!")
+ (403 "Verboten."))
+ (guard (c ((http-get-error? c) (http-get-error-code c)))
+ (http-fetch (%local-url))
+ #f)))
+
+(test-end "http-client")
diff --git a/tests/import-github.scm b/tests/import-github.scm
index 979a0fc12b..4d3f8cfc7e 100644
--- a/tests/import-github.scm
+++ b/tests/import-github.scm
@@ -26,28 +26,37 @@
#:use-module (guix packages)
#:use-module (guix tests)
#:use-module (guix upstream)
+ #:use-module (web uri)
#:use-module (ice-9 match))
(test-begin "github")
(define (call-with-releases thunk tags releases)
- (mock ((guix http-client) http-fetch
- (lambda* (uri #:key headers)
- (unless (string-prefix? "mock://" uri)
- (error "the URI ~a should not be used" uri))
- (define components
- (string-split (substring uri 8) #\/))
- (pk 'stuff components headers)
- (define (scm->json-port scm)
- (open-input-string (scm->json-string scm)))
- (match components
- (("repos" "foo" "foomatics" "releases")
- (scm->json-port releases))
- (("repos" "foo" "foomatics" "tags")
- (scm->json-port tags))
- (rest (error "TODO ~a" rest)))))
- (parameterize ((%github-api "mock://"))
- (thunk))))
+ (mock ((guix build download) open-connection-for-uri
+ (lambda _
+ ;; Return a fake socket.
+ (%make-void-port "w+0")))
+ (mock ((guix http-client) http-fetch
+ (lambda* (uri #:key headers #:allow-other-keys)
+ (let ((uri (if (string? uri)
+ (string->uri uri)
+ uri)))
+ (unless (eq? 'mock (uri-scheme uri))
+ (error "the URI ~a should not be used" uri))
+ (define components
+ (string-tokenize (uri-path uri)
+ (char-set-complement (char-set #\/))))
+ (pk 'stuff components headers)
+ (define (scm->json-port scm)
+ (open-input-string (scm->json-string scm)))
+ (match components
+ (("repos" "foo" "foomatics" "releases")
+ (scm->json-port releases))
+ (("repos" "foo" "foomatics" "tags")
+ (scm->json-port tags))
+ (rest (error "TODO ~a" rest))))))
+ (parameterize ((%github-api "mock://"))
+ (thunk)))))
;; Copied from tests/minetest.scm
(define (upstream-source->sexp upstream-source)
diff --git a/tests/lint.scm b/tests/lint.scm
index 76c2a70b3a..6bb24370da 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -35,6 +35,8 @@
#:use-module (guix tests http)
#:use-module (guix download)
#:use-module (guix git-download)
+ #:use-module (guix build-system texlive)
+ #:use-module (guix build-system emacs)
#:use-module (guix build-system gnu)
#:use-module (guix packages)
#:use-module (guix lint)
@@ -338,6 +340,25 @@
`(#:tests? ,(not (%current-target-system)))))))
(check-tests-true pkg)))
+;; The emacs-build-system sets #:tests? #f by default.
+(test-equal "tests-true: #:tests? #t acceptable for emacs packages"
+ '()
+ (let ((pkg (dummy-package "x"
+ (build-system emacs-build-system)
+ (arguments
+ `(#:tests? #t)))))
+ (check-tests-true pkg)))
+
+;; Likewise, though the 'check' phase is deleted by default,
+;; so #:tests? #t won't be useful by itself.
+(test-equal "tests-true: #:tests? #t acceptable for texlive packages"
+ '()
+ (let ((pkg (dummy-package "x"
+ (build-system texlive-build-system)
+ (arguments
+ `(#:tests? #t)))))
+ (check-tests-true pkg)))
+
(test-equal "inputs: pkg-config is probably a native input"
"'pkg-config' should probably be a native input"
(single-lint-warning-message
diff --git a/tests/packages.scm b/tests/packages.scm
index 55b1c4064f..710eace6dc 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -508,6 +508,16 @@
(and (supported-package? p "x86_64-linux")
(supported-package? p "armhf-linux"))))
+(test-assert "supported-package? vs. %current-target-system"
+ ;; The %CURRENT-TARGET-SYSTEM value should have no influence.
+ (parameterize ((%current-target-system "arm-linux-gnueabihf"))
+ (let ((p (dummy-package "foo"
+ (build-system gnu-build-system)
+ (supported-systems '("x86_64-linux" "armhf-linux")))))
+ (and (supported-package? p "x86_64-linux")
+ (not (supported-package? p "i686-linux"))
+ (supported-package? p "armhf-linux")))))
+
(test-skip (if (not %store) 8 0))
(test-assert "package-source-derivation, file"
@@ -1946,6 +1956,47 @@
(dummy-package "a"
(arguments (this-package-native-input "hello")))))
+(test-eq "modify-inputs, replace"
+ coreutils
+ ;; Replace an input; notice that the label in unchanged.
+ (let* ((p1 (dummy-package "p"
+ (inputs (list hello))))
+ (p2 (package
+ (inherit p1)
+ (version "1")
+ (inputs (modify-inputs (package-inputs p1)
+ (replace "hello" coreutils))))))
+ (lookup-package-input p2 "hello")))
+
+(test-eq "modify-inputs, replace, change output"
+ guile-3.0
+ ;; Replace an input and choose a different output.
+ (let* ((p1 (dummy-package "p"
+ (inputs (list `(,coreutils "debug")))))
+ (p2 (package
+ (inherit p1)
+ (version "1")
+ (inputs (modify-inputs (package-inputs p1)
+ (replace "coreutils" `(,guile-3.0 "out")))))))
+ (match (package-inputs p2)
+ ((("coreutils" input "out"))
+ input))))
+
+(test-eq "modify-inputs, replace, extra output"
+ guile-3.0
+ ;; Replace an input; notice that its output is preserved.
+ ;; See <https://issues.guix.gnu.org/53915>.
+ (let* ((p1 (dummy-package "p"
+ (inputs (list `(,coreutils "debug")))))
+ (p2 (package
+ (inherit p1)
+ (version "1")
+ (inputs (modify-inputs (package-inputs p1)
+ (replace "coreutils" guile-3.0))))))
+ (match (package-inputs p2)
+ ((("coreutils" input "debug"))
+ input))))
+
(test-end "packages")
;;; Local Variables:
diff --git a/tests/publish.scm b/tests/publish.scm
index e3c27c5eea..47c5eabca0 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -142,15 +142,10 @@
(unsigned-info
(format #f
"StorePath: ~a
-URL: nar/~a
-Compression: none
-FileSize: ~a
NarHash: sha256:~a
NarSize: ~d
References: ~a~%"
%item
- (basename %item)
- (path-info-nar-size info)
(bytevector->nix-base32-string
(path-info-hash info))
(path-info-nar-size info)
@@ -159,8 +154,13 @@ References: ~a~%"
(string->utf8
(canonical-sexp->string
(signed-string unsigned-info))))))
- (format #f "~aSignature: 1;~a;~a~%"
- unsigned-info (gethostname) signature))
+ (format #f "~aSignature: 1;~a;~a
+URL: nar/~a
+Compression: none
+FileSize: ~a\n"
+ unsigned-info (gethostname) signature
+ (basename %item)
+ (path-info-nar-size info)))
(utf8->string
(http-get-body
(publish-uri
@@ -173,15 +173,10 @@ References: ~a~%"
(unsigned-info
(format #f
"StorePath: ~a
-URL: nar/~a
-Compression: none
-FileSize: ~a
NarHash: sha256:~a
NarSize: ~d
References: ~%"
item
- (uri-encode (basename item))
- (path-info-nar-size info)
(bytevector->nix-base32-string
(path-info-hash info))
(path-info-nar-size info)))
@@ -189,8 +184,13 @@ References: ~%"
(string->utf8
(canonical-sexp->string
(signed-string unsigned-info))))))
- (format #f "~aSignature: 1;~a;~a~%"
- unsigned-info (gethostname) signature))
+ (format #f "~aSignature: 1;~a;~a
+URL: nar/~a
+Compression: none
+FileSize: ~a~%"
+ unsigned-info (gethostname) signature
+ (uri-encode (basename item))
+ (path-info-nar-size info)))
(let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
(utf8->string
@@ -324,7 +324,12 @@ References: ~%"
(part (store-path-hash-part %item))
(url (string-append base part ".narinfo"))
(body (http-get-port url)))
- (list (take (recutils->alist body) 5)
+ (list (filter (match-lambda
+ (("StorePath" . _) #t)
+ (("URL" . _) #t)
+ (("Compression" . _) #t)
+ (_ #f))
+ (recutils->alist body))
(response-code
(http-get (string-append base "nar/gzip/"
(basename %item))))
@@ -504,16 +509,22 @@ References: ~%"
(basename %item))))
(and (file-exists? (nar "gzip"))
(file-exists? (nar "lzip"))
- (equal? (take (pk 'narinfo/gzip+lzip narinfo) 7)
- `(("StorePath" . ,%item)
- ("URL" . ,(nar-url "gzip"))
- ("Compression" . "gzip")
- ("FileSize" . ,(number->string
- (stat:size (stat (nar "gzip")))))
- ("URL" . ,(nar-url "lzip"))
- ("Compression" . "lzip")
- ("FileSize" . ,(number->string
- (stat:size (stat (nar "lzip")))))))
+ (match (pk 'narinfo/gzip+lzip narinfo)
+ ((("StorePath" . path)
+ _ ...
+ ("Signature" . _)
+ ("URL" . gzip-url)
+ ("Compression" . "gzip")
+ ("FileSize" . (= string->number gzip-size))
+ ("URL" . lzip-url)
+ ("Compression" . "lzip")
+ ("FileSize" . (= string->number lzip-size)))
+ (and (string=? gzip-url (nar-url "gzip"))
+ (string=? lzip-url (nar-url "lzip"))
+ (= gzip-size
+ (stat:size (stat (nar "gzip"))))
+ (= lzip-size
+ (stat:size (stat (nar "lzip")))))))
(list (response-code
(http-get (string-append base (nar-url "gzip"))))
(response-code
diff --git a/tests/substitute.scm b/tests/substitute.scm
index 21b513e1d8..049e6ba762 100644
--- a/tests/substitute.scm
+++ b/tests/substitute.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
-;;; Copyright © 2014, 2015, 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2015, 2017-2019, 2021-2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -268,6 +268,29 @@ System: mips64el-linux\n")
(lambda ()
(guix-substitute "--query")))))))))
+(test-equal "query narinfo with signature over relevant subset"
+ ;; The signature covers the StorePath/NarHash/References tuple, so it is
+ ;; valid; it does not cover non-normative fields, which is fine.
+ (string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+
+ (let ((prefix (string-append "StorePath: " (%store-prefix)
+ "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
+NarHash: sha256:aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
+References: bar baz\n")))
+ (with-narinfo (string-append prefix
+ "Signature: " (signature-field prefix) "
+URL: example.nar
+Compression: none
+NarSize: 42
+Deriver: " (%store-prefix) "/foo.drv")
+ (string-trim-both
+ (with-output-to-string
+ (lambda ()
+ (with-input-from-string (string-append "have " (%store-prefix)
+ "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
+ (lambda ()
+ (guix-substitute "--query")))))))))
+
(test-equal "query narinfo signed with authorized key"
(string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
generated by cgit v1.2.3 (git 2.50.1) at 2025-08-03 03:56:07 +0000