diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/zfs-cli.el | 211 | ||||
| -rw-r--r-- | lisp/zfs.el | 94 |
2 files changed, 242 insertions, 63 deletions
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))))) diff --git a/lisp/zfs.el b/lisp/zfs.el index ff88154..efd4c31 100644 --- a/lisp/zfs.el +++ b/lisp/zfs.el @@ -26,6 +26,7 @@ Same plist shape as documented there." (defvar-local zfs-ui--row-actions nil) (defvar-local zfs-ui--refresh-fn nil) (defvar-local zfs-ui--back-action nil) +(defvar-local zfs-ui--unlock-process nil) (defun zfs-ui--targets-load () @@ -113,27 +114,28 @@ Same plist shape as documented there." (defun zfs-ui--fetch (host include-disks callback) (let ((cli-dir (file-name-directory (locate-library "zfs-cli.el")))) - (async-start - `(lambda () - (add-to-list 'load-path ,cli-dir) - (require 'zfs-cli) - (list :pools (condition-case err (zfs-cli-pools ',host) - (error (cons :error (error-message-string err)))) - :datasets (condition-case err (zfs-cli-datasets ',host) - (error (cons :error (error-message-string err)))) - :snaps (condition-case err (zfs-cli-snapshots ',host) - (error (cons :error (error-message-string err)))) - :locked ,(if include-disks - '(condition-case err - (mapcar (lambda (device) - (append device - (list :pool (and (zfs-cli-disk-unlocked-p device) - (zfs-cli-pool-on-device - (concat "/dev/mapper/" (zfs-cli-disk-mapper device))))))) - (zfs-cli-locked-disks)) - (error (cons :error (error-message-string err)))) - nil))) - callback))) + (let ((async-prompt-for-password nil)) + (async-start + `(lambda () + (add-to-list 'load-path ,cli-dir) + (require 'zfs-cli) + (list :pools (condition-case err (zfs-cli-pools ',host) + (error (cons :error (error-message-string err)))) + :datasets (condition-case err (zfs-cli-datasets ',host) + (error (cons :error (error-message-string err)))) + :snaps (condition-case err (zfs-cli-snapshots ',host) + (error (cons :error (error-message-string err)))) + :locked ,(if include-disks + '(condition-case err + (mapcar (lambda (device) + (append device + (list :pool (and (zfs-cli-disk-unlocked-p device) + (zfs-cli-pool-on-device + (concat "/dev/mapper/" (zfs-cli-disk-mapper device))))))) + (zfs-cli-locked-disks)) + (error (cons :error (error-message-string err)))) + nil))) + callback)))) (defun zfs-ui--fetch-done (result) (let ((pools (plist-get result :pools)) @@ -241,29 +243,37 @@ Same plist shape as documented there." (vui-set-state :format-status (cons (format "Format failed: %s" err) 'error))))))) +(defun zfs-ui--start-open-or-import (device passphrase) + (if (process-live-p zfs-ui--unlock-process) + (vui-set-state :message (cons "Unlock or import is already running" 'warning)) + (vui-set-state :message (cons "Waiting for Nitrokey PIN…" 'warning)) + (setq zfs-ui--unlock-process + (zfs-cli-luks-unlock-and-import-async + (plist-get device :path) (concat "luks-" (plist-get device :name)) passphrase + (vui-async-callback (status pool error-text) + (setq zfs-ui--unlock-process nil) + (if (zerop status) + (progn + (vui-set-state :message + (if pool + (cons (format "Unlocked — pool %s imported" pool) 'success) + (cons "Unlocked, but no ZFS pool found on the device" 'warning))) + (zfs-ui--refresh nil)) + (vui-set-state :message (cons (format "Error: %s" error-text) 'error)))))))) + (defun zfs-ui--do-unlock (device) - (let ((passphrase (read-passwd (format "LUKS passphrase for %s: " (plist-get device :name))))) - (condition-case err - (let ((mapper (concat "luks-" (plist-get device :name)))) - (zfs-cli-luks-open (plist-get device :path) mapper passphrase) - (let ((pool (zfs-cli-pool-on-device (concat "/dev/mapper/" mapper)))) - (if pool - (progn - (zfs-cli-import nil pool t) - (vui-set-state :message (cons (format "Unlocked — pool %s imported" pool) 'success))) - (vui-set-state :message (cons "Unlocked, but no ZFS pool found on the device" 'warning)))) - (zfs-ui--refresh nil)) - (error (zfs-ui--fail err))))) + (condition-case err + (if (zfs-cli-disk-unlocked-p device) + (zfs-ui--start-open-or-import device nil) + (let ((passphrase (read-passwd (format "LUKS passphrase for %s: " (plist-get device :name))))) + (unwind-protect + (zfs-ui--start-open-or-import device passphrase) + (clear-string passphrase)))) + (error (zfs-ui--fail err)))) (defun zfs-ui--do-import (device) (condition-case err - (let ((pool (zfs-cli-pool-on-device (concat "/dev/mapper/" (zfs-cli-disk-mapper device))))) - (if pool - (progn - (zfs-cli-import nil pool t) - (vui-set-state :message (cons (format "Imported %s" pool) 'success)) - (zfs-ui--refresh nil)) - (vui-set-state :message (cons "No ZFS pool found on the device" 'warning)))) + (zfs-ui--start-open-or-import device nil) (error (zfs-ui--fail err)))) @@ -576,7 +586,7 @@ Same plist shape as documented there." (zfs-ui--stat-card "pools" (number-to-string (length pools)) 'success card-width) (zfs-ui--stat-card "datasets" (number-to-string (length datasets)) 'link card-width) (zfs-ui--stat-card "snapshots" (number-to-string (length snaps)) 'warning card-width) - (zfs-ui--stat-card "locked disks" (number-to-string (length locked)) + (zfs-ui--stat-card "LUKS devices" (number-to-string (length locked)) (if locked 'warning 'shadow) card-width)) (vui-vstack :spacing 0 @@ -592,7 +602,7 @@ Same plist shape as documented there." (vui-vstack :spacing 0 (vui-heading-3 "Disks") - (vui-muted "LUKS disks ZFS can use once unlocked") + (vui-muted "LUKS disks and partitions ZFS can use once unlocked") (vui-table :sticky-header t :columns '((:header "" :width 3) |