diff options
Diffstat (limited to 'gnu')
| -rw-r--r-- | gnu/services.scm | 8 | ||||
| -rw-r--r-- | gnu/services/base.scm | 60 | ||||
| -rw-r--r-- | gnu/services/dbus.scm | 41 | ||||
| -rw-r--r-- | gnu/services/desktop.scm | 67 | ||||
| -rw-r--r-- | gnu/services/networking.scm | 54 | ||||
| -rw-r--r-- | gnu/services/xorg.scm | 42 | ||||
| -rw-r--r-- | gnu/system/install.scm | 117 | ||||
| -rw-r--r-- | gnu/system/linux-container.scm | 48 | ||||
| -rw-r--r-- | gnu/system/linux-initrd.scm | 170 | ||||
| -rw-r--r-- | gnu/system/locale.scm | 8 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 72 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 46 | ||||
| -rw-r--r-- | gnu/tests/base.scm | 514 | ||||
| -rw-r--r-- | gnu/tests/install.scm | 82 |
14 files changed, 664 insertions, 665 deletions
diff --git a/gnu/services.scm b/gnu/services.scm index 50e76df818..661835f68e 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -309,10 +309,10 @@ file." one) (_ (computed-file name - #~(begin - (use-modules (guix build union)) - (union-build #$output '#$things)) - #:modules '((guix build union)))))) + (with-imported-modules '((guix build union)) + #~(begin + (use-modules (guix build union)) + (union-build #$output '#$things))))))) (define* (activation-service->script service) "Return as a monadic value the activation script for SERVICE, a service of diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 5eabfec423..d9c60778a1 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -1138,44 +1138,44 @@ archive}). If that is not the case, the service will fail to start." "Return the union of the @code{lib/udev/rules.d} directories found in each item of @var{packages}." (define build - #~(begin - (use-modules (guix build union) - (guix build utils) - (srfi srfi-1) - (srfi srfi-26)) + (with-imported-modules '((guix build union) + (guix build utils)) + #~(begin + (use-modules (guix build union) + (guix build utils) + (srfi srfi-1) + (srfi srfi-26)) - (define %standard-locations - '("/lib/udev/rules.d" "/libexec/udev/rules.d")) + (define %standard-locations + '("/lib/udev/rules.d" "/libexec/udev/rules.d")) - (define (rules-sub-directory directory) - ;; Return the sub-directory of DIRECTORY containing udev rules, or - ;; #f if none was found. - (find directory-exists? - (map (cut string-append directory <>) %standard-locations))) + (define (rules-sub-directory directory) + ;; Return the sub-directory of DIRECTORY containing udev rules, or + ;; #f if none was found. + (find directory-exists? + (map (cut string-append directory <>) %standard-locations))) - (mkdir-p (string-append #$output "/lib/udev")) - (union-build (string-append #$output "/lib/udev/rules.d") - (filter-map rules-sub-directory '#$packages)))) + (mkdir-p (string-append #$output "/lib/udev")) + (union-build (string-append #$output "/lib/udev/rules.d") + (filter-map rules-sub-directory '#$packages))))) - (computed-file "udev-rules" build - #:modules '((guix build union) - (guix build utils)))) + (computed-file "udev-rules" build)) (define (udev-rule file-name contents) "Return a directory with a udev rule file FILE-NAME containing CONTENTS." (computed-file file-name - #~(begin - (use-modules (guix build utils)) - - (define rules.d - (string-append #$output "/lib/udev/rules.d")) - - (mkdir-p rules.d) - (call-with-output-file - (string-append rules.d "/" #$file-name) - (lambda (port) - (display #$contents port)))) - #:modules '((guix build utils)))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (define rules.d + (string-append #$output "/lib/udev/rules.d")) + + (mkdir-p rules.d) + (call-with-output-file + (string-append rules.d "/" #$file-name) + (lambda (port) + (display #$contents port))))))) (define kvm-udev-rule ;; Return a directory with a udev rule that changes the group of /dev/kvm to diff --git a/gnu/services/dbus.scm b/gnu/services/dbus.scm index 9a4a13d41d..d06b2dde23 100644 --- a/gnu/services/dbus.scm +++ b/gnu/services/dbus.scm @@ -46,26 +46,27 @@ "Return the system service directory, containing @code{.service} files for all the services that may be activated by the daemon." (computed-file "dbus-system-services" - #~(begin - (use-modules (guix build utils) - (srfi srfi-1)) - - (define files - (append-map (lambda (service) - (find-files (string-append - service - "/share/dbus-1/system-services") - "\\.service$")) - (list #$@services))) - - (mkdir #$output) - (for-each (lambda (file) - (symlink file - (string-append #$output "/" - (basename file)))) - files) - #t) - #:modules '((guix build utils)))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (srfi srfi-1)) + + (define files + (append-map (lambda (service) + (find-files + (string-append + service + "/share/dbus-1/system-services") + "\\.service$")) + (list #$@services))) + + (mkdir #$output) + (for-each (lambda (file) + (symlink file + (string-append #$output "/" + (basename file)))) + files) + #t)))) (define (dbus-configuration-directory services) "Return a directory contains the @code{system-local.conf} file for DBUS that diff --git a/gnu/services/desktop.scm b/gnu/services/desktop.scm index 2fb08cd1b3..86214a73bf 100644 --- a/gnu/services/desktop.scm +++ b/gnu/services/desktop.scm @@ -91,30 +91,33 @@ is set to @var{value} when the bus daemon launches it." (string-append #$service "/" #$program) (cdr (command-line)))))) + (define build + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (define service-directory + "/share/dbus-1/system-services") + + (mkdir-p (dirname (string-append #$output + service-directory))) + (copy-recursively (string-append #$service + service-directory) + (string-append #$output + service-directory)) + (symlink (string-append #$service "/etc") ;for etc/dbus-1 + (string-append #$output "/etc")) + + (for-each (lambda (file) + (substitute* file + (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$" + _ original-program arguments) + (string-append "Exec=" #$wrapper arguments + "\n")))) + (find-files #$output "\\.service$"))))) + (computed-file (string-append (package-name service) "-wrapper") - #~(begin - (use-modules (guix build utils)) - - (define service-directory - "/share/dbus-1/system-services") - - (mkdir-p (dirname (string-append #$output - service-directory))) - (copy-recursively (string-append #$service - service-directory) - (string-append #$output - service-directory)) - (symlink (string-append #$service "/etc") ;for etc/dbus-1 - (string-append #$output "/etc")) - - (for-each (lambda (file) - (substitute* file - (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$" - _ original-program arguments) - (string-append "Exec=" #$wrapper arguments - "\n")))) - (find-files #$output "\\.service$"))) - #:modules '((guix build utils)))) + build)) ;;; @@ -408,15 +411,15 @@ Users need to be in the @code{lp} group to access the D-Bus service. (define (polkit-directory packages) "Return a directory containing an @file{actions} and possibly a @file{rules.d} sub-directory, for use as @file{/etc/polkit-1}." - (computed-file "etc-polkit-1" - #~(begin - (use-modules (guix build union) (srfi srfi-26)) - - (union-build #$output - (map (cut string-append <> - "/share/polkit-1") - (list #$@packages)))) - #:modules '((guix build union)))) + (with-imported-modules '((guix build union)) + (computed-file "etc-polkit-1" + #~(begin + (use-modules (guix build union) (srfi srfi-26)) + + (union-build #$output + (map (cut string-append <> + "/share/polkit-1") + (list #$@packages))))))) (define polkit-etc-files (match-lambda diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index af2a60936b..a77ed3bb80 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il> ;;; @@ -345,39 +345,39 @@ keep the system clock synchronized with that of @var{servers}." (($ <tor-configuration> tor config-file services) (computed-file "torrc" - #~(begin - (use-modules (guix build utils) - (ice-9 match)) - - (call-with-output-file #$output - (lambda (port) - (display "\ + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (call-with-output-file #$output + (lambda (port) + (display "\ # The beginning was automatically added. User tor DataDirectory /var/lib/tor Log notice syslog\n" port) - (for-each (match-lambda - ((service (ports hosts) ...) - (format port "\ + (for-each (match-lambda + ((service (ports hosts) ...) + (format port "\ HiddenServiceDir /var/lib/tor/hidden-services/~a~%" - service) - (for-each (lambda (tcp-port host) - (format port "\ + service) + (for-each (lambda (tcp-port host) + (format port "\ HiddenServicePort ~a ~a~%" - tcp-port host)) - ports hosts))) - '#$(map (match-lambda - (($ <hidden-service> name mapping) - (cons name mapping))) - services)) - - ;; Append the user's config file. - (call-with-input-file #$config-file - (lambda (input) - (dump-port input port))) - #t))) - #:modules '((guix build utils)))))) + tcp-port host)) + ports hosts))) + '#$(map (match-lambda + (($ <hidden-service> name mapping) + (cons name mapping))) + services)) + + ;; Append the user's config file. + (call-with-input-file #$config-file + (lambda (input) + (dump-port input port))) + #t)))))))) (define (tor-shepherd-service config) "Return a <shepherd-service> running TOR." diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 9908b9526b..44d12a7e77 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -158,27 +158,27 @@ EndSection "Return a directory that contains the @code{.conf} files for X.org that includes the @code{share/X11/xorg.conf.d} directories of each package listed in @var{modules}." - (computed-file "xorg.conf.d" - #~(begin - (use-modules (guix build utils) - (srfi srfi-1)) - - (define files - (append-map (lambda (module) - (find-files (string-append - module - "/share/X11/xorg.conf.d") - "\\.conf$")) - (list #$@modules))) - - (mkdir #$output) - (for-each (lambda (file) - (symlink file - (string-append #$output "/" - (basename file)))) - files) - #t) - #:modules '((guix build utils)))) + (with-imported-modules '((guix build utils)) + (computed-file "xorg.conf.d" + #~(begin + (use-modules (guix build utils) + (srfi srfi-1)) + + (define files + (append-map (lambda (module) + (find-files (string-append + module + "/share/X11/xorg.conf.d") + "\\.conf$")) + (list #$@modules))) + + (mkdir #$output) + (for-each (lambda (file) + (symlink file + (string-append #$output "/" + (basename file)))) + files) + #t)))) (define* (xorg-start-command #:key (guile (canonical-package guile-2.0)) diff --git a/gnu/system/install.scm b/gnu/system/install.scm index de14f6fb4c..329c7aba32 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -55,52 +55,53 @@ under /root/.guix-profile where GUIX is installed." (manifest (list (package->manifest-entry guix)))))) (define build - #~(begin - (use-modules (guix build utils) - (gnu build install)) - - (define %root "root") - - (setenv "PATH" - (string-append #$guix "/sbin:" #$tar "/bin:" #$xz "/bin")) - - ;; Note: there is not much to gain here with deduplication and there - ;; is the overhead of the '.links' directory, so turn it off. - (populate-single-profile-directory %root - #:profile #$profile - #:closure "profile" - #:deduplicate? #f) - - ;; Create the tarball. Use GNU format so there's no file name - ;; length limitation. - (with-directory-excursion %root - (zero? (system* "tar" "--xz" "--format=gnu" - - ;; Avoid non-determinism in the archive. Use - ;; mtime = 1, not zero, because that is what the - ;; daemon does for files in the store (see the - ;; 'mtimeStore' constant in local-store.cc.) - "--sort=name" - "--mtime=@1" ;for files in /var/guix - "--owner=root:0" - "--group=root:0" - - "--check-links" - "-cvf" #$output - ;; Avoid adding / and /var to the tarball, - ;; so that the ownership and permissions of those - ;; directories will not be overwritten when - ;; extracting the archive. Do not include /root - ;; because the root account might have a different - ;; home directory. - "./var/guix" - (string-append "." (%store-directory))))))) + (with-imported-modules '((guix build utils) + (guix build store-copy) + (gnu build install)) + #~(begin + (use-modules (guix build utils) + (gnu build install)) + + (define %root "root") + + (setenv "PATH" + (string-append #$guix "/sbin:" #$tar "/bin:" #$xz "/bin")) + + ;; Note: there is not much to gain here with deduplication and + ;; there is the overhead of the '.links' directory, so turn it + ;; off. + (populate-single-profile-directory %root + #:profile #$profile + #:closure "profile" + #:deduplicate? #f) + + ;; Create the tarball. Use GNU format so there's no file name + ;; length limitation. + (with-directory-excursion %root + (zero? (system* "tar" "--xz" "--format=gnu" + + ;; Avoid non-determinism in the archive. Use + ;; mtime = 1, not zero, because that is what the + ;; daemon does for files in the store (see the + ;; 'mtimeStore' constant in local-store.cc.) + "--sort=name" + "--mtime=@1" ;for files in /var/guix + "--owner=root:0" + "--group=root:0" + + "--check-links" + "-cvf" #$output + ;; Avoid adding / and /var to the tarball, so + ;; that the ownership and permissions of those + ;; directories will not be overwritten when + ;; extracting the archive. Do not include /root + ;; because the root account might have a + ;; different home directory. + "./var/guix" + (string-append "." (%store-directory)))))))) (gexp->derivation "guix-tarball.tar.xz" build - #:references-graphs `(("profile" ,profile)) - #:modules '((guix build utils) - (guix build store-copy) - (gnu build install))))) + #:references-graphs `(("profile" ,profile))))) (define (log-to-info) @@ -212,20 +213,20 @@ the user's target storage device rather than on the RAM disk." (define directory (computed-file "configuration-templates" - #~(begin - (mkdir #$output) - (for-each (lambda (file target) - (copy-file file - (string-append #$output "/" - target))) - '(#$(file "bare-bones.tmpl") - #$(file "desktop.tmpl") - #$(file "lightweight-desktop.tmpl")) - '("bare-bones.scm" - "desktop.scm" - "lightweight-desktop.scm")) - #t) - #:modules '((guix build utils)))) + (with-imported-modules '((guix build utils)) + #~(begin + (mkdir #$output) + (for-each (lambda (file target) + (copy-file file + (string-append #$output "/" + target))) + '(#$(file "bare-bones.tmpl") + #$(file "desktop.tmpl") + #$(file "lightweight-desktop.tmpl")) + '("bare-bones.scm" + "desktop.scm" + "lightweight-desktop.scm")) + #t)))) `(("configuration" ,directory))) diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index 3acc579a6b..2e20379473 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -87,30 +87,28 @@ that will be shared with the host system." #:container? #t))) (define script - #~(begin - (use-modules (gnu build linux-container) - (guix build utils)) + (with-imported-modules '((guix config) + (guix utils) + (guix build utils) + (guix build syscalls) + (guix build bournish) + (gnu build file-systems) + (gnu build linux-container)) + #~(begin + (use-modules (gnu build linux-container) + (guix build utils)) - (call-with-container '#$specs - (lambda () - (setenv "HOME" "/root") - (setenv "TMPDIR" "/tmp") - (setenv "GUIX_NEW_SYSTEM" #$os-drv) - (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var")) - (primitive-load (string-append #$os-drv "/boot"))) - ;; A range of 65536 uid/gids is used to cover 16 bits worth of - ;; users and groups, which is sufficient for most cases. - ;; - ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users= - #:host-uids 65536))) + (call-with-container '#$specs + (lambda () + (setenv "HOME" "/root") + (setenv "TMPDIR" "/tmp") + (setenv "GUIX_NEW_SYSTEM" #$os-drv) + (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var")) + (primitive-load (string-append #$os-drv "/boot"))) + ;; A range of 65536 uid/gids is used to cover 16 bits worth of + ;; users and groups, which is sufficient for most cases. + ;; + ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users= + #:host-uids 65536)))) - (gexp->script "run-container" script - #:modules '((ice-9 match) - (srfi srfi-98) - (guix config) - (guix utils) - (guix build utils) - (guix build syscalls) - (guix build bournish) - (gnu build file-systems) - (gnu build linux-container)))))) + (gexp->script "run-container" script)))) diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 8339fae7ed..bbaa5c0f89 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -55,85 +55,81 @@ (guile %guile-static-stripped) (gzip gzip) (name "guile-initrd") - (system (%current-system)) - (modules '())) + (system (%current-system))) "Return a derivation that builds a Linux initrd (a gzipped cpio archive) containing GUILE and that evaluates EXP, a G-expression, upon booting. All -the derivations referenced by EXP are automatically copied to the initrd. - -MODULES is a list of Guile module names to be embedded in the initrd." +the derivations referenced by EXP are automatically copied to the initrd." ;; General Linux overview in `Documentation/early-userspace/README' and ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'. (mlet %store-monad ((init (gexp->script "init" exp - #:modules modules #:guile guile))) (define builder - #~(begin - (use-modules (gnu build linux-initrd)) + (with-imported-modules '((guix cpio) + (guix build utils) + (guix build store-copy) + (gnu build linux-initrd)) + #~(begin + (use-modules (gnu build linux-initrd)) - (mkdir #$output) - (build-initrd (string-append #$output "/initrd") - #:guile #$guile - #:init #$init - ;; Copy everything INIT refers to into the initrd. - #:references-graphs '("closure") - #:gzip (string-append #$gzip "/bin/gzip")))) + (mkdir #$output) + (build-initrd (string-append #$output "/initrd") + #:guile #$guile + #:init #$init + ;; Copy everything INIT refers to into the initrd. + #:references-graphs '("closure") + #:gzip (string-append #$gzip "/bin/gzip"))))) - (gexp->derivation name builder - #:modules '((guix cpio) - (guix build utils) - (guix build store-copy) - (gnu build linux-initrd)) - #:references-graphs `(("closure" ,init))))) + (gexp->derivation name builder + #:references-graphs `(("closure" ,init))))) (define (flat-linux-module-directory linux modules) "Return a flat directory containing the Linux kernel modules listed in MODULES and taken from LINUX." (define build-exp - #~(begin - (use-modules (ice-9 match) (ice-9 regex) - (srfi srfi-1) - (guix build utils) - (gnu build linux-modules)) + (with-imported-modules '((guix build utils) + (guix elf) + (gnu build linux-modules)) + #~(begin + (use-modules (ice-9 match) (ice-9 regex) + (srfi srfi-1) + (guix build utils) + (gnu build linux-modules)) - (define (string->regexp str) - ;; Return a regexp that matches STR exactly. - (string-append "^" (regexp-quote str) "$")) + (define (string->regexp str) + ;; Return a regexp that matches STR exactly. + (string-append "^" (regexp-quote str) "$")) - (define module-dir - (string-append #$linux "/lib/modules")) + (define module-dir + (string-append #$linux "/lib/modules")) - (define (lookup module) - (let ((name (ensure-dot-ko module))) - (match (find-files module-dir (string->regexp name)) - ((file) - file) - (() - (error "module not found" name module-dir)) - ((_ ...) - (error "several modules by that name" - name module-dir))))) + (define (lookup module) + (let ((name (ensure-dot-ko module))) + (match (find-files module-dir (string->regexp name)) + ((file) + file) + (() + (error "module not found" name module-dir)) + ((_ ...) + (error "several modules by that name" + name module-dir))))) - (define modules - (let ((modules (map lookup '#$modules))) - (append modules - (recursive-module-dependencies modules - #:lookup-module lookup)))) + (define modules + (let ((modules (map lookup '#$modules))) + (append modules + (recursive-module-dependencies modules + #:lookup-module lookup)))) - (mkdir #$output) - (for-each (lambda (module) - (format #t "copying '~a'...~%" module) - (copy-file module - (string-append #$output "/" - (basename module)))) - (delete-duplicates modules)))) + (mkdir #$output) + (for-each (lambda (module) + (format #t "copying '~a'...~%" module) + (copy-file module + (string-append #$output "/" + (basename module)))) + (delete-duplicates modules))))) - (gexp->derivation "linux-modules" build-exp - #:modules '((guix build utils) - (guix elf) - (gnu build linux-modules)))) + (gexp->derivation "linux-modules" build-exp)) (define* (base-initrd file-systems #:key @@ -227,38 +223,38 @@ loaded at boot time in the order in which they appear." (mlet %store-monad ((kodir (flat-linux-module-directory linux linux-modules))) (expression->initrd - #~(begin - (use-modules (gnu build linux-boot) - (guix build utils) - (guix build bournish) ;add the 'bournish' meta-command - (srfi srfi-26) + (with-imported-modules '((guix build bournish) + (guix build utils) + (guix build syscalls) + (gnu build linux-boot) + (gnu build linux-modules) + (gnu build file-systems) + (guix elf)) + #~(begin + (use-modules (gnu build linux-boot) + (guix build utils) + (guix build bournish) ;add the 'bournish' meta-command + (srfi srfi-26) - ;; FIXME: The following modules are for - ;; LUKS-DEVICE-MAPPING. We should instead propagate - ;; this info via gexps. - ((gnu build file-systems) - #:select (find-partition-by-luks-uuid)) - (rnrs bytevectors)) + ;; FIXME: The following modules are for + ;; LUKS-DEVICE-MAPPING. We should instead propagate + ;; this info via gexps. + ((gnu build file-systems) + #:select (find-partition-by-luks-uuid)) + (rnrs bytevectors)) - (with-output-to-port (%make-void-port "w") - (lambda () - (set-path-environment-variable "PATH" '("bin" "sbin") - '#$helper-packages))) + (with-output-to-port (%make-void-port "w") + (lambda () + (set-path-environment-variable "PATH" '("bin" "sbin") + '#$helper-packages))) - (boot-system #:mounts '#$(map file-system->spec file-systems) - #:pre-mount (lambda () - (and #$@device-mapping-commands)) - #:linux-modules '#$linux-modules - #:linux-module-directory '#$kodir - #:qemu-guest-networking? #$qemu-networking? - #:volatile-root? '#$volatile-root?)) - #:name "base-initrd" - #:modules '((guix build bournish) - (guix build utils) - (guix build syscalls) - (gnu build linux-boot) - (gnu build linux-modules) - (gnu build file-systems) - (guix elf))))) + (boot-system #:mounts '#$(map file-system->spec file-systems) + #:pre-mount (lambda () + (and #$@device-mapping-commands)) + #:linux-modules '#$linux-modules + #:linux-module-directory '#$kodir + #:qemu-guest-networking? #$qemu-networking? + #:volatile-root? '#$volatile-root?))) + #:name "base-initrd"))) ;;; linux-initrd.scm ends here diff --git a/gnu/system/locale.scm b/gnu/system/locale.scm index f9d713e0cf..3bb9f950a8 100644 --- a/gnu/system/locale.scm +++ b/gnu/system/locale.scm @@ -154,10 +154,10 @@ data format changes between libc versions." #:libc libc)) libcs))) (gexp->derivation "locale-multiple-versions" - #~(begin - (use-modules (guix build union)) - (union-build #$output (list #$@dirs))) - #:modules '((guix build union)) + (with-imported-modules '((guix build union)) + #~(begin + (use-modules (guix build union)) + (union-build #$output (list #$@dirs)))) #:local-build? #t #:substitutable? #f))))) diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index b8837c63f0..730a9ee091 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -139,10 +139,11 @@ `(fontconfig (dir "/run/current-system/profile/share/fonts"))) (define copy-guile-wm - #~(begin - (use-modules (guix build utils)) - (copy-file (car (find-files #$guile-wm "wm-init-sample.scm")) - #$output))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (copy-file (car (find-files #$guile-wm "wm-init-sample.scm")) + #$output)))) (let ((profile (plain-file "bash_profile" "\ # Honor per-interactive-shell startup file @@ -176,27 +177,26 @@ alias ll='ls -l'\n")) (zlogin (plain-file "zlogin" "\ # Honor system-wide environment variables source /etc/profile\n")) - (guile-wm (computed-file "guile-wm" copy-guile-wm - #:modules '((guix build utils)))) + (guile-wm (computed-file "guile-wm" copy-guile-wm)) (xdefaults (plain-file "Xdefaults" "\ XTerm*utf8: always XTerm*metaSendsEscape: true\n")) (fonts.conf (computed-file "fonts.conf" - #~(begin - (use-modules (guix build utils) - (sxml simple)) - - (define dir - (string-append #$output - "/fontconfig")) - - (mkdir-p dir) - (call-with-output-file (string-append dir - "/fonts.conf") - (lambda (port) - (sxml->xml '#$fonts.conf-content port)))) - #:modules '((guix build utils)))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (sxml simple)) + + (define dir + (string-append #$output + "/fontconfig")) + + (mkdir-p dir) + (call-with-output-file (string-append dir + "/fonts.conf") + (lambda (port) + (sxml->xml '#$fonts.conf-content port))))))) (gdbinit (plain-file "gdbinit" "\ # Tell GDB where to look for separate debugging files. set debug-file-directory ~/.guix-profile/lib/debug\n"))) @@ -211,22 +211,22 @@ set debug-file-directory ~/.guix-profile/lib/debug\n"))) (define (skeleton-directory skeletons) "Return a directory containing SKELETONS, a list of name/derivation tuples." (computed-file "skel" - #~(begin - (use-modules (ice-9 match) - (guix build utils)) - - (mkdir #$output) - (chdir #$output) - - ;; Note: copy the skeletons instead of symlinking - ;; them like 'file-union' does, because 'useradd' - ;; would just copy the symlinks as is. - (for-each (match-lambda - ((target source) - (copy-recursively source target))) - '#$skeletons) - #t) - #:modules '((guix build utils)))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (ice-9 match) + (guix build utils)) + + (mkdir #$output) + (chdir #$output) + + ;; Note: copy the skeletons instead of symlinking + ;; them like 'file-union' does, because 'useradd' + ;; would just copy the symlinks as is. + (for-each (match-lambda + ((target source) + (copy-recursively source target))) + '#$skeletons) + #t)))) (define (assert-valid-users/groups users groups) "Raise an error if USERS refer to groups not listed in GROUPS." diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 676e89df98..fc5eaf5706 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -155,34 +155,34 @@ made available under the /xchg CIFS share." (define builder ;; Code that launches the VM that evaluates EXP. - #~(begin - (use-modules (guix build utils) - (gnu build vm)) - - (let ((inputs '#$(list qemu coreutils)) - (linux (string-append #$linux "/bzImage")) - (initrd (string-append #$initrd "/initrd")) - (loader #$loader) - (graphs '#$(match references-graphs - (((graph-files . _) ...) graph-files) - (_ #f)))) - - (set-path-environment-variable "PATH" '("bin") inputs) - - (load-in-linux-vm loader - #:output #$output - #:linux linux #:initrd initrd - #:memory-size #$memory-size - #:make-disk-image? #$make-disk-image? - #:disk-image-format #$disk-image-format - #:disk-image-size #$disk-image-size - #:references-graphs graphs)))) + (with-imported-modules modules + #~(begin + (use-modules (guix build utils) + (gnu build vm)) + + (let ((inputs '#$(list qemu coreutils)) + (linux (string-append #$linux "/bzImage")) + (initrd (string-append #$initrd "/initrd")) + (loader #$loader) + (graphs '#$(match references-graphs + (((graph-files . _) ...) graph-files) + (_ #f)))) + + (set-path-environment-variable "PATH" '("bin") inputs) + + (load-in-linux-vm loader + #:output #$output + #:linux linux #:initrd initrd + #:memory-size #$memory-size + #:make-disk-image? #$make-disk-image? + #:disk-image-format #$disk-image-format + #:disk-image-size #$disk-image-size + #:references-graphs graphs))))) (gexp->derivation name builder ;; TODO: Require the "kvm" feature. #:system system #:env-vars env-vars - #:modules modules #:guile-for-build guile-for-build #:references-graphs references-graphs))) diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index 0013b465b4..a6278b25d4 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -70,125 +70,125 @@ using COMMAND, a gexp that evaluates to a list of strings. Compare some properties of running system to what's declared in OS, an <operating-system>." (define test - #~(begin - (use-modules (gnu build marionette) - (srfi srfi-1) - (srfi srfi-26) - (srfi srfi-64) - (ice-9 match)) - - (define marionette - (make-marionette #$command)) - - (mkdir #$output) - (chdir #$output) - - (test-begin "basic") - - (test-assert "uname" - (match (marionette-eval '(uname) marionette) - (#("Linux" host-name version _ architecture) - (and (string=? host-name - #$(operating-system-host-name os)) - (string-prefix? #$(package-version - (operating-system-kernel os)) - version) - (string-prefix? architecture %host-type))))) - - (test-assert "shell and user commands" - ;; Is everything in $PATH? - (zero? (marionette-eval '(system " + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (gnu build marionette) + (srfi srfi-1) + (srfi srfi-26) + (srfi srfi-64) + (ice-9 match)) + + (define marionette + (make-marionette #$command)) + + (mkdir #$output) + (chdir #$output) + + (test-begin "basic") + + (test-assert "uname" + (match (marionette-eval '(uname) marionette) + (#("Linux" host-name version _ architecture) + (and (string=? host-name + #$(operating-system-host-name os)) + (string-prefix? #$(package-version + (operating-system-kernel os)) + version) + (string-prefix? architecture %host-type))))) + + (test-assert "shell and user commands" + ;; Is everything in $PATH? + (zero? (marionette-eval '(system " . /etc/profile set -e -x guix --version ls --version grep --version info --version") - marionette))) - - (test-assert "accounts" - (let ((users (marionette-eval '(begin - (use-modules (ice-9 match)) - (let loop ((result '())) - (match (getpw) - (#f (reverse result)) - (x (loop (cons x result)))))) - marionette))) - (lset= string=? - (map passwd:name users) - (list - #$@(map user-account-name - (operating-system-user-accounts os)))))) - - (test-assert "shepherd services" - (let ((services (marionette-eval '(begin - (use-modules (gnu services herd)) - (call-with-values current-services - append)) - marionette))) - (lset= eq? - (pk 'services services) - '(root #$@(operating-system-shepherd-service-names os))))) - - (test-equal "login on tty1" - "root\n" - (begin - (marionette-control "sendkey ctrl-alt-f1" marionette) - ;; Wait for the 'term-tty1' service to be running (using - ;; 'start-service' is the simplest and most reliable way to do - ;; that.) + marionette))) + + (test-assert "accounts" + (let ((users (marionette-eval '(begin + (use-modules (ice-9 match)) + (let loop ((result '())) + (match (getpw) + (#f (reverse result)) + (x (loop (cons x result)))))) + marionette))) + (lset= string=? + (map passwd:name users) + (list + #$@(map user-account-name + (operating-system-user-accounts os)))))) + + (test-assert "shepherd services" + (let ((services (marionette-eval '(begin + (use-modules (gnu services herd)) + (call-with-values current-services + append)) + marionette))) + (lset= eq? + (pk 'services services) + '(root #$@(operating-system-shepherd-service-names os))))) + + (test-equal "login on tty1" + "root\n" + (begin + (marionette-control "sendkey ctrl-alt-f1" marionette) + ;; Wait for the 'term-tty1' service to be running (using + ;; 'start-service' is the simplest and most reliable way to do + ;; that.) + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'term-tty1)) + marionette) + + ;; Now we can type. + (marionette-type "root\n\nid -un > logged-in\n" marionette) + + ;; It can take a while before the shell commands are executed. + (let loop ((i 0)) + (unless (or (file-exists? "/root/logged-in") (> i 15)) + (sleep 1) + (loop (+ i 1)))) + (marionette-eval '(use-modules (rnrs io ports)) marionette) + (marionette-eval '(call-with-input-file "/root/logged-in" + get-string-all) + marionette))) + + (test-assert "host name resolution" + (match (marionette-eval + '(begin + ;; Wait for nscd or our requests go through it. + (use-modules (gnu services herd)) + (start-service 'nscd) + + (list (getaddrinfo "localhost") + (getaddrinfo #$(operating-system-host-name os)))) + marionette) + ((((? vector?) ..1) ((? vector?) ..1)) + #t) + (x + (pk 'failure x #f)))) + + (test-equal "host not found" + #f (marionette-eval - '(begin - (use-modules (gnu services herd)) - (start-service 'term-tty1)) - marionette) - - ;; Now we can type. - (marionette-type "root\n\nid -un > logged-in\n" marionette) - - ;; It can take a while before the shell commands are executed. - (let loop ((i 0)) - (unless (or (file-exists? "/root/logged-in") (> i 15)) - (sleep 1) - (loop (+ i 1)))) - (marionette-eval '(use-modules (rnrs io ports)) marionette) - (marionette-eval '(call-with-input-file "/root/logged-in" - get-string-all) - marionette))) - - (test-assert "host name resolution" - (match (marionette-eval - '(begin - ;; Wait for nscd or our requests go through it. - (use-modules (gnu services herd)) - (start-service 'nscd) - - (list (getaddrinfo "localhost") - (getaddrinfo #$(operating-system-host-name os)))) - marionette) - ((((? vector?) ..1) ((? vector?) ..1)) - #t) - (x - (pk 'failure x #f)))) - - (test-equal "host not found" - #f - (marionette-eval - '(false-if-exception (getaddrinfo "does-not-exist")) - marionette)) - - (test-assert "screendump" - (begin - (marionette-control (string-append "screendump " #$output - "/tty1.ppm") - marionette) - (file-exists? "tty1.ppm"))) - - (test-end) - (exit (= (test-runner-fail-count (test-runner-current)) 0)))) - - (gexp->derivation name test - #:modules '((gnu build marionette)))) + '(false-if-exception (getaddrinfo "does-not-exist")) + marionette)) + + (test-assert "screendump" + (begin + (marionette-control (string-append "screendump " #$output + "/tty1.ppm") + marionette) + (file-exists? "tty1.ppm"))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation name test)) (define %test-basic-os (system-test @@ -243,67 +243,67 @@ functionality tests.") (command (system-qemu-image/shared-store-script os #:graphic? #f))) (define test - #~(begin - (use-modules (gnu build marionette) - (srfi srfi-64) - (ice-9 match)) - - (define marionette - (make-marionette (list #$command))) - - (define (wait-for-file file) - ;; Wait until FILE exists in the guest; 'read' its content and - ;; return it. - (marionette-eval - `(let loop ((i 10)) - (cond ((file-exists? ,file) - (call-with-input-file ,file read)) - ((> i 0) - (sleep 1) - (loop (- i 1))) - (else - (error "file didn't show up" ,file)))) - marionette)) - - (mkdir #$output) - (chdir #$output) - - (test-begin "mcron") - - (test-eq "service running" - 'running! - (marionette-eval - '(begin - (use-modules (gnu services herd)) - (start-service 'mcron) - 'running!) - marionette)) - - ;; Make sure root's mcron job runs, has its cwd set to "/root", and - ;; runs with the right UID/GID. - (test-equal "root's job" - '(0 0) - (wait-for-file "/root/witness")) - - ;; Likewise for Alice's job. We cannot know what its GID is since - ;; it's chosen by 'groupadd', but it's strictly positive. - (test-assert "alice's job" - (match (wait-for-file "/home/alice/witness") - ((1000 gid) - (>= gid 100)))) - - ;; Last, the job that uses a command; allows us to test whether - ;; $PATH is sane. (Note that 'marionette-eval' stringifies objects - ;; that don't have a read syntax, hence the string.) - (test-equal "root's job with command" - "#<eof>" - (wait-for-file "/root/witness-touch")) - - (test-end) - (exit (= (test-runner-fail-count (test-runner-current)) 0)))) - - (gexp->derivation name test - #:modules '((gnu build marionette))))) + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (gnu build marionette) + (srfi srfi-64) + (ice-9 match)) + + (define marionette + (make-marionette (list #$command))) + + (define (wait-for-file file) + ;; Wait until FILE exists in the guest; 'read' its content and + ;; return it. + (marionette-eval + `(let loop ((i 10)) + (cond ((file-exists? ,file) + (call-with-input-file ,file read)) + ((> i 0) + (sleep 1) + (loop (- i 1))) + (else + (error "file didn't show up" ,file)))) + marionette)) + + (mkdir #$output) + (chdir #$output) + + (test-begin "mcron") + + (test-eq "service running" + 'running! + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'mcron) + 'running!) + marionette)) + + ;; Make sure root's mcron job runs, has its cwd set to "/root", and + ;; runs with the right UID/GID. + (test-equal "root's job" + '(0 0) + (wait-for-file "/root/witness")) + + ;; Likewise for Alice's job. We cannot know what its GID is since + ;; it's chosen by 'groupadd', but it's strictly positive. + (test-assert "alice's job" + (match (wait-for-file "/home/alice/witness") + ((1000 gid) + (>= gid 100)))) + + ;; Last, the job that uses a command; allows us to test whether + ;; $PATH is sane. (Note that 'marionette-eval' stringifies objects + ;; that don't have a read syntax, hence the string.) + (test-equal "root's job with command" + "#<eof>" + (wait-for-file "/root/witness-touch")) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation name test))) (define %test-mcron (system-test @@ -355,90 +355,90 @@ functionality tests.") ".local")) (define test - #~(begin - (use-modules (gnu build marionette) - (srfi srfi-1) - (srfi srfi-64) - (ice-9 match)) - - (define marionette - (make-marionette (list #$run))) - - (mkdir #$output) - (chdir #$output) - - (test-begin "avahi") - - (test-assert "wait for services" - (marionette-eval - '(begin - (use-modules (gnu services herd)) - - (start-service 'nscd) - - ;; 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~%")) - (lambda args - (format #t "waiting for nscd...~%") - (usleep 500000) - (try))))) - - ;; Wait for the other useful things. - (start-service 'avahi-daemon) - (start-service 'networking) - - #t) - marionette)) - - (test-equal "avahi-resolve-host-name" - 0 - (marionette-eval - '(system* - "/run/current-system/profile/bin/avahi-resolve-host-name" - "-v" #$mdns-host-name) - marionette)) - - (test-equal "avahi-browse" - 0 - (marionette-eval - '(system* "avahi-browse" "-avt") - marionette)) - - (test-assert "getaddrinfo .local" - ;; Wait for the 'avahi-daemon' service and perform a resolution. - (match (marionette-eval - '(getaddrinfo #$mdns-host-name) - marionette) - (((? vector? addrinfos) ..1) - (pk 'getaddrinfo addrinfos) - (and (any (lambda (ai) - (= AF_INET (addrinfo:fam ai))) - addrinfos) - (any (lambda (ai) - (= AF_INET6 (addrinfo:fam ai))) - addrinfos))))) - - (test-assert "gethostbyname .local" - (match (pk 'gethostbyname - (marionette-eval '(gethostbyname #$mdns-host-name) - marionette)) - ((? vector? result) - (and (string=? (hostent:name result) #$mdns-host-name) - (= (hostent:addrtype result) AF_INET))))) - - - (test-end) - (exit (= (test-runner-fail-count (test-runner-current)) 0)))) - - (gexp->derivation "nss-mdns" test - #:modules '((gnu build marionette))))) + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (gnu build marionette) + (srfi srfi-1) + (srfi srfi-64) + (ice-9 match)) + + (define marionette + (make-marionette (list #$run))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "avahi") + + (test-assert "wait for services" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + + (start-service 'nscd) + + ;; 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~%")) + (lambda args + (format #t "waiting for nscd...~%") + (usleep 500000) + (try))))) + + ;; Wait for the other useful things. + (start-service 'avahi-daemon) + (start-service 'networking) + + #t) + marionette)) + + (test-equal "avahi-resolve-host-name" + 0 + (marionette-eval + '(system* + "/run/current-system/profile/bin/avahi-resolve-host-name" + "-v" #$mdns-host-name) + marionette)) + + (test-equal "avahi-browse" + 0 + (marionette-eval + '(system* "avahi-browse" "-avt") + marionette)) + + (test-assert "getaddrinfo .local" + ;; Wait for the 'avahi-daemon' service and perform a resolution. + (match (marionette-eval + '(getaddrinfo #$mdns-host-name) + marionette) + (((? vector? addrinfos) ..1) + (pk 'getaddrinfo addrinfos) + (and (any (lambda (ai) + (= AF_INET (addrinfo:fam ai))) + addrinfos) + (any (lambda (ai) + (= AF_INET6 (addrinfo:fam ai))) + addrinfos))))) + + (test-assert "gethostbyname .local" + (match (pk 'gethostbyname + (marionette-eval '(gethostbyname #$mdns-host-name) + marionette)) + ((? vector? result) + (and (string=? (hostent:name result) #$mdns-host-name) + (= (hostent:addrtype result) AF_INET))))) + + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "nss-mdns" test))) (define %test-nss-mdns (system-test diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 2c0db41d69..3c83da151a 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -119,43 +119,45 @@ TARGET-SIZE bytes containing the installed system." 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 " + (with-imported-modules '((guix build utils) + (gnu build marionette)) + #~(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 @@ -178,11 +180,9 @@ cp /etc/litl-config.scm /mnt/etc/config.scm guix system init /mnt/etc/config.scm /mnt --no-substitutes sync reboot\n")) - marionette)))) + marionette))))) - (gexp->derivation "installation" install - #:modules '((guix build utils) - (gnu build marionette))))) + (gexp->derivation "installation" install))) (define %test-installed-os |