cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- [GUI] added button to delete and import gemini gertificates.

This commit is contained in:
cage 2023-03-24 10:46:54 +01:00
parent 5282e2cf86
commit 902cf57657
8 changed files with 137 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
src/gui/client/certificates-window.lisp
View File

@ -12,28 +12,90 @@
:initform '() :initform '()
:initarg :rows))) :initarg :rows)))
(defun resync-rows (certificate-frame new-rows)
(with-accessors ((tree tree)
(rows 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))
:index gui:+treeview-last-index+)))
(gui:treeview-insert-item tree :item tree-row))))
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) (defmethod initialize-instance :after ((object certificate-frame) &key)
(with-accessors ((tree tree) (with-accessors ((tree tree)
(rows rows)) object (rows rows)) object
(let ((treeview (make-instance 'gui:scrolled-treeview (let ((new-rows (all-rows))
(treeview (make-instance 'gui:scrolled-treeview
:master object :master object
:pack '(:side :top :expand t :fill :both) :pack '(:side :top :expand t :fill :both)
:columns (list (_ "File") :columns (list (_ "File")
(_ "Fingerprint"))))) (_ "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) (setf tree treeview)
(gui:treeview-heading tree gui:+treeview-first-column-id+
:text (_ "Address"))
(resync-rows object new-rows)
object))) object)))
(defun init-window (master rows) (defun delete-certificates-clsr (certificate-frame)
(lambda ()
(a:when-let* ((selections (gui:treeview-get-selection (tree certificate-frame))))
(loop for selection in selections do
(let ((url (gui:id selection)))
(ev:with-enqueued-process-and-unblock ()
(comm:make-request :gemini-delete-certificate
1
url))
(let ((new-rows (all-rows)))
(resync-rows certificate-frame new-rows)))))))
(defun import-certificates-clsr (certificate-frame)
(lambda ()
(a:when-let* ((uri (gui-mw:text-input-dialog certificate-frame
(_ "Information")
(_ "Type the net address the certificate is valid for:")))
(cert-file (gui:get-open-file :initial-dir "."
:parent certificate-frame
:multiple nil
:title (_ "Choose the certificate file")))
(key-file (gui:get-open-file :initial-dir (fs:parent-dir-path cert-file)
:parent certificate-frame
:multiple nil
:title (_ "Choose the private key file"))))
(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)))
(error (e)
(client-main-window::notify-request-error e))))))
(defun init-window (master)
(gui:with-modal-toplevel (toplevel :master master :title (_ "Certificates")) (gui:with-modal-toplevel (toplevel :master master :title (_ "Certificates"))
(gui:transient toplevel master) (gui:transient toplevel master)
(gui:grid (make-instance 'certificate-frame :master toplevel :rows rows) 0 0))) (let* ((table (make-instance 'certificate-frame :master toplevel))
(delete-button (make-instance 'gui:button
:master toplevel
:image icons:*document-delete*
:command (delete-certificates-clsr table)))
(import-button (make-instance 'gui:button
:master toplevel
:image icons:*document-add*
:command (import-certificates-clsr table))))
(gui:grid table 0 0 :sticky :news :columnspan 2)
(gui:grid delete-button 1 0 :sticky :w)
(gui:grid import-button 1 1 :sticky :w))))

48
src/gui/client/icons.lisp
View File

@ -1,30 +1,38 @@
(in-package :icons) (in-package :icons)
(a:define-constant +icon-dir+ "/data/icons/" :test #'string=) (a:define-constant +icon-dir+ "/data/icons/" :test #'string=)
(a:define-constant +search+ "fmw_search" :test #'string=) (a:define-constant +search+ "fmw_search" :test #'string=)
(a:define-constant +back+ "fmw_back" :test #'string=) (a:define-constant +back+ "fmw_back" :test #'string=)
(a:define-constant +go+ "fmw_go" :test #'string=) (a:define-constant +go+ "fmw_go" :test #'string=)
(a:define-constant +open-tour+ "fmw_open_tour" :test #'string=) (a:define-constant +open-tour+ "fmw_open_tour" :test #'string=)
(a:define-constant +refresh+ "fmw_refresh" :test #'string=) (a:define-constant +refresh+ "fmw_refresh" :test #'string=)
(a:define-constant +up+ "fmw_uparrow" :test #'string=) (a:define-constant +up+ "fmw_uparrow" :test #'string=)
(defparameter *search* nil) (a:define-constant +document-delete+ "fmw_document-delete" :test #'string=)
(defparameter *back* nil) (a:define-constant +document-add+ "fmw_document-add" :test #'string=)
(defparameter *open-iri* nil) (defparameter *search* nil)
(defparameter *open-tour* nil) (defparameter *back* nil)
(defparameter *refresh* nil) (defparameter *open-iri* nil)
(defparameter *up* nil) (defparameter *open-tour* nil)
(defparameter *refresh* nil)
(defparameter *up* nil)
(defparameter *document-delete* nil)
(defparameter *document-add* nil)
(defun load-icon (filename) (defun load-icon (filename)
(let ((path (if (not (re:scan "(?i)png$" filename)) (let ((path (if (not (re:scan "(?i)png$" filename))
@ -36,9 +44,11 @@
(gui:make-image data))))) (gui:make-image data)))))
(defun load-icons () (defun load-icons ()
(setf *search* (load-icon +search+)) (setf *search* (load-icon +search+))
(setf *back* (load-icon +back+)) (setf *back* (load-icon +back+))
(setf *open-iri* (load-icon +go+)) (setf *open-iri* (load-icon +go+))
(setf *open-tour* (load-icon +open-tour+)) (setf *open-tour* (load-icon +open-tour+))
(setf *refresh* (load-icon +refresh+)) (setf *refresh* (load-icon +refresh+))
(setf *up* (load-icon +up+))) (setf *up* (load-icon +up+))
(setf *document-delete* (load-icon +document-delete+))
(setf *document-add* (load-icon +document-add+)))

5
src/gui/client/json-rpc-communication.lisp
View File

@ -87,8 +87,9 @@
:code code :code code
:data data :data data
:text message)) :text message))
(values (rpc:extract-results raw-response) (progn
raw-response))))) (values (rpc:extract-results raw-response)
raw-response))))))
(defun close-server () (defun close-server ()
(make-request :quit-program 1)) (make-request :quit-program 1))

7
src/gui/client/menu-command.lisp
View File

@ -18,8 +18,5 @@
(comm:close-server)) (comm:close-server))
(defun show-certificates () (defun show-certificates ()
(let ((master gui-goodies:*toplevel*) (let ((master gui-goodies:*toplevel*))
(rows (cev:enqueue-request-and-wait-results :gemini-certificates (client-certificates-window:init-window master)))
1
ev:+maximum-event-priority+)))
(client-certificates-window:init-window master rows)))

18
src/gui/server/public-api-gemini-certificates.lisp
View File

@ -48,3 +48,21 @@
(defun gemini-delete-certificate (cache-key) (defun gemini-delete-certificate (cache-key)
(invalidate-cached-value cache-key)) (invalidate-cached-value cache-key))
(defun gemini-import-certificate (uri cert-file key-file)
(db-utils:with-ready-database (:connect nil)
(if (gemini-parser:gemini-iri-p uri)
(let* ((id (to-s (db:cache-put uri +cache-tls-certificate-type+)))
(cert-filename (fs:path-last-element cert-file))
(key-filename (fs:path-last-element key-file))
(cache-dir (os-utils:cached-file-path id))
(cert-out-path (strcat cache-dir
fs:*directory-sep*
cert-filename))
(key-out-path (strcat cache-dir
fs:*directory-sep*
key-filename)))
(fs:make-directory cache-dir)
(fs:copy-a-file cert-file cert-out-path :overwrite t)
(fs:copy-a-file key-file key-out-path :overwrite t))
(error (format nil (_ "~s is not a valid gemini address") uri)))))

5
src/gui/server/public-api.lisp
View File

@ -69,6 +69,11 @@
(gen-rpc "gemini-delete-certificate" (gen-rpc "gemini-delete-certificate"
'gemini-delete-certificate 'gemini-delete-certificate
"cache-key" 0) "cache-key" 0)
(gen-rpc "gemini-import-certificate"
'gemini-import-certificate
"uri" 0
"cert-file" 1
"key-file" 2)
(gen-rpc "gemini-table-of-contents" (gen-rpc "gemini-table-of-contents"
'gemini-table-of-contents 'gemini-table-of-contents
"iri" 0 "iri" 0

4
src/package.lisp
View File

@ -3318,7 +3318,9 @@
:*open-iri* :*open-iri*
:*open-tour* :*open-tour*
:*refresh* :*refresh*
:*up*)) :*up*
:*document-delete*
:*document-add*))
(defpackage :validation (defpackage :validation
(:use (:use

4
src/program-events.lisp
View File

@ -235,7 +235,7 @@
(defclass blocking-caller-event (event-on-own-thread function-event) (defclass blocking-caller-event (event-on-own-thread function-event)
((results ((results
:initform (make-instance 'box:box) :initform (make-instance 'box:box :contents :nothing)
:initarg :results :initarg :results
:accessor results))) :accessor results)))
@ -265,7 +265,7 @@
(funcall push-event-fn event) (funcall push-event-fn event)
(with-lock (lock) (with-lock (lock)
(loop (loop
while (null (box:unbox (results event))) while (eq (box:unbox (results event)) :nothing)
do do
(bt:condition-wait condition-variable lock))) (bt:condition-wait condition-variable lock)))
(let* ((event-results (results event)) (let* ((event-results (results event))