diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/containers.scm | 4 | ||||
| -rw-r--r-- | tests/gexp.scm | 64 | ||||
| -rw-r--r-- | tests/guix-environment.sh | 12 | ||||
| -rw-r--r-- | tests/guix-system.sh | 6 | ||||
| -rw-r--r-- | tests/services.scm | 91 | ||||
| -rw-r--r-- | tests/utils.scm | 14 |
6 files changed, 189 insertions, 2 deletions
diff --git a/tests/containers.scm b/tests/containers.scm index 4783f8e8a5..0ba81491ba 100644 --- a/tests/containers.scm +++ b/tests/containers.scm @@ -34,6 +34,10 @@ (test-begin "containers") +(test-assert "call-with-container, exit with 0 when there is no error" + (zero? + (call-with-container '() (const #t) #:namespaces '(user)))) + (test-assert "call-with-container, user namespace" (zero? (call-with-container '() diff --git a/tests/gexp.scm b/tests/gexp.scm index 492f3d6d89..4860a8e79c 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -619,6 +619,36 @@ (return (and (zero? (close-pipe pipe)) (= (expt n 2) (string->number str))))))) +(test-assertm "program-file" + (let* ((n (random (expt 2 50))) + (exp (gexp (begin + (use-modules (guix build utils)) + (display (ungexp n))))) + (file (program-file "program" exp + #:modules '((guix build utils)) + #:guile %bootstrap-guile))) + (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)) + (= n (string->number str))))))))) + +(test-assertm "scheme-file" + (let* ((text (plain-file "foo" "Hello, world!")) + (scheme (scheme-file "bar" #~(list "foo" #$text)))) + (mlet* %store-monad ((drv (lower-object scheme)) + (text (lower-object text)) + (out -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (mlet %store-monad ((refs ((store-lift references) out))) + (return (and (equal? refs (list text)) + (equal? `(list "foo" ,text) + (call-with-input-file out read))))))))) + (test-assert "text-file*" (let ((references (store-lift references))) (run-with-store %store @@ -643,6 +673,21 @@ file))))) #:guile-for-build (package-derivation %store %bootstrap-guile)))) +(test-assertm "mixed-text-file" + (mlet* %store-monad ((file -> (mixed-text-file "mixed" + "export PATH=" + %bootstrap-guile "/bin")) + (drv (lower-object file)) + (out -> (derivation->output-path drv)) + (guile-drv (package->derivation %bootstrap-guile)) + (guile -> (derivation->output-path guile-drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (mlet %store-monad ((refs ((store-lift references) out))) + (return (and (string=? (string-append "export PATH=" guile "/bin") + (call-with-input-file out get-string-all)) + (equal? refs (list guile)))))))) + (test-assert "gexp->derivation vs. %current-target-system" (let ((mval (gexp->derivation "foo" #~(begin @@ -661,6 +706,25 @@ (return (and (derivation? drv1) (derivation? drv2) (store-path? item))))) +(test-assertm "lower-object, computed-file" + (let* ((text (plain-file "foo" "Hello!")) + (exp #~(begin + (mkdir #$output) + (symlink #$%bootstrap-guile + (string-append #$output "/guile")) + (symlink #$text (string-append #$output "/text")))) + (computed (computed-file "computed" exp))) + (mlet* %store-monad ((text (lower-object text)) + (guile-drv (lower-object %bootstrap-guile)) + (comp-drv (lower-object computed)) + (comp -> (derivation->output-path comp-drv))) + (mbegin %store-monad + (built-derivations (list comp-drv)) + (return (and (string=? (readlink (string-append comp "/guile")) + (derivation->output-path guile-drv)) + (string=? (readlink (string-append comp "/text")) + text))))))) + (test-assert "printer" (string-match "^#<gexp \\(string-append .*#<package coreutils.*\ \"/bin/uname\"\\) [[:xdigit:]]+>$" diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index 32faf71a4e..f91c78a801 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -40,7 +40,15 @@ test "`wc -l < "$tmpdir/a"`" = 1 cmp "$tmpdir/a" "$tmpdir/b" # Make sure the exit value is preserved. -if guix environment --ad-hoc guile-bootstrap --pure -E 'guile -c "(exit 42)"' +if guix environment --ad-hoc guile-bootstrap --pure -- guile -c '(exit 42)' +then + false +else + test $? = 42 +fi + +# Same as above, but with deprecated -E flag. +if guix environment --ad-hoc guile-bootstrap --pure -E "guile -c '(exit 42)'" then false else @@ -66,7 +74,7 @@ then # as returned by '--search-paths'. guix environment -e '(@@ (gnu packages commencement) gnu-make-boot0)' \ --no-substitutes --pure \ - --exec='echo $PATH $CPATH $LIBRARY_PATH' > "$tmpdir/b" + -- /bin/sh -c 'echo $PATH $CPATH $LIBRARY_PATH' > "$tmpdir/b" ( . "$tmpdir/a" ; echo $PATH $CPATH $LIBRARY_PATH ) > "$tmpdir/c" cmp "$tmpdir/b" "$tmpdir/c" diff --git a/tests/guix-system.sh b/tests/guix-system.sh index 4289db2390..d99c9bd07b 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -132,6 +132,12 @@ EOF make_user_config "users" "wheel" guix system build "$tmpfile" -n # succeeds +guix system build "$tmpfile" -d # succeeds +guix system build "$tmpfile" -d | grep '\.drv$' + +guix system vm "$tmpfile" -d # succeeds +guix system vm "$tmpfile" -d | grep '\.drv$' + make_user_config "group-that-does-not-exist" "users" if guix system build "$tmpfile" -n 2> "$errorfile" then false diff --git a/tests/services.scm b/tests/services.scm new file mode 100644 index 0000000000..b4e2cb0b30 --- /dev/null +++ b/tests/services.scm @@ -0,0 +1,91 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 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-services) + #:use-module (gnu services) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-64)) + +(test-begin "services") + +(test-equal "fold-services" + ;; Make sure 'fold-services' returns the right result. The numbers come + ;; from services of type T3; 'xyz 60' comes from the service of type T2, + ;; where 60 = 15 × 4 = (1 + 2 + 3 + 4 + 5) × 4. + '(initial-value 5 4 3 2 1 xyz 60) + (let* ((t1 (service-type (name 't1) (extensions '()) + (compose concatenate) + (extend cons))) + (t2 (service-type (name 't2) + (extensions + (list (service-extension t1 + (cut list 'xyz <>)))) + (compose (cut reduce + 0 <>)) + (extend *))) + (t3 (service-type (name 't3) + (extensions + (list (service-extension t2 identity) + (service-extension t1 list))))) + (r (fold-services (cons* (service t1 'initial-value) + (service t2 4) + (map (lambda (x) + (service t3 x)) + (iota 5 1))) + #:target-type t1))) + (and (eq? (service-kind r) t1) + (service-parameters r)))) + +(test-assert "fold-services, ambiguity" + (let* ((t1 (service-type (name 't1) (extensions '()) + (compose concatenate) + (extend cons))) + (t2 (service-type (name 't2) + (extensions + (list (service-extension t1 list))))) + (s (service t2 42))) + (guard (c ((ambiguous-target-service-error? c) + (and (eq? (ambiguous-target-service-error-target-type c) + t1) + (eq? (ambiguous-target-service-error-service c) + s)))) + (fold-services (list (service t1 'first) + (service t1 'second) + s) + #:target-type t1) + #f))) + +(test-assert "fold-services, missing target" + (let* ((t1 (service-type (name 't1) (extensions '()))) + (t2 (service-type (name 't2) + (extensions + (list (service-extension t1 list))))) + (s (service t2 42))) + (guard (c ((missing-target-service-error? c) + (and (eq? (missing-target-service-error-target-type c) + t1) + (eq? (missing-target-service-error-service c) + s)))) + (fold-services (list s) #:target-type t1) + #f))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) diff --git a/tests/utils.scm b/tests/utils.scm index 115868c857..b65d6d20ba 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -121,6 +121,20 @@ '(0 1 2 3))) list)) +(test-equal "split, element is in list" + '((foo) (baz)) + (call-with-values + (lambda () + (split '(foo bar baz) 'bar)) + list)) + +(test-equal "split, element is not in list" + '((foo bar baz) ()) + (call-with-values + (lambda () + (split '(foo bar baz) 'quux)) + list)) + (test-equal "strip-keyword-arguments" '(a #:b b #:c c) (strip-keyword-arguments '(#:foo #:bar #:baz) |