From f067dc2ee394d0c8d7a977594a8f223c08b971c6 Mon Sep 17 00:00:00 2001 From: cage Date: Wed, 14 Feb 2024 14:41:45 +0100 Subject: [PATCH] - [GUI] added procedures to manage passwords for client TLS certificates. --- src/gemini/client.lisp | 42 ++++++++++++++++--- src/gemini/package.lisp | 4 ++ src/gui/client/gui-goodies.lisp | 22 +--------- src/gui/client/main-window.lisp | 29 +++++++++++++ .../public-api-gemini-certificates.lisp | 4 ++ src/gui/server/public-api-gemini-stream.lisp | 40 +++++++++++++++--- src/gui/server/public-api.lisp | 4 ++ src/os-utils.lisp | 11 +++++ src/package.lisp | 2 + 9 files changed, 127 insertions(+), 31 deletions(-) diff --git a/src/gemini/client.lisp b/src/gemini/client.lisp index 721e82c..67d124a 100644 --- a/src/gemini/client.lisp +++ b/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) - (key nil)) + (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) + (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)))) + (values certificate + key + (retrieve-cached-certificate-password certificate) + just-created)))) (defgeneric build-redirect-iri (meta iri-from)) diff --git a/src/gemini/package.lisp b/src/gemini/package.lisp index 58959d2..3cf4387 100644 --- a/src/gemini/package.lisp +++ b/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)) diff --git a/src/gui/client/gui-goodies.lisp b/src/gui/client/gui-goodies.lisp index fa950a3..ce6cfd2 100644 --- a/src/gui/client/gui-goodies.lisp +++ b/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 diff --git a/src/gui/client/main-window.lisp b/src/gui/client/main-window.lisp index 4e35e6d..0d8251f 100644 --- a/src/gui/client/main-window.lisp +++ b/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") diff --git a/src/gui/server/public-api-gemini-certificates.lisp b/src/gui/server/public-api-gemini-certificates.lisp index fc7ea75..d809e28 100644 --- a/src/gui/server/public-api-gemini-certificates.lisp +++ b/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) diff --git a/src/gui/server/public-api-gemini-stream.lisp b/src/gui/server/public-api-gemini-stream.lisp index 5922dce..9701b7b 100644 --- a/src/gui/server/public-api-gemini-stream.lisp +++ b/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 - :do-nothing-if-exists-in-db do-nothing-if-exists-in-db - :certificate-key cached-key - :certificate cached-certificate))) + (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))) + (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+ diff --git a/src/gui/server/public-api.lisp b/src/gui/server/public-api.lisp index 3fef560..69a8078 100644 --- a/src/gui/server/public-api.lisp +++ b/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 diff --git a/src/os-utils.lisp b/src/os-utils.lisp index 327b891..13c39de 100644 --- a/src/os-utils.lisp +++ b/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) diff --git a/src/package.lisp b/src/package.lisp index dbb8c06..f9c6184 100644 --- a/src/package.lisp +++ b/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