diff options
Diffstat (limited to 'gnu/system')
| -rw-r--r-- | gnu/system/hurd.scm | 225 | ||||
| -rw-r--r-- | gnu/system/image.scm | 532 | ||||
| -rw-r--r-- | gnu/system/install.scm | 14 | ||||
| -rw-r--r-- | gnu/system/linux-initrd.scm | 8 | ||||
| -rw-r--r-- | gnu/system/locale.scm | 9 | ||||
| -rw-r--r-- | gnu/system/pam.scm | 10 | ||||
| -rw-r--r-- | gnu/system/shadow.scm | 5 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 260 |
8 files changed, 844 insertions, 219 deletions
diff --git a/gnu/system/hurd.scm b/gnu/system/hurd.scm new file mode 100644 index 0000000000..58bfdf88f6 --- /dev/null +++ b/gnu/system/hurd.scm @@ -0,0 +1,225 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> +;;; +;;; 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 system hurd) + #:use-module (guix gexp) + #:use-module (guix profiles) + #:use-module (guix utils) + #:use-module (gnu bootloader grub) + #:use-module (gnu packages admin) + #:use-module (gnu packages base) + #:use-module (gnu packages bash) + #:use-module (gnu packages cross-base) + #:use-module (gnu packages file) + #:use-module (gnu packages guile) + #:use-module (gnu packages guile-xyz) + #:use-module (gnu packages hurd) + #:use-module (gnu packages less) + #:use-module (gnu system vm) + #:export (cross-hurd-image)) + +;;; Commentary: +;;; +;;; This module provides tools to (cross-)build GNU/Hurd virtual machine +;;; images. +;;; +;;; 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 %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 diff --git a/gnu/system/image.scm b/gnu/system/image.scm new file mode 100644 index 0000000000..571b7af5f3 --- /dev/null +++ b/gnu/system/image.scm @@ -0,0 +1,532 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> +;;; +;;; 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 system image) + #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module (guix monads) + #:use-module (guix records) + #:use-module (guix store) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module ((guix self) #:select (make-config.scm)) + #:use-module (gnu bootloader) + #:use-module (gnu bootloader grub) + #:use-module (gnu image) + #:use-module (gnu services) + #:use-module (gnu services base) + #:use-module (gnu system) + #:use-module (gnu system file-systems) + #:use-module (gnu system uuid) + #:use-module (gnu system vm) + #:use-module (guix packages) + #:use-module (gnu packages base) + #:use-module (gnu packages bootloaders) + #:use-module (gnu packages cdrom) + #:use-module (gnu packages disk) + #:use-module (gnu packages gawk) + #:use-module (gnu packages genimage) + #:use-module (gnu packages guile) + #:autoload (gnu packages gnupg) (guile-gcrypt) + #:use-module (gnu packages linux) + #:use-module (gnu packages mtools) + #:use-module ((srfi srfi-1) #:prefix srfi-1:) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 match) + #:export (esp-partition + root-partition + + efi-disk-image + iso9660-image + + find-image + system-image)) + + +;;; +;;; Images definitions. +;;; + +(define esp-partition + (partition + (size (* 40 (expt 2 20))) + (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). + (file-system "vfat") + (flags '(esp)) + (initializer (gexp initialize-efi-partition)))) + +(define root-partition + (partition + (size 'guess) + (label "Guix_image") + (file-system "ext4") + (flags '(boot)) + (initializer (gexp initialize-root-partition)))) + +(define efi-disk-image + (image + (format 'disk-image) + (partitions (list esp-partition root-partition)))) + +(define iso9660-image + (image + (format 'iso9660) + (partitions + (list (partition + (size 'guess) + (label "GUIX_IMAGE") + (flags '(boot))))) + ;; XXX: Temporarily disable compression to speed-up the tests. + (compression? #f))) + + +;; +;; Helpers. +;; + +(define not-config? + ;; Select (guix …) and (gnu …) modules, except (guix config). + (match-lambda + (('guix 'config) #f) + (('guix rest ...) #t) + (('gnu rest ...) #t) + (rest #f))) + +(define (partition->gexp partition) + "Turn PARTITION, a <partition> object, into a list-valued gexp suitable for +'make-partition-image'." + #~'(#$@(list (partition-size partition)) + #$(partition-file-system partition) + #$(partition-label partition) + #$(and=> (partition-uuid partition) + uuid-bytevector))) + +(define gcrypt-sqlite3&co + ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs. + (srfi-1:append-map + (lambda (package) + (cons package + (match (package-transitive-propagated-inputs package) + (((labels packages) ...) + packages)))) + (list guile-gcrypt guile-sqlite3))) + +(define-syntax-rule (with-imported-modules* gexp* ...) + (with-extensions gcrypt-sqlite3&co + (with-imported-modules `(,@(source-module-closure + '((gnu build vm) + (gnu build image) + (guix store database)) + #:select? not-config?) + ((guix config) => ,(make-config.scm))) + #~(begin + (use-modules (gnu build vm) + (gnu build image) + (guix store database) + (guix build utils)) + gexp* ...)))) + + +;; +;; Disk image. +;; + +(define* (system-disk-image image + #:key + (name "disk-image") + bootcfg + bootloader + register-closures? + (inputs '())) + "Return as a file-like object, the disk-image described by IMAGE. Said +image can be copied on a USB stick as is. BOOTLOADER is the bootloader that +will be installed and configured according to BOOTCFG parameter. + +Raw images of the IMAGE partitions are first created. Then, genimage is used +to assemble the partition images into a disk-image without resorting to a +virtual machine. + +INPUTS is a list of inputs (as for packages). When REGISTER-CLOSURES? is +true, register INPUTS in the store database of the image so that Guix can be +used in the image." + + (define genimage-name "image") + + (define (image->genimage-cfg image) + ;; Return as a file-like object, the genimage configuration file + ;; describing the given IMAGE. + (define (format->image-type format) + ;; Return the genimage format corresponding to FORMAT. For now, only + ;; the hdimage format (raw disk-image) is supported. + (case format + ((disk-image) "hdimage") + (else + (raise (condition + (&message + (message + (format #f (G_ "Unsupported image type ~a~%.") format)))))))) + + (define (partition->dos-type partition) + ;; Return the MBR partition type corresponding to the given PARTITION. + ;; See: https://en.wikipedia.org/wiki/Partition_type. + (let ((flags (partition-flags partition))) + (cond + ((member 'esp flags) "0xEF") + (else "0x83")))) + + (define (partition-image partition) + ;; Return as a file-like object, an image of the given PARTITION. A + ;; directory, filled by calling the PARTITION initializer procedure, is + ;; first created within the store. Then, an image of this directory is + ;; created using tools such as 'mke2fs' or 'mkdosfs', depending on the + ;; partition file-system type. + (let* ((os (image-operating-system image)) + (schema (local-file (search-path %load-path + "guix/store/schema.sql"))) + (graph (match inputs + (((names . _) ...) + names))) + (root-builder + (with-imported-modules* + (let* ((initializer #$(partition-initializer partition))) + (sql-schema #$schema) + + ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be + ;; decoded. + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (setlocale LC_ALL "en_US.utf8") + + (initializer #$output + #:references-graphs '#$graph + #:deduplicate? #f + #:system-directory #$os + #:bootloader-package + #$(bootloader-package bootloader) + #:bootcfg #$bootcfg + #:bootcfg-location + #$(bootloader-configuration-file bootloader))))) + (image-root + (computed-file "partition-image-root" root-builder + #:options `(#:references-graphs ,inputs))) + (type (partition-file-system partition)) + (image-builder + (with-imported-modules* + (let ((inputs '#$(list e2fsprogs dosfstools mtools))) + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + (make-partition-image #$(partition->gexp partition) + #$output + #$image-root))))) + (computed-file "partition.img" image-builder))) + + (define (partition->config partition) + ;; Return the genimage partition configuration for PARTITION. + (let ((label (partition-label partition)) + (dos-type (partition->dos-type partition)) + (image (partition-image partition))) + #~(format #f "~/partition ~a { + ~/~/partition-type = ~a + ~/~/image = \"~a\" + ~/}" #$label #$dos-type #$image))) + + (let* ((format (image-format image)) + (image-type (format->image-type format)) + (partitions (image-partitions image)) + (partitions-config (map partition->config partitions)) + (builder + #~(begin + (let ((format (@ (ice-9 format) format))) + (call-with-output-file #$output + (lambda (port) + (format port + "\ +image ~a { +~/~a {} +~{~a~^~%~} +}~%" #$genimage-name #$image-type (list #$@partitions-config)))))))) + (computed-file "genimage.cfg" builder))) + + (let* ((substitutable? (image-substitutable? image)) + (builder + (with-imported-modules* + (let ((inputs '#$(list genimage coreutils findutils))) + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + (genimage #$(image->genimage-cfg image) #$output)))) + (image-dir (computed-file "image-dir" builder))) + (computed-file name + #~(symlink + (string-append #$image-dir "/" #$genimage-name) + #$output) + #:options `(#:substitutable? ,substitutable?)))) + + +;; +;; ISO9660 image. +;; + +(define (has-guix-service-type? os) + "Return true if OS contains a service of the type GUIX-SERVICE-TYPE." + (not (not (srfi-1:find (lambda (service) + (eq? (service-kind service) guix-service-type)) + (operating-system-services os))))) + +(define* (system-iso9660-image image + #:key + (name "iso9660-image") + bootcfg + bootloader + register-closures? + (inputs '()) + (grub-mkrescue-environment '())) + "Return as a file-like object a bootable, stand-alone iso9660 image. + +INPUTS is a list of inputs (as for packages). When REGISTER-CLOSURES? is +true, register INPUTS in the store database of the image so that Guix can be +used in the image. " + (define root-label + (match (image-partitions image) + ((partition) + (partition-label partition)))) + + (define root-uuid + (match (image-partitions image) + ((partition) + (uuid-bytevector (partition-uuid partition))))) + + (let* ((os (image-operating-system image)) + (bootloader (bootloader-package bootloader)) + (compression? (image-compression? image)) + (substitutable? (image-substitutable? image)) + (schema (local-file (search-path %load-path + "guix/store/schema.sql"))) + (graph (match inputs + (((names . _) ...) + names))) + (root-builder + (with-imported-modules* + (sql-schema #$schema) + + ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded. + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (setlocale LC_ALL "en_US.utf8") + + (initialize-root-partition #$output + #:references-graphs '#$graph + #:deduplicate? #f + #:system-directory #$os))) + (image-root + (computed-file "image-root" root-builder + #:options `(#:references-graphs ,inputs))) + (builder + (with-imported-modules* + (let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso + sed grep coreutils findutils gawk))) + (set-path-environment-variable "PATH" '("bin" "sbin") inputs) + (make-iso9660-image #$xorriso + '#$grub-mkrescue-environment + #$bootloader + #$bootcfg + #$os + #$image-root + #$output + #:references-graphs '#$graph + #:register-closures? #$register-closures? + #:compression? #$compression? + #:volume-id #$root-label + #:volume-uuid #$root-uuid))))) + (computed-file name builder + #:options `(#:references-graphs ,inputs + #:substitutable? ,substitutable?)))) + + +;; +;; 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))) + (if (eq? format 'iso9660) + "iso9660" + (partition-file-system (find-root-partition image))))) + +(define (root-size image) + "Return the root partition size of IMAGE." + (let* ((image-size (image-size image)) + (root-partition (find-root-partition image)) + (root-size (partition-size root-partition))) + (cond + ((and (eq? root-size 'guess) image-size) + image-size) + (else root-size)))) + +(define* (image-with-os base-image os) + "Return an image based on BASE-IMAGE but with the operating-system field set +to OS. Also set the UUID and the size of the root partition." + (define root-file-system + (srfi-1:find + (lambda (fs) + (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))))) + +(define (operating-system-for-image image) + "Return an operating-system based on the one specified in IMAGE, but +suitable for image creation. Assign an UUID to the root file-system, so that +it can be used for bootloading." + (define volatile-root? (image-volatile-root? image)) + + (define (root-uuid os) + ;; UUID of the root file system, computed in a deterministic fashion. + ;; This is what we use to locate the root file system so it has to be + ;; different from the user's own file system UUIDs. + (let ((type (if (eq? (image-format image) 'iso9660) + 'iso9660 + 'dce))) + (operating-system-uuid os type))) + + (let* ((root-file-system-type (image->root-file-system image)) + (base-os (image-operating-system image)) + (file-systems-to-keep + (srfi-1:remove + (lambda (fs) + (string=? (file-system-mount-point fs) "/")) + (operating-system-file-systems base-os))) + (format (image-format image)) + (os + (operating-system + (inherit base-os) + (initrd (lambda (file-systems . rest) + (apply (operating-system-initrd base-os) + file-systems + #:volatile-root? volatile-root? + rest))) + (bootloader (if (eq? format 'iso9660) + (bootloader-configuration + (inherit + (operating-system-bootloader base-os)) + (bootloader grub-mkrescue-bootloader)) + (operating-system-bootloader base-os))) + (file-systems (cons (file-system + (mount-point "/") + (device "/dev/placeholder") + (type root-file-system-type)) + file-systems-to-keep)))) + (uuid (root-uuid os))) + (operating-system + (inherit os) + (file-systems (cons (file-system + (mount-point "/") + (device uuid) + (type root-file-system-type)) + file-systems-to-keep))))) + +(define* (make-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)) + (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. + (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)) + + (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)))))) + +;;; image.scm ends here diff --git a/gnu/system/install.scm b/gnu/system/install.scm index d31ed9a197..fe49ffdb94 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -419,8 +419,7 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m ;; Having /bin/sh is a good idea. In particular it allows Tramp ;; connections to this system to work. (service special-files-service-type - `(("/bin/sh" ,(file-append (canonical-package bash) - "/bin/sh")))) + `(("/bin/sh" ,(file-append bash "/bin/sh")))) ;; Loopback device, needed by OpenSSH notably. (service static-networking-service-type @@ -443,7 +442,7 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m (list bare-bones-os glibc-utf8-locales texinfo - (canonical-package guile-2.2))) + guile-3.0)) ;; Machines without Kernel Mode Setting (those with many old and ;; current AMD GPUs, SiS GPUs, ...) need uvesafb to show the GUI @@ -471,12 +470,6 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m (label (string-append "GNU Guix installation " (package-version guix))) - ;; XXX: The AMD Radeon driver is reportedly broken, which makes kmscon - ;; non-functional: - ;; <https://lists.gnu.org/archive/html/guix-devel/2019-03/msg00441.html>. - ;; Thus, blacklist it. - (kernel-arguments '("quiet" "modprobe.blacklist=radeon")) - (file-systems ;; Note: the disk image build code overrides this root file system with ;; the appropriate one. @@ -521,7 +514,7 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m ;; Explicitly allow for empty passwords. (base-pam-services #:allow-empty-passwords? #t)) - (packages (cons* (canonical-package glibc) ;for 'tzselect' & co. + (packages (cons* glibc ;for 'tzselect' & co. parted gptfdisk ddrescue fontconfig font-dejavu font-gnu-unifont @@ -530,6 +523,7 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m mdadm dosfstools ;mkfs.fat, for the UEFI boot partition btrfs-progs + f2fs-tools jfsutils openssh ;we already have sshd, having ssh/scp can help wireless-tools iw wpa-supplicant-minimal iproute diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index dcc9b6b937..c43d53a210 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -36,7 +36,7 @@ #:use-module ((gnu packages xorg) #:select (console-setup xkeyboard-config)) #:use-module ((gnu packages make-bootstrap) - #:select (%guile-static-stripped)) + #:select (%guile-3.0-static-stripped)) #:use-module (gnu system file-systems) #:use-module (gnu system mapped-devices) #:use-module (gnu system keyboard) @@ -62,7 +62,7 @@ (define* (expression->initrd exp #:key - (guile %guile-static-stripped) + (guile %guile-3.0-static-stripped) (gzip gzip) (name "guile-initrd") (system (%current-system))) @@ -245,6 +245,9 @@ FILE-SYSTEMS." '()) ,@(if (find (file-system-type-predicate "jfs") file-systems) (list jfs_fsck/static) + '()) + ,@(if (find (file-system-type-predicate "f2fs") file-systems) + (list f2fs-fsck/static) '()))) (define-syntax vhash ;TODO: factorize @@ -275,6 +278,7 @@ FILE-SYSTEMS." ("btrfs" => '("btrfs")) ("iso9660" => '("isofs")) ("jfs" => '("jfs")) + ("f2fs" => '("f2fs" "crc32_generic")) (else '()))) (define (file-system-modules file-systems) diff --git a/gnu/system/locale.scm b/gnu/system/locale.scm index 8466d5b07d..689d238d1a 100644 --- a/gnu/system/locale.scm +++ b/gnu/system/locale.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -86,7 +86,7 @@ or #f on failure." #f))) (define* (single-locale-directory locales - #:key (libc (canonical-package glibc))) + #:key (libc glibc)) "Return a directory containing all of LOCALES for LIBC compiled. Because locale data formats are incompatible when switching from one libc to @@ -106,7 +106,7 @@ of LIBC." ;; 'localedef' executes 'gzip' to access compressed locale sources. (setenv "PATH" - (string-append #$gzip "/bin:" #$libc "/bin")) + (string-append #+gzip "/bin:" #+libc "/bin")) (setvbuf (current-output-port) 'line) (setvbuf (current-error-port) 'line) @@ -147,7 +147,8 @@ data format changes between libc versions." (define %default-locale-libcs ;; The libcs for which we build locales by default. - (list (canonical-package glibc))) + ;; List the previous and current libc to ease transition. + (list glibc-2.29 glibc)) (define %default-locale-definitions ;; Arbitrary set of locales that are built by default. They are here mostly diff --git a/gnu/system/pam.scm b/gnu/system/pam.scm index 85f75517b1..ad02586be8 100644 --- a/gnu/system/pam.scm +++ b/gnu/system/pam.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -367,7 +367,13 @@ strings or string-valued gexps." ;; Arguments include <pam-service> as well as procedures. (compose concatenate) - (extend extend-configuration))) + (extend extend-configuration) + (description + "Configure the Pluggable Authentication Modules (PAM) for all +the specified @dfn{PAM services}. Each PAM service corresponds to a program, +such as @command{login} or @command{sshd}, and specifies for instance how the +program may authenticate users or what it should do when opening a new +session."))) (define* (pam-root-service base #:key (transform identity)) "The \"root\" PAM service, which collects <pam-service> instance and turns diff --git a/gnu/system/shadow.scm b/gnu/system/shadow.scm index a6f1d806cf..a69339bc07 100644 --- a/gnu/system/shadow.scm +++ b/gnu/system/shadow.scm @@ -378,7 +378,10 @@ the /etc/skel directory for those." (service-extension user-processes-service-type (const '(user-homes))) (service-extension etc-service-type - etc-files))))) + etc-files))) + (description + "Ensure the specified user accounts and groups exist, as well +as each account home directory."))) (define (account-service accounts+groups skeletons) "Return a <service> that takes care of user accounts and user groups, with diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 6f81ac16ff..163e8b4e9c 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -77,7 +77,7 @@ system-qemu-image/shared-store system-qemu-image/shared-store-script - system-disk-image + system-disk-image-in-vm system-docker-image virtual-machine @@ -269,95 +269,6 @@ substitutable." (eq? (service-kind service) guix-service-type)) (operating-system-services os))))) -(define* (iso9660-image #:key - (name "iso9660-image") - file-system-label - file-system-uuid - (system (%current-system)) - (target (%current-target-system)) - (qemu qemu-minimal) - os - bootcfg-drv - bootloader - (register-closures? (has-guix-service-type? os)) - (inputs '()) - (grub-mkrescue-environment '()) - (substitutable? #t)) - "Return a bootable, stand-alone iso9660 image. - -INPUTS is a list of inputs (as for packages)." - (define schema - (and register-closures? - (local-file (search-path %load-path - "guix/store/schema.sql")))) - - (expression->derivation-in-linux-vm - name - (with-extensions gcrypt-sqlite3&co - (with-imported-modules `(,@(source-module-closure '((gnu build vm) - (guix store database) - (guix build utils)) - #:select? not-config?) - ((guix config) => ,(make-config.scm))) - #~(begin - (use-modules (gnu build vm) - (guix store database) - (guix build utils)) - - (sql-schema #$schema) - - ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded. - (setenv "GUIX_LOCPATH" - #+(file-append glibc-utf8-locales "/lib/locale")) - (setlocale LC_ALL "en_US.utf8") - - (let ((inputs - '#$(append (list parted e2fsprogs dosfstools xorriso) - (map canonical-package - (list sed grep coreutils findutils gawk)))) - - - (graphs '#$(match inputs - (((names . _) ...) - names))) - ;; This variable is unused but allows us to add INPUTS-TO-COPY - ;; as inputs. - (to-register - '#$(map (match-lambda - ((name thing) thing) - ((name thing output) `(,thing ,output))) - inputs))) - - (set-path-environment-variable "PATH" '("bin" "sbin") inputs) - (make-iso9660-image #$xorriso - '#$grub-mkrescue-environment - #$(bootloader-package bootloader) - #$bootcfg-drv - #$os - "/xchg/guixsd.iso" - #:register-closures? #$register-closures? - #:closures graphs - #:volume-id #$file-system-label - #:volume-uuid #$(and=> file-system-uuid - uuid-bytevector)))))) - #:system system - #:target target - - ;; Keep a local file system for /tmp so that we can populate it directly as - ;; root and have files owned by root. See <https://bugs.gnu.org/31752>. - #:file-systems (remove (lambda (file-system) - (string=? (file-system-mount-point file-system) - "/tmp")) - %linux-vm-file-systems) - - #:make-disk-image? #f - #:single-file-output? #t - #:references-graphs inputs - #:substitutable? substitutable? - - ;; Xorriso seems to be quite memory-hungry, so increase the VM's RAM size. - #:memory-size 512)) - (define* (qemu-image #:key (name "qemu-image") (system (%current-system)) @@ -366,6 +277,9 @@ INPUTS is a list of inputs (as for packages)." (disk-image-size 'guess) (disk-image-format "qcow2") (file-system-type "ext4") + (file-system-options '()) + (device-nodes 'linux) + (extra-directives '()) file-system-label file-system-uuid os @@ -379,7 +293,8 @@ INPUTS is a list of inputs (as for packages)." 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE. Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root partition; likewise FILE-SYSTEM-UUID, if true, specifies the UUID of the root -partition (a UUID object). +partition (a UUID object). FILE-SYSTEM-OPTIONS is an optional list of +command-line options passed to 'mkfs.ext4' (or similar). The returned image is a full disk image that runs OS-DERIVATION, with a GRUB installation that uses GRUB-CONFIGURATION as its configuration @@ -390,7 +305,13 @@ all of INPUTS into the image being built. When REGISTER-CLOSURES? is true, register INPUTS in the store database of the image so that Guix can be used in the image. By default, REGISTER-CLOSURES? is set to true only if a service of type GUIX-SERVICE-TYPE is present in the services definition of the operating -system." +system. + +When DEVICE-NODES is 'linux, create Linux-device block and character devices +under /dev. When it is 'hurd, do Hurdish things. + +EXTRA-DIRECTIVES is an optional list of directives to populate the root file +system that is passed to 'populate-root-file-system'." (define schema (and register-closures? (local-file (search-path %load-path @@ -408,6 +329,9 @@ system." #~(begin (use-modules (gnu build bootloader) (gnu build vm) + ((gnu build linux-boot) + #:select (make-essential-device-nodes + make-hurd-device-nodes)) (guix store database) (guix build utils) (srfi srfi-26) @@ -439,11 +363,17 @@ system." (((names . _) ...) names))) (initialize (root-partition-initializer + #:extra-directives '#$extra-directives #:closures graphs #:copy-closures? #$copy-inputs? #:register-closures? #$register-closures? #:system-directory #$os + #:make-device-nodes + #$(match device-nodes + ('linux #~make-essential-device-nodes) + ('hurd #~make-hurd-device-nodes)) + ;; Disable deduplication to speed things up, ;; and because it doesn't help much for a ;; single system generation. @@ -465,6 +395,7 @@ system." (uuid #$(and=> file-system-uuid uuid-bytevector)) (file-system #$file-system-type) + (file-system-options '#$file-system-options) (flags '(boot)) (initializer initialize))) ;; Append a small EFI System Partition for use with UEFI @@ -508,13 +439,17 @@ system." (define* (system-docker-image os #:key (name "guix-docker-image") - (register-closures? (has-guix-service-type? os))) + (register-closures? (has-guix-service-type? os)) + shared-network?) "Build a docker image. OS is the desired <operating-system>. NAME is the -base name to use for the output file. When REGISTER-CLOSURES? is true, -register the closure of OS with Guix in the resulting Docker image. By -default, REGISTER-CLOSURES? is set to true only if a service of type -GUIX-SERVICE-TYPE is present in the services definition of the operating -system." +base name to use for the output file. When SHARED-NETWORK? is true, assume +that the container will share network with the host and thus doesn't need a +DHCP client, nscd, and so on. + +When REGISTER-CLOSURES? is true, register the closure of OS with Guix in the +resulting Docker image. By default, REGISTER-CLOSURES? is set to true only if +a service of type GUIX-SERVICE-TYPE is present in the services definition of +the operating system." (define schema (and register-closures? (local-file (search-path %load-path @@ -531,7 +466,9 @@ system." (let ((os (operating-system-with-gc-roots - (containerized-operating-system os '()) + (containerized-operating-system os '() + #:shared-network? + shared-network?) (list boot-program))) (name (string-append name ".tar.gz")) (graph "system-graph")) @@ -604,62 +541,13 @@ system." ;;; VM and disk images. ;;; -(define* (operating-system-uuid os #:optional (type 'dce)) - "Compute UUID object with a deterministic \"UUID\" for OS, of the given -TYPE (one of 'iso9660 or 'dce). Return a UUID object." - ;; Note: For this to be deterministic, we must not hash things that contains - ;; (directly or indirectly) procedures, for example. That rules out - ;; anything that contains gexps, thunk or delayed record fields, etc. - - (define service-name - (compose service-type-name service-kind)) - - (define (file-system-digest fs) - ;; Return a hashable digest that does not contain 'dependencies' since - ;; this field can contain procedures. - (let ((device (file-system-device fs))) - (list (file-system-mount-point fs) - (file-system-type fs) - (file-system-device->string device) - (file-system-options fs)))) - - (if (eq? type 'iso9660) - (let ((pad (compose (cut string-pad <> 2 #\0) - number->string)) - (h (hash (map service-name (operating-system-services os)) - 3600))) - (bytevector->uuid - (string->iso9660-uuid - (string-append "1970-01-01-" - (pad (hash (operating-system-host-name os) 24)) "-" - (pad (quotient h 60)) "-" - (pad (modulo h 60)) "-" - (pad (hash (map file-system-digest - (operating-system-file-systems os)) - 100)))) - 'iso9660)) - (bytevector->uuid - (uint-list->bytevector - (list (hash (map file-system-digest - (operating-system-file-systems os)) - (- (expt 2 32) 1)) - (hash (operating-system-host-name os) - (- (expt 2 32) 1)) - (hash (map service-name (operating-system-services os)) - (- (expt 2 32) 1)) - (hash (map file-system-digest (operating-system-file-systems os)) - (- (expt 2 32) 1))) - (endianness little) - 4) - type))) - -(define* (system-disk-image os - #:key - (name "disk-image") - (file-system-type "ext4") - (disk-image-size (* 900 (expt 2 20))) - (volatile? #t) - (substitutable? #t)) +(define* (system-disk-image-in-vm os + #:key + (name "disk-image") + (file-system-type "ext4") + (disk-image-size (* 900 (expt 2 20))) + (volatile? #t) + (substitutable? #t)) "Return the derivation of a disk image of DISK-IMAGE-SIZE bytes of the system described by OS. Said image can be copied on a USB stick as is. When VOLATILE? is true, the root file system is made volatile; this is useful @@ -667,25 +555,14 @@ to USB sticks meant to be read-only. SUBSTITUTABLE? determines whether the returned derivation should be marked as substitutable." - (define normalize-label - ;; ISO labels are all-caps (case-insensitive), but since - ;; 'find-partition-by-label' is case-sensitive, make it all-caps here. - (if (string=? "iso9660" file-system-type) - string-upcase - identity)) - (define root-label - ;; Volume name of the root file system. - (normalize-label "Guix_image")) + "Guix_image") (define (root-uuid os) ;; UUID of the root file system, computed in a deterministic fashion. ;; This is what we use to locate the root file system so it has to be ;; different from the user's own file system UUIDs. - (operating-system-uuid os - (if (string=? file-system-type "iso9660") - 'iso9660 - 'dce))) + (operating-system-uuid os 'dce)) (define file-systems-to-keep (remove (lambda (fs) @@ -702,11 +579,7 @@ substitutable." #:volatile-root? volatile? rest))) - (bootloader (if (string=? "iso9660" file-system-type) - (bootloader-configuration - (inherit (operating-system-bootloader os)) - (bootloader grub-mkrescue-bootloader)) - (operating-system-bootloader os))) + (bootloader (operating-system-bootloader os)) ;; Force our own root file system. (We need a "/" file system ;; to call 'root-uuid'.) @@ -724,33 +597,20 @@ substitutable." (type file-system-type)) file-systems-to-keep)))) (bootcfg (operating-system-bootcfg os))) - (if (string=? "iso9660" file-system-type) - (iso9660-image #:name name - #:file-system-label root-label - #:file-system-uuid uuid - #:os os - #:bootcfg-drv bootcfg - #:bootloader (bootloader-configuration-bootloader - (operating-system-bootloader os)) - #:inputs `(("system" ,os) - ("bootcfg" ,bootcfg)) - #:grub-mkrescue-environment - '(("MKRESCUE_SED_MODE" . "mbr_hfs")) - #:substitutable? substitutable?) - (qemu-image #:name name - #:os os - #:bootcfg-drv bootcfg - #:bootloader (bootloader-configuration-bootloader - (operating-system-bootloader os)) - #:disk-image-size disk-image-size - #:disk-image-format "raw" - #:file-system-type file-system-type - #:file-system-label root-label - #:file-system-uuid uuid - #:copy-inputs? #t - #:inputs `(("system" ,os) - ("bootcfg" ,bootcfg)) - #:substitutable? substitutable?)))) + (qemu-image #:name name + #:os os + #:bootcfg-drv bootcfg + #:bootloader (bootloader-configuration-bootloader + (operating-system-bootloader os)) + #:disk-image-size disk-image-size + #:disk-image-format "raw" + #:file-system-type file-system-type + #:file-system-label root-label + #:file-system-uuid uuid + #:copy-inputs? #t + #:inputs `(("system" ,os) + ("bootcfg" ,bootcfg)) + #:substitutable? substitutable?))) (define* (system-qemu-image os #:key |