;;; 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) (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 '(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-argv (argv &optional input) (let ((stderr-file (make-temp-file "zfs-cli-")) (input-file (and input (make-temp-file "zfs-cli-in-")))) (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--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)) (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 &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,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" "part" "loop")) (equal (plist-get device :fstype) "crypto_LUKS"))) (zfs-cli--flatten-device-tree (zfs-cli-block-devices)))) (defun zfs-cli-disk-unlocked-p (device) (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) (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) (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 (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))) (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) (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))))) (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-source (source mode) (let ((path (expand-file-name source))) (cond ((and (eq mode 'contents) (file-directory-p path)) (file-name-as-directory path)) ((file-directory-p path) (directory-file-name path)) (t path)))) (defun zfs-cli-rsync-async (source target mode dry-run callback) (let* ((source-arg (zfs-cli--rsync-source source mode)) (target-arg (file-name-as-directory (expand-file-name target))) (args (append '("rsync" "-rlt" "--info=progress2") (and dry-run '("--dry-run" "--itemize-changes")) (and (eq mode 'move) '("--remove-source-files")) (list source-arg target-arg)))) (zfs-cli--pipe-async (mapconcat #'shell-quote-argument args " ") 'stdout (lambda (chunk) (funcall callback (list :progress chunk))) (lambda (status err out) (funcall callback (list :done status err out)))))) (provide 'zfs-cli) ;;; zfs-cli.el ends here