;; 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 . (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 parse-fediverse-virtual-iri (iri) (let ((parsed-iri (iri:iri-parse iri))) (if (string= (uri:scheme parsed-iri) +internal-scheme-local-posts+) (values (uri:host parsed-iri) (text-utils:trim-blanks (uri:path parsed-iri) '(#\/))) (error (_ "address ~a is not a valid virtual path for posts (timeline/folder)") iri)))) (defun fediverse-virtual-iri-p (iri) (let ((parsed-iri (iri:iri-parse iri))) (string= (uri:scheme parsed-iri) +internal-scheme-local-posts+))) (defun open-message-link (url enqueue) (tui-utils:with-notify-errors (cond ((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))) ((fediverse-virtual-iri-p url) (multiple-value-bind (timeline folder) (parse-fediverse-virtual-iri url) (ui:close-open-message-link-window) (ui:focus-to-thread-window) (program-events:push-event (make-instance 'program-events:refresh-thread-windows-event :new-timeline timeline :new-folder folder)))) (t (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*))