summaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
authorMarius Bakke <mbakke@fastmail.com>2018-03-29 17:34:41 +0200
committerMarius Bakke <mbakke@fastmail.com>2018-03-29 17:34:41 +0200
commit5576cfabf3485e0cf794cc3de085a3578151ee64 (patch)
tree8ca4093d05fda6b0064d0fca429353327ec491f9 /tests
parent12cb6c31df4b90d58658e88a256e36b6808e1064 (diff)
parente086d2f68b90a39bae07ae46572e5cc6b0fc4308 (diff)
downloadpatches-5576cfabf3485e0cf794cc3de085a3578151ee64.tar
patches-5576cfabf3485e0cf794cc3de085a3578151ee64.tar.gz
Merge branch 'master' into core-updates
Diffstat (limited to 'tests')
-rw-r--r--tests/gexp.scm61
-rw-r--r--tests/graph.scm20
-rw-r--r--tests/guix-gc.sh5
-rw-r--r--tests/guix-pack.sh83
-rw-r--r--tests/guix-system.sh17
-rw-r--r--tests/publish.scm10
6 files changed, 192 insertions, 4 deletions
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 5873abdd41..2f8940e2c6 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -25,6 +25,7 @@
#:use-module (guix packages)
#:use-module (guix tests)
#:use-module ((guix build utils) #:select (with-directory-excursion))
+ #:use-module ((guix utils) #:select (call-with-temporary-directory))
#:use-module (gnu packages)
#:use-module (gnu packages base)
#:use-module (gnu packages bootstrap)
@@ -853,6 +854,37 @@
(return (and (zero? (close-pipe pipe))
(= (expt n 2) (string->number str)))))))
+(test-assertm "gexp->script #:module-path"
+ (call-with-temporary-directory
+ (lambda (directory)
+ (define str
+ "Fake (guix base32) module!")
+
+ (mkdir (string-append directory "/guix"))
+ (call-with-output-file (string-append directory "/guix/base32.scm")
+ (lambda (port)
+ (write `(begin (define-module (guix base32))
+ (define-public %fake! ,str))
+ port)))
+
+ (mlet* %store-monad ((exp -> (with-imported-modules '((guix base32))
+ (gexp (begin
+ (use-modules (guix base32))
+ (write (list %load-path
+ %fake!))))))
+ (drv (gexp->script "guile-thing" exp
+ #:guile %bootstrap-guile
+ #:module-path (list directory)))
+ (out -> (derivation->output-path drv))
+ (done (built-derivations (list drv))))
+ (let* ((pipe (open-input-pipe out))
+ (data (read pipe)))
+ (return (and (zero? (close-pipe pipe))
+ (match data
+ ((load-path str*)
+ (and (string=? str* str)
+ (not (member directory load-path))))))))))))
+
(test-assertm "program-file"
(let* ((n (random (expt 2 50)))
(exp (with-imported-modules '((guix build utils))
@@ -870,6 +902,33 @@
(return (and (zero? (close-pipe pipe))
(= n (string->number str)))))))))
+(test-assertm "program-file #:module-path"
+ (call-with-temporary-directory
+ (lambda (directory)
+ (define text (random-text))
+
+ (call-with-output-file (string-append directory "/stupid-module.scm")
+ (lambda (port)
+ (write `(begin (define-module (stupid-module))
+ (define-public %stupid-thing ,text))
+ port)))
+
+ (let* ((exp (with-imported-modules '((stupid-module))
+ (gexp (begin
+ (use-modules (stupid-module))
+ (display %stupid-thing)))))
+ (file (program-file "program" exp
+ #:guile %bootstrap-guile
+ #:module-path (list directory))))
+ (mlet* %store-monad ((drv (lower-object file))
+ (out -> (derivation->output-path drv)))
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (let* ((pipe (open-input-pipe out))
+ (str (get-string-all pipe)))
+ (return (and (zero? (close-pipe pipe))
+ (string=? text str))))))))))
+
(test-assertm "scheme-file"
(let* ((text (plain-file "foo" "Hello, world!"))
(scheme (scheme-file "bar" #~(list "foo" #$text))))
diff --git a/tests/graph.scm b/tests/graph.scm
index 00fd37243c..5faa19298a 100644
--- a/tests/graph.scm
+++ b/tests/graph.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -271,6 +271,24 @@ edges."
(list txt out))
(equal? edges `((,txt ,out)))))))))))
+(test-assert "module graph"
+ (let-values (((backend nodes+edges) (make-recording-backend)))
+ (run-with-store %store
+ (export-graph '((gnu packages guile)) 'port
+ #:node-type %module-node-type
+ #:backend backend))
+
+ (let-values (((nodes edges) (nodes+edges)))
+ (and (member '(gnu packages guile)
+ (match nodes
+ (((ids labels) ...) ids)))
+ (->bool (and (member (list '(gnu packages guile)
+ '(gnu packages libunistring))
+ edges)
+ (member (list '(gnu packages guile)
+ '(gnu packages bdw-gc))
+ edges)))))))
+
(test-assert "node-edges"
(run-with-store %store
(let ((packages (fold-packages cons '())))
diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh
index efbc7e759c..ef2d9543b7 100644
--- a/tests/guix-gc.sh
+++ b/tests/guix-gc.sh
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2013, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2013, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
#
# This file is part of GNU Guix.
#
@@ -54,6 +54,9 @@ guix gc --references "$out/bin/guile"
if guix gc --references /dev/null;
then false; else true; fi
+# Check derivers.
+guix gc --derivers "$out" | grep "$drv"
+
# Add then reclaim a .drv file.
drv="`guix build idutils -d`"
test -f "$drv"
diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh
new file mode 100644
index 0000000000..1b63b957be
--- /dev/null
+++ b/tests/guix-pack.sh
@@ -0,0 +1,83 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2018 Chris Marusich <cmmarusich@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/>.
+
+#
+# Test the `guix pack' command-line utility.
+#
+
+# A network connection is required to build %bootstrap-coreutils&co,
+# which is required to run these tests with the --bootstrap option.
+if ! guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null; then
+ exit 77
+fi
+
+guix pack --version
+
+# Use --no-substitutes because we need to verify we can do this ourselves.
+GUIX_BUILD_OPTIONS="--no-substitutes"
+export GUIX_BUILD_OPTIONS
+
+# Build a tarball with no compression.
+guix pack --compression=none --bootstrap guile-bootstrap
+
+# Build a tarball (with compression).
+guix pack --bootstrap guile-bootstrap
+
+# Build a tarball with a symlink.
+the_pack="`guix pack --bootstrap -S /opt/gnu/bin=bin guile-bootstrap`"
+
+# Try to extract it.
+test_directory="`mktemp -d`"
+trap 'rm -rf "$test_directory"' EXIT
+cd "$test_directory"
+tar -xf "$the_pack"
+test -x opt/gnu/bin/guile
+
+is_available () {
+ # Use the "type" shell builtin to see if the program is on PATH.
+ type "$1" > /dev/null
+}
+
+if is_available chroot && is_available unshare; then
+ # Verify we can use what we built.
+ unshare -r chroot . /opt/gnu/bin/guile --version
+ cd -
+else
+ echo "warning: skipped some verification because chroot or unshare is unavailable" >&2
+fi
+
+# For the tests that build Docker images below, we currently have to use
+# --dry-run because if we don't, there are only two possible cases:
+#
+# Case 1: We do not use --bootstrap, and the build takes hours to finish
+# because it needs to build tar etc.
+#
+# Case 2: We use --bootstrap, and the build fails because the bootstrap
+# Guile cannot dlopen shared libraries. Not to mention the fact
+# that we would still have to build many non-bootstrap inputs
+# (e.g., guile-json) in order to create the Docker image.
+
+# Build a Docker image.
+guix pack --dry-run --bootstrap -f docker guile-bootstrap
+
+# Build a Docker image with a symlink.
+guix pack --dry-run --bootstrap -f docker -S /opt/gnu=/ guile-bootstrap
+
+# Build a tarball pack of cross-compiled software. Use coreutils because
+# guile-bootstrap is not intended to be cross-compiled.
+guix pack --dry-run --bootstrap --target=arm-unknown-linux-gnueabihf coreutils
diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index ed8563c8aa..211c26f43d 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -1,6 +1,7 @@
# GNU Guix --- Functional package management for GNU
# Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
# Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
+# Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
#
# This file is part of GNU Guix.
#
@@ -267,3 +268,19 @@ guix system build "$tmpdir/config.scm" -n
# Searching.
guix system search tor | grep "^name: tor"
guix system search anonym network | grep "^name: tor"
+
+# Below, use -n (--dry-run) for the tests because if we actually tried to
+# build these images, the commands would take hours to run in the worst case.
+
+# Verify that the examples can be built.
+for example in gnu/system/examples/*; do
+ guix system -n disk-image $example
+done
+
+# Verify that the disk image types can be built.
+guix system -n vm gnu/system/examples/vm-image.tmpl
+guix system -n vm-image gnu/system/examples/vm-image.tmpl
+# This invocation was taken care of in the loop above:
+# guix system -n disk-image gnu/system/examples/bare-bones.tmpl
+guix system -n disk-image --file-system-type=iso9660 gnu/system/examples/bare-bones.tmpl
+guix system -n docker-image gnu/system/examples/docker-image.tmpl
diff --git a/tests/publish.scm b/tests/publish.scm
index 8c88a8c93d..1ed8308076 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -464,7 +464,7 @@ FileSize: ~a~%"
(lambda (port)
(display "Hello, build log!"
(current-error-port))
- (display "" port)))))))
+ (display #$(random-text) port)))))))
(build-derivations %store (list drv))
(let* ((response (http-get
(publish-uri (string-append "/log/"
@@ -483,4 +483,12 @@ FileSize: ~a~%"
(let ((uri (publish-uri "/log/does-not-exist")))
(response-code (http-get uri))))
+(test-equal "non-GET query"
+ '(200 404)
+ (let ((path (string-append "/" (store-path-hash-part %item)
+ ".narinfo")))
+ (map response-code
+ (list (http-get (publish-uri path))
+ (http-post (publish-uri path))))))
+
(test-end "publish")