diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/gexp.scm | 147 | ||||
| -rw-r--r-- | tests/guix-lint.sh | 5 | ||||
| -rw-r--r-- | tests/guix-package.sh | 15 | ||||
| -rw-r--r-- | tests/guix-system.sh | 9 | ||||
| -rw-r--r-- | tests/services/file-sharing.scm | 59 | ||||
| -rw-r--r-- | tests/syscalls.scm | 16 | ||||
| -rw-r--r-- | tests/transformations.scm | 10 |
7 files changed, 193 insertions, 68 deletions
diff --git a/tests/gexp.scm b/tests/gexp.scm index 6e92f0e4b3..834e78b9a0 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, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -51,18 +51,19 @@ ;; For white-box testing. (define (gexp-inputs x) ((@@ (guix gexp) gexp-inputs) x)) -(define (gexp-native-inputs x) - ((@@ (guix gexp) gexp-native-inputs) x)) (define (gexp-outputs x) ((@@ (guix gexp) gexp-outputs) x)) (define (gexp->sexp . x) (apply (@@ (guix gexp) gexp->sexp) x)) (define* (gexp->sexp* exp #:optional target) - (run-with-store %store (gexp->sexp exp - #:target target) + (run-with-store %store (gexp->sexp exp (%current-system) target) #:guile-for-build (%guile-for-build))) +(define (gexp-input->tuple input) + (list (gexp-input-thing input) (gexp-input-output input) + (gexp-input-native? input))) + (define %extension-package ;; Example of a package to use when testing 'with-extensions'. (dummy-package "extension" @@ -106,8 +107,8 @@ (let ((exp (gexp (display (ungexp coreutils))))) (and (gexp? exp) (match (gexp-inputs exp) - (((p "out")) - (eq? p coreutils))) + ((input) + (eq? (gexp-input-thing input) coreutils))) (equal? `(display ,(derivation->output-path (package-derivation %store coreutils))) (gexp->sexp* exp))))) @@ -116,8 +117,8 @@ (let ((exp (gexp (coreutils . (ungexp coreutils))))) (and (gexp? exp) (match (gexp-inputs exp) - (((p "out")) - (eq? p coreutils))) + ((input) + (eq? (gexp-input-thing input) coreutils))) (equal? `(coreutils . ,(derivation->output-path (package-derivation %store coreutils))) (gexp->sexp* exp))))) @@ -126,8 +127,9 @@ (let ((exp (gexp (display (ungexp (package-source coreutils)))))) (and (gexp? exp) (match (gexp-inputs exp) - (((o "out")) - (eq? o (package-source coreutils)))) + ((input) + (and (eq? (gexp-input-thing input) (package-source coreutils)) + (string=? (gexp-input-output input) "out")))) (equal? `(display ,(derivation->output-path (package-source-derivation %store (package-source coreutils)))) @@ -141,8 +143,9 @@ "sha256" file))) (and (gexp? exp) (match (gexp-inputs exp) - (((x "out")) - (eq? x local))) + ((input) + (and (eq? (gexp-input-thing input) local) + (string=? (gexp-input-output input) "out")))) (equal? `(display ,intd) (gexp->sexp* exp))))) (test-assert "one local file, symlink" @@ -158,8 +161,9 @@ "sha256" file))) (and (gexp? exp) (match (gexp-inputs exp) - (((x "out")) - (eq? x local))) + ((input) + (and (eq? (gexp-input-thing input) local) + (string=? (gexp-input-output input) "out")))) (equal? `(display ,intd) (gexp->sexp* exp))))) (lambda () (false-if-exception (delete-file link)))))) @@ -201,8 +205,9 @@ (expected (add-text-to-store %store "hi" "Hello, world!"))) (and (gexp? exp) (match (gexp-inputs exp) - (((x "out")) - (eq? x file))) + ((input) + (and (eq? (gexp-input-thing input) file) + (string=? (gexp-input-output input) "out")))) (equal? `(display ,expected) (gexp->sexp* exp))))) (test-assert "same input twice" @@ -211,8 +216,9 @@ (display (ungexp coreutils)))))) (and (gexp? exp) (match (gexp-inputs exp) - (((p "out")) - (eq? p coreutils))) + ((input) + (and (eq? (gexp-input-thing input) coreutils) + (string=? (gexp-input-output input) "out")))) (let ((e `(display ,(derivation->output-path (package-derivation %store coreutils))))) (equal? `(begin ,e ,e) (gexp->sexp* exp)))))) @@ -228,9 +234,8 @@ (display (ungexp drv)) (display (ungexp txt)))))) (define (match-input thing) - (match-lambda - ((drv-or-pkg _ ...) - (eq? thing drv-or-pkg)))) + (lambda (input) + (eq? (gexp-input-thing input) thing))) (and (gexp? exp) (= 4 (length (gexp-inputs exp))) @@ -255,8 +260,9 @@ (string-append (derivation->output-path drv) "/bin/guile")))) (match (gexp-inputs exp) - (((thing "out")) - (eq? thing fa)))))) + ((input) + (and (eq? (gexp-input-thing input) fa) + (string=? (gexp-input-output input) "out"))))))) (test-assert "file-append, output" (let* ((drv (package-derivation %store glibc)) @@ -268,8 +274,9 @@ (string-append (derivation->output-path drv "debug") "/lib/debug")))) (match (gexp-inputs exp) - (((thing "debug")) - (eq? thing fa)))))) + ((input) + (and (eq? (gexp-input-thing input) fa) + (string=? (gexp-input-output input) "debug"))))))) (test-assert "file-append, nested" (let* ((drv (package-derivation %store glibc)) @@ -283,8 +290,8 @@ (string-append (derivation->output-path drv) "/bin/getent")))) (match (gexp-inputs exp) - (((thing "out")) - (eq? thing file)))))) + ((input) + (eq? (gexp-input-thing input) file)))))) (test-assert "file-append, raw store item" (let* ((obj (plain-file "example.txt" "Hello!")) @@ -338,7 +345,7 @@ (string-append (derivation->output-path drv) "/bin/touch")))))) (test-equal "let-system" - (list `(begin ,(%current-system) #t) '(system-binding) '() + (list `(begin ,(%current-system) #t) '(system-binding) 'low '() '()) (let* ((exp #~(begin #$(let-system system system) @@ -346,10 +353,12 @@ (low (run-with-store %store (lower-gexp exp)))) (list (lowered-gexp-sexp low) (match (gexp-inputs exp) - (((($ (@@ (guix gexp) <system-binding>)) "out")) - '(system-binding)) + ((input) + (and (eq? (struct-vtable (gexp-input-thing input)) + (@@ (guix gexp) <system-binding>)) + (string=? (gexp-input-output input) "out") + '(system-binding))) (x x)) - (gexp-native-inputs exp) 'low (lowered-gexp-inputs low) (lowered-gexp-sources low)))) @@ -371,7 +380,6 @@ (test-equal "let-system, nested" (list `(system* ,(string-append "qemu-system-" (%current-system)) "-m" "256") - '() '(system-binding)) (let ((exp #~(system* #+(let-system (system target) @@ -386,10 +394,13 @@ (basename command)) ,@rest)) (x x)) - (gexp-inputs exp) - (match (gexp-native-inputs exp) - (((($ (@@ (guix gexp) <system-binding>)) "out")) - '(system-binding)) + (match (gexp-inputs exp) + ((input) + (and (eq? (struct-vtable (gexp-input-thing input)) + (@@ (guix gexp) <system-binding>)) + (string=? (gexp-input-output input) "out") + (gexp-input-native? input) + '(system-binding))) (x x))))) (test-assert "ungexp + ungexp-native" @@ -407,27 +418,26 @@ (bu (derivation->output-path (package-cross-derivation %store binutils target)))) (and (lset= equal? - `((,%bootstrap-guile "out") (,glibc "out")) - (gexp-native-inputs exp)) - (lset= equal? - `((,coreutils "out") (,binutils "out")) - (gexp-inputs exp)) + `((,%bootstrap-guile "out" #t) + (,coreutils "out" #f) + (,glibc "out" #t) + (,binutils "out" #f)) + (map gexp-input->tuple (gexp-inputs exp))) (equal? `(list ,guile ,cu ,libc ,bu) (gexp->sexp* exp target))))) (test-equal "ungexp + ungexp-native, nested" - (list `((,%bootstrap-guile "out")) '<> `((,coreutils "out"))) + `((,%bootstrap-guile "out" #f) (,coreutils "out" #t)) (let* ((exp (gexp (list (ungexp-native (gexp (ungexp coreutils))) (ungexp %bootstrap-guile))))) - (list (gexp-inputs exp) '<> (gexp-native-inputs exp)))) + (map gexp-input->tuple (gexp-inputs exp)))) (test-equal "ungexp + ungexp-native, nested, special mixture" - `(() <> ((,coreutils "out"))) + `((,coreutils "out" #t)) - ;; (gexp-native-inputs exp) used to return '(), wrongfully. (let* ((foo (gexp (foo (ungexp-native coreutils)))) (exp (gexp (bar (ungexp foo))))) - (list (gexp-inputs exp) '<> (gexp-native-inputs exp)))) + (map gexp-input->tuple (gexp-inputs exp)))) (test-assert "input list" (let ((exp (gexp (display @@ -437,8 +447,8 @@ (cu (derivation->output-path (package-derivation %store coreutils)))) (and (lset= equal? - `((,%bootstrap-guile "out") (,coreutils "out")) - (gexp-inputs exp)) + `((,%bootstrap-guile "out" #f) (,coreutils "out" #f)) + (map gexp-input->tuple (gexp-inputs exp))) (equal? `(display '(,guile ,cu)) (gexp->sexp* exp))))) @@ -456,11 +466,9 @@ (xbu (derivation->output-path (package-cross-derivation %store binutils target)))) (and (lset= equal? - `((,%bootstrap-guile "out") (,coreutils "out")) - (gexp-native-inputs exp)) - (lset= equal? - `((,glibc "out") (,binutils "out")) - (gexp-inputs exp)) + `((,%bootstrap-guile "out" #t) (,coreutils "out" #t) + (,glibc "out" #f) (,binutils "out" #f)) + (map gexp-input->tuple (gexp-inputs exp))) (equal? `(display (cons '(,guile ,cu) '(,xlibc ,xbu))) (gexp->sexp* exp target))))) @@ -473,8 +481,8 @@ (package-derivation %store %bootstrap-guile)))) (exp (gexp (list (ungexp-splicing (cons (+ 2 3) inputs)))))) (and (lset= equal? - `((,glibc "debug") (,%bootstrap-guile "out")) - (gexp-inputs exp)) + `((,glibc "debug" #f) (,%bootstrap-guile "out" #f)) + (map gexp-input->tuple (gexp-inputs exp))) (equal? (gexp->sexp* exp) `(list ,@(cons 5 outputs)))))) @@ -483,17 +491,16 @@ %bootstrap-guile)) (exp (gexp (list (ungexp-native-splicing (cons (+ 2 3) inputs)))))) (and (lset= equal? - `((,glibc "debug") (,%bootstrap-guile "out")) - (gexp-native-inputs exp)) - (null? (gexp-inputs exp)) + `((,glibc "debug" #t) (,%bootstrap-guile "out" #t)) + (map gexp-input->tuple (gexp-inputs exp))) (equal? (gexp->sexp* exp) ;native (gexp->sexp* exp "mips64el-linux"))))) (test-assert "gexp list splicing + ungexp-splicing" (let* ((inner (gexp (ungexp-native glibc))) (exp (gexp (list (ungexp-splicing (list inner)))))) - (and (equal? `((,glibc "out")) (gexp-native-inputs exp)) - (null? (gexp-inputs exp)) + (and (equal? `((,glibc "out" #t)) + (map gexp-input->tuple (gexp-inputs exp))) (equal? (gexp->sexp* exp) ;native (gexp->sexp* exp "mips64el-linux"))))) @@ -532,7 +539,7 @@ (test-assertm "gexp->file" (mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile)))) (guile (package-file %bootstrap-guile)) - (sexp (gexp->sexp exp)) + (sexp (gexp->sexp exp (%current-system) #f)) (drv (gexp->file "foo" exp)) (out -> (derivation->output-path drv)) (done (built-derivations (list drv))) @@ -1088,6 +1095,22 @@ importing.* \\(guix config\\) from the host" (call-with-input-file g-guile read) (list (derivation->output-path guile-drv) bash)))))) +(test-assertm "gexp->derivation #:references-graphs cross-compilation" + ;; The objects passed in #:references-graphs implicitly refer to + ;; cross-compiled derivations. Make sure this is the case. + (mlet* %store-monad ((drv1 (lower-object coreutils (%current-system) + #:target "i586-pc-gnu")) + (drv2 (lower-object coreutils (%current-system) + #:target #f)) + (drv3 (gexp->derivation "three" + #~(symlink #$coreutils #$output) + #:target "i586-pc-gnu" + #:references-graphs + `(("coreutils" ,coreutils)))) + (refs (references* (derivation-file-name drv3)))) + (return (and (member (derivation-file-name drv1) refs) + (not (member (derivation-file-name drv2) refs)))))) + (test-assertm "gexp->derivation #:allowed-references" (mlet %store-monad ((drv (gexp->derivation "allowed-refs" #~(begin diff --git a/tests/guix-lint.sh b/tests/guix-lint.sh index fdf548fbf1..97c2ea83fe 100644 --- a/tests/guix-lint.sh +++ b/tests/guix-lint.sh @@ -90,3 +90,8 @@ guix lint -L $module_dir -c inputs-should-be-native dummy dummy@42 dummy # that it does find it anyway. See <https://bugs.gnu.org/42543>. (cd "$module_dir"/.. ; guix lint -c formatting -L "$(basename "$module_dir")" dummy@42) 2>&1 > "$module_dir/out" test -z "$(cat "$module_dir/out")" + +# Likewise, when there's a warning, 'package-field-location' used to crash +# because it can't find "t-xyz/foo.scm". See <https://bugs.gnu.org/46390>. +(cd "$module_dir"/.. ; guix lint -c synopsis -L "$(basename "$module_dir")" dummy@42) 2>&1 > "$module_dir/out" +grep_warning "`cat "$module_dir/out"`" diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 7eaad6823f..39e2b514c3 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -386,6 +386,21 @@ guix package -I # '--dry-run' is passed. GUIX_BUILD_OPTIONS="--no-grafts" +# Install using the "imperative model", export a manifest, instantiate it, and +# make sure we get the same profile. +guix package --bootstrap -i guile-bootstrap --without-tests=foo +profile_directory="$(readlink -f "$default_profile")" +guix package --export-manifest > "$tmpfile" +grep 'without-tests.*foo' "$tmpfile" +guix package --rollback --bootstrap +guix package --bootstrap -m "$tmpfile" +test "$(readlink -f "$default_profile")" = "$profile_directory" +guix package --export-manifest > "$tmpfile.2nd" +cmp "$tmpfile" "$tmpfile.2nd" + +rm -f "$tmpfile.2nd" +guix package --rollback --bootstrap + # Applying a manifest file. cat > "$module_dir/manifest.scm"<<EOF (use-package-modules bootstrap) diff --git a/tests/guix-system.sh b/tests/guix-system.sh index 24cc2591d5..238c8929a8 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -337,12 +337,11 @@ for example in gnu/system/examples/*.tmpl; do guix system -n disk-image $target "$example" done -# Verify that the disk image types can be built. +# Verify that the images 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 -t iso9660 gnu/system/examples/bare-bones.tmpl +guix system -n image gnu/system/images/pinebook-pro.scm +guix system -n image -t qcow2 gnu/system/examples/vm-image.tmpl +guix system -n image -t iso9660 gnu/system/examples/bare-bones.tmpl guix system -n docker-image gnu/system/examples/docker-image.tmpl # Verify that at least the raw image type is available. diff --git a/tests/services/file-sharing.scm b/tests/services/file-sharing.scm new file mode 100644 index 0000000000..27bec57325 --- /dev/null +++ b/tests/services/file-sharing.scm @@ -0,0 +1,59 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Simon South <simon@simonsouth.net> +;;; +;;; 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 services file-sharing) + #:use-module (gnu services file-sharing) + #:use-module (srfi srfi-64)) + +;;; Tests for the (gnu services file-sharing) module. + +(test-begin "file-sharing") + + +;;; +;;; Transmission Daemon. +;;; + +(define %transmission-salt-length 8) + +(define (valid-transmission-salt? salt) + (and (string? salt) + (eqv? (string-length salt) %transmission-salt-length))) + +(test-assert "transmission-random-salt" + (valid-transmission-salt? (transmission-random-salt))) + +(test-equal "transmission-password-hash, typical values" + "{ef6fba106cdef3aac64d1410090cae353cbecde53ceVVQO2" + (transmission-password-hash "transmission" "3ceVVQO2")) + +(test-equal "transmission-password-hash, empty password" + "{820f816515d8969d058d07a1de018650619ee7ffCp.I5SWg" + (transmission-password-hash "" "Cp.I5SWg")) + +(test-error "transmission-password-hash, salt value too short" + (transmission-password-hash + "transmission" + (make-string (- %transmission-salt-length 1) #\a))) + +(test-error "transmission-password-hash, salt value too long" + (transmission-password-hash + "transmission" + (make-string (+ %transmission-salt-length 1) #\a))) + +(test-end "file-sharing") diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 09aa228e8e..706dd4177f 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2020 Simon South <simon@simonsouth.net> ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> @@ -56,6 +56,20 @@ ;; Both return values have been encountered in the wild. (memv (system-error-errno args) (list EPERM ENOENT))))) +(test-assert "mounts" + ;; Check for one of the common mount points. + (let ((mounts (mounts))) + (any (match-lambda + ((point . type) + (let ((mount (find (lambda (mount) + (string=? (mount-point mount) point)) + mounts))) + (and mount + (string=? (mount-type mount) type))))) + '(("/proc" . "proc") + ("/sys" . "sysfs") + ("/dev/shm" . "tmpfs"))))) + (test-assert "mount-points" ;; Reportedly "/" is not always listed as a mount point, so check a few ;; others (see <http://bugs.gnu.org/20261>.) diff --git a/tests/transformations.scm b/tests/transformations.scm index 7877029486..902bd45a6a 100644 --- a/tests/transformations.scm +++ b/tests/transformations.scm @@ -20,6 +20,9 @@ #:use-module (guix tests) #:use-module (guix store) #:use-module ((guix gexp) #:select (lower-object)) + #:use-module ((guix profiles) + #:select (package->manifest-entry + manifest-entry-properties)) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix git-download) @@ -413,6 +416,13 @@ `((with-latest . "foo"))))) (package-version (t p))))) +(test-equal "options->transformation + package->manifest-entry" + '((transformations . ((without-tests . "foo")))) + (let* ((p (dummy-package "foo")) + (t (options->transformation '((without-tests . "foo")))) + (e (package->manifest-entry (t p)))) + (manifest-entry-properties e))) + (test-end) ;;; Local Variables: |