cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

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

This commit is contained in:
cage 2024-02-14 14:41:45 +01:00
parent 1a5af73415
commit f067dc2ee3
9 changed files with 127 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
src/gemini/client.lisp
View File

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

4
src/gemini/package.lisp
View File

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

22
src/gui/client/gui-goodies.lisp
View File

@ -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

29
src/gui/client/main-window.lisp
View File

@ -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")

4
src/gui/server/public-api-gemini-certificates.lisp
View File

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

40
src/gui/server/public-api-gemini-stream.lisp
View File

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

4
src/gui/server/public-api.lisp
View File

@ -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

11
src/os-utils.lisp
View File

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

2
src/package.lisp
View File

@ -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