From 4c13ccbf392702cc94bcd677917ff2c44a9c264c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 30 Apr 2019 23:12:03 +0200 Subject: vm-image: Add 'label' field. * gnu/system/examples/vm-image.tmpl (label): New field. --- gnu/system/examples/vm-image.tmpl | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/examples/vm-image.tmpl b/gnu/system/examples/vm-image.tmpl index a140082c0b..0dbd31fe0a 100644 --- a/gnu/system/examples/vm-image.tmpl +++ b/gnu/system/examples/vm-image.tmpl @@ -4,9 +4,10 @@ ;; guix system reconfigure /etc/config.scm ;; -(use-modules (gnu) (srfi srfi-1)) +(use-modules (gnu) (guix) (srfi srfi-1)) (use-service-modules desktop networking ssh xorg) -(use-package-modules bootloaders certs fonts nvi wget xorg) +(use-package-modules bootloaders certs fonts nvi + package-management wget xorg) (define vm-image-motd (plain-file "motd" " \x1b[1;37mThis is the GNU system. Welcome!\x1b[0m @@ -34,6 +35,9 @@ accounts.\x1b[0m (locale "en_US.utf8") (keyboard-layout (keyboard-layout "us" "altgr-intl")) + ;; Label for the GRUB boot menu. + (label (string-append "GNU Guix " (package-version guix))) + (firmware '()) ;; Below we assume /dev/vda is the VM's hard disk. -- cgit 1.4.1 From 9c941364bfc0120e3ab5c5c4cc71a9a302d59a2b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 1 May 2019 21:11:22 +0200 Subject: vm: Build ISOs and VM images in a UTF-8 environment. Fixes a bug whereby building an image containing non-ASCII file names would fail due to improper decoding of file names. * gnu/system/vm.scm (iso9660-image, qemu-image): Set GUIX_LOCPATH and call 'setlocale' in the build environment. --- gnu/system/vm.scm | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 92b03b01ad..124abd0fc9 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -283,6 +283,11 @@ INPUTS is a list of inputs (as for packages)." (sql-schema #$schema) + ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded. + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (setlocale LC_ALL "en_US.utf8") + (let ((inputs '#$(append (list qemu parted e2fsprogs dosfstools xorriso) (map canonical-package @@ -379,6 +384,11 @@ the image." (sql-schema #$schema) + ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded. + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (setlocale LC_ALL "en_US.utf8") + (let ((inputs '#$(append (list qemu parted e2fsprogs dosfstools) (map canonical-package -- cgit 1.4.1 From 6c5790a2faf8ffc401e43b13425a707394e40874 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 7 May 2019 10:50:28 +0200 Subject: uuid: 'fat-uuid->string' preserves leading zeros. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by sirgazil . Previously, leading zeros would be removed, leading to an "invalid" UUID: (uuid->string (uuid "00CA-050E" 'fat32)) ⇒ "CA-50E" (string->uuid "CA-50E" 'fat32) ⇒ #f * gnu/system/uuid.scm (fat-uuid->string): Pad digits with zeros. * tests/uuid.scm ("uuid, FAT32, leading zeros preserved"): New test. --- gnu/system/uuid.scm | 4 ++-- tests/uuid.scm | 6 +++++- 2 files changed, 7 insertions(+), 3 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm index f13960c3e9..e7a3a0439d 100644 --- a/gnu/system/uuid.scm +++ b/gnu/system/uuid.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2017 Danny Milosavljevic ;;; ;;; This file is part of GNU Guix. @@ -175,7 +175,7 @@ ISO9660 UUID representation." "Convert FAT32/FAT16 UUID, a 4-byte bytevector, to its string representation." (let ((high (bytevector-uint-ref uuid 0 %fat-endianness 2)) (low (bytevector-uint-ref uuid 2 %fat-endianness 2))) - (format #f "~:@(~x-~x~)" low high))) + (format #f "~:@(~4,'0x-~4,'0x~)" low high))) (define %fat-uuid-rx (make-regexp "^([[:xdigit:]]{4})-([[:xdigit:]]{4})$")) diff --git a/tests/uuid.scm b/tests/uuid.scm index 260614f079..1c6d1e9e57 100644 --- a/tests/uuid.scm +++ b/tests/uuid.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018 Ludovic Courtès +;;; Copyright © 2015, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -57,6 +57,10 @@ "1234-ABCD" (uuid->string (uuid "1234-abcd" 'fat32))) +(test-equal "uuid, FAT32, leading zeros preserved" + "00CA-050E" ; + (uuid->string (uuid "00CA-050E" 'fat32))) + (test-assert "uuid, dynamic value" (let* ((good "4dab5feb-d176-45de-b287-9b0a6e4c01cb") (bad (string-drop good 3))) -- cgit 1.4.1 From af55ca481d9e6c1d1e06632f96d550b42f33210f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 9 May 2019 11:42:03 +0200 Subject: system: pam: Add #:login-uid? parameter to 'unix-pam-service'. * gnu/system/pam.scm (unix-pam-service): Add #:login-uid? parameter. In then 'session' field, add "pam_loginuid.so" as required when LOGIN-UID? is true. --- gnu/system/pam.scm | 69 ++++++++++++++++++++++++++++++------------------------ 1 file changed, 38 insertions(+), 31 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/pam.scm b/gnu/system/pam.scm index 13f76a50ed..85f75517b1 100644 --- a/gnu/system/pam.scm +++ b/gnu/system/pam.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -207,40 +207,47 @@ dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE." (env (pam-entry ; to honor /etc/environment. (control "required") (module "pam_env.so")))) - (lambda* (name #:key allow-empty-passwords? (allow-root? #f) motd) + (lambda* (name #:key allow-empty-passwords? (allow-root? #f) motd + login-uid?) "Return a standard Unix-style PAM service for NAME. When ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords. When ALLOW-ROOT? is true, allow root to run the command without authentication. When MOTD is -true, it should be a file-like object used as the message-of-the-day." +true, it should be a file-like object used as the message-of-the-day. +When LOGIN-UID? is true, require the 'pam_loginuid' module; that module sets +/proc/self/loginuid, which the libc 'getlogin' function relies on." ;; See . - (let ((name* name)) - (pam-service - (name name*) - (account (list unix)) - (auth (append (if allow-root? - (list (pam-entry - (control "sufficient") - (module "pam_rootok.so"))) - '()) - (list (if allow-empty-passwords? - (pam-entry - (control "required") - (module "pam_unix.so") - (arguments '("nullok"))) - unix)))) - (password (list (pam-entry - (control "required") - (module "pam_unix.so") - ;; Store SHA-512 encrypted passwords in /etc/shadow. - (arguments '("sha512" "shadow"))))) - (session (if motd - (list env unix - (pam-entry - (control "optional") - (module "pam_motd.so") - (arguments - (list #~(string-append "motd=" #$motd))))) - (list env unix)))))))) + (pam-service + (name name) + (account (list unix)) + (auth (append (if allow-root? + (list (pam-entry + (control "sufficient") + (module "pam_rootok.so"))) + '()) + (list (if allow-empty-passwords? + (pam-entry + (control "required") + (module "pam_unix.so") + (arguments '("nullok"))) + unix)))) + (password (list (pam-entry + (control "required") + (module "pam_unix.so") + ;; Store SHA-512 encrypted passwords in /etc/shadow. + (arguments '("sha512" "shadow"))))) + (session `(,@(if motd + (list (pam-entry + (control "optional") + (module "pam_motd.so") + (arguments + (list #~(string-append "motd=" #$motd))))) + '()) + ,@(if login-uid? + (list (pam-entry ;to fill in /proc/self/loginuid + (control "required") + (module "pam_loginuid.so"))) + '()) + ,env ,unix)))))) (define (rootok-pam-service command) "Return a PAM service for COMMAND such that 'root' does not need to -- cgit 1.4.1 From 76ae10a1f483a23ac2f88264d49011eb06c9da27 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 10 May 2019 18:11:25 +0200 Subject: linux-container: Improve filtering of unnecessary file systems. * gnu/system/linux-container.scm (containerized-operating-system)[user-file-systems]: Add trailing slash for the "/dev/" and "/sys/" prefixes. --- gnu/system/linux-container.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index 149c3d08a3..ded5f279fe 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -65,8 +65,8 @@ containerized OS." (string=? target "/") (and (string? source) (string-prefix? "/dev/" source)) - (string-prefix? "/dev" target) - (string-prefix? "/sys" target)))) + (string-prefix? "/dev/" target) + (string-prefix? "/sys/" target)))) (operating-system-file-systems os))) (define (mapping->fs fs) -- cgit 1.4.1 From 7059cfc8236b1e59ae3c1aae12d65c700e9bfd18 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 13 May 2019 10:50:27 +0200 Subject: install: Add node name in Russian. * gnu/system/install.scm (%installation-node-names): Add "ru". --- gnu/system/install.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/install.scm b/gnu/system/install.scm index 45c6051732..453b0bdd6d 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -85,7 +85,8 @@ '(("de" . "Systeminstallation") ("en" . "System Installation") ("es" . "Instalación del sistema") - ("fr" . "Installation du système"))) + ("fr" . "Installation du système") + ("ru" . "Установка системы"))) (define (log-to-info tty user) "Return a script that spawns the Info reader on the right section of the -- cgit 1.4.1 From b33454ae0b488e79faafef75a06090be6b2ac6a2 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Fri, 10 May 2019 16:56:16 +0530 Subject: linux-container: Support container network sharing. * gnu/system/linux-container.scm (container-essential-services): If network is to be shared with the host, remove network configuration files from etc service. (containerized-operating-system): If network is to be shared with the host, remove nscd service and map host's /var/run/nscd if it exists. (container-script): If network is to be shared with the host, do not create network namespace. * guix/scripts/system.scm (system-derivation-for-action): Add #:container-shared-network? argument. (perform-action): Add #:container-shared-network? argument. (show-help): Add "-N, --network" help information. (%options): Add network option. (process-action): Call perform-action with #container-shared-network? argument. * doc/guix.texi (Invoking guix system): Document the "-N, --network" option. Co-authored-by: Christopher Baines --- doc/guix.texi | 5 ++++ gnu/system/linux-container.scm | 63 ++++++++++++++++++++++++++++++++++-------- guix/scripts/system.scm | 20 ++++++++++++-- 3 files changed, 75 insertions(+), 13 deletions(-) (limited to 'gnu/system') diff --git a/doc/guix.texi b/doc/guix.texi index 843e909fb2..27e0f72ccb 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -24587,6 +24587,11 @@ When this option is omitted, @command{guix system} computes an estimate of the image size as a function of the size of the system declared in @var{file}. +@item --network +@itemx -N +For the @code{container} action, allow containers to access the host network, +that is, do not create a network namespace. + @item --root=@var{file} @itemx -r @var{file} Make @var{file} a symlink to the result, and register it as a garbage diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index ded5f279fe..ce786e39b2 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson ;;; Copyright © 2016, 2017, 2019 Ludovic Courtès +;;; Copyright © 2019 Arun Isaac ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,7 +36,7 @@ containerized-operating-system container-script)) -(define (container-essential-services os) +(define* (container-essential-services os #:key shared-network?) "Return a list of essential services corresponding to OS, a non-containerized OS. This procedure essentially strips essential services from OS that are needed on the bare metal and not in a container." @@ -51,9 +52,20 @@ from OS that are needed on the bare metal and not in a container." (let ((locale (operating-system-locale-directory os))) (with-monad %store-monad (return `(("locale" ,locale)))))) - base)) + ;; If network is to be shared with the host, remove network + ;; configuration files from etc-service. + (if shared-network? + (modify-services base + (etc-service-type + files => (remove + (match-lambda + ((filename _) + (member filename + (map basename %network-configuration-files)))) + files))) + base))) -(define (containerized-operating-system os mappings) +(define* (containerized-operating-system os mappings #:key shared-network?) "Return an operating system based on OS for use in a Linux container environment. MAPPINGS is a list of to realize in the containerized OS." @@ -76,27 +88,53 @@ containerized OS." (define useless-services ;; Services that make no sense in a container. Those that attempt to ;; access /dev/tty[0-9] in particular cannot work in a container. - (list console-font-service-type - mingetty-service-type - agetty-service-type)) + (append (list console-font-service-type + mingetty-service-type + agetty-service-type) + ;; Remove nscd service if network is shared with the host. + (if shared-network? + (list nscd-service-type) + (list)))) + + (define shared-network-file-mappings + ;; Files to map if network is to be shared with the host + (append %network-file-mappings + (let ((nscd-run-directory "/var/run/nscd")) + (if (file-exists? nscd-run-directory) + (list (file-system-mapping + (source nscd-run-directory) + (target nscd-run-directory))) + (list))))) + + ;; (write shared-network-file-mappings) + ;; (newline) (operating-system (inherit os) (swap-devices '()) ; disable swap - (essential-services (container-essential-services os)) + (essential-services (container-essential-services + os #:shared-network? shared-network?)) (services (remove (lambda (service) (memq (service-kind service) useless-services)) (operating-system-user-services os))) - (file-systems (append (map mapping->fs (cons %store-mapping mappings)) + (file-systems (append (map mapping->fs + (cons %store-mapping + (append mappings + (if shared-network? + shared-network-file-mappings + (list))))) %container-file-systems user-file-systems)))) -(define* (container-script os #:key (mappings '())) +(define* (container-script os #:key (mappings '()) shared-network?) "Return a derivation of a script that runs OS as a Linux container. MAPPINGS is a list of objects that specify the files/directories that will be shared with the host system." - (let* ((os (containerized-operating-system os mappings)) + (let* ((os (containerized-operating-system + os + mappings + #:shared-network? shared-network?)) (file-systems (filter file-system-needed-for-boot? (operating-system-file-systems os))) (specs (map file-system->spec file-systems))) @@ -121,6 +159,9 @@ that will be shared with the host system." ;; 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)))) + #:host-uids 65536 + #:namespaces (if #$shared-network? + (delq 'net %namespaces) + %namespaces))))) (gexp->script "run-container" script))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 3c3d6cbd5f..cf4418f981 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2016, 2017, 2018 Chris Marusich ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2019 Christopher Baines ;;; ;;; This file is part of GNU Guix. ;;; @@ -756,13 +757,17 @@ checking this by themselves in their 'check' procedure." (define* (system-derivation-for-action os action #:key image-size file-system-type - full-boot? mappings) + full-boot? container-shared-network? + mappings) "Return as a monadic value the derivation for OS according to ACTION." (case action ((build init reconfigure) (operating-system-derivation os)) ((container) - (container-script os #:mappings mappings)) + (container-script + os + #:mappings mappings + #:shared-network? container-shared-network?)) ((vm-image) (system-qemu-image os #:disk-image-size image-size)) ((vm) @@ -826,6 +831,7 @@ and TARGET arguments." dry-run? derivations-only? use-substitutes? bootloader-target target image-size file-system-type full-boot? + container-shared-network? (mappings '()) (gc-root #f)) "Perform ACTION for OS. INSTALL-BOOTLOADER? specifies whether to install @@ -834,6 +840,8 @@ target root directory; IMAGE-SIZE is the size of the image to be built, for the 'vm-image' and 'disk-image' actions. The root file system is created as a FILE-SYSTEM-TYPE file system. FULL-BOOT? is used for the 'vm' action; it determines whether to boot directly to the kernel or to the bootloader. +CONTAINER-SHARED-NETWORK? determines if the container will use a separate +network namespace. When DERIVATIONS-ONLY? is true, print the derivation file name(s) without building anything. @@ -883,6 +891,7 @@ static checks." #:file-system-type file-system-type #:image-size image-size #:full-boot? full-boot? + #:container-shared-network? container-shared-network? #:mappings mappings)) ;; For 'init' and 'reconfigure', always build BOOTCFG, even if @@ -1020,6 +1029,8 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ " --share=SPEC for 'vm', share host file system according to SPEC")) (display (G_ " + -N, --network for 'container', allow containers to access the network")) + (display (G_ " -r, --root=FILE for 'vm', 'vm-image', 'disk-image', 'container', and 'build', make FILE a symlink to the result, and register it as a garbage collector root")) @@ -1066,6 +1077,9 @@ Some ACTIONS support additional ARGS.\n")) (lambda (opt name arg result) (alist-cons 'image-size (size->number arg) result))) + (option '(#\N "network") #f #f + (lambda (opt name arg result) + (alist-cons 'container-shared-network? #t result))) (option '("no-bootloader" "no-grub") #f #f (lambda (opt name arg result) (alist-cons 'install-bootloader? #f result))) @@ -1182,6 +1196,8 @@ resulting from command-line parsing." #:file-system-type (assoc-ref opts 'file-system-type) #:image-size (assoc-ref opts 'image-size) #:full-boot? (assoc-ref opts 'full-boot?) + #:container-shared-network? + (assoc-ref opts 'container-shared-network?) #:mappings (filter-map (match-lambda (('file-system-mapping . m) m) -- cgit 1.4.1 From 1be065c4784805e7a7b4c3f08970d8e4043b0a60 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 13 May 2019 23:28:32 +0200 Subject: locale: Add 'glibc-supported-locales'. * gnu/system/locale.scm (glibc-supported-locales): New procedure. --- gnu/system/locale.scm | 72 +++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 70 insertions(+), 2 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/locale.scm b/gnu/system/locale.scm index 75417f6698..533a45e149 100644 --- a/gnu/system/locale.scm +++ b/gnu/system/locale.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès ;;; Copyright © 2018 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -20,6 +20,7 @@ (define-module (gnu system locale) #:use-module (guix gexp) #:use-module (guix store) + #:use-module (guix modules) #:use-module (guix records) #:use-module (guix packages) #:use-module (guix utils) @@ -37,7 +38,9 @@ locale-directory %default-locale-libcs - %default-locale-definitions)) + %default-locale-definitions + + glibc-supported-locales)) ;;; Commentary: ;;; @@ -202,4 +205,69 @@ data format changes between libc versions." "vi_VN" "zh_CN")))) + +;;; +;;; Locales supported by glibc. +;;; + +(define* (glibc-supported-locales #:optional (glibc glibc)) + "Return a file-like object that contains a list of locale name/encoding +pairs such as (\"oc_FR.UTF-8\" . \"UTF-8\"). Each pair corresponds to a +locale supported by GLIBC." + (define build + (with-imported-modules (source-module-closure + '((guix build gnu-build-system))) + #~(begin + (use-modules (guix build gnu-build-system) + (srfi srfi-1) + (ice-9 rdelim) + (ice-9 match) + (ice-9 regex) + (ice-9 pretty-print)) + + (define unpack + (assq-ref %standard-phases 'unpack)) + + (define locale-rx + ;; Regexp matching a locale line in 'localedata/SUPPORTED'. + (make-regexp + "^[[:space:]]*([[:graph:]]+)/([[:graph:]]+)[[:space:]]*\\\\$")) + + (define (read-supported-locales port) + ;; Read the 'localedata/SUPPORTED' file from PORT. That file is + ;; actually a makefile snippet, with one locale per line, and a + ;; header that can be discarded. + (let loop ((locales '())) + (define line + (read-line port)) + + (cond ((eof-object? line) + (reverse locales)) + ((string-prefix? "#" (string-trim line)) ;comment + (loop locales)) + ((string-contains line "=") ;makefile variable assignment + (loop locales)) + (else + (match (regexp-exec locale-rx line) + (#f + (loop locales)) + (m + (loop (alist-cons (match:substring m 1) + (match:substring m 2) + locales)))))))) + + (setenv "PATH" + (string-append #+(file-append tar "/bin") ":" + #+(file-append xz "/bin") ":" + #+(file-append gzip "/bin"))) + (unpack #:source #+(package-source glibc)) + + (let ((locales (call-with-input-file "localedata/SUPPORTED" + read-supported-locales))) + (call-with-output-file #$output + (lambda (port) + (pretty-print locales port))))))) + + (computed-file "glibc-supported-locales.scm" build)) + ;;; locale.scm ends here -- cgit 1.4.1 From d03de6be0aa2e2889314b5ed9a8867375363d79f Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Tue, 16 Apr 2019 17:15:02 -0400 Subject: vm: Auto-detect if inputs should be registered. The default value of the argument REGISTER-CLOSURE? of the ISO9660-IMAGE, QEMU-IMAGE and SYSTEM-DOCKER-IMAGE procedures can be computed automatically, since the operating-system definition is available in its context. When the operating-system definition does not contain the GUIX-SERVICE-TYPE, do not register the closure in the database of Guix, as it takes time and doesn't serve a purpose. * gnu/system/vm.scm (has-guix-service-type): Add predicate. (iso9660-image)[register-closures?]: Use it to compute the argument's default value. (qemu-image)[register-closures?]: Likewise, and update docstring. (system-docker-image)[register-closures?]: Likewise. (system-disk-image): Do not explicit a value for the REGISTER-CLOSURES? argument of the ISO9660-IMAGE and QEMU-IMAGE procedure calls, so that its default value is used instead. * guix/scripts/system.scm (system-derivation-for-action): Do not explicit a value for the REGISTER-CLOSURES? argument of the SYSTEM-DOCKER-IMAGE procedure call, so that its default value is used instead. --- gnu/system/vm.scm | 30 ++++++++++++++++++------------ guix/scripts/system.scm | 2 +- 2 files changed, 19 insertions(+), 13 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 124abd0fc9..2eeb700793 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -64,6 +64,7 @@ #:use-module (gnu system file-systems) #:use-module (gnu system) #:use-module (gnu services) + #:use-module (gnu services base) #:use-module (gnu system uuid) #:use-module (srfi srfi-1) @@ -249,6 +250,12 @@ made available under the /xchg CIFS share." #:guile-for-build guile-for-build #:references-graphs references-graphs))) +(define (has-guix-service-type? os) + "Return true if OS contains a service of the type GUIX-SERVICE-TYPE." + (not (not (find (lambda (service) + (eq? (service-kind service) guix-service-type)) + (operating-system-services os))))) + (define* (iso9660-image #:key (name "iso9660-image") file-system-label @@ -258,7 +265,7 @@ made available under the /xchg CIFS share." os bootcfg-drv bootloader - register-closures? + (register-closures? (has-guix-service-type? os)) (inputs '())) "Return a bootable, stand-alone iso9660 image. @@ -343,7 +350,7 @@ INPUTS is a list of inputs (as for packages)." os bootcfg-drv bootloader - (register-closures? #t) + (register-closures? (has-guix-service-type? os)) (inputs '()) copy-inputs?) "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g., @@ -359,7 +366,9 @@ file (GRUB-CONFIGURATION must be the name of a file in the VM.) INPUTS is a list of inputs (as for packages). When COPY-INPUTS? is true, copy all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, register INPUTS in the store database of the image so that Guix can be used in -the image." +the image. By default, REGISTER-CLOSURES? is set to true only if a service of +type GUIX-SERVICE-TYPE is present in the services definition of the operating +system." (define schema (and register-closures? (local-file (search-path %load-path @@ -474,14 +483,13 @@ the image." (define* (system-docker-image os #:key (name "guixsd-docker-image") - register-closures?) + (register-closures? (has-guix-service-type? os))) "Build a docker image. OS is the desired . NAME is the -base name to use for the output file. When REGISTER-CLOSURES? is not #f, -register the closure of OS with Guix in the resulting Docker image. This only -makes sense when you want to build a Guix System Docker image that has Guix -installed inside of it. If you don't need Guix (e.g., your Docker -image just contains a web server that is started by the Shepherd), then you -should set REGISTER-CLOSURES? to #f." +base name to use for the output file. When REGISTER-CLOSURES? is true, +register the closure of OS with Guix in the resulting Docker image. By +default, REGISTER-CLOSURES? is set to true only if a service of type +GUIX-SERVICE-TYPE is present in the services definition of the operating +system." (define schema (and register-closures? (local-file (search-path %load-path @@ -678,7 +686,6 @@ to USB sticks meant to be read-only." #:file-system-label root-label #:file-system-uuid uuid #:os os - #:register-closures? #t #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)) @@ -695,7 +702,6 @@ to USB sticks meant to be read-only." #:file-system-label root-label #:file-system-uuid uuid #:copy-inputs? #t - #:register-closures? #t #:inputs `(("system" ,os) ("bootcfg" ,bootcfg)))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index cf4418f981..8434d1ecaa 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -786,7 +786,7 @@ checking this by themselves in their 'check' procedure." #:disk-image-size image-size #:file-system-type file-system-type)) ((docker-image) - (system-docker-image os #:register-closures? #t)))) + (system-docker-image os)))) (define (maybe-suggest-running-guix-pull) "Suggest running 'guix pull' if this has never been done before." -- cgit 1.4.1 From 6edd5c546c7c1bb5ee45436a0441a9daf1e5509c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 10 May 2019 18:16:45 +0200 Subject: linux-container: Do not add %CONTAINER-FILE-SYSTEMS to Docker image OSes. Previously, 'guix system docker-image' would end up providing an OS that would try to mount all of %CONTAINER-FILE-SYSTEMS as well as /gnu/store, which is bound to fail in unprivileged Docker. This patch makes it so that 'guix system container' still gets those file systems, but 'guix system docker-image' doesn't. * gnu/system/linux-container.scm (containerized-operating-system): Add #:extra-file-systems parameter and honor it. Do not include %STORE-MAPPING and SHARED-NETWORK-FILE-MAPPINGS. (container-script): Add %STORE-MAPPING and optionally NETWORK-MAPPINGS to MAPPINGS and pass #:extra-file-systems. --- gnu/system/linux-container.scm | 47 +++++++++++++++++++++--------------------- 1 file changed, 23 insertions(+), 24 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index ce786e39b2..0cfd7efd99 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -65,10 +65,13 @@ from OS that are needed on the bare metal and not in a container." files))) base))) -(define* (containerized-operating-system os mappings #:key shared-network?) +(define* (containerized-operating-system os mappings + #:key + shared-network? + (extra-file-systems '())) "Return an operating system based on OS for use in a Linux container environment. MAPPINGS is a list of to realize in the -containerized OS." +containerized OS. EXTRA-FILE-SYSTEMS is a list of file systems to add to OS." (define user-file-systems (remove (lambda (fs) (let ((target (file-system-mount-point fs)) @@ -96,19 +99,6 @@ containerized OS." (list nscd-service-type) (list)))) - (define shared-network-file-mappings - ;; Files to map if network is to be shared with the host - (append %network-file-mappings - (let ((nscd-run-directory "/var/run/nscd")) - (if (file-exists? nscd-run-directory) - (list (file-system-mapping - (source nscd-run-directory) - (target nscd-run-directory))) - (list))))) - - ;; (write shared-network-file-mappings) - ;; (newline) - (operating-system (inherit os) (swap-devices '()) ; disable swap @@ -118,23 +108,32 @@ containerized OS." (memq (service-kind service) useless-services)) (operating-system-user-services os))) - (file-systems (append (map mapping->fs - (cons %store-mapping - (append mappings - (if shared-network? - shared-network-file-mappings - (list))))) - %container-file-systems + (file-systems (append (map mapping->fs mappings) + extra-file-systems user-file-systems)))) (define* (container-script os #:key (mappings '()) shared-network?) "Return a derivation of a script that runs OS as a Linux container. MAPPINGS is a list of objects that specify the files/directories that will be shared with the host system." + (define network-mappings + ;; Files to map if network is to be shared with the host + (append %network-file-mappings + (let ((nscd-run-directory "/var/run/nscd")) + (if (file-exists? nscd-run-directory) + (list (file-system-mapping + (source nscd-run-directory) + (target nscd-run-directory))) + '())))) + (let* ((os (containerized-operating-system os - mappings - #:shared-network? shared-network?)) + (cons %store-mapping + (if shared-network? + (append network-mappings mappings) + mappings)) + #:shared-network? shared-network? + #:extra-file-systems %container-file-systems)) (file-systems (filter file-system-needed-for-boot? (operating-system-file-systems os))) (specs (map file-system->spec file-systems))) -- cgit 1.4.1 From 3f9bed04f031a4d4f8d3b6dc0a4de42b0c628496 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 10 May 2019 22:07:55 +0200 Subject: linux-container: Compute essential services for THIS-OPERATING-SYSTEM. Previously, the 'essential-services' would correspond to the initial, non-containerized OS. Thus, all the file systems removed in 'container-essential-services' would actually still be there because the essential services would be computed on the non-containerized OS. This is a followup to 69cae3d3356a69b7fe69481338f760545995485e. * gnu/system/linux-container.scm (container-essential-services): Call 'operating-system-default-essential-services' to get the baseline services. (containerized-operating-system): Pass THIS-OPERATING-SYSTEM, not OS, to 'container-essential-services'. Add a dummy root file system to 'file-systems'. (container-script)[mountable-file-system?]: New procedure. Use it. --- gnu/system/linux-container.scm | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index 0cfd7efd99..16eee7a3cd 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -46,7 +46,7 @@ from OS that are needed on the bare metal and not in a container." (list (service-kind %linux-bare-metal-service) firmware-service-type system-service-type))) - (operating-system-essential-services os))) + (operating-system-default-essential-services os))) (cons (service system-service-type (let ((locale (operating-system-locale-directory os))) @@ -103,14 +103,22 @@ containerized OS. EXTRA-FILE-SYSTEMS is a list of file systems to add to OS." (inherit os) (swap-devices '()) ; disable swap (essential-services (container-essential-services - os #:shared-network? shared-network?)) + this-operating-system + #:shared-network? shared-network?)) (services (remove (lambda (service) (memq (service-kind service) useless-services)) (operating-system-user-services os))) (file-systems (append (map mapping->fs mappings) extra-file-systems - user-file-systems)))) + user-file-systems + + ;; Provide a dummy root file system so we can create + ;; a 'boot-parameters' file. + (list (file-system + (mount-point "/") + (device "nothing") + (type "dummy"))))))) (define* (container-script os #:key (mappings '()) shared-network?) "Return a derivation of a script that runs OS as a Linux container. @@ -126,6 +134,11 @@ that will be shared with the host system." (target nscd-run-directory))) '())))) + (define (mountable-file-system? file-system) + ;; Return #t if FILE-SYSTEM should be mounted in the container. + (and (not (string=? "/" (file-system-mount-point file-system))) + (file-system-needed-for-boot? file-system))) + (let* ((os (containerized-operating-system os (cons %store-mapping @@ -134,7 +147,7 @@ that will be shared with the host system." mappings)) #:shared-network? shared-network? #:extra-file-systems %container-file-systems)) - (file-systems (filter file-system-needed-for-boot? + (file-systems (filter mountable-file-system? (operating-system-file-systems os))) (specs (map file-system->spec file-systems))) -- cgit 1.4.1 From 247649d42e60b718f3f46b2bcf72d19bf799d503 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 12 May 2019 12:21:48 +0200 Subject: vm: 'system-docker-image' provides an entry point. This simplifies use of images created with 'guix system docker-image'. * gnu/system/vm.scm (system-docker-image)[boot-program]: New variable. [os]: Add it to the GC roots. [build]: Pass #:entry-point to 'build-docker-image'. * gnu/tests/docker.scm (run-docker-system-test): New procedure. (%test-docker-system): New variable. * doc/guix.texi (Invoking guix system): Remove GUIX_NEW_SYSTEM hack and '--entrypoint' from the example. Mention 'docker create', 'docker start', and 'docker exec'. --- doc/guix.texi | 18 +++++--- gnu/system/vm.scm | 18 +++++++- gnu/tests/docker.scm | 118 ++++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 145 insertions(+), 9 deletions(-) (limited to 'gnu/system') diff --git a/doc/guix.texi b/doc/guix.texi index 41ea3c314d..ae9ad0739e 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -24500,20 +24500,26 @@ system configuration file. You can then load the image and launch a Docker container using commands like the following: @example -image_id="$(docker load < guix-system-docker-image.tar.gz)" -docker run -e GUIX_NEW_SYSTEM=/var/guix/profiles/system \\ - --entrypoint /var/guix/profiles/system/profile/bin/guile \\ - $image_id /var/guix/profiles/system/boot +image_id="`docker load < guix-system-docker-image.tar.gz`" +container_id="`docker create $image_id`" +docker start $container_id @end example This command starts a new Docker container from the specified image. It will boot the Guix system in the usual manner, which means it will start any services you have defined in the operating system -configuration. Depending on what you run in the Docker container, it +configuration. You can get an interactive shell running in the container +using @command{docker exec}: + +@example +docker exec -ti $container_id /run/current-system/profile/bin/bash --login +@end example + +Depending on what you run in the Docker container, it may be necessary to give the container additional permissions. For example, if you intend to build software using Guix inside of the Docker container, you may need to pass the @option{--privileged} option to -@code{docker run}. +@code{docker create}. @item container Return a script to run the operating system declared in @var{file} diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 2eeb700793..aa37896498 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -482,7 +482,7 @@ system." (define* (system-docker-image os #:key - (name "guixsd-docker-image") + (name "guix-docker-image") (register-closures? (has-guix-service-type? os))) "Build a docker image. OS is the desired . NAME is the base name to use for the output file. When REGISTER-CLOSURES? is true, @@ -495,7 +495,19 @@ system." (local-file (search-path %load-path "guix/store/schema.sql")))) - (let ((os (containerized-operating-system os '())) + (define boot-program + ;; Program that runs the boot script of OS, which in turn starts shepherd. + (program-file "boot-program" + #~(let ((system (cadr (command-line)))) + (setenv "GUIX_NEW_SYSTEM" system) + (execl #$(file-append guile-2.2 "/bin/guile") + "guile" "--no-auto-compile" + (string-append system "/boot"))))) + + + (let ((os (operating-system-with-gc-roots + (containerized-operating-system os '()) + (list boot-program))) (name (string-append name ".tar.gz")) (graph "system-graph")) (define build @@ -546,9 +558,11 @@ system." (string-append "/xchg/" #$graph) read-reference-graph))) #$os + #:entry-point '(#$boot-program #$os) #:compressor '(#+(file-append gzip "/bin/gzip") "-9n") #:creation-time (make-time time-utc 0 1) #:transformations `((,root-directory -> "")))))))) + (expression->derivation-in-linux-vm name build #:make-disk-image? #f diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm index 25e172efae..3cd3a27884 100644 --- a/gnu/tests/docker.scm +++ b/gnu/tests/docker.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Danny Milosavljevic +;;; Copyright © 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,6 +29,7 @@ #:use-module (gnu services desktop) #:use-module (gnu packages bootstrap) ; %bootstrap-guile #:use-module (gnu packages docker) + #:use-module (gnu packages guile) #:use-module (guix gexp) #:use-module (guix grafts) #:use-module (guix monads) @@ -38,7 +40,8 @@ #:use-module (guix tests) #:use-module (guix build-system trivial) #:use-module ((guix licenses) #:prefix license:) - #:export (%test-docker)) + #:export (%test-docker + %test-docker-system)) (define %docker-os (simple-operating-system @@ -166,3 +169,116 @@ standard output device and then enters a new line.") (name "docker") (description "Test Docker container of Guix.") (value (build-tarball&run-docker-test)))) + + +(define (run-docker-system-test tarball) + "Load DOCKER-TARBALL as Docker image and run it in a Docker container, +inside %DOCKER-OS." + (define os + (marionette-operating-system + %docker-os + #:imported-modules '((gnu services herd) + (guix combinators)))) + + (define vm + (virtual-machine + (operating-system os) + ;; FIXME: Because we're using the volatile-root setup where the root file + ;; system is a tmpfs overlaid over a small root file system, 'docker + ;; load' must be able to store the whole image into memory, hence the + ;; huge memory requirements. We should avoid the volatile-root setup + ;; instead. + (memory-size 3000) + (port-forwardings '()))) + + (define test + (with-imported-modules '((gnu build marionette) + (guix build utils)) + #~(begin + (use-modules (srfi srfi-11) (srfi srfi-64) + (gnu build marionette) + (guix build utils)) + + (define marionette + (make-marionette (list #$vm))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "docker") + + (test-assert "service running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (match (start-service 'dockerd) + (#f #f) + (('service response-parts ...) + (match (assq-ref response-parts 'running) + ((pid) (number? pid)))))) + marionette)) + + (test-assert "load system image and run it" + (marionette-eval + `(begin + (define (slurp command . args) + ;; Return the output from COMMAND. + (let* ((port (apply open-pipe* OPEN_READ command args)) + (output (read-line port)) + (status (close-pipe port))) + output)) + + (define (docker-cli command . args) + ;; Run the given Docker COMMAND. + (apply invoke #$(file-append docker-cli "/bin/docker") + command args)) + + (define (wait-for-container-file container file) + ;; Wait for FILE to show up in CONTAINER. + (docker-cli "exec" container + #$(file-append guile-2.2 "/bin/guile") + "-c" + (object->string + `(let loop ((n 15)) + (when (zero? n) + (error "file didn't show up" ,file)) + (unless (file-exists? ,file) + (sleep 1) + (loop (- n 1))))))) + + (let* ((line (slurp #$(file-append docker-cli "/bin/docker") + "load" "-i" #$tarball)) + (repository&tag (string-drop line + (string-length + "Loaded image: "))) + (container (slurp + #$(file-append docker-cli "/bin/docker") + "create" repository&tag))) + (docker-cli "start" container) + + ;; Wait for shepherd to be ready. + (wait-for-container-file container + "/var/run/shepherd/socket") + + (docker-cli "exec" container + "/run/current-system/profile/bin/herd" + "status") + (slurp #$(file-append docker-cli "/bin/docker") + "exec" container + "/run/current-system/profile/bin/herd" + "status" "guix-daemon"))) + marionette)) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "docker-system-test" test)) + +(define %test-docker-system + (system-test + (name "docker-system") + (description "Run a system image as produced by @command{guix system +docker-image} inside Docker.") + (value (with-monad %store-monad + (>>= (system-docker-image (simple-operating-system)) + run-docker-system-test))))) -- cgit 1.4.1 From fc0680929ded80a5ccdc0131613cb0679b54145d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 16 May 2019 14:37:23 +0200 Subject: vm-image: Remove 'network-manager-applet' from system profile. This is a followup to 05d907ac6fc6e139389a91ab5540c0dc573a8ce7. * gnu/system/examples/vm-image.tmpl (services): Remove 'network-manager-applet'. --- gnu/system/examples/vm-image.tmpl | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/examples/vm-image.tmpl b/gnu/system/examples/vm-image.tmpl index 0dbd31fe0a..1ba47a166a 100644 --- a/gnu/system/examples/vm-image.tmpl +++ b/gnu/system/examples/vm-image.tmpl @@ -96,10 +96,13 @@ root ALL=(ALL) ALL ;; sense in a VM. (remove (lambda (service) (let ((type (service-kind service))) - (memq type (list gdm-service-type - wpa-supplicant-service-type - cups-pk-helper-service-type - network-manager-service-type)))) + (or (memq type + (list gdm-service-type + wpa-supplicant-service-type + cups-pk-helper-service-type + network-manager-service-type)) + (eq? 'network-manager-applet + (service-type-name type))))) (modify-services %desktop-services (login-service-type config => (login-configuration -- cgit 1.4.1 From 9c64080dce9fa3e77c48ae962ff1edc5d0863c6a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 16 May 2019 14:42:40 +0200 Subject: vm-image: Remove ModemManager. This is a followup to 36f5d78d4af02ad23c33bfb46702d92086bf2796. * gnu/system/examples/vm-image.tmpl (services): Remove MODEM-MANAGER-SERVICE-TYPE. --- gnu/system/examples/vm-image.tmpl | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/examples/vm-image.tmpl b/gnu/system/examples/vm-image.tmpl index 1ba47a166a..7d984155bc 100644 --- a/gnu/system/examples/vm-image.tmpl +++ b/gnu/system/examples/vm-image.tmpl @@ -92,15 +92,16 @@ root ALL=(ALL) ALL ;; Use the DHCP client service rather than NetworkManager. (service dhcp-client-service-type)) - ;; Remove GDM, NetworkManager, and wpa-supplicant, which don't make - ;; sense in a VM. + ;; Remove GDM, ModemManager, NetworkManager, and wpa-supplicant, + ;; which don't make sense in a VM. (remove (lambda (service) (let ((type (service-kind service))) (or (memq type (list gdm-service-type wpa-supplicant-service-type cups-pk-helper-service-type - network-manager-service-type)) + network-manager-service-type + modem-manager-service-type)) (eq? 'network-manager-applet (service-type-name type))))) (modify-services %desktop-services -- cgit 1.4.1 From 1d86b05618a063378d7ffc89a9b4c33dd65a760c Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Sat, 18 May 2019 17:49:05 +0200 Subject: vm: Create installation media with MBR and HFS only, no GPT. * gnu/build/vm.scm (make-iso9660-image): Accept XORRISO, GRUB-MKRESCUE-ENVIRONMENT. * gnu/system/vm.scm (iso9660-image): Pass XORRISO; accept GRUB-MKRESCUE-ENVIRONMENT. (system-disk-image): Pass GRUB-MKRESCUE-ENVIRONMENT. * gnu/packages/patches/xorriso-no-mbr-in-inner-efi.patch: New file. * gnu/packages/patches/xorriso-no-partition-table-in-inner-efi.patch: New file. * gnu/local.mk (dist_patch_DATA): Add them. * gnu/packages/cdrom.scm (xorriso)[source]: Add patches. [arguments]<#:phases>[install-frontends]: Add phase. --- gnu/build/vm.scm | 18 +++- gnu/local.mk | 4 +- gnu/packages/cdrom.scm | 14 ++- .../patches/xorriso-no-mbr-in-inner-efi.patch | 47 +++++++++ .../xorriso-no-partition-table-in-inner-efi.patch | 107 +++++++++++++++++++++ gnu/system/vm.scm | 11 ++- 6 files changed, 194 insertions(+), 7 deletions(-) create mode 100644 gnu/packages/patches/xorriso-no-mbr-in-inner-efi.patch create mode 100644 gnu/packages/patches/xorriso-no-partition-table-in-inner-efi.patch (limited to 'gnu/system') diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index ac99d6b1a3..a5d9fefa62 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -423,7 +423,8 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." ;; Graft the configuration file onto the image. (string-append "boot/grub/grub.cfg=" config-file)))) -(define* (make-iso9660-image grub config-file os-drv target +(define* (make-iso9660-image xorriso grub-mkrescue-environment + grub config-file os-drv target #:key (volume-id "Guix_image") (volume-uuid #f) register-closures? (closures '())) "Given a GRUB package, creates an iso image as TARGET, using CONFIG-FILE as @@ -431,6 +432,9 @@ GRUB configuration and OS-DRV as the stuff in it." (define grub-mkrescue (string-append grub "/bin/grub-mkrescue")) + (define grub-mkrescue-sed.sh + (string-append xorriso "/bin/grub-mkrescue-sed.sh")) + (define target-store (string-append "/tmp/root" (%store-directory))) @@ -483,9 +487,19 @@ GRUB configuration and OS-DRV as the stuff in it." #x77777777) 16)) + (setenv "MKRESCUE_SED_MODE" "original") + (setenv "MKRESCUE_SED_XORRISO" (string-append xorriso + "/bin/xorriso")) + (setenv "MKRESCUE_SED_IN_EFI_NO_PT" "yes") + (for-each (match-lambda + ((name . value) (setenv name value))) + grub-mkrescue-environment) + (let ((pipe (apply open-pipe* OPEN_WRITE - grub-mkrescue "-o" target + grub-mkrescue + (string-append "--xorriso=" grub-mkrescue-sed.sh) + "-o" target (string-append "boot/grub/grub.cfg=" config-file) "etc=/tmp/root/etc" "var=/tmp/root/var" diff --git a/gnu/local.mk b/gnu/local.mk index ac55e1dd28..694bbfd367 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -1372,7 +1372,9 @@ dist_patch_DATA = \ %D%/packages/patches/xfce4-session-fix-xflock4.patch \ %D%/packages/patches/xfce4-settings-defaults.patch \ %D%/packages/patches/xinetd-fix-fd-leak.patch \ - %D%/packages/patches/xinetd-CVE-2013-4342.patch + %D%/packages/patches/xinetd-CVE-2013-4342.patch \ + %D%/packages/patches/xorriso-no-partition-table-in-inner-efi.patch \ + %D%/packages/patches/xorriso-no-mbr-in-inner-efi.patch MISC_DISTRO_FILES = \ %D%/packages/ld-wrapper.in diff --git a/gnu/packages/cdrom.scm b/gnu/packages/cdrom.scm index 2bd5745ad3..8d9778176f 100644 --- a/gnu/packages/cdrom.scm +++ b/gnu/packages/cdrom.scm @@ -162,8 +162,20 @@ libcdio.") version ".tar.gz")) (sha256 (base32 - "0aq6lvlwlkxz56l5sbvgycr6j5c82ch2bv6zrnc2345ibfpafgx9")))) + "0aq6lvlwlkxz56l5sbvgycr6j5c82ch2bv6zrnc2345ibfpafgx9")) + (patches + (search-patches "xorriso-no-partition-table-in-inner-efi.patch" + "xorriso-no-mbr-in-inner-efi.patch")))) (build-system gnu-build-system) + (arguments + `(#:phases + (modify-phases %standard-phases + (add-after 'install 'install-frontends + (lambda* (#:key outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (out-bin (string-append out "/bin"))) + (install-file "frontend/grub-mkrescue-sed.sh" out-bin) + #t)))))) (inputs `(("acl" ,acl) ("readline" ,readline) diff --git a/gnu/packages/patches/xorriso-no-mbr-in-inner-efi.patch b/gnu/packages/patches/xorriso-no-mbr-in-inner-efi.patch new file mode 100644 index 0000000000..a43889d2c6 --- /dev/null +++ b/gnu/packages/patches/xorriso-no-mbr-in-inner-efi.patch @@ -0,0 +1,47 @@ +https://dev.lovelyhq.com/libburnia/libisoburn/commit/1eb51f44dadb8b6c5f87533ca357186cdc1ac625 +diff --git a/frontend/grub-mkrescue-sed.sh b/frontend/grub-mkrescue-sed.sh +index b3948c99..dcd9d696 100755 +--- a/frontend/grub-mkrescue-sed.sh ++++ b/frontend/grub-mkrescue-sed.sh +@@ -120,6 +120,7 @@ fi + # "yes" overwrites the MBR partition table area in the EFI boot image by zeros. + # Some EFI implementations get stuck when seeing in the EFI partition a + # partition table entry which begins at LBA 0. ++# "extra" not only zeros the partition table but also the MBR signature. + efi_zero_inner_pt=no + if test -n "$MKRESCUE_SED_IN_EFI_NO_PT" + then +@@ -192,24 +193,31 @@ then + find "$dir" + fi + +-if test "$efi_zero_inner_pt" = yes ++if test "$efi_zero_inner_pt" = yes -o "$efi_zero_inner_pt" = extra + then + did_dd=0 + if test -e "$dir"/efi.img + then ++ # Look for 0x55 0xAA in bytes 510 and 511 + magic=$(dd bs=1 skip=510 count=2 if="$dir"/efi.img 2>/dev/null | \ + od -c | head -1 | awk '{print $2 " " $3}') + if test "$magic" = "U 252" + then ++ echo "Performing actions for MKRESCUE_SED_IN_EFI_NO_PT=$efi_zero_inner_pt" >&2 + dd if=/dev/zero bs=1 seek=446 count=64 conv=notrunc of="$dir"/efi.img + did_dd=1 ++ if test "$efi_zero_inner_pt" = extra ++ then ++ dd if=/dev/zero bs=1 seek=510 count=2 conv=notrunc of="$dir"/efi.img ++ fi ++ echo >&2 + fi + fi + if test "$did_dd" = 0 + then + echo >&2 + echo "$0 : NOTE : No EFI image found or no MBR signature in it." >&2 +- echo "$0 : NOTE : Will not obey MKRESCUE_SED_IN_EFI_NO_PT=yes" >&2 ++ echo "$0 : NOTE : Will not obey MKRESCUE_SED_IN_EFI_NO_PT=$efi_zero_inner_pt" >&2 + echo >&2 + fi + fi diff --git a/gnu/packages/patches/xorriso-no-partition-table-in-inner-efi.patch b/gnu/packages/patches/xorriso-no-partition-table-in-inner-efi.patch new file mode 100644 index 0000000000..a719ca1f89 --- /dev/null +++ b/gnu/packages/patches/xorriso-no-partition-table-in-inner-efi.patch @@ -0,0 +1,107 @@ +https://dev.lovelyhq.com/libburnia/libisoburn/commit/3a2a3ba737a06162c22ace0ae09d33ba97aa2673 +diff --git a/frontend/grub-mkrescue-sed.sh b/frontend/grub-mkrescue-sed.sh +index d772ff22..b3948c99 100755 +--- a/frontend/grub-mkrescue-sed.sh ++++ b/frontend/grub-mkrescue-sed.sh +@@ -1,6 +1,6 @@ + #!/bin/sh + +-# Copyright (C) 2015 - 2016 ++# Copyright (C) 2015 - 2019 + # Thomas Schmitt , libburnia-project.org + # Provided under BSD license: Use, modify, and distribute as you like. + +@@ -117,6 +117,15 @@ fi + # command line.) + # Each argument must be a single word. No whitespace. No quotation marks. + ++# "yes" overwrites the MBR partition table area in the EFI boot image by zeros. ++# Some EFI implementations get stuck when seeing in the EFI partition a ++# partition table entry which begins at LBA 0. ++efi_zero_inner_pt=no ++if test -n "$MKRESCUE_SED_IN_EFI_NO_PT" ++then ++ efi_zero_inner_pt="$MKRESCUE_SED_IN_EFI_NO_PT" ++fi ++ + + # + # Do the work +@@ -183,12 +192,48 @@ then + find "$dir" + fi + ++if test "$efi_zero_inner_pt" = yes ++then ++ did_dd=0 ++ if test -e "$dir"/efi.img ++ then ++ magic=$(dd bs=1 skip=510 count=2 if="$dir"/efi.img 2>/dev/null | \ ++ od -c | head -1 | awk '{print $2 " " $3}') ++ if test "$magic" = "U 252" ++ then ++ dd if=/dev/zero bs=1 seek=446 count=64 conv=notrunc of="$dir"/efi.img ++ did_dd=1 ++ fi ++ fi ++ if test "$did_dd" = 0 ++ then ++ echo >&2 ++ echo "$0 : NOTE : No EFI image found or no MBR signature in it." >&2 ++ echo "$0 : NOTE : Will not obey MKRESCUE_SED_IN_EFI_NO_PT=yes" >&2 ++ echo >&2 ++ fi ++fi ++ + efi_tmp_name= ++if test x"$mode" = xmjg \ ++ -o x"$mode" = xmbr_only \ ++ -o x"$mode" = xgpt_appended \ ++ -o x"$mode" = xmbr_hfs ++then ++ # Move EFI partition image file out of the "$dir" tree, i.e. out of the ISO ++ efi_tmp_name=grub-mkrescue-sed-efi-img.$$ ++ if test -e "$dir"/efi.img ++ then ++ mv "$dir"/efi.img /tmp/$efi_tmp_name ++ elif test -e /tmp/$efi_tmp_name ++ then ++ rm /tmp/$efi_tmp_name ++ fi ++fi ++ + if test x"$mode" = xmjg + then + # Exchange arguments for the experimental GRUB2 mjg layout +- efi_tmp_name=grub-mkrescue-sed-efi-img.$$ +- mv "$dir"/efi.img /tmp/$efi_tmp_name + x=$(echo " $*" | sed \ + -e "s/-efi-boot-part --efi-boot-image/-no-pad -append_partition $partno 0xef \/tmp\/$efi_tmp_name/" \ + -e "s/--efi-boot efi\.img/-eltorito-alt-boot -e --interval:appended_partition_${partno}:all:: -no-emul-boot -isohybrid-gpt-basdat/" \ +@@ -207,8 +252,6 @@ then + elif test x"$mode" = xmbr_only + then + # Exchange arguments for no-HFS MBR-only layout +- efi_tmp_name=grub-mkrescue-sed-efi-img.$$ +- mv "$dir"/efi.img /tmp/$efi_tmp_name + x=$(echo " $*" | sed \ + -e "s/-efi-boot-part --efi-boot-image/$iso_mbr_part_type -no-pad -append_partition 2 0xef \/tmp\/$efi_tmp_name/" \ + -e "s/--efi-boot efi\.img/-eltorito-alt-boot -e --interval:appended_partition_2:all:: -no-emul-boot/" \ +@@ -228,8 +271,6 @@ then + elif test x"$mode" = xmbr_hfs + then + # Exchange arguments for MBR and HFS+ layout +- efi_tmp_name=grub-mkrescue-sed-efi-img.$$ +- mv "$dir"/efi.img /tmp/$efi_tmp_name + x=$(echo " $*" | sed \ + -e "s/-efi-boot-part --efi-boot-image/$iso_mbr_part_type -no-pad -append_partition 2 0xef \/tmp\/$efi_tmp_name/" \ + -e "s/--efi-boot efi\.img/-eltorito-alt-boot -e --interval:appended_partition_2:all:: -no-emul-boot/" \ +@@ -247,8 +288,6 @@ then + elif test x"$mode" = xgpt_appended + then + # Exchange arguments for no-HFS MBR-only layout +- efi_tmp_name=grub-mkrescue-sed-efi-img.$$ +- mv "$dir"/efi.img /tmp/$efi_tmp_name + x=$(echo " $*" | sed \ + -e "s/-efi-boot-part --efi-boot-image/-no-pad -append_partition 2 0xef \/tmp\/$efi_tmp_name -appended_part_as_gpt -partition_offset 16/" \ + -e "s/--efi-boot efi\.img/-eltorito-alt-boot -e --interval:appended_partition_2:all:: -no-emul-boot/" \ diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index aa37896498..0d4ed63eec 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -266,7 +266,8 @@ made available under the /xchg CIFS share." bootcfg-drv bootloader (register-closures? (has-guix-service-type? os)) - (inputs '())) + (inputs '()) + (grub-mkrescue-environment '())) "Return a bootable, stand-alone iso9660 image. INPUTS is a list of inputs (as for packages)." @@ -313,7 +314,9 @@ INPUTS is a list of inputs (as for packages)." inputs))) (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - (make-iso9660-image #$(bootloader-package bootloader) + (make-iso9660-image #$xorriso + '#$grub-mkrescue-environment + #$(bootloader-package bootloader) #$bootcfg-drv #$os "/xchg/guixsd.iso" @@ -704,7 +707,9 @@ to USB sticks meant to be read-only." #:bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)) #:inputs `(("system" ,os) - ("bootcfg" ,bootcfg))) + ("bootcfg" ,bootcfg)) + #:grub-mkrescue-environment + '(("MKRESCUE_SED_MODE" . "mbr_hfs"))) (qemu-image #:name name #:os os #:bootcfg-drv bootcfg -- cgit 1.4.1