;; tinmop: an humble mastodon client ;; Copyright (C) 2020 cage ;; This program is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation, either version 3 of the License, or ;; (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program. ;; If not, see [[http://www.gnu.org/licenses/][http://www.gnu.org/licenses/]]. (in-package :ui-goodies) (defun boolean-input-accepted-p (user-input) (string-equal user-input (_ "y"))) (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)) (defun clean-close-program () "Use this to close the program" (flet ((on-input-complete (maybe-accepted) (if (boolean-input-accepted-p maybe-accepted) (let ((delete-event (make-instance 'delete-all-status-event)) (quit-event (make-instance 'quit-program-event))) (push-event delete-event) (push-event quit-event)) (quit-program)))) (let ((delete-count (db:count-status-marked-to-delete))) (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)) (quit-program))))) (defun notify (message &key (life nil) (as-error nil)) (let ((event (make-instance 'notify-user-event :life life :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 () (notify starting-message :life life-start) (funcall procedure) (notify ending-message :life life-end)))) (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))) (defun info-dialog-immediate (message &key (buttons nil) (title (_ "Information"))) (let ((dialog-window (windows:make-info-message-dialog specials:*main-window* title message buttons))) (windows:menu-select dialog-window))) (defun error-dialog-immediate (message &key (buttons nil) (title (_ "Error"))) (let ((dialog-window (windows:make-error-message-dialog specials:*main-window* title message buttons))) (windows:menu-select dialog-window))) (defun input-dialog-immediate (message) (windows:make-input-dialog specials:*main-window* specials:*main-window* message)) (defun error-message (message) (let ((event (make-instance 'error-message-event :payload message))) (push-event event))) (defun info-message (message) (let ((event (make-instance 'info-message-event :payload message))) (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 (initial-value nil) (prompt +default-command-prompt+) (complete-fn #'complete:directory-complete)) (flet ((thread-fn () (let ((event (make-instance 'ask-user-input-string-event :initial-value initial-value :complete-fn complete-fn :prompt prompt :payload (box:dbox nil)))) (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 () (thread-window:go-message-up specials:*thread-window*)) (defun thread-go-down () (thread-window:go-message-down specials:*thread-window*)) (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" (thread-window:goto-first-message specials:*thread-window*)) (defun thread-goto-last-message () "Jump to last message" (thread-window:goto-last-message specials:*thread-window*)) (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" (thread-window:search-next-unread specials:*thread-window*)) (defun thread-open-selected-message () "Open selected message" (thread-window:open-message specials:*thread-window*)) (defun thread-mark-delete-selected-message () "Mark selected message for deletion" (thread-window:mark-selected-message-to-delete specials:*thread-window* :move-down-selected-message t)) (defun thread-mark-prevent-delete-selected-message () "Unmark selected message for deletion" (thread-window:mark-selected-message-prevent-delete specials:*thread-window* :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)))) (let* ((selected-row (line-oriented-window:selected-row-fields specials:*thread-window*)) (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 () (message-window:scroll-up specials:*message-window*)) (defun message-scroll-down () (message-window:scroll-down specials:*message-window*)) (defun message-scroll-begin () (message-window:scroll-begin specials:*message-window*)) (defun message-scroll-end () (message-window:scroll-end specials:*message-window*)) (defun message-scroll-next-page () (message-window:scroll-next-page specials:*message-window*)) (defun message-scroll-previous-page () (message-window:scroll-previous-page specials:*message-window*)) (defun message-search-regex () "Search regular expression in message" (flet ((on-input-complete (regex) (let ((event (make-instance 'search-regex-message-content-event :payload regex))) (push-event event)))) (ask-string-input #'on-input-complete :prompt (_ "Search key: ")))) (defun give-focus (win info-change-focus-message &rest windows-lose-focus) (setf (main-window:focused-window specials:*main-window*) win) (setf (windows:in-focus win) t) (loop for win in windows-lose-focus when win do (setf (windows:in-focus win) nil)) (windows:draw-all) (info-message info-change-focus-message)) (defmacro gen-focus-to-window (function-suffix window-get-focus &key (info-change-focus-message (_ "Focus changed")) (windows-lose-focus nil) (documentation nil)) `(defun ,(misc:format-fn-symbol t "focus-to-~a" function-suffix) () ,documentation (give-focus ,window-get-focus , info-change-focus-message ,@windows-lose-focus))) (gen-focus-to-window thread-window specials:*thread-window* :documentation "Move focus on thread window" :info-change-focus-message (_ "Focus passed on threads window") :windows-lose-focus (specials:*conversations-window* specials:*tags-window* specials:*send-message-window* specials:*message-window* specials:*follow-requests-window*)) (gen-focus-to-window message-window specials:*message-window* :documentation "Move focus on message window" :info-change-focus-message (_ "Focus passed on message window") :windows-lose-focus (specials:*conversations-window* specials:*tags-window* specials:*thread-window* specials:*send-message-window* specials:*follow-requests-window*)) (gen-focus-to-window send-message-window specials:*send-message-window* :documentation "Move focus on send message window" :info-change-focus-message (_ "Focus passed on send message window") :windows-lose-focus (specials:*open-attach-window* specials:*conversations-window* specials:*tags-window* specials:*thread-window* specials:*message-window* specials:*follow-requests-window*)) (gen-focus-to-window follow-requests-window specials:*follow-requests-window* :documentation "Move focus on follow requests window" :info-change-focus-message (_ "Focus passed on follow requests window") :windows-lose-focus (specials:*open-attach-window* specials:*conversations-window* specials:*tags-window* specials:*thread-window* specials:*message-window* specials:*send-message-window*)) (gen-focus-to-window tags-window specials:*tags-window* :documentation "Move focus on tags window" :info-change-focus-message (_ "Focus passed on tags window") :windows-lose-focus (specials:*open-attach-window* specials:*conversations-window* specials:*follow-requests-window* specials:*thread-window* specials:*message-window* specials:*send-message-window*)) (gen-focus-to-window conversations-window specials:*conversations-window* :documentation "Move focus on conversations window" :info-change-focus-message (_ "Focus passed on conversation window") :windows-lose-focus (specials:*open-attach-window* specials:*tags-window* specials:*follow-requests-window* specials:*thread-window* specials:*message-window* specials:*send-message-window*)) (gen-focus-to-window open-attach-window specials:*open-attach-window* :documentation "Move focus on open-attach window" :info-change-focus-message (_ "Focus passed on attach window") :windows-lose-focus (specials:*conversations-window* specials:*tags-window* specials:*follow-requests-window* specials:*thread-window* specials:*message-window* specials:*send-message-window*)) (defun print-quick-help () "Print a quick help" (keybindings:print-help specials:*main-window*)) (defun move-message-tree () "Move messages tree" (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" (let ((folder (thread-window:timeline-folder specials:*thread-window*))) (flet ((on-input-complete (new-timeline) (let* ((refresh-event (make-instance 'refresh-thread-windows-event :new-timeline new-timeline))) (if (string-empty-p new-timeline) (error-message (_ "No timeline specified.")) (push-event refresh-event))))) (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)))) (defun update-current-timeline () "Update current timeline" (let* ((timeline (thread-window:timeline-type specials:*thread-window*)) (folder (thread-window:timeline-folder specials:*thread-window*)) (max-id (db:last-status-id-timeline-folder timeline folder))) (multiple-value-bind (kind localp) (timeline->kind timeline) (flet ((update () (client:update-timeline timeline kind folder :min-id max-id :local localp) (let ((refresh-event (make-instance 'refresh-thread-windows-event))) (push-event refresh-event)))) (notify-procedure #'update (_ "Downloading messages.") :ending-message (_ "Messages downloaded.") :life-start (* (swconf:config-notification-life) 5)))))) (defun refresh-tags () "Update messages for subscribed tags" (let ((all-tags (db:all-subscribed-tags-name))) (flet ((update () (client:update-subscribed-tags all-tags) (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) (when-let* ((selected-row (line-oriented-window:selected-row-fields specials:*thread-window*)) (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 specials:*thread-window*)) (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 (line-oriented-window:unselect-all specials:*send-message-window*) (line-oriented-window:row-move specials:*send-message-window* amount) (draw specials:*send-message-window*))) (defun attach-go-down () (attach-move 1)) (defun attach-go-up () (attach-move -1)) (defun attach-delete () "Delete an attach" (line-oriented-window:selected-row-delete specials:*send-message-window*) (draw specials:*send-message-window*)) (defun attach-add () "Add an attach" (flet ((on-add-attach (attach-path) (when (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))))) (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))) (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))) (defun cancel-send-message () "Cancel sending operation" (close-window-and-return-to-threads specials:*send-message-window*)) (defun edit-message-body () "Edit message" (when (and specials:*send-message-window* (sending-message:message-data specials:*send-message-window*)) (with-accessors ((body sending-message:body) (subject sending-message:subject) (reply-to sending-message:reply-to) (visibility sending-message:visibility)) (sending-message:message-data specials:*send-message-window*) (let ((temp-file (fs:temporary-filename))) (with-open-file (stream temp-file :direction :output :if-exists :supersede :if-does-not-exist :error) (write-sequence body stream)) (croatoan:end-screen) (os-utils:open-with-editor temp-file) (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))) (defun compose-message (&optional reply-id subject (visibility +status-public-visibility+)) "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). (when-let* ((message (db:find-status-id reply-id)) (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)) lines))) (with-open-file (stream file :if-exists :append :direction :output :element-type 'character) (loop for line in quoted-lines do (format stream "~a~%" line)))))) (add-body () (let ((temp-file (fs:temporary-filename)) (reference-open-file (get-universal-time))) (prepare-reply-body temp-file) (croatoan:end-screen) (os-utils:open-with-editor temp-file) (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)))))) (add-body))) (defun reply-message () "Reply to message" (when-let* ((win specials:*thread-window*) (selected-message (line-oriented-window:selected-row-fields win)) (username (db:row-message-username selected-message)) (visibility (db:row-message-visibility selected-message)) (reply-id (db:row-message-status-id selected-message))) (let ((subject (db:row-message-subject selected-message))) (compose-message reply-id subject visibility)))) (defun send-message () "Send message" (when (and specials:*send-message-window* (sending-message:message-data specials:*send-message-window*)) (let ((data (sending-message:message-data specials:*send-message-window*)) (attachments (line-oriented-window:rows specials:*send-message-window*)) (max-allowed-attach (swconf:max-attachments-allowed))) (if (> (length attachments) 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 () "Open message attachments window" (when-let* ((win specials:*thread-window*) (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))) (defun open-message-attach-move (amount) (ignore-errors (line-oriented-window:unselect-all specials:*open-attach-window*) (line-oriented-window:row-move specials:*open-attach-window* amount) (draw specials:*open-attach-window*))) (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 () (when-let* ((selected-line (line-oriented-window:selected-row specials:*open-attach-window*)) (url (line-oriented-window:normal-text selected-line))) (open-attach-window:open-attachment url))) (defun close-open-message-window () (close-window-and-return-to-threads specials:*open-attach-window*)) (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) (with-blocking-notify-procedure ((format nil notify-starting-message username) (format nil notify-ending-message username)) (let ((event (make-instance event :payload username))) (push-event event)))))) (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") (_ "Followed ~a"))) (defun unfollow-user () "Unfollow user" (prompt-for-username (_ "Unfollow: ") #'complete:followed-user-complete 'unfollow-user-event (_ "Unfollowing ~a") (_ "Unfollowed ~a"))) (defun follow-request-move (amount) (ignore-errors (line-oriented-window:unselect-all specials:*follow-requests-window*) (line-oriented-window:row-move specials:*follow-requests-window* amount) (draw specials:*follow-requests-window*))) (defun follow-request-go-down () (follow-request-move 1)) (defun follow-request-go-up () (follow-request-move -1)) (defun follow-request-delete () (line-oriented-window:selected-row-delete specials:*follow-requests-window*) (draw specials:*follow-requests-window*)) (defun start-follow-request-processing () (let ((event (make-instance 'open-follow-requests-window-event))) (push-event event))) (defun close-follow-requests-window () (close-window-and-return-to-threads specials:*follow-requests-window*)) (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 (line-oriented-window:unselect-all specials:*tags-window*) (line-oriented-window:row-move specials:*tags-window* amount) (draw specials:*tags-window*))) (defun tag-go-down () (tag-move 1)) (defun tag-go-up () (tag-move -1)) (defun open-tag-folder () "Open tag folder" (when-let* ((selected-line (line-oriented-window:selected-row specials:*tags-window*)) (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 () (let* ((timeline (thread-window:timeline-type specials:*thread-window*)) (folder (thread-window:timeline-folder specials:*thread-window*)) (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 (line-oriented-window:unselect-all specials:*conversations-window*) (line-oriented-window:row-move specials:*conversations-window* amount) (draw specials:*conversations-window*))) (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 specials:*conversations-window*)) (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) (let ((event (make-instance 'change-conversation-name-event :old-name *conversation-old-name* :new-name new-name))) (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)) (push-event event))))))) (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 specials:*conversations-window*)) (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 specials:*conversations-window*)) (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" (let* ((selected-row (line-oriented-window:selected-row-fields specials:*thread-window*)) (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)))