pax_global_header00006660000000000000000000000064143301146320014507gustar00rootroot0000000000000052 comment=5258564d07fc066847d9d2873e132d082460fb54 discomfort/000077500000000000000000000000001433011463200132245ustar00rootroot00000000000000discomfort/discomfort.el000066400000000000000000000275051433011463200157300ustar00rootroot00000000000000;;; discomfort.el --- Block device handling UI -*- lexical-binding: t; -*- ;; Copyright (C) 2021, 2022 Ian Eure ;; Author: Ian Eure ;; Keywords: hardware, unix ;; Package-Requires: ((debase "0.8")) ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. If not, see . ;;; Commentary: ;; ;;; Code: (require 'eieio-base) (require 'debase) (require 'debase-objectmanager) (defgroup discomfort nil "Major mode for interacting with UDisks2." :prefix "discomfort-" :group 'tools) (defface discomfort-device-face '((t :inherit dired-mark)) "Face for the block device path." :group 'discomfort) (defface discomfort-device-mounted-face '((t :weight bold :inherit discomfort-device-face)) "Face for the block device path of a mounted device." :group 'discomfort) (defface discomfort-mountpoint-face '((t :inherit dired-directory)) "Face for the mount directory." :group 'discomfort) (defconst discomfort-service "org.freedesktop.UDisks2") (defconst discomfort-path "/org/freedesktop/UDisks2/Manager") (defconst discomfort-interface (concat discomfort-service ".Manager")) (defconst discomfort-drive (concat discomfort-service ".Drive")) (defconst discomfort-drive-ata (concat discomfort-service ".Drive.Ata")) (defconst discomfort-block (concat discomfort-service ".Block")) (defconst discomfort-partition-table (concat discomfort-service ".PartitionTable")) (defconst discomfort-partition (concat discomfort-service ".Partition")) (defconst discomfort-encrypted (concat discomfort-service ".Encrypted")) (defconst discomfort-swapspace (concat discomfort-service ".Swapspace")) (defconst discomfort-filesystem (concat discomfort-service ".Filesystem")) (defconst discomfort-loop (concat discomfort-service ".Loop")) (defvar discomfort--global nil "The global instance of Discomfort.") (defclass discomfort--om (debase-objectmanager eieio-singleton) nil :documentation "DISCOMFORT--OM is the class for the UDisks2 ObjectManager.") (defun discomfort--objectmanager* () "Construct the Discomfort ObjectManager." (let ((om (discomfort--om :bus :system :service discomfort-service :path "/org/freedesktop/UDisks2" :interface dbus-interface-objectmanager))) (debase-objectmanager-onchange om #'discomfort--refresh) (debase-objectmanager-start om) om)) (defun discomfort--objectmanager () "Return the default instance of the UDisks2 ObjectManager." (or discomfort--global (setf discomfort--global (discomfort--objectmanager*)))) (defun discomfort--refresh () "Refresh all Discomfort buffers." (mapc (lambda (b) (with-current-buffer b (when (derived-mode-p 'discomfort-mode) (revert-buffer)))) (buffer-list))) (defun discomfort--destroy () "Tear down a Discomfort ObjectManger." (interactive) (ignore-errors (debase-objectmanager-stop discomfort--global)) (setf discomfort--global nil)) (defconst discomfort-mode-map (let ((km (make-sparse-keymap))) (define-key km "d" 'discomfort-dired) (define-key km "o" 'discomfort-dired-other-window) (define-key km "m" 'discomfort-mount) (define-key km "u" 'discomfort-unmount) (define-key km (kbd "RET") 'discomfort-dwim) km)) (define-derived-mode discomfort-mode tabulated-list-mode "Discomfort" "Major mode for interacting with UDisks2." (setf discomfort-local (discomfort--objectmanager) tabulated-list-format [("Device" 20 t nil) ("Type" 15 t nil) ("Mountpoint" 20 t nil)] ;; tabulated-list-revert-hook (lambda () (debase-objectmanager--refresh discomfort-local)) tabulated-list-entries #'discomfort--filesystems show-trailing-whitespace nil) (tabulated-list-init-header) (tabulated-list-print) (hl-line-mode 1)) (defun discomfort--interfaces (obj) (mapcar #'car (cadr obj))) (defun discomfort--drive? (obj) (cadr (assoc discomfort-drive (cadr obj)))) (defun discomfort--drive-ata? (obj) (cadr (assoc discomfort-drive-ata (cadr obj)))) (defun discomfort--block? (obj) (cadr (assoc discomfort-block (cadr obj)))) (defun discomfort--partition-table? (obj) (cadr (assoc discomfort-partition-table (cadr obj)))) (defun discomfort--partition? (obj) (cadr (assoc discomfort-partition (cadr obj)))) (defun discomfort--encrypted? (obj) (cadr (assoc discomfort-encrypted (cadr obj)))) (defun discomfort--unlocked? (obj) (let ((uld (caadr (assoc "CleartextDevice" (discomfort--encrypted? obj))))) (unless (string= "/" uld) uld))) (defun discomfort--filesystem? (obj) (assoc discomfort-filesystem (cadr obj))) (defun discomfort--mounted? (obj) (discomfort--object->mount-point obj)) (defun discomfort--swapspace? (obj) (cadr (assoc discomfort-swapspace (cadr obj)))) (defun discomfort--loop? (obj) (member discomfort-loop (discomfort--interfaces obj))) (defun discomfort--obj-type (obj) (cond ((discomfort--filesystem? obj) (caadr (assoc "IdType" (discomfort--block? obj)))) ((discomfort--swapspace? obj) "swap") ((discomfort--encrypted? obj) (format "%s encrypted" (if (discomfort--unlocked? obj) "🔓" "🔒"))) ((discomfort--partition-table? obj) "label") ((discomfort--partition? obj) "partition") ((discomfort--loop? obj) "loop") ((discomfort--block? obj) "block") ((discomfort--drive-ata? obj) "ata") ((discomfort--drive? obj) "drive"))) (defun discomfort--filesystems () (with-slots (managed-objects) discomfort--global (cl-loop for obj in managed-objects when (discomfort--encrypted? obj) collect (discomfort--enc->row managed-objects obj) when (discomfort--filesystem? obj) unless (discomfort--loop? obj) collect (discomfort--object->row obj)))) (defun discomfort--enc->row (managed-objects obj) (list (car obj) (vector (discomfort--object->preferred-device obj) (discomfort--obj-type obj) (or (when-let ((ul (discomfort--unlocked? obj))) (discomfort--object->preferred-device (assoc ul managed-objects))) "")))) (defun discomfort--drives () (with-slots (managed-objects) discomfort--global (cl-loop for obj in managed-objects when (member discomfort-drive (mapcar #'car (cadr obj))) collect obj))) (defun discomfort--drive->filesystems (drive) (with-slots (managed-objects) discomfort--global (cl-loop for obj in managed-objects when (member discomfort-filesystem (mapcar #'car (cadr obj))) when (member discomfort-block (mapcar #'car (cadr obj))) when (string= drive ) collect obj))) (defun discomfort--object->preferred-device (obj) (thread-first (thread-last (cadr obj) (assoc discomfort-block) cadr (assoc "PreferredDevice") caadr (apply #'string)) (substring 0 -1))) (defun discomfort--object->mount-point (obj) (let ((mpoint (thread-last (cadr obj) (assoc discomfort-filesystem) cadr (assoc "MountPoints") caaadr (apply #'string)))) (when (> (length mpoint) 0) (substring mpoint 0 -1)))) ;; (defun discomfort--drive->row (drive) ;; (when-let ((di (discomfort--drive? drive))) ;; (list (car drive) ;; (vector ;; (mapconcat #'identity ;; (cl-remove-if #'null ;; (list (caadr (assoc "Vendor" di)) ;; (caadr (assoc "Model" di)))) ;; " ") ;; "(none)")))) (defun discomfort--object->row (obj) "Return the tabulated-list row for OBJ." (let ((mp (discomfort--object->mount-point obj))) (list (car obj) (vector (propertize (discomfort--object->preferred-device obj) 'face (if mp 'discomfort-device-mounted-face 'discomfort-device-face)) (discomfort--obj-type obj) (propertize (or mp "") 'face 'discomfort-mountpoint-face))))) (defun discomfort () "Open or switch to Discomfort buffer." (interactive) (with-current-buffer (pop-to-buffer "*discomfort*") (if (eq major-mode 'discomfort-mode) (revert-buffer) (erase-buffer) (discomfort-mode)))) (defun discomfort--id-at-point () "Return the ID of the device at point. The ID is the D-Bus path to the object." (tabulated-list-get-id)) (defun discomfort--obj-at-point () (when-let ((id (discomfort--id-at-point))) (with-slots (managed-objects) discomfort--global (assoc id managed-objects)))) (defun discomfort--mountpoint-at-point () (let ((mp (elt (get-text-property (point) 'tabulated-list-entry) 2))) (if (string= "" mp) nil mp))) (defun discomfort-dwim (&optional arg) "Perform the next logical operation for the currently selected item. If unmounted, mount and open Dired. With prefix, open in anotherwindow. If mounted, unmount." (interactive "P") (with-slots (managed-objects) discomfort--global (let ((obj (assoc (tabulated-list-get-id) managed-objects))) (cond ((and (discomfort--encrypted? obj) (not (discomfort--unlocked? obj))) (let ((mp (discomfort-unlock))) (if arg (dired-other-window mp) (dired mp)))) ((and (discomfort--encrypted? obj) (discomfort--unlocked? obj)) (discomfort-lock)) ((null (discomfort--mountpoint-at-point)) (progn (discomfort-mount) (if arg (discomfort-dired-other-window) (discomfort-dired)))) ((discomfort--mountpoint-at-point) (discomfort-unmount)))))) (defun discomfort--mount (id) "Mount the device at point." (debase-bind* (:system discomfort-service id discomfort-filesystem) (dbus-call-method "Mount" '(:array :signature "{sv}")))) (defun discomfort-mount () "Mount the device at point." (interactive) (discomfort--mount (discomfort--id-at-point)) (revert-buffer)) (defun discomfort-lock () (debase-bind* (:system discomfort-service (discomfort--id-at-point) discomfort-encrypted) ;; FIXME -- this doesn't work for some reason. (dbus-call-method "Lock" '(:array :signature "{sv}"))) (revert-buffer)) (defun discomfort-unlock () (prog1 (debase-bind* (:system discomfort-service (discomfort--id-at-point) discomfort-encrypted) (discomfort--mount (dbus-call-method "Unlock" (read-passwd "Password: ") '(:array :signature "{sv}")))) (revert-buffer))) (defun discomfort--object () "Return a DEBASE-OBJECT for the device at point." (debase-object :bus :system :service discomfort-service :path (discomfort--id-at-point))) (defun discomfort-unmount () "Unmount the device at point." (interactive) (debase-bind* (:system discomfort-service (discomfort--id-at-point) discomfort-filesystem) (dbus-call-method "Unmount" '(:array :signature "{sv}")) (revert-buffer))) (defun discomfort-dired () "Open dired for the mountpoint of the device at point." (interactive) (dired (discomfort--mountpoint-at-point))) (defun discomfort-dired-other-window () "Open dired in another window for the mountpoint of the device at point." (interactive) (dired-other-window (discomfort--mountpoint-at-point))) (provide 'discomfort) ;;; discomfort.el ends here