Merge branch 'master' into core-updates

2 files changed, 230 insertions, 5 deletions

diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index bce4c4b9d4..8842d48df8 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
-;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2017, 2019 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -43,7 +43,8 @@
             %test-separate-home-os
             %test-raid-root-os
             %test-encrypted-root-os
-            %test-btrfs-root-os))
+            %test-btrfs-root-os
+            %test-jfs-root-os))
 
 ;;; Commentary:
 ;;;
@@ -810,4 +811,77 @@ build (current-guix) and then store a couple of full system images.")
                          (command (qemu-command/writable-image image)))
       (run-basic-test %btrfs-root-os command "btrfs-root-os")))))
 
+
+;;;
+;;; JFS root file system.
+;;;
+
+(define-os-with-source (%jfs-root-os %jfs-root-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 (bootloader-configuration
+                 (bootloader grub-bootloader)
+                 (target "/dev/vdb")))
+    (kernel-arguments '("console=ttyS0"))
+    (file-systems (cons (file-system
+                          (device (file-system-label "my-root"))
+                          (mount-point "/")
+                          (type "jfs"))
+                        %base-file-systems))
+    (users (cons (user-account
+                  (name "charlie")
+                  (group "users")
+                  (supplementary-groups '("wheel" "audio" "video")))
+                 %base-user-accounts))
+    (services (cons (service marionette-service-type
+                             (marionette-configuration
+                              (imported-modules '((gnu services herd)
+                                                  (guix combinators)))))
+                    %base-services))))
+
+(define %jfs-root-installation-script
+  ;; Shell script of a simple installation.
+  "\
+. /etc/profile
+set -e -x
+guix --version
+
+export GUIX_BUILD_OPTIONS=--no-grafts
+ls -l /run/current-system/gc-roots
+parted --script /dev/vdb mklabel gpt \\
+  mkpart primary ext2 1M 3M \\
+  mkpart primary ext2 3M 2G \\
+  set 1 boot on \\
+  set 1 bios_grub on
+jfs_mkfs -L my-root -q /dev/vdb2
+mount /dev/vdb2 /mnt
+herd start cow-store /mnt
+mkdir /mnt/etc
+cp /etc/target-config.scm /mnt/etc/config.scm
+guix system build /mnt/etc/config.scm
+guix system init /mnt/etc/config.scm /mnt --no-substitutes
+sync
+reboot\n")
+
+(define %test-jfs-root-os
+  (system-test
+   (name "jfs-root-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 %jfs-root-os
+                                               %jfs-root-os-source
+                                               #:script
+                                               %jfs-root-installation-script))
+                         (command (qemu-command/writable-image image)))
+      (run-basic-test %jfs-root-os command "jfs-root-os")))))
+
 ;;; install.scm ends here
diff --git a/gnu/tests/nfs.scm b/gnu/tests/nfs.scm
index 7ef9f1f7bf..014d049ab5 100644
--- a/gnu/tests/nfs.scm
+++ b/gnu/tests/nfs.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -33,10 +34,12 @@
   #:use-module (gnu services nfs)
   #:use-module (gnu services networking)
   #:use-module (gnu packages onc-rpc)
+  #:use-module (gnu packages nfs)
   #:use-module (guix gexp)
   #:use-module (guix store)
   #:use-module (guix monads)
-  #:export (%test-nfs))
+  #:export (%test-nfs
+            %test-nfs-server))
 
 (define %base-os
   (operating-system
@@ -53,8 +56,7 @@
                rpcbind
                %base-packages))
     (services (cons*
-               (service rpcbind-service-type
-                        (rpcbind-configuration))
+               (service rpcbind-service-type)
                (service dhcp-client-service-type)
                %base-services))))
 
@@ -133,3 +135,152 @@
    (name "nfs")
    (description "Test some things related to NFS.")
    (value (run-nfs-test name "/var/run/rpcbind.sock"))))
+
+
+(define %nfs-os
+  (let ((os (simple-operating-system
+             (simple-service 'create-target-directory activation-service-type
+                             #~(begin
+                                 (mkdir "/remote")
+                                 (chmod "/remote" #o777)
+                                 #t))
+             (service dhcp-client-service-type)
+             (service nfs-service-type
+                      (nfs-configuration
+                       (debug '(nfs nfsd mountd))
+                       (exports '(("/export"
+                                   ;; crossmnt = This is the pseudo root.
+                                   ;; fsid=0 = root file system of the export
+                                   "*(ro,insecure,no_subtree_check,crossmnt,fsid=0)"))))))))
+    (operating-system
+      (inherit os)
+      (host-name "nfs-server")
+      ;; We need to use a tmpfs here, because the test system's root file
+      ;; system cannot be re-exported via NFS.
+      (file-systems (cons
+                     (file-system
+                       (device "none")
+                       (mount-point "/export")
+                       (type "tmpfs")
+                       (create-mount-point? #t))
+                     %base-file-systems))
+      (services
+       ;; Enable debugging output.
+       (modify-services (operating-system-user-services os)
+         (syslog-service-type config
+                              =>
+                              (syslog-configuration
+                               (inherit config)
+                               (config-file
+                                (plain-file
+                                 "syslog.conf"
+                                 "*.* /dev/console\n")))))))))
+
+(define (run-nfs-server-test)
+  "Run a test of an OS running a service of NFS-SERVICE-TYPE."
+  (define os
+    (marionette-operating-system
+     %nfs-os
+     #:requirements '(nscd)
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$(virtual-machine os))))
+          (define (wait-for-file file)
+            ;; Wait until FILE  exists in the guest
+            (marionette-eval
+             `(let loop ((i 10))
+                (cond ((file-exists? ,file)
+                       #t)
+                      ((> i 0)
+                       (sleep 1)
+                       (loop (- i 1)))
+                      (else
+                       (error "File didn't show up: " ,file))))
+             marionette))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "nfs-daemon")
+          (marionette-eval
+           '(begin
+              (current-output-port
+               (open-file "/dev/console" "w0"))
+              (chmod "/export" #o777)
+              (with-output-to-file "/export/hello"
+                (lambda () (display "hello world")))
+              (chmod "/export/hello" #o777))
+           marionette)
+
+          (test-assert "nscd PID file is created"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (start-service 'nscd))
+             marionette))
+
+          (test-assert "nscd is listening on its socket"
+            (marionette-eval
+             ;; XXX: Work around a race condition in nscd: nscd creates its
+             ;; PID file before it is listening on its socket.
+             '(let ((sock (socket PF_UNIX SOCK_STREAM 0)))
+                (let try ()
+                  (catch 'system-error
+                    (lambda ()
+                      (connect sock AF_UNIX "/var/run/nscd/socket")
+                      (close-port sock)
+                      (format #t "nscd is ready~%")
+                      #t)
+                    (lambda args
+                      (format #t "waiting for nscd...~%")
+                      (usleep 500000)
+                      (try)))))
+             marionette))
+
+          (test-assert "network is up"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (start-service 'networking))
+             marionette))
+
+          ;; Wait for the NFS services to be up and running.
+          (test-assert "nfs services are running"
+            (and (marionette-eval
+                  '(begin
+                     (use-modules (gnu services herd))
+                     (start-service 'nfs))
+                  marionette)
+                 (wait-for-file "/var/run/rpc.statd.pid")))
+
+          (test-assert "nfs share is advertised"
+            (marionette-eval
+             '(zero? (system* (string-append #$nfs-utils "/sbin/showmount")
+                              "-e" "nfs-server"))
+             marionette))
+
+          (test-assert "nfs share mounted"
+            (marionette-eval
+             '(begin
+                (and (zero? (system* (string-append #$nfs-utils "/sbin/mount.nfs4")
+                                     "nfs-server:/" "/remote" "-v"))
+                     (file-exists? "/remote/hello")))
+             marionette))
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "nfs-server-test" test))
+
+(define %test-nfs-server
+  (system-test
+   (name "nfs-server")
+   (description "Test that an NFS server can be started and exported
+directories can be mounted.")
+   (value (run-nfs-server-test))))