diff options
author | marty hiatt <martianhiatus [a t] riseup [d o t] net> | 2023-03-18 18:22:48 +0100 |
---|---|---|
committer | marty hiatt <martianhiatus [a t] riseup [d o t] net> | 2023-03-18 18:22:48 +0100 |
commit | 7fd37350a8a565a71b326462ff5026f729310b67 (patch) | |
tree | 608df5c686447e846265ab91317d41892bc7cf00 /lisp/mastodon-tl.el | |
parent | 9c449bd25d196a9545cbe22ba664a35a6df98224 (diff) | |
parent | dc1149ae594f44944d6807001dd2765ff1766d71 (diff) |
Merge branch 'views' into develop
Diffstat (limited to 'lisp/mastodon-tl.el')
-rw-r--r-- | lisp/mastodon-tl.el | 749 |
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) |