diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/gexp.scm | 26 | ||||
| -rw-r--r-- | tests/lint.scm | 23 | ||||
| -rw-r--r-- | tests/monads.scm | 47 | ||||
| -rw-r--r-- | tests/sets.scm | 52 |
4 files changed, 96 insertions, 52 deletions
diff --git a/tests/gexp.scm b/tests/gexp.scm index ea4df48403..d80f14344d 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -421,6 +421,30 @@ (return (and (zero? (close-pipe pipe)) (= (expt n 2) (string->number str))))))) +(test-assert "text-file*" + (let ((references (store-lift references))) + (run-with-store %store + (mlet* %store-monad + ((drv (package->derivation %bootstrap-guile)) + (guile -> (derivation->output-path drv)) + (file (text-file "bar" "This is bar.")) + (text (text-file* "foo" + %bootstrap-guile "/bin/guile " + `(,%bootstrap-guile "out") "/bin/guile " + drv "/bin/guile " + file)) + (done (built-derivations (list text))) + (out -> (derivation->output-path text)) + (refs (references out))) + ;; Make sure we get the right references and the right content. + (return (and (lset= string=? refs (list guile file)) + (equal? (call-with-input-file out get-string-all) + (string-append guile "/bin/guile " + guile "/bin/guile " + guile "/bin/guile " + file))))) + #:guile-for-build (package-derivation %store %bootstrap-guile)))) + (test-assert "printer" (string-match "^#<gexp \\(string-append .*#<package coreutils.*\ \"/bin/uname\"\\) [[:xdigit:]]+>$" diff --git a/tests/lint.scm b/tests/lint.scm index c6931329d6..27be5598de 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 Eric Bavier <bavier@member.fsf.org> -;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -75,9 +75,20 @@ (quit #t) ;exit the server thread (values))) +;; Mutex and condition variable to synchronize with the HTTP server. +(define %http-server-lock (make-mutex)) +(define %http-server-ready (make-condition-variable)) + +(define (http-open . args) + "Start listening for HTTP requests and signal %HTTP-SERVER-READY." + (with-mutex %http-server-lock + (let ((result (apply (@@ (web server http) http-open) args))) + (signal-condition-variable %http-server-ready) + result))) + (define-server-impl stub-http-server ;; Stripped-down version of Guile's built-in HTTP server. - (@@ (web server http) http-open) + http-open (@@ (web server http) http-read) http-write (@@ (web server http) http-close)) @@ -97,9 +108,11 @@ requests." `(#:socket ,%http-server-socket))) (const #t))) - (let* ((server (make-thread server-body))) - ;; Normally SERVER exits automatically once it has received a request. - (thunk))) + (with-mutex %http-server-lock + (let ((server (make-thread server-body))) + (wait-condition-variable %http-server-ready %http-server-lock) + ;; Normally SERVER exits automatically once it has received a request. + (thunk)))) (define-syntax-rule (with-http-server code body ...) (call-with-http-server code (lambda () body ...))) diff --git a/tests/monads.scm b/tests/monads.scm index 6e3dd00f72..9c3cdd20a7 100644 --- a/tests/monads.scm +++ b/tests/monads.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -156,51 +156,6 @@ (call-with-input-file b get-string-all)))) #: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")) - (gdrv (package->derivation %bootstrap-guile)) - (exp -> `(let ((out (assoc-ref %outputs "out"))) - (mkdir out) - (symlink ,guile - (string-append out "/guile-rocks")))) - (drv (derivation-expression "rocks" exp - #:inputs - `(("g" ,gdrv)))) - (out -> (derivation->output-path drv)) - (built? (built-derivations (list drv)))) - (return (and built? - (equal? guile - (readlink (string-append out "/guile-rocks")))))) - #:guile-for-build (package-derivation %store %bootstrap-guile))) - -(test-assert "text-file*" - (let ((references (store-lift references))) - (run-with-store %store - (mlet* %store-monad - ((drv (package->derivation %bootstrap-guile)) - (guile -> (derivation->output-path drv)) - (file (text-file "bar" "This is bar.")) - (text (text-file* "foo" - %bootstrap-guile "/bin/guile " - `(,%bootstrap-guile "out") "/bin/guile " - drv "/bin/guile " - file)) - (done (built-derivations (list text))) - (out -> (derivation->output-path text)) - (refs (references out))) - ;; Make sure we get the right references and the right content. - (return (and (lset= string=? refs (list guile file)) - (equal? (call-with-input-file out get-string-all) - (string-append guile "/bin/guile " - guile "/bin/guile " - guile "/bin/guile " - file))))) - #:guile-for-build (package-derivation %store %bootstrap-guile)))) - (test-assert "mapm" (every (lambda (monad run) (with-monad monad diff --git a/tests/sets.scm b/tests/sets.scm new file mode 100644 index 0000000000..0a89591765 --- /dev/null +++ b/tests/sets.scm @@ -0,0 +1,52 @@ +;;; 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-sets) + #:use-module (guix sets) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64)) + + +(test-begin "sets") + +(test-assert "set-contains?" + (let* ((lst (iota 123)) + (set (list->set lst))) + (and (every (cut set-contains? set <>) + lst) + (not (set-contains? set -1))))) + +(test-assert "set->list" + (let* ((lst (iota 123)) + (set (list->set lst))) + (lset= = lst (set->list set)))) + +(test-assert "set-union" + (let* ((a (list 'a)) + (b (list 'b)) + (s1 (setq a)) + (s2 (setq b)) + (s3 (set-union s1 s2))) + (and (set-contains? s3 a) + (set-contains? s3 b)))) + +(test-end) + + +(exit (= (test-runner-fail-count (test-runner-current)) 0)) |