Merge remote-tracking branch 'origin/master' into core-updates

4 files changed, 341 insertions, 29 deletions

diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index 5b40d4514a..1bc7a70277 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -250,19 +250,8 @@ info --version")
 
               ;; It can take a while before the shell commands are executed.
               (marionette-eval '(use-modules (rnrs io ports)) marionette)
-              (marionette-eval
-               '(let loop ((i 0))
-                  (catch 'system-error
-                    (lambda ()
-                      (call-with-input-file "/root/logged-in"
-                        get-string-all))
-                    (lambda args
-                      (if (and (< i 15) (= ENOENT (system-error-errno args)))
-                          (begin
-                            (sleep 1)
-                            (loop (+ i 1)))
-                          (apply throw args)))))
-               marionette)))
+              (wait-for-file "/root/logged-in" marionette
+                             #:read 'get-string-all)))
 
           ;; There should be one utmpx entry for the user logged in on tty1.
           (test-equal "utmpx entry"
@@ -555,11 +544,11 @@ in a loop.  See <http://bugs.gnu.org/26931>.")
                (>= gid 100))))
 
           ;; Last, the job that uses a command; allows us to test whether
-          ;; $PATH is sane.  (Note that 'marionette-eval' stringifies objects
-          ;; that don't have a read syntax, hence the string.)
+          ;; $PATH is sane.
           (test-equal "root's job with command"
-            "#<eof>"
-            (wait-for-file "/root/witness-touch" marionette))
+            ""
+            (wait-for-file "/root/witness-touch" marionette
+                           #:read '(@ (ice-9 rdelim) read-string)))
 
           (test-end)
           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
diff --git a/gnu/tests/desktop.scm b/gnu/tests/desktop.scm
new file mode 100644
index 0000000000..be64c4e7e5
--- /dev/null
+++ b/gnu/tests/desktop.scm
@@ -0,0 +1,105 @@
+;;; 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 (gnu tests desktop)
+  #:use-module (gnu tests)
+  #:use-module (gnu services)
+  #:use-module (gnu services dbus)
+  #:use-module (gnu services desktop)
+  #:use-module (gnu system vm)
+  #:use-module (guix gexp)
+  #:use-module (srfi srfi-1)
+  #:export (%test-elogind))
+
+
+;;;
+;;; Elogind.
+;;;
+
+(define (run-elogind-test vm)
+  (define test
+    (with-imported-modules '((gnu build marionette)
+                             (guix build syscalls))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (guix build syscalls)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette '(#$vm)))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "elogind")
+
+          ;; Log in as root on tty1, and check what 'loginctl' returns.
+          (test-equal "login on tty1"
+            '(("c1" "0" "root" "seat0" "/dev/tty1") ;session
+              ("seat0")                             ;seat
+              ("0" "root"))                         ;user
+
+            (begin
+              ;; Wait for tty1.
+              (marionette-eval
+               '(begin
+                  (use-modules (gnu services herd))
+                  (start-service 'term-tty1))
+               marionette)
+              (marionette-control "sendkey ctrl-alt-f1" marionette)
+
+              ;; Now we can type.
+              (marionette-type "root\n" marionette)
+              (marionette-type "loginctl list-users --no-legend > users\n"
+                               marionette)
+              (marionette-type "loginctl list-seats --no-legend > seats\n"
+                               marionette)
+              (marionette-type "loginctl list-sessions --no-legend > sessions\n"
+                               marionette)
+
+
+              ;; Read the three files.
+              (marionette-eval '(use-modules (rnrs io ports)) marionette)
+              (let ((guest-file (lambda (file)
+                                  (string-tokenize
+                                   (wait-for-file file marionette
+                                                  #:read 'get-string-all)))))
+                (list (guest-file "/root/sessions")
+                      (guest-file "/root/seats")
+                      (guest-file "/root/users")))))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "elogind" test))
+
+(define %test-elogind
+  (system-test
+   (name "elogind")
+   (description
+    "Test whether we can log in when elogind is enabled, and whether
+'loginctl' reports accurate user, session, and seat information.")
+   (value
+    (let ((os (marionette-operating-system
+               (simple-operating-system
+                (service elogind-service-type)
+                (service polkit-service-type)
+                (service dbus-root-service-type))
+               #:imported-modules '((gnu services herd)
+                                    (guix combinators)))))
+      (run-elogind-test (virtual-machine os))))))
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index 866bf885ce..d0cc08f431 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -37,6 +37,7 @@
   #:use-module (guix utils)
   #:export (%test-installed-os
             %test-installed-extlinux-os
+            %test-iso-image-installer
             %test-separate-store-os
             %test-separate-home-os
             %test-raid-root-os
@@ -126,7 +127,11 @@
   "Return a variant of OS where ROOTS are registered as GC roots."
   (operating-system
     (inherit os)
-    (services (cons (service gc-root-service-type roots)
+
+    ;; We use this procedure for the installation OS, which already defines GC
+    ;; roots.  Add ROOTS to those.
+    (services (cons (simple-service 'extra-root
+                                    gc-root-service-type roots)
                     (operating-system-user-services os)))))
 
 
@@ -196,6 +201,7 @@ reboot\n")
                              (kernel-arguments '("console=ttyS0")))
                            #:imported-modules '((gnu services herd)
                                                 (guix combinators))))
+                      (installation-disk-image-file-system-type "ext4")
                       (target-size (* 1200 MiB)))
   "Run SCRIPT (a shell script following the GuixSD installation procedure) in
 OS to install TARGET-OS.  Return a VM image of TARGET-SIZE bytes containing
@@ -213,7 +219,9 @@ packages defined in installation-os."
                        (image  (system-disk-image
                                 (operating-system-with-gc-roots
                                  os (list target))
-                                #:disk-image-size (* 1500 MiB))))
+                                #:disk-image-size (* 1500 MiB)
+                                #:file-system-type
+                                installation-disk-image-file-system-type)))
     (define install
       (with-imported-modules '((guix build utils)
                                (gnu build marionette))
@@ -229,16 +237,25 @@ packages defined in installation-os."
 
             (define marionette
               (make-marionette
-               (cons (which #$(qemu-command system))
-                     (cons* "-no-reboot" "-m" "800"
-                            "-drive"
-                            (string-append "file=" #$image
-                                           ",if=virtio,readonly")
-                            "-drive"
-                            (string-append "file=" #$output ",if=virtio")
-                            (if (file-exists? "/dev/kvm")
-                                '("-enable-kvm")
-                                '())))))
+               `(,(which #$(qemu-command system))
+                 "-no-reboot"
+                 "-m" "800"
+                 #$@(cond
+                     ((string=? "ext4" installation-disk-image-file-system-type)
+                      #~("-drive"
+                         ,(string-append "file=" #$image
+                                         ",if=virtio,readonly")))
+                     ((string=? "iso9660" installation-disk-image-file-system-type)
+                      #~("-cdrom" #$image))
+                     (else
+                      (error
+                       "unsupported installation-disk-image-file-system-type:"
+                       installation-disk-image-file-system-type)))
+                 "-drive"
+                 ,(string-append "file=" #$output ",if=virtio")
+                 ,@(if (file-exists? "/dev/kvm")
+                       '("-enable-kvm")
+                       '()))))
 
             (pk 'uname (marionette-eval '(uname) marionette))
 
@@ -314,6 +331,81 @@ per %test-installed-os, this test is expensive in terms of CPU and storage.")
 
 
 ;;;
+;;; Installation through an ISO image.
+;;;
+
+(define-os-with-source (%minimal-os-on-vda %minimal-os-on-vda-source)
+  ;; The OS we want to install.
+  (use-modules (gnu) (gnu tests) (srfi srfi-1))
+
+  (operating-system
+    (host-name "liberigilo")
+    (timezone "Europe/Paris")
+    (locale "en_US.UTF-8")
+
+    (bootloader (grub-configuration (target "/dev/vda")))
+    (kernel-arguments '("console=ttyS0"))
+    (file-systems (cons (file-system
+                          (device "my-root")
+                          (title 'label)
+                          (mount-point "/")
+                          (type "ext4"))
+                        %base-file-systems))
+    (users (cons (user-account
+                  (name "alice")
+                  (comment "Bob's sister")
+                  (group "users")
+                  (supplementary-groups '("wheel" "audio" "video"))
+                  (home-directory "/home/alice"))
+                 %base-user-accounts))
+    (services (cons (service marionette-service-type
+                             (marionette-configuration
+                              (imported-modules '((gnu services herd)
+                                                  (guix combinators)))))
+                    %base-services))))
+
+(define %simple-installation-script-for-/dev/vda
+  ;; Shell script of a simple installation.
+  "\
+. /etc/profile
+set -e -x
+guix --version
+
+export GUIX_BUILD_OPTIONS=--no-grafts
+guix build isc-dhcp
+parted --script /dev/vda mklabel gpt \\
+  mkpart primary ext2 1M 3M \\
+  mkpart primary ext2 3M 1G \\
+  set 1 boot on \\
+  set 1 bios_grub on
+mkfs.ext4 -L my-root /dev/vda2
+mount /dev/vda2 /mnt
+df -h /mnt
+herd start cow-store /mnt
+mkdir /mnt/etc
+cp /etc/target-config.scm /mnt/etc/config.scm
+guix system init /mnt/etc/config.scm /mnt --no-substitutes
+sync
+reboot\n")
+
+(define %test-iso-image-installer
+  (system-test
+   (name "iso-image-installer")
+   (description
+    "")
+   (value
+    (mlet* %store-monad ((image   (run-install
+                                   %minimal-os-on-vda
+                                   %minimal-os-on-vda-source
+                                   #:script
+                                   %simple-installation-script-for-/dev/vda
+                                   #:installation-disk-image-file-system-type
+                                   "iso9660"))
+                         (command (qemu-command/writable-image image)))
+      (run-basic-test %minimal-os-on-vda command name)))))
+
+
+;;;
 ;;; Separate /home.
 ;;;
 
diff --git a/gnu/tests/rsync.scm b/gnu/tests/rsync.scm
new file mode 100644
index 0000000000..c97836788b
--- /dev/null
+++ b/gnu/tests/rsync.scm
@@ -0,0 +1,126 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
+;;;
+;;; 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 (gnu tests rsync)
+  #:use-module (gnu packages rsync)
+  #:use-module (gnu tests)
+  #:use-module (gnu system)
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu system shadow)
+  #:use-module (gnu system vm)
+  #:use-module (gnu services)
+  #:use-module (gnu services rsync)
+  #:use-module (gnu services networking)
+  #:use-module (guix gexp)
+  #:use-module (guix store)
+  #:export (%test-rsync))
+
+(define* (run-rsync-test rsync-os #:optional (rsync-port 873))
+  "Run tests in %RSYNC-OS, which has rsync running and listening on
+PORT."
+  (define os
+    (marionette-operating-system
+     rsync-os
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm
+    (virtual-machine
+     (operating-system os)
+     (port-forwardings '())))
+
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (srfi srfi-11) (srfi srfi-64)
+                       (gnu build marionette))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "rsync")
+
+          ;; Wait for rsync to be up and running.
+          (test-eq "service running"
+            'running!
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (start-service 'rsync)
+                'running!)
+             marionette))
+
+          ;; Make sure the PID file is created.
+          (test-assert "PID file"
+            (marionette-eval
+             '(file-exists? "/var/run/rsyncd/rsyncd.pid")
+             marionette))
+
+          (test-assert "Test file copied to share"
+            (marionette-eval
+             '(begin
+                (call-with-output-file "/tmp/input"
+                  (lambda (port)
+                    (display "test-file-contents\n" port)))
+                (zero?
+                 (system* "rsync" "/tmp/input"
+                          (string-append "rsync://localhost:"
+                                         (number->string #$rsync-port)
+                                         "/files/input"))))
+             marionette))
+
+          (test-equal "Test file correctly received from share"
+            "test-file-contents"
+            (marionette-eval
+             '(begin
+                (use-modules (ice-9 rdelim))
+                (zero?
+                 (system* "rsync"
+                          (string-append "rsync://localhost:"
+                                         (number->string #$rsync-port)
+                                         "/files/input")
+                          "/tmp/output"))
+                (call-with-input-file "/tmp/output"
+                  (lambda (port)
+                    (read-line port))))
+             marionette))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "rsync-test" test))
+
+(define* %rsync-os
+  ;; Return operating system under test.
+  (let ((base-os
+         (simple-operating-system
+          (dhcp-client-service)
+          (service rsync-service-type))))
+    (operating-system
+      (inherit base-os)
+      (packages (cons* rsync
+                       (operating-system-packages base-os))))))
+
+(define %test-rsync
+  (system-test
+   (name "rsync")
+   (description "Connect to a running RSYNC server.")
+   (value (run-rsync-test %rsync-os))))