From 902cf57657ef22e83ab9f90ad5ec00a41ab770e1 Mon Sep 17 00:00:00 2001 From: cage Date: Fri, 24 Mar 2023 10:46:54 +0100 Subject: [PATCH] - [GUI] added button to delete and import gemini gertificates. --- src/gui/client/certificates-window.lisp | 88 ++++++++++++++++--- src/gui/client/icons.lisp | 48 ++++++---- src/gui/client/json-rpc-communication.lisp | 5 +- src/gui/client/menu-command.lisp | 7 +- .../public-api-gemini-certificates.lisp | 18 ++++ src/gui/server/public-api.lisp | 5 ++ src/package.lisp | 4 +- src/program-events.lisp | 4 +- 8 files changed, 137 insertions(+), 42 deletions(-) diff --git a/src/gui/client/certificates-window.lisp b/src/gui/client/certificates-window.lisp index b1a5e4f..b644f3d 100644 --- a/src/gui/client/certificates-window.lisp +++ b/src/gui/client/certificates-window.lisp @@ -12,28 +12,90 @@ :initform '() :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) (with-accessors ((tree tree) (rows rows)) object - (let ((treeview (make-instance 'gui:scrolled-treeview + (let ((new-rows (all-rows)) + (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) + (gui:treeview-heading tree gui:+treeview-first-column-id+ + :text (_ "Address")) + (resync-rows object new-rows) 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: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)))) diff --git a/src/gui/client/icons.lisp b/src/gui/client/icons.lisp index 6460585..f27bb84 100644 --- a/src/gui/client/icons.lisp +++ b/src/gui/client/icons.lisp @@ -1,30 +1,38 @@ (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) (let ((path (if (not (re:scan "(?i)png$" filename)) @@ -36,9 +44,11 @@ (gui:make-image data))))) (defun load-icons () - (setf *search* (load-icon +search+)) - (setf *back* (load-icon +back+)) - (setf *open-iri* (load-icon +go+)) - (setf *open-tour* (load-icon +open-tour+)) - (setf *refresh* (load-icon +refresh+)) - (setf *up* (load-icon +up+))) + (setf *search* (load-icon +search+)) + (setf *back* (load-icon +back+)) + (setf *open-iri* (load-icon +go+)) + (setf *open-tour* (load-icon +open-tour+)) + (setf *refresh* (load-icon +refresh+)) + (setf *up* (load-icon +up+)) + (setf *document-delete* (load-icon +document-delete+)) + (setf *document-add* (load-icon +document-add+))) diff --git a/src/gui/client/json-rpc-communication.lisp b/src/gui/client/json-rpc-communication.lisp index 58299c5..7419193 100644 --- a/src/gui/client/json-rpc-communication.lisp +++ b/src/gui/client/json-rpc-communication.lisp @@ -87,8 +87,9 @@ :code code :data data :text message)) - (values (rpc:extract-results raw-response) - raw-response))))) + (progn + (values (rpc:extract-results raw-response) + raw-response)))))) (defun close-server () (make-request :quit-program 1)) diff --git a/src/gui/client/menu-command.lisp b/src/gui/client/menu-command.lisp index 2baa0d3..3f315bb 100644 --- a/src/gui/client/menu-command.lisp +++ b/src/gui/client/menu-command.lisp @@ -18,8 +18,5 @@ (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))) + (let ((master gui-goodies:*toplevel*)) + (client-certificates-window:init-window master))) diff --git a/src/gui/server/public-api-gemini-certificates.lisp b/src/gui/server/public-api-gemini-certificates.lisp index 653ae56..a970f64 100644 --- a/src/gui/server/public-api-gemini-certificates.lisp +++ b/src/gui/server/public-api-gemini-certificates.lisp @@ -48,3 +48,21 @@ (defun gemini-delete-certificate (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))))) diff --git a/src/gui/server/public-api.lisp b/src/gui/server/public-api.lisp index da7c4e9..1cd5675 100644 --- a/src/gui/server/public-api.lisp +++ b/src/gui/server/public-api.lisp @@ -69,6 +69,11 @@ (gen-rpc "gemini-delete-certificate" 'gemini-delete-certificate "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" 'gemini-table-of-contents "iri" 0 diff --git a/src/package.lisp b/src/package.lisp index 6260c34..ac12f2b 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -3318,7 +3318,9 @@ :*open-iri* :*open-tour* :*refresh* - :*up*)) + :*up* + :*document-delete* + :*document-add*)) (defpackage :validation (:use diff --git a/src/program-events.lisp b/src/program-events.lisp index 14c23ed..b8a50dd 100644 --- a/src/program-events.lisp +++ b/src/program-events.lisp @@ -235,7 +235,7 @@ (defclass blocking-caller-event (event-on-own-thread function-event) ((results - :initform (make-instance 'box:box) + :initform (make-instance 'box:box :contents :nothing) :initarg :results :accessor results))) @@ -265,7 +265,7 @@ (funcall push-event-fn event) (with-lock (lock) (loop - while (null (box:unbox (results event))) + while (eq (box:unbox (results event)) :nothing) do (bt:condition-wait condition-variable lock))) (let* ((event-results (results event))