From 07d9c4aea99bdb50c9aa14826b64b5ca12166ad2 Mon Sep 17 00:00:00 2001 From: cage Date: Thu, 15 Feb 2024 16:15:18 +0100 Subject: [PATCH] - [GUI] added a button to give a visual hint that a the client provided the server a TLS certificate. --- Makefile.am | 4 +- Makefile.in | 4 +- data/icons/fmw_profile.png | Bin 0 -> 2060 bytes src/gemini-viewer.lisp | 2 +- src/gemini/client.lisp | 50 +++++++------- src/gui/client/icons.lisp | 28 ++++++-- src/gui/client/main-window.lisp | 65 ++++++++++++------ .../public-api-gemini-certificates.lisp | 12 +++- src/gui/server/public-api-gemini-stream.lisp | 3 +- src/gui/server/public-api.lisp | 3 + src/kami/client.lisp | 2 +- src/package.lisp | 15 ++-- 12 files changed, 123 insertions(+), 65 deletions(-) create mode 100644 data/icons/fmw_profile.png diff --git a/Makefile.am b/Makefile.am index 56bc8be..e8d68e7 100644 --- a/Makefile.am +++ b/Makefile.am @@ -42,7 +42,8 @@ confdir = $(sysconfdir)/$(PACKAGE) dist_conf_DATA = etc/init.lisp etc/default-theme.conf etc/shared.conf etc/shared-gui.conf -nobase_dist_pkgdata_DATA = data/error-pages/51 \ +nobase_dist_pkgdata_DATA = \ +data/error-pages/51 \ data/error-pages/header-51.png \ data/icons/fmw_arrow-down.png \ data/icons/fmw_arrow-up.png \ @@ -60,6 +61,7 @@ data/icons/fmw_folder.png \ data/icons/fmw_go.png \ data/icons/fmw_open_tour.png \ data/icons/fmw_page.png \ +data/icons/fmw_profile.png \ data/icons/fmw_refresh.png \ data/icons/fmw_rss-add.png \ data/icons/fmw_rss-delete.png \ diff --git a/Makefile.in b/Makefile.in index 36ffceb..556a51f 100644 --- a/Makefile.in +++ b/Makefile.in @@ -407,7 +407,8 @@ doc/tinmop.org doc/send-toot.lisp NEWS.org ChangeLog AUTHORS confdir = $(sysconfdir)/$(PACKAGE) dist_conf_DATA = etc/init.lisp etc/default-theme.conf etc/shared.conf etc/shared-gui.conf -nobase_dist_pkgdata_DATA = data/error-pages/51 \ +nobase_dist_pkgdata_DATA = \ +data/error-pages/51 \ data/error-pages/header-51.png \ data/icons/fmw_arrow-down.png \ data/icons/fmw_arrow-up.png \ @@ -425,6 +426,7 @@ data/icons/fmw_folder.png \ data/icons/fmw_go.png \ data/icons/fmw_open_tour.png \ data/icons/fmw_page.png \ +data/icons/fmw_profile.png \ data/icons/fmw_refresh.png \ data/icons/fmw_rss-add.png \ data/icons/fmw_rss-delete.png \ diff --git a/data/icons/fmw_profile.png b/data/icons/fmw_profile.png new file mode 100644 index 0000000000000000000000000000000000000000..ea49709bd19f84004fd5d586cb4722d29c34d848 GIT binary patch literal 2060 zcmaJ?eLPh89v<3m^g0YevZo0nn|U*X8Sl(6dp@6Yes9n7e81n{_xXIz(ZB$| z4QtKUA`plTOa_gu83FC9_ZQ7qmYn=nGnm2jFgO^BhUGjdi0~3XQ6Rt+@nS$W$P*|N zT0vI?Vij7*34_B}pHume2+PxAunLhx!$u%nJroiiKMsU}C@@ASc0<2b-$VmKfg5@k znT2Obe85;CBUuUtCkJr&$#Hy&0PW!pxGJa`0TBrE0EH-CETbyi&`Y{h&0M>ULjy|? zIL;0IM^a&|K)?r*f&dwdx98&>34kLBOCaGXB+5>Jh$rB21R@UaWKY0T$xc)}0r>Es zHPNJkXeyiL`yrNQ<%W)hVF?w7lgs5;xdRrG#^4AP3I&HJ;)q0h4Z>cg6vI4)y;!z= zS%C)1_)?(+7D8e`tH_Ij5@9#ACeuGk5J^7Die(?JNpoR11y6z_VDZ|LmVqqR|A&f1 zAJHU8=FQLl$K<0`W;Yljg-y^!&Js z6~BdUv@qS=ooI-;%`9~8U@o5VWmJT8gokXj$U%-CwX4{SG|FK-`RkRnI|kQ#>xo&o zIipNO2rC^`7!kC?(1>;{!+)=JW=Af{#Up#`;*)Rg?Tb@e38SFWJkys-vP0kfeQ$>6 zRf2Oi3+*-{6VFqZk`;I416_$a&p@8H%fCA_x?>HGW!CFX(#Lwbzt!75DyltnnWb~- z>Mq}t`L1pkE(Fgjre7eaPheV?^!emy7`J_!vvE_~QDldTvH$Ix0kdJgAEL9o+&r_{ zgFH8v@HVk-;ED^6hB9LqV|Q1p6a$w&-D)q6SiD_WdLgv5zDNabF}*W0T=2RmZ8Y8F zd2FMq-(v8ED_o#k?N!t8bR?lT#$rfW6s-Hayz=}$@dS{T_O)(-oll6s_H*gGd#RQq z$|gebV~TaUjaAuf>vZ&eTJVo&Oj_e{iv}~w!V$9=}uzYjZPveP?m~Hkmk=FS@e_XAkwo%u#rK)!$eNeE61%i-zac|$_ z(WXyj1bpvTBRPn7KVz=#Ua&VhaGumJZOuo9e^TPE-qzlCK2m3>Xg%%A(!7Wif&xm? zKcaShwyv*yq45{Xi4;dmePToH0|Om@TI*on%@p&(!bY#Cj*2TMuiuJ%HG9K6+r!7{Q8SrPt{hJhLoYH z&uXSf^_JD~ioD2gUU?J4Z}t4%qBmrx7#Z}meo>YcdU28zVX+7%F&>>G+TM8J_juc> z8oD{-vHzXfPK4bd-|Vybw&pcX9G|a`6Qit~N5*^Si%I=1GrZ%28|rtT+T#13dft=T zocl1vX!5t!2Yi0vwiGmkvsFK+qwMF>#$JBL#P}0C_Y3E?=)AkLkiH4CCb_lGcqc~I zl7n17(y2OkEU9+g!5^lsJ=$cjwz`|`ex{Do0x@79oAW8*+!^NY)rjQA$FlW#~YkY;zdHr z{Qb%86C`y_fbkbLn7g+xXP13tyk7W^>hE-3#BY?pYD4ETQq=JHSYW67Uj35yxL$J) zqvsR{MOFLV^c~b1URQK|_zCB+ z95#tPG8S{BwtkJVEhc-)`{CcY&*on$4{&Xbc;<%w@cSFTPVG)Dm^L_kEcE-khonV+ ztF%t%Jh*AYVHcrJ+PJTJ9W!Pqw>-Y8)+#u+HSek}rdU)(?`^j=tJBRDMh~HGtM?bP z8AuFQRmJ9+{>&(2C+QksX1S%=ZolfQzso$`Vev4Tfilepath (filename) + (if (not (re:scan "(?i)png$" filename)) + (res:get-data-file (fs:cat-parent-dir +icon-dir+ + (strcat filename ".png"))) + (res:get-data-file (fs:cat-parent-dir +icon-dir+ filename)))) + (defun load-icon (filename) - (let ((path (if (not (re:scan "(?i)png$" filename)) - (res:get-data-file (fs:cat-parent-dir +icon-dir+ - (strcat filename ".png"))) - (res:get-data-file (fs:cat-parent-dir +icon-dir+ filename))))) + (let ((path (icon-filename->filepath filename))) (with-open-file (stream path :element-type '(unsigned-byte 8)) (let ((data (gui-utils:read-into-array stream (file-length stream)))) (gui:image-scale (gui:make-image data) (client-configuration:config-icons-scaling)))))) +(defun disable-icon (filename) + (let ((pixmap (gui.pixmap:slurp-pixmap 'gui.pixmap:png + (icon-filename->filepath filename)))) + (gui.pixmap:to-disabled pixmap) + (gui:image-scale (gui:make-image (gui.pixmap:encode-base64 pixmap)) + (client-configuration:config-icons-scaling)))) + (defun load-icons () (let ((nodgui:*use-tk-for-decoding-png* t)) (setf *search* (load-icon +search+)) @@ -123,4 +139,6 @@ (setf *gemlog-subscribe* (load-icon +gemlog-subscribe+)) (setf *gemlog-unsubscribe* (load-icon +gemlog-unsubscribe+)) (setf *inline-images* (load-icon +inline-images+)) - (setf *text* (load-icon +text+)))) + (setf *text* (load-icon +text+)) + (setf *profile* (load-icon +profile+)) + (setf *profile-disabled* (disable-icon +profile+)))) diff --git a/src/gui/client/main-window.lisp b/src/gui/client/main-window.lisp index 0d8251f..3126be6 100644 --- a/src/gui/client/main-window.lisp +++ b/src/gui/client/main-window.lisp @@ -174,6 +174,14 @@ (set-bookmark-button-true main-window)) (ev:with-enqueued-process-and-unblock () (set-bookmark-button-false main-window))) + (if (cev:enqueue-request-and-wait-results :gemini-url-using-certificate-p + 1 + ev:+standard-event-priority+ + iri) + (ev:with-enqueued-process-and-unblock () + (set-certificate-button-active main-window)) + (ev:with-enqueued-process-and-unblock () + (set-certificate-button-inactive main-window))) (ev:with-enqueued-process-and-unblock () (set-gemlog-toolbar-button-appearance main-window iri)) (ev:with-enqueued-process-and-unblock (program-events:+minimum-event-priority+) @@ -279,6 +287,10 @@ :initform nil :initarg :up-button :accessor up-button) + (certificate-button + :initform nil + :initarg :certificate-button + :accessor certificate-button) (go-button :initform nil :initarg :go-button @@ -1217,10 +1229,12 @@ local file paths." (set-address-bar-text main-window iri-visited) (open-iri iri-visited main-window t))))))) -(defun set-bookmark-button-image (main-window image) +(defun set-toolbar-button-image (main-window button-slot image) (with-accessors ((tool-bar tool-bar)) main-window - (with-accessors ((bookmark-button bookmark-button)) tool-bar - (gui:configure bookmark-button :image image)))) + (gui:configure (slot-value tool-bar button-slot) :image image))) + +(defun set-bookmark-button-image (main-window image) + (set-toolbar-button-image main-window 'bookmark-button image)) (defun set-bookmark-button-false (main-window) (set-bookmark-button-image main-window icons:*star-yellow*)) @@ -1229,9 +1243,7 @@ local file paths." (set-bookmark-button-image main-window icons:*star-blue*)) (defun set-subscribe-button-image (main-window image) - (with-accessors ((tool-bar tool-bar)) main-window - (with-accessors ((subscribe-button subscribe-button)) tool-bar - (gui:configure subscribe-button :image image)))) + (set-toolbar-button-image main-window 'subscribe-button image)) (defun set-subscribe-button-unsubscribed (main-window) (set-subscribe-button-image main-window icons:*gemlog-subscribe*)) @@ -1239,6 +1251,15 @@ local file paths." (defun set-subscribe-button-subscribed (main-window) (set-subscribe-button-image main-window icons:*gemlog-unsubscribe*)) +(defun set-certificate-button-image (main-window image) + (set-toolbar-button-image main-window 'certificate-button image)) + +(defun set-certificate-button-active (main-window) + (set-certificate-button-image main-window icons:*profile*)) + +(defun set-certificate-button-inactive (main-window) + (set-certificate-button-image main-window icons:*profile-disabled*)) + (defun toggle-bookmark-iri-clsr (main-window) (lambda () (with-accessors ((tool-bar tool-bar)) main-window @@ -1290,6 +1311,7 @@ local file paths." (back-button back-button) (reload-button reload-button) (up-button up-button) + (certificate-button certificate-button) (go-button go-button) (bookmark-button bookmark-button) (tour-button tour-button) @@ -1321,6 +1343,7 @@ local file paths." (back-button back-button) (reload-button reload-button) (up-button up-button) + (certificate-button certificate-button) (go-button go-button) (bookmark-button bookmark-button) (tour-button tour-button) @@ -1330,13 +1353,14 @@ local file paths." (setf iri-entry (make-instance 'gui-mw:autocomplete-entry :master object :autocomplete-function (autocomplete-iri-clsr object))) - (setf back-button (make-instance 'gui:button :master object :image icons:*back*)) - (setf reload-button (make-instance 'gui:button :master object :image icons:*refresh*)) - (setf go-button (make-instance 'gui:button :master object :image icons:*open-iri*)) - (setf up-button (make-instance 'gui:button :master object :image icons:*up*)) - (setf bookmark-button (make-instance 'gui:button :master object)) - (setf tour-button (make-instance 'gui:button :master object :image icons:*bus-go*)) - (setf subscribe-button (make-instance 'gui:button + (setf back-button (make-instance 'gui:button :master object :image icons:*back*)) + (setf reload-button (make-instance 'gui:button :master object :image icons:*refresh*)) + (setf go-button (make-instance 'gui:button :master object :image icons:*open-iri*)) + (setf up-button (make-instance 'gui:button :master object :image icons:*up*)) + (setf certificate-button (make-instance 'gui:button :master object :image icons:*profile-disabled*)) + (setf bookmark-button (make-instance 'gui:button :master object)) + (setf tour-button (make-instance 'gui:button :master object :image icons:*bus-go*)) + (setf subscribe-button (make-instance 'gui:button :master object :image icons:*gemlog-subscribe*)) (setf inline-images-button (make-instance 'gui:button @@ -1353,13 +1377,14 @@ local file paths." (gui:grid back-button 0 0 :sticky :nsw) (gui:grid reload-button 0 1 :sticky :nsw) (gui:grid up-button 0 2 :sticky :nsw) - (gui:grid iri-entry 0 3 :sticky :nswe :padx +minimum-padding+) - (gui:grid go-button 0 4 :sticky :nsw) - (gui:grid bookmark-button 0 5 :sticky :nsw) - (gui:grid subscribe-button 0 6 :sticky :nsw) - (gui:grid tour-button 0 7 :sticky :nsw) - (gui:grid inline-images-button 0 8 :sticky :nsw) - (gui:grid-columnconfigure object 3 :weight 2) + (gui:grid certificate-button 0 3 :sticky :nsw) + (gui:grid iri-entry 0 4 :sticky :nswe :padx +minimum-padding+) + (gui:grid go-button 0 5 :sticky :nsw) + (gui:grid bookmark-button 0 6 :sticky :nsw) + (gui:grid subscribe-button 0 7 :sticky :nsw) + (gui:grid tour-button 0 8 :sticky :nsw) + (gui:grid inline-images-button 0 9 :sticky :nsw) + (gui:grid-columnconfigure object 4 :weight 2) object)) (defclass toc-frame (gui:frame) diff --git a/src/gui/server/public-api-gemini-certificates.lisp b/src/gui/server/public-api-gemini-certificates.lisp index d809e28..4cb299e 100644 --- a/src/gui/server/public-api-gemini-certificates.lisp +++ b/src/gui/server/public-api-gemini-certificates.lisp @@ -63,9 +63,9 @@ (cert-out-path (strcat cache-dir fs:*directory-sep* cert-filename)) - (key-out-path (strcat cache-dir - fs:*directory-sep* - key-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)) @@ -74,3 +74,9 @@ (defun gemini-save-certificate-key-password (certificate-path password) (gemini-client:save-cache-certificate-password certificate-path password) t) + +(defun gemini-url-using-certificate-p (url) + (a:when-let* ((certificate-path (gemini-client:fetch-cached-certificate url + :if-does-not-exist nil)) + (cached-password (gemini-client:retrieve-cached-certificate-password certificate-path))) + t)) diff --git a/src/gui/server/public-api-gemini-stream.lisp b/src/gui/server/public-api-gemini-stream.lisp index 9701b7b..b938cc9 100644 --- a/src/gui/server/public-api-gemini-stream.lisp +++ b/src/gui/server/public-api-gemini-stream.lisp @@ -215,7 +215,7 @@ cached-key cached-key-password just-created) - (gemini-client:fetch-cached-certificate iri) + (gemini-client:fetch-cached-certificate iri :if-does-not-exist :create) (cond ((or just-created (os-utils:ssl-key-has-empty-password-p cached-key)) @@ -235,7 +235,6 @@ (let ((error-message (format nil (_"a password to unlock certificate for ~a is needed") iri))) - (misc:dbg "certificate null ~a ~a" cached-certificate cached-key-password) (make-gemini-response +certificate-password-not-found-error-status-code+ error-message cached-certificate diff --git a/src/gui/server/public-api.lisp b/src/gui/server/public-api.lisp index 69a8078..9c337a8 100644 --- a/src/gui/server/public-api.lisp +++ b/src/gui/server/public-api.lisp @@ -93,6 +93,9 @@ 'gemini-save-certificate-key-password "certificate-path" 0 "password" 1) + (gen-rpc "gemini-url-using-certificate-p" + 'gemini-url-using-certificate-p + "url" 0) (gen-rpc "gemini-table-of-contents" 'gemini-table-of-contents "iri" 0 diff --git a/src/kami/client.lisp b/src/kami/client.lisp index 9889b00..ccb781f 100644 --- a/src/kami/client.lisp +++ b/src/kami/client.lisp @@ -243,7 +243,7 @@ (defun iri->filesystem-window-handlers (kami-iri) (a:when-let ((parsed-iri (iri:iri-parse kami-iri :null-on-error t))) (multiple-value-bind (cached-certificate cached-key) - (gemini-client:fetch-cached-certificate kami-iri) + (gemini-client:fetch-cached-certificate kami-iri :if-does-not-exist :create) (multiple-value-bind (actual-iri host path query port fragment scheme) (gemini-client:displace-iri parsed-iri) (declare (ignore actual-iri scheme)) diff --git a/src/package.lisp b/src/package.lisp index f9c6184..3185db0 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -3401,11 +3401,12 @@ :constants :misc :text-utils) - (:local-nicknames (:comm :json-rpc-communication) - (:re :cl-ppcre) - (:a :alexandria) - (:gui :nodgui) - (:gui-utils :nodgui.utils)) + (:local-nicknames (:comm :json-rpc-communication) + (:re :cl-ppcre) + (:a :alexandria) + (:gui :nodgui) + (:gui.pixmap :nodgui.pixmap) + (:gui-utils :nodgui.utils)) (:export :+icon-dir+ :load-icons @@ -3430,7 +3431,9 @@ :*gemlog-subscribe* :*gemlog-unsubscribe* :*inline-images* - :*text*)) + :*text* + :*profile* + :*profile-disabled*)) (defpackage :validation (:use