cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-01-31 04:24:48 +01:00
Code Issues

- implemented titan protocol;

Browse Source 
- [TUI] added titan requests;
- [GUI] fixed crash when opening the gemlog windows after refreshed the gemlogs data.
This commit is contained in:
cage 2023-07-07 14:45:05 +02:00
parent ee34c9669d
commit e1f185c439
20 changed files with 531 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile.in
View File

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

59
configure vendored
View File

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

7
configure.ac
View File

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

2
src/config.lisp.in.in
View File

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

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

28
src/gemini-viewer.lisp
View File

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

134
src/gemini/client.lisp
View File

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

2
src/gemini/gemini-constants.lisp
View File

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

5
src/gemini/package.lisp
View File

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

162
src/gemini/titan.lisp Normal file
View File

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

13
src/gui/client/gemlog-window.lisp
View File

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

2
src/gui/server/public-api-gemini-stream.lisp
View File

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

6
src/hooks.lisp
View File

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

5
src/iri-parser.lisp
View File

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

10
src/misc-utils.lisp
View File

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

45
src/open-message-link-window.lisp
View File

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

19
src/os-utils.lisp
View File

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

13
src/package.lisp
View 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

41
src/program-events.lisp
View File

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

1
tinmop.asd
View File

@ -99,6 +99,7 @@
(:file "gemini-constants")
(:file "gemini-parser")
(:file "client")
(:file "titan")
(:file "subscription")))
(:module kami
:components ((:file "package")