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-system.sh | 9 | ||||
| -rw-r--r-- | tests/inferior.scm | 34 | ||||
| -rw-r--r-- | tests/networking.scm | 3 | ||||
| -rw-r--r-- | tests/publish.scm | 16 | ||||
| -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 | 49 |
12 files changed, 162 insertions, 31 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-system.sh b/tests/guix-system.sh index f14c92ca75..f5ddd1dda3 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,8 +262,8 @@ 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" make_user_config "group-that-does-not-exist" "users" 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/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.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..9bce446d98 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 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; @@ -182,19 +182,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 +228,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" |