Merge branch 'master' into core-updates

9 files changed, 324 insertions, 50 deletions

diff --git a/tests/cpan.scm b/tests/cpan.scm
index 5d56f0bd2b..898081b3e5 100644
--- a/tests/cpan.scm
+++ b/tests/cpan.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -97,4 +98,14 @@
       (x
        (pk 'fail x #f)))))
 
+(test-equal "source-url-http"
+  ((@@ (guix import cpan) fix-source-url)
+   "http://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")
+  "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")
+
+(test-equal "source-url-https"
+  ((@@ (guix import cpan) fix-source-url)
+   "https://cpan.metacpan.org/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")
+  "mirror://cpan/authors/id/T/TE/TEST/Foo-Bar-0.1.tar.gz")
+
 (test-end "cpan")
diff --git a/tests/gexp.scm b/tests/gexp.scm
index f44f0eaf9a..03a64fa6bb 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -526,6 +526,18 @@
                             get-bytevector-all))))
                 files))))))
 
+(test-equal "gexp-modules & ungexp"
+  '((bar) (foo))
+  ((@@ (guix gexp) gexp-modules)
+   #~(foo #$(with-imported-modules '((foo)) #~+)
+          #+(with-imported-modules '((bar)) #~-))))
+
+(test-equal "gexp-modules & ungexp-splicing"
+  '((foo) (bar))
+  ((@@ (guix gexp) gexp-modules)
+   #~(foo #$@(list (with-imported-modules '((foo)) #~+)
+                   (with-imported-modules '((bar)) #~-)))))
+
 (test-assertm "gexp->derivation #:modules"
   (mlet* %store-monad
       ((build ->  #~(begin
@@ -540,31 +552,75 @@
              (s (stat (string-append p "/guile/guix/nix"))))
         (return (eq? (stat:type s) 'directory))))))
 
+(test-assertm "gexp->derivation & with-imported-modules"
+  ;; Same test as above, but using 'with-imported-modules'.
+  (mlet* %store-monad
+      ((build ->  (with-imported-modules '((guix build utils))
+                    #~(begin
+                        (use-modules (guix build utils))
+                        (mkdir-p (string-append #$output "/guile/guix/nix"))
+                        #t)))
+       (drv       (gexp->derivation "test-with-modules" build)))
+    (mbegin %store-monad
+      (built-derivations (list drv))
+      (let* ((p (derivation->output-path drv))
+             (s (stat (string-append p "/guile/guix/nix"))))
+        (return (eq? (stat:type s) 'directory))))))
+
+(test-assertm "gexp->derivation & nested with-imported-modules"
+  (mlet* %store-monad
+      ((build1 ->  (with-imported-modules '((guix build utils))
+                     #~(begin
+                         (use-modules (guix build utils))
+                         (mkdir-p (string-append #$output "/guile/guix/nix"))
+                         #t)))
+       (build2 ->  (with-imported-modules '((guix build bournish))
+                     #~(begin
+                         (use-modules (guix build bournish)
+                                      (system base compile))
+                         #+build1
+                         (call-with-output-file (string-append #$output "/b")
+                           (lambda (port)
+                             (write
+                              (read-and-compile (open-input-string "cd /foo")
+                                                #:from %bournish-language
+                                                #:to 'scheme)
+                              port))))))
+       (drv        (gexp->derivation "test-with-modules" build2)))
+    (mbegin %store-monad
+      (built-derivations (list drv))
+      (let* ((p (derivation->output-path drv))
+             (s (stat (string-append p "/guile/guix/nix")))
+             (b (string-append p "/b")))
+        (return (and (eq? (stat:type s) 'directory)
+                     (equal? '(chdir "/foo")
+                             (call-with-input-file b read))))))))
+
 (test-assertm "gexp->derivation #:references-graphs"
   (mlet* %store-monad
       ((one (text-file "one" (random-text)))
        (two (gexp->derivation "two"
                               #~(symlink #$one #$output:chbouib)))
-       (drv (gexp->derivation "ref-graphs"
-                              #~(begin
-                                  (use-modules (guix build store-copy))
-                                  (with-output-to-file #$output
-                                    (lambda ()
-                                      (write (call-with-input-file "guile"
-                                               read-reference-graph))))
-                                  (with-output-to-file #$output:one
-                                    (lambda ()
-                                      (write (call-with-input-file "one"
-                                               read-reference-graph))))
-                                  (with-output-to-file #$output:two
-                                    (lambda ()
-                                      (write (call-with-input-file "two"
-                                               read-reference-graph)))))
+       (build -> (with-imported-modules '((guix build store-copy)
+                                          (guix build utils))
+                   #~(begin
+                       (use-modules (guix build store-copy))
+                       (with-output-to-file #$output
+                         (lambda ()
+                           (write (call-with-input-file "guile"
+                                    read-reference-graph))))
+                       (with-output-to-file #$output:one
+                         (lambda ()
+                           (write (call-with-input-file "one"
+                                    read-reference-graph))))
+                       (with-output-to-file #$output:two
+                         (lambda ()
+                           (write (call-with-input-file "two"
+                                    read-reference-graph)))))))
+       (drv (gexp->derivation "ref-graphs" build
                               #:references-graphs `(("one" ,one)
                                                     ("two" ,two "chbouib")
-                                                    ("guile" ,%bootstrap-guile))
-                              #:modules '((guix build store-copy)
-                                          (guix build utils))))
+                                                    ("guile" ,%bootstrap-guile))))
        (ok? (built-derivations (list drv)))
        (guile-drv  (package->derivation %bootstrap-guile))
        (bash       (interned-file (search-bootstrap-binary "bash"
@@ -676,11 +732,11 @@
 
 (test-assertm "program-file"
   (let* ((n      (random (expt 2 50)))
-         (exp    (gexp (begin
-                         (use-modules (guix build utils))
-                         (display (ungexp n)))))
+         (exp    (with-imported-modules '((guix build utils))
+                   (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)))
diff --git a/tests/grafts.scm b/tests/grafts.scm
index 8cd048552c..13c56750ed 100644
--- a/tests/grafts.scm
+++ b/tests/grafts.scm
@@ -135,14 +135,14 @@
                                      (replacement fake)))
                          (drv     (gexp->derivation
                                    "to-graft"
-                                   #~(begin
-                                       (use-modules (guix build utils))
-                                       (mkdir-p (string-append #$output
-                                                               "/a/b/c/d"))
-                                       (symlink #$%bash
-                                                (string-append #$output
-                                                               "/bash")))
-                                   #:modules '((guix build utils))))
+                                   (with-imported-modules '((guix build utils))
+                                     #~(begin
+                                         (use-modules (guix build utils))
+                                         (mkdir-p (string-append #$output
+                                                                 "/a/b/c/d"))
+                                         (symlink #$%bash
+                                                  (string-append #$output
+                                                                 "/bash"))))))
                          (grafted ((store-lift graft-derivation) drv
                                    (list graft)))
                          (_       (built-derivations (list grafted)))
diff --git a/tests/lint.scm b/tests/lint.scm
index 1f1b0c95e9..ce751c42c9 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -102,14 +102,14 @@
   http-write
   (@@ (web server http) http-close))
 
-(define (call-with-http-server code thunk)
-  "Call THUNK with an HTTP server running and returning CODE on HTTP
-requests."
+(define (call-with-http-server code data thunk)
+  "Call THUNK with an HTTP server running and returning CODE and DATA (a
+string) on HTTP requests."
   (define (server-body)
     (define (handle request body)
       (values (build-response #:code code
                               #:reason-phrase "Such is life")
-              "Hello, world."))
+              data))
 
     (catch 'quit
       (lambda ()
@@ -123,8 +123,11 @@ requests."
       ;; 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 ...)))
+(define-syntax-rule (with-http-server code data body ...)
+  (call-with-http-server code data (lambda () body ...)))
+
+(define %long-string
+  (make-string 2000 #\a))
 
 
 (test-begin "lint")
@@ -402,18 +405,30 @@ requests."
 (test-equal "home-page: 200"
   ""
   (with-warnings
-   (with-http-server 200
+   (with-http-server 200 %long-string
      (let ((pkg (package
                   (inherit (dummy-package "x"))
                   (home-page %local-url))))
        (check-home-page pkg)))))
 
 (test-skip (if %http-server-socket 0 1))
+(test-assert "home-page: 200 but short length"
+  (->bool
+   (string-contains
+    (with-warnings
+      (with-http-server 200 "This is too small."
+        (let ((pkg (package
+                     (inherit (dummy-package "x"))
+                     (home-page %local-url))))
+          (check-home-page pkg))))
+    "suspiciously small")))
+
+(test-skip (if %http-server-socket 0 1))
 (test-assert "home-page: 404"
   (->bool
    (string-contains
     (with-warnings
-      (with-http-server 404
+      (with-http-server 404 %long-string
         (let ((pkg (package
                      (inherit (dummy-package "x"))
                      (home-page %local-url))))
@@ -501,7 +516,7 @@ requests."
 (test-equal "source: 200"
   ""
   (with-warnings
-   (with-http-server 200
+   (with-http-server 200 %long-string
      (let ((pkg (package
                   (inherit (dummy-package "x"))
                   (source (origin
@@ -511,11 +526,26 @@ requests."
        (check-source pkg)))))
 
 (test-skip (if %http-server-socket 0 1))
+(test-assert "source: 200 but short length"
+  (->bool
+   (string-contains
+    (with-warnings
+      (with-http-server 200 "This is too small."
+        (let ((pkg (package
+                     (inherit (dummy-package "x"))
+                     (source (origin
+                               (method url-fetch)
+                               (uri %local-url)
+                               (sha256 %null-sha256))))))
+          (check-source pkg))))
+    "suspiciously small")))
+
+(test-skip (if %http-server-socket 0 1))
 (test-assert "source: 404"
   (->bool
    (string-contains
     (with-warnings
-      (with-http-server 404
+      (with-http-server 404 %long-string
         (let ((pkg (package
                      (inherit (dummy-package "x"))
                      (source (origin
@@ -617,6 +647,6 @@ requests."
 (test-end "lint")
 
 ;; Local Variables:
-;; eval: (put 'with-http-server 'scheme-indent-function 1)
+;; eval: (put 'with-http-server 'scheme-indent-function 2)
 ;; eval: (put 'with-warnings 'scheme-indent-function 0)
 ;; End:
diff --git a/tests/packages.scm b/tests/packages.scm
index 94f5ea71a5..fc75e38730 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -335,7 +335,6 @@
                        ("patch" ,%bootstrap-coreutils&co)))
                     (patch-guile %bootstrap-guile)
                     (modules '((guix build utils)))
-                    (imported-modules modules)
                     (snippet '(begin
                                 ;; We end up in 'bin', because it's the first
                                 ;; directory, alphabetically.  Not a very good
diff --git a/tests/publish.scm b/tests/publish.scm
index d6d537c58a..9bf181f1fc 100644
--- a/tests/publish.scm
+++ b/tests/publish.scm
@@ -28,12 +28,15 @@
   #:use-module (guix store)
   #:use-module (guix base32)
   #:use-module (guix base64)
+  #:use-module ((guix records) #:select (recutils->alist))
   #:use-module ((guix serialization) #:select (restore-file))
   #:use-module (guix pk-crypto)
+  #:use-module (guix zlib)
   #:use-module (web uri)
   #:use-module (web client)
   #:use-module (web response)
   #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 binary-ports)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64)
@@ -52,20 +55,28 @@
   (call-with-values (lambda () (http-get uri))
     (lambda (response body) body)))
 
+(define (http-get-port uri)
+  (call-with-values (lambda () (http-get uri #:streaming? #t))
+    (lambda (response port) port)))
+
 (define (publish-uri route)
   (string-append "http://localhost:6789" route))
 
 ;; Run a local publishing server in a separate thread.
 (call-with-new-thread
  (lambda ()
-   (guix-publish "--port=6789"))) ; attempt to avoid port collision
+   (guix-publish "--port=6789" "-C0")))       ;attempt to avoid port collision
+
+(define (wait-until-ready port)
+  ;; Wait until the server is accepting connections.
+  (let ((conn (socket PF_INET SOCK_STREAM 0)))
+    (let loop ()
+      (unless (false-if-exception
+               (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") port))
+        (loop)))))
 
-;; Wait until the server is accepting connections.
-(let ((conn (socket PF_INET SOCK_STREAM 0)))
-  (let loop ()
-    (unless (false-if-exception
-             (connect conn AF_INET (inet-pton AF_INET "127.0.0.1") 6789))
-      (loop))))
+;; Wait until the two servers are ready.
+(wait-until-ready 6789)
 
 
 (test-begin "publish")
@@ -145,6 +156,40 @@ References: ~%"
        (call-with-input-string nar (cut restore-file <> temp)))
      (call-with-input-file temp read-string))))
 
+(unless (zlib-available?)
+  (test-skip 1))
+(test-equal "/nar/gzip/*"
+  "bar"
+  (call-with-temporary-output-file
+   (lambda (temp port)
+     (let ((nar (http-get-port
+                 (publish-uri
+                  (string-append "/nar/gzip/" (basename %item))))))
+       (call-with-gzip-input-port nar
+         (cut restore-file <> temp)))
+     (call-with-input-file temp read-string))))
+
+(unless (zlib-available?)
+  (test-skip 1))
+(test-equal "/*.narinfo with compression"
+  `(("StorePath" . ,%item)
+    ("URL" . ,(string-append "nar/gzip/" (basename %item)))
+    ("Compression" . "gzip"))
+  (let ((thread (call-with-new-thread
+                 (lambda ()
+                   (guix-publish "--port=6799" "-C5")))))
+    (wait-until-ready 6799)
+    (let* ((url  (string-append "http://localhost:6799/"
+                                (store-path-hash-part %item) ".narinfo"))
+           (body (http-get-port url)))
+      (filter (lambda (item)
+                (match item
+                  (("Compression" . _) #t)
+                  (("StorePath" . _)  #t)
+                  (("URL" . _) #t)
+                  (_ #f)))
+              (recutils->alist body)))))
+
 (test-equal "/nar/ with properly encoded '+' sign"
   "Congrats!"
   (let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
diff --git a/tests/records.scm b/tests/records.scm
index c6f85d4a81..d6d27bb96a 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,6 +17,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (test-records)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
@@ -214,6 +215,32 @@
              (equal? (foo-bar y) 1))              ;promise was already forced
            (eq? (foo-baz y) 'b)))))
 
+(test-assert "define-record-type* & wrong field specifier"
+  (let ((exp '(begin
+                (define-record-type* <foo> foo make-foo
+                  foo?
+                  (bar foo-bar (default 42))
+                  (baz foo-baz))
+
+                (foo (baz 1 2 3 4 5))))           ;syntax error
+        (loc         (current-source-location)))  ;keep this alignment!
+    (catch 'syntax-error
+      (lambda ()
+        (eval exp (test-module))
+        #f)
+      (lambda (key proc message location form . args)
+        (and (eq? proc 'foo)
+             (string-match "invalid field" message)
+             (equal? form '(baz 1 2 3 4 5))
+
+             ;; Make sure the location is that of the field specifier.
+             ;; See <http://bugs.gnu.org/23969>.
+             (lset= equal?
+                    (pk 'expected-loc
+                        `((line . ,(- (assq-ref loc 'line) 1))
+                          ,@(alist-delete 'line loc)))
+                    (pk 'actual-loc location)))))))
+
 (test-assert "define-record-type* & missing initializers"
   (catch 'syntax-error
     (lambda ()
diff --git a/tests/system.scm b/tests/system.scm
index b935bd07eb..b5bb9af016 100644
--- a/tests/system.scm
+++ b/tests/system.scm
@@ -41,6 +41,25 @@
 
     (users %base-user-accounts)))
 
+(define %luks-device
+  (mapped-device
+   (source "/dev/foo") (target "my-luks-device")
+   (type luks-device-mapping)))
+
+(define %os-with-mapped-device
+  (operating-system
+    (host-name "komputilo")
+    (timezone "Europe/Berlin")
+    (locale "en_US.utf8")
+    (bootloader (grub-configuration (device "/dev/sdX")))
+    (mapped-devices (list %luks-device))
+    (file-systems (cons (file-system
+                          (inherit %root-fs)
+                          (dependencies (list %luks-device)))
+                        %base-file-systems))
+    (users %base-user-accounts)))
+
+
 (test-begin "system")
 
 (test-assert "operating-system-store-file-system"
@@ -71,4 +90,28 @@
                                      %base-file-systems)))))
     (eq? gnu (operating-system-store-file-system os))))
 
+(test-equal "operating-system-user-mapped-devices"
+  '()
+  (operating-system-user-mapped-devices %os-with-mapped-device))
+
+(test-equal "operating-system-boot-mapped-devices"
+  (list %luks-device)
+  (operating-system-boot-mapped-devices %os-with-mapped-device))
+
+(test-equal "operating-system-boot-mapped-devices, implicit dependency"
+  (list %luks-device)
+
+  ;; Here we expect the implicit dependency between "/" and
+  ;; "/dev/mapper/my-luks-device" to be found, in spite of the lack of a
+  ;; 'dependencies' field in the root file system.
+  (operating-system-boot-mapped-devices
+   (operating-system
+     (inherit %os-with-mapped-device)
+     (file-systems (cons (file-system
+                           (device "/dev/mapper/my-luks-device")
+                           (title 'device)
+                           (mount-point "/")
+                           (type "ext4"))
+                         %base-file-systems)))))
+
 (test-end)
diff --git a/tests/zlib.scm b/tests/zlib.scm
new file mode 100644
index 0000000000..5455240a71
--- /dev/null
+++ b/tests/zlib.scm
@@ -0,0 +1,63 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 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-zlib)
+  #:use-module (guix zlib)
+  #:use-module (guix tests)
+  #:use-module (srfi srfi-64)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (ice-9 match))
+
+;; Test the (guix zlib) module.
+
+(unless (zlib-available?)
+  (exit 77))
+
+(test-begin "zlib")
+
+(test-assert "compression/decompression pipe"
+  (let ((data (random-bytevector (+ (random 10000)
+                                    (* 20 1024)))))
+    (match (pipe)
+      ((parent . child)
+       (match (primitive-fork)
+         (0                                       ;compress
+          (dynamic-wind
+            (const #t)
+            (lambda ()
+              (close-port parent)
+              (call-with-gzip-output-port child
+                (lambda (port)
+                  (put-bytevector port data))))
+            (lambda ()
+              (primitive-exit 0))))
+         (pid                                     ;decompress
+          (begin
+            (close-port child)
+            (let ((received (call-with-gzip-input-port parent
+                              (lambda (port)
+                                (get-bytevector-all port))
+                              #:buffer-size (* 64 1024))))
+              (match (waitpid pid)
+                ((_ . status)
+                 (and (zero? status)
+                      (port-closed? parent)
+                      (bytevector=? received data))))))))))))
+
+(test-end)