Merge branch 'master' into core-updates

2 files changed, 421 insertions, 88 deletions

diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index 0f19449508..4fe779802b 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -24,13 +24,16 @@
   #:use-module (gnu system shadow)
   #:use-module (gnu system vm)
   #:use-module (gnu services)
+  #:use-module (gnu services mcron)
   #:use-module (gnu services shepherd)
   #:use-module (guix gexp)
   #:use-module (guix store)
   #:use-module (guix monads)
   #:use-module (guix packages)
   #:use-module (srfi srfi-1)
-  #:export (%test-basic-os))
+  #:export (run-basic-test
+            %test-basic-os
+            %test-mcron))
 
 (define %simple-os
   (operating-system
@@ -56,109 +59,227 @@
                  %base-user-accounts))))
 
 
+(define* (run-basic-test os command #:optional (name "basic"))
+  "Return a derivation called NAME that tests basic features of the OS started
+using COMMAND, a gexp that evaluates to a list of strings.  Compare some
+properties of running system to what's declared in OS, an <operating-system>."
+  (define test
+    #~(begin
+        (use-modules (gnu build marionette)
+                     (srfi srfi-1)
+                     (srfi srfi-26)
+                     (srfi srfi-64)
+                     (ice-9 match))
+
+        (define marionette
+          (make-marionette #$command))
+
+        (mkdir #$output)
+        (chdir #$output)
+
+        (test-begin "basic")
+
+        (test-assert "uname"
+          (match (marionette-eval '(uname) marionette)
+            (#("Linux" host-name version _ architecture)
+             (and (string=? host-name
+                            #$(operating-system-host-name os))
+                  (string-prefix? #$(package-version
+                                     (operating-system-kernel os))
+                                  version)
+                  (string-prefix? architecture %host-type)))))
+
+        (test-assert "shell and user commands"
+          ;; Is everything in $PATH?
+          (zero? (marionette-eval '(system "
+. /etc/profile
+set -e -x
+guix --version
+ls --version
+grep --version
+info --version")
+                                  marionette)))
+
+        (test-assert "accounts"
+          (let ((users (marionette-eval '(begin
+                                           (use-modules (ice-9 match))
+                                           (let loop ((result '()))
+                                             (match (getpw)
+                                               (#f (reverse result))
+                                               (x  (loop (cons x result))))))
+                                        marionette)))
+            (lset= string=?
+                   (map passwd:name users)
+                   (list
+                    #$@(map user-account-name
+                            (operating-system-user-accounts os))))))
+
+        (test-assert "shepherd services"
+          (let ((services (marionette-eval '(begin
+                                              (use-modules (gnu services herd))
+                                              (call-with-values current-services
+                                                append))
+                                           marionette)))
+            (lset= eq?
+                   (pk 'services services)
+                   '(root #$@(operating-system-shepherd-service-names os)))))
+
+        (test-equal "login on tty1"
+          "root\n"
+          (begin
+            (marionette-control "sendkey ctrl-alt-f1" marionette)
+            ;; Wait for the 'term-tty1' service to be running (using
+            ;; 'start-service' is the simplest and most reliable way to do
+            ;; that.)
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (start-service 'term-tty1))
+             marionette)
+
+            ;; Now we can type.
+            (marionette-type "root\n\nid -un > logged-in\n" marionette)
+
+            ;; It can take a while before the shell commands are executed.
+            (let loop ((i 0))
+              (unless (or (file-exists? "/root/logged-in") (> i 15))
+                (sleep 1)
+                (loop (+ i 1))))
+            (marionette-eval '(use-modules (rnrs io ports)) marionette)
+            (marionette-eval '(call-with-input-file "/root/logged-in"
+                                get-string-all)
+                             marionette)))
+
+        (test-assert "screendump"
+          (begin
+            (marionette-control (string-append "screendump " #$output
+                                               "/tty1.ppm")
+                                marionette)
+            (file-exists? "tty1.ppm")))
+
+        (test-end)
+        (exit (= (test-runner-fail-count (test-runner-current)) 0))))
+
+  (gexp->derivation name test
+                    #:modules '((gnu build marionette))))
+
 (define %test-basic-os
-  ;; Monadic derivation that instruments %SIMPLE-OS, runs it in a VM, and runs
-  ;; a series of basic functionality tests.
-  (mlet* %store-monad ((os -> (marionette-operating-system
-                               %simple-os
-                               #:imported-modules '((gnu services herd)
-                                                    (guix combinators))))
-                       (run   (system-qemu-image/shared-store-script
-                               os #:graphic? #f)))
+  (system-test
+   (name "basic")
+   (description
+    "Instrument %SIMPLE-OS, run it in a VM, and run a series of basic
+functionality tests.")
+   (value
+    (mlet* %store-monad ((os -> (marionette-operating-system
+                                 %simple-os
+                                 #:imported-modules '((gnu services herd)
+                                                      (guix combinators))))
+                         (run   (system-qemu-image/shared-store-script
+                                 os #:graphic? #f)))
+      ;; XXX: Add call to 'virtualized-operating-system' to get the exact same
+      ;; set of services as the OS produced by
+      ;; 'system-qemu-image/shared-store-script'.
+      (run-basic-test (virtualized-operating-system os '())
+                      #~(list #$run))))))
+
+
+;;;
+;;; Mcron.
+;;;
+
+(define %mcron-os
+  ;; System with an mcron service, with one mcron job for "root" and one mcron
+  ;; job for an unprivileged user (note: #:user is an 'mcron2' thing.)
+  (let ((job1 #~(job next-second-from
+                     (lambda ()
+                       (call-with-output-file "witness"
+                         (lambda (port)
+                           (display (list (getuid) (getgid)) port))))))
+        (job2 #~(job next-second-from
+                     (lambda ()
+                       (call-with-output-file "witness"
+                         (lambda (port)
+                           (display (list (getuid) (getgid)) port))))
+                     #:user "alice"))
+        (job3 #~(job next-second-from             ;to test $PATH
+                     "touch witness-touch")))
+    (operating-system
+      (inherit %simple-os)
+      (services (cons (mcron-service (list job1 job2 job3))
+                      (operating-system-user-services %simple-os))))))
+
+(define (run-mcron-test name)
+  (mlet* %store-monad ((os ->   (marionette-operating-system
+                                 %mcron-os
+                                 #:imported-modules '((gnu services herd)
+                                                      (guix combinators))))
+                       (command (system-qemu-image/shared-store-script
+                                 os #:graphic? #f)))
     (define test
       #~(begin
           (use-modules (gnu build marionette)
-                       (srfi srfi-1)
-                       (srfi srfi-26)
                        (srfi srfi-64)
                        (ice-9 match))
 
           (define marionette
-            (make-marionette (list #$run)))
+            (make-marionette (list #$command)))
+
+          (define (wait-for-file file)
+            ;; Wait until FILE exists in the guest; 'read' its content and
+            ;; return it.
+            (marionette-eval
+             `(let loop ((i 10))
+                (cond ((file-exists? ,file)
+                       (call-with-input-file ,file read))
+                      ((> i 0)
+                       (sleep 1)
+                       (loop (- i 1)))
+                      (else
+                       (error "file didn't show up" ,file))))
+             marionette))
 
           (mkdir #$output)
           (chdir #$output)
 
-          (test-begin "basic")
+          (test-begin "mcron")
 
-          (test-assert "uname"
-            (match (marionette-eval '(uname) marionette)
-              (#("Linux" "komputilo" version _ "x86_64")
-               (string-prefix? #$(package-version
-                                  (operating-system-kernel os))
-                               version))))
+          (test-eq "service running"
+            'running!
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (start-service 'mcron)
+                'running!)
+             marionette))
 
-          (test-assert "shell and user commands"
-            ;; Is everything in $PATH?
-            (zero? (marionette-eval '(system "
-. /etc/profile
-set -e -x
-guix --version
-ls --version
-grep --version
-info --version")
-                                    marionette)))
-
-          (test-assert "accounts"
-            (let ((users (marionette-eval '(begin
-                                             (use-modules (ice-9 match))
-                                             (let loop ((result '()))
-                                               (match (getpw)
-                                                 (#f (reverse result))
-                                                 (x  (loop (cons x result))))))
-                                          marionette)))
-              (lset= string=?
-                     (map passwd:name users)
-                     (list
-                      #$@(map user-account-name
-                              (operating-system-user-accounts os))))))
-
-          (test-assert "shepherd services"
-            (let ((services (marionette-eval '(begin
-                                                (use-modules (gnu services herd))
-                                                (call-with-values current-services
-                                                  append))
-                                             marionette)))
-              (lset= eq?
-                     (pk 'services services)
-                     '(root #$@(operating-system-shepherd-service-names
-                                (virtualized-operating-system os '()))))))
-
-          (test-equal "login on tty1"
-            "root\n"
-            (begin
-              (marionette-control "sendkey ctrl-alt-f1" marionette)
-              ;; Wait for the 'term-tty1' service to be running (using
-              ;; 'start-service' is the simplest and most reliable way to do
-              ;; that.)
-              (marionette-eval
-               '(begin
-                  (use-modules (gnu services herd))
-                  (start-service 'term-tty1))
-               marionette)
-
-              ;; Now we can type.
-              (marionette-type "root\n\nid -un > logged-in\n" marionette)
-
-              ;; It can take a while before the shell commands are executed.
-              (let loop ((i 0))
-                (unless (or (file-exists? "/root/logged-in") (> i 15))
-                  (sleep 1)
-                  (loop (+ i 1))))
-              (marionette-eval '(use-modules (rnrs io ports)) marionette)
-              (marionette-eval '(call-with-input-file "/root/logged-in"
-                                  get-string-all)
-                               marionette)))
-
-          (test-assert "screendump"
-            (begin
-              (marionette-control (string-append "screendump " #$output
-                                                 "/tty1.ppm")
-                                  marionette)
-              (file-exists? "tty1.ppm")))
+          ;; Make sure root's mcron job runs, has its cwd set to "/root", and
+          ;; runs with the right UID/GID.
+          (test-equal "root's job"
+            '(0 0)
+            (wait-for-file "/root/witness"))
+
+          ;; Likewise for Alice's job.  We cannot know what its GID is since
+          ;; it's chosen by 'groupadd', but it's strictly positive.
+          (test-assert "alice's job"
+            (match (wait-for-file "/home/alice/witness")
+              ((1000 gid)
+               (>= 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.)
+          (test-equal "root's job with command"
+            "#<eof>"
+            (wait-for-file "/root/witness-touch"))
 
           (test-end)
           (exit (= (test-runner-fail-count (test-runner-current)) 0))))
 
-    (gexp->derivation "basic" test
+    (gexp->derivation name test
                       #:modules '((gnu build marionette)))))
+
+(define %test-mcron
+  (system-test
+   (name "mcron")
+   (description "Make sure the mcron service works as advertised.")
+   (value (run-mcron-test name))))
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
new file mode 100644
index 0000000000..5d893deb4c
--- /dev/null
+++ b/gnu/tests/install.scm
@@ -0,0 +1,212 @@
+;;; 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 (gnu tests install)
+  #:use-module (gnu)
+  #:use-module (gnu tests)
+  #:use-module (gnu tests base)
+  #:use-module (gnu system)
+  #:use-module (gnu system install)
+  #:use-module (gnu system vm)
+  #:use-module ((gnu build vm) #:select (qemu-command))
+  #:use-module (gnu packages qemu)
+  #:use-module (gnu packages package-management)
+  #:use-module (guix store)
+  #:use-module (guix monads)
+  #:use-module (guix packages)
+  #:use-module (guix grafts)
+  #:use-module (guix gexp)
+  #:use-module (guix utils)
+  #:export (%test-installed-os))
+
+;;; Commentary:
+;;;
+;;; Test the installation of GuixSD using the documented approach at the
+;;; command line.
+;;;
+;;; Code:
+
+(define-os-with-source (%minimal-os %minimal-os-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 (device "/dev/vdb")))
+    (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
+                             '((gnu services herd)
+                               (guix combinators)))
+                    %base-services))))
+
+(define (operating-system-with-current-guix os)
+  "Return a variant of OS that uses the current Guix."
+  (operating-system
+    (inherit os)
+    (services (modify-services (operating-system-user-services os)
+                (guix-service-type config =>
+                                   (guix-configuration
+                                    (inherit config)
+                                    (guix (current-guix))))))))
+
+(define (operating-system-with-gc-roots os roots)
+  "Return a variant of OS where ROOTS are registered as GC roots."
+  (operating-system
+    (inherit os)
+    (services (cons (service gc-root-service-type roots)
+                    (operating-system-user-services os)))))
+
+
+(define MiB (expt 2 20))
+
+(define* (run-install #:key
+                      (os (marionette-operating-system
+                           ;; Since the image has no network access, use the
+                           ;; current Guix so the store items we need are in
+                           ;; the image.
+                           (operating-system
+                             (inherit (operating-system-with-current-guix
+                                       installation-os))
+                             (kernel-arguments '("console=ttyS0")))
+                           #:imported-modules '((gnu services herd)
+                                                (guix combinators))))
+                      (target-size (* 1200 MiB)))
+  "Run the GuixSD installation procedure from OS and return a VM image of
+TARGET-SIZE bytes containing the installed system."
+
+  (mlet* %store-monad ((_      (set-grafting #f))
+                       (system (current-system))
+                       (target (operating-system-derivation %minimal-os))
+
+                       ;; Since the installation system has no network access,
+                       ;; we cheat a little bit by adding TARGET to its GC
+                       ;; roots.  This way, we know 'guix system init' will
+                       ;; succeed.
+                       (image  (system-disk-image
+                                (operating-system-with-gc-roots
+                                 os (list target))
+                                #:disk-image-size (* 1500 MiB))))
+    (define install
+      #~(begin
+          (use-modules (guix build utils)
+                       (gnu build marionette))
+
+          (set-path-environment-variable "PATH" '("bin")
+                                         (list #$qemu-minimal))
+
+          (system* "qemu-img" "create" "-f" "qcow2"
+                   #$output #$(number->string target-size))
+
+          (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")
+                              '())))))
+
+          (pk 'uname (marionette-eval '(uname) marionette))
+
+          ;; Wait for tty1.
+          (marionette-eval '(begin
+                              (use-modules (gnu services herd))
+                              (start 'term-tty1))
+                           marionette)
+
+          (marionette-eval '(call-with-output-file "/etc/litl-config.scm"
+                              (lambda (port)
+                                (write '#$%minimal-os-source port)))
+                           marionette)
+
+          (exit (marionette-eval '(zero? (system "
+. /etc/profile
+set -e -x;
+guix --version
+guix gc --list-live | grep isc-dhcp
+
+export GUIX_BUILD_OPTIONS=--no-grafts
+guix build isc-dhcp
+parted --script /dev/vdb 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/vdb2
+ls -l /dev/vdb
+mount /dev/vdb2 /mnt
+df -h /mnt
+herd start cow-store /mnt
+mkdir /mnt/etc
+cp /etc/litl-config.scm /mnt/etc/config.scm
+guix system init /mnt/etc/config.scm /mnt --no-substitutes
+sync
+reboot\n"))
+                                 marionette))))
+
+    (gexp->derivation "installation" install
+                      #:modules '((guix build utils)
+                                  (gnu build marionette)))))
+
+
+(define %test-installed-os
+  (system-test
+   (name "installed-os")
+   (description
+    "Test basic functionality of an OS installed like one would do by hand.
+This test is expensive in terms of CPU and storage usage since we need to
+build (current-guix) and then store a couple of full system images.")
+   (value
+    (mlet %store-monad ((image  (run-install))
+                        (system (current-system)))
+      (run-basic-test %minimal-os
+                      #~(let ((image #$image))
+                          ;; First we need a writable copy of the image.
+                          (format #t "copying image '~a'...~%" image)
+                          (copy-file image "disk.img")
+                          (chmod "disk.img" #o644)
+                          `(,(string-append #$qemu-minimal "/bin/"
+                                            #$(qemu-command system))
+                            ,@(if (file-exists? "/dev/kvm")
+                                  '("-enable-kvm")
+                                  '())
+                            "-no-reboot" "-m" "256"
+                            "-drive" "file=disk.img,if=virtio"))
+                      "installed-os")))))
+
+;;; install.scm ends here