From: Josselin Poiret via Guix-patches via <guix-patches@gnu.org>
To: Mathieu Othacehe <othacehe@gnu.org>
Cc: Josselin Poiret <dev@jpoiret.xyz>, 51878@debbugs.gnu.org
Subject: [bug#51878] [PATCH v2] installer: Rework installation device detection
Date: Tue, 23 Nov 2021 22:19:09 +0000 [thread overview]
Message-ID: <20211123221909.11142-1-dev@jpoiret.xyz> (raw)
In-Reply-To: <87lf1mhmgw.fsf@gnu.org>
Hello,
You're right, I didn't take CDs into account. Here is a new version
which compares the device path itself to the --root argument as well,
which is the case for CDs. I checked both iso9660 and qcow2 in qemu,
and both only list other devices.
I didn't quite get your comment about filtering the `(devices)` list.
In both cases, we use `remove`, but here I've factored out the predicate
used for it.
Best,
Josselin
-- >8 --
* gnu/installer/parted.scm (installation-device): Remove it.
* gnu/installer/parted.scm (installer-root-partition-path): Add it.
* gnu/installer/parted.scm (non-install-devices): Add
installation-device? predicate.
---
gnu/installer/parted.scm | 53 +++++++++++++++++++++++-----------------
1 file changed, 30 insertions(+), 23 deletions(-)
diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm
index 00de0a30fa..f665e67b35 100644
--- a/gnu/installer/parted.scm
+++ b/gnu/installer/parted.scm
@@ -26,6 +26,7 @@ (define-module (gnu installer parted)
#:use-module ((gnu build file-systems)
#:select (canonicalize-device-spec
find-partition-by-label
+ find-partition-by-uuid
read-partition-uuid
read-luks-partition-uuid))
#:use-module ((gnu build linux-boot)
@@ -345,35 +346,41 @@ (define (remove-logical-devices)
(with-null-output-ports
(invoke "dmsetup" "remove_all")))
-(define (installation-device)
- "Return the installation device path."
+(define (installer-root-partition-path)
+ "Return the root partition path, or #f if it could not be detected."
(let* ((cmdline (linux-command-line))
(root (find-long-option "--root" cmdline)))
(and root
- (canonicalize-device-spec (uuid root)))))
+ (or (and (access? root F_OK) root)
+ (find-partition-by-label root)
+ (and=> (uuid root)
+ find-partition-by-uuid)))))
(define (non-install-devices)
"Return all the available devices, except the install device."
- (define (read-only? device)
- (dynamic-wind
- (lambda ()
- (device-open device))
- (lambda ()
- (device-read-only? device))
- (lambda ()
- (device-close device))))
-
- ;; If parted reports that a device is read-only it is probably the
- ;; installation device. However, as this detection does not always work,
- ;; compare the device path to the installation device path read from the
- ;; command line.
- (let ((install-device (installation-device)))
- (remove (lambda (device)
- (let ((file-name (device-path device)))
- (or (read-only? device)
- (and install-device
- (string=? file-name install-device)))))
- (devices))))
+
+ (define the-installer-root-partition-path
+ (installer-root-partition-path))
+
+ ;; Read partition table of device and compare each path to the one
+ ;; we're booting from to determine if it is the installation
+ ;; device.
+ (define (installation-device? device)
+ (or (string=? the-installer-root-partition-path
+ (device-path device))
+ (let ((disk (disk-new device)))
+ (and disk
+ (let loop ((partition #f))
+ (let ((next-partition (disk-next-partition disk
+ #:partition
+ partition)))
+ (and next-partition
+ (or (string=? the-installer-root-partition-path
+ (partition-get-path
+ next-partition))
+ (loop next-partition)))))))))
+
+ (remove installation-device? (devices)))
\f
;;
--
2.33.1
next prev parent reply other threads:[~2021-11-23 22:20 UTC|newest]
Thread overview: 7+ messages / expand[flat|nested] mbox.gz Atom feed top
2021-11-15 21:04 [bug#51878] [PATCH] installer: Rework installation device detection Josselin Poiret via Guix-patches via
2021-11-15 21:32 ` [bug#51878] [PATCH v2] " Josselin Poiret via Guix-patches via
2021-11-17 14:43 ` [bug#51878] [PATCH] " Mathieu Othacehe
2021-11-23 22:19 ` Josselin Poiret via Guix-patches via [this message]
2021-11-25 9:20 ` Mathieu Othacehe
2021-11-26 9:48 ` Josselin Poiret via Guix-patches via
2021-11-26 10:53 ` bug#51878: " Mathieu Othacehe
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20211123221909.11142-1-dev@jpoiret.xyz \
--to=guix-patches@gnu.org \
--cc=51878@debbugs.gnu.org \
--cc=dev@jpoiret.xyz \
--cc=othacehe@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.