mirror of https://codeberg.org/cage/tinmop/
- implemented titan protocol;
- [TUI] added titan requests; - [GUI] fixed crash when opening the gemlog windows after refreshed the gemlogs data.
This commit is contained in:
cage
parent
ee34c9669d
commit
e1f185c439
|
|
@ -286,6 +286,7 @@ ECHO_T = @ECHO_T@
|
|||
EGREP = @EGREP@
|
||||
ETAGS = @ETAGS@
|
||||
EXEEXT = @EXEEXT@
|
||||
FILE = @FILE@
|
||||
GETTEXT_MACRO_VERSION = @GETTEXT_MACRO_VERSION@
|
||||
GIT = @GIT@
|
||||
GMSGFMT = @GMSGFMT@
|
||||
|
|
|
|||
|
|
@ -621,6 +621,7 @@ ac_subst_vars='am__EXEEXT_FALSE
|
|||
am__EXEEXT_TRUE
|
||||
LTLIBOBJS
|
||||
LIBOBJS
|
||||
FILE
|
||||
MONTAGE
|
||||
DIRNAME
|
||||
CHMOD
|
||||
|
|
@ -7684,6 +7685,64 @@ printf "%s\n" "$as_me: WARNING: Can not find imagemagick 'montage' executable."
|
|||
exit 1;
|
||||
fi
|
||||
|
||||
for ac_prog in montage
|
||||
do
|
||||
# Extract the first word of "$ac_prog", so it can be a program name with args.
|
||||
set dummy $ac_prog; ac_word=$2
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
|
||||
printf %s "checking for $ac_word... " >&6; }
|
||||
if test ${ac_cv_path_FILE+y}
|
||||
then :
|
||||
printf %s "(cached) " >&6
|
||||
else $as_nop
|
||||
case $FILE in
|
||||
[\\/]* | ?:[\\/]*)
|
||||
ac_cv_path_FILE="$FILE" # 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
|
||||
case $as_dir in #(((
|
||||
'') as_dir=./ ;;
|
||||
*/) ;;
|
||||
*) as_dir=$as_dir/ ;;
|
||||
esac
|
||||
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_FILE="$as_dir$ac_word$ac_exec_ext"
|
||||
printf "%s\n" "$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
|
||||
FILE=$ac_cv_path_FILE
|
||||
if test -n "$FILE"; then
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $FILE" >&5
|
||||
printf "%s\n" "$FILE" >&6; }
|
||||
else
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
|
||||
printf "%s\n" "no" >&6; }
|
||||
fi
|
||||
|
||||
|
||||
test -n "$FILE" && break
|
||||
done
|
||||
test -n "$FILE" || FILE="no"
|
||||
|
||||
|
||||
if test "$FILE" = "no" ; then
|
||||
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Can not find 'file' executable." >&5
|
||||
printf "%s\n" "$as_me: WARNING: Can not find 'file' executable." >&2;}
|
||||
exit 1;
|
||||
fi
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -130,6 +130,13 @@ if test "$MONTAGE" = "no" ; then
|
|||
exit 1;
|
||||
fi
|
||||
|
||||
AC_PATH_PROGS([FILE],[montage],[no])
|
||||
|
||||
if test "$FILE" = "no" ; then
|
||||
AC_MSG_WARN([Can not find 'file' executable.])
|
||||
exit 1;
|
||||
fi
|
||||
|
||||
AC_PROG_MKDIR_P
|
||||
|
||||
dnl checks for libraries
|
||||
|
|
|
|||
|
|
@ -34,6 +34,8 @@
|
|||
|
||||
(alexandria:define-constant +montage-bin+ "@MONTAGE@" :test #'string=)
|
||||
|
||||
(alexandria:define-constant +file-bin+ "@FILE@" :test #'string=)
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
|
||||
(defun allow-features (test-value feature-keyword)
|
||||
|
|
|
|||
41
src/db.lisp
41
src/db.lisp
|
|
@ -134,6 +134,9 @@
|
|||
(define-constant +table-gempub-metadata+ :gempub-metadata
|
||||
:test #'eq)
|
||||
|
||||
(define-constant +table-titan-token+ :titan-token
|
||||
:test #'eq)
|
||||
|
||||
(define-constant +bookmark-gemini-type-entry+ "gemini"
|
||||
:test #'string=)
|
||||
|
||||
|
|
@ -608,6 +611,15 @@
|
|||
" \"created-at\" TEXT NOT NULL"
|
||||
+make-close+)))
|
||||
|
||||
(defun make-titan-token ()
|
||||
(query-low-level (strcat (prepare-table +table-titan-token+
|
||||
:autogenerated-id-p t
|
||||
:autoincrementp t)
|
||||
"url TEXT NOT NULL,"
|
||||
"token TEXT NOT NULL,"
|
||||
"UNIQUE(url) ON CONFLICT FAIL"
|
||||
+make-close+)))
|
||||
|
||||
(defun build-all-indices ()
|
||||
(create-table-index +table-status+ '(:folder :timeline :status-id))
|
||||
(create-table-index +table-account+ '(:id :acct))
|
||||
|
|
@ -622,7 +634,8 @@
|
|||
(create-table-index +table-gemini-subscription+ '(:url))
|
||||
(create-table-index +table-gemlog-entries+ '(:url))
|
||||
(create-table-index +table-bookmark+ '(:type :section :value))
|
||||
(create-table-index +table-gempub-metadata+ '(:local-uri)))
|
||||
(create-table-index +table-gempub-metadata+ '(:local-uri))
|
||||
(create-table-index +table-titan-token+ '(:url)))
|
||||
|
||||
(defmacro gen-delete (suffix &rest names)
|
||||
`(progn
|
||||
|
|
@ -651,7 +664,8 @@
|
|||
+table-gemini-subscription+
|
||||
+table-gemlog-entries+
|
||||
+table-bookmark+
|
||||
+table-gempub-metadata+))
|
||||
+table-gempub-metadata+
|
||||
+table-titan-token+))
|
||||
|
||||
(defun build-views ())
|
||||
|
||||
|
|
@ -687,6 +701,7 @@
|
|||
(make-gemlog-entries)
|
||||
(make-bookmark)
|
||||
(make-gempub-metadata)
|
||||
(make-titan-token)
|
||||
(build-all-indices)
|
||||
(fs:set-file-permissions (db-path) (logior fs:+s-irusr+ fs:+s-iwusr+))))
|
||||
|
||||
|
|
@ -1865,6 +1880,8 @@ row."
|
|||
|
||||
(gen-access-message-row url :url)
|
||||
|
||||
(gen-access-message-row token :token)
|
||||
|
||||
(gen-access-message-row expire-date :expire-date)
|
||||
|
||||
(gen-access-message-row chat-id :chat-id)
|
||||
|
|
@ -2975,7 +2992,7 @@ conversation removed (default: remove)"
|
|||
(second data)))
|
||||
|
||||
(defun cache-touch (key)
|
||||
"Update the existing cache row accessing time to current time."
|
||||
"Update the column \"accessed-at\" of an existingcache row to current time."
|
||||
(with-db-current-timestamp (now)
|
||||
(query (make-update +table-cache+
|
||||
(:accessed-at)
|
||||
|
|
@ -3001,6 +3018,13 @@ conversation removed (default: remove)"
|
|||
(from :cache)
|
||||
(where (:= :key key)))))
|
||||
|
||||
(defun cache-get-key-type (key type)
|
||||
"Get cache row identified by `key'"
|
||||
(fetch-single (select :*
|
||||
(from :cache)
|
||||
(where (:and (:= :key key)
|
||||
(:= :type type))))))
|
||||
|
||||
(defun cache-get-value (key)
|
||||
"Get cache value identified by `key'"
|
||||
(row-id (cache-get key)))
|
||||
|
|
@ -3025,6 +3049,17 @@ than `days-in-the-past' days (default: `(swconf:config-purge-cache-days-offset)'
|
|||
(defun cache-delete-all ()
|
||||
(query (make-delete +table-cache+)))
|
||||
|
||||
(defun saved-titan-token (url)
|
||||
(row-token (fetch-single (select :*
|
||||
(from :titan-token)
|
||||
(where (:= :url url))))))
|
||||
|
||||
(defun save-titan-token (url token)
|
||||
(query (delete-from +table-titan-token+ (where (:= :url url))))
|
||||
(query (make-insert +table-titan-token+
|
||||
(:url :token)
|
||||
(url token))))
|
||||
|
||||
(defun tofu-passes-p (host hash)
|
||||
(let ((known-host (fetch-single (select :*
|
||||
(from +table-gemini-tofu-cert+)
|
||||
|
|
|
|||
|
|
@ -578,7 +578,6 @@
|
|||
|
||||
(defun request-success-dispatched-clrs (enqueue)
|
||||
(lambda (status code-description meta response socket iri parsed-iri)
|
||||
(declare (ignore iri))
|
||||
(labels ((starting-status (meta)
|
||||
(if (or (gemini-client:gemini-file-stream-p meta)
|
||||
(gemini-client:text-file-stream-p meta))
|
||||
|
|
@ -626,6 +625,8 @@
|
|||
query
|
||||
fragment))))
|
||||
(cond
|
||||
((gemini-client:absolute-titan-url-p iri)
|
||||
(gemini-client:debug-gemini "response from titan nothing to do"))
|
||||
((gemini-client:gemini-file-stream-p meta)
|
||||
(gemini-client:debug-gemini "response is a gemini document stream")
|
||||
(push-url-to-history specials:*message-window* actual-iri)
|
||||
|
|
@ -671,6 +672,10 @@
|
|||
fragment)))))))))
|
||||
|
||||
(defun request (url &key
|
||||
(titan-data nil)
|
||||
(titan-mime nil)
|
||||
(titan-size nil)
|
||||
(titan-token nil)
|
||||
(enqueue nil)
|
||||
(certificate nil)
|
||||
(certificate-key nil)
|
||||
|
|
@ -742,7 +747,10 @@
|
|||
:enqueue enqueue
|
||||
:do-nothing-if-exists-in-db do-nothing-if-exists-in-db
|
||||
:certificate-key cached-key
|
||||
:certificate cached-certificate))))
|
||||
:certificate cached-certificate)))
|
||||
(titan-upload-dispatch (url)
|
||||
(declare (ignore url))
|
||||
(values titan-data titan-size titan-mime titan-token)))
|
||||
(handler-case
|
||||
(gemini-client:with-request-dispatch-table ((:certificate-requested
|
||||
#'certificate-request-dispatch
|
||||
|
|
@ -753,8 +761,10 @@
|
|||
:redirect
|
||||
#'redirect-dispatch
|
||||
:success
|
||||
(request-success-dispatched-clrs enqueue))
|
||||
:ignore-warning nil)
|
||||
(request-success-dispatched-clrs enqueue)
|
||||
:titan-upload
|
||||
#'titan-upload-dispatch)
|
||||
:ignore-warning nil)
|
||||
(gemini-client:debug-gemini "viewer requesting iri ~s" url)
|
||||
(maybe-initialize-metadata specials:*message-window*)
|
||||
(let ((actual-iri (gemini-client:displace-iri (iri:iri-parse url))))
|
||||
|
|
@ -909,3 +919,13 @@ executed."
|
|||
:enqueue enqueue
|
||||
:url url)))
|
||||
(program-events:push-event event)))
|
||||
|
||||
(defun post-titan-url (url data size mime token)
|
||||
(let* ((event (make-instance 'program-events:titan-post-event
|
||||
:data data
|
||||
:data data
|
||||
:size size
|
||||
:mime mime
|
||||
:token token
|
||||
:url url)))
|
||||
(program-events:push-event event)))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;; tinmop: an humble gemini and pleroma client
|
||||
;; Copyright (C) 2020 cage
|
||||
;; Copyright © 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
|
||||
|
|
@ -358,8 +358,14 @@
|
|||
parsed-header))))))
|
||||
|
||||
(defun absolute-gemini-url-p (url)
|
||||
(when-let ((iri (iri:iri-parse url :null-on-error t)))
|
||||
(string= (uri:scheme iri) +gemini-scheme+)))
|
||||
(iri:absolute-url-scheme-p url +gemini-scheme+))
|
||||
|
||||
(defun absolute-titan-url-p (url)
|
||||
(iri:absolute-url-scheme-p url +titan-scheme+))
|
||||
|
||||
(defun absolute-gemini-or-titan-url-p (url)
|
||||
(or (absolute-gemini-url-p url)
|
||||
(absolute-titan-url-p url)))
|
||||
|
||||
(defun close-ssl-socket (socket)
|
||||
(usocket:socket-close socket))
|
||||
|
|
@ -470,49 +476,95 @@
|
|||
"received an unknown response from server ~s ~a ~s ~s"
|
||||
iri status code-description meta))))
|
||||
|
||||
(defun request-dispatch (url manage-functions &key (certificate nil) (certificate-key nil))
|
||||
(let ((parsed-iri (iri:iri-parse url)))
|
||||
(multiple-value-bind (actual-iri host path query port)
|
||||
(displace-iri parsed-iri)
|
||||
(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
|
||||
:fragment nil)
|
||||
(flet ((call-appropriate-function (response-type)
|
||||
(funcall (getf manage-functions
|
||||
response-type
|
||||
#'missing-dispath-function)
|
||||
status
|
||||
code-description
|
||||
meta
|
||||
response
|
||||
socket
|
||||
actual-iri
|
||||
parsed-iri)))
|
||||
(cond
|
||||
((gemini-client:response-redirect-p status)
|
||||
(call-appropriate-function :redirect))
|
||||
((gemini-client:response-certificate-requested-p status)
|
||||
(call-appropriate-function :certificate-requested))
|
||||
((gemini-client:response-success-p status)
|
||||
(call-appropriate-function :success))
|
||||
((gemini-client:response-input-p status)
|
||||
(call-appropriate-function :input-requested))
|
||||
((gemini-client:response-sensitive-input-p status)
|
||||
(call-appropriate-function :sensitive-input-requested))
|
||||
(t
|
||||
(call-appropriate-function :fallback))))))))
|
||||
(defun start-titan-request (url data mime-type size token &key (certificate nil) (certificate-key nil))
|
||||
(multiple-value-bind (actual-iri host path query port)
|
||||
(displace-iri (iri:iri-parse url))
|
||||
(declare (ignore actual-iri))
|
||||
(cond
|
||||
((and mime-type size)
|
||||
(multiple-value-bind (status description meta response socket)
|
||||
(gemini-client:titan-request host
|
||||
path
|
||||
mime-type
|
||||
size
|
||||
token
|
||||
data
|
||||
:port port
|
||||
:certificate-key certificate-key
|
||||
:client-certificate certificate)
|
||||
(close-ssl-socket socket)
|
||||
(values status description meta response socket)))
|
||||
((null mime-type)
|
||||
(error "mime type not present in ~a" query))
|
||||
((null size)
|
||||
(error "mime type not present or invalid in ~a" query)))))
|
||||
|
||||
(defun request-dispatch (url manage-functions
|
||||
&key
|
||||
(certificate nil)
|
||||
(certificate-key nil))
|
||||
(flet ((make-titan-request ()
|
||||
(multiple-value-bind (titan-data size mime token)
|
||||
(funcall (getf manage-functions :titan-upload
|
||||
(lambda (url)
|
||||
(declare (ignore url))
|
||||
(error
|
||||
(make-condition 'conditions:not-implemented-error
|
||||
:text
|
||||
"No function to get titan data provided"))))
|
||||
url)
|
||||
(start-titan-request url
|
||||
titan-data
|
||||
mime
|
||||
size
|
||||
token
|
||||
:certificate certificate
|
||||
:certificate-key certificate-key))))
|
||||
(let ((parsed-iri (iri:iri-parse url)))
|
||||
(multiple-value-bind (actual-iri host path query port)
|
||||
(displace-iri parsed-iri)
|
||||
(multiple-value-bind (status code-description meta response socket)
|
||||
(if (absolute-titan-url-p url)
|
||||
(make-titan-request)
|
||||
(gemini-client:request host
|
||||
path
|
||||
:certificate-key certificate-key
|
||||
:client-certificate certificate
|
||||
:query query
|
||||
:port port
|
||||
:fragment nil))
|
||||
(flet ((call-appropriate-function (response-type)
|
||||
(funcall (getf manage-functions
|
||||
response-type
|
||||
#'missing-dispath-function)
|
||||
status
|
||||
code-description
|
||||
meta
|
||||
response
|
||||
socket
|
||||
actual-iri
|
||||
parsed-iri)))
|
||||
(cond
|
||||
((gemini-client:response-redirect-p status)
|
||||
(call-appropriate-function :redirect))
|
||||
((gemini-client:response-certificate-requested-p status)
|
||||
(call-appropriate-function :certificate-requested))
|
||||
((gemini-client:response-success-p status)
|
||||
(call-appropriate-function :success))
|
||||
((gemini-client:response-input-p status)
|
||||
(call-appropriate-function :input-requested))
|
||||
((gemini-client:response-sensitive-input-p status)
|
||||
(call-appropriate-function :sensitive-input-requested))
|
||||
(t
|
||||
(call-appropriate-function :fallback)))))))))
|
||||
|
||||
(define-constant +allowed-dispatch-keys+ '(:redirect
|
||||
:certificate-requested
|
||||
:success
|
||||
:input-requested
|
||||
:sensitive-input-requested
|
||||
:fallback)
|
||||
:fallback
|
||||
:titan-upload)
|
||||
:test #'equalp)
|
||||
|
||||
(defmacro with-request-dispatch-table ((table &key (ignore-warning nil)) &body body)
|
||||
|
|
@ -528,6 +580,8 @@
|
|||
(warn (format nil
|
||||
"found unkown keys in dispatch-table table: ~s"
|
||||
unknown-keys)))
|
||||
(when (null (getf table :titan-upload))
|
||||
(warn "No dispatch for titan upload found"))
|
||||
(when (null (getf table :redirect))
|
||||
(warn "No dispatch for redirect found"))
|
||||
(when (null (getf table :certificate-requested))
|
||||
|
|
|
|||
|
|
@ -20,3 +20,5 @@
|
|||
(define-constant +gemini-scheme+ "gemini" :test #'string=)
|
||||
|
||||
(define-constant +gemini-default-port+ 1965 :test #'=)
|
||||
|
||||
(define-constant +titan-scheme+ "titan" :test #'string=)
|
||||
|
|
|
|||
|
|
@ -20,6 +20,7 @@
|
|||
:alexandria)
|
||||
(:export
|
||||
:+gemini-scheme+
|
||||
:+titan-scheme+
|
||||
:+gemini-default-port+))
|
||||
|
||||
(defpackage :gemini-parser
|
||||
|
|
@ -38,6 +39,7 @@
|
|||
(:shadowing-import-from :misc :random-elt :shuffle)
|
||||
(:export
|
||||
:+gemini-scheme+
|
||||
:+titan-scheme+
|
||||
:+preformatted-prefix+
|
||||
:+max-header-level+
|
||||
:*raw-mode-data*
|
||||
|
|
@ -168,6 +170,8 @@
|
|||
:response-redirect-p
|
||||
:response-success-p
|
||||
:absolute-gemini-url-p
|
||||
:absolute-titan-url-p
|
||||
:absolute-gemini-or-titan-url-p
|
||||
:init-default-gemini-theme
|
||||
:gemini-file-response
|
||||
:status-code
|
||||
|
|
@ -186,6 +190,7 @@
|
|||
:debug-gemini
|
||||
:open-tls-socket
|
||||
:request
|
||||
:titan-request
|
||||
:gemini-file-stream-p
|
||||
:text-file-stream-p
|
||||
:request-dispatch
|
||||
|
|
|
|||
|
|
@ -0,0 +1,162 @@
|
|||
;; tinmop: an humble gemini and pleroma client
|
||||
;; Copyright © 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-client)
|
||||
|
||||
(define-constant +chunk-buffer-size+ 2048 :test #'=
|
||||
:documentation "Chunk's size of the buffer when writing to titan")
|
||||
|
||||
(define-constant +titan-mime-key+ "mime" :test #'string=)
|
||||
|
||||
(define-constant +titan-size-key+ "size" :test #'string=)
|
||||
|
||||
(define-constant +titan-token-key+ "token" :test #'string=)
|
||||
|
||||
(define-constant +titan-field-separator+ "=" :test #'string=)
|
||||
|
||||
(define-constant +titan-records-separator+ ";" :test #'string=)
|
||||
|
||||
(defun make-titan-query (mime-type size token)
|
||||
(format nil
|
||||
"~a~a~a~a~a~a~a~3*~@[~3:*~a~a~a~a~]"
|
||||
+titan-mime-key+ +titan-field-separator+ mime-type +titan-records-separator+
|
||||
+titan-size-key+ +titan-field-separator+ size +titan-records-separator+
|
||||
+titan-token-key+ +titan-field-separator+ token))
|
||||
|
||||
(defun parse-titan-query (query)
|
||||
(flet ((get-value (key)
|
||||
(multiple-value-bind (matchedp registers)
|
||||
(scan-to-strings (format nil
|
||||
"~a~a([^~a]+)~a?"
|
||||
key
|
||||
+titan-field-separator+
|
||||
+titan-records-separator+
|
||||
+titan-records-separator+)
|
||||
query)
|
||||
(when matchedp
|
||||
(first-elt registers)))))
|
||||
(let ((raw-size (get-value +titan-size-key+)))
|
||||
(values (get-value +titan-mime-key+)
|
||||
(parse-integer raw-size)
|
||||
(get-value +titan-token-key+)))))
|
||||
|
||||
(defgeneric titan-request (host path mime-type size token data
|
||||
&key port fragment client-certificate certificate-key))
|
||||
|
||||
(defmethod titan-request (host path mime-type (size integer) token (data sequence)
|
||||
&key
|
||||
(port +gemini-default-port+)
|
||||
(fragment nil)
|
||||
(client-certificate nil)
|
||||
(certificate-key nil))
|
||||
(flex:with-input-from-sequence (stream data)
|
||||
(titan-request host
|
||||
path
|
||||
mime-type
|
||||
size
|
||||
token
|
||||
stream
|
||||
:port port
|
||||
:fragment fragment
|
||||
:client-certificate client-certificate
|
||||
:certificate-key certificate-key)))
|
||||
|
||||
(defmethod titan-request (host path mime-type (size integer) token (data pathname)
|
||||
&key
|
||||
(port +gemini-default-port+)
|
||||
(fragment nil)
|
||||
(client-certificate nil)
|
||||
(certificate-key nil))
|
||||
(with-open-file (stream
|
||||
data
|
||||
:direction :input
|
||||
:if-does-not-exist :error
|
||||
:element-type constants:+octect-type+)
|
||||
(titan-request host
|
||||
path
|
||||
mime-type
|
||||
size
|
||||
token
|
||||
stream
|
||||
:port port
|
||||
:fragment fragment
|
||||
:client-certificate client-certificate
|
||||
:certificate-key certificate-key)))
|
||||
|
||||
(defmethod titan-request (host path mime-type (size integer) token (data stream)
|
||||
&key
|
||||
(port +gemini-default-port+)
|
||||
(fragment nil)
|
||||
(client-certificate nil)
|
||||
(certificate-key nil))
|
||||
(let* ((iri (make-gemini-iri (idn:host-unicode->ascii host)
|
||||
(percent-encode-path path)
|
||||
:query (percent-encode-query (make-titan-query mime-type
|
||||
size
|
||||
token))
|
||||
:port port
|
||||
:fragment (percent-encode-fragment fragment)))
|
||||
(ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-none+)))
|
||||
(cl+ssl:with-global-context (ctx :auto-free-p t)
|
||||
(let ((socket (open-tls-socket host port)))
|
||||
(hooks:run-hooks 'hooks:*after-titan-socket*)
|
||||
(let* ((stream (usocket:socket-stream socket))
|
||||
(ssl-hostname (if (or (iri:ipv4-address-p host)
|
||||
(iri:ipv6-address-p host))
|
||||
nil
|
||||
host))
|
||||
(ssl-stream (cl+ssl:make-ssl-client-stream stream
|
||||
:certificate client-certificate
|
||||
:key certificate-key
|
||||
:external-format nil ; unsigned byte 8
|
||||
:unwrap-stream-p t
|
||||
:verify nil
|
||||
:hostname ssl-hostname))
|
||||
(request (format nil "~a~a~a" iri #\return #\newline))
|
||||
(cert-hash (crypto-shortcuts:sha512 (x509:dump-certificate ssl-stream))))
|
||||
(debug-gemini "sending titan request ~a" request)
|
||||
(if (not (db:tofu-passes-p host cert-hash))
|
||||
(error 'gemini-tofu-error :host host)
|
||||
(handler-case
|
||||
(progn
|
||||
(write-sequence (string->octets request) ssl-stream)
|
||||
(force-output ssl-stream)
|
||||
(read-stream-chunks data
|
||||
+chunk-buffer-size+
|
||||
(lambda (buffer read-so-far)
|
||||
(write-sequence (subseq buffer 0 read-so-far)
|
||||
ssl-stream)
|
||||
(force-output ssl-stream)))
|
||||
(hooks:run-hooks 'hooks:*after-titan-request-sent*)
|
||||
(multiple-value-bind (status description meta response)
|
||||
(parse-response ssl-stream)
|
||||
(close-ssl-socket socket)
|
||||
(values status description meta response socket)))
|
||||
(error (e)
|
||||
(declare (ignore e))
|
||||
(handler-case
|
||||
(multiple-value-bind (status description meta response)
|
||||
(parse-response ssl-stream)
|
||||
(values status description meta response socket))
|
||||
(error (e)
|
||||
(values 50
|
||||
(format nil
|
||||
(_ "Connection prematurely closed from the server: ~a")
|
||||
e)
|
||||
nil
|
||||
nil
|
||||
socket)))))))))))
|
||||
|
|
@ -82,14 +82,16 @@
|
|||
(let ((new-rows (all-rows)))
|
||||
(resync-rows gemlog-frame new-rows)))))))
|
||||
|
||||
(defun refresh-gemlogs-clsr (gemlog-frame)
|
||||
(defun refresh-gemlogs-clsr (window gemlog-frame)
|
||||
(lambda ()
|
||||
(when (gui:children (gui-goodies:tree gemlog-frame) gui:+treeview-root+)
|
||||
(ev:with-enqueued-process-and-unblock ()
|
||||
(gui-goodies::with-notify-errors
|
||||
(comm:make-request :gemini-gemlog-refresh-all-subscriptions 1)
|
||||
(let ((new-rows (all-rows)))
|
||||
(resync-rows gemlog-frame new-rows)))))))
|
||||
(gui-goodies:with-busy* (window)
|
||||
(comm:make-request :gemini-gemlog-refresh-all-subscriptions 1)
|
||||
(client-main-window::print-info-message (_ "All gemlog refreshed")))))
|
||||
(let ((new-rows (all-rows)))
|
||||
(resync-rows gemlog-frame new-rows)))))
|
||||
|
||||
(defun open-gemlog-clsr (main-window treeview-gemlogs)
|
||||
(lambda (e)
|
||||
|
|
@ -123,7 +125,8 @@
|
|||
(refresh-button (make-instance 'gui:button
|
||||
:master buttons-frame
|
||||
:image icons:*refresh*
|
||||
:command (refresh-gemlogs-clsr table))))
|
||||
:command (refresh-gemlogs-clsr toplevel
|
||||
table))))
|
||||
(gui-goodies:attach-tooltips (unsubscribe-button (_ "unsubscribe from selected gemlog"))
|
||||
(refresh-button (_ "refresh all subscription")))
|
||||
(gui:grid table 0 0 :sticky :nwe)
|
||||
|
|
|
|||
|
|
@ -224,7 +224,7 @@
|
|||
#'redirect-dispatch
|
||||
:success
|
||||
#'request-success-dispatched-fn)
|
||||
:ignore-warning nil)
|
||||
:ignore-warning t)
|
||||
(debug-gemini-gui "viewer requesting iri ~s" url)
|
||||
(let ((actual-iri (gemini-client:displace-iri (iri:iri-parse url))))
|
||||
(db:gemlog-mark-as-seen actual-iri)
|
||||
|
|
|
|||
|
|
@ -133,3 +133,9 @@ open the links")
|
|||
|
||||
(defparameter *after-gemini-request-sent* '()
|
||||
"Run these hooks after a gemini request has been sent")
|
||||
|
||||
(defparameter *after-titan-socket* '()
|
||||
"Run these hooks after a titan socket has been estabilshed")
|
||||
|
||||
(defparameter *after-titan-request-sent* '()
|
||||
"Run these hooks after a titan request has been sent")
|
||||
|
|
|
|||
|
|
@ -363,6 +363,11 @@
|
|||
(not (or (null (uri:scheme iri))
|
||||
(null (uri:host iri))))))
|
||||
|
||||
(defun absolute-url-scheme-p (url expected-scheme)
|
||||
(when-let ((parsed-iri (iri:iri-parse url :null-on-error t)))
|
||||
(and (absolute-url-p url)
|
||||
(string= (uri:scheme parsed-iri) expected-scheme))))
|
||||
|
||||
(defun ipv4-address-p (string)
|
||||
(ignore-errors
|
||||
(let ((bytes (mapcar #'parse-integer
|
||||
|
|
|
|||
|
|
@ -488,6 +488,16 @@ to the array"
|
|||
(setf raw (reverse rev))))
|
||||
(misc:list->array raw '(unsigned-byte 8))))))
|
||||
|
||||
(defun read-stream-chunks (stream buffer-size processing-function)
|
||||
(let ((buffer (make-fresh-array buffer-size 0 '(unsigned-byte 8) t)))
|
||||
(labels ((read-chunk ()
|
||||
(declare (optimize (debug 0) (speed 3)))
|
||||
(let ((read-so-far (read-sequence buffer stream)))
|
||||
(funcall processing-function buffer read-so-far)
|
||||
(when (not (< read-so-far buffer-size))
|
||||
(read-chunk)))))
|
||||
(read-chunk))))
|
||||
|
||||
(define-condition delimiter-not-found (error)
|
||||
((delimiter
|
||||
:initarg :delimiter
|
||||
|
|
|
|||
|
|
@ -79,23 +79,48 @@
|
|||
(multiple-value-bind (host port type selector)
|
||||
(gopher-parser:parse-iri url)
|
||||
(gopher-window::make-request host port type selector))
|
||||
(let* ((parsed (iri:iri-parse url))
|
||||
(scheme (uri:scheme parsed))
|
||||
(decoded-path (if (percent-encoded-p url)
|
||||
(percent-decode url)
|
||||
url)))
|
||||
(let ((decoded-path (if (percent-encoded-p url)
|
||||
(percent-decode url)
|
||||
url)))
|
||||
(when (and (not enqueue)
|
||||
(swconf:close-link-window-after-select-p))
|
||||
(ui:close-open-message-link-window))
|
||||
(cond
|
||||
((string= gemini-constants:+gemini-scheme+ scheme)
|
||||
((gemini-client:absolute-gemini-or-titan-url-p url)
|
||||
(db:insert-in-history (ui:open-url-prompt) url)
|
||||
(db:gemlog-mark-as-seen url)
|
||||
(gemini-viewer:ensure-just-one-stream-rendering)
|
||||
(gemini-viewer:load-gemini-url url
|
||||
:give-focus-to-message-window t
|
||||
:enqueue enqueue
|
||||
:use-cached-file-if-exists t))
|
||||
(if (gemini-client:absolute-titan-url-p url)
|
||||
(let ((upload-file-path nil))
|
||||
(labels ((on-token-input-complete (token)
|
||||
(when (string-not-empty-p token)
|
||||
(db-utils:with-ready-database (:connect nil)
|
||||
(db:save-titan-token url token)
|
||||
(let ((size (fs:file-size upload-file-path))
|
||||
(mime (os-utils:file->mime-type upload-file-path)))
|
||||
(gemini-viewer::post-titan-url url
|
||||
upload-file-path
|
||||
size
|
||||
mime
|
||||
token)))))
|
||||
(on-file-input-complete (file-path)
|
||||
(db-utils:with-ready-database (:connect nil)
|
||||
(if (fs:file-exists-p file-path)
|
||||
(let ((path-file (fs:namestring->pathname file-path))
|
||||
(cached-token (db:saved-titan-token url)))
|
||||
(setf upload-file-path path-file)
|
||||
(ui:ask-string-input #'on-token-input-complete
|
||||
:initial-value cached-token
|
||||
:prompt
|
||||
(_ "type access token: ")))
|
||||
(error (_ "no such file: ~a") file-path)))))
|
||||
(ui:ask-string-input #'on-file-input-complete
|
||||
:prompt (_ "Upload: ")
|
||||
:complete-fn #'complete:directory-complete)))
|
||||
(gemini-viewer:load-gemini-url url
|
||||
:give-focus-to-message-window t
|
||||
:enqueue enqueue
|
||||
:use-cached-file-if-exists t)))
|
||||
((fs:dirp decoded-path)
|
||||
(ui:open-file-explorer decoded-path))
|
||||
(t
|
||||
|
|
|
|||
|
|
@ -108,6 +108,9 @@
|
|||
(defun process-exit-success-p (process)
|
||||
(= (process-exit-code process) 0))
|
||||
|
||||
(defun process-output-stream (process)
|
||||
(process-output process))
|
||||
|
||||
(defmacro gen-process-stream (name)
|
||||
`(defun ,(misc:format-fn-symbol t "process-~a" name) (process)
|
||||
(,(misc:format-fn-symbol 'sb-ext "process-~a" name) process)))
|
||||
|
|
@ -211,6 +214,22 @@
|
|||
(alexandria:when-let ((program (swconf:link-regex->program-to-use resource)))
|
||||
(swconf:use-tinmop-as-external-program-p program)))
|
||||
|
||||
(defgeneric file->mime-type (object))
|
||||
|
||||
(defmethod file->mime-type ((object string))
|
||||
(let ((process (run-external-program +file-bin+
|
||||
(list "-E" "--mime-type" "--brief" object)
|
||||
:search t
|
||||
:wait t
|
||||
:output :stream
|
||||
:error nil)))
|
||||
(if (process-exit-success-p process)
|
||||
(text-utils:trim-blanks (read-line (process-output-stream process)))
|
||||
nil)))
|
||||
|
||||
(defmethod file->mime-type ((object pathname))
|
||||
(file->mime-type (fs:pathname->namestring object)))
|
||||
|
||||
(defun unzip-file (zip-file destination-dir)
|
||||
(cond
|
||||
((not (fs:file-exists-p zip-file))
|
||||
|
|
|
|||
|
|
@ -38,6 +38,7 @@
|
|||
:+unzip-bin+
|
||||
:+man-bin+
|
||||
:+montage-bin+
|
||||
:+file-bin+
|
||||
:_
|
||||
:n_))
|
||||
|
||||
|
|
@ -202,6 +203,7 @@
|
|||
:read-array
|
||||
:read-all
|
||||
:read-line-into-array
|
||||
:read-stream-chunks
|
||||
:delimiter-not-found
|
||||
:*read-delimiter*
|
||||
:read-delimited-into-array
|
||||
|
|
@ -394,6 +396,7 @@
|
|||
:open-link-with-program
|
||||
:open-resource-with-external-program
|
||||
:open-resource-with-tinmop-p
|
||||
:file->mime-type
|
||||
:unzip-file
|
||||
:unzip-single-file
|
||||
:copy-to-clipboard))
|
||||
|
|
@ -761,6 +764,7 @@
|
|||
:remove-fragment
|
||||
:normalize-path
|
||||
:absolute-url-p
|
||||
:absolute-url-scheme-p
|
||||
:ipv4-address-p
|
||||
:ipv6-address-p
|
||||
:iri-to-parent-path))
|
||||
|
|
@ -959,6 +963,7 @@
|
|||
:row-title
|
||||
:row-subtitle
|
||||
:row-url
|
||||
:row-token
|
||||
:row-expire-date
|
||||
:row-account-id
|
||||
:row-updated-at
|
||||
|
|
@ -1091,9 +1096,12 @@
|
|||
:cache-invalidate
|
||||
:cache-put
|
||||
:cache-get
|
||||
:cache-get-key-type
|
||||
:cache-get-value
|
||||
:cache-expired-p
|
||||
:cache-delete-all
|
||||
:saved-titan-token
|
||||
:save-titan-token
|
||||
:tofu-passes-p
|
||||
:tofu-delete
|
||||
:find-tls-certificates-rows
|
||||
|
|
@ -1699,6 +1707,7 @@
|
|||
:display-output-script-page
|
||||
:gemini-display-data-page
|
||||
:gemini-request-event
|
||||
:titan-post-event
|
||||
:gemini-back-event
|
||||
:gemini-got-line-event
|
||||
:gemini-abort-all-downloading-event
|
||||
|
|
@ -1864,7 +1873,9 @@
|
|||
:*before-fire-string-event-command-window*
|
||||
:*after-delete-char-from-command-window*
|
||||
:*after-gemini-socket*
|
||||
:*after-gemini-request-sent*))
|
||||
:*after-gemini-request-sent*
|
||||
:*after-titan-socket*
|
||||
:*after-titan-request-sent*))
|
||||
|
||||
(defpackage :keybindings
|
||||
(:use
|
||||
|
|
|
|||
|
|
@ -1296,7 +1296,7 @@
|
|||
(cond
|
||||
((text-utils:string-empty-p url)
|
||||
(ui:error-message (_ "Empty address")))
|
||||
((gemini-client:absolute-gemini-url-p url)
|
||||
((gemini-client:absolute-gemini-or-titan-url-p url)
|
||||
(gemini-viewer:bury-download-stream)
|
||||
(gemini-viewer:ensure-just-one-stream-rendering)
|
||||
(gemini-viewer:request url
|
||||
|
|
@ -1353,6 +1353,45 @@
|
|||
(gemini-viewer:push-url-to-history window local-path))
|
||||
(error (e) (ui:error-message (format nil "~a" e))))))))))
|
||||
|
||||
(defclass titan-post-event (program-event)
|
||||
((url
|
||||
:initform nil
|
||||
:initarg :url
|
||||
:accessor url)
|
||||
(data
|
||||
:initform nil
|
||||
:initarg :data
|
||||
:accessor data)
|
||||
(size
|
||||
:initform nil
|
||||
:initarg :size
|
||||
:accessor size)
|
||||
(mime
|
||||
:initform nil
|
||||
:initarg :mime
|
||||
:accessor mime)
|
||||
(token
|
||||
:initform nil
|
||||
:initarg :token
|
||||
:accessor token)))
|
||||
|
||||
(defmethod process-event ((object titan-post-event))
|
||||
(tui:with-notify-errors
|
||||
(with-accessors ((url url) ; if a local file *not* percent encoded
|
||||
(data data)
|
||||
(size size)
|
||||
(mime mime)
|
||||
(token token)) object
|
||||
(cond
|
||||
((text-utils:string-empty-p url)
|
||||
(ui:error-message (_ "Empty address")))
|
||||
((gemini-client:absolute-titan-url-p url)
|
||||
(gemini-viewer:request url
|
||||
:titan-data data
|
||||
:titan-size size
|
||||
:titan-mime mime
|
||||
:titan-token token))))))
|
||||
|
||||
(defclass gemini-back-event (program-event) ())
|
||||
|
||||
(defmethod process-event ((object gemini-back-event))
|
||||
|
|
|
|||
|
|
@ -99,6 +99,7 @@
|
|||
(:file "gemini-constants")
|
||||
(:file "gemini-parser")
|
||||
(:file "client")
|
||||
(:file "titan")
|
||||
(:file "subscription")))
|
||||
(:module kami
|
||||
:components ((:file "package")
|
||||
|
|
|
|||
Loading…
Reference in New Issue