gnu: Switch to 'with-imported-modules'.
* gnu/services.scm (directory-union): Use 'with-imported-modules' instead of the '#:modules' argument of 'computed-file'. * gnu/services/base.scm (udev-rules-union): Likewise. * gnu/services/dbus.scm (system-service-directory): Likewise. * gnu/services/desktop.scm (wrapped-dbus-service): (polkit-directory): Likewise. * gnu/services/networking.scm (tor-configuration->torrc): Likewise. * gnu/services/xorg.scm (xorg-configuration-directory): Likewise. * gnu/system/install.scm (self-contained-tarball): Likewise. * gnu/system/linux-container.scm (container-script): Likewise. * gnu/system/linux-initrd.scm (expression->initrd): Likewise, and remove #:modules parameter. (flat-linux-module-directory): Use 'with-imported-modules'. (base-initrd): Likewise. * gnu/system/locale.scm (locale-directory): Likewise. * gnu/system/shadow.scm (default-skeletons): Likewise. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Likewise. * gnu/tests/base.scm (run-basic-test): Likewise. * gnu/tests/install.scm (run-install): Likewise. * doc/guix.texi (Initial RAM Disk): Update 'expression->initrd' documentation.
This commit is contained in:
Ludovic Courtès
parent
0bb9929eaa
commit
4ee96a7912
|
|
@ -10016,15 +10016,11 @@ program. That gives a lot of flexibility. The
|
|||
program to run in that initrd.
|
||||
|
||||
@deffn {Monadic Procedure} expression->initrd @var{exp} @
|
||||
[#:guile %guile-static-stripped] [#:name "guile-initrd"] @
|
||||
[#:modules '()]
|
||||
[#:guile %guile-static-stripped] [#:name "guile-initrd"]
|
||||
Return a derivation that builds a Linux initrd (a gzipped cpio archive)
|
||||
containing @var{guile} and that evaluates @var{exp}, a G-expression,
|
||||
upon booting. All the derivations referenced by @var{exp} are
|
||||
automatically copied to the initrd.
|
||||
|
||||
@var{modules} is a list of Guile module names to be embedded in the
|
||||
initrd.
|
||||
@end deffn
|
||||
|
||||
@node GRUB Configuration
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(with-imported-modules '((guix build utils))
|
||||
#~(begin
|
||||
(use-modules (guix build utils))
|
||||
|
||||
(define rules.d
|
||||
(string-append #$output "/lib/udev/rules.d"))
|
||||
(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))))
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(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)))
|
||||
(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))))
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(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))))
|
||||
#:modules '((guix build union))))
|
||||
(union-build #$output
|
||||
(map (cut string-append <>
|
||||
"/share/polkit-1")
|
||||
(list #$@packages)))))))
|
||||
|
||||
(define polkit-etc-files
|
||||
(match-lambda
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(with-imported-modules '((guix build utils))
|
||||
#~(begin
|
||||
(use-modules (guix build utils)
|
||||
(ice-9 match))
|
||||
|
||||
(call-with-output-file #$output
|
||||
(lambda (port)
|
||||
(display "\
|
||||
(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))
|
||||
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))))))
|
||||
;; 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."
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(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)))
|
||||
(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))))
|
||||
(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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(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")
|
||||
(define %root "root")
|
||||
|
||||
(setenv "PATH"
|
||||
(string-append #$guix "/sbin:" #$tar "/bin:" #$xz "/bin"))
|
||||
(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)
|
||||
;; 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"
|
||||
;; 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"
|
||||
;; 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)))))))
|
||||
"--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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(with-imported-modules '((guix build utils))
|
||||
#~(begin
|
||||
(use-modules (guix build utils)
|
||||
(sxml simple))
|
||||
|
||||
(define dir
|
||||
(string-append #$output
|
||||
"/fontconfig"))
|
||||
(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))))
|
||||
(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))
|
||||
(with-imported-modules '((guix build utils))
|
||||
#~(begin
|
||||
(use-modules (ice-9 match)
|
||||
(guix build utils))
|
||||
|
||||
(mkdir #$output)
|
||||
(chdir #$output)
|
||||
(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))))
|
||||
;; 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."
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(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))))
|
||||
(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)
|
||||
(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))))
|
||||
(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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(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))
|
||||
(define marionette
|
||||
(make-marionette #$command))
|
||||
|
||||
(mkdir #$output)
|
||||
(chdir #$output)
|
||||
(mkdir #$output)
|
||||
(chdir #$output)
|
||||
|
||||
(test-begin "basic")
|
||||
(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 "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 "
|
||||
(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)))
|
||||
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 "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-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.)
|
||||
(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)
|
||||
'(false-if-exception (getaddrinfo "does-not-exist"))
|
||||
marionette))
|
||||
|
||||
;; Now we can type.
|
||||
(marionette-type "root\n\nid -un > logged-in\n" marionette)
|
||||
(test-assert "screendump"
|
||||
(begin
|
||||
(marionette-control (string-append "screendump " #$output
|
||||
"/tty1.ppm")
|
||||
marionette)
|
||||
(file-exists? "tty1.ppm")))
|
||||
|
||||
;; 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-end)
|
||||
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
||||
|
||||
(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))))
|
||||
(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))
|
||||
(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 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))
|
||||
(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)
|
||||
(mkdir #$output)
|
||||
(chdir #$output)
|
||||
|
||||
(test-begin "mcron")
|
||||
(test-begin "mcron")
|
||||
|
||||
(test-eq "service running"
|
||||
'running!
|
||||
(marionette-eval
|
||||
'(begin
|
||||
(use-modules (gnu services herd))
|
||||
(start-service 'mcron)
|
||||
'running!)
|
||||
marionette))
|
||||
(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"))
|
||||
;; 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))))
|
||||
;; 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"))
|
||||
;; 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))))
|
||||
(test-end)
|
||||
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
||||
|
||||
(gexp->derivation name test
|
||||
#:modules '((gnu build marionette)))))
|
||||
(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))
|
||||
(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)))
|
||||
(define marionette
|
||||
(make-marionette (list #$run)))
|
||||
|
||||
(mkdir #$output)
|
||||
(chdir #$output)
|
||||
(mkdir #$output)
|
||||
(chdir #$output)
|
||||
|
||||
(test-begin "avahi")
|
||||
(test-begin "avahi")
|
||||
|
||||
(test-assert "wait for services"
|
||||
(marionette-eval
|
||||
'(begin
|
||||
(use-modules (gnu services herd))
|
||||
(test-assert "wait for services"
|
||||
(marionette-eval
|
||||
'(begin
|
||||
(use-modules (gnu services herd))
|
||||
|
||||
(start-service 'nscd)
|
||||
(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)))))
|
||||
;; 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)
|
||||
;; Wait for the other useful things.
|
||||
(start-service 'avahi-daemon)
|
||||
(start-service 'networking)
|
||||
|
||||
#t)
|
||||
marionette))
|
||||
#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-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-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 "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-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))))
|
||||
(test-end)
|
||||
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
||||
|
||||
(gexp->derivation "nss-mdns" test
|
||||
#:modules '((gnu build marionette)))))
|
||||
(gexp->derivation "nss-mdns" test)))
|
||||
|
||||
(define %test-nss-mdns
|
||||
(system-test
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(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))
|
||||
(set-path-environment-variable "PATH" '("bin")
|
||||
(list #$qemu-minimal))
|
||||
|
||||
(system* "qemu-img" "create" "-f" "qcow2"
|
||||
#$output #$(number->string target-size))
|
||||
(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")
|
||||
'())))))
|
||||
(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))
|
||||
(pk 'uname (marionette-eval '(uname) marionette))
|
||||
|
||||
;; Wait for tty1.
|
||||
(marionette-eval '(begin
|
||||
(use-modules (gnu services herd))
|
||||
(start 'term-tty1))
|
||||
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)
|
||||
(marionette-eval '(call-with-output-file "/etc/litl-config.scm"
|
||||
(lambda (port)
|
||||
(write '#$%minimal-os-source port)))
|
||||
marionette)
|
||||
|
||||
(exit (marionette-eval '(zero? (system "
|
||||
(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
|
||||
|
|
|
|||
Loading…
Reference in New Issue