aboutsummaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
Diffstat (limited to 'gnu')
-rw-r--r--gnu/services.scm8
-rw-r--r--gnu/services/base.scm60
-rw-r--r--gnu/services/dbus.scm41
-rw-r--r--gnu/services/desktop.scm67
-rw-r--r--gnu/services/networking.scm54
-rw-r--r--gnu/services/xorg.scm42
-rw-r--r--gnu/system/install.scm117
-rw-r--r--gnu/system/linux-container.scm48
-rw-r--r--gnu/system/linux-initrd.scm170
-rw-r--r--gnu/system/locale.scm8
-rw-r--r--gnu/system/shadow.scm72
-rw-r--r--gnu/system/vm.scm46
-rw-r--r--gnu/tests/base.scm514
-rw-r--r--gnu/tests/install.scm82
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
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-15 21:27:16 +0000