aboutsummaryrefslogtreecommitdiff
path: root/lisp/mastodon-views.el
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/mastodon-views.el')
-rw-r--r--lisp/mastodon-views.el377
1 files changed, 258 insertions, 119 deletions
diff --git a/lisp/mastodon-views.el b/lisp/mastodon-views.el
index a3acfe0..ac62b1f 100644
--- a/lisp/mastodon-views.el
+++ b/lisp/mastodon-views.el
@@ -75,7 +75,7 @@
;; switch to timlines without closing the minor view.
;; copying the mode map however means we need to avoid/unbind/override any
-;; functions that might cause interfere with the minor view.
+;; functions that might interfere with the minor view.
;; this is not redundant, as while the buffer -init function calls
;; `mastodon-mode', it gets overridden in some but not all cases.
@@ -92,6 +92,11 @@
(define-key map (kbd "d") #'mastodon-views--delete-filter)
(define-key map (kbd "c") #'mastodon-views--create-filter)
(define-key map (kbd "g") #'mastodon-views--view-filters)
+ (define-key map (kbd "u") #'mastodon-views--update-filter)
+ (define-key map (kbd "k") #'mastodon-views--delete-filter)
+ (define-key map (kbd "a") #'mastodon-views--add-filter-kw)
+ (define-key map (kbd "r") #'mastodon-views--remove-filter-kw)
+ (define-key map (kbd "U") #'mastodon-views--update-filter-kw)
map)
"Keymap for viewing filters.")
@@ -121,6 +126,7 @@
(define-key map (kbd "a") #'mastodon-views--add-account-to-list-at-point)
(define-key map (kbd "r") #'mastodon-views--remove-account-from-list-at-point)
(define-key map (kbd "e") #'mastodon-views--edit-list-at-point)
+ (define-key map (kbd "g") #'mastodon-views--view-lists)
map)
"Keymap for when point is on list name.")
@@ -131,6 +137,7 @@
(define-key map (kbd "c") #'mastodon-views--cancel-scheduled-toot)
(define-key map (kbd "e") #'mastodon-views--edit-scheduled-as-new)
(define-key map (kbd "RET") #'mastodon-views--edit-scheduled-as-new)
+ (define-key map (kbd "g") #'mastodon-views--view-scheduled-toots)
map)
"Keymap for when point is on a scheduled toot.")
@@ -158,15 +165,9 @@ request.
This function is used as the update-function to
`mastodon-tl--init-sync', which initializes a buffer for us and
provides the JSON data."
- ;; FIXME: this is not an update function as it inserts a heading and
- ;; possible bindings string
- ;; either it should go in init-sync, or possibly in each view function
- ;; but either way, this function does almost nothing for us.
- ;; could we call init-sync in here pehaps?
- ;; (mastodon-search--insert-heading view-name)
- ;; (when bindings-string
- ;; (insert (mastodon-tl--set-face (concat "[" bindings-string "]\n\n")
- ;; 'font-lock-comment-face)))
+ ;; FIXME not tecnically an update-fun for init-sync, but just a simple way
+ ;; to set up the empty buffer or else call the insert-fun. not sure if we cd
+ ;; improve by eg calling init-sync in here, making this a real view function.
(if (seq-empty-p data)
(insert (propertize
(format "Looks like you have no %s for now." view-name)
@@ -326,8 +327,7 @@ If ID is provided, use that list."
(name (mastodon-views--get-list-name id))
(buffer-name (format "list-%s" name)))
(mastodon-tl--init buffer-name endpoint
- 'mastodon-tl--timeline
- nil
+ 'mastodon-tl--timeline nil
`(("limit" . ,mastodon-tl--timeline-posts-count)))))
(defun mastodon-views--create-list ()
@@ -393,8 +393,11 @@ If ACCOUNT-ID and HANDLE are provided use them rather than prompting."
(completing-read list-prompt
(mastodon-views--get-lists-names) nil t)))
(list-id (or id (mastodon-views--get-list-id list-name)))
- (followings (mastodon-views--get-users-followings))
- (handles (mastodon-tl--map-alist-vals-to-alist 'acct 'id followings))
+ (followings (unless handle
+ (mastodon-views--get-users-followings)))
+ (handles (unless handle
+ (mastodon-tl--map-alist-vals-to-alist
+ 'acct 'id followings)))
(account (or handle (completing-read "Account to add: "
handles nil t)))
(account-id (or account-id (alist-get account handles)))
@@ -429,8 +432,7 @@ If ID is provided, use that list."
(list-id (or id (mastodon-views--get-list-id list-name)))
(accounts (mastodon-views--accounts-in-list list-id))
(handles (mastodon-tl--map-alist-vals-to-alist 'acct 'id accounts))
- (account (completing-read "Account to remove: "
- handles nil t))
+ (account (completing-read "Account to remove: " handles nil t))
(account-id (alist-get account handles))
(url (mastodon-http--api (format "lists/%s/accounts" list-id)))
(args (mastodon-http--build-array-params-alist "account_ids[]" `(,account-id)))
@@ -516,7 +518,7 @@ JSON is the data returned by the server."
'item-type 'scheduled ; so we nav here
'face 'font-lock-comment-face
'keymap mastodon-views--scheduled-map
- 'scheduled-json toot
+ 'item-json toot
'id .id)
"\n")))
@@ -532,10 +534,8 @@ If ID, just return that toot."
(defun mastodon-views--reschedule-toot ()
"Reschedule the scheduled toot at point."
(interactive)
- (let ((id (mastodon-tl--property 'id :no-move)))
- (if (null id)
- (message "no scheduled toot at point?")
- (mastodon-toot--schedule-toot :reschedule))))
+ (mastodon-tl--do-if-item
+ (mastodon-toot--schedule-toot :reschedule)))
(defun mastodon-views--copy-scheduled-toot-text ()
"Copy the text of the scheduled toot at point."
@@ -550,36 +550,34 @@ If ID, just return that toot."
ID is that of the scheduled toot to cancel.
NO-CONFIRM means there is no ask or message, there is only do."
(interactive)
- (let ((id (or id (mastodon-tl--property 'id :no-move))))
- (if (null id)
- (message "no scheduled toot at point?")
- (when (or no-confirm
- (y-or-n-p "Cancel scheduled toot?"))
- (let* ((url (mastodon-http--api (format "scheduled_statuses/%s" id)))
- (response (mastodon-http--delete url)))
- (mastodon-http--triage response
- (lambda (_)
- (mastodon-views--view-scheduled-toots)
- (unless no-confirm
- (message "Toot cancelled!")))))))))
+ (mastodon-tl--do-if-item
+ (when (or no-confirm
+ (y-or-n-p "Cancel scheduled toot?"))
+ (let* ((id (or id (mastodon-tl--property 'id :no-move)))
+ (url (mastodon-http--api (format "scheduled_statuses/%s" id)))
+ (response (mastodon-http--delete url)))
+ (mastodon-http--triage response
+ (lambda (_)
+ (mastodon-views--view-scheduled-toots)
+ (unless no-confirm
+ (message "Toot cancelled!"))))))))
(defun mastodon-views--edit-scheduled-as-new ()
"Edit scheduled status as new toot."
(interactive)
- (let ((id (mastodon-tl--property 'id :no-move)))
- (if (null id)
- (message "no scheduled toot at point?")
- (let* ((toot (mastodon-tl--property 'scheduled-json :no-move))
- (scheduled (alist-get 'scheduled_at toot)))
- (let-alist (alist-get 'params toot)
- ;; TODO: preserve polls
- ;; (poll (alist-get 'poll params))
- (mastodon-toot--compose-buffer nil .in_reply_to_id nil .text :edit)
- (goto-char (point-max))
- ;; adopt properties from scheduled toot:
- (mastodon-toot--set-toot-properties
- .in_reply_to_id .visibility .spoiler_text .language
- scheduled id (alist-get 'media_attachments toot)))))))
+ (mastodon-tl--do-if-item
+ (let* ((toot (mastodon-tl--property 'scheduled-json :no-move))
+ (id (mastodon-tl--property 'id :no-move))
+ (scheduled (alist-get 'scheduled_at toot)))
+ (let-alist (alist-get 'params toot)
+ ;; TODO: preserve polls
+ ;; (poll (alist-get 'poll params))
+ (mastodon-toot--compose-buffer nil .in_reply_to_id nil .text :edit)
+ (goto-char (point-max))
+ ;; adopt properties from scheduled toot:
+ (mastodon-toot--set-toot-properties
+ .in_reply_to_id .visibility .spoiler_text .language
+ scheduled id (alist-get 'media_attachments toot))))))
;;; FILTERS
@@ -591,87 +589,229 @@ NO-CONFIRM means there is no ask or message, there is only do."
'mastodon-views--insert-filters
nil nil nil
"current filters"
- "c - create filter\n d - delete filter at point\n\
- n/p - go to next/prev filter")
+ "c/u - create/update filter | d/k - delete filter\
+ at point\n a/r/U - add/remove/Update filter keyword\n\
+ n/p - next/prev filter" "v2")
(with-current-buffer "*mastodon-filters*"
(use-local-map mastodon-views--view-filters-keymap)))
(defun mastodon-views--insert-filters (json)
- "Insert the user's current filters.
-JSON is what is returned by by the server."
- (mastodon-views--minor-view
- "filters"
- #'mastodon-views--insert-filter-string-set
- json))
-
-(defun mastodon-views--insert-filter-string-set (json)
"Insert a filter string plus a blank line.
JSON is the filters data."
- (mapc #'mastodon-views--insert-filter-string json))
-
-(defun mastodon-views--insert-filter-string (filter)
+ (mapc #'mastodon-views--insert-filter json))
+
+(require 'table)
+
+(defun mastodon-views--insert-filter-kws (kws)
+ "Insert filter keywords KWS."
+ (insert "\n")
+ (let ((beg (point))
+ (table-cell-horizontal-chars (if (char-displayable-p ?–)
+ "–"
+ "-"))
+ (whole-str "whole words only:"))
+ (insert (concat "Keywords: | " whole-str "\n"))
+ (mapc (lambda (kw)
+ (let ((whole (if (eq :json-false (alist-get 'whole_word kw))
+ "nil"
+ "t")))
+ (insert
+ (propertize (concat
+ (format "\"%s\" | %s\n"
+ (alist-get 'keyword kw) whole))
+ 'kw-id (alist-get 'id kw)
+ 'item-json kw
+ 'mastodon-tab-stop t
+ 'whole-word whole))))
+ kws)
+ ;; table display of kws:
+ (table-capture beg (point) "|" "\n" nil (+ 2 (length whole-str)))
+ (table-justify-column 'center)
+ (table-forward-cell) ;; col 2
+ (table-justify-column 'center)
+ (while (re-search-forward ;; goto end of table:
+ (concat table-cell-horizontal-chars
+ (make-string 1 table-cell-intersection-char)
+ "\n")
+ nil :no-error))))
+
+(defun mastodon-views--insert-filter (filter)
"Insert a single FILTER."
- (let* ((phrase (alist-get 'phrase filter))
- (contexts (alist-get 'context filter))
- (id (alist-get 'id filter))
- (filter-string (concat "- \"" phrase "\" filtered in: "
- (mapconcat #'identity contexts ", "))))
+ (let-alist filter
(insert
- (propertize filter-string
- 'item-id id ;for goto-next-filter compat
- 'item-type 'filter
- 'phrase phrase
- 'byline t) ;for goto-next-filter compat
- "\n\n")))
+ ;; FIXME: awful hack to fix nav: exclude horiz-bar from propertize then
+ ;; propertize rest of the filter text. if we add only byline prop to
+ ;; title, point will move to end of title, because at that byline-prop
+ ;; change, item-type prop is present.
+ (mastodon-tl--set-face
+ (concat "\n " mastodon-tl--horiz-bar "\n ")
+ 'success)
+ (propertize
+ (concat
+ ;; heading:
+ (mastodon-tl--set-face
+ (concat (upcase .title) " " "\n "
+ mastodon-tl--horiz-bar "\n")
+ 'success)
+ ;; context:
+ (concat "Context: " (mapconcat #'identity .context ", "))
+ ;; type (warn or hide):
+ (concat "\nType: " .filter_action))
+ 'item-json filter
+ 'byline t
+ 'item-id .id
+ 'filter-title .title
+ 'item-type 'filter))
+ ;; terms list:
+ (when .keywords ;; poss to have no keywords
+ (mastodon-views--insert-filter-kws .keywords))))
(defvar mastodon-views--filter-types
'("home" "notifications" "public" "thread" "profile"))
-(defun mastodon-views--create-filter ()
+(defun mastodon-views--create-filter (&optional id title context type terms)
"Create a filter for a word.
Prompt for a context, must be a list containting at least one of \"home\",
-\"notifications\", \"public\", \"thread\"."
+\"notifications\", \"public\", \"thread\".
+Optionally, provide ID, TITLE, CONTEXT, TYPE, and TERMS to update a filter."
(interactive)
- (let* ((url (mastodon-http--api "filters"))
- (word (read-string
- (format "Word(s) to filter (%s): " (or (current-word) ""))
- nil nil (or (current-word) "")))
+ ;; ID non-nil = we are updating
+ (let* ((url (mastodon-http--api-v2
+ (if id (format "filters/%s" id) "filters")))
+ (title (or title (read-string "Filter name: ")))
+ (terms (or terms
+ (read-string "Terms to filter (comma or space separated): ")))
+ (terms-split (split-string terms "[, ]"))
+ (terms-processed
+ (if (not terms) ;; well actually it is poss to have no terms
+ (user-error "You must select at least one term")
+ (mastodon-http--build-array-params-alist
+ "keywords_attributes[][keyword]" terms-split)))
+ (warn-or-hide
+ (or type (completing-read "Warn (like CW) or hide? "
+ '("warn" "hide") nil :match)))
+ ;; TODO: display "home (and lists)" but just use "home" for API
(contexts
- (if (string-empty-p word)
- (user-error "You must select at least one word for a filter")
- (completing-read-multiple
- "Contexts to filter [TAB for options]: "
- mastodon-views--filter-types
- nil t)))
+ (or context (completing-read-multiple
+ "Filter contexts [TAB for options, comma separated]: "
+ mastodon-views--filter-types nil :match)))
(contexts-processed
- (if (equal nil contexts)
- (user-error "You must select at least one context for a filter")
- (mapcar (lambda (x)
- (cons "context[]" x))
- contexts)))
- (response (mastodon-http--post url (push
- `("phrase" . ,word)
- contexts-processed))))
- (mastodon-http--triage response
- (lambda (_)
- (when (mastodon-tl--buffer-type-eq 'filters)
- (mastodon-views--view-filters))
- (message "Filter created for %s!" word)))))
+ (if (not contexts)
+ (user-error "You must select at least one context")
+ (mastodon-http--build-array-params-alist "context[]" contexts)))
+ (params (append `(("title" . ,title)
+ ("filter_action" . ,warn-or-hide))
+ terms-processed
+ contexts-processed))
+ (resp (if id
+ (mastodon-http--put url params)
+ (mastodon-http--post url params))))
+ (mastodon-views--filters-triage
+ resp
+ (message "Filter %s %s!" title (if id "updated" "created")))))
+
+(defun mastodon-views--update-filter ()
+ "Update filter at point."
+ (interactive)
+ (if (not (eq 'filter (mastodon-tl--property 'item-type)))
+ (user-error "No filter at point?")
+ (let* ((filter (mastodon-tl--property 'item-json))
+ (id (mastodon-tl--property 'item-id))
+ (name (read-string "Name: " (alist-get 'title filter)))
+ (contexts (completing-read-multiple
+ "Filter contexts [TAB for options, comma separated]: "
+ mastodon-views--filter-types nil :match
+ (mapconcat #'identity
+ (alist-get 'context filter) ",")))
+ (type (completing-read "Warn (like CW) or hide? "
+ '("warn" "hide") nil :match
+ (alist-get 'type filter)))
+ (terms (read-string "Terms to add (comma or space separated): ")))
+ (mastodon-views--create-filter id name contexts type terms))))
(defun mastodon-views--delete-filter ()
"Delete filter at point."
(interactive)
- (let* ((filter-id (mastodon-tl--property 'item-id :no-move))
- (phrase (mastodon-tl--property 'phrase :no-move))
- (url (mastodon-http--api (format "filters/%s" filter-id))))
- (if (null phrase)
+ (let* ((id (mastodon-tl--property 'item-id :no-move))
+ (title (mastodon-tl--property 'filter-title :no-move))
+ (url (mastodon-http--api-v2 (format "filters/%s" id))))
+ (if (not (eq 'filter (mastodon-tl--property 'item-type)))
(user-error "No filter at point?")
- (when (y-or-n-p (format "Delete filter %s? " phrase))
- (let ((response (mastodon-http--delete url)))
- (mastodon-http--triage
- response (lambda (_)
- (mastodon-views--view-filters)
- (message "Filter for \"%s\" deleted!" phrase))))))))
+ (when (y-or-n-p (format "Delete filter %s? " title))
+ (let ((resp (mastodon-http--delete url)))
+ (mastodon-views--filters-triage
+ resp
+ (message "Filter \"%s\" deleted!" title)))))))
+
+(defun mastodon-views--get-filter-kw (&optional id)
+ "GET filter with ID."
+ (let* ((id (or id (mastodon-tl--property 'kw-id :no-move)))
+ (url (mastodon-http--api-v2 (format "filters/keywords/%s" id)))
+ (resp (mastodon-http--get-json url)))
+ resp))
+
+(defun mastodon-views--update-filter-kw ()
+ "Update filter keyword.
+Prmopt to change the term, and the whole words option.
+When t, whole words means only match whole words."
+ (interactive)
+ (if (not (eq 'filter (mastodon-tl--property 'item-type)))
+ (user-error "No filter at point?")
+ (let* ((kws (alist-get 'keywords
+ (mastodon-tl--property 'item-json :no-move)))
+ (alist (mastodon-tl--map-alist-vals-to-alist 'keyword 'id kws))
+ (choice (completing-read "Update keyword: " alist))
+ (updated (read-string "Keyword: " choice))
+ (whole-word (if (y-or-n-p "Match whole words only? ")
+ "true"
+ "false"))
+ (params `(("keyword" . ,updated)
+ ("whole_word" . ,whole-word)))
+ (id (cdr (assoc choice alist #'string=)))
+ (url (mastodon-http--api-v2 (format "filters/keywords/%s" id)))
+ (resp (mastodon-http--put url params)))
+ (mastodon-views--filters-triage resp
+ (format "Keyword %s updated!" updated)))))
+
+(defun mastodon-views--filters-triage (resp msg-str)
+ "Triage filter action response RESP, reload filters, message MSG-STR."
+ (mastodon-http--triage
+ resp
+ (lambda (_resp)
+ (when (mastodon-tl--buffer-type-eq 'filters)
+ (mastodon-views--view-filters))
+ (message msg-str))))
+
+(defun mastodon-views--add-filter-kw ()
+ "Add a keyword to filter at point."
+ (interactive)
+ (if (not (eq 'filter (mastodon-tl--property 'item-type)))
+ (user-error "No filter at point?")
+ (let* ((kw (read-string "Keyword: "))
+ (id (mastodon-tl--property 'item-id :no-move))
+ (whole-word (if (y-or-n-p "Match whole words only? ")
+ "true"
+ "false"))
+ (params `(("keyword" . ,kw)
+ ("whole_word" . ,whole-word)))
+ (url (mastodon-http--api-v2 (format "filters/%s/keywords" id)))
+ (resp (mastodon-http--post url params)))
+ (mastodon-views--filters-triage resp
+ (format "Keyword %s added!" kw)))))
+
+(defun mastodon-views--remove-filter-kw ()
+ "Remove keyword from filter at point."
+ (interactive)
+ (if (not (eq 'filter (mastodon-tl--property 'item-type)))
+ (user-error "No filter at point?")
+ (let* ((kws (alist-get 'keywords
+ (mastodon-tl--property 'item-json :no-move)))
+ (alist (mastodon-tl--map-alist-vals-to-alist 'keyword 'id kws))
+ (choice (completing-read "Remove keyword: " alist))
+ (id (cdr (assoc choice alist #'string=)))
+ (url (mastodon-http--api-v2 (format "filters/keywords/%s" id)))
+ (resp (mastodon-http--delete url)))
+ (mastodon-views--filters-triage resp (format "Keyword %s removed!" choice)))))
;;; FOLLOW SUGGESTIONS
@@ -726,8 +866,7 @@ BRIEF means show fewer details."
"Return an instance base url from a user account URL.
USERNAME is the name to cull.
If INSTANCE is given, use that."
- (cond (instance
- (concat "https://" instance))
+ (cond (instance (concat "https://" instance))
;; pleroma URL is https://instance.com/users/username
((string-suffix-p "users/" (url-basepath url))
(string-remove-suffix "/users/"
@@ -741,6 +880,11 @@ If INSTANCE is given, use that."
(string-remove-suffix (concat "/@" username)
url))))
+(defun mastodon-views--get-own-instance ()
+ "Return JSON of `mastodon-active-user's instance."
+ (mastodon-http--get-json
+ (mastodon-http--api "instance" "v2") nil nil :vector))
+
(defun mastodon-views--view-instance-description
(&optional user brief instance misskey)
"View the details of the instance the current post's author is on.
@@ -750,17 +894,12 @@ INSTANCE is an instance domain name.
MISSKEY means the instance is a Misskey or derived server."
(interactive)
(if user
- (let ((response (mastodon-http--get-json
- (mastodon-http--api "instance" "v2") nil nil :vector)))
+ (let ((response (mastodon-views--get-own-instance)))
(mastodon-views--instance-response-fun response brief instance))
(mastodon-tl--do-if-item
- (let* ((toot (if (mastodon-tl--profile-buffer-p)
- ;; we may be on profile description itself:
- (or (mastodon-tl--property 'profile-json)
- ;; or on profile account listings, or just toots:
- (mastodon-tl--property 'item-json))
- ;; normal timeline/account listing:
- (mastodon-tl--property 'item-json)))
+ (let* ((toot (or (and (mastodon-tl--profile-buffer-p)
+ (mastodon-tl--property 'profile-json)) ; either profile
+ (mastodon-tl--property 'item-json))) ; or toot or user listing
(reblog (alist-get 'reblog toot))
(account (or (alist-get 'account reblog)
(alist-get 'account toot)
@@ -884,9 +1023,9 @@ IND is the optional indentation level to print at."
(mastodon-views--print-json-keys
(cdr el) (if ind (+ ind 4) 4)))
(t ; basic handling of raw booleans:
- (let ((val (cond ((equal (cdr el) :json-false)
+ (let ((val (cond ((eq (cdr el) :json-false)
"no")
- ((equal (cdr el) 't)
+ ((eq (cdr el) t)
"yes")
(t
(cdr el)))))
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-25 15:52:54 +0000