Merge branch 'staging' into core-updates

4 files changed, 159 insertions, 15 deletions

diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index f9390ee8e4..247f237622 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -307,6 +307,20 @@ info --version")
               (wait-for-file "/root/logged-in" marionette
                              #:read 'get-string-all)))
 
+          (test-equal "getlogin on tty1"
+            "\"root\""
+            (begin
+              ;; Assume we logged in in the previous test and type.
+              (marionette-type "guile -c '(write (getlogin))' > /root/login-id.tmp\n"
+                               marionette)
+              (marionette-type "mv /root/login-id{.tmp,}\n"
+                               marionette)
+
+              ;; It can take a while before the shell commands are executed.
+              (marionette-eval '(use-modules (rnrs io ports)) marionette)
+              (wait-for-file "/root/login-id" marionette
+                             #:read 'get-string-all)))
+
           ;; There should be one utmpx entry for the user logged in on tty1.
           (test-equal "utmpx entry"
             '(("root" "tty1" #f))
@@ -368,6 +382,9 @@ info --version")
                                                     result)
                              marionette))
 
+          ;; FIXME: The 'invalidate' action can't reliably obtain the exit
+          ;; code of 'nscd' so skip this test.
+          (test-skip 1)
           (test-equal "nscd invalidate action, wrong table"
             '(#f)                                 ;one value, #f
             (marionette-eval '(with-shepherd-action 'nscd ('invalidate "xyz")
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 25e172efae..3cd3a27884 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +29,7 @@
   #:use-module (gnu services desktop)
   #:use-module (gnu packages bootstrap) ; %bootstrap-guile
   #:use-module (gnu packages docker)
+  #:use-module (gnu packages guile)
   #:use-module (guix gexp)
   #:use-module (guix grafts)
   #:use-module (guix monads)
@@ -38,7 +40,8 @@
   #:use-module (guix tests)
   #:use-module (guix build-system trivial)
   #:use-module ((guix licenses) #:prefix license:)
-  #:export (%test-docker))
+  #:export (%test-docker
+            %test-docker-system))
 
 (define %docker-os
   (simple-operating-system
@@ -166,3 +169,116 @@ standard output device and then enters a new line.")
    (name "docker")
    (description "Test Docker container of Guix.")
    (value (build-tarball&run-docker-test))))
+
+
+(define (run-docker-system-test tarball)
+  "Load DOCKER-TARBALL as Docker image and run it in a Docker container,
+inside %DOCKER-OS."
+  (define os
+    (marionette-operating-system
+     %docker-os
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+
+  (define vm
+    (virtual-machine
+     (operating-system os)
+     ;; FIXME: Because we're using the volatile-root setup where the root file
+     ;; system is a tmpfs overlaid over a small root file system, 'docker
+     ;; load' must be able to store the whole image into memory, hence the
+     ;; huge memory requirements.  We should avoid the volatile-root setup
+     ;; instead.
+     (memory-size 3000)
+     (port-forwardings '())))
+
+  (define test
+    (with-imported-modules '((gnu build marionette)
+                             (guix build utils))
+      #~(begin
+          (use-modules (srfi srfi-11) (srfi srfi-64)
+                       (gnu build marionette)
+                       (guix build utils))
+
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "docker")
+
+          (test-assert "service running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (match (start-service 'dockerd)
+                  (#f #f)
+                  (('service response-parts ...)
+                   (match (assq-ref response-parts 'running)
+                     ((pid) (number? pid))))))
+             marionette))
+
+          (test-assert "load system image and run it"
+            (marionette-eval
+             `(begin
+                (define (slurp command . args)
+                  ;; Return the output from COMMAND.
+                  (let* ((port (apply open-pipe* OPEN_READ command args))
+                         (output (read-line port))
+                         (status (close-pipe port)))
+                    output))
+
+                (define (docker-cli command . args)
+                  ;; Run the given Docker COMMAND.
+                  (apply invoke #$(file-append docker-cli "/bin/docker")
+                         command args))
+
+                (define (wait-for-container-file container file)
+                  ;; Wait for FILE to show up in CONTAINER.
+                  (docker-cli "exec" container
+                              #$(file-append guile-2.2 "/bin/guile")
+                              "-c"
+                              (object->string
+                               `(let loop ((n 15))
+                                  (when (zero? n)
+                                    (error "file didn't show up" ,file))
+                                  (unless (file-exists? ,file)
+                                    (sleep 1)
+                                    (loop (- n 1)))))))
+
+                (let* ((line (slurp #$(file-append docker-cli "/bin/docker")
+                                    "load" "-i" #$tarball))
+                       (repository&tag (string-drop line
+                                                    (string-length
+                                                     "Loaded image: ")))
+                       (container (slurp
+                                   #$(file-append docker-cli "/bin/docker")
+                                   "create" repository&tag)))
+                  (docker-cli "start" container)
+
+                  ;; Wait for shepherd to be ready.
+                  (wait-for-container-file container
+                                           "/var/run/shepherd/socket")
+
+                  (docker-cli "exec" container
+                              "/run/current-system/profile/bin/herd"
+                              "status")
+                  (slurp #$(file-append docker-cli "/bin/docker")
+                         "exec" container
+                         "/run/current-system/profile/bin/herd"
+                         "status" "guix-daemon")))
+             marionette))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "docker-system-test" test))
+
+(define %test-docker-system
+  (system-test
+   (name "docker-system")
+   (description "Run a system image as produced by @command{guix system
+docker-image} inside Docker.")
+   (value (with-monad %store-monad
+            (>>= (system-docker-image (simple-operating-system))
+                 run-docker-system-test)))))
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index 430a102378..7b5ee18505 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -123,17 +123,6 @@
                                     (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)
-
-    ;; 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)))))
-
 
 (define MiB (expt 2 20))
 
diff --git a/gnu/tests/ssh.scm b/gnu/tests/ssh.scm
index e5cd439cdf..a74227ea4a 100644
--- a/gnu/tests/ssh.scm
+++ b/gnu/tests/ssh.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
 ;;;
@@ -31,7 +31,8 @@
   #:export (%test-openssh
             %test-dropbear))
 
-(define* (run-ssh-test name ssh-service pid-file #:key (sftp? #f))
+(define* (run-ssh-test name ssh-service pid-file
+                       #:key (sftp? #f) (test-getlogin? #t))
   "Run a test of an OS running SSH-SERVICE, which writes its PID to PID-FILE.
 SSH-SERVICE must be configured to listen on port 22 and to allow for root and
 empty-password logins.
@@ -54,10 +55,12 @@ When SFTP? is true, run an SFTP server test."
             (use-modules (gnu build marionette)
                          (srfi srfi-26)
                          (srfi srfi-64)
+                         (ice-9 textual-ports)
                          (ice-9 match)
                          (ssh session)
                          (ssh auth)
                          (ssh channel)
+                         (ssh popen)
                          (ssh sftp))
 
             (define marionette
@@ -147,6 +150,20 @@ root with an empty password."
                    (and (zero? (channel-get-exit-status channel))
                         (wait-for-file "/root/witness" marionette))))))
 
+            ;; Check whether the 'getlogin' procedure returns the right thing.
+            (unless #$test-getlogin?
+              (test-skip 1))
+            (test-equal "getlogin"
+              '(0 "root")
+              (call-with-connected-session/auth
+               (lambda (session)
+                 (let* ((pipe   (open-remote-input-pipe
+                                 session
+                                 "guile -c '(display (getlogin))'"))
+                        (output (get-string-all pipe))
+                        (status (channel-get-exit-status pipe)))
+                   (list status output)))))
+
             ;; Connect to the guest over SFTP.  Make sure we can write and
             ;; read a file there.
             (unless #$sftp?
@@ -217,4 +234,9 @@ root with an empty password."
                                  (dropbear-configuration
                                   (root-login? #t)
                                   (allow-empty-passwords? #t)))
-                        "/var/run/dropbear.pid"))))
+                        "/var/run/dropbear.pid"
+
+                        ;; XXX: Our Dropbear is not built with PAM support.
+                        ;; Even when it is, it seems to ignore the PAM
+                        ;; 'session' requirements.
+                        #:test-getlogin? #f))))