diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/gexp.scm | 244 | ||||
| -rw-r--r-- | tests/guix-authenticate.sh | 21 | ||||
| -rw-r--r-- | tests/guix-build.sh | 7 | ||||
| -rw-r--r-- | tests/monads.scm | 3 | ||||
| -rw-r--r-- | tests/pk-crypto.scm | 24 | ||||
| -rw-r--r-- | tests/store.scm | 3 | ||||
| -rw-r--r-- | tests/syscalls.scm | 48 | ||||
| -rw-r--r-- | tests/ui.scm | 12 | ||||
| -rw-r--r-- | tests/utils.scm | 6 |
9 files changed, 362 insertions, 6 deletions
diff --git a/tests/gexp.scm b/tests/gexp.scm new file mode 100644 index 0000000000..21606b510b --- /dev/null +++ b/tests/gexp.scm @@ -0,0 +1,244 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 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-gexp) + #:use-module (guix store) + #:use-module (guix monads) + #:use-module (guix gexp) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (gnu packages) + #:use-module (gnu packages base) + #:use-module (gnu packages bootstrap) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (rnrs io ports) + #:use-module (ice-9 match) + #:use-module (ice-9 popen)) + +;; Test the (guix gexp) module. + +(define %store + (open-connection)) + +;; For white-box testing. +(define gexp-inputs (@@ (guix gexp) gexp-inputs)) +(define gexp->sexp (@@ (guix gexp) gexp->sexp)) + +(define guile-for-build + (package-derivation %store %bootstrap-guile)) + +;; Make it the default. +(%guile-for-build guile-for-build) + +(define (gexp->sexp* exp) + (run-with-store %store (gexp->sexp exp) + #:guile-for-build guile-for-build)) + +(define-syntax-rule (test-assertm name exp) + (test-assert name + (run-with-store %store exp + #:guile-for-build guile-for-build))) + + +(test-begin "gexp") + +(test-equal "no refs" + '(display "hello!") + (let ((exp (gexp (display "hello!")))) + (and (gexp? exp) + (null? (gexp-inputs exp)) + (gexp->sexp* exp)))) + +(test-equal "unquote" + '(display `(foo ,(+ 2 3))) + (let ((exp (gexp (display `(foo ,(+ 2 3)))))) + (and (gexp? exp) + (null? (gexp-inputs exp)) + (gexp->sexp* exp)))) + +(test-assert "one input package" + (let ((exp (gexp (display (ungexp coreutils))))) + (and (gexp? exp) + (match (gexp-inputs exp) + (((p "out")) + (eq? p coreutils))) + (equal? `(display ,(derivation->output-path + (package-derivation %store coreutils))) + (gexp->sexp* exp))))) + +(test-assert "one input origin" + (let ((exp (gexp (display (ungexp (package-source coreutils)))))) + (and (gexp? exp) + (match (gexp-inputs exp) + (((o "out")) + (eq? o (package-source coreutils)))) + (equal? `(display ,(derivation->output-path + (package-source-derivation + %store (package-source coreutils)))) + (gexp->sexp* exp))))) + +(test-assert "same input twice" + (let ((exp (gexp (begin + (display (ungexp coreutils)) + (display (ungexp coreutils)))))) + (and (gexp? exp) + (match (gexp-inputs exp) + (((p "out")) + (eq? p coreutils))) + (let ((e `(display ,(derivation->output-path + (package-derivation %store coreutils))))) + (equal? `(begin ,e ,e) (gexp->sexp* exp)))))) + +(test-assert "two input packages, one derivation, one file" + (let* ((drv (build-expression->derivation + %store "foo" 'bar + #:guile-for-build (package-derivation %store %bootstrap-guile))) + (txt (add-text-to-store %store "foo" "Hello, world!")) + (exp (gexp (begin + (display (ungexp coreutils)) + (display (ungexp %bootstrap-guile)) + (display (ungexp drv)) + (display (ungexp txt)))))) + (define (match-input thing) + (match-lambda + ((drv-or-pkg _ ...) + (eq? thing drv-or-pkg)))) + + (and (gexp? exp) + (= 4 (length (gexp-inputs exp))) + (every (lambda (input) + (find (match-input input) (gexp-inputs exp))) + (list drv coreutils %bootstrap-guile txt)) + (let ((e0 `(display ,(derivation->output-path + (package-derivation %store coreutils)))) + (e1 `(display ,(derivation->output-path + (package-derivation %store %bootstrap-guile)))) + (e2 `(display ,(derivation->output-path drv))) + (e3 `(display ,txt))) + (equal? `(begin ,e0 ,e1 ,e2 ,e3) (gexp->sexp* exp)))))) + +(test-assert "input list" + (let ((exp (gexp (display + '(ungexp (list %bootstrap-guile coreutils))))) + (guile (derivation->output-path + (package-derivation %store %bootstrap-guile))) + (cu (derivation->output-path + (package-derivation %store coreutils)))) + (and (lset= equal? + `((,%bootstrap-guile "out") (,coreutils "out")) + (gexp-inputs exp)) + (equal? `(display '(,guile ,cu)) + (gexp->sexp* exp))))) + +(test-assert "input list splicing" + (let* ((inputs (list (list glibc "debug") %bootstrap-guile)) + (outputs (list (derivation->output-path + (package-derivation %store glibc) + "debug") + (derivation->output-path + (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)) + (equal? (gexp->sexp* exp) + `(list ,@(cons 5 outputs)))))) + +(test-assertm "gexp->file" + (mlet* %store-monad ((exp -> (gexp (display (ungexp %bootstrap-guile)))) + (guile (package-file %bootstrap-guile)) + (sexp (gexp->sexp exp)) + (drv (gexp->file "foo" exp)) + (out -> (derivation->output-path drv)) + (done (built-derivations (list drv))) + (refs ((store-lift references) out))) + (return (and (equal? sexp (call-with-input-file out read)) + (equal? (list guile) refs))))) + +(test-assertm "gexp->derivation" + (mlet* %store-monad ((file (text-file "foo" "Hello, world!")) + (exp -> (gexp + (begin + (mkdir (ungexp output)) + (chdir (ungexp output)) + (symlink + (string-append (ungexp %bootstrap-guile) + "/bin/guile") + "foo") + (symlink (ungexp file) + (ungexp output "2nd"))))) + (drv (gexp->derivation "foo" exp)) + (out -> (derivation->output-path drv)) + (out2 -> (derivation->output-path drv "2nd")) + (done (built-derivations (list drv))) + (refs ((store-lift references) out)) + (refs2 ((store-lift references) out2)) + (guile (package-file %bootstrap-guile "bin/guile"))) + (return (and (string=? (readlink (string-append out "/foo")) guile) + (string=? (readlink out2) file) + (equal? refs (list (dirname (dirname guile)))) + (equal? refs2 (list file)))))) + +(test-assertm "gexp->derivation, composed gexps" + (mlet* %store-monad ((exp0 -> (gexp (begin + (mkdir (ungexp output)) + (chdir (ungexp output))))) + (exp1 -> (gexp (symlink + (string-append (ungexp %bootstrap-guile) + "/bin/guile") + "foo"))) + (exp -> (gexp (begin (ungexp exp0) (ungexp exp1)))) + (drv (gexp->derivation "foo" exp)) + (out -> (derivation->output-path drv)) + (done (built-derivations (list drv))) + (guile (package-file %bootstrap-guile "bin/guile"))) + (return (string=? (readlink (string-append out "/foo")) + guile)))) + +(test-assertm "gexp->script" + (mlet* %store-monad ((n -> (random (expt 2 50))) + (exp -> (gexp + (system* + (string-append (ungexp %bootstrap-guile) + "/bin/guile") + "-c" (object->string + '(display (expt (ungexp n) 2)))))) + (drv (gexp->script "guile-thing" exp + #:guile %bootstrap-guile)) + (out -> (derivation->output-path drv)) + (done (built-derivations (list drv)))) + (let* ((pipe (open-input-pipe out)) + (str (get-string-all pipe))) + (return (and (zero? (close-pipe pipe)) + (= (expt n 2) (string->number str))))))) + +(test-equal "sugar" + '(gexp (foo (ungexp bar) (ungexp baz "out") + (ungexp (chbouib 42)) + (ungexp-splicing (list x y z)))) + '#~(foo #$bar #$baz:out #$(chbouib 42) #$@(list x y z))) + +(test-end "gexp") + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) + +;; Local Variables: +;; eval: (put 'test-assertm 'scheme-indent-function 1) +;; End: diff --git a/tests/guix-authenticate.sh b/tests/guix-authenticate.sh index 35ec7ffd6a..72c3d161d7 100644 --- a/tests/guix-authenticate.sh +++ b/tests/guix-authenticate.sh @@ -72,3 +72,24 @@ if guix authenticate rsautl -verify \ then false else true fi + + +# Test for <http://bugs.gnu.org/17312>: make sure 'guix authenticate' produces +# valid signatures when run in the C locale. +echo "5eff0b55c9c5f5e87b4e34cd60a2d5654ca1eb78c7b3c67c3179fed1cff07b4c" \ + > "$hash" + +LC_ALL=C +export LC_ALL + +guix authenticate rsautl -sign \ + -inkey "$abs_top_srcdir/tests/signing-key.sec" \ + -in "$hash" > "$sig" + +guix authenticate rsautl -verify \ + -inkey "$abs_top_srcdir/tests/signing-key.pub" \ + -pubin -in "$sig" +hash2="`guix authenticate rsautl -verify \ + -inkey $abs_top_srcdir/tests/signing-key.pub \ + -pubin -in $sig`" +test "$hash2" = `cat "$hash"` diff --git a/tests/guix-build.sh b/tests/guix-build.sh index d66e132c1f..e0c774d055 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> # # This file is part of GNU Guix. # @@ -75,7 +75,8 @@ then false; else true; fi # Invoking a monadic procedure. guix build -e "(begin - (use-modules (guix monads) (guix utils)) + (use-modules (guix gexp)) (lambda () - (derivation-expression \"test\" '(mkdir %output))))" \ + (gexp->derivation \"test\" + (gexp (mkdir (ungexp output))))))" \ --dry-run diff --git a/tests/monads.scm b/tests/monads.scm index b51e705f01..82f4b9989c 100644 --- a/tests/monads.scm +++ b/tests/monads.scm @@ -108,6 +108,9 @@ guile))) #:guile-for-build (package-derivation %store %bootstrap-guile))) +(define derivation-expression + (@@ (guix monads) derivation-expression)) + (test-assert "mlet* + derivation-expression" (run-with-store %store (mlet* %store-monad ((guile (package-file %bootstrap-guile "bin/guile")) diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm index 294c7f3df8..f5008f3248 100644 --- a/tests/pk-crypto.scm +++ b/tests/pk-crypto.scm @@ -64,6 +64,9 @@ (test-begin "pk-crypto") +(test-assert "version" + (gcrypt-version)) + (let ((sexps '("(foo bar)" ;; In Libgcrypt 1.5.3 the following integer is rendered as @@ -142,6 +145,27 @@ 1+ 0))) +(let ((bv (base16-string->bytevector + "5eff0b55c9c5f5e87b4e34cd60a2d5654ca1eb78c7b3c67c3179fed1cff07b4c"))) + (test-equal "hash corrupt due to restrictive locale encoding" + bv + + ;; In Guix up to 0.6 included this test would fail because at some point + ;; the hash value would be cropped to ASCII. In practice 'guix + ;; authenticate' would produce invalid signatures that would fail + ;; signature verification. See <http://bugs.gnu.org/17312>. + (let ((locale (setlocale LC_ALL))) + (dynamic-wind + (lambda () + (setlocale LC_ALL "C")) + (lambda () + (hash-data->bytevector + (string->canonical-sexp + (canonical-sexp->string + (bytevector->hash-data bv "sha256"))))) + (lambda () + (setlocale LC_ALL locale)))))) + (gc) ;; XXX: The test below is typically too long as it needs to gather enough entropy. diff --git a/tests/store.scm b/tests/store.scm index 90137b9754..b0f609f818 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -85,7 +85,8 @@ (not (direct-store-path? (string-append (%store-prefix) - "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile"))))) + "/283gqy39v3g9dxjy26rynl0zls82fmcg-guile-2.0.7/bin/guile"))) + (not (direct-store-path? (%store-prefix))))) (test-skip (if %store 0 13)) diff --git a/tests/syscalls.scm b/tests/syscalls.scm new file mode 100644 index 0000000000..ab34fc825b --- /dev/null +++ b/tests/syscalls.scm @@ -0,0 +1,48 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 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-syscalls) + #:use-module (guix build syscalls) + #:use-module (srfi srfi-64)) + +;; Test the (guix build syscalls) module, although there's not much that can +;; actually be tested without being root. + +(test-begin "syscalls") + +(test-equal "mount, ENOENT" + ENOENT + (catch 'system-error + (lambda () + (mount "/dev/null" "/does-not-exist" "ext2") + #f) + (compose system-error-errno list))) + +(test-assert "umount, ENOENT/EPERM" + (catch 'system-error + (lambda () + (umount "/does-not-exist") + #f) + (lambda args + ;; Both return values have been encountered in the wild. + (memv (system-error-errno args) (list EPERM ENOENT))))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) diff --git a/tests/ui.scm b/tests/ui.scm index 886223ef54..4bf7a779c5 100644 --- a/tests/ui.scm +++ b/tests/ui.scm @@ -19,6 +19,8 @@ (define-module (test-ui) #:use-module (guix ui) + #:use-module (guix store) + #:use-module (guix derivations) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-64)) @@ -189,6 +191,16 @@ interface, and powerful string processing.") (lambda args #t))) +(test-equal "show-what-to-build, zero outputs" + "" + (with-store store + (let ((drv (derivation store "zero" "/bin/sh" '() + #:outputs '()))) + (with-error-to-string + (lambda () + ;; This should print nothing. + (show-what-to-build store (list drv))))))) + (test-end "ui") diff --git a/tests/utils.scm b/tests/utils.scm index 4d2d123c6b..8ad399f75c 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -164,10 +164,12 @@ (false-if-exception (delete-file temp-file)) (test-assert "compressed-output-port + decompressed-port" (let* ((file (search-path %load-path "guix/derivations.scm")) - (data (call-with-input-file file get-bytevector-all))) - (call-with-compressed-output-port 'xz (open-file temp-file "w0b") + (data (call-with-input-file file get-bytevector-all)) + (port (open-file temp-file "w0b"))) + (call-with-compressed-output-port 'xz port (lambda (compressed) (put-bytevector compressed data))) + (close-port port) (bytevector=? data (call-with-decompressed-port 'xz (open-file temp-file "r0b") |