diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/challenge.scm | 2 | ||||
| -rw-r--r-- | tests/crate.scm | 2 | ||||
| -rw-r--r-- | tests/guix-environment.sh | 8 | ||||
| -rw-r--r-- | tests/guix-package.sh | 10 | ||||
| -rw-r--r-- | tests/guix-system.sh | 13 | ||||
| -rw-r--r-- | tests/inferior.scm | 34 | ||||
| -rw-r--r-- | tests/networking.scm | 3 | ||||
| -rw-r--r-- | tests/packages.scm | 36 | ||||
| -rw-r--r-- | tests/profiles.scm | 30 | ||||
| -rw-r--r-- | tests/publish.scm | 16 | ||||
| -rw-r--r-- | tests/store-database.scm | 19 | ||||
| -rw-r--r-- | tests/store.scm | 13 | ||||
| -rw-r--r-- | tests/substitute.scm | 1 | ||||
| -rw-r--r-- | tests/swh.scm | 37 | ||||
| -rw-r--r-- | tests/transformations.scm | 19 | ||||
| -rw-r--r-- | tests/utils.scm | 55 |
16 files changed, 252 insertions, 46 deletions
diff --git a/tests/challenge.scm b/tests/challenge.scm index 9c6d6e0d58..fdd5fd238e 100644 --- a/tests/challenge.scm +++ b/tests/challenge.scm @@ -27,8 +27,8 @@ #:use-module (guix packages) #:use-module (guix gexp) #:use-module (guix base32) + #:use-module (guix narinfo) #:use-module (guix scripts challenge) - #:use-module (guix scripts substitute) #:use-module ((guix build utils) #:select (find-files)) #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-1) diff --git a/tests/crate.scm b/tests/crate.scm index bb7032c344..b6c3a7ee2e 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -148,7 +148,7 @@ \"crate_id\": \"intermediate-b\", \"kind\": \"normal\", \"req\": \"^1.0.0\" - } + }, { \"crate_id\": \"leaf-alice\", \"kind\": \"normal\", diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index f8be48f0c0..afadcbe195 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2015, 2016, 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org> # # This file is part of GNU Guix. # @@ -121,6 +121,12 @@ guix environment --bootstrap -r "$gcroot" --ad-hoc guile-bootstrap \ test `readlink "$gcroot"` = "$expected" rm "$gcroot" +# Try '-r' with a relative file name. +(cd "$tmpdir"; mkdir "gc-root"; + guix environment --bootstrap -r "gc-root/r" --ad-hoc guile-bootstrap \ + -- guile -c 1; + rm "gc-root/r"; rmdir "gc-root") + # Same with an absolute file name. guix environment --bootstrap -r "$PWD/$gcroot" --ad-hoc guile-bootstrap \ -- guile -c 1 diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 3e5fa71d20..7eaad6823f 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 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> # Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> # # This file is part of GNU Guix. @@ -395,6 +395,14 @@ EOF guix package --bootstrap -m "$module_dir/manifest.scm" guix package -I | grep guile test `guix package -I | wc -l` -eq 1 + +# Export a manifest, instantiate it, and make sure we get the same profile. +profile_directory="$(readlink -f "$default_profile")" +guix package --export-manifest > "$tmpfile" +guix package --rollback --bootstrap +guix package --bootstrap -m "$tmpfile" +test "$(readlink -f "$default_profile")" = "$profile_directory" + guix package --rollback --bootstrap # Applying two manifests. diff --git a/tests/guix-system.sh b/tests/guix-system.sh index f14c92ca75..24cc2591d5 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 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> # Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> # Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> # @@ -204,7 +204,8 @@ cat > "$tmpfile" <<EOF (shepherd-service (provision '(buggy!)) (requirement '(does-not-exist)) - (start #t))))) + (start #t))) + (description "Buggy."))) (operating-system $OS_BASE @@ -261,10 +262,14 @@ guix system vm "$tmpfile" -d | grep '\.drv$' drv1="`guix system vm "$tmpfile" -d`" drv2="`guix system vm "$tmpfile" -d`" test "$drv1" = "$drv2" -drv1="`guix system disk-image -t iso9660 "$tmpfile" -d`" -drv2="`guix system disk-image -t iso9660 "$tmpfile" -d`" +drv1="`guix system image -t iso9660 "$tmpfile" -d`" +drv2="`guix system image -t iso9660 "$tmpfile" -d`" test "$drv1" = "$drv2" +# Check whether the graph commands work as expected. +guix system extension-graph "$tmpfile" | grep 'label = "file-systems"' +guix system shepherd-graph "$tmpfile" | grep 'label = "guix-daemon"' + make_user_config "group-that-does-not-exist" "users" if guix system build "$tmpfile" -n 2> "$errorfile" then false diff --git a/tests/inferior.scm b/tests/inferior.scm index 5fddb1fd13..7c3d730d0c 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -75,6 +75,18 @@ (inferior-eval '(throw 'a 'b 'c 'd) inferior) 'badness))) +(test-equal "&inferior-exception, legacy mode" + '(a b c d) + ;; Omit #:command to open an inferior in "legacy" mode, where Guile runs + ;; directly. + (let ((inferior (open-inferior %top-builddir))) + (guard (c ((inferior-exception? c) + (close-inferior inferior) + (and (eq? inferior (inferior-exception-inferior c)) + (inferior-exception-arguments c)))) + (inferior-eval '(throw 'a 'b 'c 'd) inferior) + 'badness))) + (test-equal "inferior-packages" (take (sort (fold-packages (lambda (package lst) (cons (list (package-name package) @@ -213,6 +225,26 @@ "uh uh"))) #f))) +(test-equal "inferior-eval-with-store, exception" + '(the-answer = 42) + (let ((inferior (open-inferior %top-builddir + #:command "scripts/guix"))) + (guard (c ((inferior-exception? c) + (close-inferior inferior) + (inferior-exception-arguments c))) + (inferior-eval-with-store inferior %store + '(lambda (store) + (throw 'the-answer '= 42)))))) + +(test-equal "inferior-eval-with-store, not a procedure" + 'wrong-type-arg + (let ((inferior (open-inferior %top-builddir + #:command "scripts/guix"))) + (guard (c ((inferior-exception? c) + (close-inferior inferior) + (car (inferior-exception-arguments c)))) + (inferior-eval-with-store inferior %store '(+ 1 2))))) + (test-equal "inferior-package-derivation" (map derivation-file-name (list (package-derivation %store %bootstrap-guile "x86_64-linux") diff --git a/tests/networking.scm b/tests/networking.scm index c494a48067..f2421370d2 100644 --- a/tests/networking.scm +++ b/tests/networking.scm @@ -68,8 +68,7 @@ (listen-on '("127.0.0.1" "::1")) (sensor '("udcf0 correction 70000")) (constraint-from '("www.gnu.org")) - (constraints-from '("https://www.google.com/")) - (allow-large-adjustment? #t))) + (constraints-from '("https://www.google.com/")))) (test-assert "openntpd configuration generation sanity check" diff --git a/tests/packages.scm b/tests/packages.scm index b3ccd98e48..ff756c6001 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 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; @@ -45,6 +45,7 @@ #:use-module (guix memoization) #:use-module (guix profiles) #:use-module (guix scripts package) + #:use-module (guix sets) #:use-module (gnu packages) #:use-module (gnu packages base) #:use-module (gnu packages guile) @@ -58,6 +59,7 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-64) + #:use-module (srfi srfi-71) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (ice-9 vlist) @@ -1628,17 +1630,27 @@ result)) '())))))) - (define (find-duplicates l) - (match l - (() '()) - ((head . tail) - (if (member head tail) - (cons head (find-duplicates tail)) - (find-duplicates tail))))) - - (pk (find-duplicates from-cache)) - (and (equal? (delete-duplicates from-cache) from-cache) - (lset= equal? no-cache from-cache)))) + (define (list->set* lst) + ;; Return two values: LST represented as a set and the list of + ;; duplicates in LST. + (let loop ((lst lst) + (duplicates '()) + (seen (set))) + (match lst + (() + (values seen duplicates)) + ((head . tail) + (if (set-contains? seen head) + (loop tail (cons head duplicates) seen) + (loop tail duplicates (set-insert head seen))))))) + + ;; Compare FROM-CACHE and NO-CACHE but avoid 'lset=', which exhibits + ;; exponential behavior. + (let ((set1 duplicates1 (list->set* from-cache)) + (set2 duplicates2 (list->set* no-cache))) + (and (null? duplicates1) (null? duplicates2) + (every (cut set-contains? set1 <>) no-cache) + (every (cut set-contains? set2 <>) from-cache))))) (test-assert "find-packages-by-name" (match (find-packages-by-name "hello") diff --git a/tests/profiles.scm b/tests/profiles.scm index 2dec42bec1..ce77711d63 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 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -154,6 +154,34 @@ (manifest-entries (manifest-add (manifest '()) (list guile-2.0.9 guile-2.0.9)))) +(test-equal "manifest->code, simple" + '(begin + (specifications->manifest (list "guile" "guile:debug" "glibc"))) + (manifest->code (manifest (list guile-2.0.9 guile-2.0.9:debug glibc)))) + +(test-equal "manifest->code, simple, versions" + '(begin + (specifications->manifest (list "guile@2.0.9" "guile@2.0.9:debug" + "glibc@2.19"))) + (manifest->code (manifest (list guile-2.0.9 guile-2.0.9:debug glibc)) + #:entry-package-version manifest-entry-version)) + +(test-equal "manifest->code, transformations" + '(begin + (use-modules (guix transformations)) + + (define transform1 + (options->transformation '((foo . "bar")))) + + (packages->manifest + (list (transform1 (specification->package "guile")) + (specification->package "glibc")))) + (manifest->code (manifest (list (manifest-entry + (inherit guile-2.0.9) + (properties `((transformations + . ((foo . "bar")))))) + glibc)))) + (test-assert "manifest-perform-transaction" (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug))) (t1 (manifest-transaction diff --git a/tests/publish.scm b/tests/publish.scm index cafd0f13a2..52101876b5 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -38,6 +38,7 @@ #:use-module ((guix pki) #:select (%public-key-file %private-key-file)) #:use-module (zlib) #:use-module (lzlib) + #:autoload (zstd) (call-with-zstd-input-port) #:use-module (web uri) #:use-module (web client) #:use-module (web response) @@ -54,6 +55,9 @@ (define %store (open-connection-for-tests)) +(define (zstd-supported?) + (resolve-module '(zstd) #t #f #:ensure #f)) + (define %reference (add-text-to-store %store "ref" "foo")) (define %item (add-text-to-store %store "item" "bar" (list %reference))) @@ -237,6 +241,18 @@ References: ~%" (cut restore-file <> temp))) (call-with-input-file temp read-string)))) +(unless (zstd-supported?) (test-skip 1)) +(test-equal "/nar/zstd/*" + "bar" + (call-with-temporary-output-file + (lambda (temp port) + (let ((nar (http-get-port + (publish-uri + (string-append "/nar/zstd/" (basename %item)))))) + (call-with-zstd-input-port nar + (cut restore-file <> temp))) + (call-with-input-file temp read-string)))) + (test-equal "/*.narinfo with compression" `(("StorePath" . ,%item) ("URL" . ,(string-append "nar/gzip/" (basename %item))) diff --git a/tests/store-database.scm b/tests/store-database.scm index 17eea38c63..d8f3ce8070 100644 --- a/tests/store-database.scm +++ b/tests/store-database.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2018, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -123,4 +123,21 @@ (pk 'welcome-exception! args) #t))))) +(test-equal "sqlite-register with incorrect size" + 'out-of-range + (call-with-temporary-output-file + (lambda (db-file port) + (delete-file db-file) + (catch #t + (lambda () + (with-database db-file db + (sqlite-register db #:path "/gnu/foo" + #:references '("/gnu/bar") + #:deriver "/gnu/foo.drv" + #:hash (string-append "sha256:" (make-string 64 #\e)) + #:nar-size -1234)) + #f) + (lambda (key . _) + key))))) + (test-end "store-database") diff --git a/tests/store.scm b/tests/store.scm index c9a08ac690..cda0e0302f 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -201,6 +201,17 @@ ;; (valid-path? %store p1) ;; (member (pk p2) (live-paths %store))))) +(test-assert "add-indirect-root and find-roots" + (call-with-temporary-directory + (lambda (directory) + (let* ((item (add-text-to-store %store "something" (random-text))) + (root (string-append directory "/gc-root"))) + (symlink item root) + (add-indirect-root %store root) + (let ((result (member (cons root item) (find-roots %store)))) + (delete-file root) + result))))) + (test-assert "permanent root" (let* ((p (with-store store (let ((p (add-text-to-store store "random-text" diff --git a/tests/substitute.scm b/tests/substitute.scm index 542aaf603f..697abc4684 100644 --- a/tests/substitute.scm +++ b/tests/substitute.scm @@ -19,6 +19,7 @@ (define-module (test-substitute) #:use-module (guix scripts substitute) + #:use-module (guix narinfo) #:use-module (guix base64) #:use-module (gcrypt hash) #:use-module (guix serialization) diff --git a/tests/swh.scm b/tests/swh.scm index 06984b2a80..a36f951241 100644 --- a/tests/swh.scm +++ b/tests/swh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,15 +20,32 @@ #:use-module (guix swh) #:use-module (guix tests http) #:use-module (web response) - #:use-module (srfi srfi-64)) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) ;; Test the JSON mapping machinery used in (guix swh). (define %origin - "{ \"visits_url\": \"/visits/42\", + "{ \"origin_visits_url\": \"/visits/42\", \"type\": \"git\", \"url\": \"http://example.org/guix.git\" }") +(define %visits + ;; A single visit where 'snapshot_url' is null. + ;; See <https://bugs.gnu.org/45615>. + "[ { + \"origin\": \"https://github.com/Genivia/ugrep\", + \"visit\": 1, + \"date\": \"2020-05-17T21:43:45.422977+00:00\", + \"status\": \"ongoing\", + \"snapshot\": null, + \"metadata\": {}, + \"type\": \"git\", + \"origin_visit_url\": \"https://archive.softwareheritage.org/api/1/origin/https://github.com/Genivia/ugrep/visit/1/\", + \"snapshot_url\": null + } ]") + (define %directory-entries "[ { \"name\": \"one\", \"type\": \"regular\", @@ -59,6 +76,20 @@ (parameterize ((%swh-base-url (%local-url))) (lookup-origin "http://example.org/whatever")))) +(test-equal "origin-visit, no snapshots" + '("https://github.com/Genivia/ugrep" + "2020-05-17T21:43:45Z" + #f) ;see <https://bugs.gnu.org/45615> + (with-http-server `((200 ,%origin) + (200 ,%visits)) + (parameterize ((%swh-base-url (%local-url))) + (let ((origin (lookup-origin "http://example.org/whatever"))) + (match (origin-visits origin) + ((visit) + (list (visit-origin visit) + (date->string (visit-date visit) "~4") + (visit-snapshot-url visit)))))))) + (test-equal "lookup-directory" '(("one" 123) ("two" 456)) (with-json-result %directory-entries diff --git a/tests/transformations.scm b/tests/transformations.scm index 9053deba41..7877029486 100644 --- a/tests/transformations.scm +++ b/tests/transformations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,6 +30,7 @@ #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix git) + #:use-module (guix upstream) #:use-module (gnu packages) #:use-module (gnu packages base) #:use-module (gnu packages busybox) @@ -396,6 +397,22 @@ (map local-file-file (origin-patches (package-source dep))))))))) +(test-equal "options->transformation, with-latest" + "42.0" + (mock ((guix upstream) %updaters + (delay (list (upstream-updater + (name 'dummy) + (pred (const #t)) + (description "") + (latest (const (upstream-source + (package "foo") + (version "42.0") + (urls '("http://example.org"))))))))) + (let* ((p (dummy-package "foo" (version "1.0"))) + (t (options->transformation + `((with-latest . "foo"))))) + (package-version (t p))))) + (test-end) ;;; Local Variables: diff --git a/tests/utils.scm b/tests/utils.scm index 009e2121ab..62ec7e8b4c 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; @@ -78,6 +78,12 @@ (not (version-prefix? "4.1" "4.16.2")) (not (version-prefix? "4.1" "4")))) +(test-equal "version-unique-prefix" + '("2" "2.2" "") + (list (version-unique-prefix "2.0" '("3.0" "2.0")) + (version-unique-prefix "2.2" '("3.0.5" "2.0.9" "2.2.7")) + (version-unique-prefix "27.1" '("27.1")))) + (test-equal "string-tokenize*" '(("foo") ("foo" "bar" "baz") @@ -182,19 +188,34 @@ skip these tests." method) (let ((data (call-with-input-file (search-path %load-path "guix.scm") get-bytevector-all))) - (let*-values (((compressed pids1) - (compressed-port method (open-bytevector-input-port data))) - ((decompressed pids2) - (decompressed-port method compressed))) - (and (every (compose zero? cdr waitpid) - (pk 'pids method (append pids1 pids2))) - (let ((result (get-bytevector-all decompressed))) - (pk 'len method - (if (bytevector? result) - (bytevector-length result) - result) - (bytevector-length data)) - (equal? result data)))))) + (call-with-temporary-output-file + (lambda (output port) + (close-port port) + (let*-values (((compressed pids) + ;; Note: 'compressed-output-port' only supports file + ;; ports. + (compressed-output-port method + (open-file output "w0")))) + (put-bytevector compressed data) + (close-port compressed) + (and (every (compose zero? cdr waitpid) + (pk 'pids method pids)) + (let*-values (((decompressed pids) + (decompressed-port method + (open-bytevector-input-port + (call-with-input-file output + get-bytevector-all)))) + ((result) + (get-bytevector-all decompressed))) + (close-port decompressed) + (pk 'len method + (if (bytevector? result) + (bytevector-length result) + result) + (bytevector-length data)) + (and (every (compose zero? cdr waitpid) + (pk 'pids method pids)) + (equal? result data))))))))) (false-if-exception (delete-file temp-file)) (unless (run?) (test-skip 1)) @@ -213,8 +234,10 @@ skip these tests." get-bytevector-all))))) (for-each test-compression/decompression - '(gzip xz lzip) - (list (const #t) (const #t) (const #t))) + `(gzip xz lzip zstd) + (list (const #t) (const #t) (const #t) + (lambda () + (resolve-module '(zstd) #t #f #:ensure #f)))) ;; This is actually in (guix store). (test-equal "store-path-package-name" |