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)))
|
|
@ -194,10 +194,12 @@
|
||||||
(defun initialize-menu (parent)
|
(defun initialize-menu (parent)
|
||||||
(with-accessors ((main-window main-window)) parent
|
(with-accessors ((main-window main-window)) parent
|
||||||
(let* ((bar (gui:make-menubar parent))
|
(let* ((bar (gui:make-menubar parent))
|
||||||
(file (gui:make-menu bar (_ "File") :underline 0))
|
(file (gui:make-menu bar (_ "File") :underline 0))
|
||||||
(help (gui:make-menu bar (_ "Help") :underline 0)))
|
(tools (gui:make-menu bar (_ "Tools") :underline 0))
|
||||||
(gui:make-menubutton file (_ "Quit") #'menu:quit :underline 0)
|
(help (gui:make-menu bar (_ "Help") :underline 0)))
|
||||||
(gui:make-menubutton help (_ "About") #'menu:help-about :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))))
|
||||||
|
|
||||||
(defclass tool-bar (gui:frame)
|
(defclass tool-bar (gui:frame)
|
||||||
((iri-entry
|
((iri-entry
|
||||||
|
|
|
@ -16,3 +16,10 @@
|
||||||
(gui:break-mainloop)
|
(gui:break-mainloop)
|
||||||
(client-events:stop-events-loop)
|
(client-events:stop-events-loop)
|
||||||
(comm:close-server))
|
(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))))))
|
(yason:encode-array-element certificate))))))
|
||||||
|
|
||||||
(defun gemini-certificates ()
|
(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)
|
(defun invalidate-cached-value (cache-key)
|
||||||
(db:cache-invalidate cache-key)
|
(db:cache-invalidate cache-key)
|
||||||
|
|
|
@ -3377,6 +3377,7 @@
|
||||||
:misc-utils)
|
:misc-utils)
|
||||||
(:local-nicknames (:comm :json-rpc-communication)
|
(:local-nicknames (:comm :json-rpc-communication)
|
||||||
(:ev :program-events)
|
(:ev :program-events)
|
||||||
|
(:cev :client-events)
|
||||||
(:re :cl-ppcre)
|
(:re :cl-ppcre)
|
||||||
(:a :alexandria)
|
(:a :alexandria)
|
||||||
(:gui :nodgui)
|
(:gui :nodgui)
|
||||||
|
@ -3384,7 +3385,27 @@
|
||||||
(:gui-shapes :nodgui.shapes))
|
(:gui-shapes :nodgui.shapes))
|
||||||
(:export
|
(:export
|
||||||
:help-about
|
: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
|
(defpackage :client-main-window
|
||||||
(:use
|
(:use
|
||||||
|
|
|
@ -165,6 +165,7 @@
|
||||||
(:file "json-rpc-communication")
|
(:file "json-rpc-communication")
|
||||||
(:file "validation")
|
(:file "validation")
|
||||||
(:file "icons")
|
(:file "icons")
|
||||||
|
(:file "certificates-window")
|
||||||
(:file "menu-command")
|
(:file "menu-command")
|
||||||
(:file "main-window")))
|
(:file "main-window")))
|
||||||
(:file "main")
|
(:file "main")
|
||||||
|
|
Loading…
Reference in New Issue