summaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/examples/bare-bones.tmpl3
-rw-r--r--gnu/system/examples/bare-hurd.tmpl54
-rw-r--r--gnu/system/file-systems.scm86
-rw-r--r--gnu/system/hurd.scm242
-rw-r--r--gnu/system/image.scm212
-rw-r--r--gnu/system/install.scm11
-rw-r--r--gnu/system/vm.scm69
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
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-30 13:38:43 +0000