all messages for Guix-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
From: Josselin Poiret via Guix-patches via <guix-patches@gnu.org>
To: Josselin Poiret <dev@jpoiret.xyz>
Cc: 51878@debbugs.gnu.org
Subject: [bug#51878] [PATCH v2] installer: Rework installation device detection
Date: Mon, 15 Nov 2021 21:32:32 +0000	[thread overview]
Message-ID: <20211115213232.15112-1-dev@jpoiret.xyz> (raw)
In-Reply-To: <20211115210404.10680-1-dev@jpoiret.xyz>

Sorry for the noise,
Josselin Poiret
-- >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 | 51 ++++++++++++++++++++++------------------
 1 file changed, 28 insertions(+), 23 deletions(-)

diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm
index 00de0a30fa..42456a1d18 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,39 @@ (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)
+    (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





  reply	other threads:[~2021-11-15 21:34 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 ` Josselin Poiret via Guix-patches via [this message]
2021-11-17 14:43 ` Mathieu Othacehe
2021-11-23 22:19   ` [bug#51878] [PATCH v2] " Josselin Poiret via Guix-patches via
2021-11-25  9:20     ` [bug#51878] [PATCH] " 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=20211115213232.15112-1-dev@jpoiret.xyz \
    --to=guix-patches@gnu.org \
    --cc=51878@debbugs.gnu.org \
    --cc=dev@jpoiret.xyz \
    /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.