diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/accounts.scm | 19 | ||||
| -rw-r--r-- | tests/build-utils.scm | 104 | ||||
| -rw-r--r-- | tests/builders.scm | 40 | ||||
| -rw-r--r-- | tests/channels.scm | 104 | ||||
| -rw-r--r-- | tests/containers.scm | 27 | ||||
| -rw-r--r-- | tests/crate.scm | 13 | ||||
| -rw-r--r-- | tests/derivations.scm | 45 | ||||
| -rw-r--r-- | tests/gexp.scm | 7 | ||||
| -rw-r--r-- | tests/git.scm | 99 | ||||
| -rw-r--r-- | tests/grafts.scm | 1 | ||||
| -rw-r--r-- | tests/graph.scm | 4 | ||||
| -rw-r--r-- | tests/guix-build-branch.sh | 2 | ||||
| -rw-r--r-- | tests/guix-daemon.sh | 4 | ||||
| -rw-r--r-- | tests/guix-environment-container.sh | 12 | ||||
| -rw-r--r-- | tests/guix-environment.sh | 35 | ||||
| -rw-r--r-- | tests/guix-pack-relocatable.sh | 6 | ||||
| -rw-r--r-- | tests/guix-package-aliases.sh | 7 | ||||
| -rw-r--r-- | tests/guix-package-net.sh | 2 | ||||
| -rw-r--r-- | tests/guix-package.sh | 17 | ||||
| -rw-r--r-- | tests/inferior.scm | 13 | ||||
| -rw-r--r-- | tests/lint.scm | 191 | ||||
| -rw-r--r-- | tests/networking.scm | 113 | ||||
| -rw-r--r-- | tests/opam.scm | 2 | ||||
| -rw-r--r-- | tests/pack.scm | 1 | ||||
| -rw-r--r-- | tests/packages.scm | 57 | ||||
| -rw-r--r-- | tests/profiles.scm | 7 | ||||
| -rw-r--r-- | tests/search-paths.scm | 8 | ||||
| -rw-r--r-- | tests/swh.scm | 41 | ||||
| -rw-r--r-- | tests/syscalls.scm | 13 | ||||
| -rw-r--r-- | tests/ui.scm | 5 | ||||
| -rw-r--r-- | tests/union.scm | 8 |
31 files changed, 855 insertions, 152 deletions
diff --git a/tests/accounts.scm b/tests/accounts.scm index 673dd42432..78136390bb 100644 --- a/tests/accounts.scm +++ b/tests/accounts.scm @@ -62,6 +62,25 @@ nobody:!:0::::::\n")) (shell "/bin/sh"))) port)))) +(test-equal "write-passwd with duplicate entry" + %passwd-sample + (call-with-output-string + (lambda (port) + (let ((charlie (password-entry + (name "charlie") + (uid 1000) (gid 998) + (real-name "Charlie") + (directory "/home/charlie") + (shell "/bin/sh")))) + (write-passwd (list (password-entry + (name "root") + (uid 0) (gid 0) + (real-name "Admin") + (directory "/root") + (shell "/bin/sh")) + charlie charlie) + port))))) + (test-equal "read-passwd + write-passwd" %passwd-sample (call-with-output-string diff --git a/tests/build-utils.scm b/tests/build-utils.scm index 46fe8ea2c0..61e6c44e63 100644 --- a/tests/build-utils.scm +++ b/tests/build-utils.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,8 +21,6 @@ (define-module (test-build-utils) #:use-module (guix tests) #:use-module (guix build utils) - #:use-module ((gnu build bootloader) - #:select (invoke/quiet)) #:use-module ((guix utils) #:select (%current-system call-with-temporary-directory)) #:use-module (gnu packages) @@ -144,4 +143,105 @@ (invoke/quiet "sh" "-c" "echo This is another error. >&2 ; false") #f)) +(let ((script-contents "\ +#!/anything/cabbage-bash-1.2.3/bin/sh + +echo hello world")) + + (test-equal "wrap-script, simple case" + (string-append + (format #f "\ +#!GUILE --no-auto-compile +#!#; Guix wrapper +#\\-~s +#\\-~s +" + '(begin (let ((current (getenv "GUIX_FOO"))) + (setenv "GUIX_FOO" + (if current + (string-append "/some/path:/some/other/path" + ":" current) + "/some/path:/some/other/path")))) + '(let ((cl (command-line))) + (apply execl "/anything/cabbage-bash-1.2.3/bin/sh" + (car cl) + (cons (car cl) + (append '("") cl))))) + script-contents) + (call-with-temporary-directory + (lambda (directory) + (let ((script-file-name (string-append directory "/foo"))) + (call-with-output-file script-file-name + (lambda (port) + (format port script-contents))) + (chmod script-file-name #o777) + + (mock ((guix build utils) which (const "GUILE")) + (wrap-script script-file-name + `("GUIX_FOO" prefix ("/some/path" + "/some/other/path")))) + (let ((str (call-with-input-file script-file-name get-string-all))) + (with-directory-excursion directory + (delete-file "foo")) + str)))))) + +(let ((script-contents "\ +#!/anything/cabbage-bash-1.2.3/bin/python3 -and -args +# vim:fileencoding=utf-8 +print('hello world')")) + + (test-equal "wrap-script, with encoding declaration" + (string-append + (format #f "\ +#!MYGUILE --no-auto-compile +#!#; # vim:fileencoding=utf-8 +#\\-~s +#\\-~s +" + '(begin (let ((current (getenv "GUIX_FOO"))) + (setenv "GUIX_FOO" + (if current + (string-append "/some/path:/some/other/path" + ":" current) + "/some/path:/some/other/path")))) + `(let ((cl (command-line))) + (apply execl "/anything/cabbage-bash-1.2.3/bin/python3" + (car cl) + (cons (car cl) + (append '("" "-and" "-args") cl))))) + script-contents) + (call-with-temporary-directory + (lambda (directory) + (let ((script-file-name (string-append directory "/foo"))) + (call-with-output-file script-file-name + (lambda (port) + (format port script-contents))) + (chmod script-file-name #o777) + + (wrap-script script-file-name + #:guile "MYGUILE" + `("GUIX_FOO" prefix ("/some/path" + "/some/other/path"))) + (let ((str (call-with-input-file script-file-name get-string-all))) + (with-directory-excursion directory + (delete-file "foo")) + str)))))) + +(test-assert "wrap-script, raises condition" + (call-with-temporary-directory + (lambda (directory) + (let ((script-file-name (string-append directory "/foo"))) + (call-with-output-file script-file-name + (lambda (port) + (format port "This is not a script"))) + (chmod script-file-name #o777) + (catch 'srfi-34 + (lambda () + (wrap-script script-file-name + #:guile "MYGUILE" + `("GUIX_FOO" prefix ("/some/path" + "/some/other/path")))) + (lambda (type obj) + (wrap-error? obj))))))) + (test-end) diff --git a/tests/builders.scm b/tests/builders.scm index 8b8ef013e7..fdcf38ded3 100644 --- a/tests/builders.scm +++ b/tests/builders.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,7 +28,8 @@ #:use-module (gcrypt hash) #:use-module (guix tests) #:use-module ((guix packages) - #:select (package-derivation package-native-search-paths)) + #:select (package? + package-derivation package-native-search-paths)) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -39,23 +40,6 @@ (define %store (open-connection-for-tests)) -(define %bootstrap-inputs - ;; Use the bootstrap inputs so it doesn't take ages to run these tests. - ;; This still involves building Make, Diffutils, and Findutils. - ;; XXX: We're relying on the higher-level `package-derivations' here. - (and %store - (map (match-lambda - ((name package) - (list name (package-derivation %store package)))) - (@@ (gnu packages commencement) %boot0-inputs)))) - -(define %bootstrap-search-paths - ;; Search path specifications that go with %BOOTSTRAP-INPUTS. - (append-map (match-lambda - ((name package _ ...) - (package-native-search-paths package))) - (@@ (gnu packages commencement) %boot0-inputs))) - (define url-fetch* (store-lower url-fetch)) @@ -94,22 +78,4 @@ (test-assert "gnu-build-system" (build-system? gnu-build-system)) -(when (or (not (network-reachable?)) (shebang-too-long?)) - (test-skip 1)) -(test-assert "gnu-build" - (let* ((url "http://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz") - (hash (nix-base32-string->bytevector - "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6")) - (tarball (url-fetch* %store url 'sha256 hash - #:guile %bootstrap-guile)) - (build (gnu-build %store "hello-2.8" - `(("source" ,tarball) - ,@%bootstrap-inputs) - #:guile %bootstrap-guile - #:search-paths %bootstrap-search-paths)) - (out (derivation->output-path build))) - (and (build-derivations %store (list (pk 'hello-drv build))) - (valid-path? %store out) - (file-exists? (string-append out "/bin/hello"))))) - (test-end "builders") diff --git a/tests/channels.scm b/tests/channels.scm index e83b5437d3..f5a7955483 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -28,6 +28,10 @@ #:use-module (guix gexp) #:use-module ((guix utils) #:select (error-location? error-location location-line)) + #:use-module ((guix build utils) #:select (which)) + #:use-module (git) + #:use-module (guix git) + #:use-module (guix tests git) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -246,4 +250,104 @@ (depends? drv3 (list drv2 drv0) (list)))))))) +(unless (which (git-command)) (test-skip 1)) +(test-equal "channel-news, no news" + '() + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "the commit")) + (with-repository directory repository + (let ((channel (channel (url (string-append "file://" directory)) + (name 'foo))) + (latest (reference-name->oid repository "HEAD"))) + (channel-news-for-commit channel (oid->string latest)))))) + +(unless (which (git-command)) (test-skip 1)) +(test-assert "channel-news, one entry" + (with-temporary-git-repository directory + `((add ".guix-channel" + ,(object->string + '(channel (version 0) + (news-file "news.scm")))) + (commit "first commit") + (add "src/a.txt" "A") + (commit "second commit") + (tag "tag-for-first-news-entry") + (add "news.scm" + ,(lambda (repository) + (let ((previous + (reference-name->oid repository "HEAD"))) + (object->string + `(channel-news + (version 0) + (entry (commit ,(oid->string previous)) + (title (en "New file!") + (eo "Nova dosiero!")) + (body (en "Yeah, a.txt.")))))))) + (commit "third commit") + (add "src/b.txt" "B") + (commit "fourth commit") + (add "news.scm" + ,(lambda (repository) + (let ((second + (commit-id + (find-commit repository "second commit"))) + (previous + (reference-name->oid repository "HEAD"))) + (object->string + `(channel-news + (version 0) + (entry (commit ,(oid->string previous)) + (title (en "Another file!")) + (body (en "Yeah, b.txt."))) + (entry (tag "tag-for-first-news-entry") + (title (en "Old news.") + (eo "Malnovaĵoj.")) + (body (en "For a.txt")))))))) + (commit "fifth commit")) + (with-repository directory repository + (define (find-commit* message) + (oid->string (commit-id (find-commit repository message)))) + + (let ((channel (channel (url (string-append "file://" directory)) + (name 'foo))) + (commit1 (find-commit* "first commit")) + (commit2 (find-commit* "second commit")) + (commit3 (find-commit* "third commit")) + (commit4 (find-commit* "fourth commit")) + (commit5 (find-commit* "fifth commit"))) + ;; First try fetching all the news up to a given commit. + (and (null? (channel-news-for-commit channel commit2)) + (lset= string=? + (map channel-news-entry-commit + (channel-news-for-commit channel commit5)) + (list commit2 commit4)) + (lset= equal? + (map channel-news-entry-title + (channel-news-for-commit channel commit5)) + '((("en" . "Another file!")) + (("en" . "Old news.") ("eo" . "Malnovaĵoj.")))) + (lset= string=? + (map channel-news-entry-commit + (channel-news-for-commit channel commit3)) + (list commit2)) + + ;; Now fetch news entries that apply to a commit range. + (lset= string=? + (map channel-news-entry-commit + (channel-news-for-commit channel commit3 commit1)) + (list commit2)) + (lset= string=? + (map channel-news-entry-commit + (channel-news-for-commit channel commit5 commit3)) + (list commit4)) + (lset= string=? + (map channel-news-entry-commit + (channel-news-for-commit channel commit5 commit1)) + (list commit4 commit2)) + (lset= equal? + (map channel-news-entry-tag + (channel-news-for-commit channel commit5 commit1)) + '(#f "tag-for-first-news-entry"))))))) + (test-end "channels") diff --git a/tests/containers.scm b/tests/containers.scm index c6c738f234..01fbcbb45a 100644 --- a/tests/containers.scm +++ b/tests/containers.scm @@ -269,4 +269,31 @@ (lset= string=? (cons* "." ".." (map basename reqs)) (pk (call-with-input-file result read)))))))))) +(test-assert "eval/container, non-empty load path" + (call-with-temporary-directory + (lambda (directory) + (define store + (open-connection-for-tests)) + (define result + (string-append directory "/r")) + (define requisites* + (store-lift requisites)) + + (mkdir result) + (run-with-store store + (mlet %store-monad ((status (eval/container + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p "/result/a/b/c"))) + #:mappings + (list (file-system-mapping + (source result) + (target "/result") + (writable? #t)))))) + (close-connection store) + (return (and (zero? status) + (file-is-directory? + (string-append result "/a/b/c"))))))))) + (test-end) diff --git a/tests/crate.scm b/tests/crate.scm index 72c3a13350..c14862ad9f 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2016 David Craven <david@craven.ch> +;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,10 +33,20 @@ \"crate\": { \"max_version\": \"1.0.0\", \"name\": \"foo\", - \"license\": \"MIT/Apache-2.0\", \"description\": \"summary\", \"homepage\": \"http://example.com\", \"repository\": \"http://example.com\", + \"keywords\": [\"dummy\" \"test\"], + \"categories\": [\"test\"] + \"actual_versions\": [ + { \"id\": \"foo\", + \"num\": \"1.0.0\", + \"license\": \"MIT OR Apache-2.0\", + \"links\": { + \"dependencies\": \"/api/v1/crates/foo/1.0.0/dependencies\" + } + } + ] } }") diff --git a/tests/derivations.scm b/tests/derivations.scm index 368012d2b2..6a7fad85b5 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -29,7 +29,6 @@ #:use-module (guix tests http) #:use-module ((guix packages) #:select (package-derivation base32)) #:use-module ((guix build utils) #:select (executable-file?)) - #:use-module ((gnu packages) #:select (search-bootstrap-binary)) #:use-module (gnu packages bootstrap) #:use-module ((gnu packages guile) #:select (guile-1.8)) #:use-module (srfi srfi-1) @@ -210,7 +209,7 @@ (test-skip 1)) (test-assert "'download' built-in builder" (let ((text (random-text))) - (with-http-server 200 text + (with-http-server `((200 ,text)) (let* ((drv (derivation %store "world" "builtin:download" '() #:env-vars `(("url" @@ -225,7 +224,7 @@ (unless (http-server-can-listen?) (test-skip 1)) (test-assert "'download' built-in builder, invalid hash" - (with-http-server 200 "hello, world!" + (with-http-server `((200 "hello, world!")) (let* ((drv (derivation %store "world" "builtin:download" '() #:env-vars `(("url" @@ -240,7 +239,7 @@ (unless (http-server-can-listen?) (test-skip 1)) (test-assert "'download' built-in builder, not found" - (with-http-server 404 "not found" + (with-http-server '((404 "not found")) (let* ((drv (derivation %store "will-never-be-found" "builtin:download" '() #:env-vars `(("url" @@ -275,9 +274,9 @@ . ,(object->string (%local-url)))) #:hash-algo 'sha256 #:hash (sha256 (string->utf8 text))))) - (and (with-http-server 200 text + (and (with-http-server `((200 ,text)) (build-derivations %store (list drv))) - (with-http-server 200 text + (with-http-server `((200 ,text)) (build-derivations %store (list drv) (build-mode check))) (string=? (call-with-input-file (derivation->output-path drv) @@ -410,6 +409,38 @@ (equal? (derivation->output-path final1) (derivation->output-path final2))))) +(test-assert "derivation with duplicate fixed-output inputs" + ;; Here we create a derivation that has two inputs, both of which are + ;; fixed-output leading to the same result. This test ensures the hash of + ;; that derivation is correctly computed, namely that duplicate inputs are + ;; coalesced. See <https://bugs.gnu.org/36777>. + (let* ((builder1 (add-text-to-store %store "fixed-builder1.sh" + "echo -n hello > $out" '())) + (builder2 (add-text-to-store %store "fixed-builder2.sh" + "echo hey; echo -n hello > $out" '())) + (hash (sha256 (string->utf8 "hello"))) + (fixed1 (derivation %store "fixed" + %bash `(,builder1) + #:hash hash #:hash-algo 'sha256)) + (fixed2 (derivation %store "fixed" + %bash `(,builder2) + #:hash hash #:hash-algo 'sha256)) + (builder3 (add-text-to-store %store "builder.sh" + "echo fake builder")) + (final (derivation %store "final" + %bash `(,builder3) + #:sources (list %bash builder3) + #:inputs (list (derivation-input fixed1) + (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)))))))) + (test-assert "multiple-output derivation" (let* ((builder (add-text-to-store %store "my-fixed-builder.sh" "echo one > $out ; echo two > $second" @@ -1232,5 +1263,5 @@ (test-end) ;; Local Variables: -;; eval: (put 'with-http-server 'scheme-indent-function 2) +;; eval: (put 'with-http-server 'scheme-indent-function 1) ;; End: diff --git a/tests/gexp.scm b/tests/gexp.scm index 5c013d838d..50d0948659 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -871,6 +871,13 @@ (eq? (derivation-input-derivation (lowered-gexp-guile lexp)) (%guile-for-build))))))) +(test-eq "lower-gexp, non-self-quoting input" + + + (guard (c ((gexp-input-error? c) + (gexp-error-invalid-input c))) + (run-with-store %store + (lower-gexp #~(foo #$+))))) + (test-assertm "gexp->derivation #:references-graphs" (mlet* %store-monad ((one (text-file "one" (random-text))) diff --git a/tests/git.scm b/tests/git.scm new file mode 100644 index 0000000000..8ba10ece51 --- /dev/null +++ b/tests/git.scm @@ -0,0 +1,99 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 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-git) + #:use-module (git) + #:use-module (guix git) + #:use-module (guix tests git) + #:use-module (guix build utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64)) + +;; Test the (guix git) tools. + +(test-begin "git") + +;; 'with-temporary-git-repository' relies on the 'git' command. +(unless (which (git-command)) (test-skip 1)) +(test-assert "commit-difference, linear history" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "first commit") + (add "b.txt" "B") + (commit "second commit") + (add "c.txt" "C") + (commit "third commit") + (add "d.txt" "D") + (commit "fourth commit")) + (with-repository directory repository + (let ((commit1 (find-commit repository "first")) + (commit2 (find-commit repository "second")) + (commit3 (find-commit repository "third")) + (commit4 (find-commit repository "fourth"))) + (and (lset= eq? (commit-difference commit4 commit1) + (list commit2 commit3 commit4)) + (lset= eq? (commit-difference commit4 commit2) + (list commit3 commit4)) + (equal? (commit-difference commit3 commit2) + (list commit3)) + + ;; COMMIT4 is not an ancestor of COMMIT1 so we should get the + ;; empty list. + (null? (commit-difference commit1 commit4))))))) + +(unless (which (git-command)) (test-skip 1)) +(test-assert "commit-difference, fork" + (with-temporary-git-repository directory + '((add "a.txt" "A") + (commit "first commit") + (branch "devel") + (checkout "devel") + (add "devel/1.txt" "1") + (commit "first devel commit") + (add "devel/2.txt" "2") + (commit "second devel commit") + (checkout "master") + (add "b.txt" "B") + (commit "second commit") + (add "c.txt" "C") + (commit "third commit") + (merge "devel" "merge") + (add "d.txt" "D") + (commit "fourth commit")) + (with-repository directory repository + (let ((master1 (find-commit repository "first commit")) + (master2 (find-commit repository "second commit")) + (master3 (find-commit repository "third commit")) + (master4 (find-commit repository "fourth commit")) + (devel1 (find-commit repository "first devel")) + (devel2 (find-commit repository "second devel")) + (merge (find-commit repository "merge"))) + (and (equal? (commit-difference master4 merge) + (list master4)) + (lset= eq? (commit-difference master3 master1) + (list master3 master2)) + (lset= eq? (commit-difference devel2 master1) + (list devel2 devel1)) + + ;; The merge occurred between MASTER2 and MASTER4 so here we + ;; expect to see all the commits from the "devel" branch in + ;; addition to those on "master". + (lset= eq? (commit-difference master4 master2) + (list master4 merge master3 devel1 devel2))))))) + +(test-end "git") diff --git a/tests/grafts.scm b/tests/grafts.scm index 6fd3d5e171..a12c6a5911 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -24,7 +24,6 @@ #:use-module (guix utils) #:use-module (guix grafts) #:use-module (guix tests) - #:use-module ((gnu packages) #:select (search-bootstrap-binary)) #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) diff --git a/tests/graph.scm b/tests/graph.scm index c4c5096226..b7732ec709 100644 --- a/tests/graph.scm +++ b/tests/graph.scm @@ -153,9 +153,9 @@ edges." (match nodes (((labels names) ...) names)))) - (match %bootstrap-inputs + (match (%bootstrap-inputs) (((labels packages) ...) - (map package-full-name packages)))))))) + (map package-full-name (filter package? packages))))))))) (test-assert "bag DAG, including origins" (let-values (((backend nodes+edges) (make-recording-backend))) diff --git a/tests/guix-build-branch.sh b/tests/guix-build-branch.sh index 3d2a7dddf5..2556a0cdb9 100644 --- a/tests/guix-build-branch.sh +++ b/tests/guix-build-branch.sh @@ -53,7 +53,7 @@ test "$v0_1_0_drv" != "$latest_drv" test "$v0_1_0_drv" != "$orig_drv" v0_1_0_drv="`guix build guix --with-commit=guile-gcrypt=v0.1.0 -d`" -guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-git.v0.1.0 +guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-0.1.0 guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-9e3eacd test "$v0_1_0_drv" != "$latest_drv" test "$v0_1_0_drv" != "$orig_drv" diff --git a/tests/guix-daemon.sh b/tests/guix-daemon.sh index 78f82eafe2..758f18cc36 100644 --- a/tests/guix-daemon.sh +++ b/tests/guix-daemon.sh @@ -141,7 +141,7 @@ daemon_pid=$! GUIX_DAEMON_SOCKET="$socket" \ guile -c ' - (use-modules (guix) (gnu packages) (guix tests)) + (use-modules (guix) (guix tests)) (with-store store (let* ((build (add-text-to-store store "build.sh" @@ -165,7 +165,7 @@ kill "$daemon_pid" # honored. client_code=' - (use-modules (guix) (gnu packages) (guix tests) (srfi srfi-34)) + (use-modules (guix) (guix tests) (srfi srfi-34)) (with-store store (let* ((build (add-text-to-store store "build.sh" diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh index 78507f76c0..d313f2e734 100644 --- a/tests/guix-environment-container.sh +++ b/tests/guix-environment-container.sh @@ -44,6 +44,11 @@ else test $? = 42 fi +# Make sure '--preserve' is honored. +result="`FOOBAR=42; export FOOBAR; guix environment -C --ad-hoc --bootstrap \ + guile-bootstrap -E ^FOO -- guile -c '(display (getenv \"FOOBAR\"))'`" +test "$result" = "42" + # By default, the UID inside the container should be the same as outside. uid="`id -u`" inner_uid="`guix environment -C --ad-hoc --bootstrap guile-bootstrap \ @@ -144,6 +149,13 @@ HOME="$tmpdir" guix environment --bootstrap --container --user=foognu \ --share="$tmpdir/umock" \ -- guile -c "$usertest" +# if not sharing CWD, chdir home +( + cd "$tmpdir" \ + && guix environment --bootstrap --container --no-cwd --user=foo \ + --ad-hoc guile-bootstrap --pure \ + -- /bin/sh -c 'test $(pwd) == "/home/foo" -a ! -d '"$tmpdir" +) # Check the exit code. diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index 5a5a69d58c..fb1c1a022d 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -84,14 +84,6 @@ echo "(use-modules (guix profiles) (gnu packages bootstrap)) guix environment --bootstrap --manifest=$tmpdir/manifest.scm --pure \ -- "$SHELL" -c 'test -f "$GUIX_ENVIRONMENT/bin/guile"' -# if not sharing CWD, chdir home -( - cd "$tmpdir" \ - && guix environment --bootstrap --container --no-cwd --user=foo \ - --ad-hoc guile-bootstrap --pure \ - -- /bin/sh -c 'test $(pwd) == "/home/foo" -a ! -d '"$tmpdir" -) - # Make sure '-r' works as expected. rm -f "$gcroot" expected="`guix environment --bootstrap --ad-hoc guile-bootstrap \ @@ -164,7 +156,7 @@ if guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null then # Compute the build environment for the initial GNU Make. guix environment --bootstrap --no-substitutes --search-paths --pure \ - -e '(@@ (gnu packages commencement) gnu-make-boot0)' > "$tmpdir/a" + -e '(@ (guix tests) gnu-make-for-tests)' > "$tmpdir/a" # Make sure bootstrap binaries are in the profile. profile=`grep "^export PATH" "$tmpdir/a" | sed -r 's|^.*="(.*)/bin"|\1|'` @@ -185,30 +177,15 @@ then # Make sure that the shell spawned with '--exec' sees the same environment # as returned by '--search-paths'. guix environment --bootstrap --no-substitutes --pure \ - -e '(@@ (gnu packages commencement) gnu-make-boot0)' \ + -e '(@ (guix tests) gnu-make-for-tests)' \ -- /bin/sh -c 'echo $PATH $CPATH $LIBRARY_PATH' > "$tmpdir/b" ( . "$tmpdir/a" ; echo $PATH $CPATH $LIBRARY_PATH ) > "$tmpdir/c" cmp "$tmpdir/b" "$tmpdir/c" rm "$tmpdir"/* - # Compute the build environment for the initial GNU Findutils. - guix environment --bootstrap --no-substitutes --search-paths --pure \ - -e '(@@ (gnu packages commencement) findutils-boot0)' > "$tmpdir/a" - profile=`grep "^export PATH" "$tmpdir/a" | sed -r 's|^.*="(.*)/bin"|\1|'` - - # Make sure the bootstrap binaries are all listed where they belong. - grep -E "^export PATH=\"$profile/bin\"" "$tmpdir/a" - grep -E "^export CPATH=\"$profile/include\"" "$tmpdir/a" - grep -E "^export LIBRARY_PATH=\"$profile/lib\"" "$tmpdir/a" - for dep in bootstrap-binaries-0 gcc-bootstrap-0 glibc-bootstrap-0 \ - make-boot0 - do - guix gc --references "$profile" | grep "$dep" - done - # The following test assumes 'make-boot0' has a "debug" output. - make_boot0_debug="`guix build -e '(@@ (gnu packages commencement) gnu-make-boot0)' | grep -e -debug`" + make_boot0_debug="`guix build -e '(@ (guix tests) gnu-make-for-tests)' | grep -e -debug`" test "x$make_boot0_debug" != "x" # Make sure the "debug" output is not listed. @@ -218,7 +195,7 @@ then # Compute the build environment for the initial GNU Make, but add in the # bootstrap Guile as an ad-hoc addition. guix environment --bootstrap --no-substitutes --search-paths --pure \ - -e '(@@ (gnu packages commencement) gnu-make-boot0)' \ + -e '(@ (guix tests) gnu-make-for-tests)' \ --ad-hoc guile-bootstrap > "$tmpdir/a" profile=`grep "^export PATH" "$tmpdir/a" | sed -r 's|^.*="(.*)/bin"|\1|'` @@ -235,14 +212,14 @@ then # Make sure a package list with plain package objects and package+output # tuples can be used with -e. expr_list_test_code=" -(list (@@ (gnu packages commencement) gnu-make-boot0) +(list (@ (guix tests) gnu-make-for-tests) (list (@ (gnu packages bootstrap) %bootstrap-guile) \"out\"))" guix environment --bootstrap --ad-hoc --no-substitutes --search-paths \ --pure -e "$expr_list_test_code" > "$tmpdir/a" profile=`grep "^export PATH" "$tmpdir/a" | sed -r 's|^.*="(.*)/bin"|\1|'` - for dep in make-boot0 guile-bootstrap + for dep in make-test-boot0 guile-bootstrap do guix gc --references "$profile" | grep "$dep" done diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh index ebada62c01..e93610eedc 100644 --- a/tests/guix-pack-relocatable.sh +++ b/tests/guix-pack-relocatable.sh @@ -78,3 +78,9 @@ else "$test_directory/Bin/sed" --version > "$test_directory/output" fi grep 'GNU sed' "$test_directory/output" +chmod -Rf +w "$test_directory"; rm -rf "$test_directory"/* + +# Ensure '-R' works with outputs other than "out". +tarball="`guix pack -R -S /share=share groff:doc`" +(cd "$test_directory"; tar xvf "$tarball") +test -d "$test_directory/share/doc/groff/html" diff --git a/tests/guix-package-aliases.sh b/tests/guix-package-aliases.sh index 5c68664093..4beed2e5b7 100644 --- a/tests/guix-package-aliases.sh +++ b/tests/guix-package-aliases.sh @@ -58,3 +58,10 @@ if guix remove -i guile-bootstrap -p "$profile" --bootstrap then false; else true; fi guix search '\<board\>' game | grep '^name: gnubg' + +guix show --version +guix show guile +guix show python@3 | grep "^name: python" + +# "python@2" exists but is deprecated; make sure it doesn't show up. +if guix show python@2; then false; else true; fi diff --git a/tests/guix-package-net.sh b/tests/guix-package-net.sh index 82c346dd4c..48a94865e1 100644 --- a/tests/guix-package-net.sh +++ b/tests/guix-package-net.sh @@ -57,7 +57,7 @@ test -L "$profile" && test -L "$profile-1-link" ! test -f "$profile-2-link" test -f "$profile/bin/guile" -boot_make="(@@ (gnu packages commencement) gnu-make-boot0)" +boot_make="(@ (guix tests) gnu-make-for-tests)" boot_make_drv="`guix build -e "$boot_make" | grep -v -e -debug`" guix package --bootstrap -p "$profile" -i "$boot_make_drv" test -L "$profile-2-link" diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 79d6ec65e4..0de30bf6c1 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -331,6 +331,17 @@ cat > "$module_dir/package.scm"<<EOF EOF guix package --bootstrap --install-from-file="$module_dir/package.scm" +# Make sure an error is raised if the file doesn't return a package. +cat > "$module_dir/package.scm"<<EOF +(use-modules (gnu packages base)) + +(define my-package coreutils) ;returns *unspecified* +EOF +if guix package --bootstrap --install-from-file="$module_dir/package.scm" +then false; else true; fi + +rm "$module_dir/package.scm" + # This one should not show up in searches since it's no supported on the # current system. test "`guix package -A super-non-portable-emacs`" = "" @@ -427,7 +438,7 @@ cat > "$module_dir/foo.scm"<<EOF (version "dummy-version") (outputs '("out" "dummy-output")) (source #f) - ;; Without a real build system, the "guix pacakge -s" command will fail. + ;; Without a real build system, the "guix package -s" command will fail. (build-system trivial-build-system) (synopsis "dummy-synopsis") (description "dummy-description") @@ -437,3 +448,7 @@ EOF guix package -L "$module_dir" -s dummy-output > /tmp/out test "`guix package -L "$module_dir" -s dummy-output | grep ^name:`" = "name: dummy-package" rm -rf "$module_dir" + +# Make sure we can see user profiles. +guix package --list-profiles | grep "$profile" +guix package --list-profiles | grep '\.guix-profile' diff --git a/tests/inferior.scm b/tests/inferior.scm index 71ebf8f59b..f54b6d6037 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -27,6 +27,7 @@ #:use-module (gnu packages bootstrap) #:use-module (gnu packages guile) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) @@ -186,6 +187,18 @@ (add-text-to-store store "foo" "Hello, world!"))))) +(test-assert "inferior-eval-with-store, &store-protocol-error" + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix"))) + (guard (c ((store-protocol-error? c) + (string-contains (store-protocol-error-message c) + "invalid character"))) + (inferior-eval-with-store inferior %store + '(lambda (store) + (add-text-to-store store "we|rd/?!@" + "uh uh"))) + #f))) + (test-equal "inferior-package-derivation" (map derivation-file-name (list (package-derivation %store %bootstrap-guile "x86_64-linux") diff --git a/tests/lint.scm b/tests/lint.scm index 8a9023a7a3..1b92f02b85 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -35,6 +35,7 @@ #:use-module (guix packages) #:use-module (guix lint) #:use-module (guix ui) + #:use-module (guix swh) #:use-module (gnu packages) #:use-module (gnu packages glib) #:use-module (gnu packages pkg-config) @@ -47,6 +48,7 @@ #:use-module (ice-9 regex) #:use-module (ice-9 getopt-long) #:use-module (ice-9 pretty-print) + #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-26) @@ -74,6 +76,12 @@ (((and (? lint-warning?) warning)) (lint-warning-message warning)))) +(define (warning-contains? str warnings) + "Return true if WARNINGS is a singleton with a warning that contains STR." + (match warnings + (((? lint-warning? warning)) + (string-contains (lint-warning-message warning) str)))) + (test-begin "lint") @@ -366,13 +374,11 @@ (single-lint-warning-message (check-home-page pkg)))) -(test-equal "home-page: host not found" - "URI http://does-not-exist domain not found: Name or service not known" +(test-assert "home-page: host not found" (let ((pkg (package (inherit (dummy-package "x")) (home-page "http://does-not-exist")))) - (single-lint-warning-message - (check-home-page pkg)))) + (warning-contains? "domain not found" (check-home-page pkg)))) (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: Connection refused" @@ -386,7 +392,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 200" '() - (with-http-server 200 %long-string + (with-http-server `((200 ,%long-string)) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -395,7 +401,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 200 but short length" "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)" - (with-http-server 200 "This is too small." + (with-http-server `((200 "This is too small.")) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -406,7 +412,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 404" "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")" - (with-http-server 404 %long-string + (with-http-server `((404 ,%long-string)) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -416,7 +422,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 301, invalid" "invalid permanent redirect from http://localhost:9999/foo/bar" - (with-http-server 301 %long-string + (with-http-server `((301 ,%long-string)) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -426,12 +432,14 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 301 -> 200" "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar" - (with-http-server 200 %long-string - (let ((initial-url (%local-url))) + (with-http-server `((200 ,%long-string)) + (let* ((initial-url (%local-url)) + (redirect (build-response #:code 301 + #:headers + `((location + . ,(string->uri initial-url)))))) (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (301 `((location - . ,(string->uri initial-url)))) - "" + (with-http-server `((,redirect "")) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -441,12 +449,14 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 301 -> 404" "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")" - (with-http-server 404 "booh!" - (let ((initial-url (%local-url))) + (with-http-server '((404 "booh!")) + (let* ((initial-url (%local-url)) + (redirect (build-response #:code 301 + #:headers + `((location + . ,(string->uri initial-url)))))) (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (301 `((location - . ,(string->uri initial-url)))) - "" + (with-http-server `((,redirect "")) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -579,7 +589,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 200" '() - (with-http-server 200 %long-string + (with-http-server `((200 ,%long-string)) (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -591,7 +601,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 200 but short length" "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)" - (with-http-server 200 "This is too small." + (with-http-server '((200 "This is too small.")) (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -606,7 +616,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 404" "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")" - (with-http-server 404 %long-string + (with-http-server `((404 ,%long-string)) (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -621,10 +631,10 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 404 and 200" '() - (with-http-server 404 %long-string + (with-http-server `((404 ,%long-string)) (let ((bad-url (%local-url))) (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server 200 %long-string + (with-http-server `((200 ,%long-string)) (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -638,11 +648,14 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 301 -> 200" "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar" - (with-http-server 200 %long-string - (let ((initial-url (%local-url))) + (with-http-server `((200 ,%long-string)) + (let* ((initial-url (%local-url)) + (redirect (build-response #:code 301 + #:headers + `((location + . ,(string->uri initial-url)))))) (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (301 `((location . ,(string->uri initial-url)))) - "" + (with-http-server `((,redirect "")) (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -657,11 +670,14 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 301 -> 404" "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")" - (with-http-server 404 "booh!" - (let ((initial-url (%local-url))) + (with-http-server '((404 "booh!")) + (let* ((initial-url (%local-url)) + (redirect (build-response #:code 301 + #:headers + `((location + . ,(string->uri initial-url)))))) (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (301 `((location . ,(string->uri initial-url)))) - "" + (with-http-server `((,redirect "")) (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -693,7 +709,7 @@ (test-equal "github-url" '() - (with-http-server 200 %long-string + (with-http-server `((200 ,%long-string)) (check-github-url (dummy-package "x" (source (origin @@ -705,17 +721,25 @@ (test-equal "github-url: one suggestion" (string-append "URL should be '" github-url "'") - (with-http-server (301 `((location . ,(string->uri github-url)))) "" - (let ((initial-uri (%local-url))) - (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (302 `((location . ,(string->uri initial-uri)))) "" - (single-lint-warning-message - (check-github-url - (dummy-package "x" (source - (origin - (method url-fetch) - (uri (%local-url)) - (sha256 %null-sha256))))))))))) + (let ((redirect (build-response #:code 301 + #:headers + `((location + . ,(string->uri github-url)))))) + (with-http-server `((,redirect "")) + (let* ((initial-url (%local-url)) + (redirect (build-response #:code 302 + #:headers + `((location + . ,(string->uri initial-url)))))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server `((,redirect "")) + (single-lint-warning-message + (check-github-url + (dummy-package "x" (source + (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256)))))))))))) (test-equal "github-url: already the correct github url" '() (check-github-url @@ -837,9 +861,88 @@ '() (check-formatting (dummy-package "x"))) +(test-assert "archival: missing content" + (let* ((origin (origin + (method url-fetch) + (uri "http://example.org/foo.tgz") + (sha256 (make-bytevector 32)))) + (warnings (with-http-server '((404 "Not archived.")) + (parameterize ((%swh-base-url (%local-url))) + (check-archival (dummy-package "x" + (source origin))))))) + (warning-contains? "not archived" warnings))) + +(test-equal "archival: content available" + '() + (let* ((origin (origin + (method url-fetch) + (uri "http://example.org/foo.tgz") + (sha256 (make-bytevector 32)))) + ;; https://archive.softwareheritage.org/api/1/content/ + (content "{ \"checksums\": {}, \"data_url\": \"xyz\", + \"length\": 42 }")) + (with-http-server `((200 ,content)) + (parameterize ((%swh-base-url (%local-url))) + (check-archival (dummy-package "x" (source origin))))))) + +(test-assert "archival: missing revision" + (let* ((origin (origin + (method git-fetch) + (uri (git-reference + (url "http://example.org/foo.git") + (commit "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))) + (sha256 (make-bytevector 32)))) + ;; https://archive.softwareheritage.org/api/1/origin/save/ + (save "{ \"origin_url\": \"http://example.org/foo.git\", + \"save_request_date\": \"2014-11-17T22:09:38+01:00\", + \"save_request_status\": \"accepted\", + \"save_task_status\": \"scheduled\" }") + (warnings (with-http-server `((404 "No revision.") ;lookup-revision + (404 "No origin.") ;lookup-origin + (200 ,save)) ;save-origin + (parameterize ((%swh-base-url (%local-url))) + (check-archival (dummy-package "x" (source origin))))))) + (warning-contains? "scheduled" warnings))) + +(test-equal "archival: revision available" + '() + (let* ((origin (origin + (method git-fetch) + (uri (git-reference + (url "http://example.org/foo.git") + (commit "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))) + (sha256 (make-bytevector 32)))) + ;; https://archive.softwareheritage.org/api/1/revision/ + (revision "{ \"author\": {}, \"parents\": [], + \"date\": \"2014-11-17T22:09:38+01:00\" }")) + (with-http-server `((200 ,revision)) + (parameterize ((%swh-base-url (%local-url))) + (check-archival (dummy-package "x" (source origin))))))) + +(test-assert "archival: rate limit reached" + ;; We should get a single warning stating that the rate limit was reached, + ;; and nothing more, in particular no other HTTP requests. + (let* ((origin (origin + (method url-fetch) + (uri "http://example.org/foo.tgz") + (sha256 (make-bytevector 32)))) + (too-many (build-response + #:code 429 + #:reason-phrase "Too many requests" + #:headers '((x-ratelimit-remaining . "0") + (x-ratelimit-reset . "3000000000")))) + (warnings (with-http-server `((,too-many "Rate limit reached.")) + (parameterize ((%swh-base-url (%local-url))) + (append-map (lambda (name) + (check-archival + (dummy-package name (source origin)))) + '("x" "y" "z")))))) + (string-contains (single-lint-warning-message warnings) + "rate limit reached"))) + (test-end "lint") ;; Local Variables: -;; eval: (put 'with-http-server 'scheme-indent-function 2) +;; eval: (put 'with-http-server 'scheme-indent-function 1) ;; eval: (put 'with-warnings 'scheme-indent-function 0) ;; End: diff --git a/tests/networking.scm b/tests/networking.scm new file mode 100644 index 0000000000..439cca5ffc --- /dev/null +++ b/tests/networking.scm @@ -0,0 +1,113 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; +;;; 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 (tests networking) + #:use-module (ice-9 regex) + #:use-module (gnu services networking) + #:use-module (srfi srfi-64)) + +;;; Tests for the (gnu services networking) module. + +(test-begin "networking") + + +;;; +;;; NTP. +;;; + +(define ntp-server->string (@@ (gnu services networking) ntp-server->string)) + +(define %ntp-server-sample + (ntp-server + (type 'server) + (address "some.ntp.server.org") + (options `(iburst (version 3) (maxpoll 16) prefer)))) + +(test-equal "ntp-server->string" + (ntp-server->string %ntp-server-sample) + "server some.ntp.server.org iburst version 3 maxpoll 16 prefer") + +(test-equal "ntp configuration servers deprecated form" + (ntp-configuration-servers + (ntp-configuration + (servers (list (ntp-server + (type 'server) + (address "example.pool.ntp.org") + (options '())))))) + (ntp-configuration-servers + (ntp-configuration + (servers (list "example.pool.ntp.org"))))) + + +;;; +;;; OpenNTPD +;;; + +(define openntpd-configuration->string (@@ (gnu services networking) + openntpd-configuration->string)) + +(define %openntpd-conf-sample + (openntpd-configuration + (server '("0.guix.pool.ntp.org" "1.guix.pool.ntp.org")) + (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))) + +(test-assert "openntpd configuration generation sanity check" + + (begin + (define (string-match/newline pattern text) + (regexp-exec (make-regexp pattern regexp/newline) text)) + + (define (match-count pattern text) + (fold-matches (make-regexp pattern regexp/newline) text 0 + (lambda (match count) + (1+ count)))) + + (let ((config (openntpd-configuration->string %openntpd-conf-sample))) + (if (not + (and (string-match/newline "^listen on 127.0.0.1$" config) + (string-match/newline "^listen on ::1$" config) + (string-match/newline "^sensor udcf0 correction 70000$" config) + (string-match/newline "^constraint from www.gnu.org$" config) + (string-match/newline "^server 0.guix.pool.ntp.org$" config) + (string-match/newline + "^constraints from \"https://www.google.com/\"$" + config) + + ;; Check for issue #3731 (see: + ;; http://debbugs.gnu.org/cgi/bugreport.cgi?bug=37318). + (= (match-count "^listen on " config) 2) + (= (match-count "^sensor " config) 1) + (= (match-count "^constraint from " config) 1) + (= (match-count "^server " config) 2) + (= (match-count "^constraints from " config) 1))) + (begin + (format #t "The configuration below failed \ +the sanity check:\n~a~%" config) + #f) + #t)))) + +(test-equal "openntpd generated config string ends with a newline" + (let ((config (openntpd-configuration->string %openntpd-conf-sample))) + (string-take-right config 1)) + "\n") + +(test-end "networking") diff --git a/tests/opam.scm b/tests/opam.scm index e8c0d15198..d3626fd010 100644 --- a/tests/opam.scm +++ b/tests/opam.scm @@ -99,7 +99,7 @@ url { ('base32 (? string? hash))))) ('build-system 'ocaml-build-system) - ('inputs + ('propagated-inputs ('quasiquote (("ocaml-zarith" ('unquote 'ocaml-zarith))))) ('native-inputs diff --git a/tests/pack.scm b/tests/pack.scm index ea88cd89f2..71ff5aec18 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -169,6 +169,7 @@ (when (and (file-exists? (string-append bin "/guile")) (file-exists? "var/guix/db/db.sqlite") + (file-is-directory? "tmp") (string=? (string-append #$%bootstrap-guile "/bin") (pk 'binlink (readlink bin))) (string=? (string-append #$profile "/bin/guile") diff --git a/tests/packages.scm b/tests/packages.scm index 836d446657..423c5061aa 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -36,6 +37,7 @@ #:use-module (guix build-system) #:use-module (guix build-system trivial) #:use-module (guix build-system gnu) + #:use-module (guix memoization) #:use-module (guix profiles) #:use-module (guix scripts package) #:use-module (gnu packages) @@ -336,18 +338,55 @@ ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on ;; %SUPPORTED-SYSTEMS. Thus the others must be ignored. (let ((p (dummy-package "foo" + (build-system gnu-build-system) + (supported-systems + `("does-not-exist" "foobar" ,@%supported-systems))))) + (parameterize ((%current-system "armhf-linux")) ; a traditionally-bootstrapped architecture + (package-transitive-supported-systems p)))) + +(test-equal "package-transitive-supported-systems: reduced binary seed, implicit inputs" + '("x86_64-linux" "i686-linux") + + ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on + ;; %SUPPORTED-SYSTEMS. Thus the others must be ignored. + (let ((p (dummy-package "foo" (build-system gnu-build-system) (supported-systems `("does-not-exist" "foobar" ,@%supported-systems))))) - (package-transitive-supported-systems p))) + (parameterize ((%current-system "x86_64-linux")) + (package-transitive-supported-systems p)))) (test-assert "supported-package?" - (let ((p (dummy-package "foo" - (build-system gnu-build-system) - (supported-systems '("x86_64-linux" "does-not-exist"))))) + (let* ((d (dummy-package "dep" + (build-system trivial-build-system) + (supported-systems '("x86_64-linux")))) + (p (dummy-package "foo" + (build-system gnu-build-system) + (inputs `(("d" ,d))) + (supported-systems '("x86_64-linux" "armhf-linux"))))) + (and (supported-package? p "x86_64-linux") + (not (supported-package? p "i686-linux")) + (not (supported-package? p "armhf-linux"))))) + +(test-assert "supported-package? vs. system-dependent graph" + ;; The inputs of a package can depend on (%current-system). Thus, + ;; 'supported-package?' must make sure that it binds (%current-system) + ;; appropriately before traversing the dependency graph. In the example + ;; below, 'supported-package?' must thus return true for both systems. + (let* ((p0a (dummy-package "foo-arm" + (build-system trivial-build-system) + (supported-systems '("armhf-linux")))) + (p0b (dummy-package "foo-x86_64" + (build-system trivial-build-system) + (supported-systems '("x86_64-linux")))) + (p (dummy-package "bar" + (build-system trivial-build-system) + (inputs + (if (string=? (%current-system) "armhf-linux") + `(("foo" ,p0a)) + `(("foo" ,p0b))))))) (and (supported-package? p "x86_64-linux") - (not (supported-package? p "does-not-exist")) - (not (supported-package? p "i686-linux"))))) + (supported-package? p "armhf-linux")))) (test-skip (if (not %store) 8 0)) @@ -918,9 +957,9 @@ (when (or (not (network-reachable?)) (shebang-too-long?)) (test-skip 1)) (test-assert "GNU Make, bootstrap" - ;; GNU Make is the first program built during bootstrap; we choose it - ;; here so that the test doesn't last for too long. - (let ((gnu-make (@@ (gnu packages commencement) gnu-make-boot0))) + ;; GNU-MAKE-FOR-TESTS can be built cheaply; we choose it here so that the + ;; test doesn't last for too long. + (let ((gnu-make gnu-make-for-tests)) (and (package? gnu-make) (or (location? (package-location gnu-make)) (not (package-location gnu-make))) diff --git a/tests/profiles.scm b/tests/profiles.scm index eef93e24cf..a4e28672b5 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -239,11 +239,10 @@ (unless (network-reachable?) (test-skip 1)) (test-assertm "profile-derivation relative symlinks, two entries" (mlet* %store-monad - ((gnu-make-boot0 -> (@@ (gnu packages commencement) gnu-make-boot0)) - (manifest -> (packages->manifest - (list %bootstrap-guile gnu-make-boot0))) + ((manifest -> (packages->manifest + (list %bootstrap-guile gnu-make-for-tests))) (guile (package->derivation %bootstrap-guile)) - (make (package->derivation gnu-make-boot0)) + (make (package->derivation gnu-make-for-tests)) (drv (profile-derivation manifest #:relative-symlinks? #t #:hooks '() diff --git a/tests/search-paths.scm b/tests/search-paths.scm index 8dad424415..767a80b76c 100644 --- a/tests/search-paths.scm +++ b/tests/search-paths.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,17 +29,17 @@ (test-equal "evaluate-search-paths, separator is #f" (string-append %top-srcdir - "/gnu/packages/bootstrap/aarch64-linux") + "/gnu/packages/aux-files/linux-libre") ;; The following search path spec should evaluate to a single item: the ;; first directory that matches the "-linux$" pattern in ;; gnu/packages/bootstrap. (let ((spec (search-path-specification (variable "CHBOUIB") - (files '("gnu/packages/bootstrap")) + (files '("gnu/packages/aux-files")) (file-type 'directory) (separator #f) - (file-pattern "-linux$")))) + (file-pattern "^linux")))) (match (evaluate-search-paths (list spec) (list %top-srcdir)) (((spec* . value)) diff --git a/tests/swh.scm b/tests/swh.scm index 07f0fda37b..e36c54e5fb 100644 --- a/tests/swh.scm +++ b/tests/swh.scm @@ -19,6 +19,7 @@ (define-module (test-swh) #:use-module (guix swh) #:use-module (guix tests http) + #:use-module (web response) #:use-module (srfi srfi-64)) ;; Test the JSON mapping machinery used in (guix swh). @@ -40,7 +41,7 @@ \"dir_id\": 2 } ]") (define-syntax-rule (with-json-result str exp ...) - (with-http-server 200 str + (with-http-server `((200 ,str)) (parameterize ((%swh-base-url (%local-url))) exp ...))) @@ -56,7 +57,7 @@ (test-equal "lookup-origin, not found" #f - (with-http-server 404 "Nope." + (with-http-server `((404 "Nope.")) (parameterize ((%swh-base-url (%local-url))) (lookup-origin "http://example.org/whatever")))) @@ -68,9 +69,45 @@ (directory-entry-length entry))) (lookup-directory "123")))) +(test-equal "rate limit reached" + 3000000000 + (let ((too-many (build-response + #:code 429 + #:reason-phrase "Too many requests" + + ;; Pretend we've reached the limit and it'll be reset in + ;; June 2065. + #:headers '((x-ratelimit-remaining . "0") + (x-ratelimit-reset . "3000000000"))))) + (with-http-server `((,too-many "Too bad.")) + (parameterize ((%swh-base-url (%local-url))) + (catch 'swh-error + (lambda () + (lookup-origin "http://example.org/guix.git")) + (lambda (key url method response) + ;; Ensure the reset time was recorded. + (@@ (guix swh) %general-rate-limit-reset-time))))))) + +(test-assert "%allow-request? and request-rate-limit-reached?" + ;; Here we test two things: that the rate limit set above is in effect and + ;; that %ALLOW-REQUEST? is called, and that 'request-rate-limit-reached?' + ;; returns true. + (let* ((key (gensym "skip-request")) + (skip-if-limit-reached + (lambda (url method) + (or (not (request-rate-limit-reached? url method)) + (throw key #t))))) + (parameterize ((%allow-request? skip-if-limit-reached)) + (catch key + (lambda () + (lookup-origin "http://example.org/guix.git") + #f) + (const #t))))) + (test-end "swh") ;; Local Variables: ;; eval: (put 'with-json-result 'scheme-indent-function 1) +;; eval: (put 'with-http-server 'scheme-indent-function 1) ;; End: diff --git a/tests/syscalls.scm b/tests/syscalls.scm index eeb223b950..1b3121e503 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -567,6 +567,19 @@ (let ((result (call-with-input-file "/var/run/utmpx" read-utmpx))) (or (utmpx? result) (eof-object? result)))) +(when (zero? (getuid)) + (test-skip 1)) +(test-equal "add-to-entropy-count" + EPERM + (call-with-output-file "/dev/urandom" + (lambda (port) + (catch 'system-error + (lambda () + (add-to-entropy-count port 77) + #f) + (lambda args + (system-error-errno args)))))) + (test-end) (false-if-exception (delete-file temp-file)) diff --git a/tests/ui.scm b/tests/ui.scm index 2138e23369..d8573e88d8 100644 --- a/tests/ui.scm +++ b/tests/ui.scm @@ -267,6 +267,7 @@ Second line" 24)) (gcrypt (specification->package "guile-gcrypt")) (go (specification->package "go")) (gnugo (specification->package "gnugo")) + (libb2 (specification->package "libb2")) (rx (cut make-regexp <> regexp/icase)) (>0 (cut > <> 0)) (=0 zero?)) @@ -283,6 +284,8 @@ Second line" 24)) (=0 (package-relevance go (map rx '("go" "game")))) (>0 (package-relevance gnugo - (map rx '("go" "game"))))))) + (map rx '("go" "game")))) + (>0 (package-relevance libb2 + (map rx '("crypto" "library"))))))) (test-end "ui") diff --git a/tests/union.scm b/tests/union.scm index 5a6a4033fc..a8387edf42 100644 --- a/tests/union.scm +++ b/tests/union.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -94,8 +95,9 @@ `(,name ,(package-derivation %store package)))) ;; Purposefully leave duplicate entries. - (append %bootstrap-inputs - (take %bootstrap-inputs 3)))) + (filter (compose package? cadr) + (append %bootstrap-inputs-for-tests + (take %bootstrap-inputs-for-tests 3))))) (builder `(begin (use-modules (guix build union)) (union-build (assoc-ref %outputs "out") |