From 317c055fc3ec29adb1acd5722f7e7fe8483b336c Mon Sep 17 00:00:00 2001
From: cashmere <cashmere@autistici.org>
Date: Fri, 4 Sep 2026 10:49:20 +0200
Subject: relic: 2026-09-04T10:49:24+02:00

---
 lisp/zfs-cli.el | 211 ++++++++++++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 190 insertions(+), 21 deletions(-)

(limited to 'lisp/zfs-cli.el')

diff --git a/lisp/zfs-cli.el b/lisp/zfs-cli.el
index 0d7b747..c72a114 100644
--- a/lisp/zfs-cli.el
+++ b/lisp/zfs-cli.el
@@ -17,6 +17,11 @@ Example: ((:name \"vps1\" :ssh \"cashmere@1.2.3.4\"))"
   :type '(repeat string)
   :group 'zfs)
 
+(defcustom zfs-authentication-command nil
+  "Command used for interactive local privilege authentication."
+  :type '(choice (const :tag "Disabled" nil) (repeat string))
+  :group 'zfs)
+
 (defconst zfs-cli--permission-error-re "permission denied\\|Insufficient privileges\\|delegated permission")
 
 (defconst zfs-cli-dataset-properties
@@ -36,10 +41,9 @@ Example: ((:name \"vps1\" :ssh \"cashmere@1.2.3.4\"))"
               (mapconcat #'shell-quote-argument command " "))
       command)))
 
-(defun zfs-cli--call (host program args sudo &optional input)
+(defun zfs-cli--call-argv (argv &optional input)
   (let ((stderr-file (make-temp-file "zfs-cli-"))
-        (input-file (and input (make-temp-file "zfs-cli-in-")))
-        (argv (zfs-cli--argv host program args sudo)))
+        (input-file (and input (make-temp-file "zfs-cli-in-"))))
     (unwind-protect
         (progn
           (when input-file
@@ -55,6 +59,40 @@ Example: ((:name \"vps1\" :ssh \"cashmere@1.2.3.4\"))"
       (delete-file stderr-file)
       (when input-file (delete-file input-file)))))
 
+(defun zfs-cli--call (host program args sudo &optional input)
+  (zfs-cli--call-argv (zfs-cli--argv host program args sudo) input))
+
+(defun zfs-cli--call-argv-async (argv input callback)
+  "Run ARGV asynchronously, send INPUT to stdin, and call CALLBACK with status, stdout, and stderr."
+  (let ((stdout (generate-new-buffer " *zfs-cli-async-out*"))
+        (stderr (generate-new-buffer " *zfs-cli-async-err*")))
+    (condition-case err
+        (let ((process
+               (make-process
+                :name "zfs-cli-authenticated"
+                :buffer stdout
+                :stderr stderr
+                :command argv
+                :connection-type 'pipe
+                :noquery t
+                :sentinel
+                (lambda (process _event)
+                  (when (memq (process-status process) '(exit signal))
+                    (let ((status (process-exit-status process))
+                          (out (with-current-buffer stdout (buffer-string)))
+                          (err (string-trim (with-current-buffer stderr (buffer-string)))))
+                      (kill-buffer stdout)
+                      (kill-buffer stderr)
+                      (funcall callback status out err)))))))
+          (when input
+            (process-send-string process input)
+            (process-send-eof process))
+          process)
+      (error
+       (kill-buffer stdout)
+       (kill-buffer stderr)
+       (signal (car err) (cdr err))))))
+
 (defun zfs-cli-run (host program args &optional input)
   (let ((result (zfs-cli--call host program args nil input)))
     (when (and (/= 0 (car result))
@@ -269,35 +307,66 @@ Example: ((:name \"vps1\" :ssh \"cashmere@1.2.3.4\"))"
     (unless (zerop (car result))
       (error "zfs-cli: %s" (cdr result)))))
 
-(defun zfs-cli--parse-block-device (device)
-  (list :name (alist-get 'name device)
-        :path (concat "/dev/" (alist-get 'name device))
-        :size (alist-get 'size device)
-        :fstype (alist-get 'fstype device)
-        :model (let ((model (alist-get 'model device)))
-                 (and model (string-trim model)))
-        :type (alist-get 'type device)
-        :mounted (seq-some #'identity (alist-get 'mountpoints device))
-        :children (mapcar #'zfs-cli--parse-block-device (alist-get 'children device))))
+(defun zfs-cli--parse-block-device (device &optional parent-name parent-model)
+  (let* ((name (alist-get 'name device))
+         (own-model (when-let* ((model (alist-get 'model device)))
+                      (string-trim model)))
+         (model (or own-model parent-model)))
+    (list :name name
+          :path (concat "/dev/" name)
+          :size (alist-get 'size device)
+          :fstype (alist-get 'fstype device)
+          :model model
+          :type (alist-get 'type device)
+          :pttype (alist-get 'pttype device)
+          :read-only (eq (alist-get 'ro device) t)
+          :mounted (seq-some #'identity (alist-get 'mountpoints device))
+          :parent parent-name
+          :children (mapcar (lambda (child)
+                              (zfs-cli--parse-block-device child name model))
+                            (alist-get 'children device)))))
 
 (defun zfs-cli-block-devices ()
-  (let ((json (zfs-cli-run-json nil "lsblk" '("-J" "-b" "-o" "NAME,SIZE,FSTYPE,MODEL,TYPE,MOUNTPOINTS"))))
+  (let ((json (zfs-cli-run-json nil "lsblk" '("-J" "-b" "-o" "NAME,SIZE,FSTYPE,MODEL,TYPE,MOUNTPOINTS,PTTYPE,RO"))))
     (mapcar #'zfs-cli--parse-block-device (alist-get 'blockdevices json))))
 
+(defun zfs-cli--flatten-device-tree (devices)
+  (mapcan (lambda (device)
+            (cons device (zfs-cli--flatten-device-tree (plist-get device :children))))
+          devices))
+
 (defun zfs-cli-locked-disks ()
   (seq-filter (lambda (device)
-                (and (member (plist-get device :type) '("disk" "loop"))
+                (and (member (plist-get device :type) '("disk" "part" "loop"))
                      (equal (plist-get device :fstype) "crypto_LUKS")))
-              (zfs-cli-block-devices)))
+              (zfs-cli--flatten-device-tree (zfs-cli-block-devices))))
 
 (defun zfs-cli-disk-unlocked-p (device)
-  (seq-find (lambda (child) (equal (plist-get child :type) "crypt"))
-            (plist-get device :children)))
+  (or (seq-find (lambda (child) (equal (plist-get child :type) "crypt"))
+                (plist-get device :children))
+      (zfs-cli-mapper-node (concat "luks-" (plist-get device :name)))))
 
 (defun zfs-cli-disk-mapper (device)
-  (when-let* ((child (seq-find (lambda (entry) (equal (plist-get entry :type) "crypt"))
-                               (plist-get device :children))))
-    (plist-get child :name)))
+  (if-let* ((child (seq-find (lambda (entry) (equal (plist-get entry :type) "crypt"))
+                             (plist-get device :children))))
+      (plist-get child :name)
+    (let ((name (concat "luks-" (plist-get device :name))))
+      (and (zfs-cli-mapper-node name) name))))
+
+(defun zfs-cli-mapper-node (name)
+  "Return the /dev/dm-* node whose Device Mapper name is NAME."
+  (when (file-directory-p "/sys/class/block")
+    (seq-some
+     (lambda (entry)
+       (let ((name-file (expand-file-name "dm/name" entry)))
+         (when (and (file-readable-p name-file)
+                    (equal (string-trim
+                            (with-temp-buffer
+                              (insert-file-contents name-file)
+                              (buffer-string)))
+                           name))
+           (concat "/dev/" (file-name-nondirectory (directory-file-name entry))))))
+     (directory-files "/sys/class/block" t "\\`dm-[0-9]+\\'"))))
 
 (defun zfs-cli--device-tree-mounted-p (device)
   (or (plist-get device :mounted)
@@ -310,6 +379,10 @@ Example: ((:name \"vps1\" :ssh \"cashmere@1.2.3.4\"))"
 (defun zfs-cli-disk-candidates ()
   (seq-filter (lambda (device)
                 (and (equal (plist-get device :type) "disk")
+                     (not (plist-get device :read-only))
+                     (not (plist-get device :fstype))
+                     (not (plist-get device :pttype))
+                     (not (plist-get device :children))
                      (not (zfs-cli--device-tree-mounted-p device))
                      (not (zfs-cli--device-tree-active-p device))))
               (zfs-cli-block-devices)))
@@ -321,12 +394,108 @@ Example: ((:name \"vps1\" :ssh \"cashmere@1.2.3.4\"))"
       (match-string 1 (cdr result)))))
 
 (defun zfs-cli-luks-open (device name passphrase)
+  (unless (executable-find "cryptsetup")
+    (error "cryptsetup is required to unlock LUKS devices"))
   (let ((result (zfs-cli--call nil "cryptsetup" (list "luksOpen" device name) t
                                (concat passphrase "\n"))))
     (unless (zerop (car result))
       (error "%s" (cdr result)))))
 
+(defconst zfs-cli--luks-unlock-script
+  (concat
+   "cryptsetup=$1\n"
+   "zdb=$2\n"
+   "zpool=$3\n"
+   "sed=$4\n"
+   "mknod=$5\n"
+   "device=$6\n"
+   "mapper=$7\n"
+   "find_mapper() {\n"
+   "  mapper_node=\n"
+   "  mapper_sysfs=\n"
+   "  for dm in /sys/class/block/dm-*; do\n"
+   "    [ -r \"$dm/dm/name\" ] || continue\n"
+   "    IFS= read -r dm_name < \"$dm/dm/name\" || continue\n"
+   "    if [ \"$dm_name\" = \"$mapper\" ]; then\n"
+   "      mapper_sysfs=$dm\n"
+   "      if [ -b \"/dev/mapper/$mapper\" ]; then\n"
+   "        mapper_node=/dev/mapper/$mapper\n"
+   "      elif [ -b \"/dev/${dm##*/}\" ]; then\n"
+   "        mapper_node=/dev/${dm##*/}\n"
+   "      fi\n"
+   "      return 0\n"
+   "    fi\n"
+   "  done\n"
+   "}\n"
+   "find_mapper\n"
+   "if [ -z \"$mapper_sysfs\" ]; then\n"
+   "  \"$cryptsetup\" luksOpen \"$device\" \"$mapper\" || exit $?\n"
+   "  find_mapper\n"
+   "fi\n"
+   "if [ -z \"$mapper_node\" ] && [ -r \"$mapper_sysfs/dev\" ]; then\n"
+   "  IFS=: read -r major minor < \"$mapper_sysfs/dev\" || exit 1\n"
+   "  [ -d /dev/mapper ] || { printf '/dev/mapper is unavailable\\n' >&2; exit 1; }\n"
+   "  \"$mknod\" -m 0600 \"/dev/mapper/$mapper\" b \"$major\" \"$minor\" || exit $?\n"
+   "  mapper_node=/dev/mapper/$mapper\n"
+   "fi\n"
+   "[ -b \"$mapper_node\" ] || { printf 'Mapper %s has no block device\\n' \"$mapper\" >&2; exit 1; }\n"
+   "pool=$(\"$zdb\" -l \"$mapper_node\" 2>/dev/null | \"$sed\" -n \"s/^[[:space:]]*name: '\\([^']*\\)'.*/\\1/p\" | \"$sed\" -n '1p')\n"
+   "if [ -n \"$pool\" ] && ! \"$zpool\" list -H -o name \"$pool\" >/dev/null 2>&1; then\n"
+   "  \"$zpool\" import -N \"$pool\" || \"$zpool\" import -d \"$mapper_node\" -N \"$pool\" || exit $?\n"
+   "fi\n"
+   "printf '%s\\n' \"$pool\"\n")
+  "Root-side script for unlocking a LUKS device and importing its ZFS pool.")
+
+(defun zfs-cli--required-executable (program)
+  "Return the absolute path to PROGRAM or signal a clear error."
+  (or (executable-find program)
+      (error "%s is required for this operation" program)))
+
+(defun zfs-cli-luks-unlock-and-import (device name passphrase)
+  "Unlock DEVICE as NAME and import its ZFS pool in one authenticated process; return the imported pool name, or nil when the unlocked device has no ZFS label."
+  (unless zfs-authentication-command
+    (error "Privileged authentication is required, but `zfs-authentication-command' is disabled"))
+  (let* ((shell (zfs-cli--required-executable "sh"))
+         (cryptsetup (zfs-cli--required-executable "cryptsetup"))
+         (zdb (zfs-cli--required-executable "zdb"))
+         (zpool (zfs-cli--required-executable "zpool"))
+         (sed (zfs-cli--required-executable "sed"))
+         (mknod (zfs-cli--required-executable "mknod"))
+         (result (zfs-cli--call-argv
+                  (append zfs-authentication-command
+                          (list shell "-c" zfs-cli--luks-unlock-script "zfs-unlock"
+                                cryptsetup zdb zpool sed mknod device name))
+                  (concat passphrase "\n"))))
+    (unless (zerop (car result))
+      (error "%s" (cdr result)))
+    (let ((pool (string-trim (cdr result))))
+      (unless (string-empty-p pool) pool))))
+
+(defun zfs-cli-luks-unlock-and-import-async (device name passphrase callback)
+  "Asynchronously unlock DEVICE as NAME, import its pool, and invoke CALLBACK with the exit status, imported pool name, and error text."
+  (unless zfs-authentication-command
+    (error "Privileged authentication is required, but `zfs-authentication-command' is disabled"))
+  (let ((shell (zfs-cli--required-executable "sh"))
+        (cryptsetup (zfs-cli--required-executable "cryptsetup"))
+        (zdb (zfs-cli--required-executable "zdb"))
+        (zpool (zfs-cli--required-executable "zpool"))
+        (sed (zfs-cli--required-executable "sed"))
+        (mknod (zfs-cli--required-executable "mknod")))
+    (zfs-cli--call-argv-async
+     (append zfs-authentication-command
+             (list shell "-c" zfs-cli--luks-unlock-script "zfs-unlock"
+                   cryptsetup zdb zpool sed mknod device name))
+     (concat (or passphrase "") "\n")
+     (lambda (status out err)
+       (funcall callback status
+                (and (zerop status)
+                     (let ((pool (string-trim out)))
+                       (unless (string-empty-p pool) pool)))
+                err)))))
+
 (defun zfs-cli-luks-close (name)
+  (unless (executable-find "cryptsetup")
+    (error "cryptsetup is required to close LUKS devices"))
   (let ((result (zfs-cli--call nil "cryptsetup" (list "luksClose" name) t)))
     (unless (zerop (car result))
       (error "%s" (cdr result)))))
-- 
cgit v1.3.1