From f19cf29cf1234bce1e8baf871645b07e8a3b33a2 Mon Sep 17 00:00:00 2001 From: cashmere Date: Mon, 3 Aug 2026 02:19:39 +0200 Subject: md: add zfs-ui.el --- lisp/zfs-cli.el | 415 ++++++++++++++++++++++ lisp/zfs.el | 1028 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 1443 insertions(+) create mode 100644 lisp/zfs-cli.el create mode 100644 lisp/zfs.el diff --git a/lisp/zfs-cli.el b/lisp/zfs-cli.el new file mode 100644 index 0000000..0e571d8 --- /dev/null +++ b/lisp/zfs-cli.el @@ -0,0 +1,415 @@ +;;; zfs-cli.el --- ZFS command execution and JSON parsing -*- lexical-binding: t; -*- + +(require 'subr-x) + +(defgroup zfs nil + "ZFS management interface." + :group 'tools) + +(defcustom zfs-hosts nil + "Remote ZFS hosts as plists with :name and :ssh keys. +Example: ((:name \"vps1\" :ssh \"cashmere@1.2.3.4\"))" + :type '(repeat sexp) + :group 'zfs) + +(defcustom zfs-privileged-command '("doas" "-n") + "Command used to retry ZFS operations with elevated privileges." + :type '(repeat string) + :group 'zfs) + +(defconst zfs-cli--permission-error-re "permission denied\\|Insufficient privileges\\|delegated permission") + +(defconst zfs-cli-dataset-properties + '(used available referenced usedbysnapshots usedbychildren compressratio + encryption keystatus mountpoint mounted quota recordsize creation)) + +(defconst zfs-cli-snapshot-properties + '(used referenced creation)) + +(defconst zfs-cli-pool-properties + '(size allocated free capacity fragmentation health dedupratio)) + +(defun zfs-cli--argv (host program args sudo) + (let ((command (append (when sudo zfs-privileged-command) (cons program args)))) + (if-let* ((target (plist-get host :ssh))) + (list "ssh" "-o" "BatchMode=yes" "-o" "ConnectTimeout=5" target + (mapconcat #'shell-quote-argument command " ")) + command))) + +(defun zfs-cli--call (host program args sudo &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))) + (unwind-protect + (progn + (when input-file + (with-temp-file input-file (insert input))) + (with-temp-buffer + (let ((status (apply #'process-file (car argv) input-file (list t stderr-file) nil (cdr argv)))) + (if (zerop status) + (cons 0 (buffer-string)) + (cons status + (with-temp-buffer + (insert-file-contents stderr-file) + (string-trim (buffer-string)))))))) + (delete-file stderr-file) + (when input-file (delete-file input-file))))) + +(defun zfs-cli-run (host program args &optional input) + (let ((result (zfs-cli--call host program args nil input))) + (when (and (/= 0 (car result)) + (string-match-p zfs-cli--permission-error-re (cdr result))) + (setq result (zfs-cli--call host program args t input))) + (if (zerop (car result)) + (cdr result) + (error "zfs-cli: %s" (cdr result))))) + +(defun zfs-cli-run-async (host program args callback &optional sudo) + (let ((stdout (generate-new-buffer " *zfs-cli-out*")) + (stderr (generate-new-buffer " *zfs-cli-err*")) + (argv (zfs-cli--argv host program args sudo))) + (make-process + :name "zfs-cli" + :buffer stdout + :stderr stderr + :command argv + :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) + (if (and (/= 0 status) + (not sudo) + (string-match-p zfs-cli--permission-error-re err)) + (zfs-cli-run-async host program args callback t) + (funcall callback (if (zerop status) (cons 0 out) (cons status err)))))))))) + +(defun zfs-cli-run-json (host program args) + (json-parse-string (zfs-cli-run host program args) + :object-type 'alist + :array-type 'list + :null-object nil + :false-object nil)) + +(defun zfs-cli--parse-collection (json key) + (mapcar (lambda (entry) (cons (symbol-name (car entry)) (cdr entry))) + (alist-get key json))) + +(defun zfs-cli-prop (entry property) + (alist-get 'value (alist-get property (alist-get 'properties (cdr entry))))) + +(defun zfs-cli-source (entry property) + (alist-get 'type (alist-get 'source (alist-get property (alist-get 'properties (cdr entry)))))) + +(defun zfs-cli--list-args (types properties) + (list "list" "-j" "-H" "--json-int" "-t" (string-join types ",") + "-o" (string-join (cons "name" (mapcar #'symbol-name properties)) ","))) + +(defun zfs-cli-datasets (host) + (zfs-cli--parse-collection + (zfs-cli-run-json host "zfs" + (zfs-cli--list-args '("filesystem" "volume") zfs-cli-dataset-properties)) + 'datasets)) + +(defun zfs-cli-snapshots (host &optional dataset) + (zfs-cli--parse-collection + (zfs-cli-run-json host "zfs" + (append (zfs-cli--list-args '("snapshot") zfs-cli-snapshot-properties) + (and dataset (list dataset)))) + 'datasets)) + +(defun zfs-cli-pools (host) + (zfs-cli--parse-collection + (zfs-cli-run-json host "zpool" + (list "list" "-j" "-H" "--json-int" + "-o" (string-join (cons "name" (mapcar #'symbol-name zfs-cli-pool-properties)) ","))) + 'pools)) + +(defun zfs-cli-snapshot (host dataset snap-name &optional recursive) + (zfs-cli-run host "zfs" + (append '("snapshot") (and recursive '("-r")) + (list (concat dataset "@" snap-name))))) + +(defun zfs-cli-create (host dataset properties) + (zfs-cli-run host "zfs" + (append '("create") + (mapcan (lambda (pair) (list "-o" (format "%s=%s" (car pair) (cdr pair)))) properties) + (list dataset)))) + +(defun zfs-cli-destroy (host target &optional recursive) + (zfs-cli-run host "zfs" + (append '("destroy") (and recursive '("-r")) (list target)))) + +(defun zfs-cli-rollback (host snapshot &optional force) + (zfs-cli-run host "zfs" + (append '("rollback") (and force '("-f")) (list snapshot)))) + +(defun zfs-cli-diff (host snapshot &optional other) + (zfs-cli-run host "zfs" + (append '("diff" "-H") (list snapshot) (and other (list other))))) + +(defun zfs-cli-send-preview (host snapshot &optional base) + (let* ((args (append '("send" "-nPv") (and base (list "-i" base)) (list snapshot))) + (output (zfs-cli-run host "zfs" args)) + (header (car (split-string output "\n" t))) + (fields (split-string header "\t"))) + (list :kind (car fields) + :base (and (equal (car fields) "incremental") (nth 1 fields)) + :bytes (string-to-number (or (car (last fields)) "0"))))) + +(defun zfs-cli--remote-wrap (host command-string) + (if-let* ((target (plist-get host :ssh))) + (format "ssh -o BatchMode=yes -o ConnectTimeout=5 %s %s" + (shell-quote-argument target) + (shell-quote-argument command-string)) + command-string)) + +(defun zfs-cli-send-pipeline (source-host snapshot target-host target-dataset base raw sudo) + (let* ((send-command (mapconcat #'shell-quote-argument + (append (when sudo zfs-privileged-command) + '("zfs" "send" "-v") + (and raw '("-w")) + (and base (list "-i" base)) + (list snapshot)) + " ")) + (receive-command (mapconcat #'shell-quote-argument + (append (when sudo zfs-privileged-command) + (list "zfs" "receive" target-dataset)) + " "))) + (concat (zfs-cli--remote-wrap source-host send-command) + " | " + (zfs-cli--remote-wrap target-host receive-command)))) + +(defun zfs-cli-send-async (source-host snapshot target-host target-dataset base raw callback &optional sudo) + (let* ((stderr-buffer (generate-new-buffer " *zfs-send-err*")) + (stderr-process + (make-pipe-process :name "zfs-send-stderr" + :buffer stderr-buffer + :noquery t + :filter (lambda (process chunk) + (when (buffer-live-p (process-buffer process)) + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert chunk))) + (when-let* ((line (car (last (split-string chunk "\n"))))) + (unless (string-blank-p line) + (funcall callback (list :progress (string-trim line)))))))) + (pipeline (zfs-cli-send-pipeline source-host snapshot target-host target-dataset base raw sudo))) + (make-process + :name "zfs-send" + :buffer (generate-new-buffer " *zfs-send-out*") + :stderr stderr-process + :command (list "sh" "-c" pipeline) + :noquery t + :sentinel + (lambda (process _event) + (when (memq (process-status process) '(exit signal)) + (let ((status (process-exit-status process)) + (err (string-trim (with-current-buffer stderr-buffer (buffer-string))))) + (when (buffer-live-p (process-buffer process)) + (kill-buffer (process-buffer process))) + (when (process-live-p stderr-process) + (delete-process stderr-process)) + (kill-buffer stderr-buffer) + (if (and (/= 0 status) + (not sudo) + (string-match-p zfs-cli--permission-error-re err)) + (zfs-cli-send-async source-host snapshot target-host target-dataset base raw callback t) + (funcall callback (list :done status err))))))))) + +(defun zfs-cli-mount (host dataset) + (zfs-cli-run host "zfs" (list "mount" dataset))) + +(defun zfs-cli-create-encrypted (host dataset passphrase &optional properties) + (zfs-cli-run host "zfs" + (append '("create") + (mapcan (lambda (pair) (list "-o" (format "%s=%s" (car pair) (cdr pair)))) + (append properties + '((encryption . "on") + (keyformat . "passphrase") + (keylocation . "prompt")))) + (list dataset)) + (concat passphrase "\n"))) + +(defun zfs-cli-pool-status (host pool) + (let ((json (zfs-cli-run-json host "zpool" (list "status" "-j" "--json-int" pool)))) + (alist-get (intern pool) (alist-get 'pools json)))) + +(defun zfs-cli--vdev-entries (node) + (cons (list :name (alist-get 'name node) + :state (alist-get 'state node) + :read-errors (alist-get 'read_errors node) + :write-errors (alist-get 'write_errors node) + :checksum-errors (alist-get 'checksum_errors node) + :type (alist-get 'vdev_type node)) + (mapcan #'zfs-cli--vdev-entries (mapcar #'cdr (alist-get 'vdevs node))))) + +(defun zfs-cli-pool-vdevs (status) + (mapcan #'zfs-cli--vdev-entries (mapcar #'cdr (alist-get 'vdevs status)))) + +(defun zfs-cli-scrub (host pool &optional stop) + (zfs-cli-run host "zpool" (append '("scrub") (and stop '("-s")) (list pool)))) + +(defun zfs-cli-export (host pool) + (zfs-cli-run host "zpool" (list "export" pool))) + +(defun zfs-cli-import (host pool &optional no-mount) + (let ((attempt (lambda (extra sudo) + (zfs-cli--call host "zpool" + (append '("import") extra (and no-mount '("-N")) (list pool)) + sudo))) + (result nil)) + (dolist (step '((nil . nil) (nil . t) (("-d" "/dev/mapper") . t))) + (when (or (null result) (/= 0 (car result))) + (setq result (funcall attempt (car step) (cdr step))))) + (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-block-devices () + (let ((json (zfs-cli-run-json nil "lsblk" '("-J" "-b" "-o" "NAME,SIZE,FSTYPE,MODEL,TYPE,MOUNTPOINTS")))) + (mapcar #'zfs-cli--parse-block-device (alist-get 'blockdevices json)))) + +(defun zfs-cli-locked-disks () + (seq-filter (lambda (device) + (and (member (plist-get device :type) '("disk" "loop")) + (equal (plist-get device :fstype) "crypto_LUKS"))) + (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))) + +(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))) + +(defun zfs-cli--device-tree-mounted-p (device) + (or (plist-get device :mounted) + (seq-some #'zfs-cli--device-tree-mounted-p (plist-get device :children)))) + +(defun zfs-cli--device-tree-active-p (device) + (or (member (plist-get device :type) '("crypt" "lvm" "raid")) + (seq-some #'zfs-cli--device-tree-active-p (plist-get device :children)))) + +(defun zfs-cli-disk-candidates () + (seq-filter (lambda (device) + (and (equal (plist-get device :type) "disk") + (not (zfs-cli--device-tree-mounted-p device)) + (not (zfs-cli--device-tree-active-p device)))) + (zfs-cli-block-devices))) + +(defun zfs-cli-pool-on-device (device) + (let ((result (zfs-cli--call nil "zdb" (list "-l" device) t))) + (when (and (zerop (car result)) + (string-match "name: '\\([^']+\\)'" (cdr result))) + (match-string 1 (cdr result))))) + +(defun zfs-cli-luks-open (device name passphrase) + (let ((result (zfs-cli--call nil "cryptsetup" (list "luksOpen" device name) t + (concat passphrase "\n")))) + (unless (zerop (car result)) + (error "%s" (cdr result))))) + +(defun zfs-cli-luks-close (name) + (let ((result (zfs-cli--call nil "cryptsetup" (list "luksClose" name) t))) + (unless (zerop (car result)) + (error "%s" (cdr result))))) + +(defun zfs-cli--pipe-async (pipeline stream on-chunk on-done) + (let ((out-buffer (generate-new-buffer " *zfs-pipe-out*")) + (err-buffer (generate-new-buffer " *zfs-pipe-err*")) + (consumer nil)) + (when (eq stream 'stderr) + (setq consumer + (make-pipe-process + :name "zfs-pipe-stderr" + :buffer err-buffer + :noquery t + :filter (lambda (process chunk) + (when (buffer-live-p (process-buffer process)) + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert chunk))) + (funcall on-chunk chunk))))) + (make-process + :name "zfs-pipe" + :buffer out-buffer + :stderr (or consumer err-buffer) + :command (list "sh" "-c" pipeline) + :noquery t + :filter (when (eq stream 'stdout) + (lambda (process chunk) + (when (buffer-live-p (process-buffer process)) + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (insert chunk))) + (funcall on-chunk chunk))) + :sentinel + (lambda (process _event) + (when (memq (process-status process) '(exit signal)) + (let ((status (process-exit-status process)) + (out (with-current-buffer out-buffer (buffer-string))) + (err (string-trim (with-current-buffer err-buffer (buffer-string))))) + (when (process-live-p consumer) + (delete-process consumer)) + (kill-buffer out-buffer) + (kill-buffer err-buffer) + (funcall on-done status err out))))))) + +(defun zfs-cli-format-disk-async (device pool-name mapper-name passphrase callback) + (let ((key-file (and passphrase (make-temp-file "zfs-luks-key-")))) + (when key-file + (with-temp-file key-file (insert passphrase)) + (chmod key-file #o600)) + (let ((pipeline + (if passphrase + (mapconcat + #'identity + (list (format "doas -n wipefs -a %s" (shell-quote-argument device)) + (format "doas -n cryptsetup luksFormat -q --key-file %s %s" + (shell-quote-argument key-file) (shell-quote-argument device)) + (format "doas -n cryptsetup open --key-file %s %s %s" + (shell-quote-argument key-file) (shell-quote-argument device) + (shell-quote-argument mapper-name)) + (format "doas -n zpool create -O compression=lz4 -O mountpoint=none %s %s" + (shell-quote-argument pool-name) + (shell-quote-argument (concat "/dev/mapper/" mapper-name)))) + " && ") + (format "doas -n wipefs -a %s && doas -n zpool create -f -O compression=lz4 -O mountpoint=none %s %s" + (shell-quote-argument device) + (shell-quote-argument pool-name) + (shell-quote-argument device))))) + (zfs-cli--pipe-async pipeline 'stderr + #'ignore + (lambda (status err _out) + (when key-file + (delete-file key-file)) + (funcall callback status err)))))) + +(defun zfs-cli-rsync-async (source target callback) + (zfs-cli--pipe-async + (format "rsync -a --info=progress2 %s %s" + (shell-quote-argument (file-name-as-directory (expand-file-name source))) + (shell-quote-argument (file-name-as-directory (expand-file-name target)))) + 'stdout + (lambda (chunk) (funcall callback (list :progress chunk))) + (lambda (status err _out) (funcall callback (list :done status err))))) + +(provide 'zfs-cli) +;;; zfs-cli.el ends here diff --git a/lisp/zfs.el b/lisp/zfs.el new file mode 100644 index 0000000..7d86e2e --- /dev/null +++ b/lisp/zfs.el @@ -0,0 +1,1028 @@ +;;; zfs.el --- ZFS management UI -*- lexical-binding: t; -*- + +(require 'vui) +(require 'vui-components) +(require 'async) +(require 'zfs-cli) + +(defcustom zfs-buffer-name "*zfs*" + "Name of the ZFS management buffer." + :type 'string + :group 'zfs) + +(defcustom zfs-targets-file (locate-user-emacs-file "zfs-targets.eld") + "File where backup targets are stored as a plain elisp list." + :type 'file + :group 'zfs) + +(defcustom zfs-backup-targets nil + "Seed backup targets, used when `zfs-targets-file' does not exist yet. +Same plist shape as documented there." + :type '(repeat sexp) + :group 'zfs) + +(defvar-local zfs-ui--row-actions nil) +(defvar-local zfs-ui--refresh-fn nil) + +(defun zfs-ui--targets-load () + (if (file-exists-p zfs-targets-file) + (with-temp-buffer + (insert-file-contents zfs-targets-file) + (goto-char (point-min)) + (read (current-buffer))) + zfs-backup-targets)) + +(defun zfs-ui--targets-save (targets) + (with-temp-file zfs-targets-file + (pp targets (current-buffer)))) + +(defun zfs--format-bytes (bytes) + (cond + ((null bytes) "-") + ((not (numberp bytes)) (format "%s" bytes)) + (t (let ((units '((1099511627776 . "T") (1073741824 . "G") (1048576 . "M") (1024 . "K"))) + (result nil)) + (dolist (unit units) + (when (and (not result) (>= bytes (car unit))) + (let ((value (/ bytes (float (car unit))))) + (setq result (if (< value 10) (format "%.1f%s" value (cdr unit)) + (format "%.0f%s" value (cdr unit))))))) + (or result (format "%dB" bytes)))))) + +(defun zfs--format-ago (epoch) + (if (not (numberp epoch)) + "-" + (let ((delta (- (float-time) epoch))) + (cond + ((< delta 90) "just now") + ((< delta 3600) (format "%dm ago" (truncate (/ delta 60)))) + ((< delta 86400) (format "%dh ago" (truncate (/ delta 3600)))) + ((< delta (* 30 86400)) (format "%dd ago" (truncate (/ delta 86400)))) + ((< delta (* 365 86400)) (format "%dmo ago" (truncate (/ delta (* 30 86400))))) + (t (format "%dy ago" (truncate (/ delta (* 365 86400))))))))) + +(defun zfs--gauge (percent &optional width) + (let* ((width (or width 20)) + (done (max 0 (min width (round (* width (/ (or percent 0) 100.0))))))) + (concat (make-string done ?█) (make-string (- width done) ?░)))) + +(defun zfs--health-face (health) + (pcase health + ("ONLINE" 'success) + ("DEGRADED" 'warning) + (_ 'error))) + +(defun zfs--capacity-face (percent) + (cond + ((>= (or percent 0) 90) 'error) + ((>= (or percent 0) 75) 'warning) + (t 'success))) + +(defun zfs--direct-children (datasets parent) + (let ((prefix (concat parent "/"))) + (seq-filter (lambda (entry) + (and (string-prefix-p prefix (car entry)) + (not (string-match-p "/" (substring (car entry) (length prefix)))))) + datasets))) + +(defun zfs--snapshots-of (snaps dataset) + (seq-filter (lambda (entry) + (string-prefix-p (concat dataset "@") (car entry))) + snaps)) + +(defun zfs--snapshot-leaf (full-name) + (car (last (split-string full-name "@" t)))) + +(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))) + +(defun zfs-ui--fetch-done (result) + (let ((pools (plist-get result :pools)) + (datasets (plist-get result :datasets)) + (snaps (plist-get result :snaps)) + (locked (plist-get result :locked))) + (vui-batch + (vui-set-state :loading nil) + (vui-set-state :refreshed (format-time-string "%H:%M")) + (if (and (eq (car-safe pools) :error) (eq (car-safe datasets) :error)) + (vui-set-state :message (cons (format "Could not reach host: %s" (cdr pools)) 'error)) + (vui-set-state :pools (and (not (eq (car-safe pools) :error)) pools)) + (vui-set-state :datasets (and (not (eq (car-safe datasets) :error)) datasets)) + (vui-set-state :snaps (and (not (eq (car-safe snaps) :error)) snaps)) + (vui-set-state :locked (and (listp locked) (not (eq (car-safe locked) :error)) locked)))))) + +(defun zfs-ui--refresh (host) + (vui-set-state :loading t) + (zfs-ui--fetch host (null host) (vui-async-callback (result) (zfs-ui--fetch-done result)))) + +(defun zfs-ui--go (page &optional arg) + (vui-batch + (vui-set-state :page page) + (vui-set-state :page-arg arg) + (vui-set-state :backup-target nil) + (vui-set-state :backup-preview nil) + (vui-set-state :backup-progress nil) + (vui-set-state :backup-done nil) + (vui-set-state :create-status nil) + (vui-set-state :format-disk nil) + (vui-set-state :format-status nil))) + +(defun zfs-ui--fail (err) + (vui-set-state :message (cons (format "Error: %s" (error-message-string err)) 'error))) + +(defun zfs-ui--do-snapshot (host dataset) + (let ((snap-name (read-string (format "Snapshot name for %s: " dataset) + (format-time-string "manual-%Y-%m-%d_%H-%M")))) + (condition-case err + (progn + (zfs-cli-snapshot host dataset snap-name) + (vui-set-state :message (cons (format "Snapshot %s@%s created" dataset snap-name) 'success)) + (zfs-ui--refresh host)) + (error (zfs-ui--fail err))))) + +(defun zfs-ui--do-destroy (host target has-dependents) + (when (yes-or-no-p (if has-dependents + (format "Destroy %s including its children and snapshots? " target) + (format "Destroy %s? " target))) + (condition-case err + (progn + (zfs-cli-destroy host target has-dependents) + (vui-set-state :message (cons (format "Destroyed %s" target) 'success)) + (zfs-ui--refresh host)) + (error (zfs-ui--fail err))))) + +(defun zfs-ui--do-rollback (host snapshot) + (when (yes-or-no-p (format "Roll back to %s? Snapshots taken after it are destroyed. " snapshot)) + (condition-case err + (progn + (zfs-cli-rollback host snapshot) + (vui-set-state :message (cons (format "Rolled back to %s" snapshot) 'success)) + (zfs-ui--refresh host)) + (error (zfs-ui--fail err))))) + +(defun zfs-ui--do-mount (host dataset) + (condition-case err + (progn + (zfs-cli-mount host dataset) + (vui-set-state :message (cons (format "Mounted %s" dataset) 'success)) + (zfs-ui--refresh host)) + (error (zfs-ui--fail err)))) + +(defun zfs-ui--do-diff (host snapshot) + (let ((command (if host + (format "ssh -o BatchMode=yes %s %s" + (shell-quote-argument (plist-get host :ssh)) + (shell-quote-argument (concat "doas -n zfs diff -H " snapshot))) + (format "doas -n zfs diff -H %s" snapshot)))) + (if (fboundp 'ghostel-compile) + (ghostel-compile command) + (compile command)))) + +(defun zfs-ui--do-scrub (host pool stop) + (condition-case err + (progn + (zfs-cli-scrub host pool stop) + (vui-set-state :message (cons (if stop "Scrub stopped" "Scrub started — reads all data, verifies checksums") + 'success)) + (zfs-ui--refresh host)) + (error (zfs-ui--fail err)))) + +(defun zfs-ui--do-export (host pool) + (when (yes-or-no-p (format "Export %s? The pool goes offline until imported again. " pool)) + (condition-case err + (progn + (zfs-cli-export host pool) + (vui-set-state :message (cons (format "Exported %s" pool) 'success)) + (zfs-ui--go 'overview) + (zfs-ui--refresh host)) + (error (zfs-ui--fail err))))) + +(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))))) + +(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)))) + (error (zfs-ui--fail err)))) + +(defun zfs-ui--do-lock (device pools) + (let* ((mapper (zfs-cli-disk-mapper device)) + (pool (zfs-cli-pool-on-device (concat "/dev/mapper/" mapper)))) + (when (yes-or-no-p (if (and pool (assoc pool pools)) + (format "Export %s and lock %s? " pool (plist-get device :name)) + (format "Lock %s? " (plist-get device :name)))) + (condition-case err + (progn + (when (and pool (assoc pool pools)) + (zfs-cli-export nil pool)) + (zfs-cli-luks-close mapper) + (vui-set-state :message (cons (format "Locked %s" (plist-get device :name)) 'success)) + (zfs-ui--refresh nil)) + (error (zfs-ui--fail err)))))) + +(defun zfs-ui--common-base (snaps target-snap-names dataset) + (let* ((own (zfs--snapshots-of snaps dataset)) + (common (seq-filter (lambda (entry) + (member (zfs--snapshot-leaf (car entry)) target-snap-names)) + own)) + (sorted (sort (copy-sequence common) + (lambda (a b) (< (or (zfs-cli-prop a 'creation) 0) + (or (zfs-cli-prop b 'creation) 0)))))) + (when sorted + (car (car (last sorted)))))) + +(defun zfs-ui--newest-snapshot (snaps dataset) + (let ((sorted (sort (copy-sequence (zfs--snapshots-of snaps dataset)) + (lambda (a b) (< (or (zfs-cli-prop a 'creation) 0) + (or (zfs-cli-prop b 'creation) 0)))))) + (car (last sorted)))) + +(defun zfs-ui--backup-preview (host dataset snapshot snaps entry target) + (let* ((leaf (file-name-nondirectory dataset)) + (target-dataset (concat (plist-get target :dataset) "/" leaf)) + (target-snap-names (condition-case nil + (mapcar (lambda (snap-entry) (zfs--snapshot-leaf (car snap-entry))) + (zfs-cli-snapshots target target-dataset)) + (error nil))) + (base (zfs-ui--common-base snaps target-snap-names dataset)) + (raw (and entry (not (member (zfs-cli-prop entry 'encryption) '(nil "off"))))) + (preview (zfs-cli-send-preview host snapshot base))) + (list :target-dataset target-dataset + :base base + :raw raw + :kind (plist-get preview :kind) + :bytes (plist-get preview :bytes)))) + +(defun zfs-ui--backup-event (event) + (pcase (car event) + (:progress + (vui-set-state :backup-progress (nth 1 event))) + (:done + (if (zerop (nth 1 event)) + (vui-batch + (vui-set-state :backup-done 'success) + (vui-set-state :backup-progress nil)) + (vui-batch + (vui-set-state :backup-done (format "%s" (nth 2 event))) + (vui-set-state :backup-progress nil)))))) + +(defun zfs-ui--start-backup (host snapshot target preview) + (vui-batch + (vui-set-state :backup-progress "starting…") + (vui-set-state :backup-done nil)) + (zfs-cli-send-async host snapshot target (plist-get preview :target-dataset) + (plist-get preview :base) (plist-get preview :raw) + (vui-async-callback (event) + (zfs-ui--backup-event event)))) + +(defun zfs-ui--field-string (key) + (or (vui-field-value key) "")) + +(defun zfs-ui--start-move (host dataset mountpoint move-dir) + (vui-set-state :create-status (cons "Copying… 0%" 'shadow)) + (zfs-cli-rsync-async + move-dir mountpoint + (vui-async-callback (event) + (pcase (car event) + (:progress + (when (string-match "\\([0-9]+%\\)" (nth 1 event)) + (vui-set-state :create-status + (cons (format "Copying… %s" (match-string 1 (nth 1 event))) 'shadow)))) + (:done + (if (zerop (nth 1 event)) + (vui-set-state :message + (cons (format "%s created, data copied — original kept in %s" dataset move-dir) + 'success)) + (vui-set-state :message + (cons (format "%s created, but copying failed: %s" dataset (nth 2 event)) + 'error))) + (zfs-ui--go 'dataset dataset) + (zfs-ui--refresh host)))))) + +(defun zfs-ui--do-create-dataset (host parent) + (let* ((leaf (zfs-ui--field-string "create-name")) + (mountpoint (zfs-ui--field-string "create-mountpoint")) + (quota (zfs-ui--field-string "create-quota")) + (passphrase (zfs-ui--field-string "create-passphrase")) + (encrypted (not (string-blank-p passphrase))) + (compression (zfs-ui--field-string "create-compression")) + (move-dir (zfs-ui--field-string "create-move")) + (dataset (concat parent "/" leaf))) + (cond + ((string-blank-p leaf) + (vui-set-state :create-status (cons "Name is empty" 'error))) + ((string-match-p "/" leaf) + (vui-set-state :create-status (cons "Name must be a single segment, no slashes" 'error))) + ((and (not (string-blank-p move-dir)) (string-blank-p mountpoint)) + (vui-set-state :create-status (cons "Moving a folder in needs a mountpoint" 'error))) + (t + (let ((properties nil)) + (when (and compression (not (equal compression "inherit"))) + (push (cons "compression" compression) properties)) + (when (and mountpoint (not (string-blank-p mountpoint)) (not (equal mountpoint "none"))) + (push (cons "mountpoint" mountpoint) properties)) + (when (and quota (not (string-blank-p quota))) + (push (cons "quota" quota) properties)) + (condition-case err + (progn + (if encrypted + (zfs-cli-create-encrypted host dataset passphrase properties) + (zfs-cli-create host dataset properties)) + (when (and (not (string-blank-p mountpoint)) (not (equal mountpoint "none"))) + (ignore-errors (zfs-cli-mount host dataset))) + (if (not (string-blank-p move-dir)) + (zfs-ui--start-move host dataset mountpoint move-dir) + (vui-set-state :message (cons (format "Created %s" dataset) 'success)) + (zfs-ui--go 'dataset dataset) + (zfs-ui--refresh host))) + (error (vui-set-state :create-status (cons (error-message-string err) 'error))))))))) + +(defun zfs-ui--do-format (device pool-name encrypted passphrase) + (let ((mapper (concat "luks-" (plist-get device :name)))) + (vui-set-state :format-status (cons "Formatting… this takes a moment" 'shadow)) + (zfs-cli-format-disk-async + (plist-get device :path) pool-name mapper (and encrypted passphrase) + (vui-async-callback (status err) + (if (zerop status) + (vui-batch + (vui-set-state :format-status (cons (format "Pool %s created on %s" pool-name (plist-get device :name)) + 'success)) + (vui-set-state :format-disk nil) + (zfs-ui--refresh nil)) + (vui-set-state :format-status (cons (format "Format failed: %s" err) 'error))))))) + +(defconst zfs-ui--property-glossary + '(("used" . "live data + snapshots + children together") + ("referenced" . "live data right now, snapshots excluded") + ("usedbysnapshots" . "only reachable through snapshots; freed when you delete them") + ("usedbychildren" . "used by datasets below this one") + ("available" . "room this dataset can still grow into") + ("compressratio" . "how much smaller data is stored; 1.31x ≈ 24% saved") + ("encryption" . "dataset-level encryption, independent of disk LUKS") + ("keystatus" . "available = key loaded, data readable") + ("mountpoint" . "where it shows up; legacy = mounted by the system, not zfs") + ("recordsize" . "max block size; matters for databases and VM images") + ("quota" . "hard size limit, if set") + ("reservation" . "space guaranteed to this dataset, if set") + ("creation" . "when the dataset was created") + ("mounted" . "whether it is currently mounted"))) + +(defun zfs-ui--dataset-row (entry depth snap-count) + (let* ((name (car entry)) + (short (file-name-nondirectory name)) + (label (concat (make-string (* 2 depth) ?\s) + (if (> snap-count 0) "▸ " " ") + short + (when (> snap-count 0) (format " (%d)" snap-count)))) + (encryption (zfs-cli-prop entry 'encryption)) + (keystatus (zfs-cli-prop entry 'keystatus))) + (vui-hstack + (vui-box (vui-button (truncate-string-to-width label 32) :no-decoration t + :key (concat "ds:" name) + :on-click (lambda () (zfs-ui--go 'dataset name))) + :width 34) + (vui-box (vui-text (zfs--format-bytes (zfs-cli-prop entry 'used))) :width 9) + (vui-box (vui-text (zfs--format-bytes (zfs-cli-prop entry 'available)) :face 'shadow) :width 9) + (vui-box (vui-text (format "%s" (or (zfs-cli-prop entry 'compressratio) "-")) :face 'shadow) :width 7) + (vui-box (cond + ((or (null encryption) (equal encryption "off")) (vui-text "·" :face 'shadow)) + ((equal keystatus "available") (vui-text "🔓" :face 'success)) + (t (vui-text "🔒" :face 'warning))) + :width 4)))) + +(defun zfs-ui--dataset-rows (entry depth datasets snaps) + (let* ((name (car entry)) + (children (zfs--direct-children datasets name)) + (own-snaps (zfs--snapshots-of snaps name))) + (push (cons (concat "ds:" name) + (list :open (vui-with-async-context (zfs-ui--go 'dataset name)) + :backup (vui-with-async-context (zfs-ui--go 'backup name)) + :create-child (vui-with-async-context (zfs-ui--go 'create name)))) + zfs-ui--row-actions) + (cons (zfs-ui--dataset-row entry depth (length own-snaps)) + (mapcan (lambda (child) (zfs-ui--dataset-rows child (1+ depth) datasets snaps)) + children)))) + +(defun zfs-ui--pool-row (pool) + (let* ((name (car pool)) + (health (zfs-cli-prop pool 'health)) + (capacity (zfs-cli-prop pool 'capacity)) + (size (zfs-cli-prop pool 'size)) + (free (zfs-cli-prop pool 'free))) + (push (cons (concat "pool:" name) + (list :open (vui-with-async-context (zfs-ui--go 'pool name)) + :create-child (vui-with-async-context (zfs-ui--go 'create name)))) + zfs-ui--row-actions) + (vui-hstack + :spacing 1 + (vui-box (vui-button name :no-decoration t + :key (concat "pool:" name) + :on-click (lambda () (zfs-ui--go 'pool name))) + :width 10) + (vui-box (vui-text (or health "?") :face (zfs--health-face health)) :width 9) + (vui-box (vui-text (zfs--gauge capacity) + :face (zfs--capacity-face capacity)) + :width 22) + (vui-text (format "%d%% · %s free of %s" + (or capacity 0) + (zfs--format-bytes free) + (zfs--format-bytes size)) + :face 'shadow)))) + +(defun zfs-ui--locked-disk-row (device pools) + (let* ((name (plist-get device :name)) + (unlocked (zfs-cli-disk-unlocked-p device)) + (mapper (zfs-cli-disk-mapper device)) + (pool (plist-get device :pool)) + (imported (and pool (assoc pool pools)))) + (push (cons (concat "lock:" name) + (if unlocked + (append (unless imported + (list :import (vui-with-async-context (zfs-ui--do-import device)))) + (list :lock (vui-with-async-context (zfs-ui--do-lock device pools)))) + (list :unlock (vui-with-async-context (zfs-ui--do-unlock device))))) + zfs-ui--row-actions) + (vui-hstack + :spacing 1 + (vui-box (vui-text (if unlocked "🔓" "🔒") :face (if unlocked 'warning 'shadow)) :width 3) + (vui-box (vui-button name :no-decoration t + :key (concat "lock:" name) + :on-click (lambda () nil)) + :width 10) + (vui-box (vui-text (or (plist-get device :model) "?") :face 'shadow) :width 24) + (vui-box (vui-text (zfs--format-bytes (plist-get device :size)) :face 'shadow) :width 8) + (vui-text (cond + (imported (format "pool %s imported · L ejects and locks" pool)) + (unlocked (format "unlocked as %s · i imports pool %s · L locks" mapper (or pool "?"))) + (t "locked · u unlock")) + :face 'shadow)))) + +(defun zfs-ui--page-overview (pools datasets snaps locked) + (push (cons 'page + (list :format (vui-with-async-context (zfs-ui--go 'new-pool)) + :targets (vui-with-async-context (zfs-ui--go 'targets)))) + zfs-ui--row-actions) + (let ((roots (seq-filter (lambda (entry) (not (string-match-p "/" (car entry)))) datasets))) + (apply + #'vui-vstack + :spacing 1 + (append + (when locked + (list (vui-vstack + :spacing 0 + (vui-heading-3 "Disks") + (vui-muted "LUKS disks ZFS can use once unlocked") + (apply #'vui-vstack :spacing 0 + (mapcar (lambda (device) (zfs-ui--locked-disk-row device pools)) locked))))) + (list + (vui-vstack + :spacing 0 + (vui-heading-3 "Pools") + (vui-muted "teams of disks; datasets live inside them · RET details · F format a disk") + (apply #'vui-vstack :spacing 0 (mapcar #'zfs-ui--pool-row pools))) + (vui-vstack + :spacing 0 + (vui-heading-3 "Datasets") + (vui-muted "named drawers · RET details · b backup · c new dataset inside") + (vui-hstack + (vui-box (vui-text "NAME" :face 'shadow) :width 34) + (vui-box (vui-text "USED" :face 'shadow) :width 9) + (vui-box (vui-text "AVAIL" :face 'shadow) :width 9) + (vui-box (vui-text "RATIO" :face 'shadow) :width 7) + (vui-box (vui-text "ENC" :face 'shadow) :width 4)) + (apply #'vui-vstack :spacing 0 + (mapcan (lambda (root) (zfs-ui--dataset-rows root 0 datasets snaps)) roots)))))))) + +(defun zfs-ui--property-row (entry property) + (let* ((raw (zfs-cli-prop entry (intern property))) + (value (cond + ((equal property "creation") (format "%s (%s)" + (format-time-string "%Y-%m-%d" raw) + (zfs--format-ago raw))) + ((and (member property '("quota" "reservation")) (or (null raw) (equal raw 0))) "none") + ((numberp raw) (zfs--format-bytes raw)) + (t (format "%s" (or raw "-"))))) + (gloss (cdr (assoc property zfs-ui--property-glossary)))) + (vui-hstack + (vui-box (vui-text property :face 'shadow) :width 18) + (vui-box (vui-text value) :width 22) + (vui-text (or gloss "") :face 'shadow)))) + +(defun zfs-ui--snapshot-row (snap dataset host) + (let* ((full-name (car snap)) + (leaf (zfs--snapshot-leaf full-name))) + (push (cons (concat "snap:" full-name) + (list :diff (vui-with-async-context (zfs-ui--do-diff host full-name)) + :rollback (vui-with-async-context (zfs-ui--do-rollback host full-name)) + :backup (vui-with-async-context (zfs-ui--go 'backup (cons dataset full-name))) + :destroy (vui-with-async-context (zfs-ui--do-destroy host full-name nil)))) + zfs-ui--row-actions) + (vui-hstack + (vui-box (vui-button (concat "@" leaf) :no-decoration t :face 'shadow + :key (concat "snap:" full-name) + :on-click (lambda () nil)) + :width 38) + (vui-box (vui-text (zfs--format-bytes (zfs-cli-prop snap 'used)) :face 'shadow) :width 9) + (vui-text (zfs--format-ago (zfs-cli-prop snap 'creation)) :face 'shadow)))) + +(defun zfs-ui--page-dataset (name host datasets snaps) + (let* ((entry (assoc name datasets)) + (own-snaps (zfs--snapshots-of snaps name))) + (when entry + (push (cons 'page + (list :snapshot (vui-with-async-context (zfs-ui--do-snapshot host name)) + :backup (vui-with-async-context (zfs-ui--go 'backup name)) + :create-child (vui-with-async-context (zfs-ui--go 'create name)) + :destroy (vui-with-async-context (zfs-ui--do-destroy host name t)) + :mount (vui-with-async-context (zfs-ui--do-mount host name)))) + zfs-ui--row-actions)) + (if (null entry) + (vui-text (format "%s not found — g to refresh" name) :face 'error) + (apply + #'vui-vstack + :spacing 1 + (append + (list + (vui-hstack :spacing 2 + (vui-heading-3 name) + (vui-text (downcase (or (alist-get 'type (cdr entry)) "")) :face 'shadow)) + (vui-muted (format "Everything in this dataset and its snapshots uses %s." + (zfs--format-bytes (zfs-cli-prop entry 'used)))) + (vui-text "s snapshot · b backup · c new dataset inside · m mount · D destroy" :face 'shadow) + (apply #'vui-vstack :spacing 0 + (mapcar (lambda (property) (zfs-ui--property-row entry property)) + '("used" "referenced" "usedbysnapshots" "usedbychildren" "available" + "compressratio" "encryption" "keystatus" "mountpoint" "recordsize" + "quota" "creation" "mounted")))) + (list + (apply + #'vui-vstack + :spacing 0 + (append + (list (vui-heading-3 (format "Snapshots (%d)" (length own-snaps))) + (vui-muted "frozen moments · d what changed since · r roll back to · D delete")) + (if own-snaps + (mapcar (lambda (snap) (zfs-ui--snapshot-row snap name host)) own-snaps) + (list (vui-muted "none yet — press s to freeze this moment"))))))))))) + +(defun zfs-ui--vdev-row (vdev depth) + (vui-hstack + (vui-box (vui-text (concat (make-string (* 2 depth) ?\s) (plist-get vdev :name))) :width 40) + (vui-box (vui-text (or (plist-get vdev :state) "?") + :face (zfs--health-face (plist-get vdev :state))) + :width 9) + (vui-text (format "%s/%s/%s errors" + (or (plist-get vdev :read-errors) 0) + (or (plist-get vdev :write-errors) 0) + (or (plist-get vdev :checksum-errors) 0)) + :face 'shadow))) + +(defun zfs-ui--page-pool (name host) + (let ((status (ignore-errors (zfs-cli-pool-status host name)))) + (when status + (push (cons 'page + (list :scrub-start (vui-with-async-context (zfs-ui--do-scrub host name nil)) + :scrub-stop (vui-with-async-context (zfs-ui--do-scrub host name t)) + :export (vui-with-async-context (zfs-ui--do-export host name)))) + zfs-ui--row-actions)) + (if (null status) + (vui-text (format "Could not read status of %s" name) :face 'error) + (let ((state (alist-get 'state status)) + (error-count (alist-get 'error_count status)) + (scan (alist-get 'scan status)) + (vdevs (zfs-cli-pool-vdevs status))) + (vui-vstack + :spacing 1 + (vui-hstack :spacing 2 + (vui-heading-3 name) + (vui-text state :face (zfs--health-face state))) + (vui-muted (if (> (or error-count 0) 0) + (format "%d errors — check the devices below" error-count) + "No known data errors.")) + (vui-text (if scan + (format "Scan: %s" (or (alist-get 'state scan) "recorded")) + "Scrub: never run here — it reads everything and verifies checksums") + :face 'shadow) + (vui-text "1 scrub start · 2 scrub stop · x export (take offline)" :face 'shadow) + (vui-vstack + :spacing 0 + (vui-heading-3 "Devices") + (apply #'vui-vstack :spacing 0 + (mapcar (lambda (vdev) (zfs-ui--vdev-row vdev 0)) vdevs)))))))) + +(defun zfs-ui--form-row (label content &optional gloss) + (vui-hstack + (vui-box (vui-text label :face 'shadow) :width 14 :align :right) + content + (when gloss (vui-hstack (vui-space 2) (vui-text gloss :face 'shadow))))) + +(defun zfs-ui--page-create (parent host create-status) + (push (cons 'page (list :submit (vui-with-async-context (zfs-ui--do-create-dataset host parent)))) + zfs-ui--row-actions) + (vui-vstack + :spacing 1 + (vui-heading-3 (format "New dataset inside %s" parent)) + (vui-muted "A dataset is a drawer: its own compression, quota and snapshots.") + (zfs-ui--form-row "Name" + (vui-field :size 24 :key "create-name" :placeholder "music") + (format "→ %s/" parent)) + (zfs-ui--form-row "Mountpoint" + (vui-field :size 24 :key "create-mountpoint" + :placeholder (expand-file-name "~/music")) + "where it appears; empty = not mounted") + (zfs-ui--form-row "Compression" + (vui-field :size 24 :key "create-compression" :value "zstd" + :placeholder "zstd") + "zstd squeezes better, lz4 is faster, off disables") + (zfs-ui--form-row "Passphrase" + (vui-field :size 24 :key "create-passphrase" :secret t + :placeholder "empty = not encrypted") + "dataset-level, on top of disk LUKS") + (zfs-ui--form-row "Quota" + (vui-field :size 24 :key "create-quota" :placeholder "empty = no limit") + "e.g. 50G") + (zfs-ui--form-row "Move folder in" + (vui-field :size 24 :key "create-move" + :placeholder "empty = start empty") + "rsync copy with progress; original is kept") + (vui-hstack + (vui-box (vui-text "") :width 14) + (vui-button "Create dataset" :on-click (lambda () (zfs-ui--do-create-dataset host parent)))) + (when create-status + (vui-text (car create-status) :face (cdr create-status))))) + +(defun zfs-ui--page-backup (arg host datasets snaps targets backup-target backup-preview backup-progress backup-done) + (let* ((dataset (if (consp arg) (car arg) arg)) + (snapshot (if (consp arg) (cdr arg) + (car (zfs-ui--newest-snapshot snaps dataset)))) + (entry (assoc dataset datasets))) + (if (null snapshot) + (vui-vstack + :spacing 1 + (vui-heading-3 (format "Backup %s" dataset)) + (vui-text "No snapshots yet — a backup sends a snapshot." :face 'warning) + (vui-button "Create one now" + :on-click (lambda () (zfs-ui--do-snapshot host dataset)))) + (vui-vstack + :spacing 1 + (vui-heading-3 (format "Backup %s" dataset)) + (vui-muted "Sends a snapshot to another machine or pool. After the first full copy only the changes travel.") + (vui-hstack + (vui-box (vui-text "Snapshot" :face 'shadow) :width 14 :align :right) + (vui-text (concat "@" (zfs--snapshot-leaf snapshot))) + (vui-space 2) + (vui-text (format "(%s)" (zfs--format-ago (zfs-cli-prop (assoc snapshot snaps) 'creation))) + :face 'shadow)) + (vui-vstack + :spacing 0 + (vui-hstack (vui-box (vui-text "Target" :face 'shadow) :width 14 :align :right) + (vui-text "")) + (apply + #'vui-vstack + :spacing 0 + (mapcar (lambda (target) + (vui-hstack + (vui-box (vui-text "") :width 14) + (vui-button (format "%s — %s %s" + (plist-get target :name) + (or (plist-get target :ssh) "this machine") + (plist-get target :dataset)) + :no-decoration (not (equal target backup-target)) + :face (when (equal target backup-target) 'success) + :on-click + (lambda () + (vui-set-state :backup-target target) + (condition-case err + (vui-set-state :backup-preview + (zfs-ui--backup-preview host dataset snapshot snaps entry target)) + (error (vui-set-state :message + (cons (format "Preview failed: %s" (error-message-string err)) 'error)))))))) + targets))) + (vui-hstack + (vui-box (vui-text "One-off" :face 'shadow) :width 14 :align :right) + (vui-field :size 18 :key "oneoff-ssh" :placeholder "user@host — empty = local") + (vui-space 1) + (vui-field :size 18 :key "oneoff-prefix" :placeholder "pool/prefix") + (vui-space 1) + (vui-button "Use once" + :on-click + (lambda () + (let ((prefix (zfs-ui--field-string "oneoff-prefix"))) + (if (string-blank-p prefix) + (vui-set-state :message (cons "One-off target needs a dataset prefix" 'error)) + (let ((target (list :name "one-off" :dataset prefix)) + (ssh (zfs-ui--field-string "oneoff-ssh"))) + (unless (string-blank-p ssh) + (setq target (append target (list :ssh ssh)))) + (vui-set-state :backup-target target) + (condition-case err + (vui-set-state :backup-preview + (zfs-ui--backup-preview host dataset snapshot snaps entry target)) + (error (vui-set-state :message + (cons (format "Preview failed: %s" (error-message-string err)) 'error)))))))))) + (when backup-target + (vui-hstack + (vui-box (vui-text "Will send" :face 'shadow) :width 14 :align :right) + (if backup-preview + (vui-text (format "%s · %s%s" + (if (equal (plist-get backup-preview :kind) "incremental") + (format "only changes since @%s" (zfs--snapshot-leaf (plist-get backup-preview :base))) + "everything (first time)") + (zfs--format-bytes (plist-get backup-preview :bytes)) + (if (plist-get backup-preview :raw) " · stays encrypted" ""))) + (vui-text "…" :face 'shadow)))) + (when (and backup-target backup-preview (not backup-progress) (not backup-done)) + (vui-hstack + (vui-box (vui-text "") :width 14) + (vui-button "Start backup" + :on-click (lambda () (zfs-ui--start-backup host snapshot backup-target backup-preview))))) + (when backup-progress + (vui-hstack + (vui-box (vui-text "Sending" :face 'shadow) :width 14 :align :right) + (vui-text backup-progress :face 'shadow))) + (when backup-done + (vui-hstack + (vui-box (vui-text "") :width 14) + (if (eq backup-done 'success) + (vui-text "Backup complete." :face 'success) + (vui-text (format "Backup failed: %s" backup-done) :face 'error)))))))) + +(defun zfs-ui--page-format (format-disk format-status) + (if (null format-disk) + (let ((candidates (zfs-cli-disk-candidates))) + (vui-vstack + :spacing 1 + (vui-heading-3 "Format a disk as ZFS") + (vui-muted "Everything on the chosen disk is erased. Only unused disks are listed.") + (if candidates + (apply + #'vui-vstack + :spacing 0 + (mapcar (lambda (device) + (vui-button (format "%s — %s — %s" + (plist-get device :name) + (or (plist-get device :model) "?") + (zfs--format-bytes (plist-get device :size))) + :no-decoration t + :on-click (lambda () (vui-set-state :format-disk device)))) + candidates)) + (vui-muted "No unused disks found. Plug one in and press g.")))) + (vui-vstack + :spacing 1 + (vui-heading-3 (format "Format %s" (plist-get format-disk :name))) + (vui-text (format "%s · %s — all data on it is erased" + (or (plist-get format-disk :model) "?") + (zfs--format-bytes (plist-get format-disk :size))) + :face 'warning) + (zfs-ui--form-row "Pool name" (vui-field :size 24 :key "format-pool" :placeholder "tank")) + (zfs-ui--form-row "Passphrase" (vui-field :size 24 :key "format-pass" :secret t + :placeholder "empty = no encryption") + "LUKS passphrase; empty leaves the disk unencrypted") + (zfs-ui--form-row "Type disk name" (vui-field :size 24 :key "format-confirm" + :placeholder (plist-get format-disk :name)) + "confirms you picked the right disk") + (vui-hstack + (vui-box (vui-text "") :width 14) + (vui-button "Format" + :face 'error + :on-click + (lambda () + (let ((pool-name (zfs-ui--field-string "format-pool")) + (passphrase (zfs-ui--field-string "format-pass"))) + (cond + ((string-blank-p pool-name) + (vui-set-state :format-status (cons "Pool name is empty" 'error))) + ((not (equal (zfs-ui--field-string "format-confirm") (plist-get format-disk :name))) + (vui-set-state :format-status (cons "Type the disk name to confirm" 'error))) + (t + (zfs-ui--do-format format-disk + pool-name + (not (string-blank-p passphrase)) + passphrase))))))) + (when format-status + (vui-text (car format-status) :face (cdr format-status)))))) + +(defun zfs-ui--page-targets (targets) + (push (cons 'page + (list :add (vui-with-async-context + (let ((name (zfs-ui--field-string "target-name")) + (ssh (zfs-ui--field-string "target-ssh")) + (prefix (zfs-ui--field-string "target-prefix"))) + (if (or (string-blank-p name) (string-blank-p prefix)) + (vui-set-state :message (cons "Name and dataset prefix are required" 'error)) + (let ((new (list :name name :dataset prefix))) + (unless (string-blank-p ssh) + (setq new (append new (list :ssh ssh)))) + (let ((updated (append targets (list new)))) + (zfs-ui--targets-save updated) + (vui-set-state :targets updated) + (vui-set-state :message (cons (format "Target %s saved to %s" name zfs-targets-file) + 'success))))))))) + zfs-ui--row-actions) + (apply + #'vui-vstack + :spacing 1 + (append + (list + (vui-heading-3 "Backup targets") + (vui-muted (format "Stored as plain elisp data in %s — edit by hand or here." zfs-targets-file))) + (if targets + (list (apply + #'vui-vstack + :spacing 0 + (mapcar (lambda (target) + (vui-hstack + :spacing 2 + (vui-box (vui-text (plist-get target :name)) :width 16) + (vui-box (vui-text (or (plist-get target :ssh) "this machine") :face 'shadow) :width 24) + (vui-box (vui-text (plist-get target :dataset) :face 'shadow) :width 28) + (vui-button "Delete" :face 'error + :on-click + (lambda () + (when (yes-or-no-p (format "Delete target %s? " (plist-get target :name))) + (let ((updated (seq-remove (lambda (other) (equal other target)) targets))) + (zfs-ui--targets-save updated) + (vui-set-state :targets updated) + (vui-set-state :message (cons "Target deleted" 'success)))))))) + targets))) + (list (vui-muted "No targets yet — add one below."))) + (list + (vui-vstack + :spacing 1 + (vui-heading-3 "Add target") + (zfs-ui--form-row "Name" (vui-field :size 24 :key "target-name" :placeholder "interserver")) + (zfs-ui--form-row "SSH" (vui-field :size 24 :key "target-ssh" :placeholder "user@host — empty = this machine")) + (zfs-ui--form-row "Dataset prefix" (vui-field :size 24 :key "target-prefix" :placeholder "backuppool/mainframe") + "must exist on the target; the dataset's leaf name is appended") + (vui-hstack + (vui-box (vui-text "") :width 14) + (vui-button "Save target" + :on-click (lambda () + (when-let* ((actions (cdr (assoc 'page zfs-ui--row-actions))) + (fn (plist-get actions :add))) + (funcall fn)))))))))) + +(vui-defcomponent zfs-app () + :state ((page 'overview) + (page-arg nil) + (host nil) + (pools nil) + (datasets nil) + (snaps nil) + (locked nil) + (targets (zfs-ui--targets-load)) + (loading t) + (message nil) + (refreshed nil) + (backup-target nil) + (backup-preview nil) + (backup-progress nil) + (backup-done nil) + (create-status nil) + (format-disk nil) + (format-status nil)) + :render + (progn + (vui-use-effect () + (zfs-ui--refresh host) + nil) + (setq zfs-ui--row-actions nil) + (setq zfs-ui--refresh-fn (vui-with-async-context (zfs-ui--refresh host))) + (push (cons 'nav + (list :back (vui-with-async-context + (if (eq page 'overview) + (bury-buffer) + (zfs-ui--go 'overview))))) + zfs-ui--row-actions) + (let ((content + (cond + (loading (vui-text "Loading…" :face 'shadow)) + ((eq page 'overview) + (if pools + (zfs-ui--page-overview pools datasets snaps locked) + (vui-vstack :spacing 1 + (vui-heading-3 "No pools found") + (vui-muted "ZFS returned no pools. Kernel module loaded, pools imported?")))) + ((eq page 'dataset) (zfs-ui--page-dataset page-arg host datasets snaps)) + ((eq page 'pool) (zfs-ui--page-pool page-arg host)) + ((eq page 'create) (zfs-ui--page-create page-arg host create-status)) + ((eq page 'backup) (zfs-ui--page-backup page-arg host datasets snaps targets + backup-target backup-preview + backup-progress backup-done)) + ((eq page 'new-pool) (zfs-ui--page-format format-disk format-status)) + ((eq page 'targets) (zfs-ui--page-targets targets)) + (t (vui-text "unknown page" :face 'error))))) + (vui-vstack + :spacing 1 + (vui-flex :width 'window :justify :space-between + (vui-hstack :spacing 2 + (vui-heading-2 "ZFS") + (vui-text (cond + ((eq page 'overview) (if host (format "on %s" (plist-get host :name)) "on this machine")) + (t (format "› %s" (if (symbolp page) (symbol-name page) page)))) + :face 'shadow)) + (vui-text (format "%s pools · refreshed %s" (length pools) (or refreshed "—")) :face 'shadow)) + (if message + (vui-text (car message) :face (cdr message)) + (vui-text " ")) + content + (vui-text (pcase page + ('overview "RET open · u unlock · F format disk · T targets · g refresh · q quit") + ('dataset "q back · s snapshot · b backup · c new dataset · d diff · r rollback · D destroy · g refresh") + ('pool "q back · 1 scrub start · 2 scrub stop · x export · g refresh") + ('backup "q back · click a target · g refresh") + (_ "q back · g refresh")) + :face 'shadow))))) + +(defun zfs-ui--key-on-line () + (save-excursion + (beginning-of-line) + (let ((end (line-end-position)) + (found nil)) + (while (and (<= (point) end) (not found)) + (setq found (vui-key-at)) + (forward-char 1)) + found))) + +(defun zfs-ui--invoke (action) + (let* ((key (zfs-ui--key-on-line)) + (row (and key (cdr (assoc key zfs-ui--row-actions)))) + (page (cdr (assoc 'page zfs-ui--row-actions)))) + (cond + ((plist-get row action) (funcall (plist-get row action))) + ((and (eq action :open) (plist-get row :open)) (funcall (plist-get row :open))) + ((plist-get page action) (funcall (plist-get page action))) + (t (message "Nothing here for that key"))))) + +(define-derived-mode zfs-mode vui-mode "ZFS" + (hl-line-mode 1)) + +(define-key zfs-mode-map (kbd "q") (lambda () (interactive) (zfs-ui--invoke :back))) +(define-key zfs-mode-map (kbd "g") (lambda () (interactive) (when zfs-ui--refresh-fn (funcall zfs-ui--refresh-fn)))) +(define-key zfs-mode-map (kbd "s") (lambda () (interactive) (zfs-ui--invoke :snapshot))) +(define-key zfs-mode-map (kbd "b") (lambda () (interactive) (zfs-ui--invoke :backup))) +(define-key zfs-mode-map (kbd "c") (lambda () (interactive) (zfs-ui--invoke :create-child))) +(define-key zfs-mode-map (kbd "d") (lambda () (interactive) (zfs-ui--invoke :diff))) +(define-key zfs-mode-map (kbd "r") (lambda () (interactive) (zfs-ui--invoke :rollback))) +(define-key zfs-mode-map (kbd "D") (lambda () (interactive) (zfs-ui--invoke :destroy))) +(define-key zfs-mode-map (kbd "m") (lambda () (interactive) (zfs-ui--invoke :mount))) +(define-key zfs-mode-map (kbd "u") (lambda () (interactive) (zfs-ui--invoke :unlock))) +(define-key zfs-mode-map (kbd "i") (lambda () (interactive) (zfs-ui--invoke :import))) +(define-key zfs-mode-map (kbd "L") (lambda () (interactive) (zfs-ui--invoke :lock))) +(define-key zfs-mode-map (kbd "F") (lambda () (interactive) (zfs-ui--invoke :format))) +(define-key zfs-mode-map (kbd "T") (lambda () (interactive) (zfs-ui--invoke :targets))) +(define-key zfs-mode-map (kbd "1") (lambda () (interactive) (zfs-ui--invoke :scrub-start))) +(define-key zfs-mode-map (kbd "2") (lambda () (interactive) (zfs-ui--invoke :scrub-stop))) +(define-key zfs-mode-map (kbd "x") (lambda () (interactive) (zfs-ui--invoke :export))) + +;;;###autoload +(defun zfs () + (interactive) + (let ((buffer (get-buffer-create zfs-buffer-name))) + (with-current-buffer buffer + (unless (eq major-mode 'zfs-mode) + (zfs-mode) + (vui-mount (vui-component 'zfs-app) buffer) + (vui-rerender-on-resize))) + (pop-to-buffer buffer))) + +(provide 'zfs) +;;; zfs.el ends here -- cgit v1.3.1