- [GUI] added procedures to manage passwords for client TLS certificates.

src/gemini/client.lisp

@@ -638,22 +638,54 @@
                         (strcat (os-utils:cached-file-path (to-s id))
                                 fs:*directory-sep* os-utils:+ssl-key-name+))))))))))
 
+(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 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)
-  (let ((certificate nil)
+  (let ((certificate  nil)
-        (key         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
+          (setf certificate  certificate-cache
-                key         key-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))))
+      (values certificate
+              key
+              (retrieve-cached-certificate-password certificate)
+              just-created))))
 
 (defgeneric build-redirect-iri (meta iri-from))
 

src/gemini/package.lisp

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

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"))
+(defun password-dialog (parent title message &key (button-message (_ "OK")))
-  (let ((res nil))
+  (gui-mw:password-input-dialog parent title message :ok-button-label button-message))
-    (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))
 
 (defclass table-frame (gui:frame)
   ((tree

src/gui/client/main-window.lisp

@@ -406,6 +406,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 +1100,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")

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

@@ -70,3 +70,7 @@
           (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)

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,35 @@
                                           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)
+             (multiple-value-bind (cached-certificate
+                                   cached-key
+                                   cached-key-password
+                                   just-created)
                  (gemini-client:fetch-cached-certificate iri)
-               (%gemini-request iri
+               (cond
-                                :do-nothing-if-exists-in-db do-nothing-if-exists-in-db
+                 ((or just-created
-                                :certificate-key            cached-key
+                      (os-utils:ssl-key-has-empty-password-p cached-key))
-                                :certificate                cached-certificate)))
+                  (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)))
+                    (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
+                                          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)))
@@ -267,6 +293,8 @@
                   (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+

src/gui/server/public-api.lisp

@@ -89,6 +89,10 @@
               "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-table-of-contents"
               'gemini-table-of-contents
               "iri" 0

src/os-utils.lisp

@@ -184,6 +184,17 @@
                          keypath
                          output-string)))))))))
 
+(defun ssl-key-has-empty-password-p (key-path)
+  (let* ((cmd-args (format nil "rsa -noout -text -in ~a" key-path))
+         (process (run-external-program +openssl-bin+
+                                        (text-utils:split-words cmd-args)
+                                        :input  nil
+                                        :output nil
+                                        :error  :output
+                                        :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
@@ -3284,6 +3285,7 @@
                     (:gw   :gemini-viewer))
   (:export
    :+tofu-error-status-code+
+   :+certificate-password-not-found-error-status-code+
    :gemini-window
    :metadata
    :init-gemini-window