cage
/
tinmop
mirror of https://codeberg.org/cage/tinmop/
1
0
Fork 0
Code Issues

- [GUI] added support for HTTP proxy; 

- [fediverse] added 'edit-status'.
This commit is contained in:
cage 2024-06-26 12:49:36 +02:00
parent 883d2c0105
commit eb85a63430
11 changed files with 91 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
etc/shared.conf
View File

@ -172,6 +172,14 @@ color-regexp = "\*[^*]+\*" #ffff00 bold
#color-regexp = "/[^/]+/" #ffff00 italic
gemini.search-engine.uri = "gemini://kennedy.gemi.dev/search"
# gemini proxy, forward all the gemini and http requests to the servel
# below, the response is converted, by the proxy, in a format fitted
# for a gemini client (e.g HTML is converted to gemtext)
gemini.proxy.uri = ""
# The width of the generated table of contents for gemini pages when
# tinmop is ran as exclusive gemini client (command line option "-G")

21
src/api-client.lisp
View File

@ -547,6 +547,27 @@ database."
:spoiler-text subject
:visibility visibility))
(defun-api-call edit-status (content
attachments
attachments-alt-text
subject
language)
"Edit a status
- content the new text of the message
- attachments a list of file path to attach or nil il no attachments
to this message exists
- subject the subject of this message"
(tooter:edit-status *client*
content
:language language
:media (mapcar (lambda (path alt-text)
(tooter:make-media *client*
(fs:namestring->pathname path)
:description alt-text))
attachments
attachments-alt-text)
:spoiler-text subject))
(defun-api-call search-user (username &key (limit 1) (resolve nil))
"Find user identified by username"
(tooter:search-accounts *client* username :limit limit :resolve resolve))

8
src/constants.lisp
View File

@ -173,11 +173,13 @@ General Public License for more details."
(define-constant +file-scheme+ "file" :test #'string=)
(define-constant +about-scheme+ "about" :test #'string=)
(define-constant +http-scheme+ "http" :test #'string=)
(define-constant +internal-scheme-bookmark+ "bookmark" :test #'string=)
(define-constant +about-scheme+ "about" :test #'string=)
(define-constant +internal-scheme-gemlogs+ "gemlog" :test #'string=)
(define-constant +internal-scheme-bookmark+ "bookmark" :test #'string=)
(define-constant +internal-scheme-gemlogs+ "gemlog" :test #'string=)
(define-constant +internal-scheme-view-source+ "view-source" :test #'string=)

15
src/gemini-viewer.lisp
View File

@ -221,7 +221,7 @@
(defgeneric downloading-allowed-p (object))
(defgeneric downloading-start-thread (object function host port path query fragment))
(defgeneric downloading-start-thread (object function scheme host port path query fragment))
(defmethod abort-downloading ((object gemini-stream))
(with-accessors ((download-thread-lock download-thread-lock)) object
@ -252,6 +252,7 @@
(defmethod downloading-start-thread ((object gemini-stream)
function
scheme
host
port
path
@ -265,6 +266,7 @@
(setf start-time (db-utils:local-time-obj-now))
(setf download-iri (gemini-parser:make-gemini-iri host
path
:scheme scheme
:query query
:port port
:fragment fragment))
@ -370,7 +372,7 @@
(text-utils:percent-decode fragment)
fragment)))
(defun request-stream-gemini-document-thread (wrapper-object host
(defun request-stream-gemini-document-thread (wrapper-object scheme host
port path query fragment favicon
gemini-format-p
&key
@ -433,6 +435,7 @@
(with-open-support-file (file-stream support-file character)
(let* ((url (gemini-parser:make-gemini-iri host
path
:scheme scheme
:query query
:port port
:fragment fragment))
@ -587,7 +590,7 @@
(if enqueue
:streaming
:running))))
(multiple-value-bind (actual-iri host path query port fragment)
(multiple-value-bind (actual-iri host path query port fragment scheme)
(gemini-client:displace-iri parsed-iri)
(gemini-client:debug-gemini "response is a stream")
(labels ((make-text-based-stream (gemini-format-p)
@ -607,6 +610,7 @@
:download-socket socket))
(favicon (fetch-favicon parsed-iri))
(thread-fn (request-stream-gemini-document-thread gemini-stream
scheme
host
port
path
@ -619,6 +623,7 @@
(program-events:push-event enqueue-event)
(downloading-start-thread gemini-stream
thread-fn
scheme
host
port
path
@ -665,6 +670,7 @@
(program-events:push-event enqueue-event)
(downloading-start-thread gemini-stream
thread-fn
scheme
host
port
path
@ -683,7 +689,7 @@
(use-cached-file-if-exists nil)
(do-nothing-if-exists-in-db nil))
(labels ((get-user-input (hide-input url prompt)
(multiple-value-bind (actual-iri host path query port fragment)
(multiple-value-bind (actual-iri host path query port fragment scheme)
(gemini-client:displace-iri (iri:iri-parse url))
(declare (ignore actual-iri query fragment))
(flet ((on-input-complete (input)
@ -692,6 +698,7 @@
(let ((encoded-input (maybe-percent-encode input)))
(request (gemini-parser:make-gemini-iri host
path
:scheme scheme
:query
encoded-input
:port port)

13
src/gemini/client.lisp
View File

@ -441,6 +441,7 @@
:documentation "timeout, in seconds, for reading response from remote server")
(defun request (host path &key
(scheme +gemini-scheme+)
(query nil)
(port +gemini-default-port+)
(fragment nil)
@ -451,10 +452,12 @@
(swconf:config-gemini-proxy)
(let* ((iri (make-gemini-iri (idn:host-unicode->ascii host)
(percent-encode-path path)
:scheme scheme
:query (percent-encode-query query)
:port port
:fragment (percent-encode-fragment fragment)))
(ctx (cl+ssl:make-context :verify-mode cl+ssl:+ssl-verify-none+)))
;; (return-from request nil)
(cl+ssl:with-global-context (ctx :auto-free-p t)
(handler-case
(let* ((actual-host (or proxy-host
@ -555,13 +558,16 @@
:certificate-key certificate-key
:certificate-key-password certificate-key-password))))
(let ((parsed-iri (iri:iri-parse url)))
(multiple-value-bind (actual-iri host path query port)
(multiple-value-bind (actual-iri host path query port x scheme)
(displace-iri parsed-iri)
(declare (ignore x))
(multiple-value-bind (status code-description meta response socket)
(if (absolute-titan-url-p url)
(make-titan-request)
(gemini-client:request host
path
:scheme (or scheme
+gemini-scheme+)
:certificate-key certificate-key
:certificate-key-password certificate-key-password
:client-certificate certificate
@ -765,3 +771,8 @@ TODO: Add client certificate."
:ignore-warning t)
(request-dispatch url dispatch-table))
(fs:slurp-file url :convert-to-string nil))))
(defun url-needs-proxy-p (url)
(and (swconf:config-gemini-proxy)
(string= (uri:scheme (iri:iri-parse url))
+http-scheme+)))

3
src/gemini/package.lisp
View File

@ -204,7 +204,8 @@
:clear-cache-certificate-password
:substitute-cache-certificate-password
:build-redirect-iri
:slurp-gemini-url))
:slurp-gemini-url
:url-needs-proxy-p))
(defpackage :gemini-dummy-server
(:use

18
src/gui/client/main-window.lisp
View File

@ -1083,8 +1083,12 @@ local file paths."
(defun open-iri (iri main-window use-cache &key (status +stream-status-streaming+))
(handler-case
(let* ((actual-iri (remove-standard-port iri))
(parsed-iri (iri:iri-parse actual-iri)))
(let* ((actual-iri (remove-standard-port iri))
(parsed-iri (iri:iri-parse actual-iri))
(needs-proxy (cev:enqueue-request-and-wait-results :gemini-url-needs-proxy-p
1
ev:+maximum-event-priority+
actual-iri)))
(cond
((string= (uri:scheme parsed-iri) +internal-scheme-view-source+)
(setf (uri:scheme parsed-iri) gemini-constants:+gemini-scheme+)
@ -1100,7 +1104,8 @@ local file paths."
(menu:manage-gemlogs))
((gemini-client:absolute-titan-url-p actual-iri)
(client-titan-window:init-window main-window main-window actual-iri))
((gemini-parser:gemini-iri-p actual-iri)
((or (gemini-parser:gemini-iri-p actual-iri)
needs-proxy)
(let ((stream-frame (stream-frame main-window)))
(start-stream-iri (iri-ensure-path actual-iri)
main-window
@ -1141,13 +1146,14 @@ local file paths."
:button-message button-label))
(encoded-input (maybe-percent-encode raw-input)))
(when (string-not-empty-p raw-input)
(multiple-value-bind (actual-iri host path query port fragment)
(multiple-value-bind (actual-iri host path query port fragment scheme)
(gemini-client:displace-iri parsed-iri)
(declare (ignore actual-iri query fragment))
(gemini-parser:make-gemini-iri host
path
:query encoded-input
:port port)))))
:scheme scheme
:query encoded-input
:port port)))))
(defun slurp-text-data (main-window iri)
(labels ((maybe-open-if-completed (stream-info support-file)

9
src/gui/server/public-api-gemini-certificates.lisp
View File

@ -50,8 +50,13 @@
t)
(defun gemini-delete-tofu-certificate (iri)
(let ((host (uri:host (iri:iri-parse iri))))
(db:tofu-delete host)))
(multiple-value-bind (proxy-host x)
(swconf:config-gemini-proxy)
(declare (ignore x))
(if proxy-host
(db:tofu-delete proxy-host)
(let ((host (uri:host (iri:iri-parse iri))))
(db:tofu-delete host)))))
(defun gemini-import-certificate (uri cert-file key-file)
(db-utils:with-ready-database (:connect nil)

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

@ -91,8 +91,8 @@
(defun request-success-dispatched-fn (status code-description meta response socket iri parsed-iri)
(declare (ignore iri))
(multiple-value-bind (actual-iri host path query port fragment)
(gemini-client:displace-iri parsed-iri )
(multiple-value-bind (actual-iri host path query port fragment scheme)
(gemini-client:displace-iri parsed-iri)
(debug-gemini-gui "response is a stream")
(labels ((make-text-based-stream (gemini-format-p)
(let* ((starting-status :streaming)
@ -112,6 +112,7 @@
:download-socket socket))
(favicon (gemini-viewer::fetch-favicon parsed-iri))
(thread-fn (gemini-viewer::request-stream-gemini-document-thread gemini-stream
scheme
host
port
path
@ -124,6 +125,7 @@
(gemini-viewer:push-db-stream gemini-stream)
(gemini-viewer::downloading-start-thread gemini-stream
thread-fn
scheme
host
port
path
@ -167,6 +169,7 @@
(gemini-viewer:push-db-stream gemini-stream)
(gemini-viewer::downloading-start-thread gemini-stream
thread-fn
scheme
host
port
path
@ -625,3 +628,6 @@
(defun titan-save-token (url token)
(db:save-titan-token url token)
t)
(defun gemini-url-needs-proxy-p (url)
(gemini-client:url-needs-proxy-p url))

3
src/gui/server/public-api.lisp
View File

@ -44,6 +44,9 @@
(gen-rpc "complete-net-address"
'complete-net-address
"hint" 0)
(gen-rpc "gemini-url-needs-proxy-p"
'gemini-url-needs-proxy-p
"iri" 0)
(gen-rpc "gemini-request"
'gemini-request
"iri" 0

2
src/package.lisp
View File

@ -74,6 +74,7 @@
:+octect-type+
:+gemini-file-extension+
:+file-scheme+
:+http-scheme+
:+about-scheme+
:+internal-scheme-bookmark+
:+internal-scheme-gemlogs+
@ -1876,6 +1877,7 @@
:fetch-remote-status
:get-remote-status
:send-status
:edit-status
:get-status-context
:search-user
:find-results