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 0000000..ea49709 Binary files /dev/null and b/data/icons/fmw_profile.png differ diff --git a/src/gemini-viewer.lisp b/src/gemini-viewer.lisp index 5a335d2..8b581b3 100644 --- a/src/gemini-viewer.lisp +++ b/src/gemini-viewer.lisp @@ -742,7 +742,7 @@ (declare (ignore status code-description response socket meta parsed-iri)) (gemini-client:debug-gemini "response requested certificate") (multiple-value-bind (cached-certificate cached-key) - (gemini-client:fetch-cached-certificate iri) + (gemini-client:fetch-cached-certificate iri :if-does-not-exist :create) (request iri :enqueue enqueue :do-nothing-if-exists-in-db do-nothing-if-exists-in-db diff --git a/src/gemini/client.lisp b/src/gemini/client.lisp index 67d124a..204ec81 100644 --- a/src/gemini/client.lisp +++ b/src/gemini/client.lisp @@ -617,15 +617,15 @@ (defun tls-cert-find (request-iri) (when-let* ((all-rows (db:find-tls-certificates-rows)) (parsed-request-iri (iri:iri-parse request-iri :null-on-error t))) - (multiple-value-bind (request-iri request-host request-path request-query request-port - request-fragment request-scheme request-user-info) + (multiple-value-bind (x request-host request-path y request-port + z request-scheme request-user-info) (gemini-client:displace-iri parsed-request-iri) - (declare (ignore request-iri request-query request-fragment)) + (declare (ignore x y z)) (loop for row in all-rows do (let ((id (db:row-id row))) (multiple-value-bind (iri host path query port fragment scheme user-info) (gemini-client:displace-iri (iri:iri-parse (db:row-cache-key row))) - (declare (ignore iri query fragment)) + (declare (ignore query fragment)) (when (and (string= request-host host) (string= request-scheme scheme) (string= request-user-info user-info) @@ -665,27 +665,27 @@ (remove-cached-certificate-password certificate-path) (save-cache-certificate-password certificate-path new-password)) -(defun fetch-cached-certificate (url) - (let ((certificate nil) - (key nil) - (just-created t)) - (multiple-value-bind (certificate-cache key-cache) - (tls-cert-find url) - (if (and certificate-cache - key-cache) - (setf certificate certificate-cache - key key-cache - just-created nil) - (multiple-value-bind (certificate-new key-new) - (gemini-client:make-client-certificate url) - (setf certificate certificate-new - key key-new))) - (assert certificate) - (assert key) - (values certificate - key - (retrieve-cached-certificate-password certificate) - just-created)))) +(defun fetch-cached-certificate (url &key (if-does-not-exist nil)) + (assert (member if-does-not-exist '(nil :create))) + (multiple-value-bind (certificate-cache key-cache) + (tls-cert-find url) + (cond + ((and certificate-cache + key-cache) + (values certificate-cache + key-cache + (retrieve-cached-certificate-password certificate-cache))) + ((eq if-does-not-exist :create) + (multiple-value-bind (certificate-new key-new) + (gemini-client:make-client-certificate url) + (assert certificate-new) + (assert key-new) + (values certificate-new + key-new + (retrieve-cached-certificate-password certificate-new) + t))) + (t + nil)))) (defgeneric build-redirect-iri (meta iri-from)) diff --git a/src/gui/client/icons.lisp b/src/gui/client/icons.lisp index 980bd26..b5e08bb 100644 --- a/src/gui/client/icons.lisp +++ b/src/gui/client/icons.lisp @@ -46,6 +46,8 @@ (a:define-constant +text+ "fmw_text.png" :test #'string=) +(a:define-constant +profile+ "fmw_profile.png" :test #'string=) + (defparameter *search* nil) (defparameter *back* nil) @@ -90,16 +92,30 @@ (defparameter *text* nil) +(defparameter *profile* nil) + +(defparameter *profile-disabled* nil) + +(defun icon-filename->filepath (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