mirror of https://codeberg.org/cage/tinmop/
- [GUI] added a button to give a visual hint that a the client provided the server a TLS certificate.
This commit is contained in:
cage
parent
f067dc2ee3
commit
07d9c4aea9
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
Binary file not shown.
|
After Width: | Height: | Size: 2.0 KiB |
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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+))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue