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

- [gemini] implemented a draft of a client authentication (via TLS certificates).

This commit is contained in:
cage 2020-10-23 20:57:17 +02:00
parent 0fd83f7745
commit 269a08718c
15 changed files with 371 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
etc/default-theme.conf
View File

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

14
etc/init.lisp
View File

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

37
src/db.lisp
View File

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

108
src/gemini-client-certificates-window.lisp Normal file
View File

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

21
src/gemini-viewer.lisp
View File

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

44
src/gemini/client.lisp
View File

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

3
src/keybindings.lisp
View File

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

2
src/os-utils.lisp
View File

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

38
src/package.lisp
View File

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

6
src/program-events.lisp
View File

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

18
src/software-configuration.lisp
View File

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

3
src/specials.lisp
View File

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

8
src/tui-utils.lisp
View File

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

96
src/ui-goodies.lisp
View File

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

1
tinmop.asd
View File

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