mirror of https://codeberg.org/cage/tinmop/
- [gemini] starting using certificates;
- removed hardcoded 'xdg-open' binary name.
This commit is contained in:
parent
df8d3221ec
commit
497efa6a92
27
Makefile.am
27
Makefile.am
|
@ -15,33 +15,35 @@
|
||||||
# along with this program.
|
# along with this program.
|
||||||
# If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]].
|
# 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 \
|
LICENSES.org COPYING etc/shared.conf etc/default-theme.conf \
|
||||||
etc/init.lisp compare_version.awk
|
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
|
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
|
etc/default-theme.conf etc/shared.conf
|
||||||
|
|
||||||
dist_man1_MANS = doc/tinmop.man
|
dist_man1_MANS = doc/tinmop.man
|
||||||
|
|
||||||
$(PACKAGE): $(CONF_PATH_FILE)
|
$(PACKAGE): $(CONF_PATH_FILE)
|
||||||
$(LISP_COMPILER) \
|
$(LISP_COMPILER) \
|
||||||
|
@ -76,3 +78,4 @@ $(CONF_PATH_FILE):
|
||||||
|
|
||||||
dist-hook:
|
dist-hook:
|
||||||
rm -fv $(top_distdir)/$(CONF_PATH_FILE)
|
rm -fv $(top_distdir)/$(CONF_PATH_FILE)
|
||||||
|
rm -fv $(top_distdir)/$(CONF_PATH_FILE_IN)
|
||||||
|
|
10
Makefile.in
10
Makefile.in
|
@ -121,7 +121,7 @@ DIST_COMMON = $(srcdir)/Makefile.am $(top_srcdir)/configure \
|
||||||
am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \
|
am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \
|
||||||
configure.lineno config.status.lineno
|
configure.lineno config.status.lineno
|
||||||
mkinstalldirs = $(install_sh) -d
|
mkinstalldirs = $(install_sh) -d
|
||||||
CONFIG_CLEAN_FILES = quick_quicklisp.sh
|
CONFIG_CLEAN_FILES = quick_quicklisp.sh src/config.lisp.in
|
||||||
CONFIG_CLEAN_VPATH_FILES =
|
CONFIG_CLEAN_VPATH_FILES =
|
||||||
am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
|
am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
|
||||||
am__vpath_adj = case $$p in \
|
am__vpath_adj = case $$p in \
|
||||||
|
@ -214,7 +214,8 @@ CTAGS = ctags
|
||||||
CSCOPE = cscope
|
CSCOPE = cscope
|
||||||
DIST_SUBDIRS = $(SUBDIRS)
|
DIST_SUBDIRS = $(SUBDIRS)
|
||||||
am__DIST_COMMON = $(dist_man1_MANS) $(srcdir)/Makefile.in \
|
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
|
config.guess config.rpath config.sub install-sh missing
|
||||||
DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
|
DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
|
||||||
distdir = $(PACKAGE)-$(VERSION)
|
distdir = $(PACKAGE)-$(VERSION)
|
||||||
|
@ -308,6 +309,7 @@ MSGFMT = @MSGFMT@
|
||||||
MSGFMT_015 = @MSGFMT_015@
|
MSGFMT_015 = @MSGFMT_015@
|
||||||
MSGMERGE = @MSGMERGE@
|
MSGMERGE = @MSGMERGE@
|
||||||
OBJEXT = @OBJEXT@
|
OBJEXT = @OBJEXT@
|
||||||
|
OPENSSL = @OPENSSL@
|
||||||
PACKAGE = @PACKAGE@
|
PACKAGE = @PACKAGE@
|
||||||
PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
|
PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
|
||||||
PACKAGE_NAME = @PACKAGE_NAME@
|
PACKAGE_NAME = @PACKAGE_NAME@
|
||||||
|
@ -383,6 +385,7 @@ 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
|
||||||
|
CONF_PATH_FILE_IN_IN = src/config.lisp.in.in
|
||||||
BUILT_SOURCES = $(CONF_PATH_FILE)
|
BUILT_SOURCES = $(CONF_PATH_FILE)
|
||||||
EXTRA_DIST = config.rpath m4/ChangeLog tinmop.asd README.org src \
|
EXTRA_DIST = config.rpath m4/ChangeLog tinmop.asd README.org src \
|
||||||
LICENSES.org COPYING etc/shared.conf etc/default-theme.conf \
|
LICENSES.org COPYING etc/shared.conf etc/default-theme.conf \
|
||||||
|
@ -436,6 +439,8 @@ $(ACLOCAL_M4): $(am__aclocal_m4_deps)
|
||||||
$(am__aclocal_m4_deps):
|
$(am__aclocal_m4_deps):
|
||||||
quick_quicklisp.sh: $(top_builddir)/config.status $(srcdir)/quick_quicklisp.sh.in
|
quick_quicklisp.sh: $(top_builddir)/config.status $(srcdir)/quick_quicklisp.sh.in
|
||||||
cd $(top_builddir) && $(SHELL) ./config.status $@
|
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)
|
install-binSCRIPTS: $(bin_SCRIPTS)
|
||||||
@$(NORMAL_INSTALL)
|
@$(NORMAL_INSTALL)
|
||||||
@list='$(bin_SCRIPTS)'; test -n "$(bindir)" || list=; \
|
@list='$(bin_SCRIPTS)'; test -n "$(bindir)" || list=; \
|
||||||
|
@ -1034,6 +1039,7 @@ $(CONF_PATH_FILE):
|
||||||
|
|
||||||
dist-hook:
|
dist-hook:
|
||||||
rm -fv $(top_distdir)/$(CONF_PATH_FILE)
|
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.
|
# 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.
|
# Otherwise a system limit (for SysV at least) may be exceeded.
|
||||||
|
|
|
@ -590,6 +590,7 @@ ac_subst_vars='am__EXEEXT_FALSE
|
||||||
am__EXEEXT_TRUE
|
am__EXEEXT_TRUE
|
||||||
LTLIBOBJS
|
LTLIBOBJS
|
||||||
LIBOBJS
|
LIBOBJS
|
||||||
|
OPENSSL
|
||||||
XDG_OPEN
|
XDG_OPEN
|
||||||
GAWK
|
GAWK
|
||||||
BASH
|
BASH
|
||||||
|
@ -6412,6 +6413,58 @@ if test "$XDG_OPEN" = "no" ; then
|
||||||
exit 1;
|
exit 1;
|
||||||
fi
|
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";
|
SBCL_MIN_VERSION="1.5.9";
|
||||||
|
@ -6423,7 +6476,7 @@ if test "$SBCL_VERSION_OK" = "1" ; then
|
||||||
exit 1;
|
exit 1;
|
||||||
fi
|
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
|
cat >confcache <<\_ACEOF
|
||||||
|
@ -7179,6 +7232,7 @@ do
|
||||||
"Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
|
"Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
|
||||||
"quick_quicklisp.sh") CONFIG_FILES="$CONFIG_FILES quick_quicklisp.sh" ;;
|
"quick_quicklisp.sh") CONFIG_FILES="$CONFIG_FILES quick_quicklisp.sh" ;;
|
||||||
"po/Makefile.in") CONFIG_FILES="$CONFIG_FILES po/Makefile.in" ;;
|
"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;;
|
*) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;
|
||||||
esac
|
esac
|
||||||
|
|
|
@ -62,6 +62,13 @@ if test "$XDG_OPEN" = "no" ; then
|
||||||
exit 1;
|
exit 1;
|
||||||
fi
|
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
|
AC_PROG_MKDIR_P
|
||||||
|
|
||||||
dnl check sbcl version
|
dnl check sbcl version
|
||||||
|
@ -74,6 +81,6 @@ if test "$SBCL_VERSION_OK" = "1" ; then
|
||||||
exit 1;
|
exit 1;
|
||||||
fi
|
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
|
AC_OUTPUT
|
||||||
|
|
|
@ -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
|
;; 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
|
;; it under the terms of the GNU General Public License as published by
|
||||||
|
@ -15,6 +13,10 @@
|
||||||
;; along with this program.
|
;; along with this program.
|
||||||
;; If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]].
|
;; 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)
|
(defmacro with-return-untranslated ((untranslated) &body body)
|
||||||
`(handler-bind ((i18n-conditions:no-translation-table-error
|
`(handler-bind ((i18n-conditions:no-translation-table-error
|
||||||
(lambda (e)
|
(lambda (e)
|
||||||
|
|
|
@ -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)))
|
|
@ -83,3 +83,6 @@ For bug report please point your browser to:
|
||||||
|
|
||||||
(define-constant +mention-prefix+ "@" :test #'string=
|
(define-constant +mention-prefix+ "@" :test #'string=
|
||||||
:documentation "The prefix for a mention in a message")
|
: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
20
src/db.lisp
|
@ -247,6 +247,7 @@
|
||||||
:autogenerated-id-p t
|
:autogenerated-id-p t
|
||||||
:autoincrementp t)
|
:autoincrementp t)
|
||||||
"key TEXT NOT NULL,"
|
"key TEXT NOT NULL,"
|
||||||
|
"type TEXT NOT NULL,"
|
||||||
;; timestamp
|
;; timestamp
|
||||||
" \"created-at\" TEXT NOT NULL,"
|
" \"created-at\" TEXT NOT NULL,"
|
||||||
;; timestamp
|
;; timestamp
|
||||||
|
@ -2721,7 +2722,7 @@ conversation removed (default: remove)"
|
||||||
(now)
|
(now)
|
||||||
(:= :key key)))))
|
(:= :key key)))))
|
||||||
|
|
||||||
(defun cache-put (key)
|
(defun cache-put (key &optional (type "generic"))
|
||||||
"Insert a new cahe row with key `key'"
|
"Insert a new cahe row with key `key'"
|
||||||
(if (cache-get key)
|
(if (cache-get key)
|
||||||
(with-db-transaction
|
(with-db-transaction
|
||||||
|
@ -2730,8 +2731,8 @@ conversation removed (default: remove)"
|
||||||
(with-db-transaction
|
(with-db-transaction
|
||||||
(with-db-current-timestamp (now)
|
(with-db-current-timestamp (now)
|
||||||
(query (make-insert +table-cache+
|
(query (make-insert +table-cache+
|
||||||
(:key :created-at :accessed-at)
|
(:key :type :created-at :accessed-at)
|
||||||
(key now now)))
|
(key type now now)))
|
||||||
(last-inserted-rowid)))))
|
(last-inserted-rowid)))))
|
||||||
|
|
||||||
(defun cache-get (key)
|
(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)))
|
(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
|
"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)))
|
(let ((row (cache-get key)))
|
||||||
(if (null row)
|
(if (null row)
|
||||||
t
|
t
|
||||||
|
@ -2777,3 +2778,14 @@ than `days-in-the-past' days (default: `(swconf:config-purge-cage-days-offset)'"
|
||||||
|
|
||||||
(defun tofu-delete (host)
|
(defun tofu-delete (host)
|
||||||
(query (delete-from +table-gemini-tofu-cert+ (where (:= :host 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+)))
|
||||||
|
|
|
@ -360,7 +360,10 @@
|
||||||
(%fill-buffer)))))))
|
(%fill-buffer)))))))
|
||||||
(%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)))
|
(let ((parsed-uri (quri:uri url)))
|
||||||
(maybe-initialize-metadata specials:*message-window*)
|
(maybe-initialize-metadata specials:*message-window*)
|
||||||
(if (null parsed-uri)
|
(if (null parsed-uri)
|
||||||
|
@ -408,8 +411,9 @@
|
||||||
(multiple-value-bind (status code-description meta response socket)
|
(multiple-value-bind (status code-description meta response socket)
|
||||||
(gemini-client:request host
|
(gemini-client:request host
|
||||||
path
|
path
|
||||||
:query query
|
:client-certificate certificate
|
||||||
:port port)
|
:query query
|
||||||
|
:port port)
|
||||||
(add-url-to-history specials:*message-window* actual-uri)
|
(add-url-to-history specials:*message-window* actual-uri)
|
||||||
(cond
|
(cond
|
||||||
((gemini-client:response-redirect-p status)
|
((gemini-client:response-redirect-p status)
|
||||||
|
@ -427,6 +431,14 @@
|
||||||
(format nil
|
(format nil
|
||||||
(_ "Redirects to ~s, follows redirect? [y/N] ")
|
(_ "Redirects to ~s, follows redirect? [y/N] ")
|
||||||
meta))))
|
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)
|
((gemini-client:response-input-p status)
|
||||||
(get-user-input nil host meta))
|
(get-user-input nil host meta))
|
||||||
((gemini-client:response-sensitive-input-p status)
|
((gemini-client:response-sensitive-input-p status)
|
||||||
|
|
|
@ -125,14 +125,23 @@
|
||||||
(header-code= header +53+)
|
(header-code= header +53+)
|
||||||
(header-code= header +59+)))
|
(header-code= header +59+)))
|
||||||
|
|
||||||
(defun header-not-implemented-p (header)
|
(defun header-certificate-failure-p (header)
|
||||||
(or (header-code= header +60+)
|
(or (header-code= header +61+)
|
||||||
(header-code= header +61+)
|
|
||||||
(header-code= header +62+)))
|
(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)
|
(defun response-input-p (code)
|
||||||
(code= code +10+))
|
(code= code +10+))
|
||||||
|
|
||||||
|
(defun response-certificate-requested-p (code)
|
||||||
|
(code= code +60+))
|
||||||
|
|
||||||
(defun response-sensitive-input-p (code)
|
(defun response-sensitive-input-p (code)
|
||||||
(code= code +11+))
|
(code= code +11+))
|
||||||
|
|
||||||
|
@ -245,17 +254,19 @@
|
||||||
meta
|
meta
|
||||||
stream))
|
stream))
|
||||||
((or (header-input-request-p parsed-header)
|
((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))
|
(results (find-code-class status-code) nil))
|
||||||
((or (header-permanent-failure-p parsed-header)
|
((or (header-permanent-failure-p parsed-header)
|
||||||
(header-temporary-failure-p parsed-header))
|
(header-temporary-failure-p parsed-header)
|
||||||
|
(header-certificate-failure-p parsed-header))
|
||||||
(let ((response-code (find-code-class status-code)))
|
(let ((response-code (find-code-class status-code)))
|
||||||
(error 'gemini-protocol-error
|
(error 'gemini-protocol-error
|
||||||
:error-code (code response-code)
|
:error-code (code response-code)
|
||||||
:error-description (description response-code))))
|
:error-description (description response-code))))
|
||||||
((header-not-implemented-p parsed-header)
|
;; ((header-not-implemented-p parsed-header)
|
||||||
(error 'conditions:not-implemented-error
|
;; (error 'conditions:not-implemented-error
|
||||||
:text (_ "The server requested a certificate but client validation is not implemented by this program")))
|
;; :text (_ "The server requested a certificate but client validation is not implemented by this program")))
|
||||||
(t
|
(t
|
||||||
parsed-header))))))
|
parsed-header))))))
|
||||||
|
|
||||||
|
@ -265,7 +276,16 @@
|
||||||
(defun close-ssl-socket (socket)
|
(defun close-ssl-socket (socket)
|
||||||
(usocket:socket-close 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))
|
(let* ((uri (make-gemini-uri host path query port))
|
||||||
(ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-none+)))
|
(ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-none+)))
|
||||||
(when query
|
(when query
|
||||||
|
@ -274,14 +294,15 @@
|
||||||
(let ((socket (usocket:socket-connect host port :element-type '(unsigned-byte 8))))
|
(let ((socket (usocket:socket-connect host port :element-type '(unsigned-byte 8))))
|
||||||
(unwind-protect
|
(unwind-protect
|
||||||
(when socket
|
(when socket
|
||||||
(let ((stream (usocket:socket-stream socket)))
|
(let* ((stream (usocket:socket-stream socket))
|
||||||
(let* ((ssl-stream (cl+ssl:make-ssl-client-stream stream
|
(ssl-stream (cl+ssl:make-ssl-client-stream stream
|
||||||
:external-format nil
|
:certificate client-certificate
|
||||||
:unwrap-stream-p t
|
:external-format nil
|
||||||
:verify nil
|
:unwrap-stream-p t
|
||||||
:hostname host))
|
:verify nil
|
||||||
(request (format nil "~a~a~a" uri #\return #\newline))
|
:hostname host))
|
||||||
(cert-hash (crypto-shortcuts:sha512 (x509:dump-certificate ssl-stream))))
|
(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))
|
(if (not (db:tofu-passes-p host cert-hash))
|
||||||
(error 'gemini-tofu-error :host host)
|
(error 'gemini-tofu-error :host host)
|
||||||
(progn
|
(progn
|
||||||
|
@ -289,4 +310,4 @@
|
||||||
(force-output ssl-stream)
|
(force-output ssl-stream)
|
||||||
(multiple-value-bind (status description meta response)
|
(multiple-value-bind (status description meta response)
|
||||||
(parse-response ssl-stream)
|
(parse-response ssl-stream)
|
||||||
(values status description meta response socket))))))))))))
|
(values status description meta response socket)))))))))))
|
||||||
|
|
|
@ -87,6 +87,7 @@
|
||||||
:gemini-tofu-error
|
:gemini-tofu-error
|
||||||
:make-gemini-file-response
|
:make-gemini-file-response
|
||||||
:host
|
:host
|
||||||
|
:response-certificate-requested-p
|
||||||
:response-input-p
|
:response-input-p
|
||||||
:response-sensitive-input-p
|
:response-sensitive-input-p
|
||||||
:response-redirect-p
|
:response-redirect-p
|
||||||
|
@ -104,4 +105,5 @@
|
||||||
:text-rendering-theme
|
:text-rendering-theme
|
||||||
:gemini-file-response-p
|
:gemini-file-response-p
|
||||||
:close-ssl-socket
|
:close-ssl-socket
|
||||||
|
:make-client-certificate
|
||||||
:request))
|
:request))
|
||||||
|
|
|
@ -26,6 +26,10 @@
|
||||||
"cpuinfo")
|
"cpuinfo")
|
||||||
:test #'string=)
|
: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))
|
(declaim (ftype (function () fixnum) cpu-number))
|
||||||
|
|
||||||
(defun cpu-number ()
|
(defun cpu-number ()
|
||||||
|
@ -40,7 +44,7 @@
|
||||||
(incf cpu-count)))))
|
(incf cpu-count)))))
|
||||||
|
|
||||||
(defun xdg-open (file)
|
(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))
|
:output nil))
|
||||||
|
|
||||||
(defun getenv (name)
|
(defun getenv (name)
|
||||||
|
@ -68,7 +72,7 @@
|
||||||
(multiple-value-bind (exe args)
|
(multiple-value-bind (exe args)
|
||||||
(external-editor)
|
(external-editor)
|
||||||
(let ((actual-args (if args
|
(let ((actual-args (if args
|
||||||
(list args)
|
(list (text-utils:split-words args))
|
||||||
nil)))
|
nil)))
|
||||||
(sb-ext:run-program exe
|
(sb-ext:run-program exe
|
||||||
(append actual-args
|
(append actual-args
|
||||||
|
@ -88,3 +92,17 @@
|
||||||
|
|
||||||
(defun cached-file-path (filename)
|
(defun cached-file-path (filename)
|
||||||
(text-utils:strcat (user-cache-dir) fs:*directory-sep* 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)))
|
||||||
|
|
|
@ -24,7 +24,8 @@
|
||||||
:+program-name+
|
:+program-name+
|
||||||
:+program-version+
|
:+program-version+
|
||||||
:+issue-tracker+
|
:+issue-tracker+
|
||||||
:+home-data-dir+
|
:+openssl-bin+
|
||||||
|
:+xdg-open-bin+
|
||||||
:_
|
:_
|
||||||
:n_))
|
:n_))
|
||||||
|
|
||||||
|
@ -49,7 +50,8 @@
|
||||||
:+status-direct-visibility+
|
:+status-direct-visibility+
|
||||||
:+folder-direct-message-prefix+
|
:+folder-direct-message-prefix+
|
||||||
:+folder-tag-prefix+
|
:+folder-tag-prefix+
|
||||||
:+mention-prefix+))
|
:+mention-prefix+
|
||||||
|
:+cache-tls-certificate-type+))
|
||||||
|
|
||||||
(defpackage :conditions
|
(defpackage :conditions
|
||||||
(:use :cl
|
(:use :cl
|
||||||
|
@ -308,6 +310,8 @@
|
||||||
:config
|
:config
|
||||||
:constants)
|
:constants)
|
||||||
(:export
|
(:export
|
||||||
|
:+ssl-cert-name+
|
||||||
|
:+ssl-key-name+
|
||||||
:cpu-number
|
:cpu-number
|
||||||
:xdg-open
|
:xdg-open
|
||||||
:getenv
|
:getenv
|
||||||
|
@ -315,7 +319,8 @@
|
||||||
:open-with-editor
|
:open-with-editor
|
||||||
:exit-program
|
:exit-program
|
||||||
:user-cache-dir
|
:user-cache-dir
|
||||||
:cached-file-path))
|
:cached-file-path
|
||||||
|
:generate-ssl-certificate))
|
||||||
|
|
||||||
(defpackage :text-utils
|
(defpackage :text-utils
|
||||||
(:use
|
(:use
|
||||||
|
@ -882,7 +887,8 @@
|
||||||
:cache-get-value
|
:cache-get-value
|
||||||
:cache-expired-p
|
:cache-expired-p
|
||||||
:tofu-passes-p
|
:tofu-passes-p
|
||||||
:tofu-delete))
|
:tofu-delete
|
||||||
|
:ssl-cert-find))
|
||||||
|
|
||||||
(defpackage :date-formatter
|
(defpackage :date-formatter
|
||||||
(:use
|
(:use
|
||||||
|
|
Loading…
Reference in New Issue