mirror of https://codeberg.org/cage/tinmop/
- [GUI] added menu command to shows certificates.
This commit is contained in:
parent
910da66e4f
commit
5282e2cf86
|
@ -0,0 +1,39 @@
|
|||
(in-package :client-certificates-window)
|
||||
|
||||
(named-readtables:in-readtable nodgui.syntax:nodgui-syntax)
|
||||
|
||||
(defclass certificate-frame (gui:frame)
|
||||
((tree
|
||||
:accessor tree
|
||||
:initform nil
|
||||
:initarg :tree)
|
||||
(rows
|
||||
:accessor rows
|
||||
:initform '()
|
||||
:initarg :rows)))
|
||||
|
||||
(defmethod initialize-instance :after ((object certificate-frame) &key)
|
||||
(with-accessors ((tree tree)
|
||||
(rows rows)) object
|
||||
(let ((treeview (make-instance 'gui:scrolled-treeview
|
||||
:master object
|
||||
:pack '(:side :top :expand t :fill :both)
|
||||
:columns (list (_ "File")
|
||||
(_ "Fingerprint")))))
|
||||
(gui:treeview-heading treeview gui:+treeview-first-column-id+
|
||||
:text (_ "Address"))
|
||||
(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))
|
||||
:index gui:+treeview-last-index+)))
|
||||
(gui:treeview-insert-item treeview :item tree-row)))
|
||||
(setf tree treeview)
|
||||
object)))
|
||||
|
||||
(defun init-window (master rows)
|
||||
(gui:with-modal-toplevel (toplevel :master master :title (_ "Certificates"))
|
||||
(gui:transient toplevel master)
|
||||
(gui:grid (make-instance 'certificate-frame :master toplevel :rows rows) 0 0)))
|
|
@ -195,7 +195,9 @@
|
|||
(with-accessors ((main-window main-window)) parent
|
||||
(let* ((bar (gui:make-menubar parent))
|
||||
(file (gui:make-menu bar (_ "File") :underline 0))
|
||||
(tools (gui:make-menu bar (_ "Tools") :underline 0))
|
||||
(help (gui:make-menu bar (_ "Help") :underline 0)))
|
||||
(gui:make-menubutton tools (_ "Certificates") #'menu:show-certificates :underline 0)
|
||||
(gui:make-menubutton file (_ "Quit") #'menu:quit :underline 0)
|
||||
(gui:make-menubutton help (_ "About") #'menu:help-about :underline 0))))
|
||||
|
||||
|
|
|
@ -16,3 +16,10 @@
|
|||
(gui:break-mainloop)
|
||||
(client-events:stop-events-loop)
|
||||
(comm:close-server))
|
||||
|
||||
(defun show-certificates ()
|
||||
(let ((master gui-goodies:*toplevel*)
|
||||
(rows (cev:enqueue-request-and-wait-results :gemini-certificates
|
||||
1
|
||||
ev:+maximum-event-priority+)))
|
||||
(client-certificates-window:init-window master rows)))
|
||||
|
|
|
@ -29,7 +29,18 @@
|
|||
(yason:encode-array-element certificate))))))
|
||||
|
||||
(defun gemini-certificates ()
|
||||
(make-instance 'gemini-certificates :contents (db:find-tls-certificates-rows)))
|
||||
(let* ((certificates-rows (sort (db:find-tls-certificates-rows)
|
||||
(lambda (a b)
|
||||
(string< (db:row-cache-key a)
|
||||
(db:row-cache-key b)))))
|
||||
(certificates-with-hash (loop for certificate-row in certificates-rows
|
||||
collect
|
||||
(let* ((cache-key (db:row-cache-key certificate-row))
|
||||
(pem-file (gemini-client::tls-cert-find cache-key))
|
||||
(hash (x509:certificate-fingerprint pem-file)))
|
||||
(append (list :hash hash :file pem-file)
|
||||
certificate-row)))))
|
||||
(make-instance 'gemini-certificates :contents certificates-with-hash)))
|
||||
|
||||
(defun invalidate-cached-value (cache-key)
|
||||
(db:cache-invalidate cache-key)
|
||||
|
|
|
@ -3377,6 +3377,7 @@
|
|||
:misc-utils)
|
||||
(:local-nicknames (:comm :json-rpc-communication)
|
||||
(:ev :program-events)
|
||||
(:cev :client-events)
|
||||
(:re :cl-ppcre)
|
||||
(:a :alexandria)
|
||||
(:gui :nodgui)
|
||||
|
@ -3384,7 +3385,27 @@
|
|||
(:gui-shapes :nodgui.shapes))
|
||||
(:export
|
||||
:help-about
|
||||
:quit))
|
||||
:quit
|
||||
:show-certificates))
|
||||
|
||||
(defpackage :client-certificates-window
|
||||
(:use
|
||||
:cl
|
||||
:config
|
||||
:constants
|
||||
:text-utils
|
||||
:misc-utils)
|
||||
(:local-nicknames (:comm :json-rpc-communication)
|
||||
(:re :cl-ppcre)
|
||||
(:a :alexandria)
|
||||
(:ev :program-events)
|
||||
(:cev :client-events)
|
||||
(:gui :nodgui)
|
||||
(:gui-mw :nodgui.mw)
|
||||
(:gui-shapes :nodgui.shapes)
|
||||
(:menu :client-menu-command))
|
||||
(:export
|
||||
:init-window))
|
||||
|
||||
(defpackage :client-main-window
|
||||
(:use
|
||||
|
|
|
@ -165,6 +165,7 @@
|
|||
(:file "json-rpc-communication")
|
||||
(:file "validation")
|
||||
(:file "icons")
|
||||
(:file "certificates-window")
|
||||
(:file "menu-command")
|
||||
(:file "main-window")))
|
||||
(:file "main")
|
||||
|
|
Loading…
Reference in New Issue