aboutsummaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/install.scm119
-rw-r--r--gnu/system/linux-container.scm49
-rw-r--r--gnu/system/linux-initrd.scm172
-rw-r--r--gnu/system/locale.scm8
-rw-r--r--gnu/system/mapped-devices.scm34
-rw-r--r--gnu/system/pam.scm61
-rw-r--r--gnu/system/shadow.scm47
-rw-r--r--gnu/system/vm.scm166
8 files changed, 356 insertions, 300 deletions
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index de14f6fb4c..734a361c37 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -55,52 +56,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 +214,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)))
@@ -391,6 +393,7 @@ Use Alt-F2 for documentation.
parted ddrescue
grub ;mostly so xrefs to its manual work
cryptsetup
+ mdadm
btrfs-progs
wireless-tools iw wpa-supplicant-minimal iproute
;; XXX: We used to have GNU fdisk here, but as of version
diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm
index 3acc579a6b..d3c0036f47 100644
--- a/gnu/system/linux-container.scm
+++ b/gnu/system/linux-container.scm
@@ -87,30 +87,29 @@ 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 combinators)
+ (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 484bce71c4..bbaa5c0f89 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -54,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
@@ -183,6 +180,7 @@ loaded at boot time in the order in which they appear."
"usb-storage" "uas" ;for the installation image etc.
"usbhid" "hid-generic" "hid-apple" ;keyboards during early boot
"dm-crypt" "xts" "serpent_generic" "wp512" ;for encrypted root partitions
+ "nvme" ;for new SSD NVMe devices
,@(if (string-match "^(x86_64|i[3-6]86)-" (%current-system))
'("pata_acpi" "pata_atiixp" ;for ATA controllers
"isci") ;for SAS controllers like Intel C602
@@ -225,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/mapped-devices.scm b/gnu/system/mapped-devices.scm
index 450b4737ac..732f73cc4b 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -85,9 +85,7 @@
(modules `((rnrs bytevectors) ;bytevector?
((gnu build file-systems)
#:select (find-partition-by-luks-uuid))
- ,@%default-modules))
- (imported-modules `((gnu build file-systems)
- ,@%default-imported-modules)))))))
+ ,@%default-modules)))))))
(define (device-mapping-service mapped-device)
"Return a service that sets up @var{mapped-device}."
@@ -101,20 +99,22 @@
(define (open-luks-device source target)
"Return a gexp that maps SOURCE to TARGET as a LUKS device, using
'cryptsetup'."
- #~(let ((source #$source))
- (zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
- "open" "--type" "luks"
-
- ;; Note: We cannot use the "UUID=source" syntax here
- ;; because 'cryptsetup' implements it by searching the
- ;; udev-populated /dev/disk/by-id directory but udev may
- ;; be unavailable at the time we run this.
- (if (bytevector? source)
- (or (find-partition-by-luks-uuid source)
- (error "LUKS partition not found" source))
- source)
-
- #$target))))
+ (with-imported-modules '((gnu build file-systems)
+ (guix build bournish))
+ #~(let ((source #$source))
+ (zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
+ "open" "--type" "luks"
+
+ ;; Note: We cannot use the "UUID=source" syntax here
+ ;; because 'cryptsetup' implements it by searching the
+ ;; udev-populated /dev/disk/by-id directory but udev may
+ ;; be unavailable at the time we run this.
+ (if (bytevector? source)
+ (or (find-partition-by-luks-uuid source)
+ (error "LUKS partition not found" source))
+ source)
+
+ #$target)))))
(define (close-luks-device source target)
"Return a gexp that closes TARGET, a LUKS device."
diff --git a/gnu/system/pam.scm b/gnu/system/pam.scm
index 743039daf6..cd7a3427ed 100644
--- a/gnu/system/pam.scm
+++ b/gnu/system/pam.scm
@@ -23,6 +23,7 @@
#:use-module (gnu services)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:use-module ((guix utils) #:select (%current-system))
@@ -38,6 +39,13 @@
pam-entry-module
pam-entry-arguments
+ pam-limits-entry
+ pam-limits-entry-domain
+ pam-limits-entry-type
+ pam-limits-entry-item
+ pam-limits-entry-value
+ pam-limits-entry->string
+
pam-services->directory
unix-pam-service
base-pam-services
@@ -76,6 +84,59 @@
(arguments pam-entry-arguments ; list of string-valued g-expressions
(default '())))
+;; PAM limits entries are used by the pam_limits PAM module to set or override
+;; limits on system resources for user sessions. The format is specified
+;; here: http://linux-pam.org/Linux-PAM-html/sag-pam_limits.html
+(define-record-type <pam-limits-entry>
+ (make-pam-limits-entry domain type item value)
+ pam-limits-entry?
+ (domain pam-limits-entry-domain) ; string
+ (type pam-limits-entry-type) ; symbol
+ (item pam-limits-entry-item) ; symbol
+ (value pam-limits-entry-value)) ; symbol or number
+
+(define (pam-limits-entry domain type item value)
+ "Construct a pam-limits-entry ensuring that the provided values are valid."
+ (define (valid? value)
+ (case item
+ ((priority) (number? value))
+ ((nice) (and (number? value)
+ (>= value -20)
+ (<= value 19)))
+ (else (or (and (number? value)
+ (>= value -1))
+ (member value '(unlimited infinity))))))
+ (define items
+ (list 'core 'data 'fsize
+ 'memlock 'nofile 'rss
+ 'stack 'cpu 'nproc
+ 'as 'maxlogins 'maxsyslogins
+ 'priority 'locks 'sigpending
+ 'msgqueue 'nice 'rtprio))
+ (when (not (member type '(hard soft both)))
+ (error "invalid limit type" type))
+ (when (not (member item items))
+ (error "invalid limit item" item))
+ (when (not (valid? value))
+ (error "invalid limit value" value))
+ (make-pam-limits-entry domain type item value))
+
+(define (pam-limits-entry->string entry)
+ "Convert a pam-limits-entry record to a string."
+ (match entry
+ (($ <pam-limits-entry> domain type item value)
+ (string-join (list domain
+ (if (eq? type 'both)
+ "-"
+ (symbol->string type))
+ (symbol->string item)
+ (cond
+ ((symbol? value)
+ (symbol->string value))
+ (else
+ (number->string value))))
+ " "))))
+
(define (pam-service->configuration service)
"Return the derivation building the configuration file for SERVICE, to be
dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE."
diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm
index f09e8c24f2..c3948900eb 100644
--- a/gnu/system/shadow.scm
+++ b/gnu/system/shadow.scm
@@ -126,17 +126,19 @@
(name "nobody")
(uid 65534)
(group "nogroup")
- (home-directory "/var/empty")
+ (shell #~(string-append #$shadow "/sbin/nologin"))
+ (home-directory "/nonexistent")
(system? #t))))
(define (default-skeletons)
"Return the default skeleton files for /etc/skel. These files are copied by
'useradd' in the home directory of newly created user accounts."
(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
@@ -170,8 +172,7 @@ 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"))
@@ -188,22 +189,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..c31e3a80ef 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -90,6 +90,21 @@
(options "trans=virtio")
(check? #f))))
+(define %vm-module-closure
+ ;; The closure of (gnu build vm), roughly.
+ ;; FIXME: Compute it automatically.
+ '((gnu build vm)
+ (gnu build install)
+ (gnu build linux-boot)
+ (gnu build linux-modules)
+ (gnu build file-systems)
+ (guix elf)
+ (guix records)
+ (guix build utils)
+ (guix build syscalls)
+ (guix build bournish)
+ (guix build store-copy)))
+
(define* (expression->derivation-in-linux-vm name exp
#:key
(system (%current-system))
@@ -97,18 +112,6 @@
initrd
(qemu qemu-minimal)
(env-vars '())
- (modules
- '((gnu build vm)
- (gnu build install)
- (gnu build linux-boot)
- (gnu build linux-modules)
- (gnu build file-systems)
- (guix elf)
- (guix records)
- (guix build utils)
- (guix build syscalls)
- (guix build bournish)
- (guix build store-copy)))
(guile-for-build
(%guile-for-build))
@@ -128,23 +131,13 @@ When MAKE-DISK-IMAGE? is true, then create a QEMU disk image of type
DISK-IMAGE-FORMAT (e.g., 'qcow2' or 'raw'), of DISK-IMAGE-SIZE bytes and
return it.
-MODULES is the set of modules imported in the execution environment of EXP.
-
When REFERENCES-GRAPHS is true, it must be a list of file name/store path
pairs, as for `derivation'. The files containing the reference graphs are
made available under the /xchg CIFS share."
(mlet* %store-monad
- ((module-dir (imported-modules modules))
- (compiled (compiled-modules modules))
- (user-builder (gexp->file "builder-in-linux-vm" exp))
+ ((user-builder (gexp->file "builder-in-linux-vm" exp))
(loader (gexp->file "linux-vm-loader"
- #~(begin
- (set! %load-path
- (cons #$module-dir %load-path))
- (set! %load-compiled-path
- (cons #$compiled
- %load-compiled-path))
- (primitive-load #$user-builder))))
+ #~(primitive-load #$user-builder)))
(coreutils -> (canonical-package coreutils))
(initrd (if initrd ; use the default initrd?
(return initrd)
@@ -155,34 +148,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 %vm-module-closure
+ #~(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)))
@@ -212,45 +205,46 @@ register INPUTS in the store database of the image so that Guix can be used in
the image."
(expression->derivation-in-linux-vm
name
- #~(begin
- (use-modules (gnu build vm)
- (guix build utils))
-
- (let ((inputs
- '#$(append (list qemu parted grub e2fsprogs)
- (map canonical-package
- (list sed grep coreutils findutils gawk))
- (if register-closures? (list guix) '())))
-
- ;; This variable is unused but allows us to add INPUTS-TO-COPY
- ;; as inputs.
- (to-register
- '#$(map (match-lambda
- ((name thing) thing)
- ((name thing output) `(,thing ,output)))
- inputs)))
-
- (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
-
- (let* ((graphs '#$(match inputs
- (((names . _) ...)
- names)))
- (initialize (root-partition-initializer
- #:closures graphs
- #:copy-closures? #$copy-inputs?
- #:register-closures? #$register-closures?
- #:system-directory #$os-derivation))
- (partitions (list (partition
- (size #$(- disk-image-size
- (* 10 (expt 2 20))))
- (label #$file-system-label)
- (file-system #$file-system-type)
- (bootable? #t)
- (initializer initialize)))))
- (initialize-hard-disk "/dev/vda"
- #:partitions partitions
- #:grub.cfg #$grub-configuration)
- (reboot))))
+ (with-imported-modules %vm-module-closure
+ #~(begin
+ (use-modules (gnu build vm)
+ (guix build utils))
+
+ (let ((inputs
+ '#$(append (list qemu parted grub e2fsprogs)
+ (map canonical-package
+ (list sed grep coreutils findutils gawk))
+ (if register-closures? (list guix) '())))
+
+ ;; This variable is unused but allows us to add INPUTS-TO-COPY
+ ;; as inputs.
+ (to-register
+ '#$(map (match-lambda
+ ((name thing) thing)
+ ((name thing output) `(,thing ,output)))
+ inputs)))
+
+ (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+
+ (let* ((graphs '#$(match inputs
+ (((names . _) ...)
+ names)))
+ (initialize (root-partition-initializer
+ #:closures graphs
+ #:copy-closures? #$copy-inputs?
+ #:register-closures? #$register-closures?
+ #:system-directory #$os-derivation))
+ (partitions (list (partition
+ (size #$(- disk-image-size
+ (* 10 (expt 2 20))))
+ (label #$file-system-label)
+ (file-system #$file-system-type)
+ (bootable? #t)
+ (initializer initialize)))))
+ (initialize-hard-disk "/dev/vda"
+ #:partitions partitions
+ #:grub.cfg #$grub-configuration)
+ (reboot)))))
#:system system
#:make-disk-image? #t
#:disk-image-size disk-image-size
generated by cgit v1.2.3 (git 2.45.0) at 2024-11-15 21:00:06 +0000