Merge branch 'master' into staging

8 files changed, 225 insertions, 3 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/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/gexp.scm b/tests/gexp.scm
index 41a53ae5a4..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
diff --git a/tests/guix-build.sh b/tests/guix-build.sh
index ab911b7210..9494e7371f 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"
diff --git a/tests/publish.scm b/tests/publish.scm
index ea0f4a3477..233b71ce93 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -314,4 +314,58 @@ 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
+        200)                                      ;nar/…
+  (call-with-temporary-directory
+   (lambda (cache)
+     (define (wait-for-file file)
+       (let loop ((i 20))
+         (or (file-exists? file)
+             (begin
+               (pk 'wait-for-file file)
+               (sleep 1)
+               (loop (- i 1))))))
+
+     (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))
+              (wait-for-file cached)
+              (let ((body         (http-get-port url))
+                    (compressed   (http-get nar-url))
+                    (uncompressed (http-get (string-append base "nar/"
+                                                           (basename %item)))))
+                (list (file-exists? nar)
+                      (filter (lambda (item)
+                                (match item
+                                  (("Compression" . _) #t)
+                                  (("StorePath" . _)  #t)
+                                  (("URL" . _) #t)
+                                  (_ #f)))
+                              (recutils->alist body))
+                      (response-code compressed)
+                      (= (response-content-length compressed)
+                         (stat:size (stat nar)))
+                      (response-code uncompressed)))))))))
+
 (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/store.scm b/tests/store.scm
index 45150d36ca..3eb8b7be5a 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")))
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)