mirror of https://codeberg.org/cage/tinmop/
282 lines
14 KiB
Common Lisp
282 lines
14 KiB
Common Lisp
(in-package :client-certificates-window)
|
|
|
|
(named-readtables:in-readtable nodgui.syntax:nodgui-syntax)
|
|
|
|
(defclass certificate-frame (gui-goodies:table-frame) ())
|
|
|
|
(defun resync-rows (certificate-frame new-rows)
|
|
(with-accessors ((tree gui-goodies:tree)
|
|
(rows gui-goodies:rows)) certificate-frame
|
|
(gui:treeview-delete-all tree)
|
|
(setf rows new-rows)
|
|
(loop for row in rows do
|
|
(let ((tree-row (make-instance 'gui:tree-item
|
|
:id (db:row-cache-key row)
|
|
:text (db:row-cache-key row)
|
|
:column-values (list (getf row :file)
|
|
(getf row :hash)
|
|
(getf row :key-file))
|
|
:index gui:+treeview-last-index+)))
|
|
(gui:treeview-insert-item tree :item tree-row)))
|
|
(gui:treeview-refit-columns-width (gui-goodies:tree certificate-frame))
|
|
certificate-frame))
|
|
|
|
(defun all-rows ()
|
|
(cev:enqueue-request-and-wait-results :gemini-certificates
|
|
1
|
|
ev:+standard-event-priority+))
|
|
|
|
(defmethod initialize-instance :after ((object certificate-frame) &key &allow-other-keys)
|
|
(with-accessors ((tree gui-goodies:tree)
|
|
(rows gui-goodies:rows)) object
|
|
(let ((new-rows (all-rows))
|
|
(treeview (make-instance 'gui:scrolled-treeview
|
|
:master object
|
|
:pack '(:side :top :expand t :fill :both)
|
|
:columns (list (_ "Certificate file")
|
|
(_ "Fingerprint")
|
|
(_ "Key file")))))
|
|
(setf tree treeview)
|
|
(gui:treeview-heading tree gui:+treeview-first-column-id+
|
|
:text (_ "Address"))
|
|
(resync-rows object new-rows)
|
|
object)))
|
|
|
|
(defun delete-certificates-clsr (certificate-frame)
|
|
(lambda ()
|
|
(a:when-let* ((selections (gui:treeview-get-selection (gui-goodies:tree certificate-frame))))
|
|
(when (gui-goodies:confirm-deletion certificate-frame (length selections))
|
|
(loop for selection in selections do
|
|
(let ((url (gui:id selection)))
|
|
(ev:with-enqueued-process-and-unblock ()
|
|
(comm:make-request :gemini-delete-client-certificate
|
|
1
|
|
url))
|
|
(let ((new-rows (all-rows)))
|
|
(resync-rows certificate-frame new-rows))))))))
|
|
|
|
(defun contextual-menu-clrs (treeview-widget)
|
|
(labels ((row-values ()
|
|
(a:when-let* ((item (first (gui:treeview-get-selection treeview-widget))))
|
|
(gui:column-values item)))
|
|
(key-path ()
|
|
(a:when-let* ((row-values (row-values)))
|
|
(third row-values)))
|
|
(cert-path ()
|
|
(a:when-let* ((row-values (row-values)))
|
|
(first row-values)))
|
|
(hash-value ()
|
|
(a:when-let* ((row-values (row-values)))
|
|
(second row-values)))
|
|
(change-passphrase ()
|
|
(a:when-let ((file-path (key-path)))
|
|
(client-main-window::change-client-certificate-key-passphrase treeview-widget file-path)))
|
|
(copy-key-path ()
|
|
(a:when-let ((file-path (key-path)))
|
|
(os-utils:copy-to-clipboard file-path)
|
|
(client-main-window:print-info-message (format nil
|
|
(_ "path ~s copied to clipboard")
|
|
file-path))))
|
|
(copy-cert-path ()
|
|
(a:when-let ((file-path (cert-path)))
|
|
(os-utils:copy-to-clipboard file-path)
|
|
(client-main-window:print-info-message (format nil
|
|
(_ "path ~s copied to clipboard")
|
|
file-path))))
|
|
(copy-hash ()
|
|
(a:when-let ((hash-value (hash-value)))
|
|
(os-utils:copy-to-clipboard hash-value)
|
|
(client-main-window:print-info-message (format nil
|
|
(_ "hash ~s copied to clipboard")
|
|
hash-value)))))
|
|
(lambda (z)
|
|
(declare (ignore z))
|
|
(let* ((popup-menu (gui:make-menu nil (_"certificate menu")))
|
|
(x (gui:screen-mouse-x))
|
|
(y (gui:screen-mouse-y)))
|
|
(gui:make-menubutton popup-menu
|
|
(_ "Change passphrase")
|
|
#'change-passphrase)
|
|
(gui:make-menubutton popup-menu
|
|
(_ "Copy key path to clipboard")
|
|
#'copy-key-path)
|
|
(gui:make-menubutton popup-menu
|
|
(_ "Copy certificate path to clipboard")
|
|
#'copy-cert-path)
|
|
(gui:make-menubutton popup-menu
|
|
(_ "Copy certificate's fingerprint to clipboard")
|
|
#'copy-hash)
|
|
(gui:popup popup-menu x y)))))
|
|
|
|
(defclass import-window (gui:frame)
|
|
((url-entry
|
|
:initform nil
|
|
:initarg :url-entry
|
|
:accessor url-entry)
|
|
(certificate-entry
|
|
:initform nil
|
|
:initarg :certificate-entry
|
|
:accessor certificate-entry)
|
|
(certificate-choose-button
|
|
:initform nil
|
|
:initarg :certificate-choose-button
|
|
:accessor certificate-choose-button)
|
|
(key-entry
|
|
:initform nil
|
|
:initarg :key-entry
|
|
:accessor key-entry)
|
|
(key-choose-button
|
|
:initform nil
|
|
:initarg :key-choose-button
|
|
:accessor key-choose-button)
|
|
(ok-button
|
|
:initform nil
|
|
:initarg :ok-button
|
|
:accessor ok-button)
|
|
(cancel-button
|
|
:initform nil
|
|
:initarg :cancel-button
|
|
:accessor cancel-button)))
|
|
|
|
(defun autocomplete-file-cb ()
|
|
(lambda (hint)
|
|
(let ((match-results (complete:directory-complete hint)))
|
|
(values match-results nil))))
|
|
|
|
(defun on-file-choosen-clsr (entry parent &optional (initial-dir nil))
|
|
(lambda ()
|
|
(when (string-not-empty-p (gui:text (certificate-entry parent)))
|
|
(setf initial-dir (fs:parent-dir-path (gui:text (certificate-entry parent)))))
|
|
(let ((file-path (gui:get-open-file :initial-dir initial-dir
|
|
:parent parent
|
|
:multiple nil
|
|
:title (_ "Choose the file"))))
|
|
(setf (gui:text entry) file-path))))
|
|
|
|
(defun import-certificate-clsr (import-window certificate-frame)
|
|
(lambda ()
|
|
(with-accessors ((url-entry url-entry)
|
|
(certificate-entry certificate-entry)
|
|
(key-entry key-entry)) import-window
|
|
(a:when-let* ((uri (gui:text url-entry))
|
|
(cert-file (gui:text certificate-entry))
|
|
(key-file (gui:text key-entry)))
|
|
(handler-case
|
|
(progn
|
|
(cev:enqueue-request-and-wait-results :gemini-import-certificate
|
|
1
|
|
ev:+standard-event-priority+
|
|
uri
|
|
cert-file
|
|
key-file)
|
|
(resync-rows certificate-frame (all-rows))
|
|
(gui:exit-from-toplevel (gui:master import-window)))
|
|
(error (e)
|
|
(gui-goodies:notify-request-error e)))))))
|
|
|
|
(defmethod initialize-instance :after ((object import-window) &key (certificate-frame nil)
|
|
&allow-other-keys)
|
|
(with-accessors ((url-entry url-entry)
|
|
(certificate-entry certificate-entry)
|
|
(key-entry key-entry)
|
|
(certificate-choose-button certificate-choose-button)
|
|
(key-choose-button key-choose-button)
|
|
(ok-button ok-button)
|
|
(cancel-button cancel-button)) object
|
|
(setf url-entry (make-instance 'gui:entry
|
|
:master object
|
|
:text (strcat gemini-constants:+gemini-scheme+ "://")))
|
|
(let* ((screen-width-in-pixel (/ (gui:screen-width) 2))
|
|
(font (gui:cget url-entry :font))
|
|
(zero-char-width (gui:font-measure font "0"))
|
|
(entries-width (truncate (/ screen-width-in-pixel zero-char-width))))
|
|
(setf certificate-entry
|
|
(make-instance 'gui-mw:autocomplete-entry
|
|
:master object
|
|
:autocomplete-function (autocomplete-file-cb)))
|
|
(setf key-entry
|
|
(make-instance 'gui-mw:autocomplete-entry
|
|
:master object
|
|
:autocomplete-function (autocomplete-file-cb)))
|
|
(gui:configure url-entry :width entries-width)
|
|
(gui:configure certificate-entry :width entries-width)
|
|
(gui:configure key-entry :width entries-width)
|
|
(let ((inner-entry-certificate (gui-mw:autocomplete-entry-widget certificate-entry))
|
|
(inner-entry-key (gui-mw:autocomplete-entry-widget key-entry))
|
|
(url-label (make-instance 'gui:label
|
|
:master object
|
|
:text (_ "Gemini address")))
|
|
(cert-label (make-instance 'gui:label
|
|
:master object
|
|
:text (_ "Certificate file")))
|
|
(key-label (make-instance 'gui:label
|
|
:master object
|
|
:text (_ "Key file")))
|
|
(buttons-frame (make-instance 'gui:frame
|
|
:master object)))
|
|
(setf certificate-choose-button
|
|
(make-instance 'gui:button
|
|
:image icons:*folder*
|
|
:master object
|
|
:command
|
|
(on-file-choosen-clsr inner-entry-certificate object ".")))
|
|
(setf key-choose-button
|
|
(make-instance 'gui:button
|
|
:image icons:*folder*
|
|
:master object
|
|
:command (on-file-choosen-clsr inner-entry-key object)))
|
|
(setf ok-button (make-instance 'gui:button
|
|
:text (_ "OK")
|
|
:master buttons-frame
|
|
:command
|
|
(import-certificate-clsr object certificate-frame)))
|
|
(setf cancel-button (make-instance 'gui:button
|
|
:text (_ "Cancel")
|
|
:master buttons-frame
|
|
:command
|
|
(lambda () (gui:exit-from-toplevel (gui:master object)))))
|
|
(gui:grid url-label 0 0)
|
|
(gui:grid url-entry 1 0)
|
|
(gui:grid cert-label 3 0)
|
|
(gui:grid certificate-entry 4 0)
|
|
(gui:grid certificate-choose-button 4 1)
|
|
(gui:grid key-label 5 0)
|
|
(gui:grid key-entry 6 0)
|
|
(gui:grid key-choose-button 6 1)
|
|
(gui:grid buttons-frame 7 0)
|
|
(gui:grid ok-button 0 0)
|
|
(gui:grid cancel-button 0 1)))))
|
|
|
|
(defun make-import-certificates-win-clsr (certificate-frame master)
|
|
(lambda ()
|
|
(gui:with-toplevel (toplevel :master master :title (_ "Import certificates"))
|
|
(gui:transient toplevel master)
|
|
(let ((frame (make-instance 'import-window
|
|
:certificate-frame certificate-frame
|
|
:master toplevel)))
|
|
(gui:grid frame 0 0 :sticky :news)))))
|
|
|
|
(defun init-window (master)
|
|
(gui:with-toplevel (toplevel :master master :title (_ "Certificates"))
|
|
(gui:transient toplevel master)
|
|
(let* ((table (make-instance 'certificate-frame :master toplevel))
|
|
(buttons-frame (make-instance 'gui:frame :master toplevel))
|
|
(delete-button (make-instance 'gui:button
|
|
:master buttons-frame
|
|
:image icons:*document-delete*
|
|
:command (delete-certificates-clsr table)))
|
|
(import-button (make-instance 'gui:button
|
|
:master buttons-frame
|
|
:image icons:*document-add*
|
|
:command
|
|
(make-import-certificates-win-clsr table toplevel))))
|
|
(gui-goodies:attach-tooltips (delete-button (_ "delete selected certificates"))
|
|
(import-button (_ "import certificate from disk")))
|
|
(gui:grid table 0 0 :sticky :nwe)
|
|
(gui:grid buttons-frame 1 0 :sticky :s)
|
|
(gui:grid delete-button 0 0 :sticky :s)
|
|
(gui:grid import-button 0 1 :sticky :s)
|
|
(gui:bind (gui:treeview (gui-goodies:tree table))
|
|
#$<3>$
|
|
(contextual-menu-clrs (gui:treeview (gui-goodies:tree table)))))))
|