diff options
Diffstat (limited to 'gnu/build')
| -rw-r--r-- | gnu/build/accounts.scm | 8 | ||||
| -rw-r--r-- | gnu/build/bootloader.scm | 1 | ||||
| -rw-r--r-- | gnu/build/chromium-extension.scm | 173 | ||||
| -rw-r--r-- | gnu/build/file-systems.scm | 36 | ||||
| -rw-r--r-- | gnu/build/hurd-boot.scm | 12 | ||||
| -rw-r--r-- | gnu/build/image.scm | 39 | ||||
| -rw-r--r-- | gnu/build/linux-container.scm | 3 | ||||
| -rw-r--r-- | gnu/build/linux-modules.scm | 10 | ||||
| -rw-r--r-- | gnu/build/marionette.scm | 84 | ||||
| -rw-r--r-- | gnu/build/secret-service.scm | 17 | ||||
| -rw-r--r-- | gnu/build/vm.scm | 500 |
11 files changed, 255 insertions, 628 deletions
diff --git a/gnu/build/accounts.scm b/gnu/build/accounts.scm index f60d68d9b3..1247fc640c 100644 --- a/gnu/build/accounts.scm +++ b/gnu/build/accounts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -490,7 +490,11 @@ new UIDs." (uid id) (directory directory) (gid (if (number? group) group (group-id group))) - (real-name (if previous + + ;; Users might change their name to something + ;; other than what the sysadmin chose, with + ;; 'chfn'. Thus consider it "stateful". + (real-name (if (and previous (not system?)) (password-entry-real-name previous) real-name)) diff --git a/gnu/build/bootloader.scm b/gnu/build/bootloader.scm index 3916930c89..9a89fe55cb 100644 --- a/gnu/build/bootloader.scm +++ b/gnu/build/bootloader.scm @@ -94,6 +94,7 @@ load the Grub bootloader located in the 'Guix_image' root partition." ;; (not eliminate it). (format port "insmod part_msdos~@ + insmod part_gpt~@ search --set=root --label Guix_image~@ configfile /boot/grub/grub.cfg~%"))) (install-efi grub-efi grub-config esp) diff --git a/gnu/build/chromium-extension.scm b/gnu/build/chromium-extension.scm index d65df09f37..8ca5251957 100644 --- a/gnu/build/chromium-extension.scm +++ b/gnu/build/chromium-extension.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2020 Marius Bakke <marius@gnu.org> +;;; Copyright © 2020, 2021 Marius Bakke <marius@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,13 +17,8 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu build chromium-extension) - #:use-module (gcrypt base16) - #:use-module ((gcrypt hash) #:prefix hash:) - #:use-module (ice-9 iconv) #:use-module (guix gexp) #:use-module (guix packages) - #:use-module (gnu packages base) - #:use-module (gnu packages check) #:use-module (gnu packages chromium) #:use-module (gnu packages gnupg) #:use-module (gnu packages tls) @@ -39,28 +34,30 @@ (define (make-signing-key seed) "Return a derivation for a deterministic PKCS #8 private key using SEED." + (computed-file + (string-append seed "-signing-key.pem") + (with-extensions (list guile-gcrypt) + #~(begin + (use-modules (gcrypt base16) (gcrypt hash) (ice-9 iconv)) + (let* ((sha256sum (bytevector->base16-string + (sha256 (string->bytevector #$seed "UTF-8")))) + ;; certtool.c wants a 56 byte seed for a 2048 bit key. + (key-size 2048) + (normalized-seed (string-take sha256sum 56))) - (define sha256sum - (bytevector->base16-string (hash:sha256 (string->bytevector seed "UTF-8")))) - - ;; certtool.c wants a 56 byte seed for a 2048 bit key. - (define size 2048) - (define normalized-seed (string-take sha256sum 56)) - - (computed-file (string-append seed "-signing-key.pem") - #~(system* #$(file-append gnutls "/bin/certtool") - "--generate-privkey" - "--key-type=rsa" - "--pkcs8" - ;; Use the provable FIPS-PUB186-4 algorithm for - ;; deterministic results. - "--provable" - "--password=" - "--no-text" - (string-append "--bits=" #$(number->string size)) - (string-append "--seed=" #$normalized-seed) - "--outfile" #$output) - #:local-build? #t)) + (system* #$(file-append gnutls "/bin/certtool") + "--generate-privkey" + "--key-type=rsa" + "--pkcs8" + ;; Use the provable FIPS-PUB186-4 algorithm for + ;; deterministic results. + "--provable" + "--password=" + "--no-text" + (string-append "--bits=" (number->string key-size)) + (string-append "--seed=" normalized-seed) + "--outfile" #$output)))) + #:local-build? #t)) (define* (make-crx signing-key package #:optional (package-output "out")) "Create a signed \".crx\" file from the unpacked Chromium extension residing @@ -68,9 +65,9 @@ in PACKAGE-OUTPUT of PACKAGE. The extension will be signed with SIGNING-KEY." (define name (package-name package)) (define version (package-version package)) - (with-imported-modules '((guix build utils)) - (computed-file - (string-append name "-" version ".crx") + (computed-file + (string-append name "-" version ".crx") + (with-imported-modules '((guix build utils)) #~(begin ;; This is not great. We pull Xorg and Chromium just to Zip and ;; sign an extension. This should be implemented with something @@ -78,27 +75,22 @@ in PACKAGE-OUTPUT of PACKAGE. The extension will be signed with SIGNING-KEY." (use-modules (guix build utils)) (let ((chromium #$(file-append ungoogled-chromium "/bin/chromium")) (xvfb #$(file-append xorg-server "/bin/Xvfb")) - (packdir "/tmp/extension")) - (mkdir-p (dirname packdir)) - (copy-recursively (ungexp package package-output) packdir) + (packdir (string-append (getcwd) "/extension"))) + (mkdir packdir) + (copy-recursively (ungexp package package-output) packdir + ;; Ensure consistent file modification times. + #:keep-mtime? #t) (system (string-append xvfb " :1 &")) (setenv "DISPLAY" ":1") (sleep 2) ;give Xorg some time to initialize... - ;; Chromium stores the current time in the .crx Zip archive. - ;; Use a fixed timestamp for deterministic behavior. - ;; FIXME (core-updates): faketime is missing an absolute reference - ;; to 'date', hence the need to set PATH. - (setenv "PATH" #$(file-append coreutils "/bin")) - (invoke #$(file-append libfaketime "/bin/faketime") - "2000-01-01 00:00:00" - chromium - "--user-data-dir=/tmp/signing-profile" + (invoke chromium + "--user-data-dir=chromium-profile" (string-append "--pack-extension=" packdir) (string-append "--pack-extension-key=" #$signing-key)) - (copy-file (string-append packdir ".crx") #$output))) - #:local-build? #t))) + (copy-file (string-append packdir ".crx") #$output)))) + #:local-build? #t)) -(define* (crx->chromium-json crx version) +(define (crx->chromium-json crx version) "Return a derivation that creates a Chromium JSON settings file for the extension given as CRX. VERSION is used to signify the CRX version, and must match the version listed in the extension manifest.json." @@ -127,66 +119,47 @@ format." "--outder") #:local-build? #t)) -(define (chromium-json->profile-object json signing-key) - "Return a derivation that installs JSON to the directory searched by -Chromium, using a file name (aka extension ID) derived from SIGNING-KEY." - (define der (signing-key->public-der signing-key)) - +(define (file-sha256sum file) (with-extensions (list guile-gcrypt) - (with-imported-modules '((guix build utils)) - (computed-file - "chromium-extension" - #~(begin - (use-modules (guix build utils) - (gcrypt base16) - (gcrypt hash)) - (define (base16-string->chromium-base16 str) - ;; Translate STR, a hexadecimal string, to a Chromium-style - ;; representation using the letters a-p (where a=0, p=15). - (define s1 "0123456789abcdef") - (define s2 "abcdefghijklmnop") - (let loop ((chars (string->list str)) - (converted '())) - (if (null? chars) - (list->string (reverse converted)) - (loop (cdr chars) - (cons (string-ref s2 (string-index s1 (car chars))) - converted))))) - - (let* ((checksum (bytevector->base16-string (file-sha256 #$der))) - (file-name (base16-string->chromium-base16 - (string-take checksum 32))) - (extension-directory (string-append #$output - "/share/chromium/extensions"))) - (mkdir-p extension-directory) - (symlink #$json (string-append extension-directory "/" - file-name ".json")))) - #:local-build? #t)))) + #~(begin + (use-modules (gcrypt base16) (gcrypt hash)) + (bytevector->base16-string (file-sha256 #$file))))) -(define* (make-chromium-extension p #:optional (output "out")) - "Create a Chromium extension from package P and return a package that, -when installed, will make the extension contained in P available as a -Chromium browser extension. OUTPUT specifies which output of P to use." - (let* ((pname (package-name p)) - (version (package-version p)) - (signing-key (make-signing-key pname))) +(define* (make-chromium-extension pkg #:optional (pkg-output "out")) + "Create a Chromium extension from package PKG and return a package that, +when installed, will make the extension contained in PKG available as a +Chromium browser extension. PKG-OUTPUT specifies which output of PKG to use." + (let* ((name (package-name pkg)) + (version (package-version pkg)) + (private-key (make-signing-key name)) + (public-key (signing-key->public-der private-key)) + (checksum (file-sha256sum public-key)) + (crx (make-crx private-key pkg pkg-output)) + (json (crx->chromium-json crx version))) (package - (inherit p) - (name (string-append pname "-chromium")) + (inherit pkg) + (name (string-append name "-chromium")) (source #f) - (build-system trivial-build-system) (native-inputs '()) - (inputs - `(("extension" ,(chromium-json->profile-object - (crx->chromium-json (make-crx signing-key p output) - version) - signing-key)))) + (inputs '()) (propagated-inputs '()) (outputs '("out")) + (build-system trivial-build-system) (arguments - '(#:modules ((guix build utils)) - #:builder - (begin - (use-modules (guix build utils)) - (copy-recursively (assoc-ref %build-inputs "extension") - (assoc-ref %outputs "out")))))))) + (list #:modules '((guix build utils)) + #:builder + #~(begin + (use-modules (guix build utils)) + (define (base16-char->chromium-base16 char) + ;; Translate CHAR, a hexadecimal character, to a Chromium-style + ;; representation using the letters a-p (where a=0, p=15). + (string-ref "abcdefghijklmnop" + (string-index "0123456789abcdef" char))) + (let ((file-name (string-map base16-char->chromium-base16 + (string-take #$checksum 32))) + (extension-directory + (string-append #$output + "/share/chromium/extensions"))) + (mkdir-p extension-directory) + (symlink #$json (string-append extension-directory "/" + file-name ".json"))))))))) diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index d8a5ddf1e5..d95340df83 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -29,6 +29,8 @@ #:use-module (guix build bournish) #:use-module ((guix build syscalls) #:hide (file-system-type)) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) @@ -54,7 +56,9 @@ mount-flags->bit-mask check-file-system - mount-file-system)) + mount-file-system + + swap-space->flags-bit-mask)) ;;; Commentary: ;;; @@ -227,6 +231,36 @@ if DEVICE does not contain an linux-swap file system." "Return the label of Linux-swap superblock SBLOCK as a string." (null-terminated-latin1->string (sub-bytevector sblock (+ 1024 4 4 4 16) 16))) + +(define (swap-space->flags-bit-mask swap) + "Return the number suitable for the 'flags' argument of 'mount' +that corresponds to the swap-space SWAP." + (define prio-flag + (let ((p (swap-space-priority swap)) + (max (ash SWAP_FLAG_PRIO_MASK (- SWAP_FLAG_PRIO_SHIFT)))) + (if p + (logior SWAP_FLAG_PREFER + (ash (cond + ((< p 0) + (begin (warning + (G_ "Given swap priority ~a is +negative, defaulting to 0.~%") p) + 0)) + ((> p max) + (begin (warning + (G_ "Limiting swap priority ~a to +~a.~%") + p max) + max)) + (else p)) + SWAP_FLAG_PRIO_SHIFT)) + 0))) + (define delayed-flag + (if (swap-space-discard? swap) + SWAP_FLAG_DISCARD + 0)) + (logior prio-flag delayed-flag)) + ;;; diff --git a/gnu/build/hurd-boot.scm b/gnu/build/hurd-boot.scm index e66d4d1ba8..ac36bd17d4 100644 --- a/gnu/build/hurd-boot.scm +++ b/gnu/build/hurd-boot.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -185,13 +185,9 @@ set." ("servers/crash-suspend" ("/hurd/crash" "--suspend")) ("servers/password" ("/hurd/password")) ("servers/socket/1" ("/hurd/pflocal")) - ("servers/socket/2" ("/hurd/pfinet" - "--interface" "eth0" - "--address" - "10.0.2.15" ;the default QEMU guest IP - "--netmask" "255.255.255.0" - "--gateway" "10.0.2.2" - "--ipv6" "/servers/socket/16")) + ;; /servers/socket/2 and /26 are created by 'static-networking-service'. + ;; XXX: Spawn pfinet without arguments on these nodes so that a DHCP + ;; client has someone to talk to? ("proc" ("/hurd/procfs" "--stat-mode=444")))) (define devices diff --git a/gnu/build/image.scm b/gnu/build/image.scm index 6eb0290256..bdd5ec25a9 100644 --- a/gnu/build/image.scm +++ b/gnu/build/image.scm @@ -166,6 +166,7 @@ produced by #:references-graphs. Pass WAL-MODE? to call-with-database." bootcfg-location bootloader-package bootloader-installer + (copy-closures? #t) (deduplicate? #t) references-graphs (register-closures? #t) @@ -176,30 +177,50 @@ produced by #:references-graphs. Pass WAL-MODE? to call-with-database." "Initialize the given ROOT directory. Use BOOTCFG and BOOTCFG-LOCATION to install the bootloader configuration. -If REGISTER-CLOSURES? is true, register REFERENCES-GRAPHS in the store. If +If COPY-CLOSURES? is true, copy all of REFERENCES-GRAPHS to the partition. If +REGISTER-CLOSURES? is true, register REFERENCES-GRAPHS in the store. If DEDUPLICATE? is true, then also deduplicate files common to CLOSURES and the rest of the store when registering the closures. SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation. Pass WAL-MODE? to register-closure." + (define root-store + (string-append root (%store-directory))) + + (define tmp-store ".tmp-store") + (populate-root-file-system system-directory root) - (populate-store references-graphs root - #:deduplicate? deduplicate?) + + (when copy-closures? + (populate-store references-graphs root + #:deduplicate? deduplicate?)) ;; Populate /dev. (when make-device-nodes (make-device-nodes root)) (when register-closures? + (unless copy-closures? + ;; XXX: 'register-closure' wants to palpate the things it registers, so + ;; create a symlink to the store. + (rename-file root-store tmp-store) + (symlink (%store-directory) root-store)) + (for-each (lambda (closure) (register-closure root closure #:wal-mode? wal-mode?)) - references-graphs)) + references-graphs) + + (unless copy-closures? + (delete-file root-store) + (rename-file tmp-store root-store))) - (when bootloader-installer - (display "installing bootloader...\n") - (bootloader-installer bootloader-package #f root)) - (when bootcfg - (install-boot-config bootcfg bootcfg-location root))) + ;; There's no point installing a bootloader if we do not populate the store. + (when copy-closures? + (when bootloader-installer + (display "installing bootloader...\n") + (bootloader-installer bootloader-package #f root)) + (when bootcfg + (install-boot-config bootcfg bootcfg-location root)))) (define* (make-iso9660-image xorriso grub-mkrescue-environment grub bootcfg system-directory root target diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm index 4a8bed5a9a..bdeca2cdb9 100644 --- a/gnu/build/linux-container.scm +++ b/gnu/build/linux-container.scm @@ -52,7 +52,7 @@ exists." (file-exists? "/proc/self/setgroups")) (define %namespaces - '(mnt pid ipc uts user net)) + '(cgroup mnt pid ipc uts user net)) (define (call-with-clean-exit thunk) "Apply THUNK, but exit with a status code of 1 if it fails." @@ -210,6 +210,7 @@ corresponds to the symbols in NAMESPACES." ;; Use the same flags as fork(3) in addition to the namespace flags. (apply logior SIGCHLD (map (match-lambda + ('cgroup CLONE_NEWCGROUP) ('mnt CLONE_NEWNS) ('uts CLONE_NEWUTS) ('ipc CLONE_NEWIPC) diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm index 3a47322065..053720574b 100644 --- a/gnu/build/linux-modules.scm +++ b/gnu/build/linux-modules.scm @@ -354,11 +354,13 @@ appears in BLACK-LIST are not loaded." (close-fdes fd) #t) (lambda args - ;; If this module was already loaded and we're in modprobe style, ignore - ;; the error. (when fd (close-fdes fd)) - (or (and recursive? (= EEXIST (system-error-errno args))) - (apply throw args))))))) + (let ((errno (system-error-errno args))) + (or (and recursive? ; we're operating in ‘modprobe’ style + (member errno + (list EEXIST ; already loaded + EINVAL))) ; unsupported by hardware + (apply throw args)))))))) (define (load-linux-modules-from-directory modules directory) "Load MODULES and their dependencies from DIRECTORY, a directory containing diff --git a/gnu/build/marionette.scm b/gnu/build/marionette.scm index fe754cd147..b336024610 100644 --- a/gnu/build/marionette.scm +++ b/gnu/build/marionette.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -20,9 +20,11 @@ (define-module (gnu build marionette) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64) #:use-module (rnrs io ports) #:use-module (ice-9 match) #:use-module (ice-9 popen) + #:use-module (ice-9 regex) #:export (marionette? make-marionette marionette-eval @@ -33,7 +35,10 @@ marionette-screen-text wait-for-screen-text %qwerty-us-keystrokes - marionette-type)) + marionette-type + + system-test-runner + qemu-command)) ;;; Commentary: ;;; @@ -358,4 +363,79 @@ to actual keystrokes." (for-each (cut marionette-control <> marionette) (string->keystroke-commands str keystrokes))) + +;;; +;;; Test helper. +;;; + +(define* (system-test-runner #:optional log-directory) + "Return a SRFI-64 test runner that calls 'exit' upon 'test-end'. When +LOG-DIRECTORY is specified, create log file within it." + (let ((runner (test-runner-simple))) + ;; Log to a file under LOG-DIRECTORY. + (test-runner-on-group-begin! runner + (let ((on-begin (test-runner-on-group-begin runner))) + (lambda (runner suite-name count) + (when log-directory + (catch 'system-error + (lambda () + (mkdir log-directory)) + (lambda args + (unless (= (system-error-errno args) EEXIST) + (apply throw args)))) + (set! test-log-to-file + (string-append log-directory "/" suite-name ".log"))) + (on-begin runner suite-name count)))) + + ;; The default behavior on 'test-end' is to only write a line if the test + ;; failed. Arrange to also write a line on success. + (test-runner-on-test-end! runner + (let ((on-end (test-runner-on-test-end runner))) + (lambda (runner) + (let* ((kind (test-result-ref runner 'result-kind)) + (results (test-result-alist runner)) + (test-name (assq-ref results 'test-name))) + (unless (memq kind '(fail xpass)) + (format (current-output-port) "~a: ~a~%" + (string-upcase (symbol->string kind)) + test-name))) + + (on-end runner)))) + + ;; On 'test-end', display test results and exit with zero if and only if + ;; there were no test failures. + (test-runner-on-final! runner + (lambda (runner) + (let ((success? (= (test-runner-fail-count runner) 0))) + (test-on-final-simple runner) + + (when (not success?) + (let* ((log-port (test-runner-aux-value runner)) + (log-file (port-filename log-port))) + (format (current-error-port) + "\nTests failed, dumping log file '~a'.\n\n" + log-file) + + ;; At this point LOG-PORT is not closed yet; flush it. + (force-output log-port) + + ;; Brute force to avoid dependency on (guix build utils) for + ;; 'dump-port'. + (let ((content (call-with-input-file log-file + get-bytevector-all))) + (put-bytevector (current-error-port) content)))) + + (exit success?)))) + runner)) + +(define* (qemu-command #:optional (system %host-type)) + "Return the default name of the QEMU command for SYSTEM." + (let ((cpu (substring system 0 + (string-index system #\-)))) + (string-append "qemu-system-" + (cond + ((string-match "^i[3456]86$" cpu) "i386") + ((string-match "armhf" cpu) "arm") + (else cpu))))) + ;;; marionette.scm ends here diff --git a/gnu/build/secret-service.scm b/gnu/build/secret-service.scm index 46dcf1b9c3..4e183e11e8 100644 --- a/gnu/build/secret-service.scm +++ b/gnu/build/secret-service.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -111,6 +111,15 @@ wait for at most HANDSHAKE-TIMEOUT seconds for handshake to complete. Return (close-port sock) #f)))) +(define (delete-file* file) + "Ensure FILE does not exist." + (catch 'system-error + (lambda () + (delete-file file)) + (lambda args + (unless (= ENOENT (system-error-errno args)) + (apply throw args))))) + (define (secret-service-receive-secrets port) "Listen to local PORT and wait for a secret service client to send secrets. Write them to the file system. Return the list of files installed on success, @@ -170,6 +179,12 @@ and #f otherwise." (log "installing file '~a' (~a bytes)...~%" file size) (mkdir-p (dirname file)) + + ;; It could be that FILE already exists, for instance + ;; because it has been created by a service's activation + ;; snippet (e.g., SSH host keys). Delete it. + (delete-file* file) + (call-with-output-file file (lambda (output) (dump port output size) diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm deleted file mode 100644 index 7b55127599..0000000000 --- a/gnu/build/vm.scm +++ /dev/null @@ -1,500 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2016 Christine Lemmer-Webber <cwebber@dustycloud.org> -;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name> -;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> -;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> -;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> -;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. - -(define-module (gnu build vm) - #:use-module (guix build utils) - #:use-module (guix build store-copy) - #:use-module (guix build syscalls) - #:use-module (guix store database) - #:use-module (gnu build bootloader) - #:use-module (gnu build linux-boot) - #:use-module (gnu build install) - #:use-module (gnu system uuid) - #:use-module (guix records) - #:use-module ((guix combinators) #:select (fold2)) - #:use-module (ice-9 format) - #:use-module (ice-9 ftw) - #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:use-module (ice-9 popen) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-26) - #:export (qemu-command - load-in-linux-vm - format-partition - - partition - partition? - partition-device - partition-size - partition-file-system - partition-label - partition-flags - partition-initializer - - estimated-partition-size - root-partition-initializer - initialize-partition-table - initialize-hard-disk)) - -;;; Commentary: -;;; -;;; This module provides supporting code to run virtual machines and build -;;; virtual machine images using QEMU. -;;; -;;; Code: - -(define* (qemu-command #:optional (system %host-type)) - "Return the default name of the QEMU command for SYSTEM." - (let ((cpu (substring system 0 - (string-index system #\-)))) - (string-append "qemu-system-" - (cond - ((string-match "^i[3456]86$" cpu) "i386") - ((string-match "armhf" cpu) "arm") - (else cpu))))) - -(define* (load-in-linux-vm builder - #:key - output - (qemu (qemu-command)) (memory-size 512) - linux initrd - make-disk-image? - single-file-output? - (disk-image-size (* 100 (expt 2 20))) - (disk-image-format "qcow2") - (references-graphs '())) - "Run BUILDER, a Scheme file, into a VM running LINUX with INITRD, and copy -the result to OUTPUT. If SINGLE-FILE-OUTPUT? is true, copy a single file from -/xchg to OUTPUT. Otherwise, copy the contents of /xchg to a new directory -OUTPUT. - -When MAKE-DISK-IMAGE? is true, OUTPUT will contain a VM image of -DISK-IMAGE-SIZE bytes resulting from the execution of BUILDER, which may -access it via /dev/hda. - -REFERENCES-GRAPHS can specify a list of reference-graph files as produced by -the #:references-graphs parameter of 'derivation'." - - (define target-arm32? - (string-prefix? "arm-" %host-type)) - - (define target-aarch64? - (string-prefix? "aarch64-" %host-type)) - - (define target-arm? - (or target-arm32? target-aarch64?)) - - (define arch-specific-flags - `(;; On ARM, a machine has to be specified. Use "virt" machine to avoid - ;; hardware limits imposed by other machines. - ,@(if target-arm? - '("-M" "virt") - '()) - - ;; On ARM32, if the kernel is built without LPAE support, ECAM conflicts - ;; with VIRT_PCIE_MMIO causing PCI devices not to show up. Disable - ;; explicitely highmem to fix it. - ;; See: https://bugs.launchpad.net/qemu/+bug/1790975. - ,@(if target-arm32? - '("-machine" "highmem=off") - '()) - - ;; Only enable kvm if we see /dev/kvm exists. This allows users without - ;; hardware virtualization to still use these commands. KVM support is - ;; still buggy on some ARM boards. Do not use it even if available. - ,@(if (and (file-exists? "/dev/kvm") - (not target-arm?)) - '("-enable-kvm") - '()) - - ;; Pass "panic=1" so that the guest dies upon error. - "-append" - ,(string-append "panic=1 --load=" builder - - ;; The serial port name differs between emulated - ;; architectures/machines. - " console=" - (if target-arm? "ttyAMA0" "ttyS0")))) - - (when make-disk-image? - (format #t "creating ~a image of ~,2f MiB...~%" - disk-image-format (/ disk-image-size (expt 2 20))) - (force-output) - (invoke "qemu-img" "create" "-f" disk-image-format output - (number->string disk-image-size))) - - (mkdir "xchg") - (mkdir "tmp") - - (match references-graphs - ((graph-files ...) - ;; Copy the reference-graph files under xchg/ so EXP can access it. - (map (lambda (file) - (copy-file file (string-append "xchg/" file))) - graph-files)) - (_ #f)) - - (apply invoke qemu "-nographic" "-no-reboot" - ;; CPU "max" behaves as "host" when KVM is enabled, and like a system - ;; CPU with the maximum possible feature set otherwise. - "-cpu" "max" - "-m" (number->string memory-size) - "-nic" "user,model=virtio-net-pci" - "-object" "rng-random,filename=/dev/urandom,id=guixsd-vm-rng" - "-device" "virtio-rng-pci,rng=guixsd-vm-rng" - "-virtfs" - (string-append "local,id=store_dev,path=" - (%store-directory) - ",security_model=none,mount_tag=store") - "-virtfs" - (string-append "local,id=xchg_dev,path=xchg" - ",security_model=none,mount_tag=xchg") - "-virtfs" - ;; Some programs require more space in /tmp than is normally - ;; available in the guest. Accommodate such programs by sharing a - ;; temporary directory. - (string-append "local,id=tmp_dev,path=tmp" - ",security_model=none,mount_tag=tmp") - "-kernel" linux - "-initrd" initrd - (append - (if make-disk-image? - `("-device" "virtio-blk,drive=myhd" - "-drive" ,(string-append "if=none,file=" output - ",format=" disk-image-format - ",id=myhd")) - '()) - arch-specific-flags)) - - (unless (file-exists? "xchg/.exit-status") - (error "VM did not produce an exit code")) - - (match (call-with-input-file "xchg/.exit-status" read) - (0 #t) - (status (error "guest VM code exited with a non-zero status" status))) - - (delete-file "xchg/.exit-status") - - ;; When MAKE-DISK-IMAGE? is true, the image is in OUTPUT already. - (unless make-disk-image? - (if single-file-output? - (let ((graph? (lambda (name stat) - (member (basename name) references-graphs)))) - (match (find-files "xchg" (negate graph?)) - ((result) - (copy-file result output)) - (x - (error "did not find a single result file" x)))) - (begin - (mkdir output) - (copy-recursively "xchg" output))))) - -(define* (register-closure prefix closure - #:key - (schema (sql-schema))) - "Register CLOSURE in PREFIX, where PREFIX is the directory name of the -target store and CLOSURE is the name of a file containing a reference graph as -produced by #:references-graphs." - (let ((items (call-with-input-file closure read-reference-graph))) - (parameterize ((sql-schema schema)) - (with-database (store-database-file #:prefix prefix) db - (register-items db items - #:prefix prefix - #:registration-time %epoch))))) - - -;;; -;;; Partitions. -;;; - -(define-record-type* <partition> partition make-partition - partition? - (device partition-device (default #f)) - (size partition-size) - (file-system partition-file-system (default "ext4")) - (file-system-options partition-file-system-options ;passed to 'mkfs.FS' - (default '())) - (label partition-label (default #f)) - (uuid partition-uuid (default #f)) - (flags partition-flags (default '())) - (initializer partition-initializer (default (const #t)))) - -(define (estimated-partition-size graphs) - "Return the estimated size of a partition that can store the store items -given by GRAPHS, a list of file names produced by #:references-graphs." - ;; Simply add a 25% overhead. - (round (* 1.25 (closure-size graphs)))) - -(define* (initialize-partition-table device partitions - #:key - (label-type "msdos") - (offset (expt 2 20))) - "Create on DEVICE a partition table of type LABEL-TYPE, containing the given -PARTITIONS (a list of <partition> objects), starting at OFFSET bytes. On -success, return PARTITIONS with their 'device' field changed to reflect their -actual /dev name based on DEVICE." - (define (partition-options part offset index) - (cons* "mkpart" "primary" "ext2" - (format #f "~aB" offset) - (format #f "~aB" (+ offset (partition-size part))) - (append-map (lambda (flag) - (list "set" (number->string index) - (symbol->string flag) "on")) - (partition-flags part)))) - - (define (options partitions offset) - (let loop ((partitions partitions) - (offset offset) - (index 1) - (result '())) - (match partitions - (() - (concatenate (reverse result))) - ((head tail ...) - (loop tail - ;; Leave one sector (512B) between partitions to placate - ;; Parted. - (+ offset 512 (partition-size head)) - (+ 1 index) - (cons (partition-options head offset index) - result)))))) - - (format #t "creating partition table with ~a partitions (~a)...\n" - (length partitions) - (string-join (map (compose (cut string-append <> " MiB") - number->string - (lambda (size) - (round (/ size (expt 2. 20)))) - partition-size) - partitions) - ", ")) - (apply invoke "parted" "--script" - device "mklabel" label-type - (options partitions offset)) - - ;; Set the 'device' field of each partition. - (reverse - (fold2 (lambda (part result index) - (values (cons (partition - (inherit part) - (device (string-append device - (number->string index)))) - result) - (+ 1 index))) - '() - 1 - partitions))) - -(define MS_BIND 4096) ; <sys/mounts.h> again! - -(define* (create-ext-file-system partition type - #:key label uuid (options '())) - "Create an ext-family file system of TYPE on PARTITION. If LABEL is true, -use that as the volume name. If UUID is true, use it as the partition UUID." - (format #t "creating ~a partition... ~@[label: ~s~] ~@[uuid: ~s~]\n" - type label (and uuid (uuid->string uuid))) - (apply invoke (string-append "mkfs." type) - "-F" partition - `(,@(if label - `("-L" ,label) - '()) - ,@(if uuid - `("-U" ,(uuid->string uuid)) - '()) - ,@options))) - -(define* (create-fat-file-system partition - #:key label uuid (options '())) - "Create a FAT file system on PARTITION. The number of File Allocation Tables -will be determined based on file system size. If LABEL is true, use that as the -volume name." - ;; FIXME: UUID is ignored! - (format #t "creating FAT partition...\n") - (apply invoke "mkfs.fat" partition - (append (if label `("-n" ,label) '()) options))) - -(define* (format-partition partition type - #:key label uuid (options '())) - "Create a file system TYPE on PARTITION. If LABEL is true, use that as the -volume name. Options is a list of command-line options passed to 'mkfs.FS'." - (cond ((string-prefix? "ext" type) - (create-ext-file-system partition type #:label label #:uuid uuid - #:options options)) - ((or (string-prefix? "fat" type) (string= "vfat" type)) - (create-fat-file-system partition #:label label #:uuid uuid - #:options options)) - (else (error "Unsupported file system.")))) - -(define (initialize-partition partition) - "Format PARTITION, a <partition> object with a non-#f 'device' field, mount -it, run its initializer, and unmount it." - (let ((target "/fs")) - (format-partition (partition-device partition) - (partition-file-system partition) - #:label (partition-label partition) - #:uuid (partition-uuid partition) - #:options (partition-file-system-options partition)) - (mkdir-p target) - (mount (partition-device partition) target - (partition-file-system partition)) - - ((partition-initializer partition) target) - - (umount target) - partition)) - -(define* (root-partition-initializer #:key (closures '()) - copy-closures? - (register-closures? #t) - system-directory - (deduplicate? #t) - (make-device-nodes - make-essential-device-nodes) - (extra-directives '())) - "Return a procedure to initialize a root partition. - -If REGISTER-CLOSURES? is true, register all of CLOSURES in the partition's -store. If DEDUPLICATE? is true, then also deduplicate files common to -CLOSURES and the rest of the store when registering the closures. If -COPY-CLOSURES? is true, copy all of CLOSURES to the partition. -SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation. - -EXTRA-DIRECTIVES is an optional list of directives to populate the root file -system that is passed to 'populate-root-file-system'." - (lambda (target) - (define target-store - (string-append target (%store-directory))) - - (when copy-closures? - ;; Populate the store. - (populate-store (map (cut string-append "/xchg/" <>) closures) - target - #:deduplicate? deduplicate?)) - - ;; Populate /dev. - (make-device-nodes target) - - ;; Optionally, register the inputs in the image's store. - (when register-closures? - (unless copy-closures? - ;; XXX: 'register-closure' wants to palpate the things it registers, so - ;; bind-mount the store on the target. - (mkdir-p target-store) - (mount (%store-directory) target-store "" MS_BIND)) - - (display "registering closures...\n") - (for-each (lambda (closure) - (register-closure target - (string-append "/xchg/" closure))) - closures) - (unless copy-closures? - (umount target-store))) - - ;; Add the non-store directories and files. - (display "populating...\n") - (populate-root-file-system system-directory target - #:extras extra-directives) - - ;; 'register-closure' resets timestamps and everything, so no need to do it - ;; once more in that case. - (unless register-closures? - ;; 'reset-timestamps' also resets file permissions; do that everywhere - ;; except on /dev so that /dev/null remains writable, etc. - (for-each (lambda (directory) - (reset-timestamps (string-append target "/" directory))) - (scandir target - (match-lambda - ((or "." ".." "dev") #f) - (_ #t)))) - (reset-timestamps (string-append target "/dev") - #:preserve-permissions? #t)))) - -(define (register-bootcfg-root target bootcfg) - "On file system TARGET, register BOOTCFG as a GC root." - (let ((directory (string-append target "/var/guix/gcroots"))) - (mkdir-p directory) - (symlink bootcfg (string-append directory "/bootcfg")))) - -(define* (initialize-hard-disk device - #:key - bootloader-package - bootcfg - bootcfg-location - bootloader-installer - (grub-efi #f) - (partitions '())) - "Initialize DEVICE as a disk containing all the <partition> objects listed -in PARTITIONS, and using BOOTCFG as its bootloader configuration file. - -Each partition is initialized by calling its 'initializer' procedure, -passing it a directory name where it is mounted." - - (define (partition-bootable? partition) - "Return the first partition found with the boot flag set." - (member 'boot (partition-flags partition))) - - (define (partition-esp? partition) - "Return the first EFI System Partition." - (member 'esp (partition-flags partition))) - - (let* ((partitions (initialize-partition-table device partitions)) - (root (find partition-bootable? partitions)) - (esp (find partition-esp? partitions)) - (target "/fs")) - (unless root - (error "no bootable partition specified" partitions)) - - (for-each initialize-partition partitions) - - (display "mounting root partition...\n") - (mkdir-p target) - (mount (partition-device root) target (partition-file-system root)) - (install-boot-config bootcfg bootcfg-location target) - (when bootloader-installer - (display "installing bootloader...\n") - (bootloader-installer bootloader-package device target)) - - (when esp - ;; Mount the ESP somewhere and install GRUB UEFI image. - (let ((mount-point (string-append target "/boot/efi"))) - (display "mounting EFI system partition...\n") - (mkdir-p mount-point) - (mount (partition-device esp) mount-point - (partition-file-system esp)) - - (display "creating EFI firmware image...") - (install-efi-loader grub-efi mount-point) - (display "done.\n") - - (umount mount-point))) - - ;; Register BOOTCFG as a GC root. - (register-bootcfg-root target bootcfg) - - (umount target))) - -;;; vm.scm ends here |