diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/channels.scm | 72 | ||||
| -rw-r--r-- | tests/containers.scm | 50 | ||||
| -rw-r--r-- | tests/guix-build.sh | 31 | ||||
| -rw-r--r-- | tests/lint.scm | 31 | ||||
| -rw-r--r-- | tests/swh.scm | 76 |
5 files changed, 228 insertions, 32 deletions
diff --git a/tests/channels.scm b/tests/channels.scm index 8540aef435..e83b5437d3 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -26,8 +26,12 @@ #:use-module (guix derivations) #:use-module (guix sets) #:use-module (guix gexp) + #:use-module ((guix utils) + #:select (error-location? error-location location-line)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) @@ -38,22 +42,23 @@ (commit "cafebabe") (spec #f)) (define instance-dir (mkdtemp! "/tmp/checkout.XXXXXX")) - (and spec - (with-output-to-file (string-append instance-dir "/.guix-channel") - (lambda _ (format #t "~a" spec)))) + (when spec + (call-with-output-file (string-append instance-dir "/.guix-channel") + (lambda (port) (write spec port)))) (checkout->channel-instance instance-dir #:commit commit #:name name)) (define instance--boring (make-instance)) +(define instance--unsupported-version + (make-instance #:spec + '(channel (version 42) (dependencies whatever)))) (define instance--no-deps (make-instance #:spec - '(channel - (version 0) - (dependencies - (channel - (name test-channel) - (url "https://example.com/test-channel")))))) + '(channel (version 0)))) +(define instance--sub-directory + (make-instance #:spec + '(channel (version 0) (directory "modules")))) (define instance--simple (make-instance #:spec '(channel @@ -78,24 +83,45 @@ (name test-channel) (url "https://example.com/test-channel-elsewhere")))))) -(define read-channel-metadata - (@@ (guix channels) read-channel-metadata)) +(define channel-instance-metadata + (@@ (guix channels) channel-instance-metadata)) +(define channel-metadata-directory + (@@ (guix channels) channel-metadata-directory)) +(define channel-metadata-dependencies + (@@ (guix channels) channel-metadata-dependencies)) -(test-equal "read-channel-metadata returns #f if .guix-channel does not exist" - #f - (read-channel-metadata instance--boring)) - -(test-assert "read-channel-metadata returns <channel-metadata>" +(test-equal "channel-instance-metadata returns default if .guix-channel does not exist" + '("/" ()) + (let ((metadata (channel-instance-metadata instance--boring))) + (list (channel-metadata-directory metadata) + (channel-metadata-dependencies metadata)))) + +(test-equal "channel-instance-metadata and default dependencies" + '() + (channel-metadata-dependencies (channel-instance-metadata instance--no-deps))) + +(test-equal "channel-instance-metadata and directory" + "/modules" + (channel-metadata-directory + (channel-instance-metadata instance--sub-directory))) + +(test-equal "channel-instance-metadata rejects unsupported version" + 1 ;line number in the generated '.guix-channel' + (guard (c ((and (message-condition? c) (error-location? c)) + (location-line (error-location c)))) + (channel-instance-metadata instance--unsupported-version))) + +(test-assert "channel-instance-metadata returns <channel-metadata>" (every (@@ (guix channels) channel-metadata?) - (map read-channel-metadata + (map channel-instance-metadata (list instance--no-deps instance--simple instance--with-dupes)))) -(test-assert "read-channel-metadata dependencies are channels" +(test-assert "channel-instance-metadata dependencies are channels" (let ((deps ((@@ (guix channels) channel-metadata-dependencies) - (read-channel-metadata instance--simple)))) + (channel-instance-metadata instance--simple)))) (match deps (((? channel? dep)) #t) (_ #f)))) @@ -128,7 +154,7 @@ ("test" (values test-dir 'whatever)) (_ (values "/not-important" 'not-important))))) (let ((instances (latest-channel-instances #f (list channel)))) - (and (eq? 2 (length instances)) + (and (= 2 (length instances)) (lset= eq? '(test test-channel) (map (compose channel-name channel-instance-channel) @@ -139,9 +165,9 @@ (and (eq? (channel-name (channel-instance-channel instance)) 'test-channel) - (eq? (channel-commit - (channel-instance-channel instance)) - 'abc1234))) + (string=? (channel-commit + (channel-instance-channel instance)) + "abc1234"))) instances)))))) (test-assert "channel-instances->manifest" diff --git a/tests/containers.scm b/tests/containers.scm index 37408f380d..c6c738f234 100644 --- a/tests/containers.scm +++ b/tests/containers.scm @@ -21,7 +21,15 @@ #:use-module (guix utils) #:use-module (guix build syscalls) #:use-module (gnu build linux-container) + #:use-module ((gnu system linux-container) + #:select (eval/container)) #:use-module (gnu system file-systems) + #:use-module (guix store) + #:use-module (guix monads) + #:use-module (guix gexp) + #:use-module (guix derivations) + #:use-module (guix tests) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) @@ -219,4 +227,46 @@ (lambda () (* 6 7)))) +(skip-if-unsupported) +(test-equal "eval/container, exit status" + 42 + (let* ((store (open-connection-for-tests)) + (status (run-with-store store + (eval/container #~(exit 42))))) + (close-connection store) + (status:exit-val status))) + +(skip-if-unsupported) +(test-assert "eval/container, writable user mapping" + (call-with-temporary-directory + (lambda (directory) + (define store + (open-connection-for-tests)) + (define result + (string-append directory "/r")) + (define requisites* + (store-lift requisites)) + + (call-with-output-file result (const #t)) + (run-with-store store + (mlet %store-monad ((status (eval/container + #~(begin + (use-modules (ice-9 ftw)) + (call-with-output-file "/result" + (lambda (port) + (write (scandir #$(%store-prefix)) + port)))) + #:mappings + (list (file-system-mapping + (source result) + (target "/result") + (writable? #t))))) + (reqs (requisites* + (list (derivation->output-path + (%guile-for-build)))))) + (close-connection store) + (return (and (zero? (pk 'status status)) + (lset= string=? (cons* "." ".." (map basename reqs)) + (pk (call-with-input-file result read)))))))))) + (test-end) diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 63a9fe68da..37666ffd01 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -146,8 +146,8 @@ test `guix build -d --sources=transitive foo \ | wc -l` -eq 3 -# Unbound variables. -cat > "$module_dir/foo.scm"<<EOF +# Unbound variable in thunked field. +cat > "$module_dir/foo.scm" <<EOF (define-module (foo) #:use-module (guix tests) #:use-module (guix build-system trivial)) @@ -162,8 +162,34 @@ if guix build package-with-something-wrong -n; then false; else true; fi guix build package-with-something-wrong -n 2> "$module_dir/err" || true grep "unbound" "$module_dir/err" # actual error grep "forget.*(gnu packages base)" "$module_dir/err" # hint + +# Unbound variable at the top level. +cat > "$module_dir/foo.scm" <<EOF +(define-module (foo) + #:use-module (guix tests)) + +(define-public foo + (dummy-package "package-with-something-wrong" + (build-system gnu-build-system))) ;unbound variable +EOF + +guix build sed -n 2> "$module_dir/err" +grep "unbound" "$module_dir/err" # actual error +grep "forget.*(guix build-system gnu)" "$module_dir/err" # hint + rm -f "$module_dir"/* +# Wrong 'define-module' clause reported by 'warn-about-load-error'. +cat > "$module_dir/foo.scm" <<EOF +(define-module (something foo) + #:use-module (guix) + #:use-module (gnu)) +EOF +guix build guile-bootstrap -n 2> "$module_dir/err" +grep "does not match file name" "$module_dir/err" + +rm "$module_dir"/* + # Should all return valid log files. drv="`guix build -d -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'`" out="`guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'`" @@ -265,6 +291,7 @@ cat > "$module_dir/gexp.scm"<<EOF EOF guix build --file="$module_dir/gexp.scm" -d guix build --file="$module_dir/gexp.scm" -d | grep 'gexp\.drv' +rm "$module_dir"/*.scm # Using 'GUIX_BUILD_OPTIONS'. GUIX_BUILD_OPTIONS="--dry-run --no-grafts" diff --git a/tests/lint.scm b/tests/lint.scm index 59be061a99..8a9023a7a3 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014, 2015, 2016 Eric Bavier <bavier@member.fsf.org> -;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2017 Alex Kost <alezost@gmail.com> @@ -619,6 +619,23 @@ (lint-warning-message second-warning)))))) (test-skip (if (http-server-can-listen?) 0 1)) +(test-equal "source: 404 and 200" + '() + (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 + (let ((pkg (package + (inherit (dummy-package "x")) + (source (origin + (method url-fetch) + (uri (list bad-url (%local-url))) + (sha256 %null-sha256)))))) + ;; Since one of the two URLs is good, this should return the empty + ;; list. + (check-source pkg))))))) + +(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 @@ -710,12 +727,12 @@ (test-equal "cve" '() - (mock ((guix scripts lint) package-vulnerabilities (const '())) + (mock ((guix lint) package-vulnerabilities (const '())) (check-vulnerabilities (dummy-package "x")))) (test-equal "cve: one vulnerability" "probably vulnerable to CVE-2015-1234" - (mock ((guix scripts lint) package-vulnerabilities + (mock ((guix lint) package-vulnerabilities (lambda (package) (list (make-struct (@@ (guix cve) <vulnerability>) 0 "CVE-2015-1234" @@ -726,7 +743,7 @@ (test-equal "cve: one patched vulnerability" '() - (mock ((guix scripts lint) package-vulnerabilities + (mock ((guix lint) package-vulnerabilities (lambda (package) (list (make-struct (@@ (guix cve) <vulnerability>) 0 "CVE-2015-1234" @@ -742,7 +759,7 @@ (test-equal "cve: known safe from vulnerability" '() - (mock ((guix scripts lint) package-vulnerabilities + (mock ((guix lint) package-vulnerabilities (lambda (package) (list (make-struct (@@ (guix cve) <vulnerability>) 0 "CVE-2015-1234" @@ -755,7 +772,7 @@ (test-equal "cve: vulnerability fixed in replacement version" '() - (mock ((guix scripts lint) package-vulnerabilities + (mock ((guix lint) package-vulnerabilities (lambda (package) (match (package-version package) ("0" @@ -772,7 +789,7 @@ (test-equal "cve: patched vulnerability in replacement" '() - (mock ((guix scripts lint) package-vulnerabilities + (mock ((guix lint) package-vulnerabilities (lambda (package) (list (make-struct (@@ (guix cve) <vulnerability>) 0 "CVE-2015-1234" diff --git a/tests/swh.scm b/tests/swh.scm new file mode 100644 index 0000000000..07f0fda37b --- /dev/null +++ b/tests/swh.scm @@ -0,0 +1,76 @@ +;;; 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-swh) + #:use-module (guix swh) + #:use-module (guix tests http) + #:use-module (srfi srfi-64)) + +;; Test the JSON mapping machinery used in (guix swh). + +(define %origin + "{ \"id\": 42, + \"visits_url\": \"/visits/42\", + \"type\": \"git\", + \"url\": \"http://example.org/guix.git\" }") + +(define %directory-entries + "[ { \"name\": \"one\", + \"type\": \"regular\", + \"length\": 123, + \"dir_id\": 1 } + { \"name\": \"two\", + \"type\": \"regular\", + \"length\": 456, + \"dir_id\": 2 } ]") + +(define-syntax-rule (with-json-result str exp ...) + (with-http-server 200 str + (parameterize ((%swh-base-url (%local-url))) + exp ...))) + +(test-begin "swh") + +(test-equal "lookup-origin" + (list 42 "git" "http://example.org/guix.git") + (with-json-result %origin + (let ((origin (lookup-origin "http://example.org/guix.git"))) + (list (origin-id origin) + (origin-type origin) + (origin-url origin))))) + +(test-equal "lookup-origin, not found" + #f + (with-http-server 404 "Nope." + (parameterize ((%swh-base-url (%local-url))) + (lookup-origin "http://example.org/whatever")))) + +(test-equal "lookup-directory" + '(("one" 123) ("two" 456)) + (with-json-result %directory-entries + (map (lambda (entry) + (list (directory-entry-name entry) + (directory-entry-length entry))) + (lookup-directory "123")))) + +(test-end "swh") + +;; Local Variables: +;; eval: (put 'with-json-result 'scheme-indent-function 1) +;; End: + |