- updated-changelog.

- updated translation file template.

ChangeLog

@@ -1,8 +1,249 @@
+2024-02-17 cage
+
+	* etc/init.lisp,
+	* po/de.po,
+	* po/es.po,
+	* po/fr.po,
+	* po/it.po,
+	* po/pl.po,
+	* po/tinmop.pot,
+	* src/gemini-viewer.lisp,
+	* src/kami/client.lisp,
+	* src/os-utils.lisp,
+	* src/package.lisp,
+	* src/ui-goodies.lisp:
+
+	- updated italian translation;
+	- updated translation file template.
+	- [TUI] added support for certificate's password for gemini requests.
+	- prevented 'ssl-key-has-empty-password-p' to print on console the
+	prompt asking for key password.
+	- added password protected TLS key, for kami protocol.
+	- removed output from ssl command when checking for empty password for
+	a certificate.
+	- added command 'clear-cached-client-tls-certificates'.
+	- updated italian translation.
+
+2024-02-16 cage
+
+	* etc/init.lisp,
+	* src/gemini/client.lisp,
+	* src/gui/client/main-window.lisp,
+	* src/package.lisp,
+	* src/ui-goodies.lisp:
+
+	- [GUI] set state of the certificates toolbar button, not only the
+	image label in: 'set-certificate-button-(active|inactive).
+	- [TUI] added command to change TLS client certificate password.
+
+2024-02-15 cage
+
+	* Makefile.am,
+	* Makefile.in,
+	* data/icons/fmw_profile.png,
+	* src/gemini-viewer.lisp,
+	* src/gemini/client.lisp,
+	* src/gemini/package.lisp,
+	* src/gui/client/certificates-window.lisp,
+	* src/gui/client/icons.lisp,
+	* src/gui/client/main-window.lisp,
+	* src/gui/server/public-api-gemini-certificates.lisp,
+	* src/gui/server/public-api-gemini-stream.lisp,
+	* src/gui/server/public-api.lisp,
+	* src/kami/client.lisp,
+	* src/package.lisp:
+
+	- [GUI] added a button to give a visual hint that a the client
+	provided the server a TLS certificate.
+	- [GUI] added confirmation from user before deleting a certificate.
+	- [GUI] added callback for toolbar certificate button (change password
+	for certificate).
+	- [GUI] ensured the key for cached password for TLC client certificate
+	is erased if an error occurred during gemini connection.
+	- [GUI] ensured the passwords cache for TLS client certificate is
+	emptied after changing a password.
+
+2024-02-14 cage
+
+	* src/gemini/client.lisp,
+	* src/gemini/package.lisp,
+	* src/gui/client/gui-goodies.lisp,
+	* src/gui/client/main-window.lisp,
+	* src/gui/server/public-api-gemini-certificates.lisp,
+	* src/gui/server/public-api-gemini-stream.lisp,
+	* src/gui/server/public-api.lisp,
+	* src/os-utils.lisp,
+	* src/package.lisp:
+
+	- [GUI] added procedures to manage passwords for client TLS
+	certificates.
+
+2024-02-11 cage
+
+	* LICENSES.org,
+	* src/api-client.lisp,
+	* src/gemini-viewer.lisp,
+	* src/gemini/client.lisp,
+	* src/gemini/dummy-server.lisp,
+	* src/gemini/gemini-parser.lisp,
+	* src/gemini/titan.lisp,
+	* src/gui/client/certificates-window.lisp,
+	* src/gui/client/json-rpc-communication.lisp,
+	* src/gui/client/main-window.lisp,
+	* src/gui/client/program-events.lisp,
+	* src/gui/client/titan-window.lisp,
+	* src/gui/server/public-api-gemini-certificates.lisp,
+	* src/gui/server/public-api-gemini-stream.lisp,
+	* src/gui/server/public-api.lisp,
+	* src/misc-utils.lisp,
+	* src/package.lisp,
+	* src/program-events.lisp,
+	* src/tests/gemini-parser-tests.lisp,
+	* src/tests/program-events-tests.lisp,
+	* src/ui-goodies.lisp,
+	* tinmop.asd:
+
+	- [GUI] fixed deletion of TLS client certificates;
+	- chaged API name form 'gemini-delete-certificate' to
+	'gemini-delete-tofu-certificate';
+	- added 'misc:db-stderr'.
+	- removed all direct references to package 'bt' (used wrappers
+	instead);
+	- addedd missing file 'dummy-server.lisp';
+	- updated LICENSES.org.
+	- added optional key password argument to gemini and titan requests.
+	- replaced occurences of 'with-lock' with 'misc:with-lock-held'.
+	Merge branch 'master' into add-password-tls-certificates
+
+2024-02-10 cage
+
+	* src/command-line.lisp,
+	* src/gemini/package.lisp,
+	* src/gui/server/public-api-gemini-stream.lisp,
+	* src/main.lisp,
+	* src/package.lisp,
+	* src/x509.lisp,
+	* tinmop.asd:
+
+	- added a dummy gemini server for debugging purposes.
+
+2024-02-08 cage
+
+	* src/gui/client/certificates-window.lisp,
+	* src/gui/server/public-api-gemini-certificates.lisp,
+	* src/package.lisp:
+
+	[GUI] added procedures to change the passhphrase to protect the
+	private key of a gemini certificate.
+
+2024-02-04 cage
+
+	* src/filesystem-utils.lisp,
+	* src/os-utils.lisp:
+
+	- added function 'os-utils:change-ssl-key-passphrase'.
+	- fixed 'filesystem-utils:temporary-directory'.
+
+2024-01-29 cage, lejun
+
+	* po/de.po,
+	* po/es.po,
+	* po/fr.po,
+	* po/it.po,
+	* po/pl.po,
+	* po/tinmop.pot,
+	* src/gui/client/certificates-window.lisp:
+
+	- fixed typo
+	for reference:
+	https://translate.codeberg.org/translate/tinmop/tinmop/en/?&offset=105#comments
+	Thanks to the person who reported this issue!
+	- updated italian translation.
+	Translated using Weblate (French)
+	Currently translated at 32.4% (167 of 514 strings)
+	Translation: tinmop/tinmop
+	Translate-URL:
+	https://translate.codeberg.org/projects/tinmop/tinmop/fr/
+	Merge pull request 'Translations update from Weblate' (#7) from
+	translate/tinmop:weblate-tinmop-tinmop into master
+
+2024-01-18 cage
+
+	* src/gui/client/gemlog-window.lisp,
+	* src/gui/server/public-api-gemini-gemlog.lisp,
+	* src/gui/server/public-api.lisp:
+
+	- [GUI] added contextual menu to copy  gemlogs links or mark all their
+	posts as already read.
+
+2023-12-28 cage
+
+	* src/api-client.lisp:
+
+	- added  missing space  to control  string in  the procedure  to print
+	notification.
+
+2023-12-27 cage
+
+	* po/de.po,
+	* po/es.po,
+	* po/fr.po,
+	* po/it.po,
+	* po/pl.po,
+	* po/tinmop.pot,
+	* src/api-client.lisp:
+
+	- added id of the posts the notification refers to;
+	- updated italian translation.
+
+2023-12-24 cage
+
+	* src/db.lisp,
+	* src/gui/client/main-window.lisp:
+
+	- [GUI] fixed test for checking mime-type on an image;
+	- allowed null values for preview url in post's attachments.
+	- fixxed call to 'member'.
+
+2023-12-07 cage
+
+	* src/program-events.lisp,
+	* src/tui-utils.lisp:
+
+	- fixed test for conditional macro call.
+	- removed another recursive thread locking
+	('push-downloading-behind').
+
+2023-12-02 cage
+
+	* data/scripts/generate-gemlog.lisp,
+	* src/api-client.lisp,
+	* src/gemini-viewer.lisp,
+	* src/gemini/gemini-parser.lisp,
+	* src/html-utils.lisp,
+	* src/misc-utils.lisp,
+	* src/package.lisp,
+	* src/program-events.lisp,
+	* src/tui-utils.lisp,
+	* src/ui-goodies.lisp:
+
+	- changed all recursive lock with the non-recursive type;
+	- prevented opening another connection when deleting cache;
+	- improved rendering of html blockquote.
+	- prevented opening another connection in a callback contained in
+	'status-tree->text'.
+	- added a directive just to debug error signaled from the TUI.
+	- improved generated gemini pages for the gemlog;
+	- removed another recursive thread locking.
+
 2023-11-19 cage
 
+	* ChangeLog,
+	* NEWS.org,
 	* tinmop.asd:
 
 	- increased version number.
+	- updated changelog and news file.
 
 2023-11-18 cage
 
@@ -3173,7 +3414,7 @@
 	- removed memory leak in ssl-utils:dump-certificate;
 	- added an hook to remove footnotes added by tinmop in post's reply.
 
-2022-03-27 Andrea Feletto <andrea@andreafeletto.com>, cage
+2022-03-27 Andrea Feletto , cage
 
 	* Makefile.am,
 	* Makefile.in,

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 \

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 \

etc/init.lisp

@@ -557,6 +557,10 @@
 
 (define-key "up"        #'gemini-certificate-window-go-up            *gemini-certificates-keymap*)
 
+(define-key "c"         #'gemini-change-certificate-password         *gemini-certificates-keymap*)
+
+(define-key "D"         #'clear-cached-client-tls-certificates       *gemini-certificates-keymap*)
+
 ;; gemini subscription window
 
 (define-key "C-J"       #'show-gemlog-to-screen                      *gemlog-subscription-keymap*)

src/gemini-viewer.lisp

@@ -679,6 +679,7 @@
                       (enqueue                    nil)
                       (certificate                nil)
                       (certificate-key            nil)
+                      (certificate-key-password   nil)
                       (use-cached-file-if-exists  nil)
                       (do-nothing-if-exists-in-db nil))
   (labels ((get-user-input (hide-input url prompt)
@@ -695,6 +696,7 @@
                                                                       encoded-input
                                                                       :port     port)
                                        :certificate-key    certificate-key
+                                       :certificate-key-password certificate-key-password
                                        :certificate        certificate
                                        :do-nothing-if-exists-in-db nil))))))
                  (ui:ask-string-input #'on-input-complete
@@ -717,6 +719,7 @@
                             (request new-url
                                      :enqueue         enqueue
                                      :certificate-key certificate-key
+                                     :certificate-key-password certificate-key-password
                                      :certificate     certificate))))))
                (ui:ask-string-input #'on-input-complete
                                     :priority program-events:+minimum-event-priority+
@@ -741,13 +744,42 @@
                                           parsed-iri)
              (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)
-               (request iri
-                        :enqueue                    enqueue
-                        :do-nothing-if-exists-in-db do-nothing-if-exists-in-db
-                        :certificate-key            cached-key
-                        :certificate                cached-certificate)))
+             (multiple-value-bind (cached-certificate
+                                   cached-key
+                                   cached-key-password
+                                   just-created)
+                 (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))
+                  (gemini-client:substitute-cache-certificate-password cached-certificate "")
+                  (request iri
+                           :do-nothing-if-exists-in-db do-nothing-if-exists-in-db
+                           :certificate-key            cached-key
+                           :certificate-key-password   ""
+                           :certificate                cached-certificate))
+                 (cached-key-password
+                  (request iri
+                           :do-nothing-if-exists-in-db do-nothing-if-exists-in-db
+                           :certificate-key            cached-key
+                           :certificate-key-password   cached-key-password
+                           :certificate                cached-certificate))
+                 (t
+                  (flet ((on-input-complete (password)
+                           (db-utils:with-ready-database (:connect nil)
+                             (gemini-client:save-cache-certificate-password cached-certificate
+                                                                            password)
+                             (request url
+                                      :enqueue         enqueue
+                                      :certificate-key certificate-key
+                                      :certificate-key-password password
+                                      :certificate     certificate))))
+                    (let ((error-message (format nil
+                                                 (_"a password to unlock certificate for ~a is needed: ")
+                                                 iri)))
+                      (ui:ask-string-input #'on-input-complete
+                                    :priority program-events:+minimum-event-priority+
+                                    :prompt  error-message)))))))
            (titan-upload-dispatch (url)
              (let ((parsed (iri:iri-parse url)))
                (values (gemini-client::remove-titan-parameters-from-path (uri:path parsed))
@@ -797,7 +829,9 @@
                   (gemini-client:request-dispatch url
                                                   gemini-client::dispatch-table
                                                   :certificate     certificate
-                                                  :certificate-key certificate-key)))))
+                                                  :certificate-key certificate-key
+                                                  :certificate-key-password
+                                                  certificate-key-password)))))
       (gemini-client:gemini-tofu-error (e)
         (ui:ask-input-on-tofu-error e
                                     (lambda ()

src/gemini/client.lisp

@@ -434,7 +434,8 @@
                             (port  +gemini-default-port+)
                             (fragment nil)
                             (client-certificate nil)
-                            (certificate-key    nil))
+                            (certificate-key    nil)
+                            (certificate-key-password nil))
   (let* ((iri (make-gemini-iri (idn:host-unicode->ascii host)
                                (percent-encode-path path)
                                :query    (percent-encode-query query)
@@ -452,6 +453,8 @@
                (ssl-stream   (cl+ssl:make-ssl-client-stream stream
                                                             :certificate     client-certificate
                                                             :key             certificate-key
+                                                            :password
+                                                            certificate-key-password
                                                             :external-format nil ; unsigned byte 8
                                                             :unwrap-stream-p t
                                                             :verify          nil
@@ -476,7 +479,11 @@
                                        "received an unknown response from server ~s ~a ~s ~s"
                                        iri status code-description meta))))
 
-(defun start-titan-request (url no-parameters-path data mime-type size token &key (certificate nil) (certificate-key nil))
+(defun start-titan-request (url no-parameters-path data mime-type size token
+                            &key
+                              (certificate nil)
+                              (certificate-key nil)
+                              (certificate-key-password))
   (multiple-value-bind (actual-iri host path query port)
       (displace-iri (iri:iri-parse url))
     (declare (ignore actual-iri))
@@ -489,10 +496,11 @@
                                         size
                                         token
                                         data
-                                        :query              query
-                                        :port               port
-                                        :certificate-key    certificate-key
-                                        :client-certificate certificate)
+                                        :query                    query
+                                        :port                     port
+                                        :certificate-key          certificate-key
+                                        :certificate-key-password certificate-key-password
+                                        :client-certificate       certificate)
          (close-ssl-socket socket)
          (values status description meta response socket)))
       ((null mime-type)
@@ -503,7 +511,8 @@
 (defun request-dispatch (url manage-functions
                          &key
                            (certificate     nil)
-                           (certificate-key nil))
+                           (certificate-key nil)
+                           (certificate-key-password nil))
   (flet ((make-titan-request ()
            (multiple-value-bind (no-parameters-path titan-data size mime token)
                (funcall (getf manage-functions :titan-upload
@@ -521,7 +530,8 @@
                                   size
                                   token
                                   :certificate     certificate
-                                  :certificate-key certificate-key))))
+                                  :certificate-key certificate-key
+                                  :certificate-key-password certificate-key-password))))
     (let ((parsed-iri (iri:iri-parse url)))
       (multiple-value-bind (actual-iri host path query port)
           (displace-iri parsed-iri)
@@ -530,11 +540,12 @@
                 (make-titan-request)
                 (gemini-client:request host
                                        path
-                                       :certificate-key    certificate-key
-                                       :client-certificate certificate
-                                       :query              query
-                                       :port               port
-                                       :fragment           nil))
+                                       :certificate-key          certificate-key
+                                       :certificate-key-password certificate-key-password
+                                       :client-certificate       certificate
+                                       :query                    query
+                                       :port                     port
+                                       :fragment                 nil))
           (flet ((call-appropriate-function (response-type)
                    (funcall (getf manage-functions
                                   response-type
@@ -606,10 +617,10 @@
 (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)
@@ -627,22 +638,58 @@
                         (strcat (os-utils:cached-file-path (to-s id))
                                 fs:*directory-sep* os-utils:+ssl-key-name+))))))))))
 
-(defun fetch-cached-certificate (url)
-  (let ((certificate nil)
-        (key         nil))
-    (multiple-value-bind (certificate-cache key-cache)
-        (tls-cert-find url)
-      (if (and certificate-cache
-               key-cache)
-          (setf certificate certificate-cache
-                key         key-cache)
-          (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))))
+(defparameter *client-key-passwords-db* '())
+
+(defparameter *client-key-passwords-db-lock* (make-lock))
+
+(defun-w-lock save-cache-certificate-password (certificate-path password)
+    *client-key-passwords-db-lock*
+  (setf *client-key-passwords-db*
+        (acons certificate-path password *client-key-passwords-db*)))
+
+(defun-w-lock retrieve-cached-certificate-password (certificate-path)
+    *client-key-passwords-db-lock*
+  (cdr (assoc certificate-path *client-key-passwords-db* :test #'string=)))
+
+;; this  code is  useless as  pushing  an existing  key will  prevents
+;; `assoc' to retrieve  the older entry, but for  consistence has been
+;; added anyway
+(defun-w-lock remove-cached-certificate-password (certificate-path)
+    *client-key-passwords-db-lock*
+  (setf *client-key-passwords-db*
+        (remove-if (lambda (a)
+                     (string= (car a) certificate-path))
+                   *client-key-passwords-db*)))
+
+(defun-w-lock clear-cache-certificate-password ()
+    *client-key-passwords-db-lock*
+  (setf *client-key-passwords-db* '()))
+
+(defun substitute-cache-certificate-password (certificate-path new-password)
+  (remove-cached-certificate-password certificate-path)
+  (save-cache-certificate-password certificate-path new-password))
+
+(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))
 

src/gemini/dummy-server.lisp

@@ -31,38 +31,50 @@ and  key   stored  in  the   file  pointed  by  the   filesystem  path
             "generated certificate and private key in ~s ~s respectively~%"
             certificate
             key)
-    (let ((server (usocket:socket-listen "127.0.0.1" port :element-type '(unsigned-byte 8))))
-      (format t "SSL server listening on port ~d~%" port)
-      (unwind-protect
-           (labels ((get-data ()
-                      (let* ((client-socket (usocket:socket-accept server))
-                             (client-stream (usocket:socket-stream client-socket)))
-                        (format t "opening socket~%")
-                        (let ((ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-peer+
-                                                        :verify-callback 'no-verify)))
-                          (cl+ssl:with-global-context (ctx :auto-free-p t)
-                            (let* ((stream (cl+ssl:make-ssl-server-stream client-stream
-                                                                          :external-format
-                                                                          nil
-                                                                          :certificate
-                                                                          certificate
-                                                                          :key
-                                                                          key))
-                                   (client-cert-fingerprint (x509:certificate-fingerprint stream)))
-                              (let* ((data    (misc:read-line-into-array stream))
-                                     (request (text-utils:trim-blanks (text-utils:to-s data))))
-                                (format t
-                                        "request ~s fingerprint ~a~%"
-                                        request
-                                        client-cert-fingerprint)
-                                (when (null client-cert-fingerprint)
-                                  (let ((response (format nil
-                                                          "~a please provide a certificate~a~a"
-                                                          (code gemini-client::+60+)
-                                                          #\return #\newline)))
-                                  (write-sequence (text-utils:string->octets response)
-                                                  stream)
-                                    (close stream)
-                                    (get-data))))))))))
-             (get-data))
-        (usocket:socket-close server)))))
+    (let ((server (usocket:socket-listen "127.0.0.1" port :element-type '(unsigned-byte 8)))
+          (client-cert-fingerprint nil))
+          (format t "SSL server listening on port ~d~%" port)
+      (labels ((get-data ()
+                 (format t "start~%")
+                 (let* ((client-socket (usocket:socket-accept server)))
+                   (format t "accepted ~a~%" client-socket)
+                   (make-thread (lambda ()
+                                  (let ((client-stream (usocket:socket-stream client-socket)))
+                                    (format t "opening socket~%")
+                                    (let ((ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-peer+
+                                                                    :verify-callback 'no-verify)))
+                                      (cl+ssl:with-global-context (ctx :auto-free-p t)
+                                        (let* ((stream (cl+ssl:make-ssl-server-stream client-stream
+                                                                                      :external-format
+                                                                                      nil
+                                                                                      :certificate
+                                                                                      certificate
+                                                                                      :key
+                                                                                      key)))
+                                          (setf client-cert-fingerprint (x509:certificate-fingerprint stream))
+                                          (let* ((data    (misc:read-line-into-array stream))
+                                                 (request (text-utils:trim-blanks (text-utils:to-s data))))
+                                            (format t
+                                                    "request ~s fingerprint ~a~%"
+                                                    request
+                                                    client-cert-fingerprint)
+                                            (if (null client-cert-fingerprint)
+                                                (let ((response (format nil
+                                                                        "~a please provide a certificate~a~a"
+                                                                        (code gemini-client::+60+)
+                                                                        #\return #\newline)))
+                                                  (format t "sending: ~a~%" response)
+                                                  (write-sequence (text-utils:string->octets response)
+                                                                  stream)
+                                                  (close stream)
+                                                  (get-data))
+                                                (let ((response (format nil
+                                                                        "~a text/gemini~a~a#OK~%"
+                                                                        (code gemini-client::+20+)
+                                                                        #\return #\newline)))
+                                                  (format t "sending: ~a~%" response)
+                                                  (write-sequence (text-utils:string->octets response)
+                                                                  stream)
+                                                  (close stream)
+                                                  (get-data)))))))))))))
+        (loop (get-data))))))

src/gemini/package.lisp

@@ -198,6 +198,11 @@
    :request-dispatch
    :with-request-dispatch-table
    :fetch-cached-certificate
+   :retrieve-cached-certificate-password
+   :save-cache-certificate-password
+   :remove-cached-certificate-password
+   :clear-cache-certificate-password
+   :substitute-cache-certificate-password
    :build-redirect-iri
    :slurp-gemini-url))
 

src/gemini/titan.lisp

@@ -62,7 +62,9 @@
               (get-value +titan-token-key+)))))
 
 (defgeneric titan-request (host path mime-type size token data
-                           &key query port fragment client-certificate certificate-key))
+                           &key
+                           query port fragment client-certificate certificate-key
+                           certificate-key-password))
 
 (defmethod titan-request (host path mime-type (size integer) token (data string)
                           &key
@@ -70,7 +72,8 @@
                             (port  +gemini-default-port+)
                             (fragment nil)
                             (client-certificate nil)
-                            (certificate-key    nil))
+                            (certificate-key    nil)
+                            (certificate-key-password nil))
   (flex:with-input-from-sequence (stream (text-utils:string->octets data))
     (titan-request host
                    path
@@ -82,7 +85,8 @@
                    :port               port
                    :fragment           fragment
                    :client-certificate client-certificate
-                   :certificate-key    certificate-key)))
+                   :certificate-key    certificate-key
+                   :certificate-key-password certificate-key-password)))
 
 (defmethod titan-request (host path mime-type (size integer) token (data pathname)
                           &key
@@ -90,7 +94,8 @@
                             (port  +gemini-default-port+)
                             (fragment nil)
                             (client-certificate nil)
-                            (certificate-key    nil))
+                            (certificate-key    nil)
+                            (certificate-key-password nil))
   (with-open-file (stream
                    data
                    :direction         :input
@@ -106,7 +111,8 @@
                    :port               port
                    :fragment           fragment
                    :client-certificate client-certificate
-                   :certificate-key    certificate-key)))
+                   :certificate-key    certificate-key
+                   :certificate-key-password certificate-key-password)))
 
 (defmethod titan-request (host path mime-type (size integer) token (data stream)
                           &key
@@ -114,7 +120,8 @@
                             (port  +gemini-default-port+)
                             (fragment nil)
                             (client-certificate nil)
-                            (certificate-key    nil))
+                            (certificate-key    nil)
+                            (certificate-key-password nil))
   (let* ((iri (make-gemini-iri (idn:host-unicode->ascii host)
                                (strcat (percent-encode-path path)
                                        (make-titan-parameters mime-type
@@ -139,6 +146,8 @@
                                                             :external-format nil ; unsigned byte 8
                                                             :unwrap-stream-p t
                                                             :verify          nil
+                                                            :password
+                                                            certificate-key-password
                                                             :hostname        ssl-hostname))
                (request    (format nil "~a~a~a" iri #\return #\newline))
                (cert-hash  (crypto-shortcuts:sha512 (x509:dump-certificate ssl-stream))))

src/gui/client/certificates-window.lisp

@@ -45,14 +45,15 @@
 (defun delete-certificates-clsr (certificate-frame)
   (lambda ()
     (a:when-let* ((selections (gui:treeview-get-selection (gui-goodies: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-client-certificate
-                               1
-                               url))
-          (let ((new-rows (all-rows)))
-            (resync-rows certificate-frame new-rows)))))))
+      (when (gui-goodies:confirm-deletion certificate-frame (length selections))
+        (loop for selection in selections do
+          (let ((url (gui:id selection)))
+            (ev:with-enqueued-process-and-unblock ()
+              (comm:make-request :gemini-delete-client-certificate
+                                 1
+                                 url))
+            (let ((new-rows (all-rows)))
+              (resync-rows certificate-frame new-rows))))))))
 
 (defun contextual-menu-clrs (treeview-widget)
   (labels ((row-values ()
@@ -69,25 +70,7 @@
                (second row-values)))
            (change-passphrase ()
              (a:when-let ((file-path (key-path)))
-               (handler-case
-                   (multiple-value-bind (old-password new-password)
-                       (gui-mw:change-password-dialog treeview-widget
-                                                      (_ "Change password")
-                                                      (_ "Change the password of the certificate")
-                                                      (_ "Old password")
-                                                      (_ "New password")
-                                                      (_ "Repeat new password")
-                                                      (_ "password and confirmation does not match")
-                                                      :button-message (_ "OK"))
-                     (os-utils:change-ssl-key-passphrase file-path
-                                                         old-password
-                                                         new-password)
-                     (gui-goodies:info-dialog treeview-widget
-                                              (format nil
-                                                      (_ "Password changed for key")
-                                                      file-path)))
-                 (error (e)
-                   (gui-goodies:error-dialog treeview-widget (format nil "~a" e))))))
+               (client-main-window::change-client-certificate-key-passphrase treeview-widget file-path)))
            (copy-key-path ()
              (a:when-let ((file-path (key-path)))
                (os-utils:copy-to-clipboard file-path)

src/gui/client/gui-goodies.lisp

@@ -97,26 +97,8 @@
        (gui:with-hourglass ,(list root-widget)
          ,@body))))
 
-(defun password-dialog (parent title message &key (button-message "OK"))
-  (let ((res nil))
-    (gui:with-modal-toplevel (toplevel :title title)
-      (gui:transient toplevel parent)
-      (let* ((widget    (make-instance 'gui-mw:password-entry
-                                       :show-password nil
-                                       :master        toplevel))
-             (label     (make-instance 'gui:label
-                                       :master toplevel
-                                       :text   message))
-             (ok-button (make-instance 'gui:button
-                                       :text   button-message
-                                       :master toplevel
-                                       :command (lambda ()
-                                                  (setf res (gui-mw:secret-string widget))
-                                                  (gui:exit-from-modal-toplevel toplevel)))))
-        (gui:grid label     0 0 :sticky :news)
-        (gui:grid widget    1 0 :sticky :news)
-        (gui:grid ok-button 1 1 :sticky :news)))
-    res))
+(defun password-dialog (parent title message &key (button-message (_ "OK")))
+  (gui-mw:password-input-dialog parent title message :ok-button-label button-message))
 
 (defclass table-frame (gui:frame)
   ((tree

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+))))

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
@@ -406,6 +418,17 @@
                                                      ev:+maximum-event-priority+
                                                      iri)
                (slurp-iri main-window iri)))
+            ((= status-code
+                comm:+certificate-password-not-found-error-status-code+)
+             (let* ((certificate-path meta)
+                    (message  (format nil
+                                      (_ "Provide the password to unlock certificate for ~a")
+                                      iri))
+                    (password (gui-goodies::password-dialog (gui:root-toplevel)
+                                                            (_ "Unlock certificate")
+                                                            message)))
+               (gemini-client:save-cache-certificate-password certificate-path password)
+               (slurp-iri main-window iri)))
             ((or (gemini-client:header-temporary-failure-p   status-code)
                  (gemini-client:header-permanent-failure-p   status-code)
                  (gemini-client:header-certificate-failure-p status-code))
@@ -1089,6 +1112,24 @@ local file paths."
            (render-gemtext-string main-window error-gemtext)
            (ev:with-enqueued-process-and-unblock ()
              (inline-all-images main-window))))
+        ((= status-code
+            comm:+certificate-password-not-found-error-status-code+)
+         (let* ((certificate-path meta)
+                (message  (format nil
+                                  (_ "Provide the password to unlock certificate for ~a")
+                                  iri))
+                (password (gui-goodies::password-dialog (gui:root-toplevel)
+                                                        (_ "Unlock certificate")
+                                                        message))
+                (actual-password (if (string-empty-p password)
+                                     ""
+                                     password)))
+           (cev:enqueue-request-and-wait-results :gemini-save-certificate-key-password
+                                                 1
+                                                 ev:+maximum-event-priority+
+                                                 certificate-path
+                                                 actual-password)
+           (start-stream-iri iri main-window use-cache status)))
         ((gemini-client:header-redirect-p status-code)
          (when (gui:ask-yesno (format nil (_ "Follow redirection to ~a?") meta)
                               :title (_ "Redirection")
@@ -1188,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*))
@@ -1200,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*))
@@ -1210,6 +1251,17 @@ 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)
+  (gui:configure (certificate-button (tool-bar main-window)) :state :normal)
+  (set-certificate-button-image main-window icons:*profile*))
+
+(defun set-certificate-button-inactive (main-window)
+  (gui:configure (certificate-button (tool-bar main-window)) :state :disabled)
+  (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
@@ -1252,6 +1304,39 @@ local file paths."
                                                      main-window))
           (print-info-message (_ "Tour is terminated") :bold t)))))
 
+(defun change-client-certificate-key-passphrase (parent-widget key-path)
+  (handler-case
+      (multiple-value-bind (old-password new-password)
+          (gui-mw:change-password-dialog parent-widget
+                                         (_ "Change password")
+                                         (_ "Change the password of the certificate")
+                                         (_ "Old password")
+                                         (_ "New password")
+                                         (_ "Repeat new password")
+                                         (_ "password and confirmation does not match")
+                                         :button-message (_ "OK"))
+        (os-utils:change-ssl-key-passphrase key-path
+                                            old-password
+                                            new-password)
+        (cev:enqueue-request-and-wait-results :gemini-clear-certificate-password-db
+                                              1
+                                              ev:+standard-event-priority+)
+        (gui-goodies:info-dialog parent-widget
+                                 (format nil
+                                         (_ "Password changed for key ~a")
+                                         key-path)))
+    (error (e)
+      (gui-goodies:error-dialog parent-widget (format nil "~a" e)))))
+
+(defun change-client-certificate-passphrase-clsr (main-window)
+  (lambda ()
+    (a:when-let ((key-path
+                  (cev:enqueue-request-and-wait-results :gemini-url-certificate-keypath
+                                                        1
+                                                        ev:+standard-event-priority+
+                                                        (get-address-bar-text main-window))))
+      (change-client-certificate-key-passphrase main-window key-path))))
+
 (defun setup-main-window-events (main-window)
   (with-accessors ((tool-bar       tool-bar)
                    (toc-frame      toc-frame)
@@ -1261,6 +1346,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)
@@ -1282,6 +1368,8 @@ local file paths."
         (setf (gui:command reload-button)        (reload-iri-clsr main-window))
         (setf (gui:command back-button)          (back-iri-clsr main-window))
         (setf (gui:command up-button)            (up-iri-clsr main-window))
+        (setf (gui:command certificate-button)
+              (change-client-certificate-passphrase-clsr main-window))
         (setf (gui:command bookmark-button)      (toggle-bookmark-iri-clsr main-window))
         (setf (gui:command tour-button)          (tour-visit-next-iri-clsr main-window))
         (setf (gui:command subscribe-button)     (toggle-subscribtion-iri-clsr main-window))
@@ -1292,6 +1380,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)
@@ -1301,13 +1390,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
@@ -1324,13 +1414,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)
@@ -1757,6 +1848,7 @@ local file paths."
       (initialize-keybindings main-frame (gui:inner-text (gemtext-widget main-frame)))
       (initialize-keybindings main-frame (gui:root-toplevel))
       (gui-goodies:gui-resize-grid-all gui-goodies:*toplevel*)
+      (set-certificate-button-inactive main-frame)
       (gui:wait-complete-redraw)
       (when (string-not-empty-p starting-iri)
         (handler-case

src/gui/client/titan-window.lisp

@@ -89,7 +89,8 @@
                                      1
                                      (to-s url)
                                      nil
-                                     titan-data)
+                                     titan-data
+                                     nil)
                   (client-main-window::print-info-message (_ "Data uploaded")))))))))))
 
 (defmethod initialize-instance :after ((object titan-frame) &key (url "") &allow-other-keys)

src/gui/server/public-api-gemini-certificates.lisp

@@ -63,10 +63,29 @@
                (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))
         (error (format nil (_ "~s is not a valid gemini address") uri)))))
+
+(defun gemini-save-certificate-key-password (certificate-path password)
+  (gemini-client:save-cache-certificate-password certificate-path password)
+  t)
+
+(defun gemini-url-certificate-keypath (url)
+  (multiple-value-bind (x keypath)
+      (gemini-client:fetch-cached-certificate url :if-does-not-exist nil)
+    (declare (ignore x))
+    keypath))
+
+(defun gemini-clear-certificate-password-db ()
+  (gemini-client:clear-cache-certificate-password))
+
+(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))

src/gui/server/public-api-gemini-stream.lisp

@@ -19,7 +19,9 @@
 
 (defclass iri-complete-response (box) ())
 
-(a:define-constant +tofu-error-status-code+ -1 :test #'=)
+(a:define-constant +tofu-error-status-code+                           -1 :test #'=)
+
+(a:define-constant +certificate-password-not-found-error-status-code+ -2 :test #'=)
 
 (defun debug-gemini-gui (&rest data)
   (apply #'gemini-client:debug-gemini (append (list (strcat "[gui] " (first data))
@@ -185,6 +187,7 @@
                               (titan-data                 nil)
                               (certificate                nil)
                               (certificate-key            nil)
+                              (certificate-key-password   nil)
                               (use-cached-file-if-exists  nil)
                               (do-nothing-if-exists-in-db nil))
   (labels ((redirect-dispatch (status code-description meta response socket iri parsed-iri)
@@ -208,12 +211,34 @@
                                           parsed-iri)
              (declare (ignore status code-description response socket meta parsed-iri))
              (debug-gemini-gui "response requested certificate")
-             (multiple-value-bind (cached-certificate cached-key)
-                 (gemini-client:fetch-cached-certificate iri)
-               (%gemini-request iri
-                                :do-nothing-if-exists-in-db do-nothing-if-exists-in-db
-                                :certificate-key            cached-key
-                                :certificate                cached-certificate)))
+             (multiple-value-bind (cached-certificate
+                                   cached-key
+                                   cached-key-password
+                                   just-created)
+                 (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))
+                  (gemini-client:substitute-cache-certificate-password cached-certificate "")
+                  (%gemini-request iri
+                                   :do-nothing-if-exists-in-db do-nothing-if-exists-in-db
+                                   :certificate-key            cached-key
+                                   :certificate-key-password   ""
+                                   :certificate                cached-certificate))
+                 (cached-key-password
+                  (%gemini-request iri
+                                   :do-nothing-if-exists-in-db do-nothing-if-exists-in-db
+                                   :certificate-key            cached-key
+                                   :certificate-key-password   cached-key-password
+                                   :certificate                cached-certificate))
+                 (t
+                  (let ((error-message (format nil
+                                               (_"a password to unlock certificate for ~a is needed")
+                                               iri)))
+                    (make-gemini-response +certificate-password-not-found-error-status-code+
+                                          error-message
+                                          cached-certificate
+                                          iri))))))
            (titan-upload-dispatch (url)
              (multiple-value-bind (no-parameters-path mime size token)
                  (gemini-client::parse-titan-parameters (uri:path (iri:iri-parse url)))
@@ -260,10 +285,15 @@
                                          do-nothing-if-exists-in-db))))
                 (progn
                   (debug-gemini-gui "ignoring cache for ~a" actual-iri)
-                  (ignore-errors (gemini-remove-stream actual-iri))
+                  (handler-case
+                      (gemini-remove-stream actual-iri)
+                    (error (e)
+                      (debug-gemini-gui "error removing stream ~a" e)))
                   (gemini-client:request-dispatch url
                                                   gemini-client::dispatch-table
                                                   :certificate     certificate
+                                                  :certificate-key-password
+                                                  certificate-key-password
                                                   :certificate-key certificate-key)))))
       (gemini-client:gemini-tofu-error (e)
         (make-gemini-response +tofu-error-status-code+
@@ -278,8 +308,12 @@
                               (gemini-client:meta e)
                               url))
       (error (e)
+        (when certificate
+          (gemini-client:remove-cached-certificate-password certificate))
         (error (_ "Error getting ~s: ~a") url e))
       (condition (c)
+        (when certificate
+          (gemini-client:remove-cached-certificate-password certificate))
         (error (_ "Error getting ~s: ~a") url c)))))
 
 (defun gemini-request (iri use-cache titan-data)

src/gui/server/public-api.lisp

@@ -89,6 +89,18 @@
               "uri"       0
               "cert-file" 1
               "key-file"  2)
+     (gen-rpc "gemini-save-certificate-key-password"
+              '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-url-certificate-keypath"
+              'gemini-url-certificate-keypath
+              "url" 0)
+     (gen-rpc "gemini-clear-certificate-password-db"
+              'gemini-clear-certificate-password-db)
      (gen-rpc "gemini-table-of-contents"
               'gemini-table-of-contents
               "iri" 0

src/kami/client.lisp

@@ -17,7 +17,8 @@
 
 (defmacro with-open-ssl-stream ((ssl-stream socket host port
                                  client-certificate
-                                 certificate-key)
+                                 certificate-key
+                                 certificate-key-password)
                                 &body body)
   (alexandria:with-gensyms (tls-context socket-stream ssl-hostname)
     `(let ((,tls-context (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-none+)))
@@ -29,6 +30,7 @@
                   (cl+ssl:make-ssl-client-stream ,socket-stream
                                                  :certificate     ,client-certificate
                                                  :key             ,certificate-key
+                                                 :password        ,certificate-key-password
                                                  :external-format nil ; unsigned byte 8
                                                  :unwrap-stream-p t
                                                  :verify          nil
@@ -215,8 +217,8 @@
 
 (defun generate-filesystem-window-handlers (path host port
                                             query fragment
-                                            client-certificate client-key)
-  (with-open-ssl-stream (stream socket host port client-certificate client-key)
+                                            client-certificate client-key certificate-key-password)
+  (with-open-ssl-stream (stream socket host port client-certificate client-key certificate-key-password)
     (let* ((9p:*tag*           10)
            (9p:*fid*           1)
            (9p:*messages-sent* '())
@@ -242,8 +244,8 @@
 
 (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)
+    (multiple-value-bind (cached-certificate cached-key cached-key-password)
+        (gemini-client:fetch-cached-certificate kami-iri :if-does-not-exist nil)
       (multiple-value-bind (actual-iri host path query port fragment scheme)
           (gemini-client:displace-iri parsed-iri)
         (declare (ignore actual-iri scheme))
@@ -253,4 +255,5 @@
                                                   query
                                                   fragment
                                                   cached-certificate
-                                                  cached-key)))))
+                                                  cached-key
+                                                  cached-key-password)))))

src/os-utils.lisp

@@ -184,6 +184,17 @@
                          keypath
                          output-string)))))))))
 
+(defun ssl-key-has-empty-password-p (key-path)
+  (with-input-from-string (passphrase-stream (format nil "~%"))
+    (let* ((cmd-args (format nil "rsa -passin stdin -noout -text -in ~a" key-path))
+           (process (run-external-program +openssl-bin+
+                                          (text-utils:split-words cmd-args)
+                                          :input  passphrase-stream
+                                          :output nil
+                                          :error  nil
+                                          :wait t)))
+      (process-exit-success-p process))))
+
 (defun send-to-pipe (data program-and-args)
   (croatoan:end-screen)
   (with-input-from-string (stream data)

src/package.lisp

@@ -409,6 +409,7 @@
    :cached-file-path
    :generate-ssl-certificate
    :change-ssl-key-passphrase
+   :ssl-key-has-empty-password-p
    :send-to-pipe
    :open-link-with-program
    :open-resource-with-external-program
@@ -3092,6 +3093,7 @@
    :open-gemini-address
    :net-address-history-back
    :delete-shown-post
+   :clear-cached-client-tls-certificates
    :address-go-back-in-path
    :address-go-root-path
    :gemini-view-source
@@ -3101,6 +3103,7 @@
    :gemini-certificate-window-move
    :gemini-certificate-window-go-down
    :gemini-certificate-window-go-up
+   :gemini-change-certificate-password
    :gemini-close-certificate-window
    :gemini-delete-certificate
    :gemini-streams-window-up
@@ -3284,6 +3287,7 @@
                     (:gw   :gemini-viewer))
   (:export
    :+tofu-error-status-code+
+   :+certificate-password-not-found-error-status-code+
    :gemini-window
    :metadata
    :init-gemini-window
@@ -3399,11 +3403,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
@@ -3428,7 +3433,9 @@
    :*gemlog-subscribe*
    :*gemlog-unsubscribe*
    :*inline-images*
-   :*text*))
+   :*text*
+   :*profile*
+   :*profile-disabled*))
 
 (defpackage :validation
   (:use

src/ui-goodies.lisp

@@ -1798,8 +1798,7 @@ authenticate this client on a gemini server."
   "Delete a gemini  certificate, this could makes all user data on the
 server unreachable as the server will not be able to identify the client.
 
-Of course  could be possible to generate a new identity (i.e. a new
-certificate).
+Often would be possible to generate a new identity (i.e. a new certificate).
 "
   (flet ((on-input-complete (answer)
            (when (boolean-input-accepted-p answer)
@@ -1819,6 +1818,45 @@ certificate).
                       :prompt      (_ "Delete this certificate? [Y/n] ")
                       :complete-fn #'complete:complete-always-empty)))
 
+(defun gemini-change-certificate-password ()
+  "Change the password for an existing TLS gemini client certificate."
+  (when-let* ((selected-row (line-oriented-window:selected-row-fields
+                             *gemini-certificates-window*))
+              (cache-key    (db:row-cache-key selected-row))
+              (key-path     (nth-value 1
+                                       (gemini-client::tls-cert-find cache-key))))
+    (let ((old-password     "")
+          (new-password     "")
+          (confirm-password ""))
+      (labels ((on-confirm-password-complete (confirm-passwd)
+                 (when confirm-passwd
+                   (setf confirm-password confirm-passwd))
+                 (if (string= confirm-password
+                              new-password)
+                     (tui:with-notify-errors
+                       (os-utils:change-ssl-key-passphrase key-path old-password new-password)
+                       (info-message (format nil (_ "Password changed for key ~a") key-path)))
+                     (error-message (_ "password and confirmation does not match"))))
+               (on-new-password-complete (new-passwd)
+                 (when new-passwd
+                   (setf new-password new-passwd))
+                 (ask-string-input #'on-confirm-password-complete
+                                   :prompt      (_ "confirm password: ")
+                                   :complete-fn #'complete:complete-always-empty
+                                   :hide-input  t))
+               (on-old-password-complete (old-passwd)
+                 (when old-passwd
+                   (setf old-password old-passwd))
+                 (ask-string-input #'on-new-password-complete
+                                   :prompt      (_ "new password: ")
+                                   :complete-fn #'complete:complete-always-empty
+                                   :hide-input  t)))
+        (ask-string-input #'on-old-password-complete
+                          :prompt      (_ "old password: ")
+                          :complete-fn #'complete:complete-always-empty
+                          :hide-input  t)))))
+
+
 (defun gemini-certificate-information ()
   (when-let* ((selected-row (line-oriented-window:selected-row-fields
                              *gemini-certificates-window*))
@@ -3018,25 +3056,52 @@ printed, on the main window."
       (filesystem-tree-window:init actual-root)
       (focus-to-filesystem-explorer-window))))
 
+(defun init-kami-window (url handlers)
+  (if handlers
+      (let* ((path          (uri:path (iri:iri-parse url)))
+             (path-to-dir-p (fs:path-referencing-dir-p path))
+             (init-path (if path-to-dir-p
+                            path
+                            (fs:parent-dir-path path))))
+        (filesystem-tree-window:init init-path handlers)
+        (if path-to-dir-p
+            (focus-to-filesystem-explorer-window)
+            (progn
+              (%file-explorer-download-path path)
+              (file-explorer-close-path))))
+      (error-message (format nil
+                             (_ "~s is not a valid kami address")
+                             url))))
+
 (defun open-kami-address (url)
-  (with-enqueued-process ()
-    (with-notify-kami-error
-      (let ((handlers (kami:iri->filesystem-window-handlers url)))
-        (if handlers
-            (let* ((path          (uri:path (iri:iri-parse url)))
-                   (path-to-dir-p (fs:path-referencing-dir-p path))
-                   (init-path (if path-to-dir-p
-                                  path
-                                  (fs:parent-dir-path path))))
-              (filesystem-tree-window:init init-path handlers)
-              (if path-to-dir-p
-                  (focus-to-filesystem-explorer-window)
+  (flet ((init-window ()
+           (let ((handlers (kami:iri->filesystem-window-handlers url)))
+             (init-kami-window url handlers))))
+    (with-enqueued-process ()
+      (with-notify-kami-error
+        (tui:with-notify-errors
+          (db-utils:with-ready-database (:connect nil)
+            (multiple-value-bind (cached-certificate cached-key cached-key-password just-created)
+                (gemini-client:fetch-cached-certificate url :if-does-not-exist :create)
+              (if (or just-created
+                      cached-key-password
+                      (os-utils:ssl-key-has-empty-password-p cached-key))
+                  (init-window)
                   (progn
-                    (%file-explorer-download-path path)
-                    (file-explorer-close-path))))
-            (error-message (format nil
-                                   (_ "~s is not a valid kami address")
-                                   url)))))))
+                    (flet ((on-input-complete (password)
+                             (db-utils:with-ready-database (:connect nil)
+                               (tui:with-notify-errors
+                                 (gemini-client:save-cache-certificate-password cached-certificate
+                                                                                password)
+                                 (let ((handlers (kami:iri->filesystem-window-handlers url)))
+                                   (init-kami-window url handlers))))))
+                      (let ((error-message
+                              (format nil
+                                      (_"a password to unlock certificate for ~a is needed: ")
+                                      url)))
+                        (ui:ask-string-input #'on-input-complete
+                                             :priority program-events:+minimum-event-priority+
+                                             :prompt  error-message))))))))))))
 
 (defun file-explorer-expand-path ()
   (when-let* ((win    *filesystem-explorer-window*)
@@ -3521,3 +3586,8 @@ gemini client certificates!)."
   (thread-window:mark-selected-message-to-delete *thread-window*
                                                  :move-down-selected-message nil)
   (focus-to-thread-window))
+
+(defun clear-cached-client-tls-certificates ()
+  "Delete all the password for TLS certificates that has been cached in memory."
+  (gemini-client:clear-cache-certificate-password)
+  (info-message (_ "Cache for TLS passord cleared")))

tinmop.asd

@@ -199,7 +199,7 @@
                              (:file "idn-tests")
                              (:file "json-rpc2-tests")))))
 
-;;(push :debug-mode            *features*)
-;;(push :debug-sql             *features*)
-;;(push :debug-gemini-request  *features*)
-;;(push :debug-json-rpc        *features*)
+;; (push :debug-mode            *features*)
+;; (push :debug-sql             *features*)
+;; (push :debug-gemini-request  *features*)
+;; (push :debug-json-rpc        *features*)