mirror of https://codeberg.org/cage/tinmop/
354 lines
18 KiB
Common Lisp
354 lines
18 KiB
Common Lisp
;; tinmop: a multiprotocol 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/>.
|
|
|
|
(in-package :open-message-link-window)
|
|
|
|
|
|
(defclass open-message-link-window (open-attach-window:open-attach-window) ())
|
|
|
|
(defmethod refresh-config :after ((object open-message-link-window))
|
|
(open-attach-window:refresh-view-links-window-config object
|
|
swconf:+key-open-message-link-window+
|
|
:center-position (modalp object)))
|
|
|
|
(defmethod resync-rows-db ((object open-message-link-window) &key
|
|
(redraw t)
|
|
(suggested-message-index nil))
|
|
(with-accessors ((rows rows)
|
|
(status-id open-attach-window:status-id)
|
|
(selected-line-bg selected-line-bg)
|
|
(selected-line-fg selected-line-fg)) object
|
|
(flet ((make-rows (links bg fg)
|
|
(mapcar (lambda (link)
|
|
(make-instance 'line
|
|
:normal-text link
|
|
:selected-text link
|
|
:normal-bg bg
|
|
:normal-fg fg
|
|
:selected-bg fg
|
|
:selected-fg bg))
|
|
links)))
|
|
(let* ((message (db:find-status-id status-id))
|
|
(reblogged-status-body (thread-window::reblogged-data message))
|
|
(body (db:row-message-rendered-text message))
|
|
(links (reverse (if (string-not-empty-p reblogged-status-body)
|
|
(collect-links reblogged-status-body)
|
|
(collect-links body)))))
|
|
(with-croatoan-window (croatoan-window object)
|
|
(when hooks:*before-displaying-links-hook*
|
|
(setf links
|
|
(hooks:run-hook-compose 'hooks:*before-displaying-links-hook* links)))
|
|
(line-oriented-window:update-all-rows object
|
|
(make-rows links
|
|
selected-line-bg
|
|
selected-line-fg))
|
|
(when suggested-message-index
|
|
(select-row object suggested-message-index))
|
|
(when redraw
|
|
(draw object)))))))
|
|
|
|
(defun init (status-id)
|
|
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
|
|
(setf *open-message-link-window*
|
|
(make-instance 'open-message-link-window
|
|
:title (_ "Links")
|
|
:status-id status-id
|
|
:single-row-height 1
|
|
:uses-border-p t
|
|
:keybindings keybindings:*open-message-link-keymap*
|
|
:croatoan-window low-level-window))
|
|
(refresh-config *open-message-link-window*)
|
|
(resync-rows-db *open-message-link-window* :redraw nil)
|
|
(when (not (line-oriented-window:rows-empty-p *open-message-link-window*))
|
|
(select-row *open-message-link-window* 0))
|
|
(draw *open-message-link-window*)
|
|
*open-message-link-window*))
|
|
|
|
(defun open-message-link (url enqueue)
|
|
(tui-utils:with-notify-errors
|
|
(if (text-utils:string-starts-with-p gopher-parser:+gopher-scheme+ url)
|
|
(multiple-value-bind (host port type selector)
|
|
(gopher-parser:parse-iri url)
|
|
(gopher-window::make-request host port type selector))
|
|
(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
|
|
((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-or-string 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* ((pathname (fs:namestring->pathname upload-file-or-string))
|
|
(file-exists-p (fs:file-exists-p pathname))
|
|
(size (if file-exists-p
|
|
(fs:file-size pathname)
|
|
(length upload-file-or-string)))
|
|
(mime (if file-exists-p
|
|
(os-utils:file->mime-type pathname)
|
|
constants:+mime-type-text+))
|
|
(upload-data (if file-exists-p
|
|
pathname
|
|
upload-file-or-string)))
|
|
(gemini-viewer::post-titan-url url
|
|
upload-data
|
|
size
|
|
mime
|
|
token)))))
|
|
(on-input-complete (data)
|
|
(db-utils:with-ready-database (:connect nil)
|
|
(let ((cached-token (db:saved-titan-token url)))
|
|
(setf upload-file-or-string data)
|
|
(ui:ask-string-input #'on-token-input-complete
|
|
:initial-value cached-token
|
|
:prompt
|
|
(_ "type access token: "))))))
|
|
(ui:ask-string-input #'on-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
|
|
(os-utils:open-resource-with-external-program decoded-path nil)))))))
|
|
|
|
(defclass open-links-window ()
|
|
((links
|
|
:initform ()
|
|
:initarg :links
|
|
:accessor links)))
|
|
|
|
(defclass open-gemini-document-link-window (focus-marked-window
|
|
simple-line-navigation-window
|
|
title-window
|
|
border-window
|
|
open-links-window)
|
|
())
|
|
|
|
(defmethod refresh-config :after ((object open-gemini-document-link-window))
|
|
(open-attach-window:refresh-view-links-window-config object
|
|
swconf:+key-open-message-link-window+
|
|
:center-position (modalp object)))
|
|
|
|
(defmethod resync-rows-db ((object open-gemini-document-link-window)
|
|
&key
|
|
(redraw t)
|
|
(suggested-message-index nil))
|
|
(with-accessors ((rows rows)
|
|
(links links)
|
|
(selected-line-bg selected-line-bg)
|
|
(selected-line-fg selected-line-fg)) object
|
|
(when hooks:*before-displaying-links-hook*
|
|
(let ((mapped-links (hooks:run-hook-compose 'hooks:*before-displaying-links-hook*
|
|
(mapcar #'gemini-parser:target links))))
|
|
(loop for mapped-link in mapped-links
|
|
for link in links
|
|
do
|
|
(setf (gemini-parser:target link) mapped-link))))
|
|
(flet ((make-rows (links bg fg)
|
|
(mapcar (lambda (link)
|
|
(make-instance 'line
|
|
:normal-text (gemini-parser:target link)
|
|
:selected-text (gemini-parser:target link)
|
|
:normal-bg bg
|
|
:normal-fg fg
|
|
:selected-bg fg
|
|
:selected-fg bg))
|
|
links)))
|
|
(with-croatoan-window (croatoan-window object)
|
|
(line-oriented-window:update-all-rows object
|
|
(make-rows links
|
|
selected-line-bg
|
|
selected-line-fg))
|
|
(when suggested-message-index
|
|
(select-row object suggested-message-index))
|
|
(when redraw
|
|
(draw object))))))
|
|
|
|
(defmethod draw :before ((object open-gemini-document-link-window))
|
|
(with-accessors ((links links)
|
|
(uses-border-p uses-border-p)
|
|
(single-row-height single-row-height)
|
|
(top-row-padding top-row-padding)
|
|
(new-messages-mark new-messages-mark)
|
|
(top-rows-slice top-rows-slice)
|
|
(bottom-rows-slice bottom-rows-slice)) object
|
|
(let ((y-start (if uses-border-p
|
|
1
|
|
0)))
|
|
(renderizable-rows-data object) ; set top and bottom slice
|
|
(win-clear object)
|
|
(with-croatoan-window (croatoan-window object)
|
|
(loop
|
|
for link in (safe-subseq links top-rows-slice bottom-rows-slice)
|
|
for y from (+ y-start top-row-padding) by single-row-height
|
|
for index from top-rows-slice
|
|
do
|
|
(print-text object
|
|
(format nil "[~a] ~a" index (gemini-parser:name link))
|
|
1 y
|
|
:bgcolor (c:bgcolor croatoan-window)
|
|
:fgcolor (c:fgcolor croatoan-window)))))))
|
|
|
|
(defmethod search-row ((object open-gemini-document-link-window) regex &key (redraw t))
|
|
(handler-case
|
|
(with-accessors ((row-selected-index row-selected-index)
|
|
(links links)) object
|
|
(let* ((scanner (create-scanner regex :case-insensitive-mode t))
|
|
(selected-link (elt links row-selected-index))
|
|
(selected-text (gemini-parser:name selected-link))
|
|
(actual-row-starting (if (scan scanner selected-text)
|
|
(1+ row-selected-index)
|
|
row-selected-index))
|
|
(position-header (position-if (lambda (a)
|
|
(scan scanner
|
|
(gemini-parser:name a)))
|
|
(safe-subseq (links object)
|
|
actual-row-starting))))
|
|
(call-next-method) ; search in urls
|
|
(when position-header ; but if an header has been found, it wins
|
|
(unselect-all object)
|
|
(select-row object (+ actual-row-starting position-header))
|
|
(when redraw
|
|
(draw object)))))
|
|
(error ()
|
|
(ui:error-message (_ "Invalid regular expression")))))
|
|
|
|
(defun init-gemini-links (links &key (title (_ "Links")) (center-position nil))
|
|
"Note that no more that one link window can be presents on the
|
|
screen."
|
|
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
|
|
(maybe-close-window *open-message-link-window*)
|
|
(setf *open-message-link-window*
|
|
(make-instance 'open-gemini-document-link-window
|
|
:center-position center-position
|
|
:top-row-padding 0
|
|
:top-horizontal-padding 1
|
|
:title title
|
|
:links links
|
|
:single-row-height 2
|
|
:uses-border-p t
|
|
:keybindings keybindings:*open-message-link-keymap*
|
|
:croatoan-window low-level-window))
|
|
(refresh-config *open-message-link-window*)
|
|
(resync-rows-db *open-message-link-window* :redraw nil)
|
|
(when (not (line-oriented-window:rows-empty-p *open-message-link-window*))
|
|
(select-row *open-message-link-window* 0))
|
|
(draw *open-message-link-window*)
|
|
*open-message-link-window*))
|
|
|
|
(defun forget-gemini-link-window ()
|
|
(setf (keybindings *message-window*)
|
|
keybindings:*message-keymap*))
|
|
|
|
(defun init-tour-links (links &key (title (_ "Links")) (center-position nil))
|
|
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
|
|
(when *open-message-link-window*
|
|
(win-close *open-message-link-window*))
|
|
(setf *open-message-link-window*
|
|
(make-instance 'open-gemini-document-link-window
|
|
:center-position center-position
|
|
:top-row-padding 0
|
|
:top-horizontal-padding 1
|
|
:title title
|
|
:links links
|
|
:single-row-height 2
|
|
:uses-border-p t
|
|
:keybindings keybindings:*open-message-link-keymap*
|
|
:croatoan-window low-level-window))
|
|
(refresh-config *open-message-link-window*)
|
|
(resync-rows-db *open-message-link-window* :redraw nil)
|
|
(when (not (line-oriented-window:rows-empty-p *open-message-link-window*))
|
|
(select-row *open-message-link-window* 0))
|
|
(draw *open-message-link-window*)
|
|
*open-message-link-window*))
|
|
|
|
(defclass open-chat-document-link-window (focus-marked-window
|
|
simple-line-navigation-window
|
|
title-window
|
|
border-window
|
|
open-links-window)
|
|
())
|
|
|
|
(defmethod refresh-config :after ((object open-chat-document-link-window))
|
|
(open-attach-window:refresh-view-links-window-config object
|
|
swconf:+key-open-message-link-window+))
|
|
|
|
(defmethod resync-rows-db ((object open-chat-document-link-window)
|
|
&key
|
|
(redraw t)
|
|
(suggested-message-index nil))
|
|
(with-accessors ((rows rows)
|
|
(links links)
|
|
(selected-line-bg selected-line-bg)
|
|
(selected-line-fg selected-line-fg)) object
|
|
(when hooks:*before-displaying-links-hook*
|
|
(setf links
|
|
(hooks:run-hook-compose 'hooks:*before-displaying-links-hook* links)))
|
|
(flet ((make-rows (links bg fg)
|
|
(mapcar (lambda (link)
|
|
(make-instance 'line
|
|
:normal-text link
|
|
:selected-text link
|
|
:normal-bg bg
|
|
:normal-fg fg
|
|
:selected-bg fg
|
|
:selected-fg bg))
|
|
links)))
|
|
(with-croatoan-window (croatoan-window object)
|
|
(line-oriented-window:update-all-rows object
|
|
(make-rows links
|
|
selected-line-bg
|
|
selected-line-fg))
|
|
(when suggested-message-index
|
|
(select-row object suggested-message-index))
|
|
(when redraw
|
|
(draw object))))))
|
|
|
|
(defun init-chat-links (links)
|
|
(let* ((low-level-window (make-croatoan-window :enable-function-keys t)))
|
|
(maybe-close-window *open-message-link-window*)
|
|
(setf *open-message-link-window*
|
|
(make-instance 'open-chat-document-link-window
|
|
:top-row-padding 0
|
|
:title (_ "Chat attachments")
|
|
:links links
|
|
:single-row-height 1
|
|
:uses-border-p t
|
|
:keybindings keybindings:*open-message-link-keymap*
|
|
:croatoan-window low-level-window))
|
|
(refresh-config *open-message-link-window*)
|
|
(resync-rows-db *open-message-link-window* :redraw nil)
|
|
(when (not (line-oriented-window:rows-empty-p *open-message-link-window*))
|
|
(select-row *open-message-link-window* 0))
|
|
(draw *open-message-link-window*)
|
|
*open-message-link-window*))
|
|
|
|
(defun forget-chat-link-window ()
|
|
(setf (keybindings *message-window*)
|
|
keybindings:*message-keymap*))
|