From c0458011174ece1871ed980b07a092615e1a5d3d Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Mon, 2 Nov 2020 17:16:05 +0100 Subject: system: image: Introduce arm32-raw image type. * gnu/system/image.scm (arm32-disk-image, arm32-image-type): New variables. (arm64-disk-image): Inherit from arm32-disk-image. (arm64-image-type): Change name to 'arm64-raw. --- gnu/system/image.scm | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/image.scm b/gnu/system/image.scm index bc6610b14c..31bd110d0d 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -66,6 +66,7 @@ efi-disk-image iso9660-image + arm32-disk-image arm64-disk-image image-with-os @@ -73,6 +74,7 @@ qcow2-image-type iso-image-type uncompressed-iso-image-type + arm32-image-type arm64-image-type image-with-label @@ -126,10 +128,10 @@ (label "GUIX_IMAGE") (flags '(boot))))))) -(define arm64-disk-image +(define arm32-disk-image (image (format 'disk-image) - (target "aarch64-linux-gnu") + (target "arm-linux-gnueabihf") (partitions (list (partition (inherit root-partition) @@ -138,6 +140,11 @@ ;; fails. (volatile-root? #f))) +(define arm64-disk-image + (image + (inherit arm32-disk-image) + (target "aarch64-linux-gnu"))) + ;;; ;;; Images types. @@ -179,9 +186,14 @@ set to the given OS." (compression? #f)) <>)))) +(define arm32-image-type + (image-type + (name 'arm32-raw) + (constructor (cut image-with-os arm32-disk-image <>)))) + (define arm64-image-type (image-type - (name 'arm) + (name 'arm64-raw) (constructor (cut image-with-os arm64-disk-image <>)))) -- cgit v1.2.3 From 99efa804bd6df5de4760ec5974ed2297f1746366 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 3 Nov 2020 20:43:02 +0100 Subject: image: Allow offloading of "partition.img" and "image.iso" builds. This builds are extremely I/O-intensive so they'd rather not run on the head node of the build farm. * gnu/system/image.scm (system-disk-image, system-iso9660-image): Pass #:local-build? #f. --- gnu/system/image.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'gnu/system') diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 31bd110d0d..4075a26552 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -354,6 +354,9 @@ used in the image." #$output image-root))))) (computed-file "partition.img" image-builder + ;; Allow offloading so that this I/O-intensive process + ;; doesn't run on the build farm's head node. + #:local-build? #f #:options `(#:references-graphs ,inputs)))) (define (partition->config partition) @@ -488,6 +491,9 @@ used in the image. " #:volume-id #$root-label #:volume-uuid #$root-uuid))))) (computed-file name builder + ;; Allow offloading so that this I/O-intensive process + ;; doesn't run on the build farm's head node. + #:local-build? #f #:options `(#:references-graphs ,inputs #:substitutable? ,substitutable?)))) -- cgit v1.2.3 From 341f67991da4380485676987e24a3fac01403835 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 4 Nov 2020 23:10:53 +0100 Subject: vm: system-qemu-image: Fix type error, remove more actual file systems. * gnu/system/vm.scm (system-qemu-image)[file-systems-to-keep]: Check whether SOURCE is a string before calling 'string-prefix?'. Remove UUIDs and file system labels as well. --- gnu/system/vm.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 80a8618729..21d777a3fe 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -641,7 +641,10 @@ of the GNU system as described by OS." (let ((target (file-system-mount-point fs)) (source (file-system-device fs))) (or (string=? target "/") - (string-prefix? "/dev/" source)))) + (and (string? source) + (string-prefix? "/dev/" source)) + (uuid? source) + (file-system-label? source)))) (operating-system-file-systems os))) (define root-uuid -- cgit v1.2.3 From fe1cd098d2b83737e96f19438612291f5a9316e4 Mon Sep 17 00:00:00 2001 From: raingloom Date: Thu, 11 Jun 2020 14:09:57 +0200 Subject: services: Add yggdrasil-service-type. * gnu/services/networking.scm (yggdrasil-configuration) (yggdrasil-configuration?, yggdrasil-configuration-package) (yggdrasil-configuration-auto-conf, yggdrasil-configuration-log-level) (yggdrasil-configuration-log-to): New procedures. (yggdrasil-service-type): New variable. * doc/guix.texi: Document it. * gnu/system/examples/yggdrasil.tmpl: Provide example. Signed-off-by: Julien Lepiller --- doc/guix.texi | 96 ++++++++++++++++++++++++++++++ gnu/services/networking.scm | 117 ++++++++++++++++++++++++++++++++++++- gnu/system/examples/yggdrasil.tmpl | 60 +++++++++++++++++++ 3 files changed, 272 insertions(+), 1 deletion(-) create mode 100644 gnu/system/examples/yggdrasil.tmpl (limited to 'gnu/system') diff --git a/doc/guix.texi b/doc/guix.texi index b7f1bc1f00..217ed7a8a8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -82,6 +82,7 @@ Copyright @copyright{} 2020 Pierre Langlois@* Copyright @copyright{} 2020 pinoaffe@* Copyright @copyright{} 2020 André Batista@* Copyright @copyright{} 2020 Alexandru-Sergiu Marton@* +Copyright @copyright{} 2020 raingloom@* Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or @@ -16848,6 +16849,101 @@ Use this to add additional options and manage shared secrets out-of-band. @end table @end deftp +@defvr {Scheme Variable} yggdrasil-service-type +The service type for connecting to the @uref{https://yggdrasil-network.github.io/, +Yggdrasil network}, an early-stage implementation of a fully end-to-end +encrypted IPv6 network. + +@quotation +Yggdrasil provides name-independent routing with cryptographically generated +addresses. Static addressing means you can keep the same address as long as +you want, even if you move to a new location, or generate a new address (by +generating new keys) whenever you want. +@uref{https://yggdrasil-network.github.io/2018/07/28/addressing.html} +@end quotation + +Pass it a value of @code{yggdrasil-configuration} to connect it to public +peers and/or local peers. + +Here is an example using public peers and a static address. The static +signing and encryption keys are defined in @file{/etc/yggdrasil-private.conf} +(the default value for @code{config-file}). + +@lisp +;; part of the operating-system declaration +(service yggdrasil-service-type + (yggdrasil-configuration + (autoconf? #f) ;; use only the public peers + (json-config + ;; choose one from + ;; https://github.com/yggdrasil-network/public-peers + '((peers . #("tcp://1.2.3.4:1337")))) + ;; /etc/yggdrasil-private.conf is the default value for config-file + )) +@end lisp +@example +# sample content for /etc/yggdrasil-private.conf +@{ + # Your public encryption key. Your peers may ask you for this to put + # into their AllowedEncryptionPublicKeys configuration. + EncryptionPublicKey: 378dc5... + + # Your private encryption key. DO NOT share this with anyone! + EncryptionPrivateKey: 0777... + + # Your public signing key. You should not ordinarily need to share + # this with anyone. + SigningPublicKey: e1664... + + # Your private signing key. DO NOT share this with anyone! + SigningPrivateKey: 0589d... +@} +@end example +@end defvr + +@deftp {Data Type} yggdrasil-configuration +Data type representing the configuration of Yggdrasil. + +@table @asis +@item @code{package} (default: @code{yggdrasil}) +Package object of Yggdrasil. + +@item @code{json-config} (default: @code{'()}) +Contents of @file{/etc/yggdrasil.conf}. Will be merged with +@file{/etc/yggdrasil-private.conf}. Note that these settings are stored in +the Guix store, which is readable to all users. @strong{Do not store your +private keys in it}. See the output of @code{yggdrasil -genconf} for a +quick overview of valid keys and their default values. + +@item @code{autoconf?} (default: @code{#f}) +Whether to use automatic mode. Enabling it makes Yggdrasil use adynamic IP +and peer with IPv6 neighbors. + +@item @code{log-level} (default: @code{'info}) +How much detail to include in logs. Use @code{'debug} for more detail. + +@item @code{log-to} (default: @code{'stdout}) +Where to send logs. By default, the service logs standard output to +@file{/var/log/yggdrasil.log}. The alternative is @code{'syslog}, which +sends output to the running syslog service. + +@item @code{config-file} (default: @code{"/etc/yggdrasil-private.conf"}) +What HJSON file to load sensitive data from. This is where private keys +should be stored, which are necessary to specify if you don't want a +randomized address after each restart. Use @code{#f} to disable. Options +defined in this file take precedence over @code{json-config}. Use the output +of @code{yggdrasil -genconf} as a starting point. To configure a static +address, delete everything except these options: + +@itemize +@item @code{EncryptionPublicKey} +@item @code{EncryptionPrivateKey} +@item @code{SigningPublicKey} +@item @code{SigningPrivateKey} +@end itemize +@end table +@end deftp + @node Unattended Upgrades @subsection Unattended Upgrades diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm index 64f54e787f..9ec0f6a9ca 100644 --- a/gnu/services/networking.scm +++ b/gnu/services/networking.scm @@ -61,7 +61,9 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-43) #:use-module (ice-9 match) + #:use-module (json) #:re-export (static-networking-service static-networking-service-type) #:export (%facebook-host-aliases @@ -180,7 +182,17 @@ pagekite-configuration-kitesecret pagekite-configuration-frontend pagekite-configuration-kites - pagekite-configuration-extra-file)) + pagekite-configuration-extra-file + + yggdrasil-service-type + yggdrasil-configuration + yggdrasil-configuration? + yggdrasil-configuration-autoconf? + yggdrasil-configuration-config-file + yggdrasil-configuration-log-level + yggdrasil-configuration-log-to + yggdrasil-configuration-json-config + yggdrasil-configuration-package)) ;;; Commentary: ;;; @@ -1750,4 +1762,107 @@ table inet filter { "Run @url{https://pagekite.net/,PageKite}, a tunneling solution to make local servers publicly accessible on the web, even behind NATs and firewalls."))) + +;;; +;;; Yggdrasil +;;; + +(define-record-type* + yggdrasil-configuration + make-yggdrasil-configuration + yggdrasil-configuration? + (package yggdrasil-configuration-package + (default yggdrasil)) + (json-config yggdrasil-configuration-json-config + (default '())) + (config-file yggdrasil-config-file + (default "/etc/yggdrasil-private.conf")) + (autoconf? yggdrasil-configuration-autoconf? + (default #f)) + (log-level yggdrasil-configuration-log-level + (default 'info)) + (log-to yggdrasil-configuration-log-to + (default 'stdout))) + +(define (yggdrasil-configuration-file config) + (define (scm->yggdrasil-json x) + (define key-value? + dotted-list?) + (define (param->camel str) + (string-concatenate + (map + string-capitalize + (string-split str (cut eqv? <> #\-))))) + (cond + ((key-value? x) + (let ((k (car x)) + (v (cdr x))) + (cons + (if (symbol? k) + (param->camel (symbol->string k)) + k) + v))) + ((list? x) (map scm->yggdrasil-json x)) + ((vector? x) (vector-map scm->yggdrasil-json x)) + (else x))) + (computed-file + "yggdrasil.conf" + #~(call-with-output-file #$output + (lambda (port) + ;; it's HJSON, so comments are a-okay + (display "# Generated by yggdrasil-service\n" port) + (display #$(scm->json-string + (scm->yggdrasil-json + (yggdrasil-configuration-json-config config))) + port))))) + +(define (yggdrasil-shepherd-service config) + "Return a for yggdrasil with CONFIG." + (define yggdrasil-command + #~(append + (list (string-append + #$(yggdrasil-configuration-package config) + "/bin/yggdrasil") + "-useconffile" + #$(yggdrasil-configuration-file config)) + (if #$(yggdrasil-configuration-autoconf? config) + '("-autoconf") + '()) + (let ((extraconf #$(yggdrasil-config-file config))) + (if extraconf + (list "-extraconffile" extraconf) + '())) + (list "-loglevel" + #$(symbol->string + (yggdrasil-configuration-log-level config)) + "-logto" + #$(symbol->string + (yggdrasil-configuration-log-to config))))) + (list (shepherd-service + (documentation "Connect to the Yggdrasil mesh network") + (provision '(yggdrasil)) + (requirement '(networking)) + (start #~(make-forkexec-constructor + #$yggdrasil-command + #:log-file "/var/log/yggdrasil.log" + #:group "yggdrasil")) + (stop #~(make-kill-destructor))))) + +(define %yggdrasil-accounts + (list (user-group (name "yggdrasil") (system? #t)))) + +(define yggdrasil-service-type + (service-type + (name 'yggdrasil) + (description + "Connect to the Yggdrasil mesh network. +See yggdrasil -genconf for config options.") + (extensions + (list (service-extension shepherd-root-service-type + yggdrasil-shepherd-service) + (service-extension account-service-type + (const %yggdrasil-accounts)) + (service-extension profile-service-type + (compose list yggdrasil-configuration-package)))))) + ;;; networking.scm ends here diff --git a/gnu/system/examples/yggdrasil.tmpl b/gnu/system/examples/yggdrasil.tmpl new file mode 100644 index 0000000000..be80bf4de9 --- /dev/null +++ b/gnu/system/examples/yggdrasil.tmpl @@ -0,0 +1,60 @@ +;; This is an operating system configuration template +;; for a "bare bones" setup, with no X11 display server. + +(use-modules (gnu)) +(use-service-modules networking ssh) +(use-package-modules admin curl networking screen) + +(operating-system + (host-name "ruby-guard-5545") + (timezone "Europe/Budapest") + (locale "en_US.utf8") + + ;; Boot in "legacy" BIOS mode, assuming /dev/sdX is the + ;; target hard disk, and "my-root" is the label of the target + ;; root file system. + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/sdX"))) + (file-systems (cons (file-system + (device (file-system-label "my-root")) + (mount-point "/") + (type "ext4")) + %base-file-systems)) + (users (cons (user-account + (name "alice") + (comment "Bob's sister") + (group "users") + ;; adding her to the yggdrasil group means she can use + ;; yggdrasilctl to modify the configuration + (supplementary-groups '("wheel" "yggdrasil"))) + %base-user-accounts)) + + ;; Globally-installed packages. + (packages (cons* screen curl %base-packages)) + + ;; Add services to the baseline: a DHCP client and + ;; an SSH server. + ;; If you add an /etc/yggdrasil-private.conf, you can log in to ssh + ;; using your Yggdrasil IPv6 address from another machine running Yggdrasil. + ;; Alternatively, the client can sit behind a router that has Yggdrasil. + ;; That file is specifically _not_ handled by Guix, because we don't want its + ;; contents to sit in the world-readable /gnu/store. + (services + (append + (list + (service dhcp-client-service-type) + (service yggdrasil-service-type + (yggdrasil-configuration + (log-to 'stdout) + (log-level 'debug) + (autoconf? #f) + (json-config + ;; choose a few from + ;; https://github.com/yggdrasil-network/public-peers + '((peers . #("tcp://1.2.3.4:1337")))) + (config-file #f))) + (service openssh-service-type + (openssh-configuration + (port-number 2222)))) + %base-services))) -- cgit v1.2.3 From e87471dc510bc393e3306fba86f919dc6bf89b7b Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Thu, 5 Nov 2020 13:14:23 +0100 Subject: uuid: Add support for bcachefs. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/system/uuid.scm (string->bcachefs-uuid): New exported procedure. (%uuid-parsers, %uuid-printers): Add the ‘bcachefs’ file system type. --- gnu/system/uuid.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm index c8352f4933..f4c4be6e2b 100644 --- a/gnu/system/uuid.scm +++ b/gnu/system/uuid.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2017 Danny Milosavljevic -;;; Copyright © 2019 Tobias Geerinckx-Rice +;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. ;;; @@ -42,6 +42,7 @@ string->ext2-uuid string->ext3-uuid string->ext4-uuid + string->bcachefs-uuid string->btrfs-uuid string->fat-uuid string->jfs-uuid @@ -236,6 +237,7 @@ ISO9660 UUID representation." (define string->ext2-uuid string->dce-uuid) (define string->ext3-uuid string->dce-uuid) (define string->ext4-uuid string->dce-uuid) +(define string->bcachefs-uuid string->dce-uuid) (define string->btrfs-uuid string->dce-uuid) (define string->jfs-uuid string->dce-uuid) @@ -251,14 +253,14 @@ ISO9660 UUID representation." (define %uuid-parsers (vhashq - ('dce 'ext2 'ext3 'ext4 'btrfs 'jfs 'luks => string->dce-uuid) + ('dce 'ext2 'ext3 'ext4 'bcachefs 'btrfs 'jfs 'luks => string->dce-uuid) ('fat32 'fat16 'fat => string->fat-uuid) ('ntfs => string->ntfs-uuid) ('iso9660 => string->iso9660-uuid))) (define %uuid-printers (vhashq - ('dce 'ext2 'ext3 'ext4 'btrfs 'jfs 'luks => dce-uuid->string) + ('dce 'ext2 'ext3 'ext4 'bcachefs 'btrfs 'jfs 'luks => dce-uuid->string) ('iso9660 => iso9660-uuid->string) ('fat32 'fat16 'fat => fat-uuid->string) ('ntfs => ntfs-uuid->string))) -- cgit v1.2.3 From f9926c071fac87925564b304c74dd6f2840b60a2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 8 Nov 2020 14:27:35 +0100 Subject: image: Offload "disk-image" derivations. This is a followup to 99efa804bd6df5de4760ec5974ed2297f1746366. * gnu/system/image.scm (system-disk-image): Pass #:local-build? #f to 'computed-file'. --- gnu/system/image.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'gnu/system') diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 4075a26552..81152f0fc4 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -414,6 +414,7 @@ image ~a { out-image)) (convert-disk-image out-image '#$format #$output))))) (computed-file name builder + #:local-build? #f ;too I/O-intensive #:options `(#:substitutable? ,substitutable?)))) -- cgit v1.2.3 From 4e9ded6d276bf488593f53a84b6e50771abac13f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 8 Nov 2020 14:27:35 +0100 Subject: image: Offload "disk-image" derivations. This is a followup to 99efa804bd6df5de4760ec5974ed2297f1746366. * gnu/system/image.scm (system-disk-image): Pass #:local-build? #f to 'computed-file'. --- gnu/system/image.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'gnu/system') diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 4075a26552..81152f0fc4 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -414,6 +414,7 @@ image ~a { out-image)) (convert-disk-image out-image '#$format #$output))))) (computed-file name builder + #:local-build? #f ;too I/O-intensive #:options `(#:substitutable? ,substitutable?)))) -- cgit v1.2.3 From 7a20c1676a8421f3ac06a2634a27c2837293df0b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 10 Nov 2020 12:20:09 +0100 Subject: vm: 'system-qemu-image' forces the use of i386/BIOS GRUB. Fixes . Reported by Maxim Cournoyer . * gnu/system/vm.scm (system-qemu-image): Add 'bootloader' field to OS. --- gnu/system/vm.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 21d777a3fe..c9580f6e7f 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -655,7 +655,14 @@ of the GNU system as described by OS." 'dce))) - (let* ((os (operating-system (inherit os) + (let* ((os (operating-system + (inherit os) + + ;; As in 'virtualized-operating-system', use BIOS-style GRUB. + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/vda"))) + ;; Assume we have an initrd with the whole QEMU shebang. ;; Force our own root file system. Refer to it by UUID so that -- cgit v1.2.3 From 000e7a0abc747ab6eb4fc23e80e4e9fbe8e75781 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 10 Nov 2020 21:49:15 +0100 Subject: vm: expression->derivation-in-linux-vm: Run in a UTF-8 locale. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Add calls to 'setenv' and 'setlocale'. --- gnu/system/vm.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index c9580f6e7f..07a59a3cd2 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -224,6 +224,12 @@ substitutable." (use-modules (guix build utils) (gnu build vm)) + ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded + ;; by 'estimated-partition-size' below. + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (setlocale LC_ALL "en_US.utf8") + (let* ((native-inputs '#+(list qemu (canonical-package coreutils))) (linux (string-append -- cgit v1.2.3 From 1ec366cdfd92e4913ab7d1096520410272e3c89c Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Tue, 10 Nov 2020 23:09:59 -0500 Subject: image: Remove conflicting user-provided EFI file system. When the image type is "raw" or derived from it (such as "qcow2"), an ESP partition and file system is already added by the image generator. If a conflicting user-provided EFI file system is provided, it causes the boot to fail, as happens for the lightweight-desktop.tmpl and desktop.tmpl templates under gnu/system/examples. * gnu/system/image.scm (operating-system-for-image): Remove file systems whose mount point is "/boot/efi". --- gnu/system/image.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'gnu/system') diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 81152f0fc4..4972d9067b 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -576,7 +576,9 @@ it can be used for bootloading." (file-systems-to-keep (srfi-1:remove (lambda (fs) - (string=? (file-system-mount-point fs) "/")) + (let ((mount-point (file-system-mount-point fs))) + (or (string=? mount-point "/") + (string=? mount-point "/boot/efi")))) (operating-system-file-systems base-os))) (format (image-format image)) (os -- cgit v1.2.3 From 19d4693939322e7e59bb33c0af3e202bd4027092 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Tue, 17 Nov 2020 14:09:57 -0500 Subject: system: vm: Remove unused system-disk-image-in-vm. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/system/vm.scm (system-disk-image-in-vm): Remove. Reported-by: Ludovic Courtès --- gnu/system/vm.scm | 72 ------------------------------------------------------- 1 file changed, 72 deletions(-) (limited to 'gnu/system') diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 07a59a3cd2..1afae6b4ed 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -77,7 +77,6 @@ system-qemu-image/shared-store system-qemu-image/shared-store-script - system-disk-image-in-vm system-docker-image virtual-machine @@ -563,77 +562,6 @@ the operating system." ;;; VM and disk images. ;;; -(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 -to USB sticks meant to be read-only. - -SUBSTITUTABLE? determines whether the returned derivation should be marked as -substitutable." - (define root-label - "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 'dce)) - - (define file-systems-to-keep - (remove (lambda (fs) - (string=? (file-system-mount-point fs) "/")) - (operating-system-file-systems os))) - - (let* ((os (operating-system (inherit os) - ;; Since this is meant to be used on real hardware, don't - ;; install QEMU networking or anything like that. Assume USB - ;; mass storage devices (usb-storage.ko) are available. - (initrd (lambda (file-systems . rest) - (apply (operating-system-initrd os) - file-systems - #:volatile-root? volatile? - rest))) - - (bootloader (operating-system-bootloader os)) - - ;; Force our own root file system. (We need a "/" file system - ;; to call 'root-uuid'.) - (file-systems (cons (file-system - (mount-point "/") - (device "/dev/placeholder") - (type file-system-type)) - file-systems-to-keep)))) - (uuid (root-uuid os)) - (os (operating-system - (inherit os) - (file-systems (cons (file-system - (mount-point "/") - (device uuid) - (type file-system-type)) - file-systems-to-keep)))) - (bootcfg (operating-system-bootcfg os))) - (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 (file-system-type "ext4") -- cgit v1.2.3 From 17d9a91e6b8bdd7709b536d34a1f2ef3fcff3b9d Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 27 Oct 2020 14:05:52 +0100 Subject: image: Add pinebook-pro support. * gnu/system/images/pinebook-pro.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. * gnu/ci.scm (%guix-system-images): Add pinebook-pro-barebones-raw-image. --- gnu/ci.scm | 4 ++- gnu/local.mk | 1 + gnu/system/images/pinebook-pro.scm | 66 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 70 insertions(+), 1 deletion(-) create mode 100644 gnu/system/images/pinebook-pro.scm (limited to 'gnu/system') diff --git a/gnu/ci.scm b/gnu/ci.scm index bf9952a450..a5afef91ae 100644 --- a/gnu/ci.scm +++ b/gnu/ci.scm @@ -57,6 +57,7 @@ #:use-module (gnu system install) #:use-module (gnu system images hurd) #:use-module (gnu system images pine64) + #:use-module (gnu system images pinebook-pro) #:use-module (gnu tests) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -205,7 +206,8 @@ SYSTEM." (define %guix-system-images (list hurd-barebones-qcow2-image - pine64-barebones-raw-image)) + pine64-barebones-raw-image + pinebook-pro-barebones-raw-image)) (define (image-jobs store system) "Return a list of jobs that build images for SYSTEM." diff --git a/gnu/local.mk b/gnu/local.mk index e728ed28d1..35369063f1 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -652,6 +652,7 @@ GNU_SYSTEM_MODULES = \ \ %D%/system/images/hurd.scm \ %D%/system/images/pine64.scm \ + %D%/system/images/pinebook-pro.scm \ \ %D%/machine.scm \ \ diff --git a/gnu/system/images/pinebook-pro.scm b/gnu/system/images/pinebook-pro.scm new file mode 100644 index 0000000000..b038e262cb --- /dev/null +++ b/gnu/system/images/pinebook-pro.scm @@ -0,0 +1,66 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (gnu system images pinebook-pro) + #:use-module (gnu bootloader) + #:use-module (gnu bootloader u-boot) + #:use-module (gnu image) + #:use-module (gnu packages linux) + #:use-module (gnu services) + #:use-module (gnu services base) + #:use-module (gnu system) + #:use-module (gnu system file-systems) + #:use-module (gnu system image) + #:use-module (srfi srfi-26) + #:export (pinebook-pro-barebones-os + pinebook-pro-image-type + pinebook-pro-barebones-raw-image)) + +(define pinebook-pro-barebones-os + (operating-system + (host-name "viso") + (timezone "Europe/Paris") + (locale "en_US.utf8") + (bootloader (bootloader-configuration + (bootloader u-boot-pinebook-pro-rk3399-bootloader) + (target "/dev/vda"))) + (initrd-modules '()) + (kernel linux-libre-arm64-generic) + (file-systems (cons (file-system + (device (file-system-label "my-root")) + (mount-point "/") + (type "ext4")) + %base-file-systems)) + (services (cons (service agetty-service-type + (agetty-configuration + (extra-options '("-L")) ; no carrier detect + (baud-rate "115200") + (term "vt100") + (tty "ttyS0"))) + %base-services)))) + +(define pinebook-pro-image-type + (image-type + (name 'pinebook-pro-raw) + (constructor (cut image-with-os arm64-disk-image <>)))) + +(define pinebook-pro-barebones-raw-image + (image + (inherit + (os->image pinebook-pro-barebones-os #:type pinebook-pro-image-type)) + (name 'pinebook-pro-barebones-raw-image))) -- cgit v1.2.3 From 788df2ecd62d5c2fc0d94928f45c947e6393e20b Mon Sep 17 00:00:00 2001 From: Mikhail Tsykalov Date: Fri, 6 Nov 2020 12:47:37 +0300 Subject: mapped-devices: Allow target to be list of strings. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/system/mapped-devices.scm (): Rename constructor to %mapped-device. [target]: Remove field. [targets]: New field. Adjust users. (mapped-device-compatibility-helper, mapped-device): New macros. (mapped-device-target): New deprecated procedure. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 3 + gnu/services/base.scm | 3 +- gnu/system.scm | 11 +-- gnu/system/linux-initrd.scm | 10 +-- gnu/system/mapped-devices.scm | 174 +++++++++++++++++++++++++----------------- 5 files changed, 119 insertions(+), 82 deletions(-) (limited to 'gnu/system') diff --git a/doc/guix.texi b/doc/guix.texi index c5a88b15fa..13fb4b1531 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -13780,6 +13780,9 @@ specifying @code{"my-partition"} leads to the creation of the @code{"/dev/mapper/my-partition"} device. For RAID devices of type @code{raid-device-mapping}, the full device name such as @code{"/dev/md0"} needs to be given. +@item targets +This list of strings specifies names of the resulting mapped devices in case +there are several. The format is identical to @var{target}. @item type This must be a @code{mapped-device-kind} object, which specifies how diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 029df5ac16..3fc4d5f885 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -298,7 +298,8 @@ FILE-SYSTEM." (define (mapped-device->shepherd-service-name md) "Return the symbol that denotes the shepherd service of MD, a ." (symbol-append 'device-mapping- - (string->symbol (mapped-device-target md)))) + (string->symbol (string-join + (mapped-device-targets md) "-")))) (define dependency->shepherd-service-name (match-lambda diff --git a/gnu/system.scm b/gnu/system.scm index b257ea0385..fcf3310fa3 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -475,9 +475,9 @@ marked as 'needed-for-boot'." (let ((device (file-system-device fs))) (if (string? device) ;title is 'device (filter (lambda (md) - (string=? (string-append "/dev/mapper/" - (mapped-device-target md)) - device)) + (any (cut string=? device <>) + (map (cut string-append "/dev/mapper" <>) + (mapped-device-targets md)))) (operating-system-mapped-devices os)) '()))) @@ -497,11 +497,12 @@ marked as 'needed-for-boot'." (define (mapped-device-users device file-systems) "Return the subset of FILE-SYSTEMS that use DEVICE." - (let ((target (string-append "/dev/mapper/" (mapped-device-target device)))) + (let ((targets (map (cut string-append "/dev/mapper/" <>) + (mapped-device-targets device)))) (filter (lambda (fs) (or (member device (file-system-dependencies fs)) (and (string? (file-system-device fs)) - (string=? (file-system-device fs) target)))) + (any (cut string=? (file-system-device fs) <>) targets)))) file-systems))) (define (operating-system-user-mapped-devices os) diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index b8a30c0abc..3e2f1282cc 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -195,11 +195,11 @@ upon error." (define device-mapping-commands ;; List of gexps to open the mapped devices. (map (lambda (md) - (let* ((source (mapped-device-source md)) - (target (mapped-device-target md)) - (type (mapped-device-type md)) - (open (mapped-device-kind-open type))) - (open source target))) + (let* ((source (mapped-device-source md)) + (targets (mapped-device-targets md)) + (type (mapped-device-type md)) + (open (mapped-device-kind-open type))) + (open source targets))) mapped-devices)) (define kodir diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm index 31c50c4e40..8b5aec983d 100644 --- a/gnu/system/mapped-devices.scm +++ b/gnu/system/mapped-devices.scm @@ -28,6 +28,7 @@ formatted-message &fix-hint &error-location)) + #:use-module (guix deprecation) #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu system uuid) @@ -42,10 +43,12 @@ #:use-module (srfi srfi-35) #:use-module (ice-9 match) #:use-module (ice-9 format) - #:export (mapped-device + #:export (%mapped-device + mapped-device mapped-device? mapped-device-source mapped-device-target + mapped-device-targets mapped-device-type mapped-device-location @@ -70,15 +73,36 @@ ;;; ;;; Code: -(define-record-type* mapped-device +(define-record-type* %mapped-device make-mapped-device mapped-device? (source mapped-device-source) ;string | list of strings - (target mapped-device-target) ;string + (targets mapped-device-targets) ;list of strings (type mapped-device-type) ; (location mapped-device-location (default (current-source-location)) (innate))) +(define-syntax mapped-device-compatibility-helper + (syntax-rules (target) + ((_ () (fields ...)) + (%mapped-device fields ...)) + ((_ ((target exp) rest ...) (others ...)) + (%mapped-device others ... + (targets (list exp)) + rest ...)) + ((_ (field rest ...) (others ...)) + (mapped-device-compatibility-helper (rest ...) + (others ... field))))) + +(define-syntax-rule (mapped-device fields ...) + "Build an record, automatically converting 'target' field +specifications to 'targets'." + (mapped-device-compatibility-helper (fields ...) ())) + +(define-deprecated (mapped-device-target md) + mapped-device-targets + (car (mapped-device-targets md))) + (define-record-type* mapped-device-kind make-mapped-device-kind mapped-device-kind? @@ -97,14 +121,14 @@ (shepherd-service-type 'device-mapping (match-lambda - (($ source target + (($ source targets ($ open close)) (shepherd-service - (provision (list (symbol-append 'device-mapping- (string->symbol target)))) + (provision (list (symbol-append 'device-mapping- (string->symbol (string-join targets "-"))))) (requirement '(udev)) (documentation "Map a device node using Linux's device mapper.") - (start #~(lambda () #$(open source target))) - (stop #~(lambda _ (not #$(close source target)))) + (start #~(lambda () #$(open source targets))) + (stop #~(lambda _ (not #$(close source targets)))) (respawn? #f)))))) (define (device-mapping-service mapped-device) @@ -162,48 +186,52 @@ option of @command{guix system}.\n") ;;; Common device mappings. ;;; -(define (open-luks-device source target) +(define (open-luks-device source targets) "Return a gexp that maps SOURCE to TARGET as a LUKS device, using 'cryptsetup'." (with-imported-modules (source-module-closure '((gnu build file-systems))) - #~(let ((source #$(if (uuid? source) - (uuid-bytevector source) - source))) - ;; XXX: 'use-modules' should be at the top level. - (use-modules (rnrs bytevectors) ;bytevector? - ((gnu build file-systems) - #:select (find-partition-by-luks-uuid))) - - ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the - ;; whole world inside the initrd (for when we're in an initrd). - (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup") - "open" "--type" "luks" - - ;; Note: We cannot use the "UUID=source" syntax here - ;; because 'cryptsetup' implements it by searching the - ;; udev-populated /dev/disk/by-id directory but udev may - ;; be unavailable at the time we run this. - (if (bytevector? source) - (or (let loop ((tries-left 10)) - (and (positive? tries-left) - (or (find-partition-by-luks-uuid source) - ;; If the underlying partition is - ;; not found, try again after - ;; waiting a second, up to ten - ;; times. FIXME: This should be - ;; dealt with in a more robust way. - (begin (sleep 1) - (loop (- tries-left 1)))))) - (error "LUKS partition not found" source)) - source) - - #$target))))) - -(define (close-luks-device source target) + (match targets + ((target) + #~(let ((source #$(if (uuid? source) + (uuid-bytevector source) + source))) + ;; XXX: 'use-modules' should be at the top level. + (use-modules (rnrs bytevectors) ;bytevector? + ((gnu build file-systems) + #:select (find-partition-by-luks-uuid))) + + ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the + ;; whole world inside the initrd (for when we're in an initrd). + (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup") + "open" "--type" "luks" + + ;; Note: We cannot use the "UUID=source" syntax here + ;; because 'cryptsetup' implements it by searching the + ;; udev-populated /dev/disk/by-id directory but udev may + ;; be unavailable at the time we run this. + (if (bytevector? source) + (or (let loop ((tries-left 10)) + (and (positive? tries-left) + (or (find-partition-by-luks-uuid source) + ;; If the underlying partition is + ;; not found, try again after + ;; waiting a second, up to ten + ;; times. FIXME: This should be + ;; dealt with in a more robust way. + (begin (sleep 1) + (loop (- tries-left 1)))))) + (error "LUKS partition not found" source)) + source) + + #$target))))))) + +(define (close-luks-device source targets) "Return a gexp that closes TARGET, a LUKS device." - #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup") - "close" #$target))) + (match targets + ((target) + #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup") + "close" #$target))))) (define* (check-luks-device md #:key needed-for-boot? @@ -235,36 +263,40 @@ option of @command{guix system}.\n") (close close-luks-device) (check check-luks-device))) -(define (open-raid-device sources target) +(define (open-raid-device sources targets) "Return a gexp that assembles SOURCES (a list of devices) to the RAID device TARGET (e.g., \"/dev/md0\"), using 'mdadm'." - #~(let ((sources '#$sources) - - ;; XXX: We're not at the top level here. We could use a - ;; non-top-level 'use-modules' form but that doesn't work when the - ;; code is eval'd, like the Shepherd does. - (every (@ (srfi srfi-1) every)) - (format (@ (ice-9 format) format))) - (let loop ((attempts 0)) - (unless (every file-exists? sources) - (when (> attempts 20) - (error "RAID devices did not show up; bailing out" - sources)) - - (format #t "waiting for RAID source devices~{ ~a~}...~%" - sources) - (sleep 1) - (loop (+ 1 attempts)))) - - ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole - ;; closure (80 MiB) in the initrd when a RAID device is needed for boot. - (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm") - "--assemble" #$target sources)))) - -(define (close-raid-device sources target) + (match targets + ((target) + #~(let ((sources '#$sources) + + ;; XXX: We're not at the top level here. We could use a + ;; non-top-level 'use-modules' form but that doesn't work when the + ;; code is eval'd, like the Shepherd does. + (every (@ (srfi srfi-1) every)) + (format (@ (ice-9 format) format))) + (let loop ((attempts 0)) + (unless (every file-exists? sources) + (when (> attempts 20) + (error "RAID devices did not show up; bailing out" + sources)) + + (format #t "waiting for RAID source devices~{ ~a~}...~%" + sources) + (sleep 1) + (loop (+ 1 attempts)))) + + ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole + ;; closure (80 MiB) in the initrd when a RAID device is needed for boot. + (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm") + "--assemble" #$target sources)))))) + +(define (close-raid-device sources targets) "Return a gexp that stops the RAID device TARGET." - #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm") - "--stop" #$target))) + (match targets + ((target) + #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm") + "--stop" #$target))))) (define raid-device-mapping ;; The type of RAID mapped devices. -- cgit v1.2.3 From a9a2fdaabcc78e7a54d9a6bcfa4ee3de308e9a90 Mon Sep 17 00:00:00 2001 From: Mikhail Tsykalov Date: Fri, 6 Nov 2020 12:47:38 +0300 Subject: mapped-devices: Add 'lvm-device-mapping'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * gnu/system/mapped-devices.scm (lvm-device-mapping, open-lvm-device, close-lvm-device): New variables. * gnu/tests/install.scm (%lvm-separate-home-os, %lvm-separate-home-os-source, %lvm-separate-home-installation-script, %test-lvm-separate-home-os): New variables. * gnu/system/linux-initrd.scm (raw-initrd): Add (srfi srfi-1) to initrd expression. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 25 ++++++++++++- gnu/system/linux-initrd.scm | 1 + gnu/system/mapped-devices.scm | 25 ++++++++++++- gnu/tests/install.scm | 87 +++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 134 insertions(+), 4 deletions(-) (limited to 'gnu/system') diff --git a/doc/guix.texi b/doc/guix.texi index 13fb4b1531..22102972a3 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -13758,7 +13758,6 @@ Guix extends this notion by considering any device or set of devices that are @dfn{transformed} in some way to create a new device; for instance, RAID devices are obtained by @dfn{assembling} several other devices, such as hard disks or partitions, into a new one that behaves as one partition. -Other examples, not yet implemented, are LVM logical volumes. Mapped devices are declared using the @code{mapped-device} form, defined as follows; for examples, see below. @@ -13771,7 +13770,8 @@ the system boots up. @item source This is either a string specifying the name of the block device to be mapped, such as @code{"/dev/sda3"}, or a list of such strings when several devices -need to be assembled for creating a new one. +need to be assembled for creating a new one. In case of LVM this is a +string specifying name of the volume group to be mapped. @item target This string specifies the name of the resulting mapped device. For @@ -13780,6 +13780,9 @@ specifying @code{"my-partition"} leads to the creation of the @code{"/dev/mapper/my-partition"} device. For RAID devices of type @code{raid-device-mapping}, the full device name such as @code{"/dev/md0"} needs to be given. +LVM logical volumes of type @code{lvm-device-mapping} need to +be specified as @code{"VGNAME-LVNAME"}. + @item targets This list of strings specifies names of the resulting mapped devices in case there are several. The format is identical to @var{target}. @@ -13803,6 +13806,11 @@ module for the appropriate RAID level to be loaded, such as @code{raid456} for RAID-4, RAID-5 or RAID-6, or @code{raid10} for RAID-10. @end defvr +@defvr {Scheme Variable} lvm-device-mapping +This defines LVM logical volume(s). Volume group is activated by +@command{vgchange} command from the package @code{lvm2}. +@end defvr + @cindex disk encryption @cindex LUKS The following example specifies a mapping from @file{/dev/sda3} to @@ -13860,6 +13868,19 @@ Note that the RAID level need not be given; it is chosen during the initial creation and formatting of the RAID device and is determined automatically later. +LVM logical volumes ``alpha'' and ``beta'' from volume group ``vg0'' can +be declared as follows: + +@lisp +(mapped-device + (source "vg0") + (target (list "vg0-alpha" "vg0-beta")) + (type lvm-device-mapping)) +@end lisp + +Devices @file{/dev/mapper/vg0-alpha} and @file{/dev/mapper/vg0-beta} can +then be used as the @code{device} of a @code{file-system} declaration +(@pxref{File Systems}). @node User Accounts @section User Accounts diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 3e2f1282cc..85e493fecb 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -217,6 +217,7 @@ upon error." (gnu system file-systems) ((guix build utils) #:hide (delete)) (guix build bournish) ;add the 'bournish' meta-command + (srfi srfi-1) ;for lvm-device-mapping (srfi srfi-26) ;; FIXME: The following modules are for diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm index 8b5aec983d..559c27bb28 100644 --- a/gnu/system/mapped-devices.scm +++ b/gnu/system/mapped-devices.scm @@ -36,7 +36,7 @@ #:autoload (gnu build linux-modules) (missing-modules) #:autoload (gnu packages cryptsetup) (cryptsetup-static) - #:autoload (gnu packages linux) (mdadm-static) + #:autoload (gnu packages linux) (mdadm-static lvm2-static) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -64,7 +64,8 @@ check-device-initrd-modules ;XXX: needs a better place luks-device-mapping - raid-device-mapping)) + raid-device-mapping + lvm-device-mapping)) ;;; Commentary: ;;; @@ -304,4 +305,24 @@ TARGET (e.g., \"/dev/md0\"), using 'mdadm'." (open open-raid-device) (close close-raid-device))) +(define (open-lvm-device source targets) + #~(and + (zero? (system* #$(file-append lvm2-static "/sbin/lvm") + "vgchange" "--activate" "ay" #$source)) + ; /dev/mapper nodes are usually created by udev, but udev may be unavailable at the time we run this. So we create them here. + (zero? (system* #$(file-append lvm2-static "/sbin/lvm") + "vgscan" "--mknodes")) + (every file-exists? (map (lambda (file) (string-append "/dev/mapper/" file)) + '#$targets)))) + + +(define (close-lvm-device source targets) + #~(zero? (system* #$(file-append lvm2-static "/sbin/lvm") + "vgchange" "--activate" "n" #$source))) + +(define lvm-device-mapping + (mapped-device-kind + (open open-lvm-device) + (close close-lvm-device))) + ;;; mapped-devices.scm ends here diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 2d62a873ca..71caa3a493 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -67,6 +67,7 @@ %test-btrfs-root-on-subvolume-os %test-jfs-root-os %test-f2fs-root-os + %test-lvm-separate-home-os %test-gui-installed-os %test-gui-installed-os-encrypted @@ -796,6 +797,92 @@ build (current-guix) and then store a couple of full system images.") (run-basic-test %encrypted-root-os command "encrypted-root-os" #:initialization enter-luks-passphrase))))) + +;;; +;;; Separate /home on LVM +;;; + +;; Since LVM support in guix currently doesn't allow root-on-LVM we use /home on LVM +(define-os-with-source (%lvm-separate-home-os %lvm-separate-home-os-source) + (use-modules (gnu) (gnu tests)) + + (operating-system + (host-name "separate-home-on-lvm") + (timezone "Europe/Paris") + (locale "en_US.utf8") + + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/vdb"))) + (kernel-arguments '("console=ttyS0")) + + (mapped-devices (list (mapped-device + (source "vg0") + (target "vg0-home") + (type lvm-device-mapping)))) + (file-systems (cons* (file-system + (device (file-system-label "root-fs")) + (mount-point "/") + (type "ext4")) + (file-system + (device "/dev/mapper/vg0-home") + (mount-point "/home") + (type "ext4") + (dependencies mapped-devices)) + %base-file-systems)) + (users %base-user-accounts) + (services (cons (service marionette-service-type + (marionette-configuration + (imported-modules '((gnu services herd) + (guix combinators))))) + %base-services)))) + +(define %lvm-separate-home-installation-script + "\ +. /etc/profile +set -e -x +guix --version + +export GUIX_BUILD_OPTIONS=--no-grafts +parted --script /dev/vdb mklabel gpt \\ + mkpart primary ext2 1M 3M \\ + mkpart primary ext2 3M 1.6G \\ + mkpart primary 1.6G 3.2G \\ + set 1 boot on \\ + set 1 bios_grub on +pvcreate /dev/vdb3 +vgcreate vg0 /dev/vdb3 +lvcreate -L 1.6G -n home vg0 +vgchange -ay +mkfs.ext4 -L root-fs /dev/vdb2 +mkfs.ext4 /dev/mapper/vg0-home +mount /dev/vdb2 /mnt +mkdir /mnt/home +mount /dev/mapper/vg0-home /mnt/home +df -h /mnt /mnt/home +herd start cow-store /mnt +mkdir /mnt/etc +cp /etc/target-config.scm /mnt/etc/config.scm +guix system init /mnt/etc/config.scm /mnt --no-substitutes +sync +reboot\n") + +(define %test-lvm-separate-home-os + (system-test + (name "lvm-separate-home-os") + (description + "Test functionality of an OS installed with a LVM /home partition") + (value + (mlet* %store-monad ((image (run-install %lvm-separate-home-os + %lvm-separate-home-os-source + #:script + %lvm-separate-home-installation-script + #:packages (list lvm2-static) + #:target-size (* 3200 MiB))) + (command (qemu-command/writable-image image))) + (run-basic-test %lvm-separate-home-os + `(,@command) "lvm-separate-home-os"))))) + ;;; ;;; Btrfs root file system. -- cgit v1.2.3