aboutsummaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2022-06-08 14:46:24 +0200
committerLudovic Courtès <ludo@gnu.org>2022-06-08 14:46:24 +0200
commit8c3e9da13a3c92a7db308db8c0d81cb474ad7799 (patch)
tree88d06952aa5cc3a9c4991d9c43eb7950ff174fe1 /gnu/system
parent5439c04ebdb7b6405f5ea2446b375f1d155a8d95 (diff)
parent0c5299200ffcd16370f047b7ccb187c60f30da34 (diff)
downloadguix-8c3e9da13a3c92a7db308db8c0d81cb474ad7799.tar
guix-8c3e9da13a3c92a7db308db8c0d81cb474ad7799.tar.gz
Merge branch 'master' into core-updates
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/file-systems.scm5
-rw-r--r--gnu/system/hurd.scm2
-rw-r--r--gnu/system/image.scm68
-rw-r--r--gnu/system/images/hurd.scm2
-rw-r--r--gnu/system/images/novena.scm2
-rw-r--r--gnu/system/images/pine64.scm2
-rw-r--r--gnu/system/images/pinebook-pro.scm2
-rw-r--r--gnu/system/images/rock64.scm2
-rw-r--r--gnu/system/install.scm256
-rw-r--r--gnu/system/linux-container.scm3
-rw-r--r--gnu/system/mapped-devices.scm53
11 files changed, 220 insertions, 177 deletions
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 437f8da898..f8f4276283 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013-2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Google LLC
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
@@ -272,7 +272,8 @@ flags are found."
;; Note: If we have (guix store database) in the search path and we do *not*
;; have (guix store) proper, 'resolve-module' returns an empty (guix store)
;; with one sub-module.
- (cond ((and=> (resolve-module '(guix store) #:ensure #f)
+ (cond ((and=> (parameterize ((current-warning-port (%make-void-port "w0")))
+ (resolve-module '(guix store) #:ensure #f))
(lambda (store)
(module-variable store '%store-prefix)))
=>
diff --git a/gnu/system/hurd.scm b/gnu/system/hurd.scm
index 8e95d0a16c..4bc32d9bd1 100644
--- a/gnu/system/hurd.scm
+++ b/gnu/system/hurd.scm
@@ -119,7 +119,7 @@
(bootloader grub-minimal-bootloader)
(targets '("/dev/vda"))))
(initrd #f)
- (initrd-modules (lambda _ '()))
+ (initrd-modules '())
(firmware '())
(host-name "guixygnu")
(file-systems '())
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 42e215f614..f02f6e0b8c 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020, 2021 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2022 Pavel Shlyak <p.shlyak@pantherx.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -31,7 +32,7 @@
#:use-module (gnu bootloader)
#:use-module (gnu bootloader grub)
#:use-module (gnu image)
- #:use-module (gnu platform)
+ #:use-module (guix platform)
#:use-module (gnu services)
#:use-module (gnu services base)
#:use-module (gnu system)
@@ -218,7 +219,8 @@ set to the given OS."
#$(partition-file-system-options partition)
#$(partition-label partition)
#$(and=> (partition-uuid partition)
- uuid-bytevector)))
+ uuid-bytevector)
+ #$(partition-flags partition)))
(define gcrypt-sqlite3&co
;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
@@ -295,27 +297,49 @@ used in the image."
;; the hdimage format (raw disk-image) is supported.
(cond
((memq format '(disk-image compressed-qcow2)) "hdimage")
- (else
- (raise (condition
- (&message
- (message
- (format #f (G_ "Unsupported image type ~a~%.") format))))))))
+ (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)))
+ (let ((flags (partition-flags partition))
+ (file-system (partition-file-system partition)))
(cond
((member 'esp flags) "0xEF")
- (else "0x83"))))
+ ((string-prefix? "ext" file-system) "0x83")
+ ((or (string=? file-system "vfat")
+ (string=? file-system "fat16")) "0x0E")
+ ((string=? file-system "fat32") "0x0C")
+ (else
+ (raise (condition
+ (&message
+ (message
+ (format #f (G_ "unsupported partition type: ~a")
+ file-system)))))))))
(define (partition->gpt-type partition)
- ;; Return the genimage GPT partition type code corresponding to PARTITION.
- ;; See https://github.com/pengutronix/genimage/blob/master/README.rst
- (let ((flags (partition-flags partition)))
+ ;; Return the genimage GPT partition type code corresponding to the
+ ;; given PARTITION. See:
+ ;; https://github.com/pengutronix/genimage/blob/master/README.rst
+ (let ((flags (partition-flags partition))
+ (file-system (partition-file-system partition)))
(cond
- ((member 'esp flags) "U")
- (else "L"))))
+ ((member 'esp flags) "U")
+ ((string-prefix? "ext" file-system) "L")
+ ((or (string=? file-system "vfat")
+ (string=? file-system "fat16")
+ (string=? file-system "fat32")) "F")
+ (else
+ (raise (condition
+ (&message
+ (message
+ (format #f (G_ "unsupported partition type: ~a")
+ file-system)))))))))
(define (partition-image partition)
;; Return as a file-like object, an image of the given PARTITION. A
@@ -382,24 +406,28 @@ used in the image."
(partition-type-values image partition)))
(let ((label (partition-label partition))
(image (partition-image partition))
- (offset (partition-offset partition)))
+ (offset (partition-offset partition))
+ (bootable (if (memq 'boot (partition-flags partition))
+ "true" "false" )))
#~(format #f "~/partition ~a {
~/~/~a = ~a
~/~/image = \"~a\"
~/~/offset = \"~a\"
+ ~/~/bootable = \"~a\"
~/}"
#$label
#$partition-type-attribute
#$partition-type-value
#$image
- #$offset))))
+ #$offset
+ #$bootable))))
(define (genimage-type-options image-type image)
(cond
- ((equal? image-type "hdimage")
- (format #f "~%~/~/gpt = ~a~%~/"
- (if (gpt-image? image) "true" "false")))
- (else "")))
+ ((equal? image-type "hdimage")
+ (format #f "~%~/~/gpt = ~a~%~/"
+ (if (gpt-image? image) "true" "false")))
+ (else "")))
(let* ((format (image-format image))
(image-type (format->image-type format))
diff --git a/gnu/system/images/hurd.scm b/gnu/system/images/hurd.scm
index 4c38c46a89..6da09b855a 100644
--- a/gnu/system/images/hurd.scm
+++ b/gnu/system/images/hurd.scm
@@ -23,7 +23,7 @@
#:use-module (gnu bootloader grub)
#:use-module (gnu image)
#:use-module (gnu packages ssh)
- #:use-module (gnu platforms hurd)
+ #:use-module (guix platforms x86)
#:use-module (gnu services)
#:use-module (gnu services ssh)
#:use-module (gnu system)
diff --git a/gnu/system/images/novena.scm b/gnu/system/images/novena.scm
index 5b625e56c5..b9ff6dcfea 100644
--- a/gnu/system/images/novena.scm
+++ b/gnu/system/images/novena.scm
@@ -22,7 +22,7 @@
#:use-module (gnu bootloader u-boot)
#:use-module (gnu image)
#:use-module (gnu packages linux)
- #:use-module (gnu platforms arm)
+ #:use-module (guix platforms arm)
#:use-module (gnu services)
#:use-module (gnu services base)
#:use-module (gnu system)
diff --git a/gnu/system/images/pine64.scm b/gnu/system/images/pine64.scm
index aaec458766..99c4ed6ceb 100644
--- a/gnu/system/images/pine64.scm
+++ b/gnu/system/images/pine64.scm
@@ -21,7 +21,7 @@
#:use-module (gnu bootloader u-boot)
#:use-module (gnu image)
#:use-module (gnu packages linux)
- #:use-module (gnu platforms arm)
+ #:use-module (guix platforms arm)
#:use-module (gnu services)
#:use-module (gnu services base)
#:use-module (gnu system)
diff --git a/gnu/system/images/pinebook-pro.scm b/gnu/system/images/pinebook-pro.scm
index 1bfac7a8bb..7e8910427e 100644
--- a/gnu/system/images/pinebook-pro.scm
+++ b/gnu/system/images/pinebook-pro.scm
@@ -21,7 +21,7 @@
#:use-module (gnu bootloader u-boot)
#:use-module (gnu image)
#:use-module (gnu packages linux)
- #:use-module (gnu platforms arm)
+ #:use-module (guix platforms arm)
#:use-module (gnu services)
#:use-module (gnu services base)
#:use-module (gnu system)
diff --git a/gnu/system/images/rock64.scm b/gnu/system/images/rock64.scm
index d25d55e528..68cb65f115 100644
--- a/gnu/system/images/rock64.scm
+++ b/gnu/system/images/rock64.scm
@@ -21,7 +21,7 @@
#:use-module (gnu bootloader u-boot)
#:use-module (gnu image)
#:use-module (gnu packages linux)
- #:use-module (gnu platforms arm)
+ #:use-module (guix platforms arm)
#:use-module (gnu services)
#:use-module (gnu services base)
#:use-module (gnu services networking)
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 073d7df1db..a3646b1d54 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -1,11 +1,12 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2017, 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -31,8 +32,10 @@
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix modules)
- #:use-module ((guix packages) #:select (package-version))
+ #:use-module ((guix packages) #:select (package-version supported-package?))
+ #:use-module (guix platform)
#:use-module ((guix store) #:select (%store-prefix))
+ #:use-module (guix utils)
#:use-module (gnu installer)
#:use-module (gnu system locale)
#:use-module (gnu services avahi)
@@ -252,7 +255,9 @@ the user's target storage device rather than on the RAM disk."
(service-type (name 'configuration-template)
(extensions
(list (service-extension etc-service-type
- /etc/configuration-files)))))
+ /etc/configuration-files)))
+ (description "Install the operating system configuration file
+templates under @file{/etc/configuration}.")))
(define %configuration-template-service
(service configuration-template-service-type #t))
@@ -281,11 +286,7 @@ the user's target storage device rather than on the RAM disk."
(provision '(maybe-uvesafb))
(requirement '(file-systems))
(start #~(lambda ()
- ;; uvesafb is only supported on x86 and x86_64.
- (or (not (and (string-suffix? "linux-gnu" %host-type)
- (or (string-prefix? "x86_64" %host-type)
- (string-prefix? "i686" %host-type))))
- (file-exists? "/dev/fb0")
+ (or (file-exists? "/dev/fb0")
(invoke #+(file-append kmod "/bin/modprobe")
"uvesafb"
(string-append "v86d=" #$v86d "/sbin/v86d")
@@ -303,7 +304,10 @@ the user's target storage device rather than on the RAM disk."
"Load the @code{uvesafb} kernel module with the right options.")
(default-value #t)))
-(define %installation-services
+(define* (%installation-services #:key (system (or (and=>
+ (%current-target-system)
+ platform-target->system)
+ (%current-system))))
;; List of services of the installation system.
(let ((motd (plain-file "motd" "
\x1b[1;37mWelcome to the installation of GNU Guix!\x1b[0m
@@ -320,119 +324,125 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m
(define bare-bones-os
(load "examples/bare-bones.tmpl"))
- (list (service virtual-terminal-service-type)
-
- (service kmscon-service-type
- (kmscon-configuration
- (virtual-terminal "tty1")
- (login-program (installer-program))))
-
- (login-service (login-configuration
- (motd motd)))
-
- ;; Documentation. The manual is in UTF-8, but
- ;; 'console-font-service' sets up Unicode support and loads a font
- ;; with all the useful glyphs like em dash and quotation marks.
- (service documentation-service-type "tty2")
-
- ;; Documentation add-on.
- %configuration-template-service
-
- ;; A bunch of 'root' ttys.
- (normal-tty "tty3")
- (normal-tty "tty4")
- (normal-tty "tty5")
- (normal-tty "tty6")
-
- ;; The usual services.
- (syslog-service)
-
- ;; Use the Avahi daemon to discover substitute servers on the local
- ;; network. It can be faster than fetching from remote servers.
- (service avahi-service-type)
-
- ;; The build daemon. Register the default substitute server key(s)
- ;; as trusted to allow the installation process to use substitutes by
- ;; default.
- (service guix-service-type
- (guix-configuration (authorize-key? #t)))
-
- ;; Start udev so that useful device nodes are available.
- ;; Use device-mapper rules for cryptsetup & co; enable the CRDA for
- ;; regulations-compliant WiFi access.
- (udev-service #:rules (list lvm2 crda))
-
- ;; Add the 'cow-store' service, which users have to start manually
- ;; since it takes the installation directory as an argument.
- (cow-store-service)
-
- ;; Install Unicode support and a suitable font.
- (service console-font-service-type
- (map (match-lambda
- ("tty2"
- ;; Use a font that contains characters such as
- ;; curly quotes as found in the manual.
- '("tty2" . "LatGrkCyr-8x16"))
- (tty
- ;; Use a font that doesn't have more than 256
- ;; glyphs so that we can use colors with varying
- ;; brightness levels (see note in setfont(8)).
- `(,tty . "lat9u-16")))
- '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
-
- ;; To facilitate copy/paste.
- (service gpm-service-type)
-
- ;; Add an SSH server to facilitate remote installs.
- (service openssh-service-type
- (openssh-configuration
- (port-number 22)
- (permit-root-login #t)
- ;; The root account is passwordless, so make sure
- ;; a password is set before allowing logins.
- (allow-empty-passwords? #f)
- (password-authentication? #t)
-
- ;; Don't start it upfront.
- (%auto-start? #f)))
-
- ;; Since this is running on a USB stick with a overlayfs as the root
- ;; file system, use an appropriate cache configuration.
- (nscd-service (nscd-configuration
- (caches %nscd-minimal-caches)))
-
- ;; 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 bash "/bin/sh"))))
-
- ;; Loopback device, needed by OpenSSH notably.
- (service static-networking-service-type
- (list %loopback-static-networking))
-
- (service wpa-supplicant-service-type)
- (dbus-service)
- (service connman-service-type
- (connman-configuration
- (disable-vpn? #t)))
-
- ;; Keep a reference to BARE-BONES-OS to make sure it can be
- ;; installed without downloading/building anything. Also keep the
- ;; things needed by 'profile-derivation' to minimize the amount of
- ;; download.
- (service gc-root-service-type
- (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
- ;; installer. Some may also need a kernel parameter like nomodeset
- ;; or vga=793, but we leave that for the user to specify in GRUB.
- (service uvesafb-service-type))))
+ (append
+ ;; Generic services
+ (list (service virtual-terminal-service-type)
+
+ (service kmscon-service-type
+ (kmscon-configuration
+ (virtual-terminal "tty1")
+ (login-program (installer-program))))
+
+ (login-service (login-configuration
+ (motd motd)))
+
+ ;; Documentation. The manual is in UTF-8, but
+ ;; 'console-font-service' sets up Unicode support and loads a font
+ ;; with all the useful glyphs like em dash and quotation marks.
+ (service documentation-service-type "tty2")
+
+ ;; Documentation add-on.
+ %configuration-template-service
+
+ ;; A bunch of 'root' ttys.
+ (normal-tty "tty3")
+ (normal-tty "tty4")
+ (normal-tty "tty5")
+ (normal-tty "tty6")
+
+ ;; The usual services.
+ (syslog-service)
+
+ ;; Use the Avahi daemon to discover substitute servers on the local
+ ;; network. It can be faster than fetching from remote servers.
+ (service avahi-service-type)
+
+ ;; The build daemon. Register the default substitute server key(s)
+ ;; as trusted to allow the installation process to use substitutes by
+ ;; default.
+ (service guix-service-type
+ (guix-configuration (authorize-key? #t)))
+
+ ;; Start udev so that useful device nodes are available.
+ ;; Use device-mapper rules for cryptsetup & co; enable the CRDA for
+ ;; regulations-compliant WiFi access.
+ (udev-service #:rules (list lvm2 crda))
+
+ ;; Add the 'cow-store' service, which users have to start manually
+ ;; since it takes the installation directory as an argument.
+ (cow-store-service)
+
+ ;; Install Unicode support and a suitable font.
+ (service console-font-service-type
+ (map (match-lambda
+ ("tty2"
+ ;; Use a font that contains characters such as
+ ;; curly quotes as found in the manual.
+ '("tty2" . "LatGrkCyr-8x16"))
+ (tty
+ ;; Use a font that doesn't have more than 256
+ ;; glyphs so that we can use colors with varying
+ ;; brightness levels (see note in setfont(8)).
+ `(,tty . "lat9u-16")))
+ '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
+
+ ;; To facilitate copy/paste.
+ (service gpm-service-type)
+
+ ;; Add an SSH server to facilitate remote installs.
+ (service openssh-service-type
+ (openssh-configuration
+ (port-number 22)
+ (permit-root-login #t)
+ ;; The root account is passwordless, so make sure
+ ;; a password is set before allowing logins.
+ (allow-empty-passwords? #f)
+ (password-authentication? #t)
+
+ ;; Don't start it upfront.
+ (%auto-start? #f)))
+
+ ;; Since this is running on a USB stick with a overlayfs as the root
+ ;; file system, use an appropriate cache configuration.
+ (nscd-service (nscd-configuration
+ (caches %nscd-minimal-caches)))
+
+ ;; 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 bash "/bin/sh"))))
+
+ ;; Loopback device, needed by OpenSSH notably.
+ (service static-networking-service-type
+ (list %loopback-static-networking))
+
+ (service wpa-supplicant-service-type)
+ (dbus-service)
+ (service connman-service-type
+ (connman-configuration
+ (disable-vpn? #t)))
+
+ ;; Keep a reference to BARE-BONES-OS to make sure it can be
+ ;; installed without downloading/building anything. Also keep the
+ ;; things needed by 'profile-derivation' to minimize the amount of
+ ;; download.
+ (service gc-root-service-type
+ (append
+ (list bare-bones-os
+ glibc-utf8-locales
+ texinfo
+ guile-3.0)
+ %default-locale-libcs)))
+
+ ;; Specific system services
+
+ ;; Machines without Kernel Mode Setting (those with many old and
+ ;; current AMD GPUs, SiS GPUs, ...) need uvesafb to show the GUI
+ ;; installer. Some may also need a kernel parameter like nomodeset
+ ;; or vga=793, but we leave that for the user to specify in GRUB.
+ `(,@(if (supported-package? v86d system)
+ (list (service uvesafb-service-type))
+ '())))))
(define %issue
;; Greeting.
@@ -496,7 +506,7 @@ Access documentation at any time by pressing Alt-F2.\x1b[0m
(comment "Guest of GNU"))))
(issue %issue)
- (services %installation-services)
+ (services (%installation-services))
;; We don't need setuid programs, except for 'passwd', which can be handy
;; if one is to allow remote SSH login to the machine being installed.
diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm
index eeb0f68c02..24077e347a 100644
--- a/gnu/system/linux-container.scm
+++ b/gnu/system/linux-container.scm
@@ -129,8 +129,7 @@ containerized OS. EXTRA-FILE-SYSTEMS is a list of file systems to add to OS."
static-networking-service-type
dhcp-client-service-type
network-manager-service-type
- connman-service-type
- wicd-service-type)
+ connman-service-type)
(list))))
(define services-to-add
diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index 96a381d5fe..e6b8970c12 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2017, 2018 Mark H Weaver <mhw@netris.org>
;;;
@@ -202,7 +202,8 @@ option of @command{guix system}.\n")
;; XXX: 'use-modules' should be at the top level.
(use-modules (rnrs bytevectors) ;bytevector?
((gnu build file-systems)
- #:select (find-partition-by-luks-uuid))
+ #:select (find-partition-by-luks-uuid
+ system*/tty))
((guix build utils) #:select (mkdir-p)))
;; Create '/run/cryptsetup/' if it does not exist, as device locking
@@ -211,28 +212,32 @@ option of @command{guix system}.\n")
;; 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)))))))
+ ;; 'cryptsetup open' requires standard input to be a tty to allow
+ ;; for interaction but shepherd sets standard input to /dev/null;
+ ;; thus, explicitly request a tty.
+ (zero? (system*/tty
+ #$(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."