aboutsummaryrefslogtreecommitdiff
path: root/lisp/mastodon-tl.el
diff options
context:
space:
mode:
authormarty hiatt <martianhiatus [a t] riseup [d o t] net>2023-03-18 18:22:48 +0100
committermarty hiatt <martianhiatus [a t] riseup [d o t] net>2023-03-18 18:22:48 +0100
commit7fd37350a8a565a71b326462ff5026f729310b67 (patch)
tree608df5c686447e846265ab91317d41892bc7cf00 /lisp/mastodon-tl.el
parent9c449bd25d196a9545cbe22ba664a35a6df98224 (diff)
parentdc1149ae594f44944d6807001dd2765ff1766d71 (diff)
Merge branch 'views' into develop
Diffstat (limited to 'lisp/mastodon-tl.el')
-rw-r--r--lisp/mastodon-tl.el749
1 files changed, 0 insertions, 749 deletions
diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el
index 325af2d..1dbe199 100644
--- a/lisp/mastodon-tl.el
+++ b/lisp/mastodon-tl.el
@@ -29,7 +29,6 @@
;;; Commentary:
;; mastodon-tl.el provides timeline functions.
-;; Also provides list, filters, follow suggestions, etc. view functions.
;;; Code:
@@ -242,60 +241,6 @@ types of mastodon links and not just shr.el-generated ones.")
We need to override the keymap so tabbing will navigate to all
types of mastodon links and not just shr.el-generated ones.")
-(defvar mastodon-tl--view-filters-keymap
- (let ((map
- (copy-keymap mastodon-mode-map)))
- (define-key map (kbd "d") 'mastodon-tl--delete-filter)
- (define-key map (kbd "c") 'mastodon-tl--create-filter)
- (define-key map (kbd "n") 'mastodon-tl--goto-next-item)
- (define-key map (kbd "p") 'mastodon-tl--goto-prev-item)
- (define-key map (kbd "TAB") 'mastodon-tl--goto-next-item)
- (define-key map (kbd "g") 'mastodon-tl--view-filters)
- (keymap-canonicalize map))
- "Keymap for viewing filters.")
-
-(defvar mastodon-tl--follow-suggestions-map
- (let ((map
- (copy-keymap mastodon-mode-map)))
- (define-key map (kbd "n") 'mastodon-tl--goto-next-item)
- (define-key map (kbd "p") 'mastodon-tl--goto-prev-item)
- (define-key map (kbd "g") 'mastodon-tl--get-follow-suggestions)
- (keymap-canonicalize map))
- "Keymap for viewing follow suggestions.")
-
-(defvar mastodon-tl--view-lists-keymap
- (let ((map ;(make-sparse-keymap)))
- (copy-keymap mastodon-mode-map)))
- (define-key map (kbd "D") 'mastodon-tl--delete-list)
- (define-key map (kbd "C") 'mastodon-tl--create-list)
- (define-key map (kbd "A") 'mastodon-tl--add-account-to-list)
- (define-key map (kbd "R") 'mastodon-tl--remove-account-from-list)
- (define-key map (kbd "E") 'mastodon-tl--edit-list)
- (define-key map (kbd "n") 'mastodon-tl--goto-next-item)
- (define-key map (kbd "p") 'mastodon-tl--goto-prev-item)
- (define-key map (kbd "g") 'mastodon-tl--view-lists)
- (keymap-canonicalize map))
- "Keymap for viewing lists.")
-
-(defvar mastodon-tl--list-name-keymap
- (let ((map (make-sparse-keymap)))
- (define-key map (kbd "<return>") 'mastodon-tl--view-timeline-list-at-point)
- (define-key map (kbd "d") 'mastodon-tl--delete-list-at-point)
- (define-key map (kbd "a") 'mastodon-tl--add-account-to-list-at-point)
- (define-key map (kbd "r") 'mastodon-tl--remove-account-from-list-at-point)
- (define-key map (kbd "e") 'mastodon-tl--edit-list-at-point)
- (keymap-canonicalize map))
- "Keymap for when point is on list name.")
-
-(defvar mastodon-tl--scheduled-map
- (let ((map (make-sparse-keymap)))
- (define-key map (kbd "r") 'mastodon-tl--reschedule-toot)
- (define-key map (kbd "c") 'mastodon-tl--cancel-scheduled-toot)
- (define-key map (kbd "e") 'mastodon-tl--edit-scheduled-as-new)
- (define-key map (kbd "<return>") 'mastodon-tl--edit-scheduled-as-new)
- (keymap-canonicalize map))
- "Keymap for when point is on a scheduled toot.")
-
(defvar mastodon-tl--byline-link-keymap
(when (require 'mpv nil :no-error)
(let ((map (make-sparse-keymap)))
@@ -1771,700 +1716,6 @@ ID is that of the post the context is currently displayed for."
(member (mastodon-auth--get-account-id) d-ids))))
-;;; LISTS
-
-(defun mastodon-tl--get-users-lists ()
- "Get the list of the user's lists from the server."
- (let ((url (mastodon-http--api "lists")))
- (mastodon-http--get-json url)))
-
-(defun mastodon-tl--get-lists-names ()
- "Return a list of the user's lists' names."
- (let ((lists (mastodon-tl--get-users-lists)))
- (mapcar (lambda (x)
- (alist-get 'title x))
- lists)))
-
-(defun mastodon-tl--get-list-by-name (name)
- "Return the list data for list with NAME."
- (let* ((lists (mastodon-tl--get-users-lists)))
- (cl-loop for list in lists
- if (string= (alist-get 'title list) name)
- return list)))
-
-(defun mastodon-tl--get-list-id (name)
- "Return id for list with NAME."
- (let ((list (mastodon-tl--get-list-by-name name)))
- (alist-get 'id list)))
-
-(defun mastodon-tl--get-list-name (id)
- "Return name of list with ID."
- (let* ((url (mastodon-http--api (format "lists/%s" id)))
- (response (mastodon-http--get-json url)))
- (alist-get 'title response)))
-
-(defun mastodon-tl--edit-list-at-point ()
- "Edit list at point."
- (interactive)
- (let ((id (get-text-property (point) 'list-id)))
- (mastodon-tl--edit-list id)))
-
-(defun mastodon-tl--edit-list (&optional id)
- "Prompt for a list and edit the name and replies policy.
-If ID is provided, use that list."
- (interactive)
- (let* ((list-names (unless id (mastodon-tl--get-lists-names)))
- (name-old (if id
- (get-text-property (point) 'list-name)
- (completing-read "Edit list: "
- list-names)))
- (id (or id (mastodon-tl--get-list-id name-old)))
- (name-choice (read-string "List name: " name-old))
- (replies-policy (completing-read "Replies policy: " ; give this a proper name
- '("followed" "list" "none")
- nil t nil nil "list"))
- (url (mastodon-http--api (format "lists/%s" id)))
- (response (mastodon-http--put url
- `(("title" . ,name-choice)
- ("replies_policy" . ,replies-policy)))))
- (mastodon-http--triage response
- (lambda ()
- (with-current-buffer response
- (let* ((json (mastodon-http--process-json))
- (name-new (alist-get 'title json)))
- (message "list %s edited to %s!" name-old name-new)))
- (when (mastodon-tl--buffer-type-eq 'lists)
- (mastodon-tl--view-lists))))))
-
-(defun mastodon-tl--view-timeline-list-at-point ()
- "View timeline of list at point."
- (interactive)
- (let ((list-id (get-text-property (point) 'list-id)))
- (mastodon-tl--view-list-timeline list-id)))
-
-(defun mastodon-tl--view-list-timeline (&optional id)
- "Prompt for a list and view its timeline.
-If ID is provided, use that list."
- (interactive)
- (let* ((list-names (unless id (mastodon-tl--get-lists-names)))
- (list-name (unless id (completing-read "View list: " list-names)))
- (id (or id (mastodon-tl--get-list-id list-name)))
- (endpoint (format "timelines/list/%s" id))
- (name (mastodon-tl--get-list-name id))
- (buffer-name (format "list-%s" name)))
- (mastodon-tl--init buffer-name endpoint 'mastodon-tl--timeline)))
-
-(defun mastodon-tl--create-list ()
- "Create a new list.
-Prompt for name and replies policy."
- (interactive)
- (let* ((title (read-string "New list name: "))
- (replies-policy (completing-read "Replies policy: " ; give this a proper name
- '("followed" "list" "none")
- nil t nil nil "list")) ; default
- (response (mastodon-http--post (mastodon-http--api "lists")
- `(("title" . ,title)
- ("replies_policy" . ,replies-policy))
- nil)))
- (mastodon-tl--list-action-triage response
- (message "list %s created!" title))))
-
-(defun mastodon-tl--delete-list-at-point ()
- "Delete list at point."
- (interactive)
- (let ((id (get-text-property (point) 'list-id)))
- (mastodon-tl--delete-list id)))
-
-(defun mastodon-tl--delete-list (&optional id)
- "Prompt for a list and delete it.
-If ID is provided, delete that list."
- (interactive)
- (let* ((list-names (unless id (mastodon-tl--get-lists-names)))
- (name (if id
- (mastodon-tl--get-list-name id)
- (completing-read "Delete list: "
- list-names)))
- (id (or id (mastodon-tl--get-list-id name)))
- (url (mastodon-http--api (format "lists/%s" id))))
- (when (y-or-n-p (format "Delete list %s?" name))
- (let ((response (mastodon-http--delete url)))
- (mastodon-tl--list-action-triage response
- (message "list %s deleted!" name))))))
-
-(defun mastodon-tl--view-lists ()
- "Show the user's lists in a new buffer."
- (interactive)
- (mastodon-tl--init-sync "lists"
- "lists"
- 'mastodon-tl--insert-lists)
- (with-current-buffer "*mastodon-lists*"
- (use-local-map mastodon-tl--view-lists-keymap)))
-
-(defun mastodon-tl--insert-lists (_json)
- "Insert the user's lists from JSON."
- ;; TODO: for now we don't use the JSON, we get it ourself again
- (let* ((lists-names (mastodon-tl--get-lists-names)))
- (erase-buffer)
- (insert (mastodon-tl--set-face
- (concat "\n ------------\n"
- " YOUR LISTS\n"
- " ------------\n\n")
- 'success)
- (mastodon-tl--set-face
- "[C - create a list\n D - delete a list\
-\n A/R - add/remove account from a list\
-\n E - edit a list\n n/p - go to next/prev item]\n\n"
- 'font-lock-comment-face))
- (mapc (lambda (x)
- (mastodon-tl--print-list-accounts x)
- (insert (propertize " ------------\n\n"
- 'face 'success)))
- lists-names)
- (goto-char (point-min))))
-;; (mastodon-tl--goto-next-item))) ; causes another request!
-
-(defun mastodon-tl--print-list-accounts (list-name)
- "Insert the accounts in list named LIST-NAME."
- (let* ((id (mastodon-tl--get-list-id list-name))
- (accounts (mastodon-tl--accounts-in-list id)))
- (insert
- (propertize list-name
- 'byline t ; so we nav here
- 'toot-id "0" ; so we nav here
- 'help-echo "RET: view list timeline, d: delete this list, \
-a: add account to this list, r: remove account from this list"
- 'list t
- 'face 'link
- 'keymap mastodon-tl--list-name-keymap
- 'list-name list-name
- 'list-id id)
- (propertize
- "\n\n"
- 'list t
- 'keymap mastodon-tl--list-name-keymap
- 'list-name list-name
- 'list-id id)
- (propertize
- (mapconcat #'mastodon-search--propertize-user accounts
- " ")
- ;; (mastodon-search--insert-users-propertized accounts)
- 'list t
- 'keymap mastodon-tl--list-name-keymap
- 'list-name list-name
- 'list-id id))))
-
-(defun mastodon-tl--get-users-followings ()
- "Return the list of followers of the logged in account."
- (let* ((id (mastodon-auth--get-account-id))
- (url (mastodon-http--api (format "accounts/%s/following" id))))
- (mastodon-http--get-json url '(("limit" . "80"))))) ; max 80 accounts
-
-(defun mastodon-tl--add-account-to-list-at-point ()
- "Prompt for account and add to list at point."
- (interactive)
- (let ((id (get-text-property (point) 'list-id)))
- (mastodon-tl--add-account-to-list id)))
-
-(defun mastodon-tl--add-account-to-list (&optional id account-id handle)
- "Prompt for a list and for an account, add account to list.
-If ID is provided, use that list.
-If ACCOUNT-ID and HANDLE are provided use them rather than prompting."
- (interactive)
- (let* ((list-prompt (if handle
- (format "Add %s to list: " handle)
- "Add account to list: "))
- (list-name (if id
- (get-text-property (point) 'list-name)
- (completing-read list-prompt
- (mastodon-tl--get-lists-names) nil t)))
- (list-id (or id (mastodon-tl--get-list-id list-name)))
- (followings (mastodon-tl--get-users-followings))
- (handles (mapcar (lambda (x)
- (cons (alist-get 'acct x)
- (alist-get 'id x)))
- followings))
- (account (or handle (completing-read "Account to add: "
- handles nil t)))
- (account-id (or account-id (alist-get account handles nil nil 'equal)))
- (url (mastodon-http--api (format "lists/%s/accounts" list-id)))
- (response (mastodon-http--post url
- `(("account_ids[]" . ,account-id)))))
- (mastodon-tl--list-action-triage
- response
- (message "%s added to list %s!" account list-name))))
-
-(defun mastodon-tl--add-toot-account-at-point-to-list ()
- "Prompt for a list, and add the account of the toot at point to it."
- (interactive)
- (let* ((toot (mastodon-tl--property 'toot-json))
- (account (mastodon-tl--field 'account toot))
- (account-id (mastodon-tl--field 'id account))
- (handle (mastodon-tl--field 'acct account)))
- (mastodon-tl--add-account-to-list nil account-id handle)))
-
-(defun mastodon-tl--remove-account-from-list-at-point ()
- "Prompt for account and remove from list at point."
- (interactive)
- (let ((id (get-text-property (point) 'list-id)))
- (mastodon-tl--remove-account-from-list id)))
-
-(defun mastodon-tl--remove-account-from-list (&optional id)
- "Prompt for a list, select an account and remove from list.
-If ID is provided, use that list."
- (interactive)
- (let* ((list-name (if id
- (get-text-property (point) 'list-name)
- (completing-read "Remove account from list: "
- (mastodon-tl--get-lists-names) nil t)))
- (list-id (or id (mastodon-tl--get-list-id list-name)))
- (accounts (mastodon-tl--accounts-in-list list-id))
- (handles (mapcar (lambda (x)
- (cons (alist-get 'acct x)
- (alist-get 'id x)))
- accounts))
- (account (completing-read "Account to remove: "
- handles nil t))
- (account-id (alist-get account handles nil nil 'equal))
- (url (mastodon-http--api (format "lists/%s/accounts" list-id)))
- (args (mastodon-http--build-array-params-alist "account_ids[]" `(,account-id)))
- (response (mastodon-http--delete url args)))
- (mastodon-tl--list-action-triage
- response
- (message "%s removed from list %s!" account list-name))))
-
-(defun mastodon-tl--list-action-triage (response message)
- "Call `mastodon-http--triage' on RESPONSE and display MESSAGE."
- (mastodon-http--triage response
- (lambda ()
- (when (mastodon-tl--buffer-type-eq 'lists)
- (mastodon-tl--view-lists))
- message)))
-
-(defun mastodon-tl--accounts-in-list (list-id)
- "Return the JSON of the accounts in list with LIST-ID."
- (let* ((url (mastodon-http--api (format "lists/%s/accounts" list-id))))
- (mastodon-http--get-json url)))
-
-
-;;; SCHEDULED TOOTS
-
-(defun mastodon-tl--get-scheduled-toots (&optional id)
- "Get the user's currently scheduled toots.
-If ID, just return that toot."
- (let* ((endpoint (if id
- (format "scheduled_statuses/%s" id)
- "scheduled_statuses"))
- (url (mastodon-http--api endpoint)))
- (mastodon-http--get-json url)))
-
-(defun mastodon-tl--reschedule-toot ()
- "Reschedule the scheduled toot at point."
- (interactive)
- (mastodon-toot--schedule-toot :reschedule))
-
-(defun mastodon-tl--view-scheduled-toots ()
- "Show the user's scheduled toots in a new buffer."
- (interactive)
- (mastodon-tl--init-sync "scheduled-toots"
- "scheduled_statuses"
- 'mastodon-tl--insert-scheduled-toots))
-
-(defun mastodon-tl--insert-scheduled-toots (json)
- "Insert the user's scheduled toots, from JSON."
- (let ((scheduleds (mastodon-tl--get-scheduled-toots)))
- (erase-buffer)
- (insert (mastodon-tl--set-face
- (concat "\n ------------\n"
- " YOUR SCHEDULED TOOTS\n"
- " ------------\n\n")
- 'success)
- (mastodon-tl--set-face
- "[n/p - prev/next\n r - reschedule\n e/RET - edit toot\n c - cancel]\n\n"
- 'font-lock-comment-face))
- (mapc #'mastodon-tl--insert-scheduled-toot scheduleds)
- (goto-char (point-min))
- (when json
- (mastodon-tl--goto-next-toot))))
-
-(defun mastodon-tl--insert-scheduled-toot (toot)
- "Insert scheduled TOOT into the buffer."
- (let* ((id (alist-get 'id toot))
- (scheduled (alist-get 'scheduled_at toot))
- (params (alist-get 'params toot))
- (text (alist-get 'text params)))
- (insert
- (propertize (concat text
- " | "
- (mastodon-toot--iso-to-human scheduled))
- 'byline t ; so we nav here
- 'toot-id "0" ; so we nav here
- 'face 'font-lock-comment-face
- 'keymap mastodon-tl--scheduled-map
- 'scheduled-json toot
- 'id id)
- "\n")))
-
-(defun mastodon-tl--copy-scheduled-toot-text ()
- "Copy the text of the scheduled toot at point."
- (interactive)
- (let* ((toot (get-text-property (point) 'toot))
- (params (alist-get 'params toot))
- (text (alist-get 'text params)))
- (kill-new text)))
-
-(defun mastodon-tl--cancel-scheduled-toot (&optional id no-confirm)
- "Cancel the scheduled toot at point.
-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 (get-text-property (point) 'id)))
- (url (mastodon-http--api (format "scheduled_statuses/%s" id))))
- (when (or no-confirm
- (y-or-n-p "Cancel scheduled toot?"))
- (let ((response (mastodon-http--delete url)))
- (mastodon-http--triage response
- (lambda ()
- (mastodon-tl--view-scheduled-toots)
- (unless no-confirm
- (message "Toot cancelled!"))))))))
-
-(defun mastodon-tl--edit-scheduled-as-new ()
- "Edit scheduled status as new toot."
- (interactive)
- (let* ((toot (get-text-property (point) 'scheduled-json))
- (id (alist-get 'id toot))
- (scheduled (alist-get 'scheduled_at toot))
- (params (alist-get 'params toot))
- (text (alist-get 'text params))
- (visibility (alist-get 'visibility params))
- (cw (alist-get 'spoiler_text params))
- (lang (alist-get 'language params))
- ;; (poll (alist-get 'poll params))
- (reply-id (alist-get 'in_reply_to_id params)))
- ;; (media (alist-get 'media_attachments toot)))
- (mastodon-toot--compose-buffer)
- (goto-char (point-max))
- (insert text)
- ;; adopt properties from scheduled toot:
- (mastodon-toot--set-toot-properties reply-id visibility cw
- lang scheduled id)))
-
-
-;;; FILTERS
-
-(defun mastodon-tl--create-filter ()
- "Create a filter for a word.
-Prompt for a context, must be a list containting at least one of \"home\",
-\"notifications\", \"public\", \"thread\"."
- (interactive)
- (let* ((url (mastodon-http--api "filters"))
- (word (read-string
- (format "Word(s) to filter (%s): " (or (current-word) ""))
- nil nil (or (current-word) "")))
- (contexts
- (if (string-empty-p word)
- (error "You must select at least one word for a filter")
- (completing-read-multiple
- "Contexts to filter [TAB for options]: "
- '("home" "notifications" "public" "thread")
- nil ; no predicate
- t))) ; require-match, as context is mandatory
- (contexts-processed
- (if (equal nil contexts)
- (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 ()
- (message "Filter created for %s!" word)
- ;; reload if we are in filters view:
- (when (mastodon-tl--buffer-type-eq 'filters)
- (mastodon-tl--view-filters))))))
-
-(defun mastodon-tl--view-filters ()
- "View the user's filters in a new buffer."
- (interactive)
- (mastodon-tl--init-sync "filters"
- "filters"
- 'mastodon-tl--insert-filters)
- (with-current-buffer "*mastodon-filters*"
- (use-local-map mastodon-tl--view-filters-keymap)))
-
-(defun mastodon-tl--insert-filters (json)
- "Insert the user's current filters.
-JSON is what is returned by by the server."
- (insert (mastodon-tl--set-face
- (concat "\n ------------\n"
- " CURRENT FILTERS\n"
- " ------------\n\n")
- 'success)
- (mastodon-tl--set-face
- "[c - create filter\n d - delete filter at point\n n/p - go to next/prev filter]\n\n"
- 'font-lock-comment-face))
- (if (seq-empty-p json)
- (insert (propertize
- "Looks like you have no filters for now."
- 'face font-lock-comment-face
- 'byline t
- 'toot-id "0")) ; so point can move here when no filters
- (mapc (lambda (x)
- (mastodon-tl--insert-filter-string x)
- (insert "\n\n"))
- json)))
-
-(defun mastodon-tl--insert-filter-string (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 ", "))))
- (insert
- (propertize filter-string
- 'toot-id id ;for goto-next-filter compat
- 'phrase phrase
- ;;'help-echo "n/p to go to next/prev filter, c to create new filter, d to delete filter at point."
- ;;'keymap mastodon-tl--view-filters-keymap
- 'byline t)))) ;for goto-next-filter compat
-
-(defun mastodon-tl--delete-filter ()
- "Delete filter at point."
- (interactive)
- (let* ((filter-id (get-text-property (point) 'toot-id))
- (phrase (get-text-property (point) 'phrase))
- (url (mastodon-http--api
- (format "filters/%s" filter-id))))
- (if (equal nil filter-id)
- (error "No filter at point?")
- (when (y-or-n-p (format "Delete this filter? ")))
- (let ((response (mastodon-http--delete url)))
- (mastodon-http--triage response (lambda ()
- (mastodon-tl--view-filters)
- (message "Filter for \"%s\" deleted!" phrase)))))))
-
-
-;;; FOLLOW SUGGESTIONS
-
-(defun mastodon-tl--get-follow-suggestions ()
- "Display a buffer of suggested accounts to follow."
- (interactive)
- (mastodon-tl--init-sync "follow-suggestions"
- "suggestions"
- 'mastodon-tl--insert-follow-suggestions)
- (with-current-buffer "*mastodon-follow-suggestions*"
- (use-local-map mastodon-tl--follow-suggestions-map)))
-
-(defun mastodon-tl--insert-follow-suggestions (response)
- "Insert follow suggestions into buffer.
-RESPONSE is the JSON returned by the server."
- (insert (mastodon-tl--set-face
- (concat "\n ------------\n"
- " SUGGESTED ACCOUNTS\n"
- " ------------\n\n")
- 'success))
- (mastodon-search--insert-users-propertized response :note)
- (goto-char (point-min)))
-
-
-;;; INSTANCES
-
-(defun mastodon-tl--view-own-instance (&optional brief)
- "View details of your own instance.
-BRIEF means show fewer details."
- (interactive)
- (mastodon-tl--view-instance-description :user brief))
-
-(defun mastodon-tl--view-own-instance-brief ()
- "View brief details of your own instance."
- (interactive)
- (mastodon-tl--view-instance-description :user :brief))
-
-(defun mastodon-tl--view-instance-description-brief ()
- "View brief details of the instance the current post's author is on."
- (interactive)
- (mastodon-tl--view-instance-description nil :brief))
-
-(defun mastodon-tl--view-instance-description (&optional user brief instance)
- "View the details of the instance the current post's author is on.
-USER means to show the instance details for the logged in user.
-BRIEF means to show fewer details.
-INSTANCE is an instance domain name."
- (interactive)
- (if user
- (let ((response (mastodon-http--get-json
- (mastodon-http--api "instance")
- nil ; params
- nil ; silent
- :vector)))
- (mastodon-tl--instance-response-fun response brief))
- (mastodon-tl--do-if-toot
- (let* ((toot (if (mastodon-tl--profile-buffer-p)
- (mastodon-tl--property 'profile-json) ; profile may have 0 toots
- (mastodon-tl--property 'toot-json)))
- (reblog (alist-get 'reblog toot))
- (account (or (alist-get 'account reblog)
- (alist-get 'account toot)))
- (url (if profile-p
- (alist-get 'url toot) ; profile
- (alist-get 'url account)))
- (username (if profile-p
- (alist-get 'username toot) ;; profile
- (alist-get 'username account)))
- (instance (if instance
- (concat "https://" instance)
- ;; pleroma URL is https://instance.com/users/username
- (if (string-suffix-p "users/" (url-basepath url))
- (string-remove-suffix "/users/"
- (url-basepath url))
- ;; mastodon:
- (string-remove-suffix (concat "/@" username)
- url))))
- (response (mastodon-http--get-json
- (if user
- (mastodon-http--api "instance")
- (concat instance "/api/v1/instance"))
- nil ; params
- nil ; silent
- :vector)))
- (mastodon-tl--instance-response-fun response brief instance)))))
-
-(defun mastodon-tl--instance-response-fun (response brief instance)
- "Display instance description RESPONSE in a new buffer.
-BRIEF means to show fewer details."
- (when response
- (let* ((domain (url-file-nondirectory instance))
- (buf (get-buffer-create
- (format "*mastodon-instance-%s*" domain))))
- (with-current-buffer buf
- (switch-to-buffer-other-window buf)
- (let ((inhibit-read-only t))
- (erase-buffer)
- (special-mode)
- (when brief
- (setq response
- (list (assoc 'uri response)
- (assoc 'title response)
- (assoc 'short_description response)
- (assoc 'email response)
- (cons 'contact_account
- (list
- (assoc 'username
- (assoc 'contact_account response))))
- (assoc 'rules response)
- (assoc 'stats response))))
- (mastodon-tl--print-json-keys response)
- (mastodon-mode)
- (mastodon-tl--set-buffer-spec (buffer-name buf)
- "instance"
- nil)
- (goto-char (point-min)))))))
-
-(defun mastodon-tl--format-key (el pad)
- "Format a key of element EL, a cons, with PAD padding."
- (format (concat "%-"
- (number-to-string pad)
- "s: ")
- (propertize
- (prin1-to-string (car el))
- 'face '(:underline t))))
-
-(defun mastodon-tl--print-json-keys (response &optional ind)
- "Print the JSON keys and values in RESPONSE.
-IND is the optional indentation level to print at."
- (let* ((cars (mapcar
- (lambda (x) (symbol-name (car x)))
- response))
- (pad (1+ (cl-reduce #'max (mapcar #'length cars)))))
- (while response
- (let ((el (pop response)))
- (cond
- ;; vector of alists (fields, instance rules):
- ((and (vectorp (cdr el))
- (not (seq-empty-p (cdr el)))
- (consp (seq-elt (cdr el) 0)))
- (insert
- (mastodon-tl--format-key el pad)
- "\n\n")
- (seq-do #'mastodon-tl--print-instance-rules-or-fields (cdr el))
- (insert "\n"))
- ;; vector of strings (media types):
- ((and (vectorp (cdr el))
- (not (seq-empty-p (cdr el)))
- (< 1 (seq-length (cdr el)))
- (stringp (seq-elt (cdr el) 0)))
- (when ind (indent-to ind))
- (insert
- (mastodon-tl--format-key el pad)
- "\n"
- (seq-mapcat
- (lambda (x) (concat x ", "))
- (cdr el) 'string)
- "\n\n"))
- ;; basic nesting:
- ((consp (cdr el))
- (when ind (indent-to ind))
- (insert
- (mastodon-tl--format-key el pad)
- "\n\n")
- (mastodon-tl--print-json-keys
- (cdr el) (if ind (+ ind 4) 4)))
- (t
- ;; basic handling of raw booleans:
- (let ((val (cond ((equal (cdr el) ':json-false)
- "no")
- ((equal (cdr el) 't)
- "yes")
- (t
- (cdr el)))))
- (when ind (indent-to ind))
- (insert (mastodon-tl--format-key el pad)
- " "
- (mastodon-tl--newline-if-long (cdr el))
- ;; only send strings straight to --render-text
- ;; this makes hyperlinks work:
- (if (not (stringp val))
- (mastodon-tl--render-text
- (prin1-to-string val))
- (mastodon-tl--render-text val))
- "\n"))))))))
-
-(defun mastodon-tl--print-instance-rules-or-fields (alist)
- "Print ALIST of instance rules or contact account or emoji fields."
- (let ((key (cond ((alist-get 'id alist)
- 'id)
- ((alist-get 'name alist)
- 'name)
- ((alist-get 'shortcode alist)
- 'shortcode)))
- (value (cond ((alist-get 'id alist)
- 'text)
- ((alist-get 'value alist)
- 'value)
- ((alist-get 'url alist)
- 'url))))
- (indent-to 4)
- (insert
- (format "%-5s: "
- (propertize (alist-get key alist)
- 'face '(:underline t)))
- (mastodon-tl--newline-if-long (alist-get value alist))
- (format "%s" (mastodon-tl--render-text
- (alist-get value alist)))
- "\n")))
-
-(defun mastodon-tl--newline-if-long (el)
- "Return a newline string if the cdr of EL is over 50 characters long."
- (let ((rend (if (stringp el) (mastodon-tl--render-text el) el)))
- (if (and (sequencep rend)
- (< 50 (length rend)))
- "\n"
- "")))
-
-
;;; FOLLOW/BLOCK/MUTE, ETC
(defmacro mastodon-tl--do-if-toot (&rest body)