diff --git a/Makefile.in b/Makefile.in index 420f3bb..5010e2a 100644 --- a/Makefile.in +++ b/Makefile.in @@ -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@ diff --git a/configure b/configure index 104e362..07a2dd4 100755 --- a/configure +++ b/configure @@ -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 + diff --git a/configure.ac b/configure.ac index 79ac723..c5d39d7 100644 --- a/configure.ac +++ b/configure.ac @@ -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 diff --git a/src/config.lisp.in.in b/src/config.lisp.in.in index 615535b..a675ae1 100644 --- a/src/config.lisp.in.in +++ b/src/config.lisp.in.in @@ -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) diff --git a/src/db.lisp b/src/db.lisp index 3203601..81d12bc 100644 --- a/src/db.lisp +++ b/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+) diff --git a/src/gemini-viewer.lisp b/src/gemini-viewer.lisp index 4f1dd43..ebba8a4 100644 --- a/src/gemini-viewer.lisp +++ b/src/gemini-viewer.lisp @@ -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))) diff --git a/src/gemini/client.lisp b/src/gemini/client.lisp index 2001583..f77d6c9 100644 --- a/src/gemini/client.lisp +++ b/src/gemini/client.lisp @@ -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)) diff --git a/src/gemini/gemini-constants.lisp b/src/gemini/gemini-constants.lisp index c1111d5..b356a67 100644 --- a/src/gemini/gemini-constants.lisp +++ b/src/gemini/gemini-constants.lisp @@ -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=) diff --git a/src/gemini/package.lisp b/src/gemini/package.lisp index 3e5b86f..6a1708a 100644 --- a/src/gemini/package.lisp +++ b/src/gemini/package.lisp @@ -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 diff --git a/src/gemini/titan.lisp b/src/gemini/titan.lisp new file mode 100644 index 0000000..9dfeec0 --- /dev/null +++ b/src/gemini/titan.lisp @@ -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))))))))))) diff --git a/src/gui/client/gemlog-window.lisp b/src/gui/client/gemlog-window.lisp index 73f8f4d..c8c1226 100644 --- a/src/gui/client/gemlog-window.lisp +++ b/src/gui/client/gemlog-window.lisp @@ -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) diff --git a/src/gui/server/public-api-gemini-stream.lisp b/src/gui/server/public-api-gemini-stream.lisp index 1eecd79..cedd813 100644 --- a/src/gui/server/public-api-gemini-stream.lisp +++ b/src/gui/server/public-api-gemini-stream.lisp @@ -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) diff --git a/src/hooks.lisp b/src/hooks.lisp index f58f6df..7d96c0c 100644 --- a/src/hooks.lisp +++ b/src/hooks.lisp @@ -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") diff --git a/src/iri-parser.lisp b/src/iri-parser.lisp index 8c54586..7a3f01c 100644 --- a/src/iri-parser.lisp +++ b/src/iri-parser.lisp @@ -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 diff --git a/src/misc-utils.lisp b/src/misc-utils.lisp index 38a9478..371817d 100644 --- a/src/misc-utils.lisp +++ b/src/misc-utils.lisp @@ -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 diff --git a/src/open-message-link-window.lisp b/src/open-message-link-window.lisp index 20b7c84..c736ee8 100644 --- a/src/open-message-link-window.lisp +++ b/src/open-message-link-window.lisp @@ -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 diff --git a/src/os-utils.lisp b/src/os-utils.lisp index 0f0851c..740f263 100644 --- a/src/os-utils.lisp +++ b/src/os-utils.lisp @@ -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)) diff --git a/src/package.lisp b/src/package.lisp index e6fdbbb..a6c6966 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -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 diff --git a/src/program-events.lisp b/src/program-events.lisp index ecd792d..8ff1156 100644 --- a/src/program-events.lisp +++ b/src/program-events.lisp @@ -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)) diff --git a/tinmop.asd b/tinmop.asd index b40be8b..db74cf4 100644 --- a/tinmop.asd +++ b/tinmop.asd @@ -99,6 +99,7 @@ (:file "gemini-constants") (:file "gemini-parser") (:file "client") + (:file "titan") (:file "subscription"))) (:module kami :components ((:file "package")