- implemented titan protocol;

- [TUI] added titan requests;
- [GUI] fixed crash when opening the gemlog windows after refreshed the gemlogs data.

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@

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
+
 
 
 

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

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)

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

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,7 +761,9 @@
                                                      :redirect
                                                      #'redirect-dispatch
                                                      :success
-                                                     (request-success-dispatched-clrs enqueue))
+                                                     (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*)
@@ -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)))

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)))
+  (iri:absolute-url-scheme-p url +gemini-scheme+))
-    (string= (uri:scheme iri) +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,18 +476,63 @@
                                        "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))
+(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)
+                                       :fragment           nil))
           (flet ((call-appropriate-function (response-type)
                    (funcall (getf manage-functions
                                   response-type
@@ -505,14 +556,15 @@
               ((gemini-client:response-sensitive-input-p status)
                (call-appropriate-function :sensitive-input-requested))
               (t
-             (call-appropriate-function :fallback))))))))
+               (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))

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

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

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

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

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)

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

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

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

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))
+        (let ((decoded-path (if (percent-encoded-p url)
-               (scheme       (uri:scheme parsed))
-               (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)
+             (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))
+                                                :use-cached-file-if-exists    t)))
             ((fs:dirp decoded-path)
              (ui:open-file-explorer decoded-path))
             (t

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

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

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

tinmop.asd

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