From 3f3ce4890089c20e79c290e55428fd349a80b84f Mon Sep 17 00:00:00 2001
From: Herman Rimm <herman@rimm.ee>
Date: Sun, 29 Sep 2024 13:31:21 +0200
Subject: [PATCH] gnu: bootloader: Add find-mount procedure.

* gnu/bootloader.scm (find-mount, find-file-system, label->uuid,
uuid->file-system, mount-point->block-device): Add procedures.
---
 gnu/bootloader.scm | 43 +++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 43 insertions(+)

diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm
index f602150506..c236eea367 100644
--- a/gnu/bootloader.scm
+++ b/gnu/bootloader.scm
@@ -88,6 +88,12 @@ (define-module (gnu bootloader)
             target-error-type
             target-error-targets
 
+            find-mount
+            find-file-system
+            label->uuid
+            uuid->file-system
+            mount-point->block-device
+
             gbegin
             :path :devpath :device :fs :label :uuid
             with-targets
@@ -318,6 +324,43 @@ (define-condition-type &target-error &error target-error?
   (type target-error-type)
   (targets target-error-targets))
 
+;; XXX: Use a more appropriate name than FS?
+(define (find-mount block-device-or-fs)
+  "Return the <mount> record with source BLOCK-DEVICE-OR-FS, or #f
+otherwise.  An FS could be efivarsfs, cgroup etc.."
+  (define (block-device-or-fs? mount)
+    (and (string=? block-device-or-fs (mount-source mount)) mount))
+  ;; A mount source is either a block device or an FS.
+  (when (and (not (string-prefix? "/dev/" block-device-or-fs))
+             (or (string-contains "/" block-device-or-fs)
+                 (string=? "none" block-device-or-fs)))
+    (error (G_ "not a block device with mount~%") block-device-or-fs))
+  (any block-device-or-fs? (mounts)))
+
+(define (find-file-system block-device)
+  "Detects the type of a given block device.  Return #f if not found."
+  (and=> (find-mount block-device) mount-type))
+
+(define (label->uuid label)
+  (and=> (find-partition-by-label (file-system-label->string label))
+         read-partition-uuid))
+
+(define (uuid->file-system uuid)
+  "Returns the UUID's type as a string.  Does not depend on current
+mounts, unlike find-file-system.  Use together with the find-uuid, or
+label->uuid procedure."
+  (symbol->string (uuid-type uuid)))
+
+;; TODO: Test together with find-mount.
+(define (mount-point->block-device point)
+  "Return the block device mounted on POINT, or #f otherwise."
+  (define (point? mount)
+    (and (string=? point (mount-point mount)) (mount-source mount)))
+  ;; A mount point is an absolute path.
+  (unless (string-prefix? "/" point)
+    (error (G_ "mount point is not an absolute path~%") point))
+  (any point? (mounts)))
+
 (define (pathcat p1 p2)
   (string-append (string-trim-right p1 #\/) "/" (string-trim p2 #\/)))