diff options
Diffstat (limited to 'gnu/system')
| -rw-r--r-- | gnu/system/examples/bare-bones.tmpl | 3 | ||||
| -rw-r--r-- | gnu/system/examples/bare-hurd.tmpl | 54 | ||||
| -rw-r--r-- | gnu/system/file-systems.scm | 86 | ||||
| -rw-r--r-- | gnu/system/hurd.scm | 242 | ||||
| -rw-r--r-- | gnu/system/image.scm | 212 | ||||
| -rw-r--r-- | gnu/system/install.scm | 11 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 69 |
7 files changed, 388 insertions, 289 deletions
diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl index 4f30a5b756..1035ab1d60 100644 --- a/gnu/system/examples/bare-bones.tmpl +++ b/gnu/system/examples/bare-bones.tmpl @@ -3,7 +3,7 @@ (use-modules (gnu)) (use-service-modules networking ssh) -(use-package-modules screen) +(use-package-modules screen ssh) (operating-system (host-name "komputilo") @@ -46,5 +46,6 @@ (services (append (list (service dhcp-client-service-type) (service openssh-service-type (openssh-configuration + (openssh openssh-sans-x) (port-number 2222)))) %base-services))) diff --git a/gnu/system/examples/bare-hurd.tmpl b/gnu/system/examples/bare-hurd.tmpl new file mode 100644 index 0000000000..414a9379c8 --- /dev/null +++ b/gnu/system/examples/bare-hurd.tmpl @@ -0,0 +1,54 @@ +;; -*-scheme-*- + +;; This is an operating system configuration template +;; for a "bare bones" setup, with no X11 display server. + +;; To build a disk image for a virtual machine, do +;; +;; ./pre-inst-env guix system disk-image --target=i586-pc-gnu \ +;; gnu/system/examples/bare-hurd.tmpl +;; +;; You may run it like so +;; +;; guix environment --ad-hoc qemu -- qemu-system-i386 -enable-kvm -m 512M \ +;; -device rtl8139,netdev=net0 -netdev user,id=net0,hostfwd=tcp:127.0.0.1:10022-:2222 \ +;; -snapshot -hda <the-image> +;; +;; and use it like +;; +;; ssh -p 10022 root@localhost +;; guix build -e '(@@ (gnu packages commencement) gnu-make-boot0)' +;; +;; or even (if you use --image-size=3G) +;; +;; guix build hello + +(use-modules (gnu) (gnu system hurd) (guix utils)) +(use-service-modules ssh) +(use-package-modules ssh) + +(define %hurd-os + (operating-system + (inherit %hurd-default-operating-system) + (bootloader (bootloader-configuration + (bootloader grub-minimal-bootloader) + (target "/dev/sdX"))) + (file-systems (cons (file-system + (device (file-system-label "my-root")) + (mount-point "/") + (type "ext2")) + %base-file-systems)) + (host-name "guixygnu") + (timezone "Europe/Amsterdam") + (packages (cons openssh-sans-x %base-packages/hurd)) + (services (cons (service openssh-service-type + (openssh-configuration + (openssh openssh-sans-x) + (use-pam? #f) + (port-number 2222) + (permit-root-login #t) + (allow-empty-passwords? #t) + (password-authentication? #t))) + %base-services/hurd)))) + +%hurd-os diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index b41f66e943..0f94577760 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> +;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,7 +22,10 @@ #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-9 gnu) #:use-module (guix records) #:use-module (gnu system uuid) @@ -38,6 +42,9 @@ file-system-needed-for-boot? file-system-flags file-system-options + file-system-options->alist + alist->file-system-options + file-system-mount? file-system-check? file-system-create-mount-point? @@ -45,6 +52,8 @@ file-system-location file-system-type-predicate + btrfs-subvolume? + btrfs-store-subvolume-file-name file-system-label file-system-label? @@ -251,6 +260,33 @@ UUID-TYPE, a symbol such as 'dce or 'iso9660." ((? string?) device))) +(define (file-system-options->alist string) + "Translate the option string format of a <file-system> record into an +association list of options or option/value pairs." + (if string + (let ((options (string-split string #\,))) + (map (lambda (param) + (let ((=index (string-index param #\=))) + (if =index + (cons (string-take param =index) + (string-drop param (1+ =index))) + param))) + options)) + '())) + +(define (alist->file-system-options options) + "Return the string representation of OPTIONS, an association list. The +string obtained can be used as the option field of a <file-system> record." + (if (null? options) + #f + (string-join (map (match-lambda + ((key . value) + (string-append key "=" value)) + (key + key)) + options) + ","))) + (define (file-system-needed-for-boot? fs) "Return true if FS has the 'needed-for-boot?' flag set, or if it holds the store--e.g., if FS is the root file system." @@ -535,4 +571,54 @@ system has the given TYPE." (lambda (fs) (string=? (file-system-type fs) type))) + +;;; +;;; Btrfs specific helpers. +;;; + +(define (btrfs-subvolume? fs) + "Predicate to check if FS, a file-system object, is a Btrfs subvolume." + (and-let* ((btrfs-file-system? (string= "btrfs" (file-system-type fs))) + (option-keys (map (match-lambda + ((key . value) key) + (key key)) + (file-system-options->alist + (file-system-options fs))))) + (find (cut string-prefix? "subvol" <>) option-keys))) + +(define (btrfs-store-subvolume-file-name file-systems) + "Return the subvolume file name within the Btrfs top level onto which the +store is located, else #f." + + (define (prepend-slash/maybe s) + (if (string=? "/" (string-take s 1)) + s + (string-append "/" s))) + + (define (file-name-depth file-name) + (length (string-tokenize file-name %not-slash))) + + (and-let* ((btrfs-subvolume-fs (filter btrfs-subvolume? file-systems)) + (btrfs-subvolume-fs* + (sort btrfs-subvolume-fs + (lambda (fs1 fs2) + (> (file-name-depth (file-system-mount-point fs1)) + (file-name-depth (file-system-mount-point fs2)))))) + (store-subvolume-fs + (find (lambda (fs) (file-prefix? (file-system-mount-point fs) + (%store-prefix))) + btrfs-subvolume-fs*)) + (options (file-system-options->alist + (file-system-options store-subvolume-fs)))) + ;; XXX: Deriving the subvolume name based from a subvolume ID is not + ;; supported, as we'd need to query the actual file system. + (or (and=> (assoc-ref options "subvol") prepend-slash/maybe) + ;; FIXME: Use &fix-hint once it no longer pulls in (guix utils). + (raise (condition + (&message + (message "The store is on a Btrfs subvolume, but the \ +subvolume name is unknown. +Hint: Use the \"subvol\" Btrfs file system option."))))))) + + ;;; file-systems.scm ends here diff --git a/gnu/system/hurd.scm b/gnu/system/hurd.scm index 58bfdf88f6..2205def577 100644 --- a/gnu/system/hurd.scm +++ b/gnu/system/hurd.scm @@ -21,6 +21,7 @@ #:use-module (guix gexp) #:use-module (guix profiles) #:use-module (guix utils) + #:use-module (gnu bootloader) #:use-module (gnu bootloader grub) #:use-module (gnu packages admin) #:use-module (gnu packages base) @@ -31,195 +32,74 @@ #:use-module (gnu packages guile-xyz) #:use-module (gnu packages hurd) #:use-module (gnu packages less) + #:use-module (gnu services) + #:use-module (gnu services base) + #:use-module (gnu services hurd) + #:use-module (gnu services shepherd) + #:use-module (gnu system) + #:use-module (gnu system shadow) #:use-module (gnu system vm) - #:export (cross-hurd-image)) + #:export (%base-packages/hurd + %base-services/hurd + %hurd-default-operating-system + %hurd-default-operating-system-kernel)) ;;; Commentary: ;;; -;;; This module provides tools to (cross-)build GNU/Hurd virtual machine -;;; images. +;;; This module provides system-specifics for the GNU/Hurd operating system +;;; and virtual machine. ;;; ;;; Code: -;; XXX: Surely this belongs in (guix profiles), but perhaps we need high-level -;; <profile> objects so one can specify hooks, etc.? -(define-gexp-compiler (compile-manifest (manifest - (@@ (guix profiles) <manifest>)) - system target) - "Lower MANIFEST as a profile." - (profile-derivation manifest - #:system system - #:target target)) +(define %hurd-default-operating-system-kernel + (if (hurd-system?) + gnumach + ;; A cross-built GNUmach does not work + (with-parameters ((%current-system "i686-linux") + (%current-target-system #f)) + gnumach))) (define %base-packages/hurd (list hurd bash coreutils file findutils grep sed guile-3.0 guile-colorized guile-readline - net-base inetutils less which)) - -(define* (cross-hurd-image #:key (hurd hurd) (gnumach gnumach)) - "Return a cross-built GNU/Hurd image." - - (define (cross-built thing) - (with-parameters ((%current-target-system "i586-pc-gnu")) - thing)) - - (define (cross-built-entry entry) - (manifest-entry - (inherit entry) - (item (cross-built (manifest-entry-item entry))) - (dependencies (map cross-built-entry - (manifest-entry-dependencies entry))))) - - (define system-profile - (map-manifest-entries cross-built-entry - (packages->manifest %base-packages/hurd))) - - (define grub.cfg - (let ((hurd (cross-built hurd)) - (mach (with-parameters ((%current-system "i686-linux")) - gnumach)) - (libc (cross-libc "i586-pc-gnu"))) - (computed-file "grub.cfg" - #~(call-with-output-file #$output - (lambda (port) - (format port " -set timeout=2 -search.file ~a/boot/gnumach - -menuentry \"GNU\" { - multiboot ~a/boot/gnumach root=device:hd0s1 - module ~a/hurd/ext2fs.static ext2fs \\ - --multiboot-command-line='${kernel-command-line}' \\ - --host-priv-port='${host-port}' \\ - --device-master-port='${device-port}' \\ - --exec-server-task='${exec-task}' -T typed '${root}' \\ - '$(task-create)' '$(task-resume)' - module ~a/lib/ld.so.1 exec ~a/hurd/exec '$(exec-task=task-create)' -}\n" - #+mach #+mach #+hurd - #+libc #+hurd)))))) - - (define fstab - (plain-file "fstab" - "# This file was generated from your Guix configuration. Any changes -# will be lost upon reboot or reconfiguration. - -/dev/hd0s1 / ext2 defaults -")) - - (define passwd - (plain-file "passwd" - "root:x:0:0:root:/root:/bin/sh -guixbuilder:x:1:1:guixbuilder:/var/empty:/bin/no-sh -")) - - (define group - (plain-file "group" - "guixbuild:x:1:guixbuilder -")) - - (define shadow - (plain-file "shadow" - "root::0:0:0:0::: -")) - - (define etc-profile - (plain-file "profile" - "\ -export PS1='\\u@\\h\\$ ' - -GUIX_PROFILE=\"/run/current-system/profile\" -. \"$GUIX_PROFILE/etc/profile\" - -GUIX_PROFILE=\"$HOME/.guix-profile\" -if [ -f \"$GUIX_PROFILE/etc/profile\" ]; then - . \"$GUIX_PROFILE/etc/profile\" -fi\n")) - - (define hurd-directives - `((directory "/servers") - ,@(map (lambda (server) - `(file ,(string-append "/servers/" server))) - '("startup" "exec" "proc" "password" - "default-pager" "crash-dump-core" - "kill" "suspend")) - ("/servers/crash" -> "crash-dump-core") - (directory "/servers/socket") - (file "/servers/socket/1") - (file "/servers/socket/2") - (file "/servers/socket/16") - ("/servers/socket/local" -> "1") - ("/servers/socket/inet" -> "2") - ("/servers/socket/inet6" -> "16") - (directory "/boot") - ("/boot/grub.cfg" -> ,grub.cfg) ;XXX: not strictly needed - ("/hurd" -> ,(file-append (with-parameters ((%current-target-system - "i586-pc-gnu")) - hurd) - "/hurd")) - - ;; TODO: Create those during activation, eventually. - (directory "/root") - (file "/root/.guile" - ,(object->string - '(begin - (use-modules (ice-9 readline) (ice-9 colorized)) - (activate-readline) (activate-colorized)))) - (directory "/run") - (directory "/run/current-system") - ("/run/current-system/profile" -> ,system-profile) - ("/etc/profile" -> ,etc-profile) - ("/etc/fstab" -> ,fstab) - ("/etc/group" -> ,group) - ("/etc/passwd" -> ,passwd) - ("/etc/shadow" -> ,shadow) - (file "/etc/hostname" "guixygnu") - (file "/etc/resolv.conf" - "nameserver 10.0.2.3\n") - ("/etc/services" -> ,(file-append (with-parameters ((%current-target-system - "i586-pc-gnu")) - net-base) - "/etc/services")) - ("/etc/protocols" -> ,(file-append (with-parameters ((%current-target-system - "i586-pc-gnu")) - net-base) - "/etc/protocols")) - ("/etc/motd" -> ,(file-append (with-parameters ((%current-target-system - "i586-pc-gnu")) - hurd) - "/etc/motd")) - ("/etc/login" -> ,(file-append (with-parameters ((%current-target-system - "i586-pc-gnu")) - hurd) - "/etc/login")) - - - ;; XXX can we instead, harmlessly set _PATH_TTYS (from glibc) in runttys.c? - ("/etc/ttys" -> ,(file-append (with-parameters ((%current-target-system - "i586-pc-gnu")) - hurd) - "/etc/ttys")) - ("/bin/sh" -> ,(file-append (with-parameters ((%current-target-system - "i586-pc-gnu")) - bash) - "/bin/sh")))) - - (qemu-image #:file-system-type "ext2" - #:file-system-options '("-o" "hurd") - #:device-nodes 'hurd - #:inputs `(("system" ,system-profile) - ("grub.cfg" ,grub.cfg) - ("fstab" ,fstab) - ("passwd" ,passwd) - ("group" ,group) - ("etc-profile" ,etc-profile) - ("shadow" ,shadow)) - #:copy-inputs? #t - #:os system-profile - #:bootcfg-drv grub.cfg - #:bootloader grub-bootloader - #:register-closures? #f - #:extra-directives hurd-directives)) - -;; Return this thunk so one can type "guix build -f gnu/system/hurd.scm". -cross-hurd-image + net-base inetutils less shepherd which)) + +(define %base-services/hurd + (list (service hurd-console-service-type + (hurd-console-configuration (hurd hurd))) + (service hurd-getty-service-type (hurd-getty-configuration + (tty "tty1"))) + (service hurd-getty-service-type (hurd-getty-configuration + (tty "tty2"))) + (service static-networking-service-type + (list (static-networking (interface "lo") + (ip "127.0.0.1") + (requirement '()) + (provision '(loopback)) + (name-servers '("10.0.2.3"))))) + (syslog-service) + (service guix-service-type + (guix-configuration + (extra-options '("--disable-chroot" + "--disable-deduplication")))))) + +(define %hurd-default-operating-system + (operating-system + (kernel %hurd-default-operating-system-kernel) + (kernel-arguments '()) + (hurd hurd) + (bootloader (bootloader-configuration + (bootloader grub-minimal-bootloader) + (target "/dev/vda"))) + (initrd (lambda _ '())) + (initrd-modules (lambda _ '())) + (firmware '()) + (host-name "guixygnu") + (file-systems '()) + (packages %base-packages/hurd) + (timezone "GNUrope") + (name-service-switch #f) + (essential-services (hurd-default-essential-services this-operating-system)) + (pam-services '()) + (setuid-programs '()) + (sudoers-file #f))) diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 571b7af5f3..1bda25fd7f 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -43,6 +44,7 @@ #:use-module (gnu packages genimage) #:use-module (gnu packages guile) #:autoload (gnu packages gnupg) (guile-gcrypt) + #:use-module (gnu packages hurd) #:use-module (gnu packages linux) #:use-module (gnu packages mtools) #:use-module ((srfi srfi-1) #:prefix srfi-1:) @@ -54,6 +56,7 @@ #:export (esp-partition root-partition + hurd-disk-image efi-disk-image iso9660-image @@ -65,9 +68,17 @@ ;;; Images definitions. ;;; +;; This is the offset before the first partition. GRUB will install itself in +;; this post-MBR gap. +(define root-offset (* 512 2048)) + +;; Generic root partition label. +(define root-label "Guix_image") + (define esp-partition (partition (size (* 40 (expt 2 20))) + (offset root-offset) (label "GNU-ESP") ;cosmetic only ;; Use "vfat" here since this property is used when mounting. The actual ;; FAT-ness is based on file system size (16 in this case). @@ -78,11 +89,32 @@ (define root-partition (partition (size 'guess) - (label "Guix_image") + (label root-label) (file-system "ext4") (flags '(boot)) (initializer (gexp initialize-root-partition)))) +(define hurd-initialize-root-partition + #~(lambda* (#:rest args) + (apply initialize-root-partition + (append args + (list #:make-device-nodes + make-hurd-device-nodes))))) + +(define hurd-disk-image + (image + (format 'disk-image) + (target "i586-pc-gnu") + (partitions + (list (partition + (size 'guess) + (offset root-offset) + (label root-label) + (file-system "ext2") + (file-system-options '("-o" "hurd" "-O" "ext_attr")) + (flags '(boot)) + (initializer hurd-initialize-root-partition)))))) + (define efi-disk-image (image (format 'disk-image) @@ -117,6 +149,7 @@ 'make-partition-image'." #~'(#$@(list (partition-size partition)) #$(partition-file-system partition) + #$(partition-file-system-options partition) #$(partition-label partition) #$(and=> (partition-uuid partition) uuid-bytevector))) @@ -136,16 +169,32 @@ (with-imported-modules `(,@(source-module-closure '((gnu build vm) (gnu build image) + (gnu build hurd-boot) + (gnu build linux-boot) (guix store database)) #:select? not-config?) ((guix config) => ,(make-config.scm))) #~(begin (use-modules (gnu build vm) (gnu build image) + (gnu build hurd-boot) + (gnu build linux-boot) (guix store database) (guix build utils)) gexp* ...)))) +(define (root-partition? partition) + "Return true if PARTITION is the root partition, false otherwise." + (member 'boot (partition-flags partition))) + +(define (find-root-partition image) + "Return the root partition of the given IMAGE." + (srfi-1:find root-partition? (image-partitions image))) + +(define (root-partition-index image) + "Return the index of the root partition of the given IMAGE." + (1+ (srfi-1:list-index root-partition? (image-partitions image)))) + ;; ;; Disk image. @@ -221,8 +270,11 @@ used in the image." #:references-graphs '#$graph #:deduplicate? #f #:system-directory #$os + #:grub-efi #+grub-efi #:bootloader-package - #$(bootloader-package bootloader) + #+(bootloader-package bootloader) + #:bootloader-installer + #+(bootloader-installer bootloader) #:bootcfg #$bootcfg #:bootcfg-location #$(bootloader-configuration-file bootloader))))) @@ -232,7 +284,7 @@ used in the image." (type (partition-file-system partition)) (image-builder (with-imported-modules* - (let ((inputs '#$(list e2fsprogs dosfstools mtools))) + (let ((inputs '#+(list e2fsprogs dosfstools mtools))) (set-path-environment-variable "PATH" '("bin" "sbin") inputs) (make-partition-image #$(partition->gexp partition) #$output @@ -243,11 +295,17 @@ used in the image." ;; Return the genimage partition configuration for PARTITION. (let ((label (partition-label partition)) (dos-type (partition->dos-type partition)) - (image (partition-image partition))) + (image (partition-image partition)) + (offset (partition-offset partition))) #~(format #f "~/partition ~a { - ~/~/partition-type = ~a - ~/~/image = \"~a\" - ~/}" #$label #$dos-type #$image))) +~/~/partition-type = ~a +~/~/image = \"~a\" +~/~/offset = \"~a\" +~/}" + #$label + #$dos-type + #$image + #$offset))) (let* ((format (image-format image)) (image-type (format->image-type format)) @@ -269,9 +327,17 @@ image ~a { (let* ((substitutable? (image-substitutable? image)) (builder (with-imported-modules* - (let ((inputs '#$(list genimage coreutils findutils))) + (let ((inputs '#+(list genimage coreutils findutils)) + (bootloader-installer + #+(bootloader-disk-image-installer bootloader))) (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - (genimage #$(image->genimage-cfg image) #$output)))) + (genimage #$(image->genimage-cfg image) #$output) + ;; Install the bootloader directly on the disk-image. + (when bootloader-installer + (bootloader-installer + #+(bootloader-package bootloader) + #$(root-partition-index image) + (string-append #$output "/" #$genimage-name)))))) (image-dir (computed-file "image-dir" builder))) (computed-file name #~(symlink @@ -364,14 +430,6 @@ used in the image. " ;; Image creation. ;; -(define (root-partition? partition) - "Return true if PARTITION is the root partition, false otherwise." - (member 'boot (partition-flags partition))) - -(define (find-root-partition image) - "Return the root partition of the given IMAGE." - (srfi-1:find root-partition? (image-partitions image))) - (define (image->root-file-system image) "Return the IMAGE root partition file-system type." (let ((format (image-format image))) @@ -398,18 +456,18 @@ to OS. Also set the UUID and the size of the root partition." (string=? (file-system-mount-point fs) "/")) (operating-system-file-systems os))) - (let*-values (((partitions) (image-partitions base-image)) - ((root-partition other-partitions) - (srfi-1:partition root-partition? partitions))) - (image - (inherit base-image) - (operating-system os) - (partitions - (cons (partition - (inherit (car root-partition)) - (uuid (file-system-device root-file-system)) - (size (root-size base-image))) - other-partitions))))) + (image + (inherit base-image) + (operating-system os) + (partitions + (map (lambda (p) + (if (root-partition? p) + (partition + (inherit p) + (uuid (file-system-device root-file-system)) + (size (root-size base-image))) + p)) + (image-partitions base-image))))) (define (operating-system-for-image image) "Return an operating-system based on the one specified in IMAGE, but @@ -462,71 +520,61 @@ it can be used for bootloading." (type root-file-system-type)) file-systems-to-keep))))) -(define* (make-system-image image) +(define* (system-image image) "Return the derivation of IMAGE. It can be a raw disk-image or an ISO9660 image, depending on IMAGE format." (define substitutable? (image-substitutable? image)) (let* ((os (operating-system-for-image image)) (image* (image-with-os image os)) + (target (image-target image)) (register-closures? (has-guix-service-type? os)) (bootcfg (operating-system-bootcfg os)) (bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)))) - (case (image-format image) - ((disk-image) - (system-disk-image image* - #:bootcfg bootcfg - #:bootloader bootloader - #:register-closures? register-closures? - #:inputs `(("system" ,os) - ("bootcfg" ,bootcfg)))) - ((iso9660) - (system-iso9660-image image* - #:bootcfg bootcfg - #:bootloader bootloader - #:register-closures? register-closures? - #:inputs `(("system" ,os) - ("bootcfg" ,bootcfg)) - #:grub-mkrescue-environment - '(("MKRESCUE_SED_MODE" . "mbr_hfs"))))))) - -(define (find-image file-system-type) - "Find and return an image that could match the given FILE-SYSTEM-TYPE. This -is useful to adapt to interfaces written before the addition of the <image> -record." - ;; XXX: Add support for system and target here, or in the caller. + (with-parameters ((%current-target-system target)) + (case (image-format image) + ((disk-image) + (system-disk-image image* + #:bootcfg bootcfg + #:bootloader bootloader + #:register-closures? register-closures? + #:inputs `(("system" ,os) + ("bootcfg" ,bootcfg)))) + ((iso9660) + (system-iso9660-image + image* + #:bootcfg bootcfg + #:bootloader bootloader + #:register-closures? register-closures? + #:inputs `(("system" ,os) + ("bootcfg" ,bootcfg)) + ;; Make sure to use a mode that does no imply + ;; HFS+ tree creation that may fail with: + ;; + ;; "libisofs: FAILURE : Too much files to mangle, + ;; cannot guarantee unique file names" + ;; + ;; This happens if some limits are exceeded, see: + ;; https://lists.gnu.org/archive/html/grub-devel/2020-06/msg00048.html + #:grub-mkrescue-environment + '(("MKRESCUE_SED_MODE" . "mbr_only")))))))) + +(define (find-image file-system-type target) + "Find and return an image built that could match the given FILE-SYSTEM-TYPE, +built for TARGET. This is useful to adapt to interfaces written before the +addition of the <image> record." (match file-system-type ("iso9660" iso9660-image) - (_ efi-disk-image))) - -(define (system-image image) - "Wrap 'make-system-image' call, so that it is used only if the given IMAGE -is supported. Otherwise, fallback to image creation in a VM. This is -temporary and should be removed once 'make-system-image' is able to deal with -all types of images." - (define substitutable? (image-substitutable? image)) - (define volatile-root? (image-volatile-root? image)) + (_ (cond + ((and target + (hurd-triplet? target)) + hurd-disk-image) + (else + efi-disk-image))))) - (let* ((image-os (image-operating-system image)) - (image-root-filesystem-type (image->root-file-system image)) - (bootloader (bootloader-configuration-bootloader - (operating-system-bootloader image-os))) - (bootloader-name (bootloader-name bootloader)) - (size (image-size image)) - (format (image-format image))) - (mbegin %store-monad - (if (and (or (eq? bootloader-name 'grub) - (eq? bootloader-name 'extlinux)) - (eq? format 'disk-image)) - ;; Fallback to image creation in a VM when it is not yet supported - ;; by this module. - (system-disk-image-in-vm image-os - #:disk-image-size size - #:file-system-type image-root-filesystem-type - #:volatile? volatile-root? - #:substitutable? substitutable?) - (lower-object - (make-system-image image)))))) +;;; Local Variables: +;;; eval: (put 'maybe-with-target 'scheme-indent-function 1) +;;; End: ;;; image.scm ends here diff --git a/gnu/system/install.scm b/gnu/system/install.scm index fe49ffdb94..d0ff2e7c52 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -32,6 +32,7 @@ #:use-module ((guix packages) #:select (package-version)) #:use-module ((guix store) #:select (%store-prefix)) #:use-module (gnu installer) + #:use-module (gnu system locale) #:use-module (gnu services dbus) #:use-module (gnu services networking) #:use-module (gnu services shepherd) @@ -439,10 +440,12 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m ;; things needed by 'profile-derivation' to minimize the amount of ;; download. (service gc-root-service-type - (list bare-bones-os - glibc-utf8-locales - texinfo - guile-3.0)) + (append + (list bare-bones-os + glibc-utf8-locales + texinfo + guile-3.0) + %default-locale-libcs)) ;; Machines without Kernel Mode Setting (those with many old and ;; current AMD GPUs, SiS GPUs, ...) need uvesafb to show the GUI diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 3e483fd86c..f2b6b71b4d 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -141,7 +141,7 @@ (define* (expression->derivation-in-linux-vm name exp #:key - (system (%current-system)) target + (system (%current-system)) (linux linux-libre) initrd (qemu qemu-minimal) @@ -226,10 +226,11 @@ substitutable." (let* ((native-inputs '#+(list qemu (canonical-package coreutils))) - (linux (string-append #$linux "/" - #$(system-linux-image-file-name))) - (initrd #$initrd) - (loader #$loader) + (linux (string-append + #+linux "/" + #+(system-linux-image-file-name system))) + (initrd #+initrd) + (loader #+loader) (graphs '#$(match references-graphs (((graph-files . _) ...) graph-files) (_ #f))) @@ -249,8 +250,6 @@ substitutable." #:memory-size #$memory-size #:make-disk-image? #$make-disk-image? #:single-file-output? #$single-file-output? - #:target-arm32? #$(check target-arm32?) - #:target-aarch64? #$(check target-aarch64?) #:disk-image-format #$disk-image-format #:disk-image-size size #:references-graphs graphs)))))) @@ -258,7 +257,7 @@ substitutable." (gexp->derivation name builder ;; TODO: Require the "kvm" feature. #:system system - #:target target + #:target #f ;EXP is always executed natively #:env-vars env-vars #:guile-for-build guile-for-build #:references-graphs references-graphs @@ -318,11 +317,27 @@ system that is passed to 'populate-root-file-system'." (local-file (search-path %load-path "guix/store/schema.sql")))) + (define preserve-target + (if target + (lambda (obj) + (with-parameters ((%current-target-system target)) + obj)) + identity)) + + (define inputs* + (map (match-lambda + ((name thing) + `(,name ,(preserve-target thing))) + ((name thing output) + `(,name ,(preserve-target thing) ,output))) + inputs)) + (expression->derivation-in-linux-vm name (with-extensions gcrypt-sqlite3&co (with-imported-modules `(,@(source-module-closure '((gnu build vm) (gnu build bootloader) + (gnu build hurd-boot) (guix store database) (guix build utils)) #:select? not-config?) @@ -330,9 +345,10 @@ system that is passed to 'populate-root-file-system'." #~(begin (use-modules (gnu build bootloader) (gnu build vm) + ((gnu build hurd-boot) + #:select (make-hurd-device-nodes)) ((gnu build linux-boot) - #:select (make-essential-device-nodes - make-hurd-device-nodes)) + #:select (make-essential-device-nodes)) (guix store database) (guix build utils) (srfi srfi-26) @@ -346,7 +362,7 @@ system that is passed to 'populate-root-file-system'." (setlocale LC_ALL "en_US.utf8") (let ((inputs - '#$(append (list parted e2fsprogs dosfstools) + '#+(append (list parted e2fsprogs dosfstools) (map canonical-package (list sed grep coreutils findutils gawk)))) @@ -356,7 +372,7 @@ system that is passed to 'populate-root-file-system'." '#$(map (match-lambda ((name thing) thing) ((name thing output) `(,thing ,output))) - inputs))) + inputs*))) (set-path-environment-variable "PATH" '("bin" "sbin") inputs) @@ -368,7 +384,7 @@ system that is passed to 'populate-root-file-system'." #:closures graphs #:copy-closures? #$copy-inputs? #:register-closures? #$register-closures? - #:system-directory #$os + #:system-directory #$(preserve-target os) #:make-device-nodes #$(match device-nodes @@ -423,18 +439,17 @@ system that is passed to 'populate-root-file-system'." #:partitions partitions #:grub-efi grub-efi #:bootloader-package - #$(bootloader-package bootloader) - #:bootcfg #$bootcfg-drv + #+(bootloader-package bootloader) + #:bootcfg #$(preserve-target bootcfg-drv) #:bootcfg-location #$(bootloader-configuration-file bootloader) #:bootloader-installer - #$(bootloader-installer bootloader))))))) + #+(bootloader-installer bootloader))))))) #:system system - #:target target #:make-disk-image? #t #:disk-image-size disk-image-size #:disk-image-format disk-image-format - #:references-graphs inputs + #:references-graphs inputs* #:substitutable? substitutable?)) (define* (system-docker-image os @@ -751,6 +766,8 @@ environment with the store shared with the host. MAPPINGS is a list of (define* (system-qemu-image/shared-store os #:key + (system (%current-system)) + (target (%current-target-system)) full-boot? (disk-image-size (* (if full-boot? 500 30) (expt 2 20)))) "Return a derivation that builds a QEMU image of OS that shares its store @@ -771,6 +788,8 @@ bootloader refers to: OS kernel, initrd, bootloader data, etc." ;; This is more than needed (we only need the kernel, initrd, GRUB for its ;; font, and the background image), but it's hard to filter that. (qemu-image #:os os + #:system system + #:target target #:bootcfg-drv bootcfg #:bootloader (bootloader-configuration-bootloader (operating-system-bootloader os)) @@ -811,6 +830,8 @@ with '-virtfs' options for the host file systems listed in SHARED-FS." (define* (system-qemu-image/shared-store-script os #:key + (system (%current-system)) + (target (%current-target-system)) (qemu qemu) (graphic? #t) (memory-size 256) @@ -834,6 +855,8 @@ it is mostly useful when FULL-BOOT? is true." (mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?)) (image (system-qemu-image/shared-store os + #:system system + #:target target #:full-boot? full-boot? #:disk-image-size disk-image-size))) (define kernel-arguments @@ -841,7 +864,8 @@ it is mostly useful when FULL-BOOT? is true." #+@(operating-system-kernel-arguments os "/dev/vda1"))) (define qemu-exec - #~(list (string-append #$qemu "/bin/" #$(qemu-command (%current-system))) + #~(list #+(file-append qemu "/bin/" + (qemu-command (or target system))) #$@(if full-boot? #~() #~("-kernel" #$(operating-system-kernel-file os) @@ -858,7 +882,7 @@ it is mostly useful when FULL-BOOT? is true." #~(call-with-output-file #$output (lambda (port) (format port "#!~a~% exec ~a \"$@\"~%" - #$(file-append bash "/bin/sh") + #+(file-append bash "/bin/sh") (string-join #$qemu-exec " ")) (chmod port #o555)))) @@ -907,10 +931,11 @@ FORWARDINGS is a list of host-port/guest-port pairs." (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>) system target) - ;; XXX: SYSTEM and TARGET are ignored. (match vm (($ <virtual-machine> os qemu graphic? memory-size disk-image-size ()) (system-qemu-image/shared-store-script os + #:system system + #:target target #:qemu qemu #:graphic? graphic? #:memory-size memory-size @@ -923,6 +948,8 @@ FORWARDINGS is a list of host-port/guest-port pairs." "user,model=virtio-net-pci," (port-forwardings->qemu-options forwardings))))) (system-qemu-image/shared-store-script os + #:system system + #:target target #:qemu qemu #:graphic? graphic? #:memory-size memory-size |