cage/tinmop
1
0
Fork 0
mirror of https://codeberg.org/cage/tinmop/ synced 2025-03-10 11:00:04 +01:00
Code Issues

- [GUI] made link working for local files and gemtext files over gemini protocol.

Browse Source
This commit is contained in:
cage 2023-03-06 18:38:46 +01:00
parent d6fdf00253
commit 24b0b07bb3
8 changed files with 164 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/constants.lisp
View File

@ -160,3 +160,5 @@ General Public License for more details."
:documentation "Ed is the standard editor!")
(define-constant +octect-type+ '(unsigned-byte 8) :test #'equalp)
(define-constant +gemini-file-extension+ "gmi" :test #'string=)

8
src/gemini/gemini-parser.lisp
View File

@ -285,6 +285,14 @@
(let ((parsed (or (ignore-errors (iri:iri-parse link-value))
(iri:make-iri nil nil nil nil link-value nil nil))))
(cond
((null original-host)
(if (fs:extension-dir-p original-path)
(normalize-path (strcat original-path
link-value))
(let ((path-to-last-dir (fs:parent-dir-path original-path)))
(normalize-path (strcat path-to-last-dir
fs:*directory-sep*
link-value)))))
((null (uri:host parsed))
(let* ((absolute-path-p (string-starts-with-p "/" link-value))
(query-path-p (uri:query parsed))

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

@ -2,13 +2,19 @@
(named-readtables:in-readtable nodgui.syntax:nodgui-syntax)
(a:define-constant +stream-status-streaming+ :streaming :test #'eq)
(a:define-constant +stream-status-canceled+ :canceled :test #'eq)
(a:define-constant +stream-status-downloading+ :downloading :test #'eq)
(defclass gemini-stream ()
((server-stream-handle
:initform nil
:initarg :server-stream-handle
:accessor server-stream-handle)
(status
:initform :streaming
:initform +stream-status-streaming+
:initarg :status
:accessor status)
(status-lock
@ -45,9 +51,8 @@
(remove stream-object *gemini-streams-db*))
*gemini-streams-db*)
(defmethod abort-downloading ((object gemini-stream))
(setf (status object) :canceled))
(setf (status object) +stream-status-canceled+))
(defun remove-all-db-stream ()
(map nil
@ -62,9 +67,32 @@
(defun find-db-stream-url (url)
(find-db-stream-if (lambda (a) (string= (server-stream-handle a) url))))
(defun find-streaming-stream-url ()
(find-db-stream-if (lambda (a) (eq (status a) +stream-status-streaming+))))
(defun notify-request-error (error)
(gui-goodies:error-dialog gui-goodies:*toplevel* error))
(defgeneric stop-stream-thread (object))
(defmethod stop-stream-thread ((object gemini-stream))
(with-accessors ((fetching-thread fetching-thread)) object
(abort-downloading object)
(when (bt:threadp fetching-thread)
(bt:join-thread fetching-thread))))
(defmethod stop-stream-thread ((object string))
(let ((stream-wrapper (find-db-stream-url object)))
(stop-stream-thread stream-wrapper)))
(defun stop-steaming-stream-thread ()
(let ((stream-wrapper (find-streaming-stream-url)))
(stop-stream-thread stream-wrapper)))
(defun maybe-stop-steaming-stream-thread ()
(a:when-let ((stream-wrapper (find-streaming-stream-url)))
(stop-stream-thread stream-wrapper)))
(defmacro with-notify-errors (&body body)
`(handler-case
(progn ,@body)
@ -114,13 +142,19 @@
(defun start-streaming-thread (iri &key
(use-cache t)
(process-function #'identity)
(status :streaming))
(when (not (find-db-stream-url iri))
(let ((stream-wrapper (make-instance 'gemini-stream
:server-stream-handle iri
:status status)))
(status +stream-status-streaming+))
(let ((existing-stream (find-db-stream-url iri)))
(when existing-stream
(stop-stream-thread existing-stream)
(setf (status existing-stream) status))
(let ((stream-wrapper (or existing-stream
(make-instance 'gemini-stream
:server-stream-handle iri
:status status))))
(when (not existing-stream)
(push-db-stream stream-wrapper))
(flet ((aborting-function ()
(eq (status stream-wrapper) :canceled)))
(eq (status stream-wrapper) +stream-status-canceled+)))
(let ((stream-thread (bt:make-thread (lambda ()
(slurp-gemini-stream iri
:use-cache use-cache
@ -129,7 +163,8 @@
:aborting-function
#'aborting-function)))))
(setf (fetching-thread stream-wrapper) stream-thread)
(push-db-stream stream-wrapper))))))
stream-wrapper)))))
(defun initialize-menu (parent)
(with-accessors ((main-window main-window)) parent
@ -193,7 +228,7 @@
(gen-ir-access pre-alt-text)
(defun link-click-mouse-1-callback (link-value main-window &key (use-cache t))
(defun link-click-mouse-1-callback-clsr (link-value main-window &key (use-cache t))
(lambda ()
(open-iri link-value main-window use-cache)))
@ -300,8 +335,8 @@
link-font
link-fg
link-bg
(link-click-mouse-1-callback target-iri
main-window)
(link-click-mouse-1-callback-clsr target-iri
main-window)
:over-callback
(lambda () (print-info-message target-iri))
:leave-callback
@ -391,6 +426,27 @@
(getf response :cached)
(getf response :iri)))
(defun open-local-path (path main-window)
(cond
((fs:file-exists-p path)
(if (fs:has-extension path +gemini-file-extension+)
(let ((parsed-lines (cev:enqueue-request-and-wait-results :gemini-parse-local-file
1
ev:+standard-event-priority+
path)))
(ev:with-enqueued-process-and-unblock ()
(clean-gemtext main-window)
(collect-ir-lines path gui-goodies:*main-frame* parsed-lines)))
(let ((lines (cev:enqueue-request-and-wait-results :gemini-slurp-local-file
1
ev:+standard-event-priority+
path)))
(ev:with-enqueued-process-and-unblock ()
(clean-gemtext main-window)
(set-text-gemtext main-window lines)))))
((fs:directory-exists-p path))))
(defun open-iri (iri main-window use-cache)
(handler-case
(let ((parsed-iri (iri:iri-parse iri)))
@ -398,13 +454,12 @@
(if (string= (uri:scheme parsed-iri)
gemini-constants:+gemini-scheme+)
(start-stream-iri iri main-window use-cache)
(progn))
(progn)))
(client-os-utils:open-resource-with-external-program main-window iri))
(open-local-path iri main-window)))
(error (e)
#+debug-mode (misc:dbg "error quen getting iri from autocomplete ~a" e)
(notify-request-error e))))
(defun start-stream-iri (iri main-window use-cache &optional (status :streaming))
(defun start-stream-iri (iri main-window use-cache &optional (status +stream-status-streaming+))
(let ((connecting-response (cev:enqueue-request-and-wait-results :gemini-request
1
ev:+maximum-event-priority+
@ -418,13 +473,21 @@
(displace-gemini-response connecting-response)
(cond
((gemini-client:header-success-p status-code)
(start-streaming-thread iri
:use-cache nil
:process-function (lambda (lines)
(collect-ir-lines iri main-window lines)
(misc:dbg "lines ~a" lines))
:status status))))))
(cond
((eq status +stream-status-streaming+)
(maybe-stop-steaming-stream-thread)
(clean-gemtext main-window)
(start-streaming-thread iri
:use-cache nil
:process-function (lambda (lines)
(collect-ir-lines iri main-window lines)
(misc:dbg "lines ~a" lines))
:status status))
((eq status +stream-status-downloading+)
(when (not (find-db-stream-url iri))
(enqueue-request-notify-error :gemini-request 1 iri use-cache)))
(t
(error "Unrecognized stream status for address ~s: ~s" iri status))))))))
(defun open-iri-clsr (main-window use-cache)
(lambda ()
@ -580,6 +643,12 @@
(defun print-error-message (message)
(print-info-message message :color (gui-goodies:parse-color "red") :bold t))
(defun clean-gemtext (main-window)
(setf (gui:text (gemtext-widget main-window)) ""))
(defun set-text-gemtext (main-window text)
(setf (gui:text (gemtext-widget main-window)) text))
(defun init-main-window ()
(gui:with-nodgui (:title +program-name+)
(icons:load-icons)

36
src/gui/client/os-utils.lisp Normal file
View File

@ -0,0 +1,36 @@
;; tinmop: an humble gemini and pleroma client
;; Copyright (C) 2020 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/>.
(in-package :client-os-utils)
(defun open-resource-with-external-program (main-window resource &key (open-for-edit nil))
(flet ((edit (file)
(croatoan:end-screen)
(os-utils:open-with-editor file)))
(let ((program (swconf:link-regex->program-to-use resource)))
(if program
(cond
((swconf:use-editor-as-external-program-p program)
(edit resource))
((swconf:use-tinmop-as-external-program-p program)
(if open-for-edit
(edit resource)
(client-main-window:open-local-path resource main-window)))
(t
(os-utils:open-link-with-program program resource :wait open-for-edit)))
(if open-for-edit
(error (_ "No program defined in configuration file to edit this kind of files."))
(os-utils:xdg-open resource))))))

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

@ -415,3 +415,11 @@
(defmethod yason:encode ((object gemini-toc) &optional (stream *standard-output*))
(encode-flat-array-of-plists (unbox object) stream))
(defun gemini-parse-local-file (path)
(let ((parsed-lines (gemini-parser:parse-gemini-file (fs:slurp-file path))))
(make-instance 'parsed-lines-slice
:contents (rearrange-parsed-line-for-encoding parsed-lines))))
(defun gemini-slurp-local-file (path)
(fs:slurp-file path))

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

@ -72,6 +72,12 @@
(gen-rpc "gemini-toc"
'gemini-table-of-contents
"iri" 0)
(gen-rpc "gemini-parse-local-file"
'gemini-parse-local-file
"path" 0)
(gen-rpc "gemini-slurp-local-file"
'gemini-slurp-local-file
"path" 0)
(gen-rpc "tour-shuffle" 'tour-shuffle)
(gen-rpc "tour-add-link"
'tour-add-link

10
src/package.lisp
View File

@ -67,6 +67,7 @@
:+cache-tls-certificate-type+
:+standard-editor+
:+octect-type+
:+gemini-file-extension+
;; GUI
:+minimum-padding+
:+ps-file-dialog-filter+))
@ -3264,6 +3265,14 @@
:gemini-h3-justification
:gemini-preformatted-text-justification))
(defpackage :client-os-utils
(:use
:cl
:config
:constants)
(:export
:open-resource-with-external-program))
(defpackage :client-events
(:use
:cl
@ -3386,6 +3395,7 @@
(:gui-shapes :nodgui.shapes)
(:menu :client-menu-command))
(:export
:open-local-path
:init-main-window))
(defpackage :main

1
tinmop.asd
View File

@ -160,6 +160,7 @@
:components ((:file "constants")
(:file "gui-goodies")
(:file "client-configuration")
(:file "os-utils")
(:file "program-events")
(:file "json-rpc-communication")
(:file "validation")