aboutsummaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/cache.scm88
-rw-r--r--tests/cran.scm6
-rw-r--r--tests/derivations.scm14
-rw-r--r--tests/discovery.scm52
-rw-r--r--tests/gexp.scm11
-rw-r--r--tests/guix-build.sh9
-rw-r--r--tests/packages.scm35
-rw-r--r--tests/profiles.scm29
-rw-r--r--tests/publish.scm131
-rw-r--r--tests/scripts-build.scm7
-rw-r--r--tests/search-paths.scm2
-rw-r--r--tests/services.scm15
-rw-r--r--tests/size.scm18
-rw-r--r--tests/store.scm13
-rw-r--r--tests/ui.scm6
-rw-r--r--tests/workers.scm45
16 files changed, 467 insertions, 14 deletions
diff --git a/tests/cache.scm b/tests/cache.scm
new file mode 100644
index 0000000000..e46cdd816d
--- /dev/null
+++ b/tests/cache.scm
@@ -0,0 +1,88 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 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-cache)
+ #:use-module (guix cache)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-64)
+ #:use-module ((guix utils) #:select (call-with-temporary-directory))
+ #:use-module (ice-9 match))
+
+(cond-expand
+ (guile-2.2
+ ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
+ ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it.
+ (define time-monotonic time-tai))
+ (else #t))
+
+(test-begin "cache")
+
+(test-equal "remove-expired-cache-entries"
+ '("o" "l" "d")
+ (let* ((removed '())
+ (now (time-second (current-time time-monotonic)))
+ (ttl 100)
+ (stamp (match-lambda
+ ((or "n" "e" "w") (+ now 100))
+ ((or "o" "l" "d") (- now 100))))
+ (delete (lambda (entry)
+ (set! removed (cons entry removed)))))
+ (remove-expired-cache-entries (reverse '("n" "e" "w"
+ "o" "l" "d"))
+ #:entry-expiration stamp
+ #:delete-entry delete)
+ removed))
+
+(define-syntax-rule (test-cache-cleanup cache exp ...)
+ (call-with-temporary-directory
+ (lambda (cache)
+ (let* ((deleted '())
+ (delete! (lambda (entry)
+ (set! deleted (cons entry deleted)))))
+ exp ...
+ (maybe-remove-expired-cache-entries cache
+ (const '("a" "b" "c"))
+ #:entry-expiration (const 0)
+ #:delete-entry delete!)
+ (reverse deleted)))))
+
+(test-equal "maybe-remove-expired-cache-entries, first cleanup"
+ '("a" "b" "c")
+ (test-cache-cleanup cache))
+
+(test-equal "maybe-remove-expired-cache-entries, no cleanup needed"
+ '()
+ (test-cache-cleanup cache
+ (call-with-output-file (string-append cache "/last-expiry-cleanup")
+ (lambda (port)
+ (display (+ (time-second (current-time time-monotonic)) 100)
+ port)))))
+
+(test-equal "maybe-remove-expired-cache-entries, cleanup needed"
+ '("a" "b" "c")
+ (test-cache-cleanup cache
+ (call-with-output-file (string-append cache "/last-expiry-cleanup")
+ (lambda (port)
+ (display 0 port)))))
+
+(test-end "cache")
+
+;;; Local Variables:
+;;; eval: (put 'test-cache-cleanup 'scheme-indent-function 1)
+;;; End:
diff --git a/tests/cran.scm b/tests/cran.scm
index c162d45d8a..d785ec5db1 100644
--- a/tests/cran.scm
+++ b/tests/cran.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -17,6 +18,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-cran)
+ #:use-module (gnu packages statistics)
#:use-module (guix import cran)
#:use-module (guix tests)
#:use-module (srfi srfi-1)
@@ -86,6 +88,10 @@ Date/Publication: 2015-07-14 14:15:16
'()
((@@ (guix import cran) listify) simple-alist "BadList"))
+(test-equal "r-mininal is not a cran package"
+ #f
+ ((@@ (guix import cran) cran-package?) r-minimal))
+
(test-assert "description->package"
;; Replace network resources with sample data.
(mock ((guix build download) url-fetch
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 75c8d1dfb1..cabbf7b951 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -701,6 +701,20 @@
#:modules '((guix module that
does not exist)))))
+(test-equal "build-expression->derivation and builder encoding"
+ '("UTF-8" #t)
+ (let* ((exp '(λ (α) (+ α 1)))
+ (drv (build-expression->derivation %store "foo" exp)))
+ (match (derivation-builder-arguments drv)
+ ((... builder)
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (call-with-input-file builder
+ (lambda (port)
+ (list (port-encoding port)
+ (->bool
+ (string-contains (get-string-all port)
+ "(λ (α) (+ α 1))"))))))))))
+
(test-assert "build-expression->derivation and derivation-prerequisites"
(let ((drv (build-expression->derivation %store "fail" #f)))
(any (match-lambda
diff --git a/tests/discovery.scm b/tests/discovery.scm
new file mode 100644
index 0000000000..b838731e16
--- /dev/null
+++ b/tests/discovery.scm
@@ -0,0 +1,52 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 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-discovery)
+ #:use-module (guix discovery)
+ #:use-module (guix build-system)
+ #:use-module (srfi srfi-64)
+ #:use-module (ice-9 match))
+
+(define %top-srcdir
+ (dirname (search-path %load-path "guix.scm")))
+
+(test-begin "discovery")
+
+(test-assert "scheme-modules"
+ (match (map module-name (scheme-modules %top-srcdir "guix/import"))
+ ((('guix 'import _ ...) ..1)
+ #t)))
+
+(test-assert "all-modules"
+ (match (map module-name
+ (all-modules `((,%top-srcdir . "guix/build-system"))))
+ ((('guix 'build-system names) ..1)
+ names)))
+
+(test-assert "fold-module-public-variables"
+ (let ((modules (all-modules `((,%top-srcdir . "guix/build-system")))))
+ (match (fold-module-public-variables (lambda (obj result)
+ (if (build-system? obj)
+ (cons obj result)
+ result))
+ '()
+ modules)
+ (((? build-system? bs) ..1)
+ bs))))
+
+(test-end "discovery")
diff --git a/tests/gexp.scm b/tests/gexp.scm
index b3f7323984..cf88a9db80 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -627,6 +627,10 @@
#~(foo #$@(list (with-imported-modules '((foo)) #~+)
(with-imported-modules '((bar)) #~-)))))
+(test-equal "gexp-modules and literal Scheme object"
+ '()
+ (gexp-modules #t))
+
(test-assertm "gexp->derivation #:modules"
(mlet* %store-monad
((build -> #~(begin
@@ -946,6 +950,13 @@
(string=? (readlink (string-append comp "/text"))
text)))))))
+(test-assert "lower-object & gexp-input-error?"
+ (guard (c ((gexp-input-error? c)
+ (gexp-error-invalid-input c)))
+ (run-with-store %store
+ (lower-object (current-module))
+ #:guile-for-build (%guile-for-build))))
+
(test-assert "printer"
(string-match "^#<gexp \\(string-append .*#<package coreutils.*\
\"/bin/uname\"\\) [[:xdigit:]]+>$"
diff --git a/tests/guix-build.sh b/tests/guix-build.sh
index ab911b7210..880a582777 100644
--- a/tests/guix-build.sh
+++ b/tests/guix-build.sh
@@ -36,6 +36,14 @@ guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' | \
guix build hello -d | \
grep -e '-hello-[0-9\.]\+\.drv$'
+# Passing a URI.
+GUIX_DAEMON_SOCKET="file://$NIX_STATE_DIR/daemon-socket/socket" \
+guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'
+
+( if GUIX_DAEMON_SOCKET="weird://uri" \
+ guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'; \
+ then exit 1; fi )
+
# Check --sources option with its arguments
module_dir="t-guix-build-$$"
mkdir "$module_dir"
@@ -177,7 +185,6 @@ test "`guix build superseded -d`" = "`guix build bar -d`"
# Parsing package names and versions.
guix build -n time # PASS
guix build -n time@1.7 # PASS, version found
-guix build -n time-1.7 # PASS, deprecated version syntax
if guix build -n time@3.2; # FAIL, version not found
then false; else true; fi
if guix build -n something-that-will-never-exist; # FAIL
diff --git a/tests/packages.scm b/tests/packages.scm
index aa29758830..930374dabf 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -470,6 +470,14 @@
(package-derivation %store p)
#f)))
+(let ((dummy (dummy-package "foo" (inputs `(("x" ,(current-module)))))))
+ (test-equal "&package-input-error"
+ (list dummy (current-module))
+ (guard (c ((package-input-error? c)
+ (list (package-error-package c)
+ (package-error-invalid-input c))))
+ (package-derivation %store dummy))))
+
(test-assert "reference to non-existent output"
;; See <http://bugs.gnu.org/19630>.
(parameterize ((%graft? #f))
@@ -878,6 +886,33 @@
(and (build-derivations %store (list drv))
(file-exists? (string-append out "/bin/make")))))))
+(test-equal "package-mapping"
+ 42
+ (let* ((dep (dummy-package "chbouib"
+ (native-inputs `(("x" ,grep)))))
+ (p0 (dummy-package "example"
+ (inputs `(("foo" ,coreutils)
+ ("bar" ,grep)
+ ("baz" ,dep)))))
+ (transform (lambda (p)
+ (package (inherit p) (source 42))))
+ (rewrite (package-mapping transform))
+ (p1 (rewrite p0)))
+ (and (eq? p1 (rewrite p0))
+ (eqv? 42 (package-source p1))
+ (match (package-inputs p1)
+ ((("foo" dep1) ("bar" dep2) ("baz" dep3))
+ (and (eq? dep1 (rewrite coreutils)) ;memoization
+ (eq? dep2 (rewrite grep))
+ (eq? dep3 (rewrite dep))
+ (eqv? 42
+ (package-source dep1) (package-source dep2)
+ (package-source dep3))
+ (match (package-native-inputs dep3)
+ ((("x" dep))
+ (and (eq? dep (rewrite grep))
+ (package-source dep))))))))))
+
(test-assert "package-input-rewriting"
(let* ((dep (dummy-package "chbouib"
(native-inputs `(("x" ,grep)))))
diff --git a/tests/profiles.scm b/tests/profiles.scm
index d0b1e14a86..093422792f 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -50,6 +50,12 @@
(run-with-store %store exp
#:guile-for-build (%guile-for-build))))
+(define-syntax-rule (test-equalm name value exp)
+ (test-equal name
+ value
+ (run-with-store %store exp
+ #:guile-for-build (%guile-for-build))))
+
;; Example manifest entries.
(define guile-1.8.8
@@ -366,6 +372,29 @@
get-string-all)
"foo!"))))))
+(test-equalm "union vs. dangling symlink" ;<https://bugs.gnu.org/26949>
+ "does-not-exist"
+ (mlet* %store-monad
+ ((thing1 -> (dummy-package "dummy"
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder
+ (let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (symlink "does-not-exist"
+ (string-append out "/dangling"))
+ #t)))))
+ (thing2 -> (package (inherit thing1) (name "dummy2")))
+ (drv (profile-derivation (packages->manifest
+ (list thing1 thing2))
+ #:hooks '()
+ #:locales? #f))
+ (profile -> (derivation->output-path drv)))
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (return (readlink (readlink (string-append profile "/dangling")))))))
+
(test-end "profiles")
;;; Local Variables:
diff --git a/tests/publish.scm b/tests/publish.scm
index ea0f4a3477..31043f71fa 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -98,6 +98,18 @@
(connect conn AF_INET (inet-pton AF_INET "127.0.0.1") port))
(loop)))))
+(define (wait-for-file file)
+ ;; Wait until FILE shows up.
+ (let loop ((i 20))
+ (cond ((file-exists? file)
+ #t)
+ ((zero? i)
+ (error "file didn't show up" file))
+ (else
+ (pk 'wait-for-file file)
+ (sleep 1)
+ (loop (- i 1))))))
+
;; Wait until the two servers are ready.
(wait-until-ready 6789)
@@ -122,13 +134,15 @@ URL: nar/~a
Compression: none
NarHash: sha256:~a
NarSize: ~d
-References: ~a~%"
+References: ~a
+FileSize: ~a~%"
%item
(basename %item)
(bytevector->nix-base32-string
(path-info-hash info))
(path-info-nar-size info)
- (basename (first (path-info-references info)))))
+ (basename (first (path-info-references info)))
+ (path-info-nar-size info)))
(signature (base64-encode
(string->utf8
(canonical-sexp->string
@@ -152,11 +166,13 @@ URL: nar/~a
Compression: none
NarHash: sha256:~a
NarSize: ~d
-References: ~%"
+References: ~%\
+FileSize: ~a~%"
item
(uri-encode (basename item))
(bytevector->nix-base32-string
(path-info-hash info))
+ (path-info-nar-size info)
(path-info-nar-size info)))
(signature (base64-encode
(string->utf8
@@ -314,4 +330,113 @@ References: ~%"
(call-with-input-string "" port-sha256))))))
(response-code (http-get uri))))
+(unless (zlib-available?)
+ (test-skip 1))
+(test-equal "with cache"
+ (list #t
+ `(("StorePath" . ,%item)
+ ("URL" . ,(string-append "nar/gzip/" (basename %item)))
+ ("Compression" . "gzip"))
+ 200 ;nar/gzip/…
+ #t ;Content-Length
+ #t ;FileSize
+ 200) ;nar/…
+ (call-with-temporary-directory
+ (lambda (cache)
+ (let ((thread (with-separate-output-ports
+ (call-with-new-thread
+ (lambda ()
+ (guix-publish "--port=6797" "-C2"
+ (string-append "--cache=" cache)))))))
+ (wait-until-ready 6797)
+ (let* ((base "http://localhost:6797/")
+ (part (store-path-hash-part %item))
+ (url (string-append base part ".narinfo"))
+ (nar-url (string-append base "/nar/gzip/" (basename %item)))
+ (cached (string-append cache "/gzip/" (basename %item)
+ ".narinfo"))
+ (nar (string-append cache "/gzip/"
+ (basename %item) ".nar"))
+ (response (http-get url)))
+ (and (= 404 (response-code response))
+
+ ;; We should get an explicitly short TTL for 404 in this case
+ ;; because it's going to become 200 shortly.
+ (match (assq-ref (response-headers response) 'cache-control)
+ ((('max-age . ttl))
+ (< ttl 3600)))
+
+ (wait-for-file cached)
+ (let* ((body (http-get-port url))
+ (compressed (http-get nar-url))
+ (uncompressed (http-get (string-append base "nar/"
+ (basename %item))))
+ (narinfo (recutils->alist body)))
+ (list (file-exists? nar)
+ (filter (lambda (item)
+ (match item
+ (("Compression" . _) #t)
+ (("StorePath" . _) #t)
+ (("URL" . _) #t)
+ (_ #f)))
+ narinfo)
+ (response-code compressed)
+ (= (response-content-length compressed)
+ (stat:size (stat nar)))
+ (= (string->number
+ (assoc-ref narinfo "FileSize"))
+ (stat:size (stat nar)))
+ (response-code uncompressed)))))))))
+
+(unless (zlib-available?)
+ (test-skip 1))
+(let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz"
+ (random-text))))
+ (test-equal "with cache, uncompressed"
+ (list #f
+ `(("StorePath" . ,item)
+ ("URL" . ,(string-append "nar/" (basename item)))
+ ("Compression" . "none"))
+ 200 ;nar/…
+ (path-info-nar-size
+ (query-path-info %store item)) ;FileSize
+ 404) ;nar/gzip/…
+ (call-with-temporary-directory
+ (lambda (cache)
+ (let ((thread (with-separate-output-ports
+ (call-with-new-thread
+ (lambda ()
+ (guix-publish "--port=6796" "-C2"
+ (string-append "--cache=" cache)))))))
+ (wait-until-ready 6796)
+ (let* ((base "http://localhost:6796/")
+ (part (store-path-hash-part item))
+ (url (string-append base part ".narinfo"))
+ (cached (string-append cache "/none/"
+ (basename item) ".narinfo"))
+ (nar (string-append cache "/none/"
+ (basename item) ".nar"))
+ (response (http-get url)))
+ (and (= 404 (response-code response))
+
+ (wait-for-file cached)
+ (let* ((body (http-get-port url))
+ (compressed (http-get (string-append base "nar/gzip/"
+ (basename item))))
+ (uncompressed (http-get (string-append base "nar/"
+ (basename item))))
+ (narinfo (recutils->alist body)))
+ (list (file-exists? nar)
+ (filter (lambda (item)
+ (match item
+ (("Compression" . _) #t)
+ (("StorePath" . _) #t)
+ (("URL" . _) #t)
+ (_ #f)))
+ narinfo)
+ (response-code uncompressed)
+ (string->number
+ (assoc-ref narinfo "FileSize"))
+ (response-code compressed))))))))))
+
(test-end "publish")
diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm
index a1f684c736..a408ea6f8d 100644
--- a/tests/scripts-build.scm
+++ b/tests/scripts-build.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,6 +23,7 @@
#:use-module (guix scripts build)
#:use-module (guix ui)
#:use-module (guix utils)
+ #:use-module (gnu packages)
#:use-module (gnu packages base)
#:use-module (gnu packages busybox)
#:use-module (ice-9 match)
@@ -97,8 +98,8 @@
(test-assert "options->transformation, with-input"
(let* ((p (dummy-package "guix.scm"
- (inputs `(("foo" ,coreutils)
- ("bar" ,grep)
+ (inputs `(("foo" ,(specification->package "coreutils"))
+ ("bar" ,(specification->package "grep"))
("baz" ,(dummy-package "chbouib"
(native-inputs `(("x" ,grep)))))))))
(t (options->transformation '((with-input . "coreutils=busybox")
diff --git a/tests/search-paths.scm b/tests/search-paths.scm
index 2a4c18dd76..8dad424415 100644
--- a/tests/search-paths.scm
+++ b/tests/search-paths.scm
@@ -29,7 +29,7 @@
(test-equal "evaluate-search-paths, separator is #f"
(string-append %top-srcdir
- "/gnu/packages/bootstrap/armhf-linux")
+ "/gnu/packages/bootstrap/aarch64-linux")
;; The following search path spec should evaluate to a single item: the
;; first directory that matches the "-linux$" pattern in
diff --git a/tests/services.scm b/tests/services.scm
index 8993c3dafc..8484ee982a 100644
--- a/tests/services.scm
+++ b/tests/services.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -31,6 +31,17 @@
(test-begin "services")
+(test-equal "services, default value"
+ '(42 123 234 error)
+ (let* ((t1 (service-type (name 't1) (extensions '())))
+ (t2 (service-type (name 't2) (extensions '())
+ (default-value 42))))
+ (list (service-value (service t2))
+ (service-value (service t2 123))
+ (service-value (service t1 234))
+ (guard (c ((missing-value-service-error? c) 'error))
+ (service t1)))))
+
(test-assert "service-back-edges"
(let* ((t1 (service-type (name 't1) (extensions '())
(compose +) (extend *)))
@@ -75,7 +86,7 @@
(iota 5 1)))
#:target-type t1)))
(and (eq? (service-kind r) t1)
- (service-parameters r))))
+ (service-value r))))
(test-assert "fold-services, ambiguity"
(let* ((t1 (service-type (name 't1) (extensions '())
diff --git a/tests/size.scm b/tests/size.scm
index 068ebc1d68..575b1abfdd 100644
--- a/tests/size.scm
+++ b/tests/size.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -86,6 +86,22 @@
(profile-self-size profile3)
(profile-self-size profile4))))))))))))
+(test-assertm "store-profile with multiple items"
+ (mlet* %store-monad ((file1 (gexp->derivation "file1"
+ #~(symlink #$%bootstrap-guile
+ #$output)))
+ (file2 (text-file* "file2"
+ "the file => " file1)))
+ (mbegin %store-monad
+ (built-derivations (list file2))
+ (mlet %store-monad ((profiles (store-profile
+ (list (derivation->output-path file2)
+ (derivation->output-path file1))))
+ (reference (store-profile
+ (list (derivation->output-path file2)))))
+ (return (and (= (length profiles) 4)
+ (lset= equal? profiles reference)))))))
+
(test-end "size")
;;; Local Variables:
diff --git a/tests/store.scm b/tests/store.scm
index 45150d36ca..45aeb329b0 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -48,6 +48,14 @@
(test-begin "store")
+(test-assert "open-connection with file:// URI"
+ (let ((store (open-connection (string-append "file://"
+ (%daemon-socket-uri)))))
+ (and (add-text-to-store store "foo" "bar")
+ (begin
+ (close-connection store)
+ #t))))
+
(test-equal "connection handshake error"
EPROTO
(let ((port (%make-void-port "rw")))
@@ -750,8 +758,9 @@
(cut export-paths %store (list file) <>))))
(delete-paths %store (list file))
- ;; Flip a bit in the stream's payload.
- (let* ((index (quotient (bytevector-length dump) 4))
+ ;; Flip a bit in the stream's payload. INDEX here falls in the middle of
+ ;; the file contents in DUMP, regardless of the store prefix.
+ (let* ((index #x70)
(byte (bytevector-u8-ref dump index)))
(bytevector-u8-set! dump index (logxor #xff byte)))
diff --git a/tests/ui.scm b/tests/ui.scm
index cfe417d497..1e98e3534b 100644
--- a/tests/ui.scm
+++ b/tests/ui.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -189,6 +189,10 @@ Second line" 24))
(string->duration "1m")
(string->duration "30d"))
+(test-equal "duration, 2 hours"
+ 7200
+ (time-second (string->duration "2h")))
+
(test-equal "duration, 1 second"
(make-time time-duration 0 1)
(string->duration "1s"))
diff --git a/tests/workers.scm b/tests/workers.scm
new file mode 100644
index 0000000000..44b882f691
--- /dev/null
+++ b/tests/workers.scm
@@ -0,0 +1,45 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 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-workers)
+ #:use-module (guix workers)
+ #:use-module (ice-9 threads)
+ #:use-module (srfi srfi-64))
+
+(test-begin "workers")
+
+(test-equal "enqueue"
+ 4242
+ (let* ((pool (make-pool))
+ (result 0)
+ (1+! (let ((lock (make-mutex)))
+ (lambda ()
+ (with-mutex lock
+ (set! result (+ result 1)))))))
+ (let loop ((i 4242))
+ (unless (zero? i)
+ (pool-enqueue! pool 1+!)
+ (loop (- i 1))))
+ (let poll ()
+ (unless (pool-idle? pool)
+ (pk 'busy result)
+ (sleep 1)
+ (poll)))
+ result))
+
+(test-end)