tests: Introduce 'simple-operating-system' and use it.

* gnu/tests.scm (%simple-os): New macro.
(simple-operating-system): New macro.
* gnu/tests/base.scm (%simple-os): Define using 'simple-operating-system'.
(%mcron-os): Use 'simple-operating-system'.
* gnu/tests/mail.scm (%opensmtpd-os): Likewise.
* gnu/tests/messaging.scm (%base-os, os-with-service): Remove.
(run-xmpp-test): Use 'simple-operating-system'.
* gnu/tests/networking.scm (%inetd-os): Likewise.
* gnu/tests/ssh.scm (%base-os, os-with-service): Remove.
(run-ssh-test): Use 'simple-operating-system'.
* gnu/tests/web.scm (%nginx-os): Likewise.

7 files changed, 88 insertions, 150 deletions

diff --git a/gnu/tests.scm b/gnu/tests.scm
index 8abe6c608b..e84d1ebb20 100644
--- a/gnu/tests.scm
+++ b/gnu/tests.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,7 +21,11 @@
   #:use-module (guix utils)
   #:use-module (guix records)
   #:use-module (gnu system)
+  #:use-module (gnu system grub)
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu system shadow)
   #:use-module (gnu services)
+  #:use-module (gnu services base)
   #:use-module (gnu services shepherd)
   #:use-module ((gnu packages) #:select (scheme-modules))
   #:use-module (srfi srfi-1)
@@ -37,6 +41,8 @@
             marionette-operating-system
             define-os-with-source
 
+            simple-operating-system
+
             system-test
             system-test?
             system-test-name
@@ -190,6 +196,41 @@ the system under test."
 
 
 ;;;
+;;; Simple operating systems.
+;;;
+
+(define %simple-os
+  (operating-system
+    (host-name "komputilo")
+    (timezone "Europe/Berlin")
+    (locale "en_US.UTF-8")
+
+    (bootloader (grub-configuration (device "/dev/sdX")))
+    (file-systems (cons (file-system
+                          (device "my-root")
+                          (title 'label)
+                          (mount-point "/")
+                          (type "ext4"))
+                        %base-file-systems))
+    (firmware '())
+
+    (users (cons (user-account
+                  (name "alice")
+                  (comment "Bob's sister")
+                  (group "users")
+                  (supplementary-groups '("wheel" "audio" "video"))
+                  (home-directory "/home/alice"))
+                 %base-user-accounts))))
+
+(define-syntax-rule (simple-operating-system user-services ...)
+  "Return an operating system that includes USER-SERVICES in addition to
+%BASE-SERVICES."
+  (operating-system (inherit %simple-os)
+                    (services (cons* user-services ... %base-services))))
+
+
+
+;;;
 ;;; Tests.
 ;;;
 
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index 000a4ddecb..bcb8299c73 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -19,8 +19,6 @@
 (define-module (gnu tests base)
   #:use-module (gnu tests)
   #:use-module (gnu system)
-  #:use-module (gnu system grub)
-  #:use-module (gnu system file-systems)
   #:use-module (gnu system shadow)
   #:use-module (gnu system nss)
   #:use-module (gnu system vm)
@@ -44,27 +42,7 @@
             %test-nss-mdns))
 
 (define %simple-os
-  (operating-system
-    (host-name "komputilo")
-    (timezone "Europe/Berlin")
-    (locale "en_US.UTF-8")
-
-    (bootloader (grub-configuration (device "/dev/sdX")))
-    (file-systems (cons (file-system
-                          (device "my-root")
-                          (title 'label)
-                          (mount-point "/")
-                          (type "ext4"))
-                        %base-file-systems))
-    (firmware '())
-
-    (users (cons (user-account
-                  (name "alice")
-                  (comment "Bob's sister")
-                  (group "users")
-                  (supplementary-groups '("wheel" "audio" "video"))
-                  (home-directory "/home/alice"))
-                 %base-user-accounts))))
+  (simple-operating-system))
 
 
 (define* (run-basic-test os command #:optional (name "basic")
@@ -420,10 +398,8 @@ functionality tests.")
                      #: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))))))
+    (simple-operating-system
+     (mcron-service (list job1 job2 job3)))))
 
 (define (run-mcron-test name)
   (mlet* %store-monad ((os ->   (marionette-operating-system
diff --git a/gnu/tests/mail.scm b/gnu/tests/mail.scm
index 47328a54ae..d5c08b7f09 100644
--- a/gnu/tests/mail.scm
+++ b/gnu/tests/mail.scm
@@ -19,11 +19,8 @@
 (define-module (gnu tests mail)
   #:use-module (gnu tests)
   #:use-module (gnu system)
-  #:use-module (gnu system file-systems)
-  #:use-module (gnu system grub)
   #:use-module (gnu system vm)
   #:use-module (gnu services)
-  #:use-module (gnu services base)
   #:use-module (gnu services mail)
   #:use-module (gnu services networking)
   #:use-module (guix gexp)
@@ -32,23 +29,15 @@
   #:export (%test-opensmtpd))
 
 (define %opensmtpd-os
-  (operating-system
-    (host-name "komputilo")
-    (timezone "Europe/Berlin")
-    (locale "en_US.UTF-8")
-    (bootloader (grub-configuration (device #f)))
-    (file-systems %base-file-systems)
-    (firmware '())
-    (services (cons*
-               (dhcp-client-service)
-               (service opensmtpd-service-type
-                        (opensmtpd-configuration
-                         (config-file
-                          (plain-file "smtpd.conf" "
+  (simple-operating-system
+   (dhcp-client-service)
+   (service opensmtpd-service-type
+            (opensmtpd-configuration
+             (config-file
+              (plain-file "smtpd.conf" "
 listen on 0.0.0.0
 accept from any for local deliver to mbox
-"))))
-               %base-services))))
+"))))))
 
 (define (run-opensmtpd-test)
   "Return a test of an OS running OpenSMTPD service."
diff --git a/gnu/tests/messaging.scm b/gnu/tests/messaging.scm
index b0c8254ce0..cefb52534a 100644
--- a/gnu/tests/messaging.scm
+++ b/gnu/tests/messaging.scm
@@ -19,12 +19,8 @@
 (define-module (gnu tests messaging)
   #:use-module (gnu tests)
   #:use-module (gnu system)
-  #:use-module (gnu system grub)
-  #:use-module (gnu system file-systems)
-  #:use-module (gnu system shadow)
   #:use-module (gnu system vm)
   #:use-module (gnu services)
-  #:use-module (gnu services base)
   #:use-module (gnu services messaging)
   #:use-module (gnu services networking)
   #:use-module (gnu packages messaging)
@@ -33,30 +29,11 @@
   #:use-module (guix monads)
   #:export (%test-prosody))
 
-(define %base-os
-  (operating-system
-    (host-name "komputilo")
-    (timezone "Europe/Berlin")
-    (locale "en_US.UTF-8")
-
-    (bootloader (grub-configuration (device "/dev/sdX")))
-    (file-systems %base-file-systems)
-    (firmware '())
-    (users %base-user-accounts)
-    (services (cons (dhcp-client-service)
-                    %base-services))))
-
-(define (os-with-service service)
-  "Return a test operating system that runs SERVICE."
-  (operating-system
-    (inherit %base-os)
-    (services (cons service
-                    (operating-system-user-services %base-os)))))
-
 (define (run-xmpp-test name xmpp-service pid-file create-account)
   "Run a test of an OS running XMPP-SERVICE, which writes its PID to PID-FILE."
   (mlet* %store-monad ((os -> (marionette-operating-system
-                               (os-with-service xmpp-service)
+                               (simple-operating-system (dhcp-client-service)
+                                                        xmpp-service)
                                #:imported-modules '((gnu services herd))))
                        (command (system-qemu-image/shared-store-script
                                  os #:graphic? #f))
diff --git a/gnu/tests/networking.scm b/gnu/tests/networking.scm
index 53c80a4ac1..cfcb490874 100644
--- a/gnu/tests/networking.scm
+++ b/gnu/tests/networking.scm
@@ -19,12 +19,8 @@
 (define-module (gnu tests networking)
   #:use-module (gnu tests)
   #:use-module (gnu system)
-  #:use-module (gnu system grub)
-  #:use-module (gnu system file-systems)
-  #:use-module (gnu system shadow)
   #:use-module (gnu system vm)
   #:use-module (gnu services)
-  #:use-module (gnu services base)
   #:use-module (gnu services networking)
   #:use-module (guix gexp)
   #:use-module (guix store)
@@ -34,35 +30,27 @@
 
 (define %inetd-os
   ;; Operating system with 2 inetd services.
-  (operating-system
-    (host-name "komputilo")
-    (timezone "Europe/Brussels")
-    (locale "en_US.utf8")
-
-    (bootloader (grub-configuration (device "/dev/sdX")))
-    (file-systems %base-file-systems)
-    (firmware '())
-    (users %base-user-accounts)
-    (services (cons* (dhcp-client-service)
-                     (service inetd-service-type
-                              (inetd-configuration
-                               (entries (list
-                                         (inetd-entry
-                                          (name "echo")
-                                          (socket-type 'stream)
-                                          (protocol "tcp")
-                                          (wait? #f)
-                                          (user "root"))
-                                         (inetd-entry
-                                          (name "dict")
-                                          (socket-type 'stream)
-                                          (protocol "tcp")
-                                          (wait? #f)
-                                          (user "root")
-                                          (program (file-append bash
-                                                                "/bin/bash"))
-                                          (arguments
-                                           (list "bash" (plain-file "my-dict.sh" "\
+  (simple-operating-system
+   (dhcp-client-service)
+   (service inetd-service-type
+            (inetd-configuration
+             (entries (list
+                       (inetd-entry
+                        (name "echo")
+                        (socket-type 'stream)
+                        (protocol "tcp")
+                        (wait? #f)
+                        (user "root"))
+                       (inetd-entry
+                        (name "dict")
+                        (socket-type 'stream)
+                        (protocol "tcp")
+                        (wait? #f)
+                        (user "root")
+                        (program (file-append bash
+                                              "/bin/bash"))
+                        (arguments
+                         (list "bash" (plain-file "my-dict.sh" "\
 while read line
 do
     if [[ $line =~ ^DEFINE\\ (.*)$ ]]
@@ -81,8 +69,7 @@ do
     else
         echo ERROR
     fi
-done" ))))))))
-                     %base-services))))
+done" ))))))))))
 
 (define* (run-inetd-test)
   "Run tests in %INETD-OS, where the inetd service provides an echo service on
diff --git a/gnu/tests/ssh.scm b/gnu/tests/ssh.scm
index c1582c4737..02931e982a 100644
--- a/gnu/tests/ssh.scm
+++ b/gnu/tests/ssh.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -20,12 +20,8 @@
 (define-module (gnu tests ssh)
   #:use-module (gnu tests)
   #:use-module (gnu system)
-  #:use-module (gnu system grub)
-  #:use-module (gnu system file-systems)
-  #:use-module (gnu system shadow)
   #:use-module (gnu system vm)
   #:use-module (gnu services)
-  #:use-module (gnu services base)
   #:use-module (gnu services ssh)
   #:use-module (gnu services networking)
   #:use-module (gnu packages ssh)
@@ -35,26 +31,6 @@
   #:export (%test-openssh
             %test-dropbear))
 
-(define %base-os
-  (operating-system
-    (host-name "komputilo")
-    (timezone "Europe/Berlin")
-    (locale "en_US.UTF-8")
-
-    (bootloader (grub-configuration (device "/dev/sdX")))
-    (file-systems %base-file-systems)
-    (firmware '())
-    (users %base-user-accounts)
-    (services (cons (dhcp-client-service)
-                    %base-services))))
-
-(define (os-with-service service)
-  "Return a test operating system that runs SERVICE."
-  (operating-system
-    (inherit %base-os)
-    (services (cons service
-                    (operating-system-user-services %base-os)))))
-
 (define* (run-ssh-test name ssh-service pid-file #:key (sftp? #f))
   "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
@@ -62,7 +38,9 @@ empty-password logins.
 
 When SFTP? is true, run an SFTP server test."
   (mlet* %store-monad ((os ->   (marionette-operating-system
-                                 (os-with-service ssh-service)
+                                 (simple-operating-system
+                                  (dhcp-client-service)
+                                  ssh-service)
                                  #:imported-modules '((gnu services herd)
                                                       (guix combinators))))
                        (command (system-qemu-image/shared-store-script
diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm
index bae0e8fad7..cdc5791237 100644
--- a/gnu/tests/web.scm
+++ b/gnu/tests/web.scm
@@ -24,7 +24,6 @@
   #:use-module (gnu system shadow)
   #:use-module (gnu system vm)
   #:use-module (gnu services)
-  #:use-module (gnu services base)
   #:use-module (gnu services web)
   #:use-module (gnu services networking)
   #:use-module (guix gexp)
@@ -55,23 +54,14 @@
 
 (define %nginx-os
   ;; Operating system under test.
-  (operating-system
-    (host-name "komputilo")
-    (timezone "Europe/Berlin")
-    (locale "en_US.utf8")
-
-    (bootloader (grub-configuration (device "/dev/sdX")))
-    (file-systems %base-file-systems)
-    (firmware '())
-    (users %base-user-accounts)
-    (services (cons* (dhcp-client-service)
-                     (service nginx-service-type
-                              (nginx-configuration
-                               (log-directory "/var/log/nginx")
-                               (server-blocks %nginx-servers)))
-                     (simple-service 'make-http-root activation-service-type
-                                     %make-http-root)
-                     %base-services))))
+  (simple-operating-system
+   (dhcp-client-service)
+   (service nginx-service-type
+            (nginx-configuration
+             (log-directory "/var/log/nginx")
+             (server-blocks %nginx-servers)))
+   (simple-service 'make-http-root activation-service-type
+                   %make-http-root)))
 
 (define* (run-nginx-test #:optional (http-port 8042))
   "Run tests in %NGINX-OS, which has nginx running and listening on