summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2019-07-22 18:58:48 +0200
committerMarius Bakke <mbakke@fastmail.com>2019-07-22 18:58:48 +0200
commitccad0e4d6973da7af8badfb7125f35f7e51eb2d7 (patch)
tree15ff9da1c1c03b088d0ad9240f2c1878f5da5802 /tests
parentd478cc043557ca3fcd5fced87d2e2c8e246eff03 (diff)
parent26986544469ef290885f5f8d71006751e9e8daf8 (diff)
downloadpatches-ccad0e4d6973da7af8badfb7125f35f7e51eb2d7.tar
patches-ccad0e4d6973da7af8badfb7125f35f7e51eb2d7.tar.gz
Merge branch 'master' into core-updates
Diffstat (limited to 'tests')
-rw-r--r--tests/channels.scm72
-rw-r--r--tests/containers.scm50
-rw-r--r--tests/guix-build.sh31
-rw-r--r--tests/lint.scm31
-rw-r--r--tests/swh.scm76
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:
+