2020-09-06 11:32:08 +02:00
|
|
|
;; tinmop: an humble gemini and pleroma client
|
2020-05-08 15:45:43 +02:00
|
|
|
;; 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/][http://www.gnu.org/licenses/]].
|
|
|
|
|
|
|
|
(in-package :ui-goodies)
|
|
|
|
|
|
|
|
(defun boolean-input-accepted-p (user-input)
|
2021-09-09 15:15:05 +02:00
|
|
|
(values (string-equal user-input (_ "y"))
|
|
|
|
(string-not-empty-p user-input)))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
2021-08-28 12:33:49 +02:00
|
|
|
(defun open-manual ()
|
|
|
|
#+man-bin
|
|
|
|
(progn
|
|
|
|
(croatoan:end-screen)
|
|
|
|
(tui:with-notify-errors
|
2021-09-12 12:16:29 +02:00
|
|
|
(let ((process (os-utils:run-external-program +man-bin+
|
|
|
|
(list +program-name+)
|
|
|
|
:search t
|
|
|
|
:wait t
|
|
|
|
:input t
|
|
|
|
:output t
|
|
|
|
:error t)))
|
|
|
|
(when (not (os-utils:process-exit-success-p process))
|
|
|
|
(error (_ "Unable to load manual, contact your system administrator"))))))
|
2021-08-28 12:33:49 +02:00
|
|
|
#-man-bin
|
|
|
|
(notify (_ "No manpage binary found on this system") :as-error t))
|
|
|
|
|
2020-05-08 15:45:43 +02:00
|
|
|
(defun quit-program ()
|
|
|
|
"This is not the right function to quit the program, use
|
|
|
|
'clean-close-program'."
|
|
|
|
(hooks:run-hooks 'hooks:*before-quit*)
|
|
|
|
(db-utils:close-db)
|
|
|
|
(os-utils:exit-program))
|
|
|
|
|
2021-09-09 15:22:50 +02:00
|
|
|
(defmacro with-valid-yes-at-prompt ((input-text y-pressed-p) &body body)
|
|
|
|
(with-gensyms (not-null-input-p)
|
|
|
|
`(multiple-value-bind (,y-pressed-p ,not-null-input-p)
|
|
|
|
(boolean-input-accepted-p ,input-text)
|
|
|
|
(when ,not-null-input-p
|
|
|
|
,@body))))
|
|
|
|
|
2020-09-12 11:16:15 +02:00
|
|
|
(defun clean-temporary-files ()
|
|
|
|
"Use this to close the program"
|
|
|
|
(flet ((on-input-complete (maybe-accepted)
|
2021-09-09 15:22:50 +02:00
|
|
|
(with-valid-yes-at-prompt (maybe-accepted y-pressed-p)
|
|
|
|
(when y-pressed-p
|
|
|
|
(fs:clean-temporary-directories)
|
|
|
|
(fs:clean-temporary-files))
|
|
|
|
(push-event (make-instance 'quit-program-event)))))
|
2020-09-12 11:16:15 +02:00
|
|
|
(let ((temporary-text (strcat (format nil
|
|
|
|
(_ "~a Temporary files~2%")
|
|
|
|
(swconf:gemini-h1-prefix))
|
|
|
|
(format nil
|
|
|
|
"~{- ~a~%~}"
|
2021-08-20 17:04:23 +02:00
|
|
|
fs:*temporary-files-created*)
|
|
|
|
(format nil
|
|
|
|
"~{- ~a~%~}"
|
|
|
|
fs:*temporary-directories-created*)))
|
2020-09-12 11:16:15 +02:00
|
|
|
(temporary-files-count (length fs:*temporary-files-created*)))
|
|
|
|
(if (> temporary-files-count 0)
|
|
|
|
(progn
|
2021-04-10 13:52:56 +02:00
|
|
|
(message-window:prepare-for-rendering *message-window* temporary-text)
|
2020-09-12 11:16:15 +02:00
|
|
|
(windows:draw *message-window*)
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt (format nil
|
|
|
|
(n_ "Delete ~a temporary file? [y/N] "
|
|
|
|
"Delete ~a temporary files? [y/N] "
|
|
|
|
temporary-files-count)
|
|
|
|
temporary-files-count)))
|
|
|
|
(push-event (make-instance 'quit-program-event))))))
|
|
|
|
|
2020-05-08 15:45:43 +02:00
|
|
|
(defun clean-close-program ()
|
|
|
|
"Use this to close the program"
|
|
|
|
(flet ((on-input-complete (maybe-accepted)
|
2021-09-09 15:22:50 +02:00
|
|
|
(with-valid-yes-at-prompt (maybe-accepted y-pressed-p)
|
2021-09-09 15:15:05 +02:00
|
|
|
(if y-pressed-p
|
|
|
|
(let ((delete-event (make-instance 'delete-all-status-event)))
|
|
|
|
(push-event delete-event))
|
|
|
|
(db-utils:with-ready-database (:connect nil)
|
|
|
|
(db:renumber-all-timelines '())))
|
2021-09-09 15:22:50 +02:00
|
|
|
(clean-temporary-files))))
|
2020-09-30 18:24:58 +02:00
|
|
|
(let ((delete-count (db:count-status-marked-to-delete))
|
2020-10-01 16:39:09 +02:00
|
|
|
(stop-download-event (make-instance 'gemini-abort-all-downloading-event
|
2020-09-30 18:24:58 +02:00
|
|
|
:priority +maximum-event-priority+)))
|
|
|
|
(push-event stop-download-event)
|
2020-05-08 15:45:43 +02:00
|
|
|
(if (> delete-count 0)
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt (format nil
|
|
|
|
(n_ "Delete ~a message? [y/N] "
|
|
|
|
"Delete ~a messages? [y/N] "
|
|
|
|
delete-count)
|
|
|
|
delete-count))
|
2021-08-14 14:38:42 +02:00
|
|
|
(progn
|
|
|
|
(db:renumber-all-timelines '())
|
|
|
|
(clean-temporary-files))))))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
2020-07-06 16:11:34 +02:00
|
|
|
(defun notify (message &key (life nil) (as-error nil) (priority +standard-event-priority+))
|
2020-05-08 15:45:43 +02:00
|
|
|
(let ((event (make-instance 'notify-user-event
|
2020-07-06 16:11:34 +02:00
|
|
|
:priority priority
|
2020-07-04 11:15:55 +02:00
|
|
|
:life (if as-error
|
|
|
|
(tui:standard-error-notify-life)
|
|
|
|
life)
|
2020-05-08 15:45:43 +02:00
|
|
|
:notify-error as-error
|
|
|
|
:payload message)))
|
|
|
|
(push-event event)))
|
|
|
|
|
|
|
|
(defun notify-procedure (procedure starting-message
|
|
|
|
&key
|
|
|
|
(ending-message (_ "Task completed"))
|
|
|
|
(life-start nil)
|
|
|
|
(life-end nil))
|
|
|
|
(bt:make-thread (lambda ()
|
2021-08-12 15:13:47 +02:00
|
|
|
(when (string-not-empty-p starting-message)
|
|
|
|
(notify starting-message :life life-start))
|
2020-05-08 15:45:43 +02:00
|
|
|
(funcall procedure)
|
2021-08-12 15:13:47 +02:00
|
|
|
(when (string-not-empty-p ending-message)
|
|
|
|
(notify ending-message :life life-end)))))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defmacro with-blocking-notify-procedure ((starting-message
|
|
|
|
&optional (ending-message `(_ "Task completed")))
|
|
|
|
&body body)
|
|
|
|
`(progn
|
|
|
|
(notify ,starting-message)
|
|
|
|
,@body
|
|
|
|
(notify ,ending-message)))
|
|
|
|
|
|
|
|
(defun info-dialog (message &key (buttons nil) (title (_ "Information")))
|
|
|
|
(let ((event (make-instance 'info-dialog-event
|
|
|
|
:buttons buttons
|
|
|
|
:title title
|
|
|
|
:payload message)))
|
|
|
|
(push-event event)))
|
|
|
|
|
|
|
|
(defun error-dialog (message &key (buttons nil) (title (_ "Error")))
|
|
|
|
(let ((event (make-instance 'error-dialog-event
|
|
|
|
:buttons buttons
|
|
|
|
:title title
|
|
|
|
:payload message)))
|
|
|
|
(push-event event)))
|
|
|
|
|
2020-05-16 20:01:41 +02:00
|
|
|
(defun info-dialog-immediate (message
|
|
|
|
&key
|
|
|
|
(buttons nil)
|
|
|
|
(title (_ "Information"))
|
|
|
|
(append-ok-button t))
|
2020-09-11 15:18:59 +02:00
|
|
|
(let ((dialog-window (windows:make-info-message-dialog *main-window*
|
2020-05-08 15:45:43 +02:00
|
|
|
title
|
|
|
|
message
|
2020-05-16 20:01:41 +02:00
|
|
|
buttons
|
|
|
|
append-ok-button)))
|
2020-05-08 15:45:43 +02:00
|
|
|
(windows:menu-select dialog-window)))
|
|
|
|
|
2020-05-16 20:01:41 +02:00
|
|
|
(defun error-dialog-immediate (message
|
|
|
|
&key
|
|
|
|
(buttons nil)
|
|
|
|
(title (_ "Error"))
|
|
|
|
(append-ok-button t))
|
2020-09-11 15:18:59 +02:00
|
|
|
(let ((dialog-window (windows:make-error-message-dialog *main-window*
|
2020-05-08 15:45:43 +02:00
|
|
|
title
|
|
|
|
message
|
2020-05-16 20:01:41 +02:00
|
|
|
buttons
|
|
|
|
append-ok-button)))
|
2020-05-08 15:45:43 +02:00
|
|
|
(windows:menu-select dialog-window)))
|
|
|
|
|
|
|
|
(defun input-dialog-immediate (message)
|
2020-09-11 15:18:59 +02:00
|
|
|
(windows:make-input-dialog *main-window* *main-window* message))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
2020-11-01 18:01:32 +01:00
|
|
|
(defun error-message (message &optional (priority +standard-event-priority+))
|
2020-05-08 15:45:43 +02:00
|
|
|
(let ((event (make-instance 'error-message-event
|
2020-11-01 18:01:32 +01:00
|
|
|
:priority priority
|
2020-05-08 15:45:43 +02:00
|
|
|
:payload message)))
|
|
|
|
(push-event event)))
|
|
|
|
|
2020-11-01 18:01:32 +01:00
|
|
|
(defun info-message (message &optional (priority +standard-event-priority+))
|
2020-05-08 15:45:43 +02:00
|
|
|
(let ((event (make-instance 'info-message-event
|
2020-11-01 18:01:32 +01:00
|
|
|
:priority priority
|
|
|
|
:payload message)))
|
2020-05-08 15:45:43 +02:00
|
|
|
(push-event event)))
|
|
|
|
|
|
|
|
(defun confirm-file-overwrite-dialog-immediate (filepath)
|
|
|
|
(let ((res (info-dialog-immediate (format nil
|
|
|
|
(_ "File \"~a\" exists, overwrite?")
|
|
|
|
filepath)
|
|
|
|
:buttons (list (_ "Cancel")))))
|
|
|
|
(string= res +menu-button-ok+)))
|
|
|
|
|
|
|
|
(defun confirm-dialog-immediate (message)
|
|
|
|
(let ((res (info-dialog-immediate message
|
|
|
|
:buttons (list (_ "Cancel")))))
|
|
|
|
(string= res +menu-button-ok+)))
|
|
|
|
|
|
|
|
(defun request-error-window (condition-object)
|
|
|
|
(error-dialog (format nil
|
|
|
|
(_ "Request failed: error code ~d message \"~a\"")
|
|
|
|
(tooter:code condition-object)
|
|
|
|
(tooter:message condition-object))))
|
|
|
|
|
|
|
|
(defun ask-string-input (on-input-complete-fn
|
|
|
|
&key
|
2020-08-15 14:58:54 +02:00
|
|
|
(hide-input nil)
|
|
|
|
(priority nil)
|
|
|
|
(initial-value nil)
|
|
|
|
(prompt +default-command-prompt+)
|
2020-12-29 18:39:45 +01:00
|
|
|
(complete-fn #'complete:complete-always-empty))
|
2020-05-08 15:45:43 +02:00
|
|
|
(flet ((thread-fn ()
|
2020-08-15 14:58:54 +02:00
|
|
|
(let* ((password-echo (and hide-input
|
|
|
|
(swconf:config-password-echo-character)))
|
|
|
|
(event (make-instance 'ask-user-input-string-event
|
|
|
|
:echo-character password-echo
|
|
|
|
:forced-priority priority
|
|
|
|
:initial-value initial-value
|
|
|
|
:complete-fn complete-fn
|
|
|
|
:prompt prompt
|
|
|
|
:payload (box:dbox nil))))
|
2020-05-08 15:45:43 +02:00
|
|
|
(with-accessors ((lock lock)
|
|
|
|
(condition-variable condition-variable)) event
|
|
|
|
(push-event event)
|
|
|
|
(with-lock (lock)
|
|
|
|
(bt:condition-wait condition-variable lock)
|
|
|
|
(funcall on-input-complete-fn (box:dunbox (payload event))))))))
|
|
|
|
(bt:make-thread #'thread-fn)))
|
|
|
|
|
|
|
|
(defun thread-go-up ()
|
2020-09-11 15:18:59 +02:00
|
|
|
(thread-window:go-message-up *thread-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun thread-go-down ()
|
2020-09-11 15:18:59 +02:00
|
|
|
(thread-window:go-message-down *thread-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun thread-goto-message ()
|
|
|
|
"Jump to message"
|
|
|
|
(flet ((on-input-complete (index)
|
|
|
|
(when-let* ((index-as-number (num:safe-parse-number index))
|
|
|
|
(event (make-instance 'thread-goto-message
|
|
|
|
:payload index-as-number)))
|
|
|
|
(push-event event))))
|
|
|
|
(ask-string-input #'on-input-complete :prompt (_ "Jump to message: "))))
|
|
|
|
|
|
|
|
(defun thread-goto-first-message ()
|
|
|
|
"Jump to first message"
|
2020-09-11 15:18:59 +02:00
|
|
|
(thread-window:goto-first-message *thread-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun thread-goto-last-message ()
|
|
|
|
"Jump to last message"
|
2020-09-11 15:18:59 +02:00
|
|
|
(thread-window:goto-last-message *thread-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun thread-search-message-body (direction)
|
|
|
|
"Search in messages body"
|
|
|
|
(flet ((on-input-complete (text-looking-for)
|
|
|
|
(let ((event (make-instance 'thread-search-message-body-event
|
|
|
|
:payload text-looking-for
|
|
|
|
:search-direction direction)))
|
|
|
|
(push-event event))))
|
|
|
|
(ask-string-input #'on-input-complete :prompt (_ "Search key: "))))
|
|
|
|
|
|
|
|
(defun thread-search-next-message-body ()
|
|
|
|
"Search next matching message's body"
|
|
|
|
(thread-search-message-body :next))
|
|
|
|
|
|
|
|
(defun thread-search-previous-message-body ()
|
|
|
|
"Search previous matching messages body"
|
|
|
|
(thread-search-message-body :previous))
|
|
|
|
|
|
|
|
(defun thread-search-message-meta (direction)
|
|
|
|
"Search in messages metadata.
|
|
|
|
|
|
|
|
Metadata includes:
|
|
|
|
|
|
|
|
|
|
|
|
- spoiler-text (subject of message)
|
|
|
|
- tags
|
|
|
|
- username"
|
|
|
|
(flet ((on-input-complete (text-looking-for)
|
|
|
|
(let ((event (make-instance 'thread-search-message-meta-event
|
|
|
|
:payload text-looking-for
|
|
|
|
:search-direction direction)))
|
|
|
|
(push-event event))))
|
|
|
|
(ask-string-input #'on-input-complete :prompt (_ "Search key: "))))
|
|
|
|
|
|
|
|
(defun thread-search-next-message-meta ()
|
|
|
|
"Search next matching message's metadata
|
|
|
|
|
|
|
|
Metadata includes:
|
|
|
|
|
|
|
|
|
|
|
|
- spoiler-text (subject of message)
|
|
|
|
- tags
|
|
|
|
- username"
|
|
|
|
|
|
|
|
(thread-search-message-meta :next))
|
|
|
|
|
|
|
|
(defun thread-search-previous-message-meta ()
|
|
|
|
"Search previous matching message's metadata
|
|
|
|
|
|
|
|
Metadata includes:
|
|
|
|
|
|
|
|
|
|
|
|
- spoiler-text (subject of message)
|
|
|
|
- tags
|
|
|
|
- username"
|
|
|
|
|
|
|
|
(thread-search-message-meta :previous))
|
|
|
|
|
|
|
|
(defun thread-search-next-unread-message ()
|
|
|
|
"Jump to next unread message"
|
2020-09-11 15:18:59 +02:00
|
|
|
(thread-window:search-next-unread *thread-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
2020-12-29 13:01:59 +01:00
|
|
|
(defun repeat-search ()
|
|
|
|
"Repeat the last search performed"
|
2021-06-17 14:44:49 +02:00
|
|
|
(push-event (make-instance 'search-next-event
|
|
|
|
:priority +maximum-event-priority+)))
|
2020-12-29 13:01:59 +01:00
|
|
|
|
2020-05-08 15:45:43 +02:00
|
|
|
(defun thread-open-selected-message ()
|
|
|
|
"Open selected message"
|
2020-10-02 18:26:59 +02:00
|
|
|
(setf (windows:keybindings specials:*message-window*)
|
|
|
|
keybindings:*message-keymap*)
|
2020-09-11 15:18:59 +02:00
|
|
|
(thread-window:open-message *thread-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun thread-mark-delete-selected-message ()
|
|
|
|
"Mark selected message for deletion"
|
2020-09-11 15:18:59 +02:00
|
|
|
(thread-window:mark-selected-message-to-delete *thread-window*
|
2020-05-08 15:45:43 +02:00
|
|
|
:move-down-selected-message t))
|
|
|
|
|
|
|
|
(defun thread-mark-prevent-delete-selected-message ()
|
|
|
|
"Unmark selected message for deletion"
|
2020-09-11 15:18:59 +02:00
|
|
|
(thread-window:mark-selected-message-prevent-delete *thread-window*
|
2020-05-08 15:45:43 +02:00
|
|
|
:move-down-selected-message t))
|
|
|
|
|
|
|
|
(defun subscribe-to-hash ()
|
|
|
|
"Subscribe to hashtag"
|
|
|
|
(flet ((on-input-complete (tags)
|
|
|
|
(let ((event (make-instance 'subscribe-tags-event
|
|
|
|
:payload tags))
|
|
|
|
(refresh-event (make-instance 'refresh-tag-window-event)))
|
|
|
|
(push-event refresh-event)
|
|
|
|
(push-event event))))
|
2020-09-11 15:18:59 +02:00
|
|
|
(let* ((selected-row (line-oriented-window:selected-row-fields *thread-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
(tags (and selected-row
|
|
|
|
(db:row-message-tags selected-row))))
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:initial-value tags
|
|
|
|
:prompt (_ "Subscribe to: ")))))
|
|
|
|
|
|
|
|
(defun unsubscribe-to-hash ()
|
|
|
|
"Unsubscribe to hashtag"
|
|
|
|
(flet ((on-input-complete (tag)
|
|
|
|
(db-utils:with-ready-database (:connect nil)
|
|
|
|
(when (and (string-not-empty-p tag)
|
|
|
|
(> (length tag)
|
|
|
|
(length +folder-tag-prefix+)))
|
|
|
|
(let ((unsubscribe-event (make-instance 'unsubscribe-tags-event
|
|
|
|
:payload (db:folder-name->tag tag)))
|
|
|
|
(refresh-event (make-instance 'refresh-tag-window-event)))
|
|
|
|
(push-event unsubscribe-event)
|
|
|
|
(push-event refresh-event))))))
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:initial-value +folder-tag-prefix+
|
|
|
|
:prompt (_ "Unsubscribe to: ")
|
|
|
|
:complete-fn #'complete:tags-complete)))
|
|
|
|
|
|
|
|
(defun message-scroll-up ()
|
2020-09-11 15:18:59 +02:00
|
|
|
(message-window:scroll-up *message-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun message-scroll-down ()
|
2020-09-11 15:18:59 +02:00
|
|
|
(message-window:scroll-down *message-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
2021-06-27 13:13:28 +02:00
|
|
|
(defun message-scroll-left ()
|
|
|
|
(message-window:scroll-left *message-window*))
|
|
|
|
|
|
|
|
(defun message-scroll-right ()
|
|
|
|
(message-window:scroll-right *message-window*))
|
|
|
|
|
2020-05-08 15:45:43 +02:00
|
|
|
(defun message-scroll-begin ()
|
2020-09-11 15:18:59 +02:00
|
|
|
(message-window:scroll-begin *message-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun message-scroll-end ()
|
2020-09-11 15:18:59 +02:00
|
|
|
(message-window:scroll-end *message-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun message-scroll-next-page ()
|
2020-09-11 15:18:59 +02:00
|
|
|
(message-window:scroll-next-page *message-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun message-scroll-previous-page ()
|
2020-09-11 15:18:59 +02:00
|
|
|
(message-window:scroll-previous-page *message-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
2021-10-17 17:40:18 +02:00
|
|
|
(defun message-search-regex-callback (regex &key (priority +maximum-event-priority+))
|
|
|
|
(let ((event (make-instance 'search-regex-message-content-event
|
|
|
|
:priority priority
|
|
|
|
:payload regex)))
|
|
|
|
(push-event event)))
|
|
|
|
|
2020-05-08 15:45:43 +02:00
|
|
|
(defun message-search-regex ()
|
|
|
|
"Search regular expression in message"
|
2021-10-17 17:40:18 +02:00
|
|
|
(ask-string-input #'message-search-regex-callback
|
|
|
|
:prompt (_ "Search key: ")))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
2021-04-11 15:19:45 +02:00
|
|
|
(defun message-toggle-preformatted-block ()
|
|
|
|
"Toggles on/of preformatted block from text and shows alt text, if exists"
|
|
|
|
(message-window:toggle-preformatted-block *message-window*))
|
|
|
|
|
2021-05-01 11:12:52 +02:00
|
|
|
(defun give-focus (win info-change-focus-message)
|
2020-09-11 15:18:59 +02:00
|
|
|
(setf (main-window:focused-window *main-window*)
|
2020-05-08 15:45:43 +02:00
|
|
|
win)
|
2021-05-01 11:12:52 +02:00
|
|
|
(remove-focus-to-all-windows)
|
2020-05-08 15:45:43 +02:00
|
|
|
(setf (windows:in-focus win) t)
|
|
|
|
(windows:draw-all)
|
2020-05-09 21:58:12 +02:00
|
|
|
(when info-change-focus-message
|
2020-11-01 18:01:32 +01:00
|
|
|
(info-message info-change-focus-message +maximum-event-priority+)))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
2021-04-28 16:26:10 +02:00
|
|
|
(defun remove-focus-to-all-windows ()
|
|
|
|
(stack:do-stack-element (window windows::*window-stack*)
|
|
|
|
(when (typep window 'main-window::focus-marked-window)
|
|
|
|
(setf (windows:in-focus window) nil))))
|
|
|
|
|
2021-05-01 11:12:52 +02:00
|
|
|
(defun pass-focus (all-adjacent-win-fn intersecting-fn sort-predicate)
|
|
|
|
(let* ((window (main-window:focused-window *main-window*))
|
|
|
|
(all-adjacent-win (stack:stack-select windows::*window-stack*
|
|
|
|
all-adjacent-win-fn))
|
|
|
|
(to-intersecting-win (remove-if-not intersecting-fn
|
|
|
|
all-adjacent-win))
|
|
|
|
(intersect-sorted (sort to-intersecting-win
|
|
|
|
sort-predicate)))
|
|
|
|
(setf intersect-sorted
|
|
|
|
(remove window intersect-sorted))
|
|
|
|
(setf intersect-sorted
|
|
|
|
(remove-if-not (lambda(a) (typep a 'main-window::focus-marked-window))
|
|
|
|
intersect-sorted))
|
|
|
|
(when intersect-sorted
|
|
|
|
(remove-focus-to-all-windows)
|
|
|
|
(give-focus (first-elt intersect-sorted) nil))))
|
|
|
|
|
|
|
|
(defun pass-focus-on-right ()
|
|
|
|
"Pass the focus on the window placed on the right of the window that
|
|
|
|
current has focus"
|
|
|
|
(let* ((window (main-window:focused-window *main-window*))
|
|
|
|
(x-focused (win-x window))
|
|
|
|
(y-focused (win-y window))
|
|
|
|
(w-focused (win-width window)))
|
|
|
|
(labels ((all-adjacent-fn (w)
|
|
|
|
(>= (win-x w)
|
|
|
|
(+ x-focused
|
|
|
|
w-focused)))
|
|
|
|
(intersect-fn (w)
|
|
|
|
(<= (win-y w)
|
|
|
|
y-focused
|
|
|
|
(+ (win-y w) (win-height w))))
|
|
|
|
(sort-predicate (a b)
|
|
|
|
(< (win-y a) (win-y b))))
|
|
|
|
(pass-focus #'all-adjacent-fn #'intersect-fn #'sort-predicate))))
|
|
|
|
|
|
|
|
(defun pass-focus-on-left ()
|
|
|
|
"Pass the focus on the window placed on the left of the window that current has focus"
|
|
|
|
(let* ((window (main-window:focused-window *main-window*))
|
|
|
|
(x-focused (win-x window))
|
|
|
|
(y-focused (win-y window)))
|
|
|
|
(labels ((all-adjacent-fn (w)
|
|
|
|
(< (win-x w)
|
|
|
|
x-focused))
|
|
|
|
(intersect-fn (w)
|
|
|
|
(<= (win-y w)
|
|
|
|
y-focused
|
|
|
|
(+ (win-y w) (win-height w))))
|
|
|
|
(sort-predicate (a b)
|
|
|
|
(< (win-y a) (win-y b))))
|
|
|
|
(pass-focus #'all-adjacent-fn #'intersect-fn #'sort-predicate))))
|
|
|
|
|
|
|
|
(defun pass-focus-on-bottom ()
|
|
|
|
"Pass the focus on the window placed below the window that current has focus"
|
|
|
|
(let* ((window (main-window:focused-window *main-window*))
|
|
|
|
(x-focused (win-x window))
|
|
|
|
(y-focused (win-y window)))
|
|
|
|
(labels ((all-adjacent-fn (w)
|
|
|
|
(> (win-y w)
|
|
|
|
y-focused))
|
|
|
|
(intersect-fn (w)
|
|
|
|
(<= (win-x w)
|
|
|
|
x-focused
|
|
|
|
(+ (win-x w) (win-width w))))
|
|
|
|
(sort-predicate (a b)
|
|
|
|
(> (win-x a) (win-x b))))
|
|
|
|
(pass-focus #'all-adjacent-fn #'intersect-fn #'sort-predicate))))
|
|
|
|
|
|
|
|
(defun pass-focus-on-top ()
|
|
|
|
"Pass the focus on the window placed above the window that current has focus"
|
|
|
|
(let* ((window (main-window:focused-window *main-window*))
|
|
|
|
(x-focused (win-x window))
|
|
|
|
(y-focused (win-y window)))
|
|
|
|
(labels ((all-adjacent-fn (w)
|
|
|
|
(< (win-y w)
|
|
|
|
y-focused))
|
|
|
|
(intersect-fn (w)
|
|
|
|
(<= (win-x w)
|
|
|
|
x-focused
|
|
|
|
(+ (win-x w) (win-width w))))
|
|
|
|
(sort-predicate (a b)
|
|
|
|
(> (win-x a) (win-x b))))
|
|
|
|
(pass-focus #'all-adjacent-fn #'intersect-fn #'sort-predicate))))
|
|
|
|
|
2020-05-08 15:45:43 +02:00
|
|
|
(defmacro gen-focus-to-window (function-suffix window-get-focus
|
|
|
|
&key
|
|
|
|
(info-change-focus-message (_ "Focus changed"))
|
|
|
|
(documentation nil))
|
2020-05-09 21:58:12 +02:00
|
|
|
`(defun ,(misc:format-fn-symbol t "focus-to-~a" function-suffix) (&key (print-message t))
|
2020-05-08 15:45:43 +02:00
|
|
|
,documentation
|
2020-05-09 21:58:12 +02:00
|
|
|
(give-focus ,window-get-focus
|
|
|
|
(if print-message
|
|
|
|
,info-change-focus-message
|
2021-05-01 11:12:52 +02:00
|
|
|
nil))))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
2020-06-28 12:59:23 +02:00
|
|
|
(defun focus-to-thread-window (&key (print-message t))
|
|
|
|
"move focus on thread window"
|
2020-09-11 15:18:59 +02:00
|
|
|
(message-window:prepare-for-display-status-mode *message-window*)
|
2020-06-28 12:59:23 +02:00
|
|
|
(give-focus *thread-window*
|
|
|
|
(if print-message
|
|
|
|
(_ "focus passed on threads window")
|
2021-05-01 11:12:52 +02:00
|
|
|
nil))
|
2020-09-09 21:13:57 +02:00
|
|
|
(when-window-shown (*chats-list-window*)
|
2021-01-11 19:14:53 +01:00
|
|
|
(close-chats-list-window))
|
|
|
|
(when-window-shown (*gemini-subscription-window*)
|
|
|
|
(close-gemlog-window)))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(gen-focus-to-window message-window
|
2020-09-11 15:18:59 +02:00
|
|
|
*message-window*
|
2020-05-08 15:45:43 +02:00
|
|
|
:documentation "Move focus on message window"
|
2021-11-12 15:00:34 +01:00
|
|
|
:info-change-focus-message
|
|
|
|
(if (message-window:gemini-window-p)
|
|
|
|
(_ "Focus passed on gemini stream window")
|
|
|
|
(_ "Focus passed on message window")))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(gen-focus-to-window send-message-window
|
2020-09-11 15:18:59 +02:00
|
|
|
*send-message-window*
|
2020-05-08 15:45:43 +02:00
|
|
|
:documentation "Move focus on send message window"
|
2021-05-01 11:12:52 +02:00
|
|
|
:info-change-focus-message (_ "Focus passed on send message window"))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(gen-focus-to-window follow-requests-window
|
2020-09-11 15:18:59 +02:00
|
|
|
*follow-requests-window*
|
2020-05-08 15:45:43 +02:00
|
|
|
:documentation "Move focus on follow requests window"
|
2021-05-01 11:12:52 +02:00
|
|
|
:info-change-focus-message (_ "Focus passed on follow requests window"))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(gen-focus-to-window tags-window
|
2020-09-11 15:18:59 +02:00
|
|
|
*tags-window*
|
2020-05-08 15:45:43 +02:00
|
|
|
:documentation "Move focus on tags window"
|
2021-05-01 11:12:52 +02:00
|
|
|
:info-change-focus-message (_ "Focus passed on tags window"))
|
|
|
|
|
2020-05-08 15:45:43 +02:00
|
|
|
(gen-focus-to-window conversations-window
|
2020-09-11 15:18:59 +02:00
|
|
|
*conversations-window*
|
2020-05-08 15:45:43 +02:00
|
|
|
:documentation "Move focus on conversations window"
|
2021-05-01 11:12:52 +02:00
|
|
|
:info-change-focus-message (_ "Focus passed on conversation window"))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(gen-focus-to-window open-attach-window
|
2020-09-11 15:18:59 +02:00
|
|
|
*open-attach-window*
|
2020-05-08 15:45:43 +02:00
|
|
|
:documentation "Move focus on open-attach window"
|
2021-05-01 11:12:52 +02:00
|
|
|
:info-change-focus-message (_ "Focus passed on attach window"))
|
2020-05-17 17:47:33 +02:00
|
|
|
|
|
|
|
(gen-focus-to-window open-message-link-window
|
2020-09-11 15:18:59 +02:00
|
|
|
*open-message-link-window*
|
2020-05-17 17:47:33 +02:00
|
|
|
:documentation "Move focus on open-link window"
|
2021-05-01 11:12:52 +02:00
|
|
|
:info-change-focus-message (_ "Focus passed on link window"))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
2020-08-30 15:34:08 +02:00
|
|
|
(gen-focus-to-window open-gemini-stream-windows
|
2020-09-11 15:18:59 +02:00
|
|
|
*gemini-streams-window*
|
2020-08-30 15:34:08 +02:00
|
|
|
:documentation "Move focus on open gemini streams window"
|
2021-05-01 11:12:52 +02:00
|
|
|
:info-change-focus-message (_ "Focus passed on gemini-stream window"))
|
2020-09-05 17:02:00 +02:00
|
|
|
|
|
|
|
(gen-focus-to-window chats-list-window
|
|
|
|
*chats-list-window*
|
|
|
|
:documentation "Move focus on chats list window"
|
2021-05-01 11:12:52 +02:00
|
|
|
:info-change-focus-message (_ "Focus passed on chats list window"))
|
2020-09-05 17:02:00 +02:00
|
|
|
|
2020-10-23 20:57:17 +02:00
|
|
|
(gen-focus-to-window open-gemini-certificates-window
|
|
|
|
*gemini-certificates-window*
|
|
|
|
:documentation "Move focus on open-gemini certificates window"
|
2021-05-01 11:12:52 +02:00
|
|
|
:info-change-focus-message (_ "Focus passed on TLS certificates window."))
|
2021-01-09 16:27:40 +01:00
|
|
|
|
|
|
|
(gen-focus-to-window open-gemini-subscription-window
|
|
|
|
*gemini-subscription-window*
|
|
|
|
:documentation "Move focus on open-gemini certificates window"
|
2021-05-01 11:12:52 +02:00
|
|
|
:info-change-focus-message (_ "Focus passed on gemlog subscriptions window."))
|
2020-10-23 20:57:17 +02:00
|
|
|
|
2021-05-16 14:18:19 +02:00
|
|
|
(gen-focus-to-window gemini-toc-window
|
|
|
|
*gemini-toc-window*
|
|
|
|
:documentation "Move focus on gemini page table of contents window"
|
|
|
|
:info-change-focus-message (_ "Focus passed on gemini toc window."))
|
|
|
|
|
2021-08-25 18:15:57 +02:00
|
|
|
(gen-focus-to-window gempub-library-window
|
|
|
|
*gempub-library-window*
|
|
|
|
:documentation "Move focus on gempub library window"
|
|
|
|
:info-change-focus-message (_ "Focus passed on gempub library window"))
|
|
|
|
|
2021-12-10 11:50:37 +01:00
|
|
|
(gen-focus-to-window filesystem-explorer-window
|
|
|
|
*filesystem-explorer-window*
|
|
|
|
:documentation "Move focus on filesystem explorer window"
|
|
|
|
:info-change-focus-message (_ "Focus passed on file explorer window"))
|
|
|
|
|
2020-05-08 15:45:43 +02:00
|
|
|
(defun print-quick-help ()
|
|
|
|
"Print a quick help"
|
2020-09-11 15:18:59 +02:00
|
|
|
(keybindings:print-help *main-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
2020-10-03 21:08:55 +02:00
|
|
|
(defun apropos-help ()
|
|
|
|
"Print a command's documentation matching a regular expression."
|
|
|
|
(flet ((on-input-complete (regex)
|
|
|
|
(let ((event (make-instance 'help-apropos-event
|
|
|
|
:regex regex)))
|
|
|
|
(push-event event))))
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt (_ "Search for commands (regexp): ")
|
|
|
|
:complete-fn #'complete:complete-always-empty)))
|
|
|
|
|
2021-08-28 16:39:34 +02:00
|
|
|
(defun apropos-help-global ()
|
2021-09-12 12:41:33 +02:00
|
|
|
"Print a command's documentation matching a regular expression in all commands database."
|
2021-08-28 16:39:34 +02:00
|
|
|
(flet ((on-input-complete (regex)
|
|
|
|
(let ((event (make-instance 'help-apropos-event
|
|
|
|
:globalp t
|
|
|
|
:regex regex)))
|
|
|
|
(push-event event))))
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt (_ "Search for commands (regexp): ")
|
|
|
|
:complete-fn #'complete:complete-always-empty)))
|
|
|
|
|
2020-05-08 15:45:43 +02:00
|
|
|
(defun move-message-tree ()
|
2021-01-17 20:37:26 +01:00
|
|
|
"Move messages tree to a different folder. If folder does not exist will be created."
|
2020-05-08 15:45:43 +02:00
|
|
|
(flet ((on-input-complete (new-folder)
|
|
|
|
(let ((move-event (make-instance 'move-selected-tree-event
|
|
|
|
:new-folder new-folder))
|
|
|
|
(refresh-event (make-instance 'refresh-thread-windows-event)))
|
|
|
|
(if (string-not-empty-p new-folder)
|
|
|
|
(with-blocking-notify-procedure
|
|
|
|
((format nil (_ "Saving messages in ~s") new-folder)
|
|
|
|
(format nil (_ "Saved message in ~s") new-folder))
|
|
|
|
(push-event move-event)
|
|
|
|
(push-event refresh-event))
|
|
|
|
(error-message (_ "No folder specified."))))))
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt (_ "Move to folder: ")
|
|
|
|
:complete-fn #'complete:folder-complete)))
|
|
|
|
|
|
|
|
(defun change-folder ()
|
|
|
|
"Change folder"
|
|
|
|
(flet ((on-input-complete (new-folder)
|
|
|
|
(db-utils:with-ready-database (:connect nil)
|
|
|
|
(let ((refresh-event (make-instance 'refresh-thread-windows-event
|
|
|
|
:new-folder new-folder))
|
|
|
|
(folder-exists-p (db:folder-exists-p new-folder)))
|
|
|
|
(if (string-not-empty-p new-folder)
|
|
|
|
(if folder-exists-p
|
|
|
|
(push-event refresh-event)
|
|
|
|
(error-message (format nil
|
|
|
|
(_ "Folder ~s does not exists.")
|
|
|
|
new-folder)))
|
|
|
|
(error-message (_ "No folder specified.")))))))
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt (_ "Change folder: ")
|
|
|
|
:complete-fn #'complete:folder-complete)))
|
|
|
|
|
|
|
|
(defun change-timeline ()
|
|
|
|
"Change timeline"
|
2020-09-11 15:18:59 +02:00
|
|
|
(let ((folder (thread-window:timeline-folder *thread-window*)))
|
2020-05-08 15:45:43 +02:00
|
|
|
(flet ((on-input-complete (new-timeline)
|
|
|
|
(let* ((refresh-event (make-instance 'refresh-thread-windows-event
|
|
|
|
:new-timeline new-timeline)))
|
2020-05-30 09:53:12 +02:00
|
|
|
(cond
|
|
|
|
((string-empty-p new-timeline)
|
|
|
|
(error-message (_ "No timeline specified.")))
|
|
|
|
((db:hidden-recipient-p new-timeline)
|
|
|
|
(error-message (_ "This timeline is protected.")))
|
|
|
|
(t
|
|
|
|
(push-event refresh-event))))))
|
2020-05-08 15:45:43 +02:00
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt (_ "Change timeline: ")
|
|
|
|
:complete-fn (complete:timeline-complete-fn folder)))))
|
|
|
|
|
|
|
|
(defun timeline->kind (timeline)
|
|
|
|
"Return two values: the kind of timeline (on the server) to fetch
|
|
|
|
and if fetch local (again, to server) statuses only."
|
|
|
|
(cond
|
|
|
|
((string= timeline db:+federated-timeline+)
|
|
|
|
(values :public nil))
|
|
|
|
((string= timeline db:+local-timeline+)
|
|
|
|
(values :public t))
|
|
|
|
((string= timeline db:+home-timeline+)
|
|
|
|
(values :home nil))))
|
|
|
|
|
2020-07-06 16:11:34 +02:00
|
|
|
(defun %update-timeline-event (event-payload-function)
|
|
|
|
(let ((event (make-instance 'function-event :payload event-payload-function)))
|
|
|
|
(notify (_ "Downloading messages.")
|
|
|
|
:priority +maximum-event-priority+
|
2020-09-18 21:43:13 +02:00
|
|
|
:life (swconf:config-notification-life))
|
2020-07-06 16:11:34 +02:00
|
|
|
(push-event event)
|
|
|
|
(notify (_ "Messages downloaded.")
|
|
|
|
:priority +minimum-event-priority+
|
2020-09-18 21:43:13 +02:00
|
|
|
:life (swconf:config-notification-life))))
|
2020-07-06 16:11:34 +02:00
|
|
|
|
2020-06-11 17:28:39 +02:00
|
|
|
(defun update-current-timeline (&optional (recover-count 0))
|
2020-05-30 09:53:12 +02:00
|
|
|
"Update current timeline
|
|
|
|
|
|
|
|
This command also checks notifications about mentioning the user
|
|
|
|
and (if such mentions exists) download the mentioning toots in the
|
|
|
|
folder \"mentions\"."
|
2020-07-06 16:11:34 +02:00
|
|
|
(flet ((update-payload ()
|
2021-09-10 17:34:03 +02:00
|
|
|
(let* ((timeline (thread-window:timeline-type *thread-window*))
|
|
|
|
(folder (thread-window:timeline-folder *thread-window*))
|
|
|
|
(max-id (db:last-pagination-status-id-timeline-folder timeline folder))
|
|
|
|
(win *thread-window*)
|
|
|
|
(selected-message (line-oriented-window:selected-row-fields win))
|
|
|
|
(selected-message-id (db:row-message-status-id selected-message)))
|
2020-07-06 16:11:34 +02:00
|
|
|
(multiple-value-bind (kind localp)
|
|
|
|
(timeline->kind timeline)
|
2020-05-14 18:14:28 +02:00
|
|
|
(with-notify-errors
|
2021-09-10 17:34:03 +02:00
|
|
|
(client:update-timeline timeline
|
|
|
|
kind
|
|
|
|
folder
|
|
|
|
:recover-from-skipped-statuses t
|
|
|
|
:recover-count recover-count
|
|
|
|
:min-id max-id
|
|
|
|
:local localp)
|
2020-05-30 09:53:12 +02:00
|
|
|
(let ((update-mentions-event (make-instance 'update-mentions-event))
|
2021-09-10 17:34:03 +02:00
|
|
|
(refresh-event (make-instance 'refresh-thread-windows-event
|
|
|
|
:message-status-id
|
|
|
|
selected-message-id)))
|
2020-05-30 09:53:12 +02:00
|
|
|
;; updating home also triggers the checks for mentions
|
|
|
|
(when (eq kind :home)
|
|
|
|
(push-event update-mentions-event))
|
2020-07-06 16:11:34 +02:00
|
|
|
(push-event refresh-event)))))))
|
|
|
|
(%update-timeline-event #'update-payload)))
|
2020-05-14 16:32:01 +02:00
|
|
|
|
2020-06-11 17:28:39 +02:00
|
|
|
(defun update-current-timeline-backwards (&optional (recover-count 0))
|
2020-05-14 16:32:01 +02:00
|
|
|
"Update current timeline backwards
|
|
|
|
|
|
|
|
Starting from the oldest toot and going back."
|
2020-07-06 16:11:34 +02:00
|
|
|
(flet ((update-payload ()
|
2021-09-10 18:36:34 +02:00
|
|
|
(let* ((timeline (thread-window:timeline-type *thread-window*))
|
|
|
|
(folder (thread-window:timeline-folder *thread-window*))
|
|
|
|
(min-id (db:first-pagination-status-id-timeline-folder timeline
|
|
|
|
folder))
|
|
|
|
(win *thread-window*)
|
|
|
|
(selected-message (line-oriented-window:selected-row-fields win))
|
|
|
|
(selected-message-id (db:row-message-status-id selected-message)))
|
2020-07-06 16:11:34 +02:00
|
|
|
(multiple-value-bind (kind localp)
|
|
|
|
(timeline->kind timeline)
|
2020-05-14 18:14:28 +02:00
|
|
|
(with-notify-errors
|
|
|
|
(client:update-timeline timeline
|
|
|
|
kind
|
|
|
|
folder
|
2020-06-11 17:28:39 +02:00
|
|
|
:recover-count recover-count
|
|
|
|
:recover-from-skipped-statuses t
|
|
|
|
:max-id min-id
|
|
|
|
:local localp)
|
2021-09-10 18:36:34 +02:00
|
|
|
(let ((refresh-event (make-instance 'refresh-thread-windows-event
|
|
|
|
:message-status-id selected-message-id)))
|
|
|
|
|
2020-07-06 16:11:34 +02:00
|
|
|
(push-event refresh-event)))))))
|
|
|
|
(%update-timeline-event #'update-payload)))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
2021-06-13 14:07:47 +02:00
|
|
|
(defun expand-status-tree (force)
|
2020-06-12 18:44:22 +02:00
|
|
|
(flet ((update ()
|
2021-09-10 17:34:03 +02:00
|
|
|
(when-let* ((selected-message (line-oriented-window:selected-row-fields *thread-window*))
|
2020-09-11 15:18:59 +02:00
|
|
|
(timeline (thread-window:timeline-type *thread-window*))
|
|
|
|
(folder (thread-window:timeline-folder *thread-window*))
|
2020-11-07 15:57:45 +01:00
|
|
|
(status-id (actual-author-message-id selected-message))
|
2020-06-12 18:44:22 +02:00
|
|
|
(expand-event (make-instance 'expand-thread-event
|
2021-06-13 14:07:47 +02:00
|
|
|
:force-saving-of-ignored-status force
|
2020-06-12 18:44:22 +02:00
|
|
|
:new-folder folder
|
|
|
|
:new-timeline timeline
|
|
|
|
:status-id status-id))
|
2020-11-07 15:57:45 +01:00
|
|
|
(refresh-event (make-instance 'refresh-thread-windows-event
|
2021-09-12 11:53:53 +02:00
|
|
|
:priority +minimum-event-priority+
|
|
|
|
:message-status-id status-id)))
|
2020-06-12 18:44:22 +02:00
|
|
|
(push-event expand-event)
|
|
|
|
(push-event refresh-event))))
|
|
|
|
(notify-procedure #'update (_ "Expanding thread"))))
|
2020-05-30 09:53:12 +02:00
|
|
|
|
2021-06-13 14:07:47 +02:00
|
|
|
(defun refresh-thread ()
|
|
|
|
"Check and download a thread
|
|
|
|
|
|
|
|
Expand the post until all the reply and parents are downloaded."
|
|
|
|
(expand-status-tree nil))
|
|
|
|
|
|
|
|
(defun refresh-thread-totally ()
|
|
|
|
"Check and download a thread
|
|
|
|
|
|
|
|
Expand the post until all the reply and parents are downloaded.
|
|
|
|
|
|
|
|
If some posts was deleted before, download them again."
|
|
|
|
(expand-status-tree t))
|
|
|
|
|
2020-05-08 15:45:43 +02:00
|
|
|
(defun refresh-tags ()
|
|
|
|
"Update messages for subscribed tags"
|
2020-05-14 20:23:40 +02:00
|
|
|
(let* ((all-tags (db:all-subscribed-tags-name))
|
|
|
|
(all-paginations (db:all-tag-paginations-status all-tags)))
|
2020-05-08 15:45:43 +02:00
|
|
|
(flet ((update ()
|
2020-05-14 20:23:40 +02:00
|
|
|
(client:update-subscribed-tags all-tags all-paginations)
|
2020-05-08 15:45:43 +02:00
|
|
|
(let ((update-got-message-event
|
|
|
|
(make-instance 'tag-mark-got-messages-event))
|
|
|
|
(notify-event
|
|
|
|
(make-instance 'notify-fetched-new-tag-messages-event))
|
|
|
|
(update-subscribed-event
|
|
|
|
(make-instance 'update-last-refresh-subscribe-tags-event))
|
|
|
|
(refresh-window-event (make-instance 'refresh-tag-window-event)))
|
|
|
|
(push-event update-got-message-event)
|
|
|
|
(push-event notify-event)
|
|
|
|
(push-event update-subscribed-event)
|
|
|
|
(push-event refresh-window-event))))
|
|
|
|
(notify-procedure #'update
|
|
|
|
(_ "Downloading tags messages.")
|
|
|
|
:ending-message (_ "Messages downloaded.")
|
|
|
|
:life-start (* (swconf:config-notification-life) 5)))))
|
|
|
|
|
|
|
|
(defun confirm-selected-row-action (message)
|
2020-09-11 15:18:59 +02:00
|
|
|
(when-let* ((selected-row (line-oriented-window:selected-row-fields *thread-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
(status-id (db:row-message-status-id selected-row))
|
|
|
|
(confirmedp (confirm-dialog-immediate message)))
|
|
|
|
(values status-id selected-row)))
|
|
|
|
|
|
|
|
(defun favourite-selected-status ()
|
|
|
|
"Favourite selected status"
|
|
|
|
(multiple-value-bind (selected-id selected-message)
|
|
|
|
(confirm-selected-row-action (_ "Favorite this message?"))
|
|
|
|
(when selected-id
|
|
|
|
(let ((selected-index (db:row-message-index selected-message)))
|
|
|
|
(flet ((update ()
|
|
|
|
(let* ((favourite-event (make-instance 'favourite-status-event
|
|
|
|
:payload selected-id
|
|
|
|
:message-index selected-index)))
|
|
|
|
(push-event favourite-event))))
|
|
|
|
(notify-procedure #'update
|
|
|
|
(_ "Favouring message.")
|
|
|
|
:ending-message (_ "Favoured message.")))))))
|
|
|
|
|
|
|
|
(defun unfavourite-selected-status ()
|
|
|
|
"Unfavourite selected status"
|
|
|
|
(multiple-value-bind (selected-id selected-message)
|
|
|
|
(confirm-selected-row-action (_ "Remove this message from your favourites?"))
|
|
|
|
(when selected-id
|
|
|
|
(let ((selected-index (db:row-message-index selected-message)))
|
|
|
|
(flet ((update ()
|
|
|
|
(let* ((unfavourite-event (make-instance 'unfavourite-status-event
|
|
|
|
:payload selected-id
|
|
|
|
:message-index selected-index)))
|
|
|
|
(push-event unfavourite-event))))
|
|
|
|
(notify-procedure #'update
|
|
|
|
(_ "Unfavouring message.")
|
|
|
|
:ending-message (_ "Unfavoured message.")))))))
|
|
|
|
|
|
|
|
(defun boost-selected-status ()
|
|
|
|
"Boost selected status"
|
|
|
|
(multiple-value-bind (selected-id selected-message)
|
|
|
|
(confirm-selected-row-action (_ "Boost this message?"))
|
|
|
|
(when selected-id
|
|
|
|
(let ((selected-index (db:row-message-index selected-message)))
|
|
|
|
(flet ((update ()
|
|
|
|
(let* ((reblog-event (make-instance 'reblog-status-event
|
|
|
|
:payload selected-id
|
|
|
|
:message-index selected-index)))
|
|
|
|
(push-event reblog-event))))
|
|
|
|
(notify-procedure #'update
|
|
|
|
(_ "Boosting message.")
|
|
|
|
:ending-message (_ "Boosted message.")))))))
|
|
|
|
|
|
|
|
(defun unboost-selected-status ()
|
|
|
|
"Unboost selected status"
|
|
|
|
(multiple-value-bind (selected-id selected-message)
|
|
|
|
(confirm-selected-row-action (_ "Unboost this message?"))
|
|
|
|
(when selected-id
|
|
|
|
(let ((selected-index (db:row-message-index selected-message)))
|
|
|
|
(flet ((update ()
|
|
|
|
(let* ((unreblog-event (make-instance 'unreblog-status-event
|
|
|
|
:payload selected-id
|
|
|
|
:message-index selected-index)))
|
|
|
|
(push-event unreblog-event))))
|
|
|
|
(notify-procedure #'update
|
|
|
|
(_ "Uboosting message.")
|
|
|
|
:ending-message (_ "Unboosted message.")))))))
|
|
|
|
|
|
|
|
(defun ignore-user ()
|
|
|
|
"Ignore user"
|
|
|
|
(when-let* ((selected-row (line-oriented-window:selected-row-fields
|
2020-09-11 15:18:59 +02:00
|
|
|
*thread-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
(username (db:row-message-username selected-row))
|
|
|
|
(selected-id (confirm-selected-row-action (format nil
|
|
|
|
(_ "Ignore ~s?")
|
|
|
|
username))))
|
|
|
|
(with-blocking-notify-procedure
|
|
|
|
((format nil (_ "Ignoring ~s") username)
|
|
|
|
(format nil (_ "User ~s ignored") username))
|
|
|
|
(db:ignore-status-author selected-id))))
|
|
|
|
|
|
|
|
(defun unignore-user ()
|
|
|
|
"Unignore user"
|
|
|
|
(flet ((on-input-complete (username)
|
|
|
|
(let* ((event (make-instance 'unignore-user-event
|
|
|
|
:payload username)))
|
|
|
|
(if (string-not-empty-p username)
|
|
|
|
(push-event event)
|
|
|
|
(error-message (_ "No username specified."))))))
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt (_ "Unignore username: ")
|
|
|
|
:complete-fn #'complete:ignored-username-complete)))
|
|
|
|
|
|
|
|
(defun attach-move (amount)
|
|
|
|
(ignore-errors
|
2020-09-11 15:18:59 +02:00
|
|
|
(line-oriented-window:unselect-all *send-message-window*)
|
|
|
|
(line-oriented-window:row-move *send-message-window* amount)
|
|
|
|
(draw *send-message-window*)))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun attach-go-down ()
|
|
|
|
(attach-move 1))
|
|
|
|
|
|
|
|
(defun attach-go-up ()
|
|
|
|
(attach-move -1))
|
|
|
|
|
|
|
|
(defun attach-delete ()
|
|
|
|
"Delete an attach"
|
2020-09-11 15:18:59 +02:00
|
|
|
(line-oriented-window:selected-row-delete *send-message-window*)
|
|
|
|
(win-clear *send-message-window*)
|
|
|
|
(draw *send-message-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun attach-add ()
|
|
|
|
"Add an attach"
|
|
|
|
(flet ((on-add-attach (attach-path)
|
2020-05-09 21:58:12 +02:00
|
|
|
(if (string-not-empty-p attach-path)
|
|
|
|
(let ((add-event (make-instance 'send-message-add-attachment-event
|
|
|
|
:payload attach-path)))
|
|
|
|
(if (fs:file-exists-p attach-path)
|
|
|
|
(push-event add-event)
|
|
|
|
(error-message (format nil (_ "File ~s does not exists.") attach-path)))
|
|
|
|
(attach-add))
|
|
|
|
(info-message (_ "Message ready to be sent")))))
|
2020-05-08 15:45:43 +02:00
|
|
|
(ask-string-input #'on-add-attach
|
|
|
|
:prompt (_ "Add attachment: ")
|
|
|
|
:complete-fn #'complete:directory-complete)))
|
|
|
|
|
|
|
|
(defun change-subject ()
|
|
|
|
"Change subject"
|
|
|
|
(flet ((on-change-subject (new-subject)
|
|
|
|
(let* ((event (make-instance 'send-message-change-subject-event
|
|
|
|
:payload new-subject)))
|
|
|
|
(push-event event))))
|
|
|
|
(ask-string-input #'on-change-subject
|
|
|
|
:prompt (_ "New subject: "))))
|
|
|
|
|
|
|
|
(defun change-visibility ()
|
|
|
|
"Change message's visibility"
|
|
|
|
(flet ((on-change-visibility (new-visibility)
|
|
|
|
(let* ((event (make-instance 'send-message-change-visibility-event
|
|
|
|
:payload new-visibility)))
|
|
|
|
(push-event event))))
|
|
|
|
(ask-string-input #'on-change-visibility
|
|
|
|
:prompt (_ "New visibility: ")
|
|
|
|
:complete-fn #'complete:visibility-complete)))
|
|
|
|
|
2020-09-18 16:32:04 +02:00
|
|
|
(defun change-mentions ()
|
|
|
|
"Change mentions"
|
|
|
|
(flet ((on-add-mentions (new-mentions)
|
|
|
|
(let* ((event (make-instance 'send-message-change-mentions-event
|
|
|
|
:payload new-mentions)))
|
|
|
|
(push-event event))))
|
|
|
|
(ask-string-input #'on-add-mentions
|
|
|
|
:prompt (_ "Add mentions: ")
|
|
|
|
:complete-fn #'complete:username-complete)))
|
|
|
|
|
2020-05-08 15:45:43 +02:00
|
|
|
(defmacro close-window-and-return-to-threads (window-to-close)
|
|
|
|
`(progn
|
|
|
|
(win-close ,window-to-close)
|
|
|
|
(setf ,window-to-close nil)
|
|
|
|
(focus-to-thread-window)))
|
|
|
|
|
2020-06-28 11:46:24 +02:00
|
|
|
(defmacro close-window-and-return-to-message (window-to-close)
|
|
|
|
`(progn
|
|
|
|
(win-close ,window-to-close)
|
|
|
|
(setf ,window-to-close nil)
|
|
|
|
(focus-to-message-window)))
|
|
|
|
|
2020-05-08 15:45:43 +02:00
|
|
|
(defun cancel-send-message ()
|
|
|
|
"Cancel sending operation"
|
2020-09-11 15:18:59 +02:00
|
|
|
(close-window-and-return-to-threads *send-message-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun edit-message-body ()
|
|
|
|
"Edit message"
|
2020-09-11 15:18:59 +02:00
|
|
|
(when (and *send-message-window*
|
|
|
|
(sending-message:message-data *send-message-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
(with-accessors ((body sending-message:body)
|
|
|
|
(subject sending-message:subject)
|
|
|
|
(reply-to sending-message:reply-to)
|
|
|
|
(visibility sending-message:visibility))
|
2020-09-11 15:18:59 +02:00
|
|
|
(sending-message:message-data *send-message-window*)
|
2020-06-23 13:12:35 +02:00
|
|
|
(let ((temp-file (fs:temporary-file)))
|
2020-05-08 15:45:43 +02:00
|
|
|
(with-open-file (stream temp-file
|
|
|
|
:direction :output
|
|
|
|
:if-exists :supersede
|
|
|
|
:if-does-not-exist :error)
|
|
|
|
(write-sequence body stream))
|
|
|
|
(croatoan:end-screen)
|
2021-05-29 14:48:02 +02:00
|
|
|
(tui:with-notify-errors
|
|
|
|
(os-utils:open-with-editor temp-file))
|
2020-05-08 15:45:43 +02:00
|
|
|
(setf body (fs:slurp-file temp-file))))))
|
|
|
|
|
|
|
|
(defun close-send-message-window ()
|
|
|
|
"Close message window and cancel operation"
|
|
|
|
(cancel-send-message))
|
|
|
|
|
|
|
|
(defparameter *message-to-send* nil)
|
|
|
|
|
|
|
|
(defun message-exceeds-server-limit-p (body)
|
|
|
|
(if (> (length body)
|
|
|
|
(swconf:max-message-length))
|
|
|
|
(- (length body)
|
|
|
|
(swconf:max-message-length))
|
|
|
|
nil))
|
|
|
|
|
|
|
|
(defun exceeding-characters-notify (exceeding)
|
|
|
|
(error-message (format nil
|
|
|
|
(n_ "Your message is ~a character too long."
|
|
|
|
"Your message is ~a characters too long."
|
|
|
|
exceeding)
|
|
|
|
exceeding)))
|
|
|
|
|
2020-12-27 14:51:59 +01:00
|
|
|
(defun compose-message (&key timeline folder reply-id subject (visibility +status-public-visibility+) (message-header-text nil))
|
2020-05-08 15:45:43 +02:00
|
|
|
"Compose a new message"
|
|
|
|
(setf *message-to-send* (make-instance 'sending-message:message-ready-to-send
|
|
|
|
:visibility visibility
|
|
|
|
:reply-to reply-id
|
|
|
|
:subject subject))
|
|
|
|
(labels ((open-window ()
|
|
|
|
(let ((event (make-instance 'open-send-message-window-event
|
|
|
|
:payload *message-to-send*)))
|
|
|
|
(push-event event)))
|
|
|
|
(add-subject ()
|
|
|
|
(flet ((on-add-subject (new-subject)
|
|
|
|
(setf (sending-message:subject *message-to-send*)
|
|
|
|
new-subject)
|
|
|
|
(open-window)
|
|
|
|
(attach-add)))
|
|
|
|
(let ((old-subject (sending-message:subject *message-to-send*)))
|
|
|
|
(if (string-empty-p old-subject)
|
|
|
|
(ask-string-input #'on-add-subject
|
|
|
|
:prompt (_ "Add subject: "))
|
|
|
|
(progn
|
|
|
|
(open-window)
|
|
|
|
(attach-add))))))
|
|
|
|
(prepare-reply-body (file)
|
|
|
|
(when reply-id
|
|
|
|
;; we do not need to take into account folder or
|
|
|
|
;; timeline here as the id in unique identifier for a
|
|
|
|
;; single message *content* regardless of the position
|
|
|
|
;; in db (folder, timeline).
|
2020-05-15 17:39:23 +02:00
|
|
|
(when-let* ((message (db:find-message-id reply-id))
|
|
|
|
(reply-username (db:row-message-username message))
|
|
|
|
(quoted-text (db:row-message-rendered-text message))
|
|
|
|
(lines (split-lines quoted-text))
|
|
|
|
(quote-mark (swconf:quote-char))
|
|
|
|
(quoted-lines (mapcar (lambda (a) (strcat quote-mark a))
|
2020-07-18 13:03:58 +02:00
|
|
|
lines))
|
|
|
|
(thread-users (db:message->thread-users timeline
|
|
|
|
folder
|
2020-07-19 13:27:40 +02:00
|
|
|
reply-id
|
|
|
|
:local-name-prefix
|
|
|
|
message-rendering-utils:+temp-mention-prefix+
|
|
|
|
:acct-prefix
|
|
|
|
+mention-prefix+)))
|
2020-05-08 15:45:43 +02:00
|
|
|
(with-open-file (stream file
|
|
|
|
:if-exists :append
|
|
|
|
:direction :output
|
|
|
|
:element-type 'character)
|
2020-05-15 17:39:23 +02:00
|
|
|
(format stream "~a~%" (msg-utils:add-mention-prefix reply-username))
|
2020-05-08 15:45:43 +02:00
|
|
|
(loop for line in quoted-lines do
|
2020-07-18 13:03:58 +02:00
|
|
|
(let ((line-fixed-mentions
|
|
|
|
(message-rendering-utils:local-mention->acct line
|
|
|
|
thread-users)))
|
|
|
|
(format stream "~a~%" line-fixed-mentions)))))))
|
2020-06-25 12:29:35 +02:00
|
|
|
(add-signature (file)
|
|
|
|
(when-let ((signature (message-rendering-utils:signature)))
|
|
|
|
(with-open-file (stream
|
|
|
|
file
|
|
|
|
:direction :output
|
|
|
|
:element-type 'character
|
|
|
|
:if-exists :append)
|
2020-09-18 15:55:22 +02:00
|
|
|
(write-sequence signature stream))))
|
2020-12-27 14:51:59 +01:00
|
|
|
(insert-header-text (file)
|
2020-12-28 15:37:13 +01:00
|
|
|
(when (string-not-empty-p message-header-text)
|
2020-12-27 14:51:59 +01:00
|
|
|
(with-open-file (stream file
|
|
|
|
:if-exists :append
|
|
|
|
:direction :output
|
|
|
|
:element-type 'character)
|
|
|
|
(format stream "~a~%" message-header-text))))
|
2020-05-08 15:45:43 +02:00
|
|
|
(add-body ()
|
2020-06-25 12:29:35 +02:00
|
|
|
(let ((temp-file (fs:temporary-file)))
|
2020-12-27 14:51:59 +01:00
|
|
|
(insert-header-text temp-file)
|
2020-09-18 15:55:22 +02:00
|
|
|
(prepare-reply-body temp-file)
|
|
|
|
(add-signature temp-file)
|
|
|
|
(let ((reference-open-file (get-universal-time)))
|
|
|
|
(croatoan:end-screen)
|
2021-05-29 14:48:02 +02:00
|
|
|
(tui:with-notify-errors
|
|
|
|
(os-utils:open-with-editor temp-file))
|
2020-09-18 15:55:22 +02:00
|
|
|
(when (and (> (fs:file-size temp-file)
|
|
|
|
0)
|
|
|
|
(> (fs:get-stat-mtime temp-file)
|
|
|
|
reference-open-file))
|
|
|
|
(let ((body (fs:slurp-file temp-file)))
|
|
|
|
(setf (sending-message:body *message-to-send*) body)
|
|
|
|
(add-subject)))))))
|
2020-05-08 15:45:43 +02:00
|
|
|
(add-body)))
|
|
|
|
|
2020-11-07 15:57:45 +01:00
|
|
|
(defun actual-author-message-id (message-row)
|
|
|
|
(or (db:row-message-reblog-id message-row)
|
|
|
|
(db:row-message-status-id message-row)))
|
|
|
|
|
2020-05-08 15:45:43 +02:00
|
|
|
(defun reply-message ()
|
|
|
|
"Reply to message"
|
2020-09-11 15:18:59 +02:00
|
|
|
(when-let* ((win *thread-window*)
|
2020-05-08 15:45:43 +02:00
|
|
|
(selected-message (line-oriented-window:selected-row-fields win))
|
2020-11-07 15:57:45 +01:00
|
|
|
(actual-message (if (db:row-message-reblog-id selected-message)
|
|
|
|
(db:find-message-id (db:row-message-reblog-id selected-message))
|
|
|
|
selected-message))
|
|
|
|
(timeline (db:row-message-timeline actual-message))
|
2020-07-18 13:03:58 +02:00
|
|
|
(folder (thread-window:timeline-folder win))
|
2020-11-07 15:57:45 +01:00
|
|
|
(username (db:row-message-username actual-message))
|
|
|
|
(visibility (db:row-message-visibility actual-message))
|
|
|
|
(reply-id (actual-author-message-id actual-message)))
|
|
|
|
(let* ((subject (db:row-message-subject actual-message)))
|
2020-12-27 14:51:59 +01:00
|
|
|
(compose-message :timeline timeline
|
|
|
|
:folder folder
|
|
|
|
:reply-id reply-id
|
|
|
|
:subject subject
|
|
|
|
:visibility visibility))))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun send-message ()
|
|
|
|
"Send message"
|
2020-09-11 15:18:59 +02:00
|
|
|
(when (and *send-message-window*
|
|
|
|
(sending-message:message-data *send-message-window*))
|
|
|
|
(let ((data (sending-message:message-data *send-message-window*))
|
2021-04-08 15:13:31 +02:00
|
|
|
(attachments-count (line-oriented-window:rows-length *send-message-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
(max-allowed-attach (swconf:max-attachments-allowed)))
|
2021-04-08 15:13:31 +02:00
|
|
|
(if (> attachments-count
|
2020-05-08 15:45:43 +02:00
|
|
|
max-allowed-attach)
|
|
|
|
(error-message (format nil
|
|
|
|
(_ "The maximum allowed number of media is ~a.")
|
|
|
|
(swconf:max-attachments-allowed)))
|
|
|
|
(progn
|
|
|
|
(notify (_ "Sending message"))
|
|
|
|
(let ((event (make-instance 'send-message-event
|
|
|
|
:use-ui-notification t
|
|
|
|
:payload data)))
|
|
|
|
(push-event event)))))))
|
|
|
|
|
|
|
|
(defun open-message-attach ()
|
2020-06-07 13:00:19 +02:00
|
|
|
"Open message attachments window"
|
2020-09-11 15:18:59 +02:00
|
|
|
(when-let* ((win *thread-window*)
|
2020-05-08 15:45:43 +02:00
|
|
|
(selected-message (line-oriented-window:selected-row-fields win)))
|
|
|
|
(open-attach-window:init (db:row-message-status-id selected-message))
|
|
|
|
(focus-to-open-attach-window)))
|
|
|
|
|
2021-09-09 18:27:32 +02:00
|
|
|
(defun open-all-message-attachments ()
|
|
|
|
(when-let* ((win *thread-window*)
|
|
|
|
(selected-message (line-oriented-window:selected-row-fields win))
|
|
|
|
(status-id (db:row-message-status-id selected-message))
|
|
|
|
(attachment-urls (db:all-attachments-urls-to-status status-id
|
|
|
|
:add-reblogged-urls t)))
|
|
|
|
(loop for attachment-url in attachment-urls do
|
|
|
|
(open-attach-window:open-attachment attachment-url))))
|
|
|
|
|
2020-05-08 15:45:43 +02:00
|
|
|
(defun open-message-attach-move (amount)
|
|
|
|
(ignore-errors
|
2020-09-11 15:18:59 +02:00
|
|
|
(line-oriented-window:unselect-all *open-attach-window*)
|
|
|
|
(line-oriented-window:row-move *open-attach-window* amount)
|
|
|
|
(draw *open-attach-window*)))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun open-message-attach-go-down ()
|
|
|
|
(open-message-attach-move 1))
|
|
|
|
|
|
|
|
(defun open-message-attach-go-up ()
|
|
|
|
(open-message-attach-move -1))
|
|
|
|
|
|
|
|
(defun open-message-attach-perform-opening ()
|
2020-09-11 15:18:59 +02:00
|
|
|
(when-let* ((selected-line (line-oriented-window:selected-row *open-attach-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
(url (line-oriented-window:normal-text selected-line)))
|
|
|
|
(open-attach-window:open-attachment url)))
|
|
|
|
|
2020-05-17 17:47:33 +02:00
|
|
|
(defun close-open-attach-window ()
|
2020-09-11 15:18:59 +02:00
|
|
|
(close-window-and-return-to-threads *open-attach-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
2020-10-03 16:58:02 +02:00
|
|
|
(defun search-link-window ()
|
|
|
|
"Search a link window with a text matching a regular expression"
|
|
|
|
(flet ((on-input-complete (regex)
|
|
|
|
(when-let* ((window (main-window:focused-window *main-window*)))
|
|
|
|
(let ((event (make-instance 'search-link-event
|
|
|
|
:window window
|
|
|
|
:regex regex)))
|
|
|
|
(push-event event)))))
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt (_ "Search key: ")
|
|
|
|
:complete-fn #'complete:complete-always-empty)))
|
|
|
|
|
2020-06-22 13:58:04 +02:00
|
|
|
(defun open-gemini-message-link-window ()
|
2020-09-11 15:18:59 +02:00
|
|
|
(let* ((window *message-window*)
|
2020-06-28 17:39:21 +02:00
|
|
|
(metadata (message-window:metadata window))
|
|
|
|
(links (gemini-viewer:gemini-metadata-links metadata)))
|
2020-06-22 13:58:04 +02:00
|
|
|
(open-message-link-window:init-gemini-links links)
|
|
|
|
(focus-to-open-message-link-window)))
|
|
|
|
|
2020-05-17 17:47:33 +02:00
|
|
|
(defun open-message-link ()
|
2020-06-07 13:00:19 +02:00
|
|
|
"Open message links window
|
|
|
|
|
2020-06-22 13:58:04 +02:00
|
|
|
Browse and optionally open the links the text of the message window contains."
|
2020-09-11 15:18:59 +02:00
|
|
|
(if (message-window:display-gemini-text-p *message-window*)
|
2020-06-22 13:58:04 +02:00
|
|
|
(open-gemini-message-link-window)
|
2020-09-11 15:18:59 +02:00
|
|
|
(when-let* ((win *thread-window*)
|
2020-06-22 13:58:04 +02:00
|
|
|
(selected-message (line-oriented-window:selected-row-fields win)))
|
|
|
|
(open-message-link-window:init (db:row-message-status-id selected-message))
|
|
|
|
(focus-to-open-message-link-window))))
|
2020-05-17 17:47:33 +02:00
|
|
|
|
2021-10-30 18:39:08 +02:00
|
|
|
(defun open-next-visible-link ()
|
2022-01-06 18:17:07 +01:00
|
|
|
"Open next visible link in the window"
|
2021-10-30 18:39:08 +02:00
|
|
|
(when-let* ((visible-rows (message-window:visible-rows *message-window*))
|
|
|
|
(link-line (message-window:row-find-original-object visible-rows
|
|
|
|
'gemini-parser:link-line))
|
2021-12-04 14:33:53 +01:00
|
|
|
(link-object (message-window:extract-original-object link-line)))
|
|
|
|
(let* ((uri (gemini-parser::link-value link-object))
|
|
|
|
(current-url (ignore-errors (iri:iri-parse (gemini-viewer:current-gemini-url))))
|
|
|
|
(absolute-uri (if (or (null current-url)
|
|
|
|
(iri:absolute-url-p uri))
|
|
|
|
uri
|
|
|
|
(gemini-parser:absolutize-link uri
|
|
|
|
(uri:host current-url)
|
|
|
|
(uri:port current-url)
|
|
|
|
(uri:path current-url)))))
|
|
|
|
(open-message-link-window:open-message-link absolute-uri nil))))
|
2021-10-30 18:39:08 +02:00
|
|
|
|
2021-11-26 14:10:11 +01:00
|
|
|
(defun go-to-next-link ()
|
|
|
|
(when-let* ((win *message-window*)
|
|
|
|
(1+selected-row-pos (1+ (line-oriented-window:row-selected-index win)))
|
|
|
|
(link-line-pos (message-window:row-position-original-object win
|
2022-01-06 18:17:07 +01:00
|
|
|
'gemini-parser:link-line
|
|
|
|
:start 1+selected-row-pos)))
|
2021-11-26 14:10:11 +01:00
|
|
|
(line-oriented-window:row-move win (- link-line-pos (1- 1+selected-row-pos)))
|
|
|
|
(windows:draw win)))
|
|
|
|
|
|
|
|
(defun go-to-previous-link ()
|
|
|
|
(when-let* ((win *message-window*)
|
|
|
|
(selected-row-pos (line-oriented-window:row-selected-index win))
|
|
|
|
(link-line-pos (message-window:row-position-original-object win
|
|
|
|
'gemini-parser:link-line
|
|
|
|
:end selected-row-pos
|
|
|
|
:from-end t)))
|
|
|
|
(line-oriented-window:row-move win (- link-line-pos selected-row-pos))
|
|
|
|
(windows:draw win)))
|
|
|
|
|
2020-10-23 20:57:17 +02:00
|
|
|
(defun line-window-move (win amount)
|
|
|
|
(ignore-errors
|
|
|
|
(line-oriented-window:unselect-all win)
|
|
|
|
(line-oriented-window:row-move win amount)
|
|
|
|
(draw win)))
|
|
|
|
|
|
|
|
(defun line-window-go-up (win)
|
|
|
|
(line-window-move win -1))
|
|
|
|
|
|
|
|
(defun line-window-go-down (win)
|
|
|
|
(line-window-move win 1))
|
|
|
|
|
2020-05-17 17:47:33 +02:00
|
|
|
(defun open-message-link-move (amount)
|
|
|
|
(ignore-errors
|
2020-09-11 15:18:59 +02:00
|
|
|
(line-oriented-window:unselect-all *open-message-link-window*)
|
|
|
|
(line-oriented-window:row-move *open-message-link-window* amount)
|
|
|
|
(draw *open-message-link-window*)))
|
2020-05-17 17:47:33 +02:00
|
|
|
|
|
|
|
(defun open-message-link-go-down ()
|
|
|
|
(open-message-link-move 1))
|
|
|
|
|
|
|
|
(defun open-message-link-go-up ()
|
|
|
|
(open-message-link-move -1))
|
|
|
|
|
2020-09-11 15:18:59 +02:00
|
|
|
(defun %open-message-link-perform-opening (enqueue)
|
|
|
|
(when-let* ((selected-line (line-oriented-window:selected-row *open-message-link-window*))
|
2020-05-17 17:47:33 +02:00
|
|
|
(url (line-oriented-window:normal-text selected-line)))
|
2020-09-11 15:18:59 +02:00
|
|
|
(open-message-link-window:open-message-link url enqueue)))
|
|
|
|
|
|
|
|
(defun open-message-link-perform-opening ()
|
|
|
|
(%open-message-link-perform-opening nil))
|
|
|
|
|
|
|
|
(defun open-message-link-open-enqueue ()
|
|
|
|
"Open the url and keep the data stream in background
|
|
|
|
|
|
|
|
This makes sense only for gemini file stream, if not this command performs the same as
|
|
|
|
'open-message-link-perform-opening'"
|
|
|
|
(%open-message-link-perform-opening t))
|
2020-05-17 17:47:33 +02:00
|
|
|
|
|
|
|
(defun close-open-message-link-window ()
|
2021-08-16 21:39:13 +02:00
|
|
|
(when-window-shown (*open-message-link-window*)
|
|
|
|
(when (message-window:display-gemini-text-p *open-message-link-window*)
|
|
|
|
(open-message-link-window:forget-gemini-link-window))
|
|
|
|
(if (message-window:display-gemini-text-p *message-window*)
|
|
|
|
(close-window-and-return-to-message *open-message-link-window*)
|
|
|
|
(close-window-and-return-to-threads *open-message-link-window*))))
|
2020-05-17 17:47:33 +02:00
|
|
|
|
2020-10-23 20:57:17 +02:00
|
|
|
(defun gemini-open-certificates-window ()
|
|
|
|
"Open a window with all the client certificated generated so far to
|
|
|
|
authenticate this client on a gemini server."
|
|
|
|
(gemini-certificates-window:open-gemini-certificates-window)
|
|
|
|
(focus-to-open-gemini-certificates-window))
|
|
|
|
|
|
|
|
(defun gemini-certificate-window-move (amount)
|
|
|
|
(line-window-move *gemini-certificates-window* amount))
|
|
|
|
|
|
|
|
(defun gemini-certificate-window-go-down ()
|
|
|
|
(line-window-go-down *gemini-certificates-window*))
|
|
|
|
|
|
|
|
(defun gemini-certificate-window-go-up ()
|
|
|
|
(line-window-go-up *gemini-certificates-window*))
|
|
|
|
|
|
|
|
(defun gemini-close-certificate-window ()
|
|
|
|
(close-window-and-return-to-message *gemini-certificates-window*))
|
|
|
|
|
|
|
|
(defun gemini-delete-certificate ()
|
|
|
|
"Delete a gemini certificate, this could makes all user data on the
|
|
|
|
server unreachable as the server will not be able to identify the client.
|
|
|
|
|
2021-05-01 13:44:50 +02:00
|
|
|
Of course could be possible to generate a new identity (i.e. a new
|
2020-10-23 20:57:17 +02:00
|
|
|
certificate).
|
|
|
|
"
|
|
|
|
(flet ((on-input-complete (answer)
|
|
|
|
(when (boolean-input-accepted-p answer)
|
|
|
|
(db-utils:with-ready-database (:connect nil)
|
|
|
|
(let* ((selected-row (line-oriented-window:selected-row-fields
|
|
|
|
*gemini-certificates-window*))
|
|
|
|
(cache-key (db:row-cache-key selected-row))
|
|
|
|
(event (make-instance 'function-event
|
|
|
|
:payload
|
|
|
|
(lambda ()
|
|
|
|
(line-oriented-window:resync-rows-db
|
|
|
|
*gemini-certificates-window*
|
|
|
|
:suggested-message-index 0)))))
|
|
|
|
(db:cache-invalidate cache-key)
|
|
|
|
(push-event event))))))
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt (_ "Delete this certificate? [Y/n] ")
|
|
|
|
:complete-fn #'complete:complete-always-empty)))
|
|
|
|
|
2021-01-09 16:27:40 +01:00
|
|
|
(defun gemini-open-gemlog-window ()
|
|
|
|
"Open a window with all the gemlog subscribed."
|
|
|
|
(gemini-subscription-window:open-gemini-subscription-window)
|
|
|
|
(focus-to-open-gemini-subscription-window))
|
|
|
|
|
|
|
|
(defun close-gemlog-window ()
|
|
|
|
(close-window-and-return-to-threads *gemini-subscription-window*))
|
|
|
|
|
2021-01-10 11:35:28 +01:00
|
|
|
(defmacro with-selected-gemlog-id ((fields gemlog-id) &body body)
|
|
|
|
`(when-let* ((,fields (line-oriented-window:selected-row-fields *gemini-subscription-window*))
|
|
|
|
(,gemlog-id (db:row-url ,fields)))
|
|
|
|
,@body))
|
|
|
|
|
|
|
|
(defun gemlog-cancel-subscription ()
|
|
|
|
(with-selected-gemlog-id (fields gemlog-id)
|
2021-01-28 16:14:00 +01:00
|
|
|
(when-let* ((event (make-instance 'program-events:gemlog-cancel-subscription-event
|
|
|
|
:payload gemlog-id)))
|
2021-01-10 11:35:28 +01:00
|
|
|
(with-blocking-notify-procedure ((format nil (_ "Canceling subscription for ~s") gemlog-id))
|
|
|
|
(program-events:push-event event)))))
|
|
|
|
|
2021-01-10 13:01:03 +01:00
|
|
|
(defun show-gemlog-to-screen ()
|
2021-01-10 11:35:28 +01:00
|
|
|
(with-selected-gemlog-id (fields gemlog-id)
|
|
|
|
(when-let* ((entries (db:gemlog-entries gemlog-id))
|
|
|
|
(event (make-instance 'program-events:gemlog-show-event
|
|
|
|
:gemlog-url gemlog-id
|
|
|
|
:title (db:row-title fields)
|
|
|
|
:subtitle (db:row-subtitle fields)
|
|
|
|
:entries entries)))
|
2021-01-11 19:14:53 +01:00
|
|
|
(program-events:push-event event))))
|
2021-01-10 11:35:28 +01:00
|
|
|
|
2021-01-10 13:01:03 +01:00
|
|
|
(defun gemlog-refresh-all ()
|
2021-07-31 11:04:18 +02:00
|
|
|
(program-events:push-event (make-instance 'program-events:gemlog-refresh-all-event)))
|
2021-01-09 16:27:40 +01:00
|
|
|
|
2020-05-08 15:45:43 +02:00
|
|
|
(defun prompt-for-username (prompt complete-function event
|
|
|
|
notify-starting-message
|
|
|
|
notify-ending-message)
|
|
|
|
(flet ((on-input-complete (username)
|
|
|
|
(when (string-not-empty-p username)
|
2021-11-16 10:15:06 +01:00
|
|
|
(progn
|
|
|
|
(notify (format nil notify-starting-message username))
|
|
|
|
(let ((event (make-instance event :payload username)))
|
|
|
|
(push-event event))
|
|
|
|
(when notify-ending-message
|
|
|
|
(notify (format nil notify-ending-message username)))))))
|
2020-05-08 15:45:43 +02:00
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt prompt
|
|
|
|
:complete-fn complete-function)))
|
|
|
|
(defun follow-user ()
|
|
|
|
"Follow user"
|
|
|
|
(prompt-for-username (_ "Follow: ")
|
|
|
|
#'complete:unfollowed-user-complete
|
|
|
|
'follow-user-event
|
|
|
|
(_ "Following ~a")
|
2021-11-16 10:15:06 +01:00
|
|
|
nil))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun unfollow-user ()
|
|
|
|
"Unfollow user"
|
|
|
|
(prompt-for-username (_ "Unfollow: ")
|
|
|
|
#'complete:followed-user-complete
|
|
|
|
'unfollow-user-event
|
|
|
|
(_ "Unfollowing ~a")
|
2021-11-16 10:15:06 +01:00
|
|
|
nil))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun follow-request-move (amount)
|
|
|
|
(ignore-errors
|
2020-09-11 15:18:59 +02:00
|
|
|
(line-oriented-window:unselect-all *follow-requests-window*)
|
|
|
|
(line-oriented-window:row-move *follow-requests-window* amount)
|
|
|
|
(draw *follow-requests-window*)))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun follow-request-go-down ()
|
|
|
|
(follow-request-move 1))
|
|
|
|
|
|
|
|
(defun follow-request-go-up ()
|
|
|
|
(follow-request-move -1))
|
|
|
|
|
|
|
|
(defun follow-request-delete ()
|
2020-09-11 15:18:59 +02:00
|
|
|
(line-oriented-window:selected-row-delete *follow-requests-window*)
|
2021-06-12 21:15:50 +02:00
|
|
|
(win-clear *follow-requests-window*)
|
2020-09-11 15:18:59 +02:00
|
|
|
(draw *follow-requests-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun start-follow-request-processing ()
|
|
|
|
(let ((event (make-instance 'open-follow-requests-window-event)))
|
|
|
|
(push-event event)))
|
|
|
|
|
|
|
|
(defun close-follow-requests-window ()
|
2020-09-11 15:18:59 +02:00
|
|
|
(close-window-and-return-to-threads *follow-requests-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun cancel-follow-requests ()
|
|
|
|
(close-follow-requests-window))
|
|
|
|
|
|
|
|
(defun process-follow-requests ()
|
|
|
|
(when (confirm-dialog-immediate (_ "Confirm operation?"))
|
|
|
|
(follow-requests:process-requests))
|
|
|
|
(close-follow-requests-window))
|
|
|
|
|
|
|
|
(defun tag-move (amount)
|
|
|
|
(ignore-errors
|
2020-09-11 15:18:59 +02:00
|
|
|
(line-oriented-window:unselect-all *tags-window*)
|
|
|
|
(line-oriented-window:row-move *tags-window* amount)
|
|
|
|
(draw *tags-window*)))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun tag-go-down ()
|
|
|
|
(tag-move 1))
|
|
|
|
|
|
|
|
(defun tag-go-up ()
|
|
|
|
(tag-move -1))
|
|
|
|
|
|
|
|
(defun open-tag-folder ()
|
|
|
|
"Open tag folder"
|
2020-09-11 15:18:59 +02:00
|
|
|
(when-let* ((selected-line (line-oriented-window:selected-row *tags-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
(tag (line-oriented-window:normal-text selected-line))
|
|
|
|
(refresh-thread (make-instance 'refresh-thread-windows-event
|
|
|
|
:new-timeline db:+default-tag-timeline+
|
|
|
|
:new-folder tag))
|
|
|
|
(refresh-tags (make-instance 'refresh-tag-window-event)))
|
|
|
|
(db:unmark-tag-got-new-messages (db:folder-name->tag tag))
|
|
|
|
(push-event refresh-tags)
|
|
|
|
(push-event refresh-thread)))
|
|
|
|
|
|
|
|
(defun update-conversations ()
|
|
|
|
"Update conversations"
|
|
|
|
(flet ((update ()
|
2020-09-11 15:18:59 +02:00
|
|
|
(let* ((timeline (thread-window:timeline-type *thread-window*))
|
|
|
|
(folder (thread-window:timeline-folder *thread-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
(update-event (make-instance 'update-conversations-event
|
|
|
|
:new-timeline timeline
|
|
|
|
:new-folder folder)))
|
|
|
|
(push-event update-event))))
|
|
|
|
(notify-procedure #'update
|
|
|
|
(_ "Updating conversations.")
|
|
|
|
:ending-message (_ "Conversations updated."))))
|
|
|
|
|
|
|
|
(defun open-conversation ()
|
|
|
|
"Open conversation"
|
|
|
|
(flet ((on-input-complete (folder)
|
|
|
|
(let ((refresh-event (make-instance 'refresh-thread-windows-event
|
|
|
|
:new-timeline db:+default-converation-timeline+
|
|
|
|
:new-folder folder)))
|
|
|
|
(push-event refresh-event))))
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt (_ "Open conversation: ")
|
|
|
|
:complete-fn #'complete:conversation-folder)))
|
|
|
|
|
|
|
|
(defun conversation-move (amount)
|
|
|
|
(ignore-errors
|
2020-09-11 15:18:59 +02:00
|
|
|
(line-oriented-window:unselect-all *conversations-window*)
|
|
|
|
(line-oriented-window:row-move *conversations-window* amount)
|
|
|
|
(draw *conversations-window*)))
|
2020-05-08 15:45:43 +02:00
|
|
|
|
|
|
|
(defun conversation-go-down ()
|
|
|
|
(conversation-move 1))
|
|
|
|
|
|
|
|
(defun conversation-go-up ()
|
|
|
|
(conversation-move -1))
|
|
|
|
|
|
|
|
(defun goto-conversation ()
|
|
|
|
(when-let* ((selected-row (line-oriented-window:selected-row
|
2020-09-11 15:18:59 +02:00
|
|
|
*conversations-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
(folder (line-oriented-window:normal-text selected-row))
|
|
|
|
(refresh-event (make-instance 'refresh-thread-windows-event
|
|
|
|
:new-timeline db:+default-converation-timeline+
|
|
|
|
:new-folder folder)))
|
|
|
|
(push-event refresh-event)))
|
|
|
|
|
|
|
|
(defparameter *conversation-old-name* nil)
|
|
|
|
|
|
|
|
(defun change-conversation-name ()
|
|
|
|
"Change conversation's name"
|
|
|
|
(setf *conversation-old-name* nil)
|
|
|
|
(labels ((add-old-name ()
|
|
|
|
(flet ((on-add-old-name (old-name)
|
|
|
|
(when (string-not-empty-p old-name)
|
|
|
|
(setf *conversation-old-name* old-name)
|
|
|
|
(add-new-name))))
|
|
|
|
(ask-string-input #'on-add-old-name
|
|
|
|
:prompt (_ "Old name: ")
|
|
|
|
:complete-fn
|
|
|
|
#'complete:conversation-folder)))
|
|
|
|
(add-new-name ()
|
|
|
|
(flet ((on-add-new-name (new-name)
|
|
|
|
(db-utils:with-ready-database (:connect nil)
|
2020-05-10 19:19:35 +02:00
|
|
|
(let ((update-event (make-instance 'change-conversation-name-event
|
|
|
|
:old-name *conversation-old-name*
|
|
|
|
:new-name new-name))
|
|
|
|
(refresh-event
|
|
|
|
(make-instance 'refresh-conversations-window-event)))
|
2020-05-08 15:45:43 +02:00
|
|
|
(when (string-not-empty-p new-name)
|
|
|
|
(if (db:conversation-folder-exists-p new-name)
|
|
|
|
(error-message (format nil
|
|
|
|
(_ "A conversation with name ~a already exists.")
|
|
|
|
new-name))
|
2020-05-10 19:19:35 +02:00
|
|
|
(progn
|
|
|
|
(push-event update-event)
|
|
|
|
(push-event refresh-event))))))))
|
2020-05-08 15:45:43 +02:00
|
|
|
(ask-string-input #'on-add-new-name
|
|
|
|
:prompt (_ "New name: ")))))
|
|
|
|
(add-old-name)))
|
|
|
|
|
|
|
|
(defun ignore-conversation ()
|
|
|
|
"Ignore conversation"
|
|
|
|
(flet ((on-input-complete (maybe-accepted)
|
|
|
|
(when (boolean-input-accepted-p maybe-accepted)
|
|
|
|
(let ((ignore-event (make-instance 'ignore-conversations-event))
|
|
|
|
(refresh-event (make-instance 'refresh-conversations-window-event)))
|
|
|
|
(push-event ignore-event)
|
|
|
|
(push-event refresh-event)))))
|
|
|
|
(when-let* ((selected-row (line-oriented-window:selected-row
|
2020-09-11 15:18:59 +02:00
|
|
|
*conversations-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
(folder (line-oriented-window:normal-text selected-row)))
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt (format nil
|
|
|
|
(_ "Ignore conversation ~s? [y/N] ")
|
|
|
|
folder)))))
|
|
|
|
|
|
|
|
(defun delete-conversation ()
|
|
|
|
"Delete conversation"
|
|
|
|
(flet ((on-input-complete (maybe-accepted)
|
|
|
|
(when (boolean-input-accepted-p maybe-accepted)
|
|
|
|
(let ((delete-event (make-instance 'delete-conversations-event))
|
|
|
|
(refresh-event (make-instance 'refresh-conversations-window-event)))
|
|
|
|
(push-event delete-event)
|
|
|
|
(push-event refresh-event)))))
|
|
|
|
(when-let* ((selected-row (line-oriented-window:selected-row
|
2020-09-11 15:18:59 +02:00
|
|
|
*conversations-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
(folder (line-oriented-window:normal-text selected-row)))
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt (format nil
|
|
|
|
(_ "Delete conversation ~s? [y/N] ")
|
|
|
|
folder)))))
|
|
|
|
|
|
|
|
(defun report-status ()
|
|
|
|
"Report status to admins"
|
2020-09-11 15:18:59 +02:00
|
|
|
(let* ((selected-row (line-oriented-window:selected-row-fields *thread-window*))
|
2020-05-08 15:45:43 +02:00
|
|
|
(status-id (db:row-message-status-id selected-row))
|
|
|
|
(username (db:row-message-username selected-row))
|
|
|
|
(account-id (db:acct->id username)))
|
|
|
|
(flet ((on-input-complete (comment)
|
|
|
|
(when (string-not-empty-p comment)
|
|
|
|
(let ((event (make-instance 'report-status-event
|
|
|
|
:account-id account-id
|
|
|
|
:status-id status-id
|
|
|
|
:comment comment))
|
|
|
|
(max-comment-length (swconf:max-report-comment-length)))
|
|
|
|
(if (> (length comment)
|
|
|
|
max-comment-length)
|
|
|
|
(error-message (format nil
|
|
|
|
(n_ "Comment too long by ~a character"
|
|
|
|
"Comment too long by ~a characters"
|
|
|
|
(- max-comment-length
|
|
|
|
(length comment)))
|
|
|
|
(- max-comment-length
|
|
|
|
(length comment))))
|
|
|
|
(with-blocking-notify-procedure
|
|
|
|
((format nil (_ "Reporting user: ~s") username)
|
|
|
|
(_ "Report trasmitted."))
|
|
|
|
(push-event event)))))))
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt (_ "Comment on reports: ")))))
|
|
|
|
|
|
|
|
(defparameter *crypto-username* nil)
|
|
|
|
|
|
|
|
(defun crypto-import-key ()
|
|
|
|
"Import crypto key for an user"
|
|
|
|
(setf *crypto-username* nil)
|
|
|
|
(labels ((add-username ()
|
|
|
|
(flet ((on-add-username (username)
|
|
|
|
(db-utils:with-ready-database (:connect nil)
|
|
|
|
(when (string-not-empty-p username)
|
|
|
|
(if (db:user-exists-p username)
|
|
|
|
(progn
|
|
|
|
(setf *crypto-username* username)
|
|
|
|
(add-key))
|
|
|
|
(error-message (format nil
|
|
|
|
(_ "User ~s does not exists in database")
|
|
|
|
username)))))))
|
|
|
|
(ask-string-input #'on-add-username
|
|
|
|
:prompt (_ "Username: ")
|
|
|
|
:complete-fn #'complete:username-complete)))
|
|
|
|
(add-key ()
|
|
|
|
(flet ((on-add-key (key)
|
|
|
|
(let ((event (make-instance 'add-crypto-data-event
|
|
|
|
:username *crypto-username*
|
|
|
|
:key key)))
|
|
|
|
(when (string-not-empty-p key)
|
|
|
|
(push-event event)
|
|
|
|
(notify (format nil
|
|
|
|
(_ "Added crypto key for user ~s")
|
|
|
|
*crypto-username*))))))
|
|
|
|
(ask-string-input #'on-add-key
|
|
|
|
:prompt (_ "Key: ")))))
|
|
|
|
(add-username)))
|
|
|
|
|
|
|
|
(defun crypto-generate-key ()
|
|
|
|
"Generate a crypto key for an user"
|
|
|
|
(labels ((on-add-username (username)
|
|
|
|
(db-utils:with-ready-database (:connect nil)
|
|
|
|
(when (string-not-empty-p username)
|
|
|
|
(if (db:user-exists-p username)
|
|
|
|
(let* ((key (crypto-utils:generate-key))
|
|
|
|
(event (make-instance 'add-crypto-data-event
|
|
|
|
:username username
|
|
|
|
:key key)))
|
|
|
|
(push-event event)
|
|
|
|
(notify (format nil (_ "Generated key for user ~s") username))
|
|
|
|
(info-message (format nil (_ "user ~s key ~s") username key)))
|
|
|
|
(error-message (format nil
|
|
|
|
(_ "User ~s does not exists in database")
|
|
|
|
username)))))))
|
|
|
|
(ask-string-input #'on-add-username
|
|
|
|
:prompt (_ "Username: ")
|
|
|
|
:complete-fn #'complete:username-complete)))
|
|
|
|
|
|
|
|
(defun crypto-export-key ()
|
|
|
|
"Show crypto key for an user"
|
|
|
|
(labels ((on-add-username (username)
|
|
|
|
(db-utils:with-ready-database (:connect nil)
|
|
|
|
(when (string-not-empty-p username)
|
|
|
|
(if (db:user-exists-p username)
|
|
|
|
(let* ((key (db:crypto-user-key username)))
|
|
|
|
(info-message (format nil
|
|
|
|
(_ "Added key for user ~s: ~a")
|
|
|
|
username
|
|
|
|
key)))
|
|
|
|
(error-message (format nil
|
|
|
|
(_ "User ~s does not exists in database")
|
|
|
|
username)))))))
|
|
|
|
(ask-string-input #'on-add-username
|
|
|
|
:prompt (_ "Username: ")
|
|
|
|
:complete-fn #'complete:username-complete)))
|
2020-05-15 16:44:06 +02:00
|
|
|
|
|
|
|
(defun show-about-window ()
|
2020-05-15 19:03:51 +02:00
|
|
|
"Show an informative window about this program"
|
2020-05-15 16:44:06 +02:00
|
|
|
(let ((lines (text-utils:split-lines +help-about-message+))
|
|
|
|
(bg (swconf:win-bg swconf:+key-help-dialog+))
|
|
|
|
(fg (swconf:win-fg swconf:+key-help-dialog+)))
|
2020-09-11 15:18:59 +02:00
|
|
|
(windows:make-blocking-message-dialog *main-window*
|
2020-05-15 16:44:06 +02:00
|
|
|
nil
|
|
|
|
(_ "About this software")
|
|
|
|
lines
|
|
|
|
bg
|
|
|
|
fg)))
|
2021-07-03 12:34:05 +02:00
|
|
|
|
|
|
|
(defun show-welcome-window ()
|
|
|
|
"Show an informative window about this program"
|
|
|
|
(let ((lines (text-utils:split-lines +welcome-message+))
|
|
|
|
(bg (swconf:win-bg swconf:+key-help-dialog+))
|
|
|
|
(fg (swconf:win-fg swconf:+key-help-dialog+)))
|
|
|
|
(windows:make-blocking-message-dialog *main-window*
|
|
|
|
nil
|
2021-08-28 12:41:18 +02:00
|
|
|
(_ " Welcome ")
|
2021-07-03 12:34:05 +02:00
|
|
|
lines
|
|
|
|
bg
|
|
|
|
fg)))
|
|
|
|
|
2020-05-15 19:03:51 +02:00
|
|
|
(defun reset-timeline-pagination ()
|
|
|
|
"Removes the pagination data for current timeline and folder
|
|
|
|
|
2021-08-28 14:02:03 +02:00
|
|
|
For each timeline the software keep tracks of the oldest and newest
|
|
|
|
toot fetched from the instance, This way we can expand the messages
|
|
|
|
thread from the point we left after the latest update.
|
2020-05-15 19:03:51 +02:00
|
|
|
|
2021-08-28 14:02:03 +02:00
|
|
|
This command will remove those limits so that we can just jump to the
|
|
|
|
last messages posted on the instance and start expanding toots from
|
|
|
|
there."
|
2020-09-11 15:18:59 +02:00
|
|
|
(let* ((timeline (thread-window:timeline-type *thread-window*))
|
|
|
|
(folder (thread-window:timeline-folder *thread-window*)))
|
2020-05-15 19:03:51 +02:00
|
|
|
(with-blocking-notify-procedure ((_ "Clearing pagination data"))
|
|
|
|
(db:remove-pagination-status folder timeline))))
|
2020-05-31 16:49:26 +02:00
|
|
|
|
|
|
|
(defun poll-vote ()
|
2020-06-07 12:12:36 +02:00
|
|
|
"Vote in a poll"
|
2020-05-31 16:49:26 +02:00
|
|
|
(labels ((valid-indices-p (choices options)
|
|
|
|
(let ((max-index (length options)))
|
|
|
|
(every (lambda (a) (and (>= a 0)
|
|
|
|
(< a max-index)))
|
|
|
|
choices)))
|
|
|
|
(on-input-complete (choices)
|
|
|
|
(let ((choices-list (split-words choices)))
|
|
|
|
(if (or (null choices-list)
|
|
|
|
(notevery (lambda (a)
|
|
|
|
(let ((idx (parse-integer a :junk-allowed t)))
|
|
|
|
(and idx
|
|
|
|
(>= idx 0))))
|
|
|
|
choices-list))
|
|
|
|
(error-message
|
2021-05-01 13:44:50 +02:00
|
|
|
(_ "Invalid choices, use a space separated list of positive integers."))
|
2020-05-31 16:49:26 +02:00
|
|
|
(db-utils:with-ready-database (:connect nil)
|
|
|
|
(when-let* ((fields (line-oriented-window:selected-row-fields
|
2020-09-11 15:18:59 +02:00
|
|
|
*thread-window*))
|
2020-05-31 16:49:26 +02:00
|
|
|
(status-id (db:row-message-status-id fields))
|
|
|
|
(poll (db:find-poll-bound-to-status status-id))
|
|
|
|
(poll-id (db:row-id poll))
|
|
|
|
(event (make-instance 'poll-vote-event
|
|
|
|
:poll-id poll-id
|
|
|
|
:choices choices-list))
|
|
|
|
(actual-choices (mapcar (lambda (a)
|
|
|
|
(parse-integer a :junk-allowed t))
|
|
|
|
choices-list))
|
|
|
|
(options (db:all-poll-options poll-id)))
|
|
|
|
(if (not (valid-indices-p actual-choices options))
|
|
|
|
(error-message
|
|
|
|
(format nil
|
|
|
|
(_ "Invalid choices, index choice out of range (max ~a).")
|
|
|
|
(1- (length options))))
|
2021-06-17 20:04:08 +02:00
|
|
|
(with-blocking-notify-procedure ((_ "Voting… ")
|
2020-05-31 16:49:26 +02:00
|
|
|
(_ "Choice sent."))
|
|
|
|
(push-event event)))))))))
|
2020-06-07 12:12:36 +02:00
|
|
|
(when-let* ((fields (line-oriented-window:selected-row-fields
|
2020-09-11 15:18:59 +02:00
|
|
|
*thread-window*))
|
2020-06-07 12:12:36 +02:00
|
|
|
(status-id (db:row-message-status-id fields)))
|
|
|
|
(let ((poll (db:find-poll-bound-to-status status-id)))
|
|
|
|
(if poll
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt
|
|
|
|
(_ "Type the index (or space separated indices) of selected choices: "))
|
|
|
|
(error-message (_ "This in not a poll")))))))
|
2020-06-28 12:36:59 +02:00
|
|
|
|
2020-09-05 17:02:00 +02:00
|
|
|
;;;; chats
|
|
|
|
|
|
|
|
(defun refresh-chats ()
|
2020-12-08 11:31:21 +01:00
|
|
|
"Refresh the chats lists, but not the chat's messages"
|
2020-09-05 17:02:00 +02:00
|
|
|
(program-events:push-event (make-instance 'program-events:get-chats-event)))
|
|
|
|
|
|
|
|
(defun refresh-chat-messages ()
|
|
|
|
"Force the refresh of the chat's messages"
|
|
|
|
(when-let* ((fields (line-oriented-window:selected-row-fields *chats-list-window*))
|
|
|
|
(chat-id (db:row-id fields)))
|
|
|
|
(let* ((min-message-id (db:last-chat-message-id chat-id))
|
|
|
|
(event (make-instance 'program-events:get-chat-messages-event
|
|
|
|
:chat-id chat-id
|
|
|
|
:min-message-id min-message-id)))
|
|
|
|
(program-events:push-event event))))
|
|
|
|
|
|
|
|
(defun open-chats-list-window ()
|
|
|
|
"open a window containing the list of active chat ordered from the
|
|
|
|
mot recent updated to least recent"
|
|
|
|
(chats-list-window:open-chats-list-window)
|
|
|
|
(focus-to-chats-list-window))
|
|
|
|
|
|
|
|
(defun close-chats-list-window ()
|
2020-09-11 15:18:59 +02:00
|
|
|
(close-window-and-return-to-threads *chats-list-window*))
|
2020-09-05 17:02:00 +02:00
|
|
|
|
2020-09-06 14:42:16 +02:00
|
|
|
(defun update-all-chats-messages ()
|
2020-12-31 11:36:34 +01:00
|
|
|
(program-events:push-event (make-instance 'program-events:update-all-chat-messages-event
|
|
|
|
:priority +minimum-event-priority+)))
|
2020-09-06 14:42:16 +02:00
|
|
|
|
2020-09-05 17:02:00 +02:00
|
|
|
(defun update-all-chats-data ()
|
|
|
|
(refresh-chats)
|
2020-09-06 14:42:16 +02:00
|
|
|
(update-all-chats-messages))
|
2020-09-05 17:02:00 +02:00
|
|
|
|
|
|
|
(defun show-chat-to-screen ()
|
|
|
|
(when-let* ((fields (line-oriented-window:selected-row-fields *chats-list-window*))
|
|
|
|
(chat-id (db:row-id fields))
|
|
|
|
(chat (db:find-chat chat-id))
|
|
|
|
(event (make-instance 'program-events:chat-show-event
|
|
|
|
:chat chat)))
|
2020-09-06 14:42:16 +02:00
|
|
|
(close-chats-list-window)
|
|
|
|
(program-events:push-event event)
|
2020-09-06 16:37:57 +02:00
|
|
|
(focus-to-message-window)
|
2020-09-06 14:42:16 +02:00
|
|
|
(chat-loop chat)))
|
|
|
|
|
|
|
|
(defun chat-loop (chat)
|
2020-09-06 17:28:16 +02:00
|
|
|
"Start writing to chat"
|
2020-09-06 14:42:16 +02:00
|
|
|
(labels ((post-message (message)
|
|
|
|
(let ((event (make-instance 'program-events:chat-post-message-event
|
|
|
|
:priority +maximum-event-priority+
|
|
|
|
:message message
|
|
|
|
:chat-id (db:row-id chat))))
|
|
|
|
(push-event event)))
|
|
|
|
(%loop ()
|
|
|
|
(labels ((on-message-composed (message)
|
|
|
|
(when (string-not-empty-p message)
|
|
|
|
(post-message message)
|
|
|
|
(update-all-chats-messages)
|
|
|
|
(let ((show-event (make-instance 'program-events:chat-show-event
|
2020-09-06 17:28:16 +02:00
|
|
|
:priority +minimum-event-priority+
|
|
|
|
:chat chat)))
|
2020-09-06 14:42:16 +02:00
|
|
|
(push-event show-event)
|
|
|
|
(%loop))))
|
|
|
|
(ask-fn ()
|
|
|
|
(lambda ()
|
|
|
|
(ask-string-input #'on-message-composed
|
|
|
|
:priority +minimum-event-priority+
|
|
|
|
:prompt (_ "Add message (enter to quit): ")
|
|
|
|
:complete-fn #'complete:complete-chat-message))))
|
|
|
|
(push-event (make-instance 'function-event
|
|
|
|
:priority +minimum-event-priority+
|
|
|
|
:payload (ask-fn))))))
|
|
|
|
(%loop)))
|
2020-09-05 17:02:00 +02:00
|
|
|
|
2020-09-06 20:17:34 +02:00
|
|
|
(defun open-chat-link-window ()
|
2020-09-11 15:18:59 +02:00
|
|
|
(let* ((window *message-window*)
|
2020-09-06 20:17:34 +02:00
|
|
|
(chat (message-window:metadata window))
|
|
|
|
(chat-id (db:row-id chat))
|
|
|
|
(links (db:all-chat-links chat-id)))
|
|
|
|
(open-message-link-window:init-chat-links links)
|
|
|
|
(focus-to-open-message-link-window)))
|
|
|
|
|
2020-09-09 21:13:57 +02:00
|
|
|
(defun change-chat-label ()
|
2020-09-10 17:50:22 +02:00
|
|
|
"Change the name (called label) of a chat"
|
2020-09-09 21:13:57 +02:00
|
|
|
(let* ((fields (line-oriented-window:selected-row-fields *chats-list-window*))
|
|
|
|
(chat-id (db:row-id fields)))
|
|
|
|
(flet ((on-input-complete (new-label)
|
|
|
|
(when (string-not-empty-p new-label)
|
|
|
|
(push-event (make-instance 'chat-change-label-event
|
|
|
|
:chat-id chat-id
|
|
|
|
:label new-label)))))
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt (_ "Type the new label of the chat: ")
|
|
|
|
:complete-fn #'complete:complete-chat-message))))
|
|
|
|
|
2020-09-10 17:50:22 +02:00
|
|
|
(defun chat-create-new ()
|
|
|
|
"Start a new chat"
|
|
|
|
(let ((chat-user-id nil)
|
|
|
|
(chat-username nil))
|
|
|
|
(labels ((on-user-id-complete (username)
|
|
|
|
(when (string-not-empty-p username)
|
|
|
|
(when-let* ((user-id (db:username->id username)))
|
|
|
|
(setf chat-user-id user-id)
|
|
|
|
(setf chat-username username)
|
|
|
|
(ask-string-input #'on-label-complete
|
|
|
|
:prompt (_ "Type the new label of the chat: ")))))
|
|
|
|
(on-label-complete (chat-label)
|
|
|
|
(when (string-not-empty-p chat-label)
|
|
|
|
(push-event (make-instance 'chat-create-event
|
|
|
|
:chat-label chat-label
|
|
|
|
:user-id chat-user-id))
|
|
|
|
(update-all-chats-data)
|
|
|
|
(notify (format nil
|
|
|
|
(_ "Chat ~a with ~a created")
|
|
|
|
chat-label
|
|
|
|
chat-username)))))
|
|
|
|
(ask-string-input #'on-user-id-complete
|
|
|
|
:prompt (_ "Type the user to chat with: ")
|
|
|
|
:complete-fn #'complete:username-complete))))
|
|
|
|
|
|
|
|
(defun chat-list-move (amount)
|
|
|
|
(ignore-errors
|
2020-09-11 15:18:59 +02:00
|
|
|
(line-oriented-window:unselect-all *chats-list-window*)
|
|
|
|
(line-oriented-window:row-move *chats-list-window* amount)
|
|
|
|
(draw *chats-list-window*)))
|
2020-09-10 17:50:22 +02:00
|
|
|
|
|
|
|
(defun chat-list-go-up ()
|
|
|
|
(chat-list-move -1))
|
|
|
|
|
|
|
|
(defun chat-list-go-down ()
|
|
|
|
(chat-list-move 1))
|
|
|
|
|
2020-06-28 12:36:59 +02:00
|
|
|
;;;; gemini
|
|
|
|
|
2021-01-11 18:21:38 +01:00
|
|
|
(defun gemini-open-url-prompt ()
|
2021-05-01 13:44:50 +02:00
|
|
|
"This is used when opening gemini link too, see:
|
2021-01-11 18:21:38 +01:00
|
|
|
open-message-link-window:open-message-link"
|
|
|
|
(_ "Open Gemini url: "))
|
|
|
|
|
2020-06-28 12:36:59 +02:00
|
|
|
(defun open-gemini-address ()
|
2020-09-06 14:42:16 +02:00
|
|
|
"Ask for a gemini address and try to load it"
|
2020-06-28 12:36:59 +02:00
|
|
|
(flet ((on-input-complete (url)
|
2021-04-03 13:04:40 +02:00
|
|
|
(gemini-viewer:load-gemini-url (trim-blanks url)
|
2021-04-03 11:14:58 +02:00
|
|
|
:use-cached-file-if-exists t
|
2021-03-27 11:01:36 +01:00
|
|
|
:priority program-events:+maximum-event-priority+)))
|
|
|
|
|
2021-01-11 18:21:38 +01:00
|
|
|
(let ((prompt (gemini-open-url-prompt)))
|
2020-06-28 12:36:59 +02:00
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt prompt
|
2020-12-17 13:56:07 +01:00
|
|
|
:complete-fn (complete:make-complete-gemini-iri-fn prompt)))))
|
2020-06-28 17:39:21 +02:00
|
|
|
|
|
|
|
(defun gemini-history-back ()
|
|
|
|
"Reopen a previous visited gemini address"
|
|
|
|
(push-event (make-instance 'gemini-back-event)))
|
2020-07-15 12:40:30 +02:00
|
|
|
|
|
|
|
(defun gemini-view-source ()
|
|
|
|
"Shows the source of current gemini page"
|
2020-09-11 15:18:59 +02:00
|
|
|
(gemini-viewer:view-source *message-window*))
|
2020-07-26 16:34:05 +02:00
|
|
|
|
|
|
|
(defun gemini-abort-download ()
|
|
|
|
"Stop a transferring data from a gemini server"
|
2020-12-29 12:36:10 +01:00
|
|
|
(when-let* ((fields (line-oriented-window:selected-row-fields *gemini-streams-window*))
|
2020-12-17 13:56:07 +01:00
|
|
|
(iri-to-abort (gemini-viewer:download-iri fields))
|
2020-08-30 15:34:08 +02:00
|
|
|
(event (make-instance 'gemini-abort-downloading-event
|
2020-12-17 13:56:07 +01:00
|
|
|
:payload iri-to-abort
|
2020-08-30 15:34:08 +02:00
|
|
|
:priority program-events:+maximum-event-priority+)))
|
2020-07-26 16:34:05 +02:00
|
|
|
(push-event event)))
|
2020-08-30 15:34:08 +02:00
|
|
|
|
|
|
|
(defun gemini-open-streams-window ()
|
|
|
|
"Open a window listing the gemini streams"
|
|
|
|
(gemini-viewer:open-gemini-stream-window)
|
|
|
|
(focus-to-open-gemini-stream-windows))
|
|
|
|
|
2021-05-16 14:18:19 +02:00
|
|
|
(defun trivial-line-oriented-window-move (win amount)
|
|
|
|
(ignore-errors
|
|
|
|
(line-oriented-window:unselect-all win)
|
|
|
|
(line-oriented-window:row-move win amount)
|
|
|
|
(draw win)))
|
|
|
|
|
2020-08-30 15:34:08 +02:00
|
|
|
(defun gemini-streams-move (amount)
|
|
|
|
(ignore-errors
|
2020-09-11 15:18:59 +02:00
|
|
|
(line-oriented-window:unselect-all *gemini-streams-window*)
|
|
|
|
(line-oriented-window:row-move *gemini-streams-window* amount)
|
|
|
|
(draw *gemini-streams-window*)))
|
2020-08-30 15:34:08 +02:00
|
|
|
|
|
|
|
(defun gemini-streams-window-up ()
|
|
|
|
"Move to the upper stream in the list."
|
|
|
|
(gemini-streams-move -1))
|
|
|
|
|
|
|
|
(defun gemini-streams-window-down ()
|
|
|
|
"Move to the lower stream in the list."
|
|
|
|
(gemini-streams-move 1))
|
|
|
|
|
|
|
|
(defun gemini-streams-window-close ()
|
|
|
|
"Close the streams window."
|
2020-09-11 15:18:59 +02:00
|
|
|
(close-window-and-return-to-message *gemini-streams-window*))
|
2020-08-30 15:34:08 +02:00
|
|
|
|
|
|
|
(defun gemini-streams-window-open-stream ()
|
|
|
|
"Open the selected stream."
|
2020-09-11 15:18:59 +02:00
|
|
|
(when-let* ((fields (line-oriented-window:selected-row-fields *gemini-streams-window*))
|
2020-12-17 13:56:07 +01:00
|
|
|
(iri-to-open (gemini-viewer:download-iri fields)))
|
|
|
|
(gemini-viewer:db-entry-to-foreground iri-to-open)))
|
2020-12-29 12:36:10 +01:00
|
|
|
|
|
|
|
(defun gemini-refresh-page ()
|
|
|
|
"Refresh current gemini page"
|
|
|
|
(when-let* ((url (gemini-viewer:current-gemini-url))
|
|
|
|
(event-abort (make-instance 'gemini-abort-downloading-event
|
|
|
|
:payload url
|
|
|
|
:priority program-events:+maximum-event-priority+))
|
|
|
|
(event-open (make-instance 'gemini-request-event
|
|
|
|
;; :priority
|
|
|
|
;; program-events:+maximum-event-priority+
|
|
|
|
:use-cached-file-if-exists nil
|
|
|
|
:url url)))
|
|
|
|
(push-event event-abort)
|
|
|
|
(push-event event-open)))
|
2020-12-30 12:24:13 +01:00
|
|
|
|
2021-01-09 16:27:40 +01:00
|
|
|
(defun gemlogs-subscription-move (amount)
|
|
|
|
(ignore-errors
|
|
|
|
(line-oriented-window:unselect-all *gemini-subscription-window*)
|
|
|
|
(line-oriented-window:row-move *gemini-subscription-window* amount)
|
|
|
|
(draw *gemini-subscription-window*)))
|
|
|
|
|
|
|
|
(defun gemlogs-subscription-go-down ()
|
2021-01-24 11:48:25 +01:00
|
|
|
(gemlogs-subscription-move 1))
|
2021-01-09 16:27:40 +01:00
|
|
|
|
|
|
|
(defun gemlogs-subscription-go-up ()
|
2021-01-24 11:48:25 +01:00
|
|
|
(gemlogs-subscription-move -1))
|
2021-01-09 16:27:40 +01:00
|
|
|
|
2021-01-09 11:01:10 +01:00
|
|
|
(defun gemini-subscribe-gemlog ()
|
|
|
|
"Subscribe to the gemlog shown in the main window.
|
|
|
|
|
|
|
|
The page must be formatted according to gemini subscription specifications:
|
|
|
|
|
|
|
|
gemini://gemini.circumlunar.space/docs/companion/subscription.gmi
|
|
|
|
|
|
|
|
"
|
|
|
|
(when-let ((url (gemini-viewer:current-gemini-url)))
|
|
|
|
(with-blocking-notify-procedure ((format nil (_ "Subscribing to ~s") url))
|
|
|
|
(let ((event (make-instance 'gemini-gemlog-subscribe-event
|
|
|
|
:payload url)))
|
|
|
|
(push-event event)))))
|
|
|
|
|
2021-04-10 13:52:56 +02:00
|
|
|
(defun send-to-pipe-on-input-complete (command data)
|
|
|
|
(when (and (string-not-empty-p command)
|
|
|
|
data)
|
|
|
|
(push-event (make-instance 'send-to-pipe-event
|
|
|
|
:data data
|
|
|
|
:command command))
|
|
|
|
(info-message (format nil (_ "Command ~s completed") command))))
|
|
|
|
|
2020-12-30 12:24:13 +01:00
|
|
|
(defun send-to-pipe ()
|
|
|
|
"Send contents of window to a command"
|
|
|
|
(flet ((on-input-complete (command)
|
2021-04-10 13:52:56 +02:00
|
|
|
(let ((data (line-oriented-window:rows->text *message-window*)))
|
|
|
|
(send-to-pipe-on-input-complete command data))))
|
2020-12-30 12:24:13 +01:00
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt (format nil (_ "Send to command: ")))))
|
|
|
|
|
|
|
|
(defun send-message-to-pipe ()
|
|
|
|
"Send contents of a message to a command"
|
|
|
|
(when-let* ((selected-message (line-oriented-window:selected-row-fields *thread-window*))
|
|
|
|
(message (db:row-message-rendered-text selected-message)))
|
|
|
|
(flet ((on-input-complete (command)
|
2021-04-10 13:52:56 +02:00
|
|
|
(send-to-pipe-on-input-complete command message)))
|
2020-12-30 12:24:13 +01:00
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt (format nil (_ "Send message to command: "))))))
|
2021-05-01 13:44:50 +02:00
|
|
|
|
|
|
|
|
|
|
|
(let ((tour ()))
|
2021-05-02 13:47:06 +02:00
|
|
|
|
2021-10-10 12:38:37 +02:00
|
|
|
(defun shuffle-tour ()
|
|
|
|
"Shuffle the links in the tour"
|
|
|
|
(setf tour (shuffle tour)))
|
|
|
|
|
2021-08-27 14:17:14 +02:00
|
|
|
(defun clean-tour (regex)
|
2021-10-10 12:38:37 +02:00
|
|
|
"Remove links from the tour matching `regex'"
|
2021-08-27 14:17:14 +02:00
|
|
|
(let ((scanner (create-scanner regex :case-insensitive-mode t)))
|
|
|
|
(setf tour
|
|
|
|
(remove-if (lambda (a)
|
|
|
|
(or (scan scanner (gemini-parser:name a))
|
|
|
|
(scan scanner (gemini-parser:target a))))
|
|
|
|
tour))))
|
|
|
|
|
|
|
|
(defun clean-all-tour ()
|
2021-10-10 12:38:37 +02:00
|
|
|
"Remove all links from the tour"
|
2021-08-27 14:17:14 +02:00
|
|
|
(clean-tour ".*"))
|
|
|
|
|
|
|
|
(defun add-links-to-tour (links)
|
|
|
|
(funcall (tour-mode-on-input-completed-clsr links) ".*"))
|
|
|
|
|
2021-05-02 13:47:06 +02:00
|
|
|
(defun tour-mode-on-input-completed-clsr (links)
|
|
|
|
(lambda (data)
|
|
|
|
(when (string-not-empty-p data)
|
2021-05-04 11:52:42 +02:00
|
|
|
(let ((parsed-tour (ignore-errors (tour-mode-parser:parse-tour-mode data))))
|
|
|
|
(if (not parsed-tour)
|
2021-05-02 13:47:06 +02:00
|
|
|
(when-let ((scanner (create-scanner data)))
|
|
|
|
(loop for link in links do
|
|
|
|
(when (or (scan scanner (gemini-parser:name link))
|
|
|
|
(scan scanner (gemini-parser:target link)))
|
|
|
|
(pushnew link tour :test (lambda (a b)
|
|
|
|
(string= (gemini-parser:target a)
|
2021-05-04 11:52:42 +02:00
|
|
|
(gemini-parser:target b)))))))
|
|
|
|
(let ((all-indices ()))
|
|
|
|
(loop for index in parsed-tour do
|
|
|
|
(if (tour-mode-parser:range-p index)
|
|
|
|
(let ((from (tour-mode-parser:range-from index))
|
|
|
|
(to (tour-mode-parser:range-to index)))
|
|
|
|
(loop for i from (min from to) to (max from to) do
|
|
|
|
(pushnew i all-indices :test #'=)))
|
|
|
|
(pushnew index all-indices :test #'=)))
|
|
|
|
(loop for index in (reverse all-indices) do
|
|
|
|
(if (<= 0 index (length links))
|
|
|
|
(push (elt links index) tour)
|
|
|
|
(notify (format nil (_ "Index ~a out of range") index)
|
|
|
|
:as-error t))))))
|
2021-05-02 13:47:06 +02:00
|
|
|
(info-message (_ "Tour saved")))))
|
|
|
|
|
2021-05-01 13:44:50 +02:00
|
|
|
(defun tour-mode-link ()
|
2021-08-28 16:59:50 +02:00
|
|
|
"Enable \"tour mode\".
|
|
|
|
Ask for link indices, each link
|
2021-05-01 13:44:50 +02:00
|
|
|
corresponding to the index will be saved in a special queue that
|
2021-05-02 13:49:20 +02:00
|
|
|
can be opened using `next-tour-link' in a last-in last-out way.
|
|
|
|
|
2021-08-28 15:51:32 +02:00
|
|
|
More than one index can be specified using comma (',') or space as
|
|
|
|
separator and index ranges can be specified using dash, e.g:
|
|
|
|
|
|
|
|
1 2 5 8-12
|
|
|
|
|
|
|
|
The string above will save the link index number 1, 2, 3, 5, 8, 9,
|
|
|
|
10, 11, 12 to the tour.
|
|
|
|
|
2021-05-02 13:49:20 +02:00
|
|
|
If user input is made by a single word only (i.e. a string with no
|
|
|
|
spaces), the input is used as a regular expression to collect
|
|
|
|
matching links (matching name or URI)."
|
2021-05-01 20:25:15 +02:00
|
|
|
(with-accessors ((links open-message-link-window::links)) *open-message-link-window*
|
2021-05-02 13:47:06 +02:00
|
|
|
(ask-string-input (tour-mode-on-input-completed-clsr links)
|
|
|
|
:prompt (format nil (_ "link indices: ")))))
|
2021-05-01 13:44:50 +02:00
|
|
|
|
|
|
|
(defun next-tour-link ()
|
|
|
|
"Open the next link in the tour queue."
|
|
|
|
(let* ((queue (reverse tour))
|
|
|
|
(link (first queue)))
|
|
|
|
(if (null queue)
|
|
|
|
(error-message (_ "Tour completed"))
|
2021-05-01 20:25:15 +02:00
|
|
|
(let ((url (gemini-parser:target link)))
|
2021-05-01 13:44:50 +02:00
|
|
|
(setf tour (reverse (rest queue)))
|
2021-10-10 12:38:37 +02:00
|
|
|
(focus-to-message-window)
|
2021-05-01 20:25:15 +02:00
|
|
|
(open-message-link-window:open-message-link url nil)))))
|
|
|
|
|
|
|
|
(defun show-tour-links ()
|
2021-05-02 13:47:06 +02:00
|
|
|
"Show a link window with all the links in the tour queue."
|
2021-06-13 16:02:12 +02:00
|
|
|
(open-message-link-window:init-gemini-links (reverse tour))
|
|
|
|
(focus-to-open-message-link-window))
|
|
|
|
|
|
|
|
(defun save-selected-message-in-tour ()
|
|
|
|
"Save the selected link in the tour queue"
|
|
|
|
(ignore-errors
|
|
|
|
(let ((win *open-message-link-window*))
|
|
|
|
(with-accessors ((links open-message-link-window::links)) win
|
|
|
|
(when-let* ((selected-index (line-oriented-window:row-selected-index win))
|
|
|
|
(selected-link (elt links selected-index))
|
|
|
|
(label (or (gemini-parser:name selected-link)
|
|
|
|
(gemini-parser:target selected-link))))
|
|
|
|
(push selected-link tour)
|
2021-10-10 12:38:37 +02:00
|
|
|
(info-message (format nil (_ "~s saved in tour") label)))))))
|
|
|
|
|
|
|
|
(defun gemlog-add-unread-posts-tour ()
|
|
|
|
"Add all the unread gemlog posts to the tour"
|
|
|
|
(when-let* ((unread-posts (db:gemini-all-unread-posts))
|
|
|
|
(links (mapcar (lambda (row)
|
|
|
|
(gemini-parser:make-gemini-link (db:row-url row)
|
|
|
|
(db:row-title row)))
|
|
|
|
unread-posts)))
|
|
|
|
(add-links-to-tour links))))
|
2021-05-16 14:18:19 +02:00
|
|
|
|
|
|
|
(defun open-gemini-toc ()
|
|
|
|
"Opend a windows that contains a generated table of contents of the
|
|
|
|
gemini page the program is rendering."
|
|
|
|
(push-event (make-instance 'gemini-toc-open)))
|
|
|
|
|
|
|
|
(defun gemini-toc-jump-to-entry ()
|
|
|
|
(let* ((selected-row (line-oriented-window:selected-row-fields *gemini-toc-window*))
|
|
|
|
(gid-looking-for (message-window:gemini-toc-group-id selected-row)))
|
|
|
|
(push-event (make-instance 'gemini-toc-jump-to-section
|
|
|
|
:toc-win *gemini-toc-window*
|
|
|
|
:message-win *message-window*
|
|
|
|
:gid-looking-for gid-looking-for))))
|
|
|
|
|
2021-06-13 12:17:43 +02:00
|
|
|
(defun gemini-toc-scroll-up ()
|
|
|
|
(trivial-line-oriented-window-move *gemini-toc-window* -1)
|
|
|
|
(gemini-toc-jump-to-entry))
|
|
|
|
|
|
|
|
(defun gemini-toc-scroll-down ()
|
|
|
|
(trivial-line-oriented-window-move *gemini-toc-window* 1)
|
|
|
|
(gemini-toc-jump-to-entry))
|
|
|
|
|
2021-05-16 14:18:19 +02:00
|
|
|
(defun gemini-toc-close ()
|
2021-09-03 12:32:09 +02:00
|
|
|
(hooks:remove-hook 'hooks:*before-rendering-message-visible-rows*
|
|
|
|
#'gemini-page-toc:highlight-current-section)
|
2021-11-12 15:00:34 +01:00
|
|
|
(close-window-and-return-to-message *gemini-toc-window*)
|
|
|
|
(windows:refresh-config *message-window*)
|
|
|
|
(windows:draw *message-window*))
|
2021-06-16 19:18:30 +02:00
|
|
|
|
|
|
|
(defun gemini-toc-scroll-down-page ()
|
|
|
|
(message-window:scroll-down *message-window*))
|
|
|
|
|
|
|
|
(defun gemini-toc-scroll-up-page ()
|
|
|
|
(message-window:scroll-up *message-window*))
|
2021-06-18 17:48:56 +02:00
|
|
|
|
|
|
|
(defun ask-input-on-tofu-error (condition fn)
|
|
|
|
(let ((host (gemini-client:host condition)))
|
|
|
|
(flet ((on-input-complete (maybe-accepted)
|
|
|
|
(when (ui::boolean-input-accepted-p maybe-accepted)
|
|
|
|
(db-utils:with-ready-database (:connect nil)
|
|
|
|
(db:tofu-delete host)
|
|
|
|
(funcall fn)))))
|
|
|
|
(ui:ask-string-input #'on-input-complete
|
|
|
|
:prompt
|
|
|
|
(format nil
|
|
|
|
(_ "Host ~s signature changed! This is a potential security risk! Ignore this warning? [y/N] ")
|
|
|
|
host)
|
|
|
|
:priority program-events:+standard-event-priority+))))
|
2021-08-03 18:31:34 +02:00
|
|
|
|
|
|
|
(defun import-gemini-certificate ()
|
|
|
|
"Import a TLS certificate, not generated from tinmop, to authenticate this client."
|
|
|
|
(let ((cert-file nil)
|
|
|
|
(cert-key-file nil))
|
|
|
|
(labels ((file-valid-p (path)
|
|
|
|
(cond
|
|
|
|
((string-empty-p path)
|
|
|
|
(ui:notify (_ "Empty path") :as-error t)
|
|
|
|
nil)
|
|
|
|
((not (fs:file-exists-p path))
|
|
|
|
(error-message (format nil (_ "No such file ~s") path))
|
|
|
|
nil)
|
|
|
|
((= (fs:file-size path) 0)
|
|
|
|
(error-message (format nil (_ "File ~s is empty") path))
|
|
|
|
nil)
|
|
|
|
(t :file-valid)))
|
|
|
|
(on-cert-path-input-complete (cert-path)
|
|
|
|
(when (file-valid-p cert-path)
|
|
|
|
(setf cert-file cert-path)
|
|
|
|
(ui:ask-string-input #'on-cert-key-path-input-complete
|
|
|
|
:prompt (format nil (_ "Insert certificate key file: "))
|
|
|
|
:complete-fn #'complete:directory-complete)))
|
|
|
|
(on-cert-key-path-input-complete (key-path)
|
|
|
|
(let ((prompt-history (gemini-open-url-prompt))
|
|
|
|
(prompt (_ "Insert the gemini IRI where where credential are valid: ")))
|
|
|
|
(when (file-valid-p key-path)
|
|
|
|
(setf cert-key-file key-path)
|
|
|
|
(ui:ask-string-input #'on-valid-uri-complete
|
|
|
|
:prompt prompt
|
|
|
|
:complete-fn
|
|
|
|
(complete:make-complete-gemini-iri-fn prompt-history)))))
|
|
|
|
(on-valid-uri-complete (uri)
|
|
|
|
(db-utils:with-ready-database (:connect nil)
|
|
|
|
(if (gemini-parser:gemini-iri-p uri)
|
|
|
|
(let* ((id (to-s (db:cache-put uri +cache-tls-certificate-type+)))
|
|
|
|
(cert-filename (fs:path-last-element cert-file))
|
|
|
|
(key-filename (fs:path-last-element cert-key-file))
|
|
|
|
(cache-dir (os-utils:cached-file-path id))
|
|
|
|
(cert-out-path (strcat cache-dir
|
|
|
|
fs:*directory-sep*
|
|
|
|
cert-filename))
|
|
|
|
(key-out-path (strcat cache-dir
|
|
|
|
fs:*directory-sep*
|
|
|
|
key-filename)))
|
|
|
|
(fs:make-directory cache-dir)
|
|
|
|
(fs:copy-a-file cert-file cert-out-path :overwrite t)
|
|
|
|
(fs:copy-a-file cert-key-file key-out-path :overwrite t)
|
|
|
|
(info-message (format nil (_ "Certificate imported for ~s") uri)))
|
|
|
|
(error-message (format nil
|
|
|
|
(_ "~s is not a valid gemini address")
|
|
|
|
uri))))))
|
|
|
|
(ui:ask-string-input #'on-cert-path-input-complete
|
|
|
|
:prompt (format nil (_ "Insert certificate file: "))
|
|
|
|
:complete-fn #'complete:directory-complete))))
|
2021-08-16 14:22:47 +02:00
|
|
|
|
|
|
|
(defun bookmark-gemini-page ()
|
|
|
|
(if (message-window:gemini-window-p)
|
|
|
|
(let* ((link (gemini-viewer:current-gemini-url))
|
|
|
|
(metadata (message-window:metadata *message-window*))
|
|
|
|
(source (gemini-viewer:gemini-metadata-source-file metadata))
|
|
|
|
(description (gemini-parser:gemini-first-h1 source)))
|
|
|
|
(labels ((on-description-completed (new-description)
|
2021-08-16 15:28:37 +02:00
|
|
|
(if (text-utils:string-empty-p new-description)
|
|
|
|
(error-message (_ "Empty description"))
|
|
|
|
(progn
|
|
|
|
(setf description new-description)
|
|
|
|
(ui:ask-string-input #'on-section-completed
|
|
|
|
:prompt (format nil (_ "Insert bookmark section: "))
|
|
|
|
:complete-fn #'complete:bookmark-section-complete))))
|
2021-08-16 14:22:47 +02:00
|
|
|
(on-section-completed (section)
|
|
|
|
(db-utils:with-ready-database (:connect nil)
|
|
|
|
(db:bookmark-add db:+bookmark-gemini-type-entry+
|
|
|
|
link
|
|
|
|
:section section
|
|
|
|
:description description))
|
|
|
|
(notify (format nil (_ "Added ~s in bookmark") link))))
|
|
|
|
(ui:ask-string-input #'on-description-completed
|
|
|
|
:prompt (format nil (_ "Insert bookmark description: "))
|
|
|
|
:initial-value description)))
|
|
|
|
(error-message (_ "The window is not displaying a gemini document"))))
|
|
|
|
|
|
|
|
(defun generate-bookmark-page ()
|
|
|
|
(let ((bookmarks-sections (db:bookmark-all-grouped-by-section)))
|
|
|
|
(with-output-to-string (stream)
|
2021-08-16 14:30:59 +02:00
|
|
|
(format stream (gemini-parser:geminize-h1 (_ "My bookmark~2%")))
|
2021-08-16 14:22:47 +02:00
|
|
|
(loop for section in bookmarks-sections do
|
|
|
|
(let ((header (car section))
|
|
|
|
(bookmarks (cdr section)))
|
|
|
|
(when (string-empty-p header)
|
|
|
|
(setf header (_ "Uncategorized")))
|
2021-08-16 14:30:59 +02:00
|
|
|
(write-string (gemini-parser:geminize-h2 header) stream)
|
2021-08-16 14:22:47 +02:00
|
|
|
(write-char #\Newline stream)
|
|
|
|
(write-char #\Newline stream)
|
|
|
|
(loop for bookmark in bookmarks do
|
|
|
|
(let ((link (join-with-strings* " "
|
|
|
|
(db:row-value bookmark)
|
|
|
|
(db:row-description bookmark))))
|
|
|
|
(write-string (gemini-parser:geminize-link link) stream)
|
|
|
|
(write-char #\Newline stream)))
|
|
|
|
(write-char #\Newline stream))))))
|
|
|
|
|
|
|
|
(defun display-bookmark ()
|
|
|
|
(let* ((bookmark-page (generate-bookmark-page))
|
|
|
|
(event (make-instance 'gemini-display-data-page
|
|
|
|
:window *message-window*
|
|
|
|
:payload bookmark-page)))
|
|
|
|
(push-event event)))
|
2021-08-16 15:28:37 +02:00
|
|
|
|
2021-11-12 15:00:34 +01:00
|
|
|
(defun generate-latest-visited-url ()
|
2021-11-12 15:04:19 +01:00
|
|
|
(let ((history (remove-duplicates (db:history-prompt->values (gemini-open-url-prompt))
|
|
|
|
:test #'string=)))
|
2021-11-12 15:00:34 +01:00
|
|
|
(with-output-to-string (stream)
|
|
|
|
(format stream (gemini-parser:geminize-h1 (_ "Latest visited addresses~2%")))
|
|
|
|
(loop for iri in history when (gemini-client:absolute-gemini-url-p iri) do
|
|
|
|
(format stream "~a~%" (gemini-parser:geminize-link iri))))))
|
|
|
|
|
|
|
|
(defun display-latest-visited-urls ()
|
|
|
|
(let* ((bookmark-page (generate-latest-visited-url))
|
|
|
|
(event (make-instance 'gemini-display-data-page
|
|
|
|
:window *message-window*
|
|
|
|
:payload bookmark-page)))
|
|
|
|
(push-event event)))
|
|
|
|
|
2021-08-16 15:28:37 +02:00
|
|
|
(defun delete-gemini-bookmark ()
|
|
|
|
(flet ((on-description-completed (selected)
|
|
|
|
(if (text-utils:string-empty-p selected)
|
|
|
|
(error-message (_ "No entry selected"))
|
|
|
|
(when-let ((id (db:bookmark-complete->id selected)))
|
|
|
|
(db-utils:with-ready-database (:connect nil)
|
|
|
|
(db:bookmark-delete id))))))
|
|
|
|
(ui:ask-string-input #'on-description-completed
|
|
|
|
:prompt (format nil (_ "Delete bookmark: "))
|
|
|
|
:complete-fn
|
|
|
|
(complete:bookmark-description-complete-clsr db:+bookmark-gemini-type-entry+))))
|
2021-08-25 18:15:57 +02:00
|
|
|
|
|
|
|
(defun open-gempub-library ()
|
|
|
|
"Open the personal library of gempub files."
|
|
|
|
(flet ((on-input-completed (query)
|
|
|
|
(push-event (make-instance 'function-event
|
|
|
|
:payload
|
|
|
|
(lambda ()
|
2021-08-28 14:02:03 +02:00
|
|
|
(tui:with-notify-errors
|
|
|
|
(db-utils:with-ready-database (:connect nil)
|
|
|
|
(gempub:open-gempub-library-window query)
|
|
|
|
(focus-to-gempub-library-window))))))))
|
2021-08-25 18:15:57 +02:00
|
|
|
(ui:ask-string-input #'on-input-completed
|
|
|
|
:prompt (format nil (_ "Search criteria: ")))))
|
|
|
|
|
|
|
|
(defun gempub-library-window-move (amount)
|
|
|
|
(ignore-errors
|
|
|
|
(line-oriented-window:unselect-all *gempub-library-window*)
|
|
|
|
(line-oriented-window:row-move *gempub-library-window* amount)
|
|
|
|
(draw *gempub-library-window*)))
|
|
|
|
|
|
|
|
(defun gempub-library-window-go-up ()
|
|
|
|
(gempub-library-window-move -1))
|
|
|
|
|
|
|
|
(defun gempub-library-window-go-down ()
|
|
|
|
(gempub-library-window-move 1))
|
|
|
|
|
|
|
|
(defun gempub-library-window-close ()
|
|
|
|
(close-window-and-return-to-message *gempub-library-window*))
|
2021-08-26 15:47:27 +02:00
|
|
|
|
|
|
|
(defun gempub-open-file ()
|
|
|
|
"Open the selected gempub."
|
|
|
|
(when-let* ((fields (line-oriented-window:selected-row-fields *gempub-library-window*))
|
|
|
|
(iri-to-open (db:row-local-uri fields)))
|
|
|
|
(gemini-viewer:load-gemini-url iri-to-open :give-focus-to-message-window t)))
|
2021-10-08 11:55:16 +02:00
|
|
|
|
|
|
|
(defun message-window-lock-scrolling ()
|
2021-10-08 14:35:40 +02:00
|
|
|
"Lock automatic scrolling of message window"
|
2021-10-08 11:55:16 +02:00
|
|
|
(setf (message-window:adjust-rows-strategy specials:*message-window*)
|
2021-10-08 14:35:40 +02:00
|
|
|
#'line-oriented-window:adjust-rows-noop)
|
|
|
|
(info-message (_ "Message window scrolling locked")))
|
2021-10-08 11:55:16 +02:00
|
|
|
|
|
|
|
(defun message-window-unlock-scrolling ()
|
2021-10-08 14:35:40 +02:00
|
|
|
"Allow automatic scrolling of the message window to always show the
|
|
|
|
last line (the one on the bottom of the text; useful for chats, for
|
|
|
|
example)."
|
2021-10-08 11:55:16 +02:00
|
|
|
(setf (message-window:adjust-rows-strategy specials:*message-window*)
|
2021-10-08 14:35:40 +02:00
|
|
|
#'line-oriented-window:adjust-rows-select-last)
|
|
|
|
(info-message (_ "Message window scrolling unlocked")))
|
|
|
|
|
|
|
|
(defun eval-command ()
|
|
|
|
"Eval (execute) a lisp form. (e.g '(ui:notify \"foo\")' )"
|
|
|
|
(flet ((on-input-completed (query)
|
|
|
|
(push-event (make-instance 'function-event
|
|
|
|
:payload
|
|
|
|
(lambda ()
|
|
|
|
(tui:with-notify-errors
|
|
|
|
(db-utils:with-ready-database (:connect nil)
|
|
|
|
(with-input-from-string (stream query)
|
|
|
|
(funcall (compile nil
|
|
|
|
`(lambda () ,(read stream))))))))))))
|
|
|
|
(ui:ask-string-input #'on-input-completed
|
|
|
|
:prompt (format nil (_ "eval: ")))))
|
2021-11-16 16:00:13 +01:00
|
|
|
|
|
|
|
(defun load-script-callback-event (script-file)
|
|
|
|
(lambda ()
|
|
|
|
(tui:with-notify-errors
|
|
|
|
(db-utils:with-ready-database (:connect nil)
|
|
|
|
(let ((output (with-output-to-string (stream)
|
|
|
|
(let ((*standard-output* stream))
|
|
|
|
(load script-file
|
|
|
|
:verbose nil
|
|
|
|
:print nil
|
|
|
|
:if-does-not-exist :error)))))
|
|
|
|
(push-event (make-instance 'gemini-display-data-page
|
|
|
|
:window *message-window*
|
|
|
|
:payload output)))))))
|
|
|
|
(defun load-script-file ()
|
|
|
|
"Asks for a lisp file and execute (in lisp jargon, \"load\") it, the
|
|
|
|
output of the script (that is the standard output is redirected, and
|
|
|
|
printed, on the main window."
|
|
|
|
(flet ((on-input-completed (query)
|
|
|
|
(push-event (make-instance 'function-event
|
|
|
|
:payload (load-script-callback-event query)))))
|
|
|
|
(ui:ask-string-input #'on-input-completed
|
|
|
|
:prompt (format nil (_ "load file: "))
|
|
|
|
:complete-fn #'complete:directory-complete)))
|
2021-11-16 19:55:03 +01:00
|
|
|
|
|
|
|
(defun view-user-avatar ()
|
|
|
|
"View the Avatar (AKA propic) image for this user"
|
|
|
|
(when-let* ((selected-row (line-oriented-window:selected-row-fields *thread-window*))
|
|
|
|
(username (db:row-message-username selected-row))
|
|
|
|
(account (db:acct->user username))
|
2021-11-19 10:43:33 +01:00
|
|
|
(avatar-url (db:row-avatar account)))
|
2021-11-16 19:55:03 +01:00
|
|
|
(open-attach-window:open-attachment avatar-url)))
|
2021-12-10 11:50:37 +01:00
|
|
|
|
2022-01-06 18:17:07 +01:00
|
|
|
(defun open-file-explorer (&optional (root "/"))
|
2022-01-06 12:17:31 +01:00
|
|
|
(with-enqueued-process ()
|
2022-01-06 18:22:33 +01:00
|
|
|
(let ((actual-root (fs:prepend-pwd root)))
|
|
|
|
(filesystem-tree-window:init actual-root)
|
|
|
|
(focus-to-filesystem-explorer-window))))
|
2021-12-10 11:50:37 +01:00
|
|
|
|
2022-01-09 14:47:22 +01:00
|
|
|
|
|
|
|
(defun open-remote-file-explorer (&optional (root "/"))
|
|
|
|
(with-enqueued-process ()
|
|
|
|
(let ((handlers (kami:generate-filesystem-window-handlers root
|
|
|
|
*host*
|
|
|
|
*port*
|
|
|
|
*client-certificate*
|
|
|
|
*certificate-key*)))
|
|
|
|
(filesystem-tree-window:init root handlers)
|
|
|
|
(focus-to-filesystem-explorer-window))))
|
|
|
|
|
2021-12-12 12:57:08 +01:00
|
|
|
(defun file-explorer-expand-path ()
|
2021-12-10 11:50:37 +01:00
|
|
|
(when-let* ((win *filesystem-explorer-window*)
|
|
|
|
(fields (line-oriented-window:selected-row-fields win))
|
|
|
|
(path (fstree:tree-path fields))
|
|
|
|
(dirp (fstree:tree-dir-p fields)))
|
|
|
|
(fstree:expand-treenode win path)))
|
|
|
|
|
2021-12-12 12:57:08 +01:00
|
|
|
(defun file-explorer-close-path ()
|
2021-12-10 11:50:37 +01:00
|
|
|
(when-let* ((win *filesystem-explorer-window*)
|
|
|
|
(fields (line-oriented-window:selected-row-fields win))
|
|
|
|
(path (fstree:tree-path fields))
|
|
|
|
(dirp (fstree:tree-dir-p fields)))
|
|
|
|
(fstree:close-treenode win path)))
|
|
|
|
|
2021-12-10 15:30:26 +01:00
|
|
|
(defun file-explorer-delete-path ()
|
|
|
|
(when-let* ((win *filesystem-explorer-window*)
|
|
|
|
(fields (line-oriented-window:selected-row-fields win))
|
|
|
|
(path (fstree:tree-path fields)))
|
|
|
|
(flet ((on-input-complete (maybe-accepted)
|
|
|
|
(with-valid-yes-at-prompt (maybe-accepted y-pressed-p)
|
|
|
|
(when y-pressed-p
|
|
|
|
(with-enqueued-process ()
|
|
|
|
(fstree:delete-treenode win path))))))
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt
|
2021-12-14 13:14:08 +01:00
|
|
|
(format nil (_ "Delete ~a? ") path)))))
|
2021-12-10 15:30:26 +01:00
|
|
|
|
2021-12-12 12:57:08 +01:00
|
|
|
(defun file-explorer-rename-path ()
|
2021-12-10 11:50:37 +01:00
|
|
|
"Rename (or move) a file or directory"
|
|
|
|
(when-let* ((win *filesystem-explorer-window*)
|
|
|
|
(fields (line-oriented-window:selected-row-fields win))
|
|
|
|
(path (fstree:tree-path fields)))
|
|
|
|
(flet ((on-input-complete (new-path)
|
2021-12-11 11:06:06 +01:00
|
|
|
(when (string-not-empty-p new-path)
|
|
|
|
(with-enqueued-process ()
|
|
|
|
(fstree:rename-treenode win path new-path)))))
|
2021-12-10 11:50:37 +01:00
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt
|
2021-12-14 13:14:08 +01:00
|
|
|
(format nil (_ "Rename ~a to: ") path)))))
|
2021-12-10 11:50:37 +01:00
|
|
|
|
2021-12-12 12:53:03 +01:00
|
|
|
(defun file-explorer-download-path ()
|
|
|
|
"Download a file"
|
|
|
|
(when-let* ((win *filesystem-explorer-window*)
|
|
|
|
(fields (line-oriented-window:selected-row-fields win))
|
|
|
|
(path (fstree:tree-path fields))
|
|
|
|
(output-file (fs:temporary-file)))
|
|
|
|
(flet ((on-input-complete (destination-file)
|
|
|
|
(when (string-not-empty-p destination-file)
|
|
|
|
(with-enqueued-process ()
|
|
|
|
(with-blocking-notify-procedure
|
|
|
|
((format nil (_ "Staring download of ~a") path)
|
|
|
|
(format nil (_ "Download completed in ~a") destination-file))
|
|
|
|
(fstree:download-treenode win path destination-file)
|
|
|
|
(info-message destination-file))))))
|
|
|
|
(ask-string-input #'on-input-complete
|
2021-12-14 13:14:08 +01:00
|
|
|
:prompt (format nil (_ "Download ~a to: ") path)
|
2021-12-12 12:53:03 +01:00
|
|
|
:initial-value output-file))))
|
|
|
|
|
2021-12-12 14:37:38 +01:00
|
|
|
(defun file-explorer-upload-path ()
|
|
|
|
"Upload a file"
|
|
|
|
(when-let* ((win *filesystem-explorer-window*)
|
|
|
|
(fields (line-oriented-window:selected-row-fields win))
|
2022-01-09 14:47:22 +01:00
|
|
|
(destination-dir (fstree:tree-path fields)))
|
2021-12-12 14:37:38 +01:00
|
|
|
(labels ((build-actual-destination-file (source destination)
|
|
|
|
(if (fs:extension-dir-p destination)
|
|
|
|
(fs:cat-parent-dir destination
|
|
|
|
(fs:path-last-element source))
|
|
|
|
destination))
|
|
|
|
(on-input-complete (source-file)
|
|
|
|
(cond
|
|
|
|
((fs:dirp source-file)
|
|
|
|
(error-message (format nil "~a is a directory" source-file)))
|
|
|
|
((not (fs:file-exists-p source-file))
|
|
|
|
(error-message (format nil "~a does not exists" source-file)))
|
|
|
|
(t
|
2022-01-09 14:47:22 +01:00
|
|
|
(when (string-not-empty-p source-file)
|
2021-12-12 14:37:38 +01:00
|
|
|
(with-enqueued-process ()
|
|
|
|
(with-blocking-notify-procedure
|
2021-12-14 13:14:08 +01:00
|
|
|
((format nil (_ "Starting upload of ~a") source-file)
|
2022-01-09 14:47:22 +01:00
|
|
|
(format nil (_ "Upload completed in ~a") destination-dir))
|
|
|
|
(let ((destination-file (build-actual-destination-file source-file
|
|
|
|
destination-dir)))
|
|
|
|
(fstree:upload-treenode win source-file destination-file)
|
|
|
|
(info-message destination-file)))))))))
|
2021-12-12 14:37:38 +01:00
|
|
|
(ask-string-input #'on-input-complete
|
2021-12-14 13:14:08 +01:00
|
|
|
:prompt (_ "Upload: ")
|
2021-12-12 14:37:38 +01:00
|
|
|
:complete-fn #'complete:directory-complete))))
|
|
|
|
|
2021-12-11 11:06:06 +01:00
|
|
|
(defun file-explorer-create-path ()
|
|
|
|
"create a file or directory"
|
|
|
|
(when-let* ((win *filesystem-explorer-window*)
|
|
|
|
(fields (line-oriented-window:selected-row-fields win))
|
|
|
|
(path (fstree:tree-path fields)))
|
|
|
|
(flet ((on-input-complete (new-path)
|
|
|
|
(when (string-not-empty-p new-path)
|
|
|
|
(with-enqueued-process ()
|
|
|
|
(let ((dirp (fs:extension-dir-p new-path)))
|
|
|
|
(fstree:create-treenode win new-path dirp))))))
|
|
|
|
(ask-string-input #'on-input-complete
|
2021-12-14 13:14:08 +01:00
|
|
|
:prompt (_ "Create: ")
|
2021-12-11 11:06:06 +01:00
|
|
|
:initial-value path))))
|
|
|
|
|
2021-12-10 11:50:37 +01:00
|
|
|
(defun file-explorer-move (amount)
|
|
|
|
(ignore-errors
|
|
|
|
(line-oriented-window:unselect-all *filesystem-explorer-window*)
|
|
|
|
(line-oriented-window:row-move *filesystem-explorer-window* amount)
|
|
|
|
(win-clear *filesystem-explorer-window*)
|
|
|
|
(draw *filesystem-explorer-window*)))
|
|
|
|
|
|
|
|
(defun file-explorer-go-down ()
|
|
|
|
(file-explorer-move 1))
|
|
|
|
|
|
|
|
(defun file-explorer-go-up ()
|
|
|
|
(file-explorer-move -1))
|
2021-12-12 21:40:59 +01:00
|
|
|
|
|
|
|
(defun file-explorer-search ()
|
|
|
|
(flet ((on-input-complete (re)
|
|
|
|
(when (string-not-empty-p re)
|
|
|
|
(push-event (make-instance 'filesystem-tree-search-message-event
|
|
|
|
:payload re)))))
|
|
|
|
(ask-string-input #'on-input-complete
|
2021-12-14 13:14:08 +01:00
|
|
|
:prompt (_ "Search for: "))))
|
2021-12-13 18:12:20 +01:00
|
|
|
|
|
|
|
(defun file-explorer-mark-entry ()
|
|
|
|
(when-let* ((win *filesystem-explorer-window*)
|
|
|
|
(fields (line-oriented-window:selected-row-fields win))
|
|
|
|
(path (fstree:tree-path fields)))
|
|
|
|
(with-enqueued-process ()
|
|
|
|
(fstree:mark-node win path)
|
2021-12-14 13:05:40 +01:00
|
|
|
(file-explorer-go-down))))
|
|
|
|
|
|
|
|
(defun file-explorer-delete-tree ()
|
2022-01-06 13:00:16 +01:00
|
|
|
(when-let* ((win *filesystem-explorer-window*)
|
2021-12-14 13:05:40 +01:00
|
|
|
(fields (line-oriented-window:selected-row-fields win))
|
|
|
|
(path (fstree:tree-path fields)))
|
|
|
|
(flet ((on-input-complete (maybe-accepted)
|
|
|
|
(with-valid-yes-at-prompt (maybe-accepted y-pressed-p)
|
|
|
|
(when y-pressed-p
|
|
|
|
(with-enqueued-process ()
|
|
|
|
(fstree:recursive-delete-node win path)
|
|
|
|
(fstree:resync-rows-db win
|
|
|
|
:selected-path (fs:parent-dir-path path)
|
|
|
|
:redraw nil)
|
|
|
|
(windows:win-clear win)
|
|
|
|
(windows:draw win))))))
|
|
|
|
(ask-string-input #'on-input-complete
|
|
|
|
:prompt
|
2021-12-14 13:14:08 +01:00
|
|
|
(format nil (_ "Delete ~a? ") path)))))
|
2021-12-14 13:05:40 +01:00
|
|
|
|
|
|
|
(defun file-explorer-delete-marked ()
|
2022-01-06 11:39:29 +01:00
|
|
|
(when-let* ((win *filesystem-explorer-window*))
|
2021-12-14 13:05:40 +01:00
|
|
|
(flet ((on-input-complete (maybe-accepted)
|
|
|
|
(with-valid-yes-at-prompt (maybe-accepted y-pressed-p)
|
|
|
|
(when y-pressed-p
|
|
|
|
(line-oriented-window:loop-rows
|
|
|
|
(win row
|
|
|
|
when (fstree:tree-marked-p (line-oriented-window:fields row)) do)
|
|
|
|
(let ((path (fstree:tree-path (line-oriented-window:fields row))))
|
|
|
|
(fstree:recursive-delete-node win path)))
|
|
|
|
(let ((root (fstree:tree-path (mtree:data (fstree:filesystem-root win)))))
|
|
|
|
(fstree:resync-rows-db win
|
|
|
|
:selected-path root
|
|
|
|
:redraw t))))))
|
|
|
|
(ask-string-input #'on-input-complete
|
2021-12-14 13:14:08 +01:00
|
|
|
:prompt (_ "Delete marked items? ")))))
|
2022-01-06 11:39:29 +01:00
|
|
|
|
|
|
|
(defun file-explorer-scroll-begin ()
|
|
|
|
(when-let* ((win *filesystem-explorer-window*))
|
|
|
|
(when (not (line-oriented-window:rows-empty-p win))
|
|
|
|
(line-oriented-window:select-row win 0)
|
|
|
|
(windows:win-clear win)
|
|
|
|
(windows:draw win))))
|
|
|
|
|
|
|
|
(defun file-explorer-scroll-end ()
|
|
|
|
(when-let* ((win *filesystem-explorer-window*))
|
|
|
|
(when (not (line-oriented-window:rows-empty-p win))
|
|
|
|
(line-oriented-window:select-row win (1- (line-oriented-window:rows-length win)))
|
|
|
|
(windows:win-clear win)
|
|
|
|
(windows:draw win))))
|
2022-01-06 12:17:31 +01:00
|
|
|
|
|
|
|
(defun file-explorer-close-window ()
|
|
|
|
(close-window-and-return-to-message *filesystem-explorer-window*))
|
2022-01-06 13:00:16 +01:00
|
|
|
|
|
|
|
(defun file-explorer-open-node ()
|
2022-01-06 13:03:31 +01:00
|
|
|
"Download in a temporary file and open the eselected file, or expand
|
|
|
|
if the selected item represents a directory."
|
2022-01-06 13:00:16 +01:00
|
|
|
(when-let* ((win *filesystem-explorer-window*)
|
|
|
|
(fields (line-oriented-window:selected-row-fields win))
|
|
|
|
(path (fstree:tree-path fields)))
|
|
|
|
(fstree:open-node win path)))
|
2022-01-08 13:18:45 +01:00
|
|
|
|
|
|
|
(defun file-explorer-edit-file ()
|
|
|
|
(let* ((win *filesystem-explorer-window*)
|
|
|
|
(fields (line-oriented-window:selected-row-fields win))
|
|
|
|
(path (fstree:tree-path fields)))
|
|
|
|
(fstree:edit-node win path)))
|