;;; discomfort.el --- Block device handling UI       -*- lexical-binding: t; -*-

;; Copyright (C) 2021, 2022  Ian Eure

;; Author: Ian Eure <ian@retrospec.tv>
;; 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 <https://www.gnu.org/licenses/>.

;;; 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
