me
/
guix
Archived
1
0
Fork 0
Code

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.
master
Ludovic Courtès 2017-03-31 22:13:50 +02:00
parent 9af7ecd959
commit 892d9089a8
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
7 changed files with 88 additions and 150 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
gnu/tests.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -21,7 +21,11 @@
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix records) #:use-module (guix records)
#:use-module (gnu system) #: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)
#:use-module (gnu services base)
#:use-module (gnu services shepherd) #:use-module (gnu services shepherd)
#:use-module ((gnu packages) #:select (scheme-modules)) #:use-module ((gnu packages) #:select (scheme-modules))
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
@ -37,6 +41,8 @@
marionette-operating-system marionette-operating-system
define-os-with-source define-os-with-source
simple-operating-system
system-test system-test
system-test? system-test?
system-test-name system-test-name
@ -188,6 +194,41 @@ the system under test."
(use-modules modules ...) (use-modules modules ...)
(operating-system fields ...))))))) (operating-system fields ...)))))))
;;;
;;; 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. ;;; Tests.

30
gnu/tests/base.scm
View File

@ -19,8 +19,6 @@
(define-module (gnu tests base) (define-module (gnu tests base)
#:use-module (gnu tests) #:use-module (gnu tests)
#:use-module (gnu system) #:use-module (gnu system)
#:use-module (gnu system grub)
#:use-module (gnu system file-systems)
#:use-module (gnu system shadow) #:use-module (gnu system shadow)
#:use-module (gnu system nss) #:use-module (gnu system nss)
#:use-module (gnu system vm) #:use-module (gnu system vm)
@ -44,27 +42,7 @@
%test-nss-mdns)) %test-nss-mdns))
(define %simple-os (define %simple-os
(operating-system (simple-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* (run-basic-test os command #:optional (name "basic") (define* (run-basic-test os command #:optional (name "basic")
@ -420,10 +398,8 @@ functionality tests.")
#:user "alice")) #:user "alice"))
(job3 #~(job next-second-from ;to test $PATH (job3 #~(job next-second-from ;to test $PATH
"touch witness-touch"))) "touch witness-touch")))
(operating-system (simple-operating-system
(inherit %simple-os) (mcron-service (list job1 job2 job3)))))
(services (cons (mcron-service (list job1 job2 job3))
(operating-system-user-services %simple-os))))))
(define (run-mcron-test name) (define (run-mcron-test name)
(mlet* %store-monad ((os -> (marionette-operating-system (mlet* %store-monad ((os -> (marionette-operating-system

25
gnu/tests/mail.scm
View File

@ -19,11 +19,8 @@
(define-module (gnu tests mail) (define-module (gnu tests mail)
#:use-module (gnu tests) #:use-module (gnu tests)
#:use-module (gnu system) #:use-module (gnu system)
#:use-module (gnu system file-systems)
#:use-module (gnu system grub)
#:use-module (gnu system vm) #:use-module (gnu system vm)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services base)
#:use-module (gnu services mail) #:use-module (gnu services mail)
#:use-module (gnu services networking) #:use-module (gnu services networking)
#:use-module (guix gexp) #:use-module (guix gexp)
@ -32,23 +29,15 @@
#:export (%test-opensmtpd)) #:export (%test-opensmtpd))
(define %opensmtpd-os (define %opensmtpd-os
(operating-system (simple-operating-system
(host-name "komputilo") (dhcp-client-service)
(timezone "Europe/Berlin") (service opensmtpd-service-type
(locale "en_US.UTF-8") (opensmtpd-configuration
(bootloader (grub-configuration (device #f))) (config-file
(file-systems %base-file-systems) (plain-file "smtpd.conf" "
(firmware '())
(services (cons*
(dhcp-client-service)
(service opensmtpd-service-type
(opensmtpd-configuration
(config-file
(plain-file "smtpd.conf" "
listen on 0.0.0.0 listen on 0.0.0.0
accept from any for local deliver to mbox accept from any for local deliver to mbox
")))) "))))))
%base-services))))
(define (run-opensmtpd-test) (define (run-opensmtpd-test)
"Return a test of an OS running OpenSMTPD service." "Return a test of an OS running OpenSMTPD service."

27
gnu/tests/messaging.scm
View File

@ -19,12 +19,8 @@
(define-module (gnu tests messaging) (define-module (gnu tests messaging)
#:use-module (gnu tests) #:use-module (gnu tests)
#:use-module (gnu system) #: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 system vm)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services base)
#:use-module (gnu services messaging) #:use-module (gnu services messaging)
#:use-module (gnu services networking) #:use-module (gnu services networking)
#:use-module (gnu packages messaging) #:use-module (gnu packages messaging)
@ -33,30 +29,11 @@
#:use-module (guix monads) #:use-module (guix monads)
#:export (%test-prosody)) #: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) (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." "Run a test of an OS running XMPP-SERVICE, which writes its PID to PID-FILE."
(mlet* %store-monad ((os -> (marionette-operating-system (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)))) #:imported-modules '((gnu services herd))))
(command (system-qemu-image/shared-store-script (command (system-qemu-image/shared-store-script
os #:graphic? #f)) os #:graphic? #f))

57
gnu/tests/networking.scm
View File

@ -19,12 +19,8 @@
(define-module (gnu tests networking) (define-module (gnu tests networking)
#:use-module (gnu tests) #:use-module (gnu tests)
#:use-module (gnu system) #: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 system vm)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services base)
#:use-module (gnu services networking) #:use-module (gnu services networking)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix store) #:use-module (guix store)
@ -34,35 +30,27 @@
(define %inetd-os (define %inetd-os
;; Operating system with 2 inetd services. ;; Operating system with 2 inetd services.
(operating-system (simple-operating-system
(host-name "komputilo") (dhcp-client-service)
(timezone "Europe/Brussels") (service inetd-service-type
(locale "en_US.utf8") (inetd-configuration
(entries (list
(bootloader (grub-configuration (device "/dev/sdX"))) (inetd-entry
(file-systems %base-file-systems) (name "echo")
(firmware '()) (socket-type 'stream)
(users %base-user-accounts) (protocol "tcp")
(services (cons* (dhcp-client-service) (wait? #f)
(service inetd-service-type (user "root"))
(inetd-configuration (inetd-entry
(entries (list (name "dict")
(inetd-entry (socket-type 'stream)
(name "echo") (protocol "tcp")
(socket-type 'stream) (wait? #f)
(protocol "tcp") (user "root")
(wait? #f) (program (file-append bash
(user "root")) "/bin/bash"))
(inetd-entry (arguments
(name "dict") (list "bash" (plain-file "my-dict.sh" "\
(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 while read line
do do
if [[ $line =~ ^DEFINE\\ (.*)$ ]] if [[ $line =~ ^DEFINE\\ (.*)$ ]]
@ -81,8 +69,7 @@ do
else else
echo ERROR echo ERROR
fi fi
done" )))))))) done" ))))))))))
%base-services))))
(define* (run-inetd-test) (define* (run-inetd-test)
"Run tests in %INETD-OS, where the inetd service provides an echo service on "Run tests in %INETD-OS, where the inetd service provides an echo service on

30
gnu/tests/ssh.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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> ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
@ -20,12 +20,8 @@
(define-module (gnu tests ssh) (define-module (gnu tests ssh)
#:use-module (gnu tests) #:use-module (gnu tests)
#:use-module (gnu system) #: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 system vm)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services base)
#:use-module (gnu services ssh) #:use-module (gnu services ssh)
#:use-module (gnu services networking) #:use-module (gnu services networking)
#:use-module (gnu packages ssh) #:use-module (gnu packages ssh)
@ -35,26 +31,6 @@
#:export (%test-openssh #:export (%test-openssh
%test-dropbear)) %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)) (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. "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 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." When SFTP? is true, run an SFTP server test."
(mlet* %store-monad ((os -> (marionette-operating-system (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) #:imported-modules '((gnu services herd)
(guix combinators)))) (guix combinators))))
(command (system-qemu-image/shared-store-script (command (system-qemu-image/shared-store-script

26
gnu/tests/web.scm
View File

@ -24,7 +24,6 @@
#:use-module (gnu system shadow) #:use-module (gnu system shadow)
#:use-module (gnu system vm) #:use-module (gnu system vm)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services base)
#:use-module (gnu services web) #:use-module (gnu services web)
#:use-module (gnu services networking) #:use-module (gnu services networking)
#:use-module (guix gexp) #:use-module (guix gexp)
@ -55,23 +54,14 @@
(define %nginx-os (define %nginx-os
;; Operating system under test. ;; Operating system under test.
(operating-system (simple-operating-system
(host-name "komputilo") (dhcp-client-service)
(timezone "Europe/Berlin") (service nginx-service-type
(locale "en_US.utf8") (nginx-configuration
(log-directory "/var/log/nginx")
(bootloader (grub-configuration (device "/dev/sdX"))) (server-blocks %nginx-servers)))
(file-systems %base-file-systems) (simple-service 'make-http-root activation-service-type
(firmware '()) %make-http-root)))
(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))))
(define* (run-nginx-test #:optional (http-port 8042)) (define* (run-nginx-test #:optional (http-port 8042))
"Run tests in %NGINX-OS, which has nginx running and listening on "Run tests in %NGINX-OS, which has nginx running and listening on