From 269a08718c0fd4283d517a087bbb6d7c7e90db2c Mon Sep 17 00:00:00 2001 From: cage Date: Fri, 23 Oct 2020 20:57:17 +0200 Subject: [PATCH] - [gemini] implemented a draft of a client authentication (via TLS certificates). --- etc/default-theme.conf | 16 +++ etc/init.lisp | 14 +++ src/db.lisp | 37 +++++-- src/gemini-client-certificates-window.lisp | 108 +++++++++++++++++++++ src/gemini-viewer.lisp | 21 +++- src/gemini/client.lisp | 44 +++++---- src/keybindings.lisp | 3 + src/os-utils.lisp | 2 +- src/package.lisp | 38 +++++++- src/program-events.lisp | 6 ++ src/software-configuration.lisp | 18 ++++ src/specials.lisp | 3 + src/tui-utils.lisp | 8 ++ src/ui-goodies.lisp | 96 ++++++++++++++++-- tinmop.asd | 1 + 15 files changed, 371 insertions(+), 44 deletions(-) create mode 100644 src/gemini-client-certificates-window.lisp diff --git a/etc/default-theme.conf b/etc/default-theme.conf index 8275ea4..cca399f 100644 --- a/etc/default-theme.conf +++ b/etc/default-theme.conf @@ -486,6 +486,22 @@ open-gemini-stream-window.input.selected.background = black open-gemini-stream-window.input.selected.foreground = #FFB200 +# window for managing gemini certificate + +gemini-certificates-window.background = black + +gemini-certificates-window.foreground = cyan + +gemini-certificates-window.input.selected.background = cyan + +gemini-certificates-window.input.selected.foreground = black + +gemini-certificates-window.link.foreground = yellow + +gemini-certificates-window.creation-time.foreground = green + +gemini-certificates-window.access-time.foreground = green + # chats #chat list window diff --git a/etc/init.lisp b/etc/init.lisp index 5f38933..2618f4f 100644 --- a/etc/init.lisp +++ b/etc/init.lisp @@ -313,6 +313,8 @@ (define-key "d" #'gemini-open-streams-window *gemini-message-keymap*) +(define-key "c" #'gemini-open-certificates-window *gemini-message-keymap*) + ;; gemini stream window keymap (define-key "a" #'gemini-abort-download *gemini-downloads-keymap*) @@ -325,6 +327,18 @@ (define-key "C-J" #'gemini-streams-window-open-stream *gemini-downloads-keymap*) +;; gemini certificates window keymap + +(define-key "a" #'gemini-abort-download *gemini-certificates-keymap*) + +(define-key "up" #'gemini-certificate-window-go-up *gemini-certificates-keymap*) + +(define-key "down" #'gemini-certificate-window-go-down *gemini-certificates-keymap*) + +(define-key "q" #'gemini-close-certificate-window *gemini-certificates-keymap*) + +(define-key "C-J" #'gemini-delete-certificate *gemini-certificates-keymap*) + ;; tags keymap (define-key "up" #'tag-go-up *tags-keymap*) diff --git a/src/db.lisp b/src/db.lisp index 3d713cb..2defcf4 100644 --- a/src/db.lisp +++ b/src/db.lisp @@ -1725,6 +1725,14 @@ row." (gen-access-message-row label :label) +(gen-access-message-row cache-key :key) + +(gen-access-message-row cache-type :type) + +(gen-access-message-row cache-accessed-at :accessed-at) + +(gen-access-message-row cache-created-at :created-at) + (defun row-votes-count (row) (and row (db-getf row :votes-count 0))) @@ -2780,12 +2788,23 @@ than `days-in-the-past' days (default: `(swconf:config-purge-cache-days-offset)' (query (delete-from +table-gemini-tofu-cert+ (where (:= :host host))))) (defun ssl-cert-find (url) - (when-let* ((actual-text-looking-for (strcat url "%")) - (query (select :* - (from +table-cache+) - (where (:like :key - actual-text-looking-for)))) - (in-cache (fetch-single query)) - (id (getf in-cache :id))) - (strcat (os-utils:cached-file-path (to-s id)) - fs:*directory-sep* os-utils:+ssl-cert-name+))) + (when-let* ((text-looking-for (strcat url "%")) + (query (select :* + (from +table-cache+) + (where (:and (:like :key text-looking-for) + (:= :type +cache-tls-certificate-type+))))) + (in-cache (fetch-single query)) + (id (getf in-cache :id))) + (values (strcat (os-utils:cached-file-path (to-s id)) + fs:*directory-sep* os-utils:+ssl-cert-name+) + (strcat (os-utils:cached-file-path (to-s id)) + fs:*directory-sep* os-utils:+ssl-key-name+)))) + +(defun find-tls-certificates-rows (&optional (url "")) + (when-let* ((text-looking-for (strcat url "%")) + (query (select :* + (from +table-cache+) + (where (:and (:like :key text-looking-for) + (:= :type +cache-tls-certificate-type+))) + (order-by (:desc :updated-at))))) + (fetch-all-rows query))) diff --git a/src/gemini-client-certificates-window.lisp b/src/gemini-client-certificates-window.lisp new file mode 100644 index 0000000..b823ac9 --- /dev/null +++ b/src/gemini-client-certificates-window.lisp @@ -0,0 +1,108 @@ +;; tinmop: an humble gemini and pleroma client +;; Copyright (C) 2020 cage + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. +;; If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]]. + +(in-package :gemini-certificates-window) + +(defclass gemini-certificates-window (focus-marked-window + simple-line-navigation-window + title-window + border-window) + ()) + +(defmethod refresh-config :after ((object gemini-certificates-window)) + (open-attach-window:refresh-view-links-window-config object + swconf:+key-gemini-certificates-window+) + (refresh-config-sizes object swconf:+key-thread-window+) + (win-move object + (- (win-width *main-window*) + (win-width object)) + 0) + (win-move object + (- (win-width *main-window*) + (win-width object)) + 0) + object) + +(defun cache->list-item (cache-db-row &optional (attributes (tui:attribute-bold))) + (multiple-value-bind (link-fg creation-fg access-fg) + (swconf:gemini-certificates-window-colors) + (let ((creation-date (db-utils:encode-datetime-string (db:row-cache-created-at cache-db-row))) + (access-date (db-utils:encode-datetime-string (db:row-cache-accessed-at cache-db-row))) + (link (db:row-cache-key cache-db-row))) + (reduce (lambda (a b) (cat-tui-string a b :color-attributes-contagion nil)) + (list (_ "address: ") + (make-tui-string link :fgcolor link-fg :attributes attributes) + (_ " creation date: ") + (make-tui-string (db-utils:decode-date-string creation-date) + :fgcolor creation-fg :attributes attributes) + (_ " last access date: ") + (make-tui-string (db-utils:decode-date-string access-date) + :fgcolor access-fg :attributes attributes)))))) + +(defun cache->unselected-list-item (cache-db-row) + (cache->list-item cache-db-row (tui:combine-attributes (tui:attribute-bold)))) + +(defun cache->selected-list-item (cache-db-row) + (tui:tui-string->chars-string (cache->list-item cache-db-row))) + +(defmethod resync-rows-db ((object gemini-certificates-window) + &key + (redraw t) + (suggested-message-index nil)) + (with-accessors ((rows rows) + (selected-line-bg selected-line-bg) + (selected-line-fg selected-line-fg)) object + (flet ((make-rows (cache-rows bg fg) + (mapcar (lambda (cache-row) + (make-instance 'line + :normal-text (cache->unselected-list-item cache-row) + :selected-text (cache->selected-list-item cache-row) + :fields cache-row + :normal-bg fg + :normal-fg bg + :selected-bg bg + :selected-fg fg)) + cache-rows))) + (with-croatoan-window (croatoan-window object) + (setf rows (make-rows (db:find-tls-certificates-rows) + selected-line-bg + selected-line-fg)) + (when suggested-message-index + (handler-bind ((conditions:out-of-bounds + (lambda (e) + (invoke-restart 'ignore-selecting-action e)))) + (select-row object suggested-message-index))) + (when redraw + (win-clear object) + (draw object)))))) + +(defun open-gemini-certificates-window () + (let* ((low-level-window (make-croatoan-window :enable-function-keys t))) + (setf *gemini-certificates-window* + (make-instance 'gemini-certificates-window + :top-row-padding 0 + :title (_ "Generated certificates") + :single-row-height 1 + :uses-border-p t + :keybindings keybindings:*gemini-certificates-keymap* + :croatoan-window low-level-window)) + (refresh-config *gemini-certificates-window*) + (resync-rows-db *gemini-certificates-window* :redraw nil) + (when (rows *gemini-certificates-window*) + (select-row *gemini-certificates-window* 0)) + (draw *gemini-certificates-window*) + *gemini-certificates-window*)) diff --git a/src/gemini-viewer.lisp b/src/gemini-viewer.lisp index f53ace8..c02236d 100644 --- a/src/gemini-viewer.lisp +++ b/src/gemini-viewer.lisp @@ -363,6 +363,7 @@ (defun request (url &key (enqueue nil) (certificate nil) + (certificate-key nil) (do-nothing-if-exists-in-db t)) (let ((parsed-uri (quri:uri url))) (maybe-initialize-metadata specials:*message-window*) @@ -394,6 +395,17 @@ (if enqueue :streaming :running))) + (fetch-cached-certificate (actual-uri) + (let* ((certificate-and-key + (or (multiple-value-list + (db:ssl-cert-find actual-uri)) + (multiple-value-list + (gemini-client:make-client-certificate actual-uri)))) + (certificate (first certificate-and-key)) + (key (second certificate-and-key))) + (assert certificate) + (assert key) + (values certificate key))) (get-user-input (hide-input host prompt) (flet ((on-input-complete (input) (when (string-not-empty-p input) @@ -411,6 +423,7 @@ (multiple-value-bind (status code-description meta response socket) (gemini-client:request host path + :certificate-key certificate-key :client-certificate certificate :query query :port port) @@ -432,13 +445,13 @@ (_ "Redirects to ~s, follows redirect? [y/N] ") meta)))) ((gemini-client:response-certificate-requested-p status) - (let ((certificate (or (db:ssl-cert-find actual-uri) - (gemini-client:make-client-certificate actual-uri)))) - (assert certificate) + (multiple-value-bind (cached-certificate cached-key) + (fetch-cached-certificate actual-uri) (request actual-uri :enqueue enqueue :do-nothing-if-exists-in-db do-nothing-if-exists-in-db - :certificate certificate))) + :certificate-key cached-key + :certificate cached-certificate))) ((gemini-client:response-input-p status) (get-user-input nil host meta)) ((gemini-client:response-sensitive-input-p status) diff --git a/src/gemini/client.lisp b/src/gemini/client.lisp index 1a5251f..b6b5655 100644 --- a/src/gemini/client.lisp +++ b/src/gemini/client.lisp @@ -280,12 +280,15 @@ (let* ((cache-id (db:cache-put uri +cache-tls-certificate-type+)) (cert-dir (os-utils:cached-file-path (text-utils:to-s cache-id)))) (fs:make-directory cert-dir) - (os-utils:generate-ssl-certificate cert-dir))) + (multiple-value-bind (certificate key) + (os-utils:generate-ssl-certificate cert-dir) + (values certificate key)))) (defun request (host path &key (query nil) (port +gemini-default-port+) - (client-certificate nil)) + (client-certificate nil) + (certificate-key nil)) (let* ((uri (make-gemini-uri host path query port)) (ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-none+))) (when query @@ -293,21 +296,22 @@ (cl+ssl:with-global-context (ctx :auto-free-p t) (let ((socket (usocket:socket-connect host port :element-type '(unsigned-byte 8)))) (unwind-protect - (when socket - (let* ((stream (usocket:socket-stream socket)) - (ssl-stream (cl+ssl:make-ssl-client-stream stream - :certificate client-certificate - :external-format nil - :unwrap-stream-p t - :verify nil - :hostname host)) - (request (format nil "~a~a~a" uri #\return #\newline)) - (cert-hash (crypto-shortcuts:sha512 (x509:dump-certificate ssl-stream)))) - (if (not (db:tofu-passes-p host cert-hash)) - (error 'gemini-tofu-error :host host) - (progn - (write-sequence (babel:string-to-octets request) ssl-stream) - (force-output ssl-stream) - (multiple-value-bind (status description meta response) - (parse-response ssl-stream) - (values status description meta response socket))))))))))) + (when socket + (let* ((stream (usocket:socket-stream socket)) + (ssl-stream (cl+ssl:make-ssl-client-stream stream + :certificate client-certificate + :key certificate-key + :external-format nil + :unwrap-stream-p t + :verify nil + :hostname host)) + (request (format nil "~a~a~a" uri #\return #\newline)) + (cert-hash (crypto-shortcuts:sha512 (x509:dump-certificate ssl-stream)))) + (if (not (db:tofu-passes-p host cert-hash)) + (error 'gemini-tofu-error :host host) + (progn + (write-sequence (babel:string-to-octets request) ssl-stream) + (force-output ssl-stream) + (multiple-value-bind (status description meta response) + (parse-response ssl-stream) + (values status description meta response socket))))))))))) diff --git a/src/keybindings.lisp b/src/keybindings.lisp index 79b1db3..ced85ee 100644 --- a/src/keybindings.lisp +++ b/src/keybindings.lisp @@ -255,6 +255,9 @@ produces a tree and graft the latter on `existing-tree'" (defparameter *gemini-downloads-keymap* (make-starting-comand-tree) "The keymap for window that shows all gemini streams.") +(defparameter *gemini-certificates-keymap* (make-starting-comand-tree) + "The keymap for window that shows all gemini certificates.") + (defparameter *chats-list-keymap* (make-starting-comand-tree) "The keymap for window that shows all the chats.") diff --git a/src/os-utils.lisp b/src/os-utils.lisp index 1e9c041..32b8b73 100644 --- a/src/os-utils.lisp +++ b/src/os-utils.lisp @@ -72,7 +72,7 @@ (multiple-value-bind (exe args) (external-editor) (let ((actual-args (if args - (list (text-utils:split-words args)) + (text-utils:split-words args) nil))) (sb-ext:run-program exe (append actual-args diff --git a/src/package.lisp b/src/package.lisp index a45e218..f6cadba 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -785,6 +785,10 @@ :row-votes-count :row-message-reply-to-id :row-text-url + :row-cache-key + :row-cache-type + :row-cache-accessed-at + :row-cache-created-at :next-status-tree :previous-status-tree :message-tree-root-equal @@ -888,7 +892,8 @@ :cache-expired-p :tofu-passes-p :tofu-delete - :ssl-cert-find)) + :ssl-cert-find + :find-tls-certificates-rows)) (defpackage :date-formatter (:use @@ -957,6 +962,7 @@ :+key-open-attach-window+ :+key-open-message-link-window+ :+key-open-gemini-stream-window+ + :+key-gemini-certificates-window+ :+key-conversations-window+ :+key-keybindings-window+ :+key-suggestions-window+ @@ -995,6 +1001,7 @@ :gemini-h2-prefix :gemini-h3-prefix :gemini-bullet-prefix + :gemini-certificates-window-colors :signature-file-path :vote-vertical-bar :crypted-mark-value @@ -1140,6 +1147,7 @@ :*open-attach-window* :*open-message-link-window* :*gemini-streams-window* + :*gemini-certificates-window* :*chats-list-window*)) (defpackage :complete @@ -1268,6 +1276,7 @@ :chat-create-event :search-link-event :help-apropos-event + :redraw-window-event :function-event :dispatch-program-events :add-pagination-status-event @@ -1411,6 +1420,7 @@ :*open-message-link-keymap* :*open-gemini-link-keymap* :*gemini-downloads-keymap* + :*gemini-certificates-keymap* :*chats-list-keymap* :*chat-message-keymap* :define-key @@ -1849,6 +1859,26 @@ :init-chat-links :forget-chat-link-window)) +(defpackage :gemini-certificates-window + (:use + :cl + :alexandria + :cl-ppcre + :access + :croatoan + :config + :constants + :text-utils + :misc + :mtree + :specials + :windows + :line-oriented-window + :tui-utils) + (:shadowing-import-from :misc :random-elt :shuffle) + (:export + :open-gemini-certificates-window)) + (defpackage :command-window (:use :cl @@ -2229,6 +2259,12 @@ :gemini-view-source :gemini-abort-download :gemini-open-streams-window + :gemini-open-certificates-window + :gemini-certificate-window-move + :gemini-certificate-window-go-down + :gemini-certificate-window-go-up + :gemini-close-certificate-window + :gemini-delete-certificate :gemini-streams-window-up :gemini-streams-window-down :gemini-streams-window-close diff --git a/src/program-events.lisp b/src/program-events.lisp index e898f36..83aa369 100644 --- a/src/program-events.lisp +++ b/src/program-events.lisp @@ -1227,6 +1227,12 @@ (with-accessors ((regex regex)) object (keybindings:print-help specials:*main-window* :regex regex))) +(defclass redraw-window-event (program-event) ()) + +(defmethod process-event ((object redraw-window-event)) + (with-accessors ((window payload)) object + (windows:draw window))) + ;;;; general usage (defclass function-event (program-event) ()) diff --git a/src/software-configuration.lisp b/src/software-configuration.lisp index d31e47d..c47a539 100644 --- a/src/software-configuration.lisp +++ b/src/software-configuration.lisp @@ -334,6 +334,8 @@ value scheme link + creation-time + access-time quote h1 h2 @@ -381,6 +383,7 @@ open-attach-window open-message-link-window open-gemini-stream-window + gemini-certificates-window command-window command-separator gemini @@ -490,6 +493,21 @@ +key-bullet+ +key-prefix+)) +(defun gemini-certificates-window-colors () + "return three color values" + (values (access:accesses *software-configuration* + +key-gemini-certificates-window+ + +key-link+ + +key-foreground+) + (access:accesses *software-configuration* + +key-gemini-certificates-window+ + +key-creation-time+ + +key-foreground+) + (access:accesses *software-configuration* + +key-gemini-certificates-window+ + +key-access-time+ + +key-foreground+))) + (defun signature-file-path () "Returns the filepath of the signature file, the $HOME is prepended." (let* ((signature-file (or (access:accesses *software-configuration* diff --git a/src/specials.lisp b/src/specials.lisp index edf5e29..765c819 100644 --- a/src/specials.lisp +++ b/src/specials.lisp @@ -55,5 +55,8 @@ (defparameter *gemini-streams-window* nil "The window that shows all gemini-streams.") +(defparameter *gemini-certificates-window* nil + "The window that shows all gemini client certificates.") + (defparameter *chats-list-window* nil "The window that shows all the chats.") diff --git a/src/tui-utils.lisp b/src/tui-utils.lisp index 544fee7..fb2bd1d 100644 --- a/src/tui-utils.lisp +++ b/src/tui-utils.lisp @@ -159,6 +159,14 @@ as argument `complex-string'." attributes and color of a." (croatoan:concat-complex-string a b :color-attributes-contagion color-attributes-contagion)) +(defmethod cat-complex-string ((a sequence) (b complex-string) + &key (color-attributes-contagion t)) + "Return a complex string that is the results of concatenating of + `a' (a string) and `b' (a `complex-string') If + `color-attributes-contagion' is non nil `b' will inherit all the + attributes and color of a." + (croatoan:concat-complex-string a b :color-attributes-contagion color-attributes-contagion)) + (defmethod cat-complex-string ((a complex-string) (b complex-string) &key (color-attributes-contagion nil)) "Return a complex string that is the results of concatenating of `a' diff --git a/src/ui-goodies.lisp b/src/ui-goodies.lisp index 39bebdd..d75548d 100644 --- a/src/ui-goodies.lisp +++ b/src/ui-goodies.lisp @@ -398,7 +398,8 @@ Metadata includes: *message-window* :documentation "Move focus on message window" :info-change-focus-message (_ "Focus passed on message window") - :windows-lose-focus (*chats-list-window* + :windows-lose-focus (*gemini-certificates-window* + *chats-list-window* *gemini-streams-window* *open-message-link-window* *open-attach-window* @@ -412,7 +413,8 @@ Metadata includes: *send-message-window* :documentation "Move focus on send message window" :info-change-focus-message (_ "Focus passed on send message window") - :windows-lose-focus (*chats-list-window* + :windows-lose-focus (*gemini-certificates-window* + *chats-list-window* *gemini-streams-window* *open-message-link-window* *open-attach-window* @@ -426,7 +428,8 @@ Metadata includes: *follow-requests-window* :documentation "Move focus on follow requests window" :info-change-focus-message (_ "Focus passed on follow requests window") - :windows-lose-focus (*chats-list-window* + :windows-lose-focus (*gemini-certificates-window* + *chats-list-window* *gemini-streams-window* *open-message-link-window* *open-attach-window* @@ -440,7 +443,8 @@ Metadata includes: *tags-window* :documentation "Move focus on tags window" :info-change-focus-message (_ "Focus passed on tags window") - :windows-lose-focus (*chats-list-window* + :windows-lose-focus (*gemini-certificates-window* + *chats-list-window* *gemini-streams-window* *open-message-link-window* *open-attach-window* @@ -453,7 +457,8 @@ Metadata includes: *conversations-window* :documentation "Move focus on conversations window" :info-change-focus-message (_ "Focus passed on conversation window") - :windows-lose-focus (*chats-list-window* + :windows-lose-focus (*gemini-certificates-window* + *chats-list-window* *gemini-streams-window* *open-message-link-window* *open-attach-window* @@ -467,7 +472,8 @@ Metadata includes: *open-attach-window* :documentation "Move focus on open-attach window" :info-change-focus-message (_ "Focus passed on attach window") - :windows-lose-focus (*chats-list-window* + :windows-lose-focus (*gemini-certificates-window* + *chats-list-window* *gemini-streams-window* *open-message-link-window* *conversations-window* @@ -481,7 +487,8 @@ Metadata includes: *open-message-link-window* :documentation "Move focus on open-link window" :info-change-focus-message (_ "Focus passed on link window") - :windows-lose-focus (*chats-list-window* + :windows-lose-focus (*gemini-certificates-window* + *chats-list-window* *gemini-streams-window* *conversations-window* *open-attach-window* @@ -495,7 +502,8 @@ Metadata includes: *gemini-streams-window* :documentation "Move focus on open gemini streams window" :info-change-focus-message (_ "Focus passed on gemini-stream window") - :windows-lose-focus (*chats-list-window* + :windows-lose-focus (*gemini-certificates-window* + *chats-list-window* *open-message-link-window* *conversations-window* *open-attach-window* @@ -509,7 +517,8 @@ Metadata includes: *chats-list-window* :documentation "Move focus on chats list window" :info-change-focus-message (_ "Focus passed on chats list window") - :windows-lose-focus (*gemini-streams-window* + :windows-lose-focus (*gemini-certificates-window* + *gemini-streams-window* *open-message-link-window* *conversations-window* *open-attach-window* @@ -519,6 +528,20 @@ Metadata includes: *message-window* *send-message-window*)) +(gen-focus-to-window open-gemini-certificates-window + *gemini-certificates-window* + :documentation "Move focus on open-gemini certificates window" + :info-change-focus-message (_ "Focus passed on TLS certificates window.") + :windows-lose-focus (*chats-list-window* + *gemini-streams-window* + *conversations-window* + *open-attach-window* + *tags-window* + *follow-requests-window* + *thread-window* + *message-window* + *send-message-window*)) + (defun print-quick-help () "Print a quick help" (keybindings:print-help *main-window*)) @@ -1072,6 +1095,18 @@ Browse and optionally open the links the text of the message window contains." (open-message-link-window:init (db:row-message-status-id selected-message)) (focus-to-open-message-link-window)))) +(defun line-window-move (win amount) + (ignore-errors + (line-oriented-window:unselect-all win) + (line-oriented-window:row-move win amount) + (draw win))) + +(defun line-window-go-up (win) + (line-window-move win -1)) + +(defun line-window-go-down (win) + (line-window-move win 1)) + (defun open-message-link-move (amount) (ignore-errors (line-oriented-window:unselect-all *open-message-link-window*) @@ -1106,6 +1141,49 @@ This makes sense only for gemini file stream, if not this command performs the s (close-window-and-return-to-message *open-message-link-window*) (close-window-and-return-to-threads *open-message-link-window*))) +(defun gemini-open-certificates-window () + "Open a window with all the client certificated generated so far to +authenticate this client on a gemini server." + (gemini-certificates-window:open-gemini-certificates-window) + (focus-to-open-gemini-certificates-window)) + +(defun gemini-certificate-window-move (amount) + (line-window-move *gemini-certificates-window* amount)) + +(defun gemini-certificate-window-go-down () + (line-window-go-down *gemini-certificates-window*)) + +(defun gemini-certificate-window-go-up () + (line-window-go-up *gemini-certificates-window*)) + +(defun gemini-close-certificate-window () + (close-window-and-return-to-message *gemini-certificates-window*)) + +(defun gemini-delete-certificate () + "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 identit (i.e. a new +certificate). +" + (flet ((on-input-complete (answer) + (when (boolean-input-accepted-p answer) + (db-utils:with-ready-database (:connect nil) + (let* ((selected-row (line-oriented-window:selected-row-fields + *gemini-certificates-window*)) + (cache-key (db:row-cache-key selected-row)) + (event (make-instance 'function-event + :payload + (lambda () + (line-oriented-window:resync-rows-db + *gemini-certificates-window* + :suggested-message-index 0))))) + (db:cache-invalidate cache-key) + (push-event event)))))) + (ask-string-input #'on-input-complete + :prompt (_ "Delete this certificate? [Y/n] ") + :complete-fn #'complete:complete-always-empty))) + (defun prompt-for-username (prompt complete-function event notify-starting-message notify-ending-message) diff --git a/tinmop.asd b/tinmop.asd index 10296ee..d9fb95e 100644 --- a/tinmop.asd +++ b/tinmop.asd @@ -108,6 +108,7 @@ (:file "message-window") (:file "open-attach-window") (:file "open-message-link-window") + (:file "gemini-client-certificates-window") (:file "command-window") (:file "sending-message") (:file "follow-requests")