diff options
author | Ludovic Courtès <ludo@gnu.org> | 2016-07-20 11:42:02 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2016-07-20 11:42:17 +0200 |
commit | 7575655212ecfbcd1f04e429c8a7a41f8720d027 (patch) | |
tree | 558982d3cf50ef6b19ef293850de1f485fde66a6 /gnu/system | |
parent | 5d4c90ae02f1e0b42d575bba2d828d63aaf79be5 (diff) | |
parent | 5f01078129f4eaa4760a14f22761cf357afb6738 (diff) | |
download | patches-7575655212ecfbcd1f04e429c8a7a41f8720d027.tar patches-7575655212ecfbcd1f04e429c8a7a41f8720d027.tar.gz |
Merge branch 'master' into core-updates
Diffstat (limited to 'gnu/system')
-rw-r--r-- | gnu/system/install.scm | 119 | ||||
-rw-r--r-- | gnu/system/linux-container.scm | 49 | ||||
-rw-r--r-- | gnu/system/linux-initrd.scm | 172 | ||||
-rw-r--r-- | gnu/system/locale.scm | 8 | ||||
-rw-r--r-- | gnu/system/mapped-devices.scm | 34 | ||||
-rw-r--r-- | gnu/system/pam.scm | 61 | ||||
-rw-r--r-- | gnu/system/shadow.scm | 47 | ||||
-rw-r--r-- | gnu/system/vm.scm | 166 |
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 |