From ca7a68ebeb5039883cd43b6165ba1915b0974a41 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 20 Jun 2016 00:21:29 +0200 Subject: tests: Fix list of exports in (gnu tests). * gnu/tests.scm: Export 'marionette-service-type'. --- gnu/tests.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gnu/tests.scm') diff --git a/gnu/tests.scm b/gnu/tests.scm index 08d8315ea04..7ca80ebf0ef 100644 --- a/gnu/tests.scm +++ b/gnu/tests.scm @@ -21,7 +21,7 @@ #:use-module (gnu system) #:use-module (gnu services) #:use-module (gnu services shepherd) - #:export (backdoor-service-type + #:export (marionette-service-type marionette-operating-system)) ;;; Commentary: @@ -112,7 +112,7 @@ (define marionette-service-type ;; This is the type of the "marionette" service, allowing a guest system to ;; be manipulated from the host. This marionette REPL is essentially a - ;; universal marionette. + ;; universal backdoor. (service-type (name 'marionette-repl) (extensions (list (service-extension shepherd-root-service-type -- cgit v1.3 From 94b4274d0dc5768bac255980c7e785bd3dff261f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 20 Jun 2016 21:51:59 +0200 Subject: tests: Add system installation test. * gnu/tests.scm (define-os-with-source): New macro. * gnu/tests/install.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. * build-aux/run-system-tests.scm (%system-tests): Likewise. --- build-aux/run-system-tests.scm | 4 +- gnu/local.mk | 3 +- gnu/tests.scm | 22 ++++- gnu/tests/install.scm | 205 +++++++++++++++++++++++++++++++++++++++++ 4 files changed, 231 insertions(+), 3 deletions(-) create mode 100644 gnu/tests/install.scm (limited to 'gnu/tests.scm') diff --git a/build-aux/run-system-tests.scm b/build-aux/run-system-tests.scm index e98de9cb7e1..4ce9b83fed7 100644 --- a/build-aux/run-system-tests.scm +++ b/build-aux/run-system-tests.scm @@ -18,6 +18,7 @@ (define-module (run-system-tests) #:use-module (gnu tests base) + #:use-module (gnu tests install) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix derivations) @@ -45,7 +46,8 @@ (lift1 reverse %store-monad)))) (define %system-tests - (list %test-basic-os)) + (list %test-basic-os + %test-installed-os)) (define (run-system-tests . args) (with-store store diff --git a/gnu/local.mk b/gnu/local.mk index 55fea0e8559..150d6af553b 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -409,7 +409,8 @@ GNU_SYSTEM_MODULES = \ %D%/build/vm.scm \ \ %D%/tests.scm \ - %D%/tests/base.scm + %D%/tests/base.scm \ + %D%/tests/install.scm patchdir = $(guilemoduledir)/%D%/packages/patches diff --git a/gnu/tests.scm b/gnu/tests.scm index 7ca80ebf0ef..348b5ad40fa 100644 --- a/gnu/tests.scm +++ b/gnu/tests.scm @@ -22,7 +22,8 @@ #:use-module (gnu services) #:use-module (gnu services shepherd) #:export (marionette-service-type - marionette-operating-system)) + marionette-operating-system + define-os-with-source)) ;;; Commentary: ;;; @@ -127,4 +128,23 @@ in a virtual machine--i.e., controlled from the host system." (services (cons (service marionette-service-type imported-modules) (operating-system-user-services os))))) +(define-syntax define-os-with-source + (syntax-rules (use-modules operating-system) + "Define two variables: OS containing the given operating system, and +SOURCE containing the source to define OS as an sexp. + +This is convenient when we need both the object so we can +instantiate it, and the source to create it so we can store in in a file in +the system under test." + ((_ (os source) + (use-modules modules ...) + (operating-system fields ...)) + (begin + (define os + (operating-system fields ...)) + (define source + '(begin + (use-modules modules ...) + (operating-system fields ...))))))) + ;;; tests.scm ends here diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm new file mode 100644 index 00000000000..0b3950a2127 --- /dev/null +++ b/gnu/tests/install.scm @@ -0,0 +1,205 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ludovic Courtès +;;; +;;; 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 . + +(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 + ;; 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. + (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) + (list (string-append #$qemu-minimal "/bin/" + #$(qemu-command system)) + "-enable-kvm" "-no-reboot" "-m" "256" + "-drive" "file=disk.img,if=virtio")) + "installed-os"))) + +;;; install.scm ends here -- cgit v1.3 From 98b65b5ff6b1dea0ad58b0f47dd163c32d0cbf6e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 20 Jun 2016 22:34:13 +0200 Subject: tests: Add a mechanism to describe and discover system tests. * gnu/tests.scm (): New record type. (write-system-test, test-modules, fold-system-tests) (all-system-tests): New procedures. * gnu/tests/base.scm (%test-basic-os): Turn into a . * gnu/tests/install.scm (%test-installed-os): Likewise. * build-aux/run-system-tests.scm (%system-tests): Remove. (run-system-tests): Use 'all-system-tests'. --- Makefile.am | 1 - build-aux/run-system-tests.scm | 15 +++++----- gnu/tests.scm | 68 +++++++++++++++++++++++++++++++++++++++++- gnu/tests/base.scm | 30 +++++++++++-------- gnu/tests/install.scm | 36 ++++++++++++---------- 5 files changed, 112 insertions(+), 38 deletions(-) (limited to 'gnu/tests.scm') diff --git a/Makefile.am b/Makefile.am index 8fd1c1b0b65..37a0aef7dc5 100644 --- a/Makefile.am +++ b/Makefile.am @@ -334,7 +334,6 @@ check-local: endif !CAN_RUN_TESTS check-system: $(GOBJECTS) - $(AM_V_at)echo "Running system tests..." $(AM_V_at)$(top_builddir)/pre-inst-env \ $(GUILE) --no-auto-compile \ -e '(@@ (run-system-tests) run-system-tests)' \ diff --git a/build-aux/run-system-tests.scm b/build-aux/run-system-tests.scm index 4ce9b83fed7..f7c99def235 100644 --- a/build-aux/run-system-tests.scm +++ b/build-aux/run-system-tests.scm @@ -17,8 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (run-system-tests) - #:use-module (gnu tests base) - #:use-module (gnu tests install) + #:use-module (gnu tests) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix derivations) @@ -45,14 +44,16 @@ lst) (lift1 reverse %store-monad)))) -(define %system-tests - (list %test-basic-os - %test-installed-os)) - (define (run-system-tests . args) + (define tests + (all-system-tests)) + + (format (current-error-port) "Running ~a system tests...~%" + (length tests)) + (with-store store (run-with-store store - (mlet* %store-monad ((drv (sequence %store-monad %system-tests)) + (mlet* %store-monad ((drv (mapm %store-monad system-test-value tests)) (out -> (map derivation->output-path drv))) (mbegin %store-monad (show-what-to-build* drv) diff --git a/gnu/tests.scm b/gnu/tests.scm index 348b5ad40fa..ea779ed6f07 100644 --- a/gnu/tests.scm +++ b/gnu/tests.scm @@ -18,12 +18,28 @@ (define-module (gnu tests) #:use-module (guix gexp) + #:use-module (guix utils) + #:use-module (guix records) #:use-module (gnu system) #:use-module (gnu services) #:use-module (gnu services shepherd) + #:use-module ((gnu packages) #:select (scheme-modules)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9 gnu) + #:use-module (ice-9 match) #:export (marionette-service-type marionette-operating-system - define-os-with-source)) + define-os-with-source + + system-test + system-test? + system-test-name + system-test-value + system-test-description + system-test-location + + fold-system-tests + all-system-tests)) ;;; Commentary: ;;; @@ -147,4 +163,54 @@ the system under test." (use-modules modules ...) (operating-system fields ...))))))) + +;;; +;;; Tests. +;;; + +(define-record-type* system-test make-system-test + system-test? + (name system-test-name) ;string + (value system-test-value) ;%STORE-MONAD value + (description system-test-description) ;string + (location system-test-location (innate) ; + (default (and=> (current-source-location) + source-properties->location)))) + +(define (write-system-test test port) + (match test + (($ name _ _ ($ file line)) + (format port "#" + name file line + (number->string (object-address test) 16))) + (($ name) + (format port "#" name + (number->string (object-address test) 16))))) + +(set-record-type-printer! write-system-test) + +(define (test-modules) + "Return the list of modules that define system tests." + (scheme-modules (dirname (search-path %load-path "guix.scm")) + "gnu/tests")) + +(define (fold-system-tests proc seed) + "Invoke PROC on each system test, passing it the test and the previous +result." + (fold (lambda (module result) + (fold (lambda (thing result) + (if (system-test? thing) + (proc thing result) + result)) + result + (module-map (lambda (sym var) + (false-if-exception (variable-ref var))) + module))) + '() + (test-modules))) + +(define (all-system-tests) + "Return the list of system tests." + (reverse (fold-system-tests cons '()))) + ;;; tests.scm ends here diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index b417bc4bda0..3dfa28f7f57 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -161,16 +161,20 @@ info --version") #: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))) - ;; 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)))) + (system-test + (name "basic") + (description + "Instrument %SIMPLE-OS, run it in a VM, and runs 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)))))) diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 0b3950a2127..c33919ba2fa 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -185,21 +185,25 @@ reboot\n")) (define %test-installed-os - ;; 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. - (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) - (list (string-append #$qemu-minimal "/bin/" - #$(qemu-command system)) - "-enable-kvm" "-no-reboot" "-m" "256" - "-drive" "file=disk.img,if=virtio")) - "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) + (list (string-append #$qemu-minimal "/bin/" + #$(qemu-command system)) + "-enable-kvm" "-no-reboot" "-m" "256" + "-drive" "file=disk.img,if=virtio")) + "installed-os"))))) ;;; install.scm ends here -- cgit v1.3 From 037f9e07cd03d6894a6b5fc9a252c34d3b163962 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 Jun 2016 21:09:08 +0200 Subject: tests: 'marionette-service-type' nows takes a . * gnu/tests.scm (): New record type. (marionette-shepherd-service): Argument now is a . (marionette-operating-system): Adjust accordingly. Add #:requirements parameter and honor it. --- gnu/tests.scm | 183 +++++++++++++++++++++++++++++++++------------------------- 1 file changed, 104 insertions(+), 79 deletions(-) (limited to 'gnu/tests.scm') diff --git a/gnu/tests.scm b/gnu/tests.scm index ea779ed6f07..1821ac45c55 100644 --- a/gnu/tests.scm +++ b/gnu/tests.scm @@ -27,7 +27,13 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) #:use-module (ice-9 match) - #:export (marionette-service-type + #:export (marionette-configuration + marionette-configuration? + marionette-configuration-device + marionette-configuration-imported-modules + marionette-configuration-requirements + + marionette-service-type marionette-operating-system define-os-with-source @@ -50,81 +56,93 @@ ;;; ;;; Code: -(define (marionette-shepherd-service imported-modules) +(define-record-type* + marionette-configuration make-marionette-configuration + marionette-configuration? + (device marionette-configuration-device ;string + (default "/dev/hvc0")) + (imported-modules marionette-configuration-imported-modules + (default '())) + (requirements marionette-configuration-requirements ;list of symbols + (default '()))) + +(define (marionette-shepherd-service config) "Return the Shepherd service for the marionette REPL" - (define device - "/dev/hvc0") - - (list (shepherd-service - (provision '(marionette)) - (requirement '(udev)) ;so that DEVICE is available - (modules '((ice-9 match) - (srfi srfi-9 gnu) - (guix build syscalls) - (rnrs bytevectors))) - (imported-modules `((guix build syscalls) - ,@imported-modules)) - (start - #~(lambda () - (define (clear-echo termios) - (set-field termios (termios-local-flags) - (logand (lognot (local-flags ECHO)) - (termios-local-flags termios)))) - - (define (self-quoting? x) - (letrec-syntax ((one-of (syntax-rules () - ((_) #f) - ((_ pred rest ...) - (or (pred x) - (one-of rest ...)))))) - (one-of symbol? string? pair? null? vector? - bytevector? number? boolean?))) - - (match (primitive-fork) - (0 - (dynamic-wind - (const #t) - (lambda () - (let* ((repl (open-file #$device "r+0")) - (termios (tcgetattr (fileno repl))) - (console (open-file "/dev/console" "r+0"))) - ;; Don't echo input back. - (tcsetattr (fileno repl) (tcsetattr-action TCSANOW) - (clear-echo termios)) - - ;; Redirect output to the console. - (close-fdes 1) - (close-fdes 2) - (dup2 (fileno console) 1) - (dup2 (fileno console) 2) - (close-port console) - - (display 'ready repl) - (let loop () - (newline repl) - - (match (read repl) - ((? eof-object?) - (primitive-exit 0)) - (expr - (catch #t - (lambda () - (let ((result (primitive-eval expr))) - (write (if (self-quoting? result) - result - (object->string result)) - repl))) - (lambda (key . args) - (print-exception (current-error-port) - (stack-ref (make-stack #t) 1) - key args) - (write #f repl))))) - (loop)))) - (lambda () - (primitive-exit 1)))) - (pid - pid)))) - (stop #~(make-kill-destructor))))) + (match config + (($ device imported-modules requirement) + (list (shepherd-service + (provision '(marionette)) + + ;; Always depend on UDEV so that DEVICE is available. + (requirement `(udev ,@requirement)) + + (modules '((ice-9 match) + (srfi srfi-9 gnu) + (guix build syscalls) + (rnrs bytevectors))) + (imported-modules `((guix build syscalls) + ,@imported-modules)) + (start + #~(lambda () + (define (clear-echo termios) + (set-field termios (termios-local-flags) + (logand (lognot (local-flags ECHO)) + (termios-local-flags termios)))) + + (define (self-quoting? x) + (letrec-syntax ((one-of (syntax-rules () + ((_) #f) + ((_ pred rest ...) + (or (pred x) + (one-of rest ...)))))) + (one-of symbol? string? pair? null? vector? + bytevector? number? boolean?))) + + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (let* ((repl (open-file #$device "r+0")) + (termios (tcgetattr (fileno repl))) + (console (open-file "/dev/console" "r+0"))) + ;; Don't echo input back. + (tcsetattr (fileno repl) (tcsetattr-action TCSANOW) + (clear-echo termios)) + + ;; Redirect output to the console. + (close-fdes 1) + (close-fdes 2) + (dup2 (fileno console) 1) + (dup2 (fileno console) 2) + (close-port console) + + (display 'ready repl) + (let loop () + (newline repl) + + (match (read repl) + ((? eof-object?) + (primitive-exit 0)) + (expr + (catch #t + (lambda () + (let ((result (primitive-eval expr))) + (write (if (self-quoting? result) + result + (object->string result)) + repl))) + (lambda (key . args) + (print-exception (current-error-port) + (stack-ref (make-stack #t) 1) + key args) + (write #f repl))))) + (loop)))) + (lambda () + (primitive-exit 1)))) + (pid + pid)))) + (stop #~(make-kill-destructor))))))) (define marionette-service-type ;; This is the type of the "marionette" service, allowing a guest system to @@ -136,12 +154,19 @@ marionette-shepherd-service))))) (define* (marionette-operating-system os - #:key (imported-modules '())) - "Return a marionetteed variant of OS such that OS can be used as a marionette -in a virtual machine--i.e., controlled from the host system." + #:key + (imported-modules '()) + (requirements '())) + "Return a marionetteed variant of OS such that OS can be used as a +marionette in a virtual machine--i.e., controlled from the host system. The +marionette service in the guest is started after the Shepherd services listed +in REQUIREMENTS." (operating-system (inherit os) - (services (cons (service marionette-service-type imported-modules) + (services (cons (service marionette-service-type + (marionette-configuration + (requirements requirements) + (imported-modules imported-modules))) (operating-system-user-services os))))) (define-syntax define-os-with-source -- cgit v1.3 From a91c3fc727ba90d8c9b91f67fb672da2e6b877ad Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 12 Jul 2016 00:38:50 +0200 Subject: services: no longer has an 'imported-modules' field. * gnu/services/shepherd.scm ()[imported-modules]: Remove. (%default-imported-modules): Make private. (shepherd-service-file): Use 'with-imported-modules'. (shepherd-configuration-file): Remove 'modules' and the calls to 'imported-modules' and 'compiled-modules'. Use 'with-imported-modules' instead. * doc/guix.texi (Shepherd Services): Adjust accordingly. * gnu/services/base.scm (file-system-shepherd-service): Use 'with-imported-modules'. Remove 'imported-modules' field. * gnu/system/mapped-devices.scm (device-mapping-service-type): Remove 'imported-modules'. (open-luks-device): Use 'with-imported-modules'. * gnu/tests.scm (marionette-shepherd-service): Remove 'imported-modules' field and use 'with-imported-modules'. --- doc/guix.texi | 4 -- gnu/services/base.scm | 105 ++++++++++++++++++------------------ gnu/services/shepherd.scm | 43 +++++---------- gnu/system/mapped-devices.scm | 34 ++++++------ gnu/tests.scm | 122 +++++++++++++++++++++--------------------- 5 files changed, 144 insertions(+), 164 deletions(-) (limited to 'gnu/tests.scm') diff --git a/doc/guix.texi b/doc/guix.texi index abd294e8864..37e854dc59a 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10848,10 +10848,6 @@ where @var{service-name} is one of the symbols in @var{provision} This is the list of modules that must be in scope when @code{start} and @code{stop} are evaluated. -@item @code{imported-modules} (default: @var{%default-imported-modules}) -This is the list of modules to import in the execution environment of -the Shepherd. - @end table @end deftp diff --git a/gnu/services/base.scm b/gnu/services/base.scm index d9c60778a1c..02e3b419042 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -229,59 +229,58 @@ FILE-SYSTEM." (create? (file-system-create-mount-point? file-system)) (dependencies (file-system-dependencies file-system))) (if (file-system-mount? file-system) - (list - (shepherd-service - (provision (list (file-system->shepherd-service-name file-system))) - (requirement `(root-file-system - ,@(map dependency->shepherd-service-name dependencies))) - (documentation "Check, mount, and unmount the given file system.") - (start #~(lambda args - ;; FIXME: Use or factorize with 'mount-file-system'. - (let ((device (canonicalize-device-spec #$device '#$title)) - (flags #$(mount-flags->bit-mask - (file-system-flags file-system)))) - #$(if create? - #~(mkdir-p #$target) - #~#t) - #$(if check? - #~(begin - ;; Make sure fsck.ext2 & co. can be found. - (setenv "PATH" - (string-append - #$e2fsprogs "/sbin:" - "/run/current-system/profile/sbin:" - (getenv "PATH"))) - (check-file-system device #$type)) - #~#t) - - (mount device #$target #$type flags - #$(file-system-options file-system)) - - ;; For read-only bind mounts, an extra remount is - ;; needed, as per , - ;; which still applies to Linux 4.0. - (when (and (= MS_BIND (logand flags MS_BIND)) - (= MS_RDONLY (logand flags MS_RDONLY))) - (mount device #$target #$type - (logior MS_BIND MS_REMOUNT MS_RDONLY)))) - #t)) - (stop #~(lambda args - ;; Normally there are no processes left at this point, so - ;; TARGET can be safely unmounted. - - ;; Make sure PID 1 doesn't keep TARGET busy. - (chdir "/") - - (umount #$target) - #f)) - - ;; We need an additional module. - (modules `(((gnu build file-systems) - #:select (check-file-system canonicalize-device-spec)) - ,@%default-modules)) - (imported-modules `((gnu build file-systems) - (guix build bournish) - ,@%default-imported-modules)))) + (with-imported-modules '((gnu build file-systems) + (guix build bournish)) + (list + (shepherd-service + (provision (list (file-system->shepherd-service-name file-system))) + (requirement `(root-file-system + ,@(map dependency->shepherd-service-name dependencies))) + (documentation "Check, mount, and unmount the given file system.") + (start #~(lambda args + ;; FIXME: Use or factorize with 'mount-file-system'. + (let ((device (canonicalize-device-spec #$device '#$title)) + (flags #$(mount-flags->bit-mask + (file-system-flags file-system)))) + #$(if create? + #~(mkdir-p #$target) + #~#t) + #$(if check? + #~(begin + ;; Make sure fsck.ext2 & co. can be found. + (setenv "PATH" + (string-append + #$e2fsprogs "/sbin:" + "/run/current-system/profile/sbin:" + (getenv "PATH"))) + (check-file-system device #$type)) + #~#t) + + (mount device #$target #$type flags + #$(file-system-options file-system)) + + ;; For read-only bind mounts, an extra remount is + ;; needed, as per , + ;; which still applies to Linux 4.0. + (when (and (= MS_BIND (logand flags MS_BIND)) + (= MS_RDONLY (logand flags MS_RDONLY))) + (mount device #$target #$type + (logior MS_BIND MS_REMOUNT MS_RDONLY)))) + #t)) + (stop #~(lambda args + ;; Normally there are no processes left at this point, so + ;; TARGET can be safely unmounted. + + ;; Make sure PID 1 doesn't keep TARGET busy. + (chdir "/") + + (umount #$target) + #f)) + + ;; We need an additional module. + (modules `(((gnu build file-systems) + #:select (check-file-system canonicalize-device-spec)) + ,@%default-modules))))) '()))) (define file-system-service-type diff --git a/gnu/services/shepherd.scm b/gnu/services/shepherd.scm index 5d829e4c38e..f35a6bf10aa 100644 --- a/gnu/services/shepherd.scm +++ b/gnu/services/shepherd.scm @@ -47,9 +47,7 @@ shepherd-service-stop shepherd-service-auto-start? shepherd-service-modules - shepherd-service-imported-modules - %default-imported-modules %default-modules shepherd-service-file @@ -138,9 +136,7 @@ for a service that extends SHEPHERD-ROOT-SERVICE-TYPE and nothing else." (auto-start? shepherd-service-auto-start? ;Boolean (default #t)) (modules shepherd-service-modules ;list of module names - (default %default-modules)) - (imported-modules shepherd-service-imported-modules ;list of module names - (default %default-imported-modules))) + (default %default-modules))) (define (shepherd-service-canonical-name service) "Return the 'canonical name' of SERVICE." @@ -203,37 +199,26 @@ stored." (define (shepherd-service-file service) "Return a file defining SERVICE." (gexp->file (shepherd-service-file-name service) - #~(begin - (use-modules #$@(shepherd-service-modules service)) - - (make - #:docstring '#$(shepherd-service-documentation service) - #:provides '#$(shepherd-service-provision service) - #:requires '#$(shepherd-service-requirement service) - #:respawn? '#$(shepherd-service-respawn? service) - #:start #$(shepherd-service-start service) - #:stop #$(shepherd-service-stop service))))) + (with-imported-modules %default-imported-modules + #~(begin + (use-modules #$@(shepherd-service-modules service)) + + (make + #:docstring '#$(shepherd-service-documentation service) + #:provides '#$(shepherd-service-provision service) + #:requires '#$(shepherd-service-requirement service) + #:respawn? '#$(shepherd-service-respawn? service) + #:start #$(shepherd-service-start service) + #:stop #$(shepherd-service-stop service)))))) (define (shepherd-configuration-file services) "Return the shepherd configuration file for SERVICES." - (define modules - (delete-duplicates - (append-map shepherd-service-imported-modules services))) - (assert-valid-graph services) - (mlet %store-monad ((modules (imported-modules modules)) - (compiled (compiled-modules modules)) - (files (mapm %store-monad - shepherd-service-file - services))) + (mlet %store-monad ((files (mapm %store-monad + shepherd-service-file services))) (define config #~(begin - (eval-when (expand load eval) - (set! %load-path (cons #$modules %load-path)) - (set! %load-compiled-path - (cons #$compiled %load-compiled-path))) - (use-modules (srfi srfi-34) (system repl error-handling)) diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm index 450b4737acc..732f73cc4ba 100644 --- a/gnu/system/mapped-devices.scm +++ b/gnu/system/mapped-devices.scm @@ -85,9 +85,7 @@ (modules `((rnrs bytevectors) ;bytevector? ((gnu build file-systems) #:select (find-partition-by-luks-uuid)) - ,@%default-modules)) - (imported-modules `((gnu build file-systems) - ,@%default-imported-modules))))))) + ,@%default-modules))))))) (define (device-mapping-service mapped-device) "Return a service that sets up @var{mapped-device}." @@ -101,20 +99,22 @@ (define (open-luks-device source target) "Return a gexp that maps SOURCE to TARGET as a LUKS device, using 'cryptsetup'." - #~(let ((source #$source)) - (zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup") - "open" "--type" "luks" - - ;; Note: We cannot use the "UUID=source" syntax here - ;; because 'cryptsetup' implements it by searching the - ;; udev-populated /dev/disk/by-id directory but udev may - ;; be unavailable at the time we run this. - (if (bytevector? source) - (or (find-partition-by-luks-uuid source) - (error "LUKS partition not found" source)) - source) - - #$target)))) + (with-imported-modules '((gnu build file-systems) + (guix build bournish)) + #~(let ((source #$source)) + (zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup") + "open" "--type" "luks" + + ;; Note: We cannot use the "UUID=source" syntax here + ;; because 'cryptsetup' implements it by searching the + ;; udev-populated /dev/disk/by-id directory but udev may + ;; be unavailable at the time we run this. + (if (bytevector? source) + (or (find-partition-by-luks-uuid source) + (error "LUKS partition not found" source)) + source) + + #$target))))) (define (close-luks-device source target) "Return a gexp that closes TARGET, a LUKS device." diff --git a/gnu/tests.scm b/gnu/tests.scm index 1821ac45c55..8abe6c608ba 100644 --- a/gnu/tests.scm +++ b/gnu/tests.scm @@ -80,68 +80,68 @@ (srfi srfi-9 gnu) (guix build syscalls) (rnrs bytevectors))) - (imported-modules `((guix build syscalls) - ,@imported-modules)) (start - #~(lambda () - (define (clear-echo termios) - (set-field termios (termios-local-flags) - (logand (lognot (local-flags ECHO)) - (termios-local-flags termios)))) - - (define (self-quoting? x) - (letrec-syntax ((one-of (syntax-rules () - ((_) #f) - ((_ pred rest ...) - (or (pred x) - (one-of rest ...)))))) - (one-of symbol? string? pair? null? vector? - bytevector? number? boolean?))) - - (match (primitive-fork) - (0 - (dynamic-wind - (const #t) - (lambda () - (let* ((repl (open-file #$device "r+0")) - (termios (tcgetattr (fileno repl))) - (console (open-file "/dev/console" "r+0"))) - ;; Don't echo input back. - (tcsetattr (fileno repl) (tcsetattr-action TCSANOW) - (clear-echo termios)) - - ;; Redirect output to the console. - (close-fdes 1) - (close-fdes 2) - (dup2 (fileno console) 1) - (dup2 (fileno console) 2) - (close-port console) - - (display 'ready repl) - (let loop () - (newline repl) - - (match (read repl) - ((? eof-object?) - (primitive-exit 0)) - (expr - (catch #t - (lambda () - (let ((result (primitive-eval expr))) - (write (if (self-quoting? result) - result - (object->string result)) - repl))) - (lambda (key . args) - (print-exception (current-error-port) - (stack-ref (make-stack #t) 1) - key args) - (write #f repl))))) - (loop)))) - (lambda () - (primitive-exit 1)))) - (pid - pid)))) + (with-imported-modules `((guix build syscalls) + ,@imported-modules) + #~(lambda () + (define (clear-echo termios) + (set-field termios (termios-local-flags) + (logand (lognot (local-flags ECHO)) + (termios-local-flags termios)))) + + (define (self-quoting? x) + (letrec-syntax ((one-of (syntax-rules () + ((_) #f) + ((_ pred rest ...) + (or (pred x) + (one-of rest ...)))))) + (one-of symbol? string? pair? null? vector? + bytevector? number? boolean?))) + + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (let* ((repl (open-file #$device "r+0")) + (termios (tcgetattr (fileno repl))) + (console (open-file "/dev/console" "r+0"))) + ;; Don't echo input back. + (tcsetattr (fileno repl) (tcsetattr-action TCSANOW) + (clear-echo termios)) + + ;; Redirect output to the console. + (close-fdes 1) + (close-fdes 2) + (dup2 (fileno console) 1) + (dup2 (fileno console) 2) + (close-port console) + + (display 'ready repl) + (let loop () + (newline repl) + + (match (read repl) + ((? eof-object?) + (primitive-exit 0)) + (expr + (catch #t + (lambda () + (let ((result (primitive-eval expr))) + (write (if (self-quoting? result) + result + (object->string result)) + repl))) + (lambda (key . args) + (print-exception (current-error-port) + (stack-ref (make-stack #t) 1) + key args) + (write #f repl))))) + (loop)))) + (lambda () + (primitive-exit 1)))) + (pid + pid))))) (stop #~(make-kill-destructor))))))) (define marionette-service-type -- cgit v1.3