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.scm81
-rw-r--r--tests/git-authenticate.scm150
-rw-r--r--tests/git.scm52
-rw-r--r--tests/graph.scm28
-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.scm56
-rw-r--r--tests/profiles.scm5
-rw-r--r--tests/publish.scm61
-rw-r--r--tests/pypi.scm119
-rw-r--r--tests/substitute.scm25
23 files changed, 899 insertions, 151 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 ad8e1d57b8..c80ca13fab 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014-2021 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
+;;; 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)
@@ -1413,6 +1458,7 @@ importing.* \\(guix config\\) from the host"
(test-assertm "mixed-text-file"
(mlet* %store-monad ((file -> (mixed-text-file "mixed"
+ #:guile %bootstrap-guile
"export PATH="
%bootstrap-guile "/bin"))
(drv (lower-object file))
@@ -1430,7 +1476,8 @@ importing.* \\(guix config\\) from the host"
(mlet* %store-monad ((union -> (file-union "union"
`(("a" ,(plain-file "a" "1"))
("b/c/d" ,(plain-file "d" "2"))
- ("e" ,(plain-file "e" "3")))))
+ ("e" ,(plain-file "e" "3")))
+ #:guile %bootstrap-guile))
(drv (lower-object union))
(out -> (derivation->output-path drv)))
(define (contents=? file str)
@@ -1469,7 +1516,8 @@ importing.* \\(guix config\\) from the host"
(symlink #$%bootstrap-guile
(string-append #$output "/guile"))
(symlink #$text (string-append #$output "/text"))))
- (computed (computed-file "computed" exp)))
+ (computed (computed-file "computed" exp
+ #:guile %bootstrap-guile)))
(mlet* %store-monad ((text (lower-object text))
(guile-drv (lower-object %bootstrap-guile))
(comp-drv (lower-object computed))
@@ -1504,7 +1552,8 @@ importing.* \\(guix config\\) from the host"
(display item port))))))
(computed (computed-file "computed" exp
#:options
- `(#:references-graphs (("graph" ,pkg)))))
+ `(#:references-graphs (("graph" ,pkg)))
+ #:guile %bootstrap-guile))
(drv0 (package-derivation %store pkg #:graft? #t))
(drv1 (parameterize ((%graft? #t))
(run-with-store %store
@@ -1535,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/graph.scm b/tests/graph.scm
index fadac265f9..baa08a6be2 100644
--- a/tests/graph.scm
+++ b/tests/graph.scm
@@ -36,6 +36,7 @@
#:use-module (gnu packages libunistring)
#:use-module (gnu packages bootstrap)
#:use-module (ice-9 match)
+ #:use-module (ice-9 sandbox)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
@@ -113,6 +114,33 @@ edges."
(list p4 p4)
(list p2 p3))))))))
+(test-assert "package DAG, oops it was a cycle"
+ (let-values (((backend nodes+edges) (make-recording-backend)))
+ (letrec ((p1 (dummy-package "p1" (inputs `(("p3" ,p3)))))
+ (p2 (dummy-package "p2" (inputs `(("p1" ,p1)))))
+ (p3 (dummy-package "p3" (inputs `(("p2" ,p2) ("p1", p1))))))
+ (call-with-time-limit
+ 600 ;; If ever this test should fail, we still want it to terminate
+ (lambda ()
+ (run-with-store %store
+ (export-graph (list p3) 'port
+ #:node-type %package-node-type
+ #:backend backend)))
+ (lambda ()
+ (run-with-store %store
+ (export-graph
+ (list (dummy-package "timeout-reached"))
+ 'port
+ #:node-type %package-node-type
+ #:backend backend))))
+ ;; We should see nothing more than these 3 packages.
+ (let-values (((nodes edges) (nodes+edges)))
+ (and (equal? nodes (map package->tuple (list p3 p2 p1)))
+ (equal? edges
+ (map edge->tuple
+ (list p3 p3 p2 p1)
+ (list p2 p1 p1 p3))))))))
+
(test-assert "reverse package DAG"
(let-values (((backend nodes+edges) (make-recording-backend)))
(run-with-store %store
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 3506f94f91..710eace6dc 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -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 © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
@@ -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"
@@ -716,7 +726,8 @@
(use-modules (guix build utils))
(setenv "PATH" #+bin)
(invoke "tar" "xvf" #+out)
- (copy-file #+name #$output)))))
+ (copy-file #+name #$output)))
+ #:guile %bootstrap-guile))
(drv (run-with-store %store (lower-object f)))
(_ (build-derivations %store (list drv))))
(call-with-input-file (derivation->output-path drv)
@@ -1945,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/profiles.scm b/tests/profiles.scm
index cac5b73347..d59d75985f 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
@@ -302,7 +302,8 @@
(call-with-output-file
(string-append #$output "/bin/guile")
(lambda (port)
- (display "Fake!\n" port))))))))
+ (display "Fake!\n" port))))
+ #:guile %bootstrap-guile))))
(guile (package->derivation %bootstrap-guile))
(drv (profile-derivation (manifest (list entry1 entry2))
#:hooks '()
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/pypi.scm b/tests/pypi.scm
index 1ea5f02643..88bb0a3116 100644
--- a/tests/pypi.scm
+++ b/tests/pypi.scm
@@ -3,6 +3,7 @@
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2022 Vivien Kraus <vivien@planete-kraus.eu>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,68 +24,50 @@
#:use-module (guix import pypi)
#:use-module (guix base32)
#:use-module (guix memoization)
+ #:use-module (guix utils)
#:use-module (gcrypt hash)
#:use-module (guix tests)
#:use-module (guix build-system python)
#:use-module ((guix build utils) #:select (delete-file-recursively which mkdir-p))
+ #:use-module ((guix diagnostics) #:select (guix-warning-port))
+ #:use-module (json)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (srfi srfi-64)
- #:use-module (ice-9 match))
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 optargs))
+
+(define* (foo-json #:key (name "foo") (name-in-url #f))
+ "Create a JSON description of an example pypi package, named @var{name},
+optionally using a different @var{name in its URL}."
+ (scm->json-string
+ `((info
+ . ((version . "1.0.0")
+ (name . ,name)
+ (license . "GNU LGPL")
+ (summary . "summary")
+ (home_page . "http://example.com")
+ (classifiers . #())
+ (download_url . "")))
+ (urls . #())
+ (releases
+ . ((1.0.0
+ . #(((url . ,(format #f "https://example.com/~a-1.0.0.egg"
+ (or name-in-url name)))
+ (packagetype . "bdist_egg"))
+ ((url . ,(format #f "https://example.com/~a-1.0.0.tar.gz"
+ (or name-in-url name)))
+ (packagetype . "sdist"))
+ ((url . ,(format #f "https://example.com/~a-1.0.0-py2.py3-none-any.whl"
+ (or name-in-url name)))
+ (packagetype . "bdist_wheel")))))))))
(define test-json-1
- "{
- \"info\": {
- \"version\": \"1.0.0\",
- \"name\": \"foo\",
- \"license\": \"GNU LGPL\",
- \"summary\": \"summary\",
- \"home_page\": \"http://example.com\",
- \"classifiers\": [],
- \"download_url\": \"\"
- },
- \"urls\": [],
- \"releases\": {
- \"1.0.0\": [
- {
- \"url\": \"https://example.com/foo-1.0.0.egg\",
- \"packagetype\": \"bdist_egg\"
- }, {
- \"url\": \"https://example.com/foo-1.0.0.tar.gz\",
- \"packagetype\": \"sdist\"
- }, {
- \"url\": \"https://example.com/foo-1.0.0-py2.py3-none-any.whl\",
- \"packagetype\": \"bdist_wheel\"
- }
- ]
- }
-}")
+ (foo-json))
(define test-json-2
- "{
- \"info\": {
- \"version\": \"1.0.0\",
- \"name\": \"foo-99\",
- \"license\": \"GNU LGPL\",
- \"summary\": \"summary\",
- \"home_page\": \"http://example.com\",
- \"classifiers\": [],
- \"download_url\": \"\"
- },
- \"urls\": [],
- \"releases\": {
- \"1.0.0\": [
- {
- \"url\": \"https://example.com/foo-99-1.0.0.egg\",
- \"packagetype\": \"bdist_egg\"
- }, {
- \"url\": \"https://example.com/foo-99-1.0.0.tar.gz\",
- \"packagetype\": \"sdist\"
- }, {
- \"url\": \"https://example.com/foo-99-1.0.0-py2.py3-none-any.whl\",
- \"packagetype\": \"bdist_wheel\"
- }
- ]
- }
-}")
+ (foo-json #:name "foo-99"))
(define test-source-hash
"")
@@ -211,6 +194,30 @@ Requires-Dist: pytest (>=3.1.0); extra == 'testing'
call-with-input-string)
(parse-wheel-metadata test-metadata-with-extras-jedi)))
+(test-equal "find-project-url, with numpy"
+ "numpy"
+ (find-project-url
+ "numpy"
+ "https://files.pythonhosted.org/packages/0a/c8/a62767a6b374a0dfb02d2a0456e5f56a372cdd1689dbc6ffb6bf1ddedbc0/numpy-1.22.1.zip"))
+
+(test-equal "find-project-url, uWSGI"
+ "uwsgi"
+ (find-project-url
+ "uWSGI"
+ "https://files.pythonhosted.org/packages/24/fd/93851e4a076719199868d4c918cc93a52742e68370188c1c570a6e42a54f/uwsgi-2.0.20.tar.gz"))
+
+(test-equal "find-project-url, flake8-array-spacing"
+ "flake8_array_spacing"
+ (find-project-url
+ "flake8-array-spacing"
+ "https://files.pythonhosted.org/packages/a4/21/ff29b901128b681b7de7a2787b3aeb3e1f3cba4a8c0cffa9712cbff016bc/flake8_array_spacing-0.2.0.tar.gz"))
+
+(test-equal "find-project-url, foo/goo"
+ "foo"
+ (find-project-url
+ "foo"
+ "https://files.pythonhosted.org/packages/f0/f00/goo-0.0.0.tar.gz"))
+
(test-assert "pypi->guix-package, no wheel"
;; Replace network resources with sample data.
(mock ((guix import utils) url-fetch
@@ -260,10 +267,8 @@ Requires-Dist: pytest (>=3.1.0); extra == 'testing'
hash)
(equal? (pypi->guix-package "foo" #:version "1.0.0")
(pypi->guix-package "foo"))
- (catch 'quit
- (lambda ()
- (pypi->guix-package "foo" #:version "42"))
- (const #t))))
+ (guard (c ((error? c) #t))
+ (pypi->guix-package "foo" #:version "42"))))
(x
(pk 'fail x #f))))))
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-10 03:08:10 +0000