cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-02-16 08:00:35 +01:00
Code Issues

- [gemini] starting using certificates;

Browse Source 
- removed hardcoded 'xdg-open' binary name.
This commit is contained in:
cage 2020-10-11 18:22:07 +02:00
parent df8d3221ec
commit 497efa6a92
13 changed files with 243 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
Makefile.am
View File

@ -15,33 +15,35 @@
# along with this program.
# If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]].
ACLOCAL_AMFLAGS = -I m4
ACLOCAL_AMFLAGS = -I m4
bin_SCRIPTS = tinmop
bin_SCRIPTS = tinmop
CLEANFILES = $(bin_SCRIPTS) $(CONF_PATH_FILE);
CLEANFILES = $(bin_SCRIPTS) $(CONF_PATH_FILE);
CONF_PATH_FILE = src/config.lisp
CONF_PATH_FILE = src/config.lisp
CONF_PATH_FILE_IN = src/config.lisp.in
CONF_PATH_FILE_IN = src/config.lisp.in
BUILT_SOURCES = $(CONF_PATH_FILE)
CONF_PATH_FILE_IN_IN = src/config.lisp.in.in
EXTRA_DIST = config.rpath m4/ChangeLog tinmop.asd README.org src \
BUILT_SOURCES = $(CONF_PATH_FILE)
EXTRA_DIST = config.rpath m4/ChangeLog tinmop.asd README.org src \
LICENSES.org COPYING etc/shared.conf etc/default-theme.conf \
etc/init.lisp compare_version.awk
SUBDIRS = po
SUBDIRS = po
dist_doc_DATA = README.org README.txt LICENSES.org CONTRIBUTING.org \
dist_doc_DATA = README.org README.txt LICENSES.org CONTRIBUTING.org \
doc/man.org doc/send-toot.lisp NEWS.org ChangeLog
confdir = $(sysconfdir)/$(PACKAGE)
confdir = $(sysconfdir)/$(PACKAGE)
dist_conf_DATA = etc/init.lisp etc/next-previous-open.lisp \
dist_conf_DATA = etc/init.lisp etc/next-previous-open.lisp \
etc/default-theme.conf etc/shared.conf
dist_man1_MANS = doc/tinmop.man
dist_man1_MANS = doc/tinmop.man
$(PACKAGE): $(CONF_PATH_FILE)
$(LISP_COMPILER) \
@ -76,3 +78,4 @@ $(CONF_PATH_FILE):
dist-hook:
rm -fv $(top_distdir)/$(CONF_PATH_FILE)
rm -fv $(top_distdir)/$(CONF_PATH_FILE_IN)

10
Makefile.in
View File

@ -121,7 +121,7 @@ DIST_COMMON = $(srcdir)/Makefile.am $(top_srcdir)/configure \
am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \
configure.lineno config.status.lineno
mkinstalldirs = $(install_sh) -d
CONFIG_CLEAN_FILES = quick_quicklisp.sh
CONFIG_CLEAN_FILES = quick_quicklisp.sh src/config.lisp.in
CONFIG_CLEAN_VPATH_FILES =
am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
am__vpath_adj = case $$p in \
@ -214,7 +214,8 @@ CTAGS = ctags
CSCOPE = cscope
DIST_SUBDIRS = $(SUBDIRS)
am__DIST_COMMON = $(dist_man1_MANS) $(srcdir)/Makefile.in \
$(srcdir)/quick_quicklisp.sh.in COPYING ChangeLog compile \
$(srcdir)/quick_quicklisp.sh.in \
$(top_srcdir)/src/config.lisp.in.in COPYING ChangeLog compile \
config.guess config.rpath config.sub install-sh missing
DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
distdir = $(PACKAGE)-$(VERSION)
@ -308,6 +309,7 @@ MSGFMT = @MSGFMT@
MSGFMT_015 = @MSGFMT_015@
MSGMERGE = @MSGMERGE@
OBJEXT = @OBJEXT@
OPENSSL = @OPENSSL@
PACKAGE = @PACKAGE@
PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
PACKAGE_NAME = @PACKAGE_NAME@
@ -383,6 +385,7 @@ bin_SCRIPTS = tinmop
CLEANFILES = $(bin_SCRIPTS) $(CONF_PATH_FILE);
CONF_PATH_FILE = src/config.lisp
CONF_PATH_FILE_IN = src/config.lisp.in
CONF_PATH_FILE_IN_IN = src/config.lisp.in.in
BUILT_SOURCES = $(CONF_PATH_FILE)
EXTRA_DIST = config.rpath m4/ChangeLog tinmop.asd README.org src \
LICENSES.org COPYING etc/shared.conf etc/default-theme.conf \
@ -436,6 +439,8 @@ $(ACLOCAL_M4): $(am__aclocal_m4_deps)
$(am__aclocal_m4_deps):
quick_quicklisp.sh: $(top_builddir)/config.status $(srcdir)/quick_quicklisp.sh.in
cd $(top_builddir) && $(SHELL) ./config.status $@
src/config.lisp.in: $(top_builddir)/config.status $(top_srcdir)/src/config.lisp.in.in
cd $(top_builddir) && $(SHELL) ./config.status $@
install-binSCRIPTS: $(bin_SCRIPTS)
@$(NORMAL_INSTALL)
@list='$(bin_SCRIPTS)'; test -n "$(bindir)" || list=; \
@ -1034,6 +1039,7 @@ $(CONF_PATH_FILE):
dist-hook:
rm -fv $(top_distdir)/$(CONF_PATH_FILE)
rm -fv $(top_distdir)/$(CONF_PATH_FILE_IN)
# Tell versions [3.59,3.63) of GNU make to not export all variables.
# Otherwise a system limit (for SysV at least) may be exceeded.

56
configure vendored
View File

@ -590,6 +590,7 @@ ac_subst_vars='am__EXEEXT_FALSE
am__EXEEXT_TRUE
LTLIBOBJS
LIBOBJS
OPENSSL
XDG_OPEN
GAWK
BASH
@ -6412,6 +6413,58 @@ if test "$XDG_OPEN" = "no" ; then
exit 1;
fi
for ac_prog in openssl
do
# Extract the first word of "$ac_prog", so it can be a program name with args.
set dummy $ac_prog; ac_word=$2
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
$as_echo_n "checking for $ac_word... " >&6; }
if ${ac_cv_path_OPENSSL+:} false; then :
$as_echo_n "(cached) " >&6
else
case $OPENSSL in
[\\/]* | ?:[\\/]*)
ac_cv_path_OPENSSL="$OPENSSL" # Let the user override the test with a path.
;;
*)
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
for as_dir in $PATH
do
IFS=$as_save_IFS
test -z "$as_dir" && as_dir=.
for ac_exec_ext in '' $ac_executable_extensions; do
if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then
ac_cv_path_OPENSSL="$as_dir/$ac_word$ac_exec_ext"
$as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
break 2
fi
done
done
IFS=$as_save_IFS
;;
esac
fi
OPENSSL=$ac_cv_path_OPENSSL
if test -n "$OPENSSL"; then
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $OPENSSL" >&5
$as_echo "$OPENSSL" >&6; }
else
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
$as_echo "no" >&6; }
fi
test -n "$OPENSSL" && break
done
test -n "$OPENSSL" || OPENSSL="no"
if test "$OPENSSL" = "no" ; then
as_fn_error $? "Can not find openssl binary." "$LINENO" 5
exit 1;
fi
SBCL_MIN_VERSION="1.5.9";
@ -6423,7 +6476,7 @@ if test "$SBCL_VERSION_OK" = "1" ; then
exit 1;
fi
ac_config_files="$ac_config_files Makefile quick_quicklisp.sh po/Makefile.in"
ac_config_files="$ac_config_files Makefile quick_quicklisp.sh po/Makefile.in src/config.lisp.in"
cat >confcache <<\_ACEOF
@ -7179,6 +7232,7 @@ do
"Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
"quick_quicklisp.sh") CONFIG_FILES="$CONFIG_FILES quick_quicklisp.sh" ;;
"po/Makefile.in") CONFIG_FILES="$CONFIG_FILES po/Makefile.in" ;;
"src/config.lisp.in") CONFIG_FILES="$CONFIG_FILES src/config.lisp.in" ;;
*) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;
esac

9
configure.ac
View File

@ -62,6 +62,13 @@ if test "$XDG_OPEN" = "no" ; then
exit 1;
fi
AC_PATH_PROGS([OPENSSL],[openssl],[no])
if test "$OPENSSL" = "no" ; then
AC_MSG_ERROR([Can not find openssl binary.])
exit 1;
fi
AC_PROG_MKDIR_P
dnl check sbcl version
@ -74,6 +81,6 @@ if test "$SBCL_VERSION_OK" = "1" ; then
exit 1;
fi
AC_CONFIG_FILES([Makefile quick_quicklisp.sh po/Makefile.in])
AC_CONFIG_FILES([Makefile quick_quicklisp.sh po/Makefile.in src/config.lisp.in])
AC_OUTPUT

6
src/config.lisp.in
View File

@ -1,5 +1,3 @@
;; 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
@ -15,6 +13,10 @@
;; along with this program.
;; If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]].
(alexandria:define-constant +openssl-bin+ "/usr/bin/openssl" :test #'string=)
(alexandria:define-constant +xdg-open-bin+ "/usr/bin/xdg-open" :test #'string=)
(defmacro with-return-untranslated ((untranslated) &body body)
`(handler-bind ((i18n-conditions:no-translation-table-error
(lambda (e)

47
src/config.lisp.in.in Normal file
View File

@ -0,0 +1,47 @@
;; 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/]].
(alexandria:define-constant +openssl-bin+ "@OPENSSL@" :test #'string=)
(alexandria:define-constant +xdg-open-bin+ "@XDG_OPEN@" :test #'string=)
(defmacro with-return-untranslated ((untranslated) &body body)
`(handler-bind ((i18n-conditions:no-translation-table-error
(lambda (e)
(declare (ignore e))
(invoke-restart 'cl-i18n:return-untranslated))))
(handler-case
(progn ,@body)
(i18n-conditions:no-translation (e)
(declare (ignorable e))
#+debug-mode
(progn
(warn e)
,untranslated)
#-debug-mode ,untranslated))))
(defun _ (a)
"get translated string"
(with-return-untranslated (a)
(cl-i18n:translate a)))
(defun n_ (a b n)
"Get stranslated string with plural forms
- a the untranslated string template
- b the string template to return if no translation was found
- n the number of object mentioned in the string template"
(declare (ignore b))
(with-return-untranslated (a)
(cl-i18n:ntranslate a a n)))

3
src/constants.lisp
View File

@ -83,3 +83,6 @@ For bug report please point your browser to:
(define-constant +mention-prefix+ "@" :test #'string=
:documentation "The prefix for a mention in a message")
(define-constant +cache-tls-certificate-type+ "certificate" :test #'string=
:documentation "The cache type for TLS certificate")

20
src/db.lisp
View File

@ -247,6 +247,7 @@
:autogenerated-id-p t
:autoincrementp t)
"key TEXT NOT NULL,"
"type TEXT NOT NULL,"
;; timestamp
" \"created-at\" TEXT NOT NULL,"
;; timestamp
@ -2721,7 +2722,7 @@ conversation removed (default: remove)"
(now)
(:= :key key)))))
(defun cache-put (key)
(defun cache-put (key &optional (type "generic"))
"Insert a new cahe row with key `key'"
(if (cache-get key)
(with-db-transaction
@ -2730,8 +2731,8 @@ conversation removed (default: remove)"
(with-db-transaction
(with-db-current-timestamp (now)
(query (make-insert +table-cache+
(:key :created-at :accessed-at)
(key now now)))
(:key :type :created-at :accessed-at)
(key type now now)))
(last-inserted-rowid)))))
(defun cache-get (key)
@ -2752,7 +2753,7 @@ conversation removed (default: remove)"
(defun cache-expired-p (key &key (days-in-the-past (swconf:config-purge-cage-days-offset)))
"Return non nil if the last time the cache was accessed was older
than `days-in-the-past' days (default: `(swconf:config-purge-cage-days-offset)'"
than `days-in-the-past' days (default: `(swconf:config-purge-cache-days-offset)'"
(let ((row (cache-get key)))
(if (null row)
t
@ -2777,3 +2778,14 @@ than `days-in-the-past' days (default: `(swconf:config-purge-cage-days-offset)'"
(defun tofu-delete (host)
(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+)))

18
src/gemini-viewer.lisp
View File

@ -360,7 +360,10 @@
(%fill-buffer)))))))
(%fill-buffer))))))
(defun request (url &key (enqueue nil) (do-nothing-if-exists-in-db t))
(defun request (url &key
(enqueue nil)
(certificate nil)
(do-nothing-if-exists-in-db t))
(let ((parsed-uri (quri:uri url)))
(maybe-initialize-metadata specials:*message-window*)
(if (null parsed-uri)
@ -408,8 +411,9 @@
(multiple-value-bind (status code-description meta response socket)
(gemini-client:request host
path
:query query
:port port)
:client-certificate certificate
:query query
:port port)
(add-url-to-history specials:*message-window* actual-uri)
(cond
((gemini-client:response-redirect-p status)
@ -427,6 +431,14 @@
(format nil
(_ "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)
(request actual-uri
:enqueue enqueue
:do-nothing-if-exists-in-db do-nothing-if-exists-in-db
:certificate certificate)))
((gemini-client:response-input-p status)
(get-user-input nil host meta))
((gemini-client:response-sensitive-input-p status)

59
src/gemini/client.lisp
View File

@ -125,14 +125,23 @@
(header-code= header +53+)
(header-code= header +59+)))
(defun header-not-implemented-p (header)
(or (header-code= header +60+)
(header-code= header +61+)
(defun header-certificate-failure-p (header)
(or (header-code= header +61+)
(header-code= header +62+)))
(defun header-not-implemented-p (header)
(declare (ignore header))
nil)
(defun header-certificate-requested-p (header)
(header-code= header +60+))
(defun response-input-p (code)
(code= code +10+))
(defun response-certificate-requested-p (code)
(code= code +60+))
(defun response-sensitive-input-p (code)
(code= code +11+))
@ -245,17 +254,19 @@
meta
stream))
((or (header-input-request-p parsed-header)
(header-redirect-p parsed-header))
(header-redirect-p parsed-header)
(header-certificate-requested-p parsed-header))
(results (find-code-class status-code) nil))
((or (header-permanent-failure-p parsed-header)
(header-temporary-failure-p parsed-header))
((or (header-permanent-failure-p parsed-header)
(header-temporary-failure-p parsed-header)
(header-certificate-failure-p parsed-header))
(let ((response-code (find-code-class status-code)))
(error 'gemini-protocol-error
:error-code (code response-code)
:error-description (description response-code))))
((header-not-implemented-p parsed-header)
(error 'conditions:not-implemented-error
:text (_ "The server requested a certificate but client validation is not implemented by this program")))
;; ((header-not-implemented-p parsed-header)
;; (error 'conditions:not-implemented-error
;; :text (_ "The server requested a certificate but client validation is not implemented by this program")))
(t
parsed-header))))))
@ -265,7 +276,16 @@
(defun close-ssl-socket (socket)
(usocket:socket-close socket))
(defun request (host path &key (query nil) (port +gemini-default-port+))
(defun make-client-certificate (uri)
(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)))
(defun request (host path &key
(query nil)
(port +gemini-default-port+)
(client-certificate nil))
(let* ((uri (make-gemini-uri host path query port))
(ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-none+)))
(when query
@ -274,14 +294,15 @@
(let ((socket (usocket:socket-connect host port :element-type '(unsigned-byte 8))))
(unwind-protect
(when socket
(let ((stream (usocket:socket-stream socket)))
(let* ((ssl-stream (cl+ssl:make-ssl-client-stream stream
: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))))
(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
@ -289,4 +310,4 @@
(force-output ssl-stream)
(multiple-value-bind (status description meta response)
(parse-response ssl-stream)
(values status description meta response socket))))))))))))
(values status description meta response socket)))))))))))

2
src/gemini/package.lisp
View File

@ -87,6 +87,7 @@
:gemini-tofu-error
:make-gemini-file-response
:host
:response-certificate-requested-p
:response-input-p
:response-sensitive-input-p
:response-redirect-p
@ -104,4 +105,5 @@
:text-rendering-theme
:gemini-file-response-p
:close-ssl-socket
:make-client-certificate
:request))

22
src/os-utils.lisp
View File

@ -26,6 +26,10 @@
"cpuinfo")
:test #'string=)
(alexandria:define-constant +ssl-cert-name+ "cert.pem" :test #'string=)
(alexandria:define-constant +ssl-key-name+ "key" :test #'string=)
(declaim (ftype (function () fixnum) cpu-number))
(defun cpu-number ()
@ -40,7 +44,7 @@
(incf cpu-count)))))
(defun xdg-open (file)
(uiop:launch-program (format nil "xdg-open '~a'" file)
(uiop:launch-program (format nil "~a '~a'" +xdg-open-bin+ file)
:output nil))
(defun getenv (name)
@ -68,7 +72,7 @@
(multiple-value-bind (exe args)
(external-editor)
(let ((actual-args (if args
(list args)
(list (text-utils:split-words args))
nil)))
(sb-ext:run-program exe
(append actual-args
@ -88,3 +92,17 @@
(defun cached-file-path (filename)
(text-utils:strcat (user-cache-dir) fs:*directory-sep* filename))
(defun generate-ssl-certificate (outdir)
(let* ((cert-file (text-utils:strcat outdir fs:*directory-sep* +ssl-cert-name+))
(key-file (text-utils:strcat outdir fs:*directory-sep* +ssl-key-name+))
(cmd-args (format nil
(text-utils:strcat "req -new -nodes -x509 -days 365 -batch "
"-keyout ~a -outform PEM -out ~a")
key-file
cert-file)))
(sb-ext:run-program +openssl-bin+
(text-utils:split-words cmd-args)
:output nil
:error :output)
(values cert-file key-file)))

14
src/package.lisp
View File

@ -24,7 +24,8 @@
:+program-name+
:+program-version+
:+issue-tracker+
:+home-data-dir+
:+openssl-bin+
:+xdg-open-bin+
:_
:n_))
@ -49,7 +50,8 @@
:+status-direct-visibility+
:+folder-direct-message-prefix+
:+folder-tag-prefix+
:+mention-prefix+))
:+mention-prefix+
:+cache-tls-certificate-type+))
(defpackage :conditions
(:use :cl
@ -308,6 +310,8 @@
:config
:constants)
(:export
:+ssl-cert-name+
:+ssl-key-name+
:cpu-number
:xdg-open
:getenv
@ -315,7 +319,8 @@
:open-with-editor
:exit-program
:user-cache-dir
:cached-file-path))
:cached-file-path
:generate-ssl-certificate))
(defpackage :text-utils
(:use
@ -882,7 +887,8 @@
:cache-get-value
:cache-expired-p
:tofu-passes-p
:tofu-delete))
:tofu-delete
:ssl-cert-find))
(defpackage :date-formatter
(:use