From: Andreas Gerler Date: Sun, 22 Dec 2024 12:49:27 +0000 (+0100) Subject: add mastodon X-Git-Url: http://git.bundesbrandschatzamt.de/?a=commitdiff_plain;h=685401afcd08db4e0fb23da67b8b11efec456b58;p=emacsconfig.git add mastodon Signed-off-by: Andreas Gerler --- diff --git a/elpa/mastodon-20241202.1839/dir b/elpa/mastodon-20241202.1839/dir new file mode 100644 index 00000000..28d21f79 --- /dev/null +++ b/elpa/mastodon-20241202.1839/dir @@ -0,0 +1,19 @@ +This is the file .../info/dir, which contains the +topmost node of the Info hierarchy, called (dir)Top. +The first time you invoke Info you start off looking at this node. + +File: dir, Node: Top This is the top of the INFO tree + + This (the Directory node) gives a menu of major topics. + Typing "q" exits, "H" lists all Info commands, "d" returns here, + "h" gives a primer for first-timers, + "mEmacs" visits the Emacs manual, etc. + + In Emacs, you can click mouse button 2 on a menu item or cross reference + to select it. + +* Menu: + +Emacs +* Mastodon: (mastodon). Client for fediverse services using the + Mastodon API. diff --git a/elpa/mastodon-20241202.1839/mastodon-async.el b/elpa/mastodon-20241202.1839/mastodon-async.el new file mode 100644 index 00000000..b059407d --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-async.el @@ -0,0 +1,362 @@ +;;; mastodon-async.el --- Async streaming functions for mastodon.el -*- lexical-binding: t -*- + +;; Copyright (C) 2017 Alex J. Griffith +;; Author: Alex J. Griffith +;; Maintainer: Marty Hiatt +;; Package-Requires: ((emacs "27.1")) +;; Homepage: https://codeberg.org/martianh/mastodon.el + +;; This file is not part of GNU Emacs. + +;; This file is part of mastodon.el. + +;; mastodon.el 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. + +;; mastodon.el 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 mastodon.el. If not, see . + +;;; Commentary: + +;; Rework sync code so it does not mess up the async-buffer + +;;; Code: + +(require 'mastodon-tl) +(require 'json) +(require 'url-http) + +(defvar url-http-end-of-headers) + +(autoload 'mastodon-auth--access-token "mastodon-auth") +(autoload 'mastodon-http--api "mastodon-http") +(autoload 'mastodon-http--get-json "mastodon-http") +(autoload 'mastodon-mode "mastodon") +(autoload 'mastodon-notifications--timeline "mastodon-notifications") +(autoload 'mastodon-tl--timeline "mastodon-tl") + +(defgroup mastodon-async nil + "An async module for mastodon streams." + :prefix "mastodon-async-" + :group 'external) + +;;;###autoload +(define-minor-mode mastodon-async-mode + "Async Mastodon." + :lighter " MasA") + +(defvar mastodon-instance-url) + +(defvar mastodon-tl--enable-relative-timestamps) +(defvar mastodon-tl--display-media-p) +(defvar mastodon-tl--buffer-spec) + +(defvar-local mastodon-async--queue "" ;;"*mastodon-async-queue*" + "The intermediate queue buffer name.") + +(defvar-local mastodon-async--buffer "" ;;"*mastodon-async-buffer*" + "User facing output buffer name.") + +(defvar-local mastodon-async--http-buffer "" ;;"" + "Buffer variable bound to http output.") + +(defun mastodon-async--display-http () + "Display the async HTTP input buffer." + (display-buffer mastodon-async--http-buffer)) + +(defun mastodon-async--display-buffer () + "Display the async user facing buffer." + (interactive) + (display-buffer mastodon-async--buffer)) + +(defun mastodon-async--display-queue () + "Display the async queue buffer." + (display-buffer mastodon-async--queue)) + +(defun mastodon-async--stop-http () + "Stop the http processs and close the async and http buffer." + (interactive) + (let ((inhibit-read-only t)) + (stop-process (get-buffer-process mastodon-async--http-buffer)) + (delete-process (get-buffer-process mastodon-async--http-buffer)) + (kill-buffer mastodon-async--http-buffer) + (setq mastodon-async--http-buffer "") + (when (not (string= "" mastodon-async--queue)) ; error handle on kill async buffer + (kill-buffer mastodon-async--queue)))) + +(defun mastodon-async--stream-notifications () + "Open a stream of user notifications." + (interactive) + (mastodon-async--mastodon + "user" + "home" + "notifications" + 'mastodon-async--process-queue-string-notifications)) + +(defun mastodon-async--stream-home () + "Open a stream of the home timeline." + (interactive) + (mastodon-async--mastodon + "user" + "home" + "home" + 'mastodon-async--process-queue-string)) + +(defun mastodon-async--stream-federated () + "Open a stream of Federated." + (interactive) + (mastodon-async--mastodon + "public" + "public" + "federated" + 'mastodon-async--process-queue-string)) + +(defun mastodon-async--stream-local () + "Open a stream of Local." + (interactive) + ;; Need to add another layer of filtering for this to work + ;; apparently it the local flag does not work + (mastodon-async--mastodon + "public" + "public?local=true" + "local" + 'mastodon-async--process-queue-local-string)) + +(defun mastodon-async--mastodon (endpoint timeline name filter) + "Make sure that the previous async process has been closed. +Then start an async stream at ENDPOINT filtering toots +using FILTER. +TIMELINE is a specific target, such as federated or home. +NAME is the center portion of the buffer name for +*mastodon-async-buffer and *mastodon-async-queue." + (ignore timeline) ;; TODO: figure out what this is meant to be used for + (let ((buffer (mastodon-async--start-process + endpoint filter name))) + (with-current-buffer buffer + (mastodon-async--display-buffer) + (goto-char (point-max)) + (goto-char 1)))) + +(defun mastodon-async--get (url callback) + "An async GET request to URL with CALLBACK." + (let ((url-request-method "GET") + (url-request-extra-headers + `(("Authorization" . + ,(concat + "Bearer " + (mastodon-auth--access-token)))))) + (url-retrieve url callback))) + +(defun mastodon-async--set-http-buffer (buffer http-buffer) + "Initialize for BUFFER a local variable `mastodon-async--http-buffer'. +HTTP-BUFFER is the initializing value. Use this funcion if HTTP-BUFFER +is not known when `mastodon-async--setup-buffer' is called." + (with-current-buffer (get-buffer-create buffer) + (setq mastodon-async--http-buffer http-buffer))) + +(defun mastodon-async--set-local-variables (buffer + http-buffer + buffer-name + queue-name) + "Set local variables for BUFFER, HTTP-BUFFER, BUFFER-NAME, and QUEUE-NAME." + (with-current-buffer (get-buffer-create buffer) + (let ((value mastodon-instance-url)) + (make-local-variable 'mastodon-instance-url) + (setq-local mastodon-instance-url value)) + (setq mastodon-async--http-buffer http-buffer) + (setq mastodon-async--buffer buffer-name) + (setq mastodon-async--queue queue-name))) + +(defun mastodon-async--setup-http (http-buffer name) + "Add local variables to HTTP-BUFFER. +NAME is used to generate the display buffer and the queue." + (let ((queue-name (concat " *mastodon-async-queue-" name "-" + mastodon-instance-url "*")) + (buffer-name (concat "*mastodon-async-display-" name "-" + mastodon-instance-url "*"))) + (mastodon-async--set-local-variables http-buffer http-buffer + buffer-name queue-name))) + +(defun mastodon-async--setup-queue (http-buffer name) + "Set up HTTP-BUFFER buffer for the async queue. +NAME is used to generate the display buffer and the queue." + (let ((queue-name (concat " *mastodon-async-queue-" name "-" + mastodon-instance-url "*")) + (buffer-name(concat "*mastodon-async-display-" name "-" + mastodon-instance-url "*"))) + (mastodon-async--set-local-variables queue-name http-buffer + buffer-name queue-name) + queue-name)) + +(defun mastodon-async--setup-buffer (http-buffer name endpoint) + "Set up the buffer timeline like `mastodon-tl--init'. +HTTP-BUFFER the name of the http-buffer, if unknown, set to... +NAME is the name of the stream for the buffer name. +ENDPOINT is the endpoint for the stream and timeline." + (let ((queue-name (concat " *mastodon-async-queue-" name "-" + mastodon-instance-url "*")) + (buffer-name (concat "*mastodon-async-display-" name "-" + mastodon-instance-url "*")) + ;; if user stream, we need "timelines/home" not "timelines/user" + ;; if notifs, we need "notifications" not "timelines/notifications" + (endpoint (cond + ((string= name "notifications") "notifications") + ((string= name "home") "timelines/home") + (t (format "timelines/%s" endpoint))))) + (mastodon-async--set-local-variables buffer-name http-buffer + buffer-name queue-name) + ;; Similar to timeline init. + (with-current-buffer (get-buffer-create buffer-name) + (setq inhibit-read-only t) ; for home timeline? + (make-local-variable 'mastodon-tl--enable-relative-timestamps) + (make-local-variable 'mastodon-tl--display-media-p) + (message (mastodon-http--api endpoint)) + (if (string= name "notifications") + (mastodon-notifications--timeline + (mastodon-http--get-json + (mastodon-http--api "notifications"))) + (mastodon-tl--timeline (mastodon-http--get-json + (mastodon-http--api endpoint)))) + (mastodon-mode) + (mastodon-tl--set-buffer-spec buffer-name + endpoint + (if (string= name "notifications") + 'mastodon-notifications--timeline + 'mastodon-tl--timeline)) + (setq-local mastodon-tl--enable-relative-timestamps nil) + (setq-local mastodon-tl--display-media-p t) + (current-buffer)))) + +(defun mastodon-async--start-process (endpoint filter &optional name) + "Start an async mastodon stream at ENDPOINT. +Filter the toots using FILTER. +NAME is used for the queue and display buffer." + (let* ((stream (concat "streaming/" endpoint)) + (async-queue (mastodon-async--setup-queue "" (or name stream))) + (async-buffer (mastodon-async--setup-buffer "" (or name stream) endpoint)) + (http-buffer (mastodon-async--get + (mastodon-http--api stream) + (lambda (status) + (ignore status) + (message "HTTP SOURCE CLOSED"))))) + (mastodon-async--setup-http http-buffer (or name stream)) + (mastodon-async--set-http-buffer async-buffer http-buffer) + (mastodon-async--set-http-buffer async-queue http-buffer) + (set-process-filter (get-buffer-process http-buffer) + (mastodon-async--http-hook filter)) + http-buffer)) + +(defun mastodon-async--http-hook (filter) + "Return a lambda with a custom FILTER for processing toots." + (let ((filter filter)) + (lambda (proc data) + (with-current-buffer (process-buffer proc) + (let* ((string + (mastodon-async--stream-filter + (mastodon-async--http-layer proc data))) + (queue-string (mastodon-async--cycle-queue string))) + (when queue-string + (mastodon-async--output-toot + (funcall filter queue-string)))))))) + +(defun mastodon-async--process-queue-string (string) + "Parse the output STRING of the queue buffer, returning only update events." + (let ((split-strings (split-string string "\n" t))) + (when split-strings ; do nothing if we get nothing; just postpones the error + (let ((event-type (replace-regexp-in-string + "^event: " "" + (car split-strings))) + (data (replace-regexp-in-string + "^data: " "" (cadr split-strings)))) + (when (string= "update" event-type) + ;; in some casses the data is not fully formed + ;; for now return nil if malformed using `ignore-errors' + (ignore-errors (json-read-from-string data))))))) + +(defun mastodon-async--process-queue-string-notifications (string) + "Parse the output STRING of the queue buffer, returning only notification events." + ;; NB notification events in streams include follow requests + (let* ((split-strings (split-string string "\n" t)) + (event-type (replace-regexp-in-string + "^event: " "" + (car split-strings))) + (data (replace-regexp-in-string + "^data: " "" (cadr split-strings)))) + (when (string= "notification" event-type) + ;; in some casses the data is not fully formed + ;; for now return nil if malformed using `ignore-errors' + (ignore-errors (json-read-from-string data))))) + +(defun mastodon-async--process-queue-local-string (string) + "Use STRING to limit the public endpoint to displaying local steams only." + (let ((json (mastodon-async--process-queue-string string))) + (when json + (when (mastodon-async--account-local-p json) + json)))) + +(defun mastodon-async--account-local-p (json) + "Test JSON to see if account is local." + (not (string-match-p + "@" + (alist-get 'acct (alist-get 'account json))))) + +(defun mastodon-async--output-toot (toot) + "Process TOOT and prepend it to the async user-facing buffer." + (if (not (bufferp (get-buffer mastodon-async--buffer))) + (mastodon-async--stop-http) + (when toot + (with-current-buffer mastodon-async--buffer + (let* ((inhibit-read-only t) + (old-max (point-max)) + (previous (point)) + (mastodon-tl--enable-relative-timestamps t) + (mastodon-tl--display-media-p t)) + (goto-char (point-min)) + (if (equal (buffer-name) + (concat "*mastodon-async-display-notifications-" + mastodon-instance-url "*")) + (mastodon-notifications--timeline (list toot)) + (mastodon-tl--timeline (list toot))) + (if (eq previous 1) + (goto-char 1) + (goto-char (+ previous (- (point-max) old-max))))))))) + +(defun mastodon-async--cycle-queue (string) + "Append the most recent STRING from http buffer to queue buffer. +Then determine if a full message has been recived. If so return it. +Full messages are seperated by two newlines" + (with-current-buffer mastodon-async--queue + (goto-char (max-char)) + (insert (decode-coding-string string 'utf-8)) + (goto-char 0) + (let ((next (re-search-forward "\n\n" nil t))) + (when next + (let ((return-string (buffer-substring 1 next)) + (inhibit-read-only t)) + (delete-region 1 next) + return-string))))) + +(defun mastodon-async--http-layer (proc data) + "Passes PROC and DATA to ‘url-http-generic-filter’. +It then processes its output." + (with-current-buffer (process-buffer proc) + (let ((start (max 1 (- (point-max) 2)))) + (url-http-generic-filter proc data) + (when (> url-http-end-of-headers start) + (setq start url-http-end-of-headers)) + (let ((end (- (point-max) 2))) + (buffer-substring start end))))) + +(defun mastodon-async--stream-filter (string) + "Remove comments from STRING." + (replace-regexp-in-string "^:.*\n" "" string)) + +(provide 'mastodon-async) +;;; mastodon-async.el ends here diff --git a/elpa/mastodon-20241202.1839/mastodon-auth.el b/elpa/mastodon-20241202.1839/mastodon-auth.el new file mode 100644 index 00000000..01639fb2 --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-auth.el @@ -0,0 +1,227 @@ +;;; mastodon-auth.el --- Auth functions for mastodon.el -*- lexical-binding: t -*- + +;; Copyright (C) 2017-2019 Johnson Denen +;; Copyright (C) 2021 Abhiseck Paira +;; Author: Johnson Denen +;; Maintainer: Marty Hiatt +;; Homepage: https://codeberg.org/martianh/mastodon.el + +;; This file is not part of GNU Emacs. + +;; This file is part of mastodon.el. + +;; mastodon.el 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. + +;; mastodon.el 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 mastodon.el. If not, see . + +;;; Commentary: + +;; mastodon-auth.el supports authorizing and authenticating with Mastodon. + +;;; Code: + +(require 'plstore) +(require 'auth-source) +(require 'json) +(eval-when-compile (require 'subr-x)) ; for if-let + +(autoload 'mastodon-client "mastodon-client") +(autoload 'mastodon-client--active-user "mastodon-client") +(autoload 'mastodon-client--form-user-from-vars "mastodon-client") +(autoload 'mastodon-client--make-user-active "mastodon-client") +(autoload 'mastodon-client--store-access-token "mastodon-client") +(autoload 'mastodon-http--api "mastodon-http") +(autoload 'mastodon-http--concat-params-to-url "mastodon-http") +(autoload 'mastodon-http--get-json "mastodon-http") +(autoload 'mastodon-http--post "mastodon-http") +(autoload 'mastodon-return-credential-account "mastodon") + +(defvar mastodon-instance-url) +(defvar mastodon-client-scopes) +(defvar mastodon-client-redirect-uri) +(defvar mastodon-active-user) + +(defgroup mastodon-auth nil + "Authenticate with Mastodon." + :prefix "mastodon-auth-" + :group 'mastodon) + +(defvar mastodon-auth-source-file nil + "This variable is obsolete. +This variable currently serves no purpose and will be removed in +the future.") + +(defvar mastodon-auth--token-alist nil + "Alist of User access tokens keyed by instance url.") + +(defvar mastodon-auth--acct-alist nil + "Alist of account accts (name@domain) keyed by instance url.") + +(defvar mastodon-auth--user-unaware + " ** MASTODON.EL - NOTICE ** + +It appears that you are not aware of the recent developments in +mastodon.el. In short we now require that you also set the +variable `mastodon-active-user' in your init file in addition to +`mastodon-instance-url'. + +Please see its documentation to understand what value it accepts +by running M-x describe-variable on it or visiting our web page: +https://codeberg.org/martianh/mastodon.el + +We apologize for the inconvenience. +") + +(defun mastodon-auth--get-browser-login-url () + "Return properly formed browser login url." + (mastodon-http--concat-params-to-url + (concat mastodon-instance-url "/oauth/authorize/") + `(("response_type" . "code") + ("redirect_uri" . ,mastodon-client-redirect-uri) + ("scope" . ,mastodon-client-scopes) + ("client_id" . ,(plist-get (mastodon-client) :client_id))))) + +(defvar mastodon-auth--explanation + (format + " +1. A URL has been copied to your clipboard. Open this URL in a +javascript capable browser and your browser will take you to your +Mastodon instance's login page. + +2. Login to your account (%s) and authorize \"mastodon.el\". + +3. After authorization you will be presented an authorization +code. Copy this code and paste it in the minibuffer prompt." + (mastodon-client--form-user-from-vars))) + +(defun mastodon-auth--show-notice (notice buffer-name &optional ask) + "Display NOTICE to user. +By default NOTICE is displayed in vertical split occupying 50% of total +width. The buffer name of the buffer being displayed in the +window is BUFFER-NAME. +When optional argument ASK is given which should be a string, use +ASK as the minibuffer prompt. Return whatever user types in +response to the prompt. +When ASK is absent return nil." + (let ((buffer (get-buffer-create buffer-name)) + (inhibit-read-only t) + ask-value window) + (set-buffer buffer) + (erase-buffer) + (insert notice) + (fill-region (point-min) (point-max)) + (read-only-mode) + + (setq window (select-window + (split-window (frame-root-window) nil 'below) + t)) + (switch-to-buffer buffer t) + (when ask + (setq ask-value (read-string ask)) + (kill-buffer buffer) + (delete-window window)) + ask-value)) + +(defun mastodon-auth--request-authorization-code () + "Ask authorization code and return it." + (let ((url (mastodon-auth--get-browser-login-url)) + (select-enable-clipboard t) + authorization-code) + (kill-new url) + (message "%s" url) + (setq authorization-code + (mastodon-auth--show-notice mastodon-auth--explanation + "*mastodon-notice*" + "Authorization Code: ")) + authorization-code)) + +(defun mastodon-auth--generate-token () + "Generate access_token for the user. Return response buffer." + (let ((authorization-code (mastodon-auth--request-authorization-code))) + (mastodon-http--post + (concat mastodon-instance-url "/oauth/token") + `(("grant_type" . "authorization_code") + ("client_secret" . ,(plist-get (mastodon-client) :client_secret)) + ("client_id" . ,(plist-get (mastodon-client) :client_id)) + ("code" . ,authorization-code) + ("redirect_uri" . ,mastodon-client-redirect-uri)) + nil + :unauthenticated))) + +(defun mastodon-auth--get-token () + "Make a request to generate an auth token and return JSON response." + (with-current-buffer (mastodon-auth--generate-token) + (goto-char (point-min)) + (re-search-forward "^$" nil 'move) + (let ((json-object-type 'plist) + (json-key-type 'keyword) + (json-array-type 'vector) + (json-string (buffer-substring-no-properties (point) (point-max)))) + (json-read-from-string json-string)))) + +(defun mastodon-auth--access-token () + "Return the access token to use with `mastodon-instance-url'. +Generate/save token if none known yet." + (cond (mastodon-auth--token-alist + ;; user variables are known and initialised. + (alist-get mastodon-instance-url mastodon-auth--token-alist nil nil #'string=)) + ((plist-get (mastodon-client--active-user) :access_token) + ;; user variables need to be read from plstore. + (push (cons mastodon-instance-url + (plist-get (mastodon-client--active-user) :access_token)) + mastodon-auth--token-alist) + (alist-get mastodon-instance-url mastodon-auth--token-alist nil nil #'string=)) + ((null mastodon-active-user) + ;; user not aware of 2FA-related changes and has not set + ;; `mastodon-active-user'. Make user aware and error out. + (mastodon-auth--show-notice mastodon-auth--user-unaware + "*mastodon-notice*") + (error "Variables not set properly")) + (t + ;; user access-token needs to fetched from the server and + ;; stored and variables initialised. + (mastodon-auth--handle-token-response (mastodon-auth--get-token))))) + +(defun mastodon-auth--handle-token-response (response) + "Add token RESPONSE to `mastodon-auth--token-alist'. +The token is returned by `mastodon-auth--get-token'. +Handle any errors from the server." + (pcase response + ((and (let token (plist-get response :access_token)) + (guard token)) + (mastodon-client--make-user-active + (mastodon-client--store-access-token token)) + (cdar (push (cons mastodon-instance-url token) + mastodon-auth--token-alist))) + (`(:error ,class :error_description ,error) + (error "Mastodon-auth--access-token: %s: %s" class error)) + (_ (error "Unknown response from mastodon-auth--get-token!")))) + +(defun mastodon-auth--get-account-name () + "Request user credentials and return an account name." + (alist-get 'acct + (mastodon-return-credential-account))) + +(defun mastodon-auth--get-account-id () + "Request user credentials and return an account name." + (alist-get 'id + (mastodon-return-credential-account))) + +(defun mastodon-auth--user-acct () + "Return a mastodon user acct name." + (or (cdr (assoc mastodon-instance-url mastodon-auth--acct-alist)) + (let ((acct (mastodon-auth--get-account-name))) + (push (cons mastodon-instance-url acct) mastodon-auth--acct-alist) + acct))) + +(provide 'mastodon-auth) +;;; mastodon-auth.el ends here diff --git a/elpa/mastodon-20241202.1839/mastodon-autoloads.el b/elpa/mastodon-20241202.1839/mastodon-autoloads.el new file mode 100644 index 00000000..4108b8e2 --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-autoloads.el @@ -0,0 +1,155 @@ +;;; mastodon-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*- +;; Generated by the `loaddefs-generate' function. + +;; This file is part of GNU Emacs. + +;;; Code: + +(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path))) + + + +;;; Generated autoloads from mastodon.el + +(autoload 'mastodon "mastodon" "\ +Connect client to `mastodon-instance-url' instance. +If there are any open mastodon.el buffers, switch to one instead. +Prority in switching is given to timeline views." t) +(autoload 'mastodon-toot "mastodon" "\ +Update instance with new toot. Content is captured in a new buffer. +If USER is non-nil, insert after @ symbol to begin new toot. +If REPLY-TO-ID is non-nil, attach new toot to a conversation. +If REPLY-JSON is the json of the toot being replied to. + +(fn &optional USER REPLY-TO-ID REPLY-JSON)" t) +(autoload 'mastodon-notifications-get "mastodon" "\ +Display NOTIFICATIONS in buffer. +Optionally only print notifications of type TYPE, a string. +BUFFER-NAME is added to \"*mastodon-\" to create the buffer name. +MAX-ID is a request parameter for pagination. + +(fn &optional TYPE BUFFER-NAME MAX-ID)" t) +(autoload 'mastodon-url-lookup "mastodon" "\ +If a URL resembles a fediverse link, try to load in `mastodon.el'. +Does a WebFinger lookup on the server. +URL can be arg QUERY-URL, or URL at point, or provided by the user. +If a status or account is found, load it in `mastodon.el', if +not, just browse the URL in the normal fashion. +If FORCE, do a lookup regardless of the result of `mastodon--fedi-url-p'. + +(fn &optional QUERY-URL FORCE)" t) +(add-hook 'mastodon-mode-hook #'mastodon-mode-hook-fun) +(register-definition-prefixes "mastodon" '("mastodon-")) + + +;;; Generated autoloads from mastodon-async.el + +(autoload 'mastodon-async-mode "mastodon-async" "\ +Async Mastodon. + +This is a minor mode. If called interactively, toggle the +`Mastodon-Async mode' mode. If the prefix argument is positive, enable +the mode, and if it is zero or negative, disable the mode. + +If called from Lisp, toggle the mode if ARG is `toggle'. Enable the +mode if ARG is nil, omitted, or is a positive number. Disable the mode +if ARG is a negative number. + +To check whether the minor mode is enabled in the current buffer, +evaluate the variable `mastodon-async-mode'. + +The mode's hook is called both when the mode is enabled and when it is +disabled. + +(fn &optional ARG)" t) +(register-definition-prefixes "mastodon-async" '("mastodon-async--")) + + +;;; Generated autoloads from mastodon-auth.el + +(register-definition-prefixes "mastodon-auth" '("mastodon-auth-")) + + +;;; Generated autoloads from mastodon-client.el + +(register-definition-prefixes "mastodon-client" '("mastodon-client")) + + +;;; Generated autoloads from mastodon-discover.el + +(register-definition-prefixes "mastodon-discover" '("mastodon-discover")) + + +;;; Generated autoloads from mastodon-http.el + +(register-definition-prefixes "mastodon-http" '("mastodon-http--")) + + +;;; Generated autoloads from mastodon-inspect.el + +(register-definition-prefixes "mastodon-inspect" '("mastodon-inspect--")) + + +;;; Generated autoloads from mastodon-iso.el + +(register-definition-prefixes "mastodon-iso" '("mastodon-iso-639-")) + + +;;; Generated autoloads from mastodon-media.el + +(register-definition-prefixes "mastodon-media" '("mastodon-media--")) + + +;;; Generated autoloads from mastodon-notifications.el + +(register-definition-prefixes "mastodon-notifications" '("mastodon-notifications-")) + + +;;; Generated autoloads from mastodon-profile.el + +(register-definition-prefixes "mastodon-profile" '("mastodon-profile-")) + + +;;; Generated autoloads from mastodon-search.el + +(register-definition-prefixes "mastodon-search" '("mastodon-search-")) + + +;;; Generated autoloads from mastodon-tl.el + +(register-definition-prefixes "mastodon-tl" '("mastodon-tl-" "with-mastodon-buffer")) + + +;;; Generated autoloads from mastodon-toot.el + +(add-hook 'mastodon-toot-mode-hook #'mastodon-profile--fetch-server-account-settings-maybe) +(register-definition-prefixes "mastodon-toot" '("mastodon-t")) + + +;;; Generated autoloads from mastodon-transient.el + +(register-definition-prefixes "mastodon-transient" '("mastodon-transient-")) + + +;;; Generated autoloads from mastodon-views.el + +(register-definition-prefixes "mastodon-views" '("mastodon-views-")) + + +;;; Generated autoloads from mastodon-widget.el + +(register-definition-prefixes "mastodon-widget" '("mastodon-widget-")) + +;;; End of scraped data + +(provide 'mastodon-autoloads) + +;; Local Variables: +;; version-control: never +;; no-byte-compile: t +;; no-update-autoloads: t +;; no-native-compile: t +;; coding: utf-8-emacs-unix +;; End: + +;;; mastodon-autoloads.el ends here diff --git a/elpa/mastodon-20241202.1839/mastodon-client.el b/elpa/mastodon-20241202.1839/mastodon-client.el new file mode 100644 index 00000000..c0db3d61 --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-client.el @@ -0,0 +1,208 @@ +;;; mastodon-client.el --- Client functions for mastodon.el -*- lexical-binding: t -*- + +;; Copyright (C) 2017-2019 Johnson Denen +;; Copyright (C) 2021 Abhiseck Paira +;; Author: Johnson Denen +;; Maintainer: Marty Hiatt +;; Homepage: https://codeberg.org/martianh/mastodon.el + +;; This file is not part of GNU Emacs. + +;; This file is part of mastodon.el. + +;; mastodon.el 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. + +;; mastodon.el 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 mastodon.el. If not, see . + +;;; Commentary: + +;; mastodon-client.el supports registering the Emacs client with your Mastodon instance. + +;;; Code: + +(require 'plstore) +(require 'json) +(require 'url) + +(defvar mastodon-instance-url) +(defvar mastodon-active-user) + +(autoload 'mastodon-http--api "mastodon-http") +(autoload 'mastodon-http--post "mastodon-http") + +(defcustom mastodon-client--token-file (concat user-emacs-directory "mastodon.plstore") + "File path where Mastodon access tokens are stored." + :group 'mastodon + :type 'file) + +(defvar mastodon-client--client-details-alist nil + "An alist of Client id and secrets keyed by the instance url.") + +(defvar mastodon-client--active-user-details-plist nil + "A plist of active user details.") + +(defvar mastodon-client-scopes "read write follow" + "Scopes to pass to oauth during registration.") + +(defvar mastodon-client-website "https://codeberg.org/martianh/mastodon.el" + "Website of mastodon.el.") + +(defvar mastodon-client-redirect-uri "urn:ietf:wg:oauth:2.0:oob" + "Redirect_uri as required by oauth.") + +(defun mastodon-client--register () + "POST client to Mastodon." + (mastodon-http--post (mastodon-http--api "apps") + `(("client_name" . "mastodon.el") + ("redirect_uris" . ,mastodon-client-redirect-uri) + ("scopes" . ,mastodon-client-scopes) + ("website" . ,mastodon-client-website)) + nil + :unauthenticated)) + +(defun mastodon-client--fetch () + "Return JSON from `mastodon-client--register' call." + (with-current-buffer (mastodon-client--register) + (goto-char (point-min)) + (re-search-forward "^$" nil 'move) + (let ((json-object-type 'plist) + (json-key-type 'keyword) + (json-array-type 'vector) + (json-string (buffer-substring-no-properties (point) (point-max)))) + (json-read-from-string json-string)))) + +(defun mastodon-client--token-file () + "Return `mastodon-client--token-file'." + mastodon-client--token-file) + +(defun mastodon-client--store () + "Store client_id and client_secret in `mastodon-client--token-file'. + +Make `mastodon-client--fetch' call to determine client values." + (let ((plstore (plstore-open (mastodon-client--token-file))) + (client (mastodon-client--fetch)) + ;; alexgriffith reported seeing ellipses in the saved output + ;; which indicate some output truncating. Nothing in `plstore-save' + ;; seems to ensure this cannot happen so let's do that ourselves: + (print-length nil) + (print-level nil)) + (plstore-put plstore (concat "mastodon-" mastodon-instance-url) client nil) + (plstore-save plstore) + (plstore-close plstore) + client)) + +(defun mastodon-client--remove-key-from-plstore (plstore) + "Remove KEY from PLSTORE." + (cdr plstore)) + +;; Actually it returns a plist with client-details if such details are +;; already stored in mastodon.plstore +(defun mastodon-client--read () + "Retrieve client_id and client_secret from `mastodon-client--token-file'." + (let* ((plstore (plstore-open (mastodon-client--token-file))) + (mastodon (plstore-get plstore (concat "mastodon-" mastodon-instance-url)))) + (mastodon-client--remove-key-from-plstore mastodon))) + +(defun mastodon-client--general-read (key) + "Retrieve the plstore item keyed by KEY. +Return plist without the KEY." + (let* ((plstore (plstore-open (mastodon-client--token-file))) + (plstore-item (plstore-get plstore key))) + (mastodon-client--remove-key-from-plstore plstore-item))) + +(defun mastodon-client--make-user-details-plist () + "Make a plist with current user details. Return it." + `(:username ,(mastodon-client--form-user-from-vars) + :instance ,mastodon-instance-url + :client_id ,(plist-get (mastodon-client) :client_id) + :client_secret ,(plist-get (mastodon-client) :client_secret))) + +(defun mastodon-client--store-access-token (token) + "Save TOKEN as :access_token in plstore of the current user. +Return the plist after the operation." + (let* ((user-details (mastodon-client--make-user-details-plist)) + (plstore (plstore-open (mastodon-client--token-file))) + (username (plist-get user-details :username)) + (plstore-value (setq user-details + (plist-put user-details :access_token token))) + (print-length nil) + (print-level nil)) + (plstore-put plstore (concat "user-" username) plstore-value nil) + (plstore-save plstore) + (plstore-close plstore) + plstore-value)) + +(defun mastodon-client--make-user-active (user-details) + "USER-DETAILS is a plist consisting of user details." + (let ((plstore (plstore-open (mastodon-client--token-file))) + (print-length nil) + (print-level nil)) + (plstore-put plstore "active-user" user-details nil) + (plstore-save plstore) + (plstore-close plstore))) + +(defun mastodon-client--form-user-from-vars () + "Create a username from user variable. Return that username. +Username in the form user@instance.com is formed from the +variables `mastodon-instance-url' and `mastodon-active-user'." + (concat mastodon-active-user + "@" + (url-host (url-generic-parse-url mastodon-instance-url)))) + +(defun mastodon-client--make-current-user-active () + "Make the user specified by user variables active user. +Return the details (plist)." + (let ((username (mastodon-client--form-user-from-vars)) + user-plist) + (when (setq user-plist + (mastodon-client--general-read (concat "user-" username))) + (mastodon-client--make-user-active user-plist)) + user-plist)) + +(defun mastodon-client--current-user-active-p () + "Return user-details if the current user is active. +Otherwise return nil." + (let ((username (mastodon-client--form-user-from-vars)) + (user-details (mastodon-client--general-read "active-user"))) + (when (and user-details + (string= (plist-get user-details :username) username)) + user-details))) + +(defun mastodon-client--active-user () + "Return the details of the currently active user. +Details is a plist." + (let ((active-user-details mastodon-client--active-user-details-plist)) + (unless active-user-details + (setq active-user-details + (or (mastodon-client--current-user-active-p) + (mastodon-client--make-current-user-active))) + (setq mastodon-client--active-user-details-plist + active-user-details)) + active-user-details)) + +(defun mastodon-client () + "Return variable client secrets to use for `mastodon-instance-url'. +Read plist from `mastodon-client--token-file' if variable is nil. +Fetch and store plist if `mastodon-client--read' returns nil." + (let ((client-details + (cdr (assoc mastodon-instance-url mastodon-client--client-details-alist)))) + (unless client-details + (setq client-details + (or (mastodon-client--read) + (mastodon-client--store))) + (push (cons mastodon-instance-url client-details) + mastodon-client--client-details-alist)) + client-details)) + +(provide 'mastodon-client) +;;; mastodon-client.el ends here + diff --git a/elpa/mastodon-20241202.1839/mastodon-discover.el b/elpa/mastodon-20241202.1839/mastodon-discover.el new file mode 100644 index 00000000..993cc275 --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-discover.el @@ -0,0 +1,125 @@ +;;; mastodon-discover.el --- Use Mastodon.el with discover.el -*- lexical-binding: t -*- + +;; Copyright (C) 2019 Johnson Denen +;; Copyright (C) 2020-2024 Marty Hiatt +;; Author: Johnson Denen +;; Marty Hiatt +;; Maintainer: Marty Hiatt +;; Homepage: https://codeberg.org/martianh/mastodon.el + +;; This file is not part of GNU Emacs. + +;; This file is part of mastodon.el. + +;; mastodon.el 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. + +;; mastodon.el 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 mastodon.el. If not, see . + +;;; Commentary: + +;; This adds optional functionality that can be used if the dicover package +;; is present. +;; +;; See the README file for how to use this. + +;;; Code: + +(declare-function discover-add-context-menu "discover") + +(autoload 'mastodon-kill-window "mastodon") + +(defun mastodon-discover () + "Plug Mastodon functionality into `discover'." + (interactive) + (when (require 'discover nil :noerror) + (discover-add-context-menu + :bind "?" + :mode 'mastodon-mode + :mode-hook 'mastodon-mode-hook + :context-menu + '(mastodon + (description "Mastodon feed viewer") + (actions + ("Toots" + ("A" "View profile of author" mastodon-profile--get-toot-author) + ("b" "Boost" mastodon-toot--boost) + ("f" "Favourite" mastodon-toot--favourite) + ("c" "Toggle hidden text (CW)" mastodon-tl--toggle-spoiler-text-in-toot) + ("k" "Bookmark toot" mastodon-toot--toggle-bookmark) + ("v" "Vote on poll" mastodon-tl--poll-vote) + ("n" "Next" mastodon-tl--goto-next-item) + ("p" "Prev" mastodon-tl--goto-prev-item) + ("TAB" "Next link item" mastodon-tl--next-tab-item) + ("S-TAB" "Prev link item" mastodon-tl--previous-tab-item) + ;; NB: (when (require 'mpv etc. calls don't work here + ("C-RET" "Play media" mastodon-tl--mpv-play-video-at-point) + ("t" "New toot" mastodon-toot) + ("r" "Reply" mastodon-toot--reply) + ("C" "Copy toot URL" mastodon-toot--copy-toot-url) + ("o" "Open toot URL" mastodon-toot--open-toot-url) + ("d" "Delete (your) toot" mastodon-toot--delete-toot) + ("D" "Delete and redraft (your) toot" mastodon-toot--delete-toot) + ("e" "Edit (your) toot" mastodon-toot--edit-toot-at-point) + ("E" "View edits of (your) toot" mastodon-toot--view-toot-edits) + ("i" "Pin/Unpin (your) toot" mastodon-toot--pin-toot-toggle) + ("P" "View user profile" mastodon-profile--show-user) + ("a" "Translate toot at point" mastodon-toot--translate-toot-text) + ("T" "View thread" mastodon-tl--thread) + ("v" "Vote on poll" mastodon-tl--poll-vote) + ("," "View toot's favouriters" mastodon-toot--list-toot-favouriters) + ("." "View toot's boosters" mastodon-toot--list-toot-boosters) + ("/" "Switch buffers" mastodon-switch-to-buffer)) + ("Views" + ("h/?" "View mode help/keybindings" describe-mode) + ("#" "Tag search" mastodon-tl--get-tag-timeline) + ("\"" "List followed tags" mastodon-tl--list-followed-tags) + ("'" "Followed tags timeline" mastodon-tl--followed-tags-timeline) + ("F" "Federated" mastodon-tl--get-federated-timeline) + ("H" "Home" mastodon-tl--get-home-timeline) + ("L" "Local" mastodon-tl--get-local-timeline) + ("N" "Notifications" mastodon-notifications-get) + ("@" "Notifications with mentions" mastodon-notifications--get-mentions) + ("g/u" "Update timeline" mastodon-tl--update) + ("s" "Search" mastodon-search--query) + ("O" "Jump to your profile" mastodon-profile--my-profile) + ("U" "Update your profile note" mastodon-profile--update-user-profile-note) + ("K" "View bookmarks" mastodon-profile--view-bookmarks) + ("V" "View favourites" mastodon-profile--view-favourites) + ("R" "View follow requests" mastodon-profile--view-follow-requests) + ("G" "View follow suggestions" mastodon-tl--get-follow-suggestions) + ("I" "View filters" mastodon-tl--view-filters) + ("X" "View lists" mastodon-tl--view-lists) + ("S" "View scheduled toots" mastodon-tl--view-scheduled-toots) + (";" "View instance description" mastodon-tl--view-instance-description)) + ("Users" + ("W" "Follow" mastodon-tl--follow-user) + ("C-S-W" "Unfollow" mastodon-tl--unfollow-user) + ("M" "Mute" mastodon-tl--mute-user) + ("C-S-M" "Unmute" mastodon-tl--unmute-user) + ("B" "Block" mastodon-tl--block-user) + ("C-S-B" "Unblock" mastodon-tl--unblock-user)) + ("Images" + ;; RET errors here also :/ + ("/i" "Load full image in browser" 'shr-browse-image) + ("r" "rotate" 'image-rotate) + ("+" "zoom in" 'image-increase-size) + ("-" "zoom out" 'image-decrease-size) + ("u" "copy URL" 'shr-maybe-probe-and-copy-url)) + ("Profile view" + ("C-c C-c" "Cycle profile views" mastodon-profile--account-view-cycle)) + ("Quit" + ("q" "Quit mastodon and bury buffer." kill-this-buffer) + ("Q" "Quit mastodon buffer and kill window." mastodon--kill-window) + ("M-C-q" "Quit mastodon and kill all buffers." mastodon-kill-all-buffers))))))) + +(provide 'mastodon-discover) +;;; mastodon-discover.el ends here diff --git a/elpa/mastodon-20241202.1839/mastodon-http.el b/elpa/mastodon-20241202.1839/mastodon-http.el new file mode 100644 index 00000000..47b96fed --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-http.el @@ -0,0 +1,426 @@ +;;; mastodon-http.el --- HTTP request/response functions for mastodon.el -*- lexical-binding: t -*- + +;; Copyright (C) 2017-2019 Johnson Denen +;; Copyright (C) 2020-2024 Marty Hiatt +;; Author: Johnson Denen +;; Marty Hiatt +;; Maintainer: Marty Hiatt +;; Homepage: https://codeberg.org/martianh/mastodon.el + +;; This file is not part of GNU Emacs. + +;; This file is part of mastodon.el. + +;; mastodon.el 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. + +;; mastodon.el 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 mastodon.el. If not, see . + +;;; Commentary: + +;; mastodon-http.el provides HTTP request/response functions. + +;;; Code: + +(require 'json) +(require 'request) ; for attachments upload +(require 'url) +(require 'shr) + +(defvar mastodon-instance-url) +(defvar mastodon-toot--media-attachment-ids) +(defvar mastodon-toot--media-attachment-filenames) + +(autoload 'mastodon-auth--access-token "mastodon-auth") +(autoload 'mastodon-toot--update-status-fields "mastodon-toot") + +(defvar mastodon-http--api-version "v1") + +(defconst mastodon-http--timeout 15 + "HTTP request timeout, in seconds. Has no effect on Emacs < 26.1.") + +(defun mastodon-http--api (endpoint &optional version) + "Return Mastodon API URL for ENDPOINT. +Optionally specify VERSION in format vX." + (concat mastodon-instance-url "/api/" + (or version mastodon-http--api-version) "/" endpoint)) + +(defun mastodon-http--api-v2 (endpoint) + "Return Mastodon API v2 URL for ENDPOINT." + (mastodon-http--api endpoint "v2")) + +(defun mastodon-http--response () + "Capture response buffer content as string." + (with-current-buffer (current-buffer) + (buffer-substring-no-properties (point-min) (point-max)))) + +(defun mastodon-http--response-body (pattern) + "Return substring matching PATTERN from `mastodon-http--response'." + (let ((resp (mastodon-http--response))) + (string-match pattern resp) + (match-string 0 resp))) + +(defun mastodon-http--status () + "Return HTTP Response Status Code from `mastodon-http--response'." + (let* ((status-line (mastodon-http--response-body "^HTTP/1.*$"))) + (string-match "[0-9][0-9][0-9]" status-line) + (match-string 0 status-line))) + +(defun mastodon-http--url-retrieve-synchronously (url &optional silent) + "Retrieve URL asynchronously. +This is a thin abstraction over the system +`url-retrieve-synchronously'. Depending on which version of this +is available we will call it with or without a timeout. +SILENT means don't message." + (if (< (cdr (func-arity 'url-retrieve-synchronously)) 4) + (url-retrieve-synchronously url) + (url-retrieve-synchronously url (or silent nil) nil mastodon-http--timeout))) + +(defun mastodon-http--triage (response success) + "Determine if RESPONSE was successful. +Call SUCCESS if successful. Message status and JSON error from +RESPONSE if unsuccessful." + (let ((status (with-current-buffer response + (mastodon-http--status)))) + (if (string-prefix-p "2" status) + (funcall success response) + (if (string-prefix-p "404" status) + (message "Error %s: page not found" status) + (let ((json-response (with-current-buffer response + (mastodon-http--process-json)))) + (message "Error %s: %s" status (alist-get 'error json-response))))))) + +(defun mastodon-http--read-file-as-string (filename &optional url) + "Read a file FILENAME as a string. +Used to generate image preview. +URL means FILENAME is a URL." + (with-temp-buffer + (if url + (url-insert-file-contents filename) + (insert-file-contents filename)) + (string-to-unibyte (buffer-string)))) + +(defmacro mastodon-http--authorized-request (method body &optional unauthenticated-p) + "Make a METHOD type request using BODY, with Mastodon authorization. +Unless UNAUTHENTICATED-P is non-nil." + (declare (debug 'body) + (indent 1)) + `(let ((url-request-method ,method) + (url-request-extra-headers + (unless ,unauthenticated-p + (list (cons "Authorization" + (concat "Bearer " (mastodon-auth--access-token))))))) + ,body)) + +(defun mastodon-http--build-params-string (params) + "Build a request parameters string from parameters alist PARAMS." + ;; (url-build-query-string args nil)) + ;; url-build-query-string adds 'nil' for empty params so lets stick with our + ;; own: + (mapconcat (lambda (p) + (when (cdr p) ; only when value + (concat (url-hexify-string (car p)) + "=" (url-hexify-string (cdr p))))) + params "&")) + +(defun mastodon-http--build-array-params-alist (param-str array) + "Return parameters alist using PARAM-STR and ARRAY param values. +Used for API form data parameters that take an array." + (cl-loop for x in array + collect (cons param-str x))) + +(defun mastodon-http--concat-params-to-url (url params) + "Build a query string with PARAMS and concat to URL." + (if params + (concat url "?" + (mastodon-http--build-params-string params)) + url)) + +(defun mastodon-http--post (url + &optional params headers unauthenticated-p json) + "POST synchronously to URL, optionally with PARAMS and HEADERS. +Authorization header is included by default unless +UNAUTHENTICATED-P is non-nil. +If JSON is :json, encode PARAMS as JSON for +the request data. If it is :raw, just use the plain params." + ;; NB: raw is used by `mastodon-tl--unfilter-user-languages'; not sure if + ;; there's a way around it? + (mastodon-http--authorized-request "POST" + (let* ((url-request-data + (when params + (cond ((eq json :json) + (json-encode params)) + ((eq json :raw) + params) + (t + (mastodon-http--build-params-string params))))) + (url-request-extra-headers + (append url-request-extra-headers ; auth set in macro + (if json + '(("Content-Type" . "application/json") + ("Accept" . "application/json")) + (unless (assoc "Content-Type" headers) ; pleroma compat: + '(("Content-Type" . "application/x-www-form-urlencoded")))) + headers))) + (with-temp-buffer + (mastodon-http--url-retrieve-synchronously url))) + unauthenticated-p)) + +(defun mastodon-http--get (url &optional params silent) + "Make synchronous GET request to URL. +PARAMS is an alist of any extra parameters to send with the request. +SILENT means don't message." + (mastodon-http--authorized-request "GET" + ;; url-request-data doesn't seem to work with GET requests?: + (let ((url (mastodon-http--concat-params-to-url url params))) + (mastodon-http--url-retrieve-synchronously url silent)))) + +(defun mastodon-http--get-response (url &optional params no-headers silent vector) + "Make synchronous GET request to URL. Return JSON and response headers. +PARAMS is an alist of any extra parameters to send with the request. +SILENT means don't message. +NO-HEADERS means don't collect http response headers. +VECTOR means return json arrays as vectors." +(let ((buf (mastodon-http--get url params silent))) + ;; --get can return nil if instance unresponsive: + (if (not buf) + (user-error "Looks like the server response borked. \ +Is your instance up?") + (with-current-buffer buf + (mastodon-http--process-response no-headers vector))))) + +(defun mastodon-http--get-json (url &optional params silent vector) + "Return only JSON data from URL request. +PARAMS is an alist of any extra parameters to send with the request. +SILENT means don't message. +VECTOR means return json arrays as vectors." + (car (mastodon-http--get-response url params :no-headers silent vector))) + +(defun mastodon-http--process-json () + "Return only JSON data from async URL request. +Callback to `mastodon-http--get-json-async', usually +`mastodon-tl--init*', is run on the result." + (car (mastodon-http--process-response :no-headers))) + +(defun mastodon-http--render-html-err (string) + "Render STRING as HTML in a temp buffer. +STRING should be a HTML for a 404 errror." + (with-temp-buffer + (insert string) + (shr-render-buffer (current-buffer)) + (view-mode))) ; for 'q' to kill buffer and window + ;; (error ""))) ; stop subsequent processing + +(defun mastodon-http--process-response (&optional no-headers vector) + "Process http response. +Return a cons of JSON list and http response headers. +If NO-HEADERS is non-nil, just return the JSON. +VECTOR means return json arrays as vectors. +Callback to `mastodon-http--get-response-async', usually +`mastodon-tl--init*', is run on the result." + ;; view raw response: + ;; (switch-to-buffer (current-buffer)) + (let ((headers (unless no-headers + (mastodon-http--process-headers)))) + (goto-char (point-min)) + (re-search-forward "^$" nil 'move) + (let ((json-array-type (if vector 'vector 'list)) + (json-string (decode-coding-string + (buffer-substring-no-properties (point) (point-max)) + 'utf-8))) + (kill-buffer) + (cond ((or (string-empty-p json-string) (null json-string)) + nil) + ;; if we get html, just render it and error: + ;; ideally we should handle the status code in here rather than + ;; this crappy hack? + ((string-prefix-p "\n<" json-string) ; html hack + ;; NB: in this case, process-response returns t!: + (mastodon-http--render-html-err json-string) + nil) ;; return nil instead of t + ;; if no json or html, maybe we have a plain string error message + ;; (misskey does this, but there are probably better ways to do + ;; this): + ((not (or (string-prefix-p "\n{" json-string) + (string-prefix-p "\n[" json-string))) + (error "%s" json-string)) + (t + ;; instance may return error in JSON e.g. ((error . "Record not + ;; found")) for a null endpoint. but we don't error here because + ;; sometimes we just want to check for such an error in an + ;; if/cond. + `(,(json-read-from-string json-string) . ,headers)))))) + +(defun mastodon-http--process-headers () + "Return an alist of http response headers." + (goto-char (point-min)) + (let* ((head-str (buffer-substring-no-properties + (point-min) + (re-search-forward "^$" nil 'move))) + (head-list (split-string head-str "\n"))) + (mapcar (lambda (x) + (let ((list (split-string x ": "))) + (cons (car list) (cadr list)))) + head-list))) + +(defun mastodon-http--delete (url &optional params) + "Make DELETE request to URL. +PARAMS is an alist of any extra parameters to send with the request." + ;; url-request-data only works with POST requests? + (let ((url (mastodon-http--concat-params-to-url url params))) + (mastodon-http--authorized-request "DELETE" + (with-temp-buffer + (mastodon-http--url-retrieve-synchronously url))))) + +(defun mastodon-http--put (url &optional params headers) + "Make PUT request to URL. +PARAMS is an alist of any extra parameters to send with the request. +HEADERS is an alist of any extra headers to send with the request." + (mastodon-http--authorized-request "PUT" + (let ((url-request-data + (when params (mastodon-http--build-params-string params))) + (url-request-extra-headers + (append url-request-extra-headers ; auth set in macro + (unless (assoc "Content-Type" headers) ; pleroma compat: + '(("Content-Type" . "application/x-www-form-urlencoded"))) + headers))) + (with-temp-buffer (mastodon-http--url-retrieve-synchronously url))))) + +;; profile update functions + +(defun mastodon-http--patch-json (url &optional params) + "Make synchronous PATCH request to URL. Return JSON response. +Optionally specify the PARAMS to send." + (with-current-buffer (mastodon-http--patch url params) + (mastodon-http--process-json))) + +(defun mastodon-http--patch (url &optional params json) + "Make synchronous PATCH request to URL. +Optionally specify the PARAMS to send. +JSON means send params as JSON data." + (mastodon-http--authorized-request "PATCH" + ;; NB: unlike POST, PATCHing only works if we use query params! + ;; so here, unless JSON arg, we use query params and do not set + ;; `url-request-data'. this is probably an error, i don't understand it. + (let* ((url-request-data + (when (and params json) + (encode-coding-string + (json-encode params) 'utf-8))) + ;; (mastodon-http--build-params-string params)))) + (url (unless json + (mastodon-http--concat-params-to-url url params))) + (headers (when json + '(("Content-Type" . "application/json") + ("Accept" . "application/json")))) + (url-request-extra-headers + (append url-request-extra-headers headers))) + (mastodon-http--url-retrieve-synchronously url)))) + + ;; Asynchronous functions + +(defun mastodon-http--get-async (url &optional params callback &rest cbargs) + "Make GET request to URL. +Pass response buffer to CALLBACK function with args CBARGS. +PARAMS is an alist of any extra parameters to send with the request." + (let ((url (mastodon-http--concat-params-to-url url params))) + (mastodon-http--authorized-request "GET" + (url-retrieve url callback cbargs)))) + +(defun mastodon-http--get-response-async (url &optional params callback &rest cbargs) + "Make GET request to URL. Call CALLBACK with http response and CBARGS. +PARAMS is an alist of any extra parameters to send with the request." + (mastodon-http--get-async + url + params + (lambda (status) + (when status ; for flakey servers + (apply callback (mastodon-http--process-response) cbargs))))) + +(defun mastodon-http--get-json-async (url &optional params callback &rest cbargs) + "Make GET request to URL. Call CALLBACK with json-list and CBARGS. +PARAMS is an alist of any extra parameters to send with the request." + (mastodon-http--get-async + url + params + (lambda (status) + (when status ;; only when we actually get sth? + (apply callback (mastodon-http--process-json) cbargs))))) + +(defun mastodon-http--post-async (url params _headers &optional callback &rest cbargs) + "POST asynchronously to URL with PARAMS and HEADERS. +Then run function CALLBACK with arguements CBARGS. +Authorization header is included by default unless UNAUTHENTICED-P is non-nil." + (mastodon-http--authorized-request "POST" + (let (;(request-timeout 5) ; this is from request.el no url.el! + (url-request-data (when params + (mastodon-http--build-params-string params)))) + (with-temp-buffer + (url-retrieve url callback cbargs))))) + +;; TODO: test for curl first? +(defun mastodon-http--post-media-attachment (url filename caption) + "Make POST request to upload FILENAME with CAPTION to the server's media URL. +The upload is asynchronous. On succeeding, +`mastodon-toot--media-attachment-ids' is set to the id(s) of the +item uploaded, and `mastodon-toot--update-status-fields' is run." + (let* ((file (file-name-nondirectory filename)) + (request-backend 'curl) + (desc `(("description" . ,caption))) + (cb (cl-function + (lambda (&key data &allow-other-keys) + (when data + (let* ((id (alist-get 'id data))) + ;; update ids: + (push id mastodon-toot--media-attachment-ids) + ;; pleroma, PUT the description: + ;; this is how the mangane akkoma web client does it + ;; and it seems easier than the other options! + (when (and caption + (not (string= caption (alist-get 'description data)))) + (let ((url (mastodon-http--api (format "media/%s" id)))) + ;; (message "PUTting image description") + (mastodon-http--put url desc))) + (message "Uploading %s... (done)" file) + (mastodon-toot--update-status-fields))))))) + (request + url + :type "POST" + :params desc + :files `(("file" . (,file :file ,filename + :mime-type "multipart/form-data"))) + :parser 'json-read + :headers `(("Authorization" . ,(concat "Bearer " + (mastodon-auth--access-token)))) + :sync nil + :success (apply-partially cb) + :error (cl-function + (lambda (&key error-thrown &allow-other-keys) + (cond + ;; handle curl errors first (eg 26, can't read file/path) + ;; because the '=' test below fails for them + ;; they have the form (error . error message 24) + ((not (proper-list-p error-thrown)) ; not dotted list + (message "Got error: %s. Shit went south." (cdr error-thrown))) + ;; handle mastodon api errors + ;; they have the form (error http 401) + ((= (car (last error-thrown)) 401) + (message "Got error: %s Unauthorized: The access token is invalid" + error-thrown)) + ((= (car (last error-thrown)) 422) + (message "Got error: %s Unprocessable entity: file or file\ + type is unsupported or invalid" + error-thrown)) + (t + (message "Got error: %s Shit went south" + error-thrown)))))))) + +(provide 'mastodon-http) +;;; mastodon-http.el ends here diff --git a/elpa/mastodon-20241202.1839/mastodon-inspect.el b/elpa/mastodon-20241202.1839/mastodon-inspect.el new file mode 100644 index 00000000..4981943f --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-inspect.el @@ -0,0 +1,129 @@ +;;; mastodon-inspect.el --- Client for Mastodon -*- lexical-binding: t -*- + +;; Copyright (C) 2017-2019 Johnson Denen +;; Copyright (C) 2020-2024 Marty Hiatt +;; Author: Johnson Denen +;; Marty Hiatt +;; Maintainer: Marty Hiatt +;; Homepage: https://codeberg.org/martianh/mastodon.el + +;; This file is not part of GNU Emacs. + +;; This file is part of mastodon.el. + +;; mastodon.el 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. + +;; mastodon.el 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 mastodon.el. If not, see . + +;;; Commentary: + +;; Some tools to help inspect / debug mastodon.el + +;;; Code: +(autoload 'mastodon-http--api "mastodon-http") +(autoload 'mastodon-http--get-json "mastodon-http") +(autoload 'mastodon-http--get-search-json "mastodon-http") +(autoload 'mastodon-media--inline-images "mastodon-media") +(autoload 'mastodon-mode "mastodon") +(autoload 'mastodon-tl--as-string "mastodon-tl") +(autoload 'mastodon-tl--property "mastodon-tl") +(autoload 'mastodon-tl--toot "mastodon-tl") + +(defvar mastodon-instance-url) + +(defgroup mastodon-inspect nil + "Tools to help inspect toots." + :prefix "mastodon-inspect-" + :group 'external) + +(defun mastodon-inspect--dump-json-in-buffer (name json) + "Buffer NAME is opened and JSON in printed into it." + (switch-to-buffer-other-window name) + (erase-buffer) + (let ((print-level nil) + (print-length nil)) + (insert (pp json t))) + (goto-char (point-min)) + (emacs-lisp-mode) + (message "success")) + +(defun mastodon-inspect--toot () + "Find next toot and dump its meta data into new buffer." + (interactive) + (mastodon-inspect--dump-json-in-buffer + (concat "*mastodon-inspect-toot-" + (mastodon-tl--as-string (mastodon-tl--property 'item-id)) + "*") + (mastodon-tl--property 'item-json))) + +(defun mastodon-inspect--download-single-toot (item-id) + "Download the toot/status represented by ITEM-ID." + (mastodon-http--get-json + (mastodon-http--api (concat "statuses/" item-id)))) + +(defun mastodon-inspect--view-single-toot (item-id) + "View the toot/status represented by ITEM-ID." + (interactive "s Toot ID: ") + (let ((buffer (get-buffer-create (concat "*mastodon-status-" item-id "*")))) + (with-current-buffer buffer + (let ((toot (mastodon-inspect--download-single-toot item-id ))) + (mastodon-tl--toot toot) + (goto-char (point-min)) + (while (search-forward "\n\n\n | " nil t) + (replace-match "\n | ")) + (mastodon-media--inline-images (point-min) (point-max)))) + (switch-to-buffer-other-window buffer) + (mastodon-mode))) + +(defun mastodon-inspect--view-single-toot-source (item-id) + "View the ess source of a toot/status represented by ITEM-ID." + (interactive "s Toot ID: ") + (mastodon-inspect--dump-json-in-buffer + (concat "*mastodon-status-raw-" item-id "*") + (mastodon-inspect--download-single-toot item-id))) + + +(defvar mastodon-inspect--search-query-accounts-result) +(defvar mastodon-inspect--single-account-json) + +(defvar mastodon-inspect--search-query-full-result) +(defvar mastodon-inspect--search-result-tags) + +(defun mastodon-inspect--get-search-result (query) + "Inspect function for a search result for QUERY." + (interactive) + (setq mastodon-inspect--search-query-full-result + (append ; convert vector to list + (mastodon-http--get-search-json + (format "%s/api/v2/search" mastodon-instance-url) + query) + nil)) + (setq mastodon-inspect--search-result-tags + (append (cdr + (caddr mastodon-inspect--search-query-full-result)) + nil))) + +(defun mastodon-inspect--get-search-account (query) + "Return JSON for a single account after search QUERY." + (interactive) + (setq mastodon-inspect--search-query-accounts-result + (append ; convert vector to list + (mastodon-http--get-search-json + (format "%s/api/v1/accounts/search" mastodon-instance-url) + query) + nil)) + (setq mastodon-inspect--single-account-json + (car mastodon-inspect--search-query-accounts-result))) + + +(provide 'mastodon-inspect) +;;; mastodon-inspect.el ends here diff --git a/elpa/mastodon-20241202.1839/mastodon-iso.el b/elpa/mastodon-20241202.1839/mastodon-iso.el new file mode 100644 index 00000000..6199cbe0 --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-iso.el @@ -0,0 +1,244 @@ +;;; mastodon-iso.el --- ISO language code lists for mastodon.el -*- lexical-binding: t -*- + +;; Copyright (C) 2022 Marty Hiatt +;; Author: Marty Hiatt +;; Homepage: https://codeberg.org/martianh/mastodon.el + +;; This file is not part of GNU Emacs. + +;; This file is part of mastodon.el. + +;; mastodon.el 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. + +;; mastodon.el 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 mastodon.el. If not, see . + +;;; Commentary: + +;;; Code: + +;; via +;; https://github.com/VyrCossont/mastodon/blob/0836f4a656d5486784cadfd7d0cd717bb67ede4c/app/helpers/languages_helper.rb +;; and +;; https://github.com/Shinmera/language-codes/blob/master/data/iso-639-3.lisp + +(defvar mastodon-iso-639-1 + '(("Abkhazian" . "ab") + ("Afar" . "aa") + ("Afrikaans" . "af") + ("Akan" . "ak") + ("Albanian" . "sq") + ("Amharic" . "am") + ("Arabic" . "ar") + ("Aragonese" . "an") + ("Armenian" . "hy") + ("Assamese" . "as") + ("Avaric" . "av") + ("Avestan" . "ae") + ("Aymara" . "ay") + ("Azerbaijani" . "az") + ("Bambara" . "bm") + ("Bashkir" . "ba") + ("Basque" . "eu") + ("Belarusian" . "be") + ("Bengali" . "bn") + ("Bihari languages" . "bh") + ("Bislama" . "bi") + ("Bosnian" . "bs") + ("Breton" . "br") + ("Bulgarian" . "bg") + ("Burmese" . "my") + ("Central Khmer" . "km") + ("Chamorro" . "ch") + ("Chechen" . "ce") + ("Chinese" . "zh") + ("Chuvash" . "cv") + ("Cornish" . "kw") + ("Corsican" . "co") + ("Cree" . "cr") + ("Croatian" . "hr") + ("Czech" . "cs") + ("Danish" . "da") + ("Dzongkha" . "dz") + ("English" . "en") + ("Esperanto" . "eo") + ("Estonian" . "et") + ("Ewe" . "ee") + ("Faroese" . "fo") + ("Fijian" . "fj") + ("Finnish" . "fi") + ("Dutch" . "nl") + ("French" . "fr") + ("Fulah" . "ff") + ("Galician" . "gl") + ("Ganda" . "lg") + ("Georgian" . "ka") + ("German" . "de") + ("Greek" . "el") + ("Guarani" . "gn") + ("Gujarati" . "gu") + ("Haitian" . "ht") + ("Hausa" . "ha") + ("Hebrew" . "he") + ("Herero" . "hz") + ("Hindi" . "hi") + ("Hiri Motu" . "ho") + ("Hungarian" . "hu") + ("Icelandic" . "is") + ("Ido" . "io") + ("Igbo" . "ig") + ("Indonesian" . "id") + ("Interlingua" . "ia") + ("Inuktitut" . "iu") + ("Inupiaq" . "ik") + ("Irish" . "ga") + ("Italian" . "it") + ("Japanese" . "ja") + ("Japanese" . "jp") + ("Javanese" . "jv") + ("Kalaallisut" . "kl") + ("Kannada" . "kn") + ("Kanuri" . "kr") + ("Kashmiri" . "ks") + ("Kazakh" . "kk") + ("Kikuyu" . "ki") + ("Kinyarwanda" . "rw") + ("Komi" . "kv") + ("Kongo" . "kg") + ("Korean" . "ko") + ("Kurdish" . "ku") + ("Kuanyama" . "kj") + ("Kirghiz" . "ky") + ("Lao" . "lo") + ("Latin" . "la") + ("Latvian" . "lv") + ("Limburgan" . "li") + ("Lingala" . "ln") + ("Lithuanian" . "lt") + ("Luba-Katanga" . "lu") + ("Luxembourgish" . "lb") + ("Macedonian" . "mk") + ("Malagasy" . "mg") + ("Malay" . "ms") + ("Malayalam" . "ml") + ("Divehi" . "dv") + ("Maltese" . "mt") + ("Manx" . "gv") + ("Maori" . "mi") + ("Marathi" . "mr") + ("Marshallese" . "mh") + ("Mongolian" . "mn") + ("Nauru" . "na") + ("Navajo" . "nv") + ("Ndonga" . "ng") + ("Nepali" . "ne") + ("Ndebele, North" . "nd") + ("Northern Sami" . "se") + ("Norwegian" . "no") + ("Bokmål, Norwegian" . "nb") + ("Chichewa" . "ny") + ("Norwegian Nynorsk" . "nn") + ("Interlingue" . "ie") + ("Occitan" . "oc") + ("Ojibwa" . "oj") + ("Church Slavic" . "cu") + ("Oriya" . "or") + ("Oromo" . "om") + ("Ossetian" . "os") + ("Pali" . "pi") + ("Persian" . "fa") + ("Polish" . "pl") + ("Portuguese" . "pt") + ("Panjabi" . "pa") + ("Pushto" . "ps") + ("Quechua" . "qu") + ("Romanian" . "ro") + ("Romansh" . "rm") + ("Rundi" . "rn") + ("Russian" . "ru") + ("Samoan" . "sm") + ("Sango" . "sg") + ("Sanskrit" . "sa") + ("Sardinian" . "sc") + ("Gaelic" . "gd") + ("Serbian" . "sr") + ("Shona" . "sn") + ("Sichuan Yi" . "ii") + ("Sindhi" . "sd") + ("Sinhala" . "si") + ("Slovak" . "sk") + ("Slovenian" . "sl") + ("Somali" . "so") + ("Sotho, Southern" . "st") + ("Ndebele, South" . "nr") + ("Spanish" . "es") + ("Sundanese" . "su") + ("Swahili" . "sw") + ("Swati" . "ss") + ("Swedish" . "sv") + ("Tagalog" . "tl") + ("Tahitian" . "ty") + ("Tajik" . "tg") + ("Tamil" . "ta") + ("Tatar" . "tt") + ("Telugu" . "te") + ("Thai" . "th") + ("Tibetan" . "bo") + ("Tigrinya" . "ti") + ("Tonga (Tonga Islands)" . "to") + ("Tsonga" . "ts") + ("Tswana" . "tn") + ("Turkish" . "tr") + ("Turkmen" . "tk") + ("Twi" . "tw") + ("Ukrainian" . "uk") + ("Urdu" . "ur") + ("Uighur" . "ug") + ("Uzbek" . "uz") + ("Catalan" . "ca") + ("Venda" . "ve") + ("Vietnamese" . "vi") + ("Volapük" . "vo") + ("Walloon" . "wa") + ("Welsh" . "cy") + ("Western Frisian" . "fy") + ("Wolof" . "wo") + ("Xhosa" . "xh") + ("Yiddish" . "yi") + ("Yoruba" . "yo") + ("Zhuang" . "za") + ("Zulu" . "zu"))) + +;; web UI doesn't respect these for now +(defvar mastodon-iso-639-regional + '(("es-AR" "Español (Argentina)") + ("es-MX" "Español (México)") + ("pt-BR" "Português (Brasil)") + ("pt-PT" "Português (Portugal)") + ("sr-Latn" "Srpski (latinica)") + ("zh-CN" "简体中文") + ("zh-HK" "繁體中文（香港）") + ("zh-TW" "繁體中文（臺灣）"))) + +(defvar mastodon-iso-639-3 + '(("ast" "Asturian" "Asturianu") + ("ckb" "Sorani (Kurdish)" "سۆرانی") + ("jbo" "Lojban" "la .lojban.") + ("kab" "Kabyle" "Taqbaylit") + ("kmr" "Kurmanji (Kurdish)" "Kurmancî") + ("ldn" "Láadan" "Láadan") + ("lfn" "Lingua Franca Nova" "lingua franca nova") + ("tok" "Toki Pona" "toki pona") + ("zba" "Balaibalan" "باليبلن") + ("zgh" "Standard Moroccan Tamazight" "ⵜⴰⵎⴰⵣⵉⵖⵜ"))) + +(provide 'mastodon-iso) +;;; mastodon-iso.el ends here diff --git a/elpa/mastodon-20241202.1839/mastodon-media.el b/elpa/mastodon-20241202.1839/mastodon-media.el new file mode 100644 index 00000000..86014103 --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-media.el @@ -0,0 +1,518 @@ +;;; mastodon-media.el --- Functions for inlining Mastodon media -*- lexical-binding: t -*- + +;; Copyright (C) 2017-2019 Johnson Denen +;; Copyright (C) 2020-2024 Marty Hiatt +;; Author: Johnson Denen +;; Marty Hiatt +;; Maintainer: Marty Hiatt +;; Homepage: https://codeberg.org/martianh/mastodon.el + +;; This file is not part of GNU Emacs. + +;; This file is part of mastodon.el. + +;; mastodon.el 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. + +;; mastodon.el 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 mastodon.el. If not, see . + +;;; Commentary: + +;; mastodon-media.el provides functions for inlining media. + +;; Known bug gnutls -12 when trying to access images on some systems. +;; It looks like their may be a version mismatch between the encryption +;; required by the server and client. + +;;; Code: +(require 'url-cache) +(require 'mm-decode) +(require 'image-mode) + +(autoload 'mastodon-tl--propertize-img-str-or-url "mastodon-tl") +(autoload 'mastodon-tl--image-trans-check "mastodon-tl") + +(defvar url-show-status) + +(defvar mastodon-tl--shr-image-map-replacement) + +(defgroup mastodon-media nil + "Inline Mastadon media." + :prefix "mastodon-media-" + :group 'mastodon) + +(defcustom mastodon-media--avatar-height 20 + "Height of the user avatar images (if shown)." + :type 'integer) + +(defcustom mastodon-media--preview-max-height 250 + "Max height of any media attachment preview to be shown in timelines." + :type 'integer) + +(defcustom mastodon-media--enable-image-caching nil + "Whether images should be cached." + :type 'boolean) + +(defcustom mastodon-media--hide-sensitive-media t + "Whether media marked as sensitive should be hidden." + :type 'boolean) + +(defvar mastodon-media--generic-avatar-data + (base64-decode-string + "iVBORw0KGgoAAAANSUhEUgAAAGQAAABkCAIAAAD/gAIDAAAACXBIWXMAAAsTAAALEwEAmpwYAAAA +B3RJTUUH4QUIFCg2lVD1hwAAABZ0RVh0Q29tbWVudABHZW5lcmljIGF2YXRhcsyCnMsAAAcGSURB +VHja7dzdT1J/HAfwcw7EQzMKW0pGRMK4qdRZbdrs6aIRbt506V1b/AV1U2td9l9UXnmhW6vgwuko +SbcOD/a0RB4CCRCRg0AIR4Hz8LvgN2cKCMI5wOH7uXBuugO+eH8+fM/3HIFpmoZAVVYIIABYAAtg +ASyABbAAAcACWAALYAEsgAUIABbAAlgAC2ABLEAAsAAWwAJYAAtgAQKAxUjxm+R50DRN0zRFUf+8 +kggCwzAMwwDrfyOSJGmattlsdrvd5XLlcrndnyoUir6+vpGRkZMnT/J4vIarwY26MaTAZLVap6en +fT7f9vY2QRA7Ozv/vJJ8vkgk4vP5XV1dWq1Wq9VKpdIGkjUGi6IoFEWnp6ddLlcymSRJsvzv83g8 +kUikUCi0Wq1Opzt16lS7YBEE8ebNG6PRiGHYoUwHyW7cuPHo0SOlUsl9LIIgXrx4Ybfb//79e7Qj +CIXC3t7ex48fX7lyhctYBSkURTOZTC3H4fF4SqXy6dOnLHuxh0VR1PPnz2uX2uv17Nmzy5cvc21R +StP0q1ev7HZ7XaQgCCJJ0u/3T0xMBINBrmGhKGo0Go88p0p5Wa1Wg8GQSqW4g0XT9NTUFIZhdT9y +Npudn59nLVwIO7FyuVxVrRIqr1AoZDab2QkXG1hTU1PJZJKhg5MkOT8/HwqFuIBF07TP52MoVrvh +YqLHG4BlsVi2t7cZfQiSJB0OBwudyDiWzWYjCILpR1lZWeECltPp3LeXwEQFg8FoNNryWPl8noVp +ws6jgG1lgAWwuI914cIFPp/xnX6ZTCYSiVoeq7+/n4U/Q61Wy+Xylse6desWC8kaGBiQSCQtjyWR +SGQyGY/HY+4hpFJpV1cXRwa8TqdjtBOHh4fVajVHsLRarVKpZChcUqn07t27LPQgS1gSiUSn04nF +4rofGYbh4eHhgYEBTq2ztFrtyMhI3ZtRo9GMjY2xEyv2sCQSiV6vV6lUdWzGzs7O8fHxwcFBDq7g +5XL5kydPent76+LV2dmp1+vv37/P5gqe7SvSDofj5cuXteydwjAslUr1ev2DBw9YPt1pwL0ODodj +YmLCYrEcYZ8LhmGNRjM+Ps5yphqGBUFQKBQyGo0mk2l1dTWfz5MkSVFUPp8/+GSEQiEMw8eOHYNh +uLu7e2hoaGxsjM05tbfYvpkNx/FQKBSJRCAI6unpwTBsbW0tmUwWbtc6mCMEQSAIOn78+Llz586f +P9/T05PL5QKBgEKh4GyyCkZfvnwJhULhcHhzczOTyRRuYMtms/l8PpPJZDKZnZ2dvc9HIBCIxeIT +J04Uvil87ejoOH36tEwm02g0V69evXjxIkewCkZer/fr16+/f/+OxWKlrvQQBEEQxL7dYQRBhEJh +0fNwBEHEYrFMJlOpVP39/RqNhgU1prAKTDMzMy6XKxqNJhIJptY+CHLmzBmZTHbp0qXbt2+rVKpW +wtplWl5eDofDTF803Bs0tVrNKFmdsXAcn52dnZ2dDQaD7DAVJRsdHb1z507dT93rhoXj+MrKytzc +3NLSEnNNVyHZ2bNnr127NjQ0NDg4WEey+mDhOP7u3bu5ubkyI5z9iMnl8nv37o2OjgoEgmbBisVi +r1+/ttlsjQ1UmYg9fPiwo6OjwVg4jn///v3Dhw/Ly8vNEKiiXhKJpK+vT6fT1d6S/FqkUBSdnJz0 ++/1QsxZFUclkEkXReDxOkuT169dr8TpisnAcN5lMb9++ZfP+11pKIBAUdgpv3rx55BGGtIMUBEG5 +XM7tdhsMhoWFhb3/S8UsVitK1curaqzV1dX379+3nNQ+r42NjSPsPlaH5fP5mnyiV+Ll9XonJyfD +4XC1XkhVDTgzM/Pz50+oxSubzX779u3z58/VLneQyqUMBsOnT5+acz1V7XoiHo9//PjRZDKl0+n6 +Y3k8HrPZ3Gxr9Fq81tfXl5aWAoFA5cO+IqxIJFLYSIA4VARBuN3uxcXFyoc9v5IGNJvNVquVAw14 +sBktFkt3d7dUKq3k5BGpJFYLCwucacCizZhIJCoJF3JorBYXF//8+QNxtAiCKFwiqKRvkEPnOoqi +HGvAfeFKJBIVTnqkfKx+/PjBsbleKlwej6cmLI/H43A4OByr3XClUimn03louMphra2teb1eqA0q +m836fL6tra0jYkUiEb/fz8k3waLhikQiXq+3/NtiSayNjY1fv35BbVP5fN7pdG5tbR0Fy+12c360 +Hxzz5a8KI6V6EMMwzo/2fZ2YTqej0WgqlSoVLqRUDwYCAajNiqKoYDBYphOLY8ViscItVG1VJEmu +r6+XeU8sjhWPxzc3N9sNiyAIDMOqS1YbDqwKx1YRrFQqxc7HJDRnpdPpUuEqgoVhWL0+i6hFz6tL +ja3iM4u1zw1qwhlfJihI0bfCNhxYe4NSqg3/A862hQAbrdtHAAAAAElFTkSuQmCC") + "The PNG data for a generic 100x100 avatar.") + +(defvar mastodon-media--generic-broken-image-data + (base64-decode-string + "iVBORw0KGgoAAAANSUhEUgAAAMgAAADICAYAAACtWK6eAAAACXBIWXMAAAsTAAALEwEAmpwYAAAA +B3RJTUUH4QUIFQUVFt+0LQAAABZ0RVh0Q29tbWVudABHZW5lcmljIGF2YXRhcsyCnMsAAAdoSURB +VHja7d1NSFRrAIfx//iB6ZDSMJYVkWEk0ceYFUkkhhQlEUhEg0FlC1eBoRTUwlbRok0TgRQURZAE +FgpjJmFajpK4kggxpXHRQEGWUJZizpy7uPfC5eKiV+dD5zw/mN05jrxnnjnfcxyWZVkCMKc0SXI4 +HIwEMIcUhgAgEIBAAAIBCAQgEIBAAAIBCAQgEAAEAhAIQCAAgQAEAhAIQCAAgQA2kBaNP8Jt7ViM +onErOWsQgEAAAgEIBCAQgEAAAgEIBCAQgEAAEAhAIACBAAQCEAhAIACBAAQCEAhAIAAIBCAQgEAA +AgEIBCAQgEAAAgEIBACBAAQCEAhAIACBAAQCEAhAIACBAAQCgEAAAgEIBCAQgECAxSyNIYitz58/ +a3BwUIODgxoZGVEoFFIoFNK3b980NTWlX79+SZIyMzOVlZWlVatWae3atSooKJDH49HOnTvl8XiU +ksJ3WSI4LMuyHA7Hgv6IZVmM5D8mJyf1/PlzdXZ2qrOzU8FgcMF/0+126+DBg6qqqlJFRYXS0vhe ++6MP9wI/1wQSJeFwWH6/X01NTWpra9PU1FTM3isvL0/nz5/XuXPntHz5ciqIcSCy/v50L+hlV+Pj +49a1a9esdevWLXgMTV8ul8u6c+eOFYlELMwtKmNNIOa+fv1qXbp0yXI6nXEP4/+v0tJS6+PHj9RA +IIk3PT1tXb161crOzk54GP995ebmWt3d3RRBIInj9/utgoKCRRXGf18ZGRmW3++niigHwk56PHf4 +Yiw9PV0dHR0qLy9nD52jWAQylxUrVmhgYEAbN24kkCgsM84+JZmJiQmdPn1akUiEweBE4eL/NsrN +zVVZWZlKSkpUWFioTZs2yeVyKTs7W7Ozs5qYmNDExITev3+v/v5+9fX1qb+/f8FjevPmTdXW1rIG +IZDFN9gbNmyQ1+uV1+uVx+MxXlAjIyNqbGzU3bt39fPnz3n9vytXrlQwGJTT6SQQThQm/ohIamqq +VVlZaXV1dUXtPT98+GCVlZXNe7n4fD6OYnGYN7GDnZ6ebtXU1FhjY2Mxed9IJGLV19fPa7kUFRUR +CIEkZrAdDod15syZmIXxf7W1tfNaNqOjowSygBdHseZh7969GhgY0IMHD5Sfnx+X97xx44Z2795t +PF93dzcLjMO88TvHcP/+ffX19WnXrl3xXVApKbp9+7bxfSFv3rxhwRFI7B07dkxDQ0Oqrq5O2P9Q +XFysffv2Gc0zOjrKwiOQ2Hv69Kny8vIS/n8cP37caPqxsTEWHoHYa//HxPfv3xk0ArGP1atXG03/ +7z3vIBBbyM3NNZo+KyuLQSMQ+5icnDSaPicnh0EjEPsYHh42mp7L3gnEVnp6eoymLyoqYtAIxD4e +PXpkNP3+/fsZtAXgcvclpL29XUeOHPnj6Z1Op8bHx7Vs2TJ7fri5o9A+ZmZmdPHiRaN5vF6vbeNg +E8tmGhoaNDQ0ZPTteeHCBQaOQJLfkydPdP36daN5Tp48qc2bNzN47IMkt9evX+vw4cOanp7+43ly +cnI0PDy8KK4dYx8EMRMIBHT06FGjOCTJ5/PZPg42sZJce3u7Dh06pB8/fhjNV11dndBL8tnEYhMr +5lpaWuT1evX792+j+YqLixUIBLj+ik2s5NXc3KwTJ04Yx5Gfn69nz54RB5tYyaupqUlVVVWanZ01 +ms/tdqujo4P9DgJJXg8fPtSpU6cUDoeN43j58qUKCwsZRAJJTvfu3dPZs2eNf0/X7Xarq6tL27dv +ZxAJJDn5fD7V1NQYx7FmzRq9evVK27ZtYxAJJDk1NDSorq7O+ChgQUGBent7tWXLFgYxxniecILU +1dXJ5/MZz7d161a9ePHC+N50sAZZMq5cuTKvOEpKStTT00McccSJwji7devWvJ7bceDAAbW2ttr6 +cQbGH26eD7K0BAIBlZeXG5/nqKioUEtLizIyMhhEAklOX758kcfj0adPn4zXHG1tbcSRoEDYB4mT +y5cvG8exZ88etba2Egf7IMnt7du32rFjh9G5jvz8fA0MDBj/UBxYgyw5jY2NRnGkpqaqubmZOBYB +AomxmZkZPX782Gie+vr6uD9/BGxiJURvb69KS0v/ePrMzEyFQiG5XC4Gj02s5BcIBIymr6ysJA42 +sezj3bt3RtObPv8DBLKkBYNBo+m5r4NAbCUUChlNv379egaNQOzD9FdJ2P8gEFsxfQQaFyMuLhzm +jfUAG45tOBw2fhY6ojP2rEGWwiqdONjEAggEIBCAQAACAUAgAIEA0cIPx8UYJ1FZgwAEAhAIAAIB +CAQgEIBAAAIBFiNOFMaY6V1tnFhkDQIQCEAgAIEABAKAQAACAQgEIBCAQAACAQgEIBCAQABIXO4e +c1y+zhoEIBCAQAAQCEAgAIEABAIQCEAgAIEABAIQCEAgAAgEIBCAQAACAQgEIBCAQAACAQgEAIEA +BAIQCEAgAIEABAIsJVH58WqHw8FIgjUIQCAACAQgEIBAAAIBCAQgEIBAAAIBCAQgEAAEAhAIQCBA +fKRJkmVZjAQwh78A6vCRWJE8K+8AAAAASUVORK5CYII=") + "The PNG data for a generic 200x200 \"broken image\" view.") + +(defvar mastodon-media--sensitive-image-data + (base64-decode-string + "iVBORw0KGgoAAAANSUhEUgAAAMgAAADICAYAAACtWK6eAAAA6npUWHRSYXcgcHJvZmlsZSB0eXBl +IGV4aWYAAHjajVHbjcQwCPx3FVcCr/hRjvOSroMtfyc2Ts4rrXRIxjAQPEzC8fo9w89lkiXYknIs +MRLMihWpCDJ1W5tnsuabbaPGMx7uggBS3NrTIo4fwBGz58X7efSPQSPgimh5CrU6vs746gMlfw5y +Bsr9Zdr9Ax+k4oxsXi2WnKbV9o1my88xTRKXyMngTSilWBBnIUvQc7+InpuUNmjpgt7AyEergJMc +ykrwqtZZ6nVMK+7YvAU0skMMb9qFJ/xKUADz4g9VusX8q82j0Rf7z1rhDfqGdxgpcULlAAABhWlD +Q1BJQ0MgcHJvZmlsZQAAeJx9kT1Iw0AcxV8/tKJVBzuIOGSoTnZREd1qFYpQIdQKrTqYXPohNGlI +UlwcBdeCgx+LVQcXZ10dXAVB8APE2cFJ0UVK/F9SaBHjwXE/3t173L0D/PUyU81gHFA1y0gnE0I2 +tyKEXtGJIHowgz6JmfqsKKbgOb7u4ePrXYxneZ/7c/QqeZMBPoE4znTDIl4nntq0dM77xBFWkhTi +c+Ixgy5I/Mh12eU3zkWH/TwzYmTSc8QRYqHYxnIbs5KhEk8SRxVVo3x/1mWF8xZntVxlzXvyF4bz +2vIS12kOI4kFLEKEABlVbKAMCzFaNVJMpGk/4eEfcvwiuWRybYCRYx4VqJAcP/gf/O7WLEyMu0nh +BNDxYtsfI0BoF2jUbPv72LYbJ0DgGbjSWv5KHZj+JL3W0qJHQP82cHHd0uQ94HIHGHzSJUNypABN +f6EAvJ/RN+WAgVuge9XtrbmP0wcgQ12lboCDQ2C0SNlrHu/uau/t3zPN/n4Ag31yra/8+kkAAA14 +aVRYdFhNTDpjb20uYWRvYmUueG1wAAAAAAA8P3hwYWNrZXQgYmVnaW49Iu+7vyIgaWQ9Ilc1TTBN +cENlaGlIenJlU3pOVGN6a2M5ZCI/Pgo8eDp4bXBtZXRhIHhtbG5zOng9ImFkb2JlOm5zOm1ldGEv +IiB4OnhtcHRrPSJYTVAgQ29yZSA0LjQuMC1FeGl2MiI+CiA8cmRmOlJERiB4bWxuczpyZGY9Imh0 +dHA6Ly93d3cudzMub3JnLzE5OTkvMDIvMjItcmRmLXN5bnRheC1ucyMiPgogIDxyZGY6RGVzY3Jp +cHRpb24gcmRmOmFib3V0PSIiCiAgICB4bWxuczp4bXBNTT0iaHR0cDovL25zLmFkb2JlLmNvbS94 +YXAvMS4wL21tLyIKICAgIHhtbG5zOnN0RXZ0PSJodHRwOi8vbnMuYWRvYmUuY29tL3hhcC8xLjAv +c1R5cGUvUmVzb3VyY2VFdmVudCMiCiAgICB4bWxuczpkYz0iaHR0cDovL3B1cmwub3JnL2RjL2Vs +ZW1lbnRzLzEuMS8iCiAgICB4bWxuczpHSU1QPSJodHRwOi8vd3d3LmdpbXAub3JnL3htcC8iCiAg +ICB4bWxuczp0aWZmPSJodHRwOi8vbnMuYWRvYmUuY29tL3RpZmYvMS4wLyIKICAgIHhtbG5zOnht +cD0iaHR0cDovL25zLmFkb2JlLmNvbS94YXAvMS4wLyIKICAgeG1wTU06RG9jdW1lbnRJRD0iZ2lt +cDpkb2NpZDpnaW1wOmYyYjU4MzUwLTc3ZWMtNDAxNC1hNDVlLTE1N2QyZjljOGM5NyIKICAgeG1w +TU06SW5zdGFuY2VJRD0ieG1wLmlpZDowOTk5MzZhMi1jOGM5LTRkYTAtYTI0Yi02YTM1MmUyNmNi +NmUiCiAgIHhtcE1NOk9yaWdpbmFsRG9jdW1lbnRJRD0ieG1wLmRpZDphMDliYmZhMi03MzA2LTQ3 +NWQtOGExNC05YzA3ZTE1NmFiMTYiCiAgIGRjOkZvcm1hdD0iaW1hZ2UvcG5nIgogICBHSU1QOkFQ +ST0iMi4wIgogICBHSU1QOlBsYXRmb3JtPSJMaW51eCIKICAgR0lNUDpUaW1lU3RhbXA9IjE3MTc1 +MDI1MDIzNDQ1NzIiCiAgIEdJTVA6VmVyc2lvbj0iMi4xMC4zNCIKICAgdGlmZjpPcmllbnRhdGlv +bj0iMSIKICAgeG1wOkNyZWF0b3JUb29sPSJHSU1QIDIuMTAiCiAgIHhtcDpNZXRhZGF0YURhdGU9 +IjIwMjQ6MDY6MDRUMTQ6MDE6NDArMDI6MDAiCiAgIHhtcDpNb2RpZnlEYXRlPSIyMDI0OjA2OjA0 +VDE0OjAxOjQwKzAyOjAwIj4KICAgPHhtcE1NOkhpc3Rvcnk+CiAgICA8cmRmOlNlcT4KICAgICA8 +cmRmOmxpCiAgICAgIHN0RXZ0OmFjdGlvbj0ic2F2ZWQiCiAgICAgIHN0RXZ0OmNoYW5nZWQ9Ii8i +CiAgICAgIHN0RXZ0Omluc3RhbmNlSUQ9InhtcC5paWQ6NTRmM2I5NDktOTlkMS00Mzk2LWI2NzIt +Y2ZkYjRlZWFiYTA1IgogICAgICBzdEV2dDpzb2Z0d2FyZUFnZW50PSJHaW1wIDIuMTAgKExpbnV4 +KSIKICAgICAgc3RFdnQ6d2hlbj0iMjAyNC0wNi0wNFQxNDowMTo0MiswMjowMCIvPgogICAgPC9y +ZGY6U2VxPgogICA8L3htcE1NOkhpc3Rvcnk+CiAgPC9yZGY6RGVzY3JpcHRpb24+CiA8L3JkZjpS +REY+CjwveDp4bXBtZXRhPgogICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAKICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIAogICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIAogICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgCiAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgIAogICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +CiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAKICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIAogICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgCiAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIAogICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgCiAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAKICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgIAogICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgCiAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAg +ICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgICAKICAgICAgICAgICAgICAg +ICAgICAgICAgICAgCjw/eHBhY2tldCBlbmQ9InciPz6w3d0DAAAABmJLR0QA/wD/AP+gvaeTAAAA +CXBIWXMAAC4jAAAuIwF4pT92AAAAB3RJTUUH6AYEDAEq/VtQSwAAABl0RVh0Q29tbWVudABDcmVh +dGVkIHdpdGggR0lNUFeBDhcAAAtOSURBVHja7dvbT5R3Hsfxz5xwhtOsjkgFGQZRTlFOCjJSkpVe +YFltmpZNuo3t9qLdu/4Pa/+L3jVZL9pEU2q7aGirEkUkWw+IM5SpOELxgICcUXjmsBfKBOooo2Za +3H2/Ei+EeRif74/3c5gnmj47fDgqAHGZGQFAIACBAAQCEAhAIACBAAQCEAhAIAAIBCAQgEAAAgEI +BCAQgEAAAgEIBCAQAAQCEAhAIACBAAQCEAhAIACBAAQCgEAAAgEIBCAQgEAAAgEIBCAQgEAAAgFA +IACBAAQCEAhAIACBAAQCEAhAIAAIBCAQgEAAAgEIBCAQgEAAAgEIBCAQAAQCEAhAIACBAAQCEAjw +CrIm+w0ikYiCwaB8Pp8GBweVk5OjoqIiOZ1OjY+Pq6qq6g8fwuLiov7d1qbFhQUdOHhQaampSd0O +BBLT2dmp8+fP6/3331dzc7Oi0ahu3bql1tZW7dixY00MIRqNKhQKyWyxyPQ7bAcCkSSNjY3p7Nmz +anzjDeXl5cW+7vF41NLSos7OzjUxhHXr1umvLS2/23bgHkSSNDk5+ahC65Md5uTkaMuyaID/u0BS +UlIkSd0XLmhubu6J73vr6tb8gO7fv69gMMhvyhqfV7LeN6mBZGdnKysrS1NTU2r95htNTU29Uou9 +uLiojo4OhUIhfvPX8LyS+b6mzw4fjibzHz8+Pq6jx45pfGxMqamp+suBA9pWWCiTKf5tbSgU0vXr +1+X3+3Xnzh1t2bJFFRUV8ng8kqSBgQF99dVXkiTXxo36xyefaGBgQD6/X0ODg8rNzVVdXZ1ycnJW +DNDn86nv55/1YH5excXF8nq9slgsikajmpiY0PDwsPx+v5qbm5WZmamJiQmdOHlSN4NB2Ww2paWn +a252Vk1NTSovL3/qdsePH1dfX5/WrVsnm82mSCSiAwcOqKCgQF1dXeru7pbNZpNhGCoqKlJzc3NC ++53oJW0gEND1gQGNjY4qNzdXZWVlKikpic07EolocHBQgUBAwWBQVqtVnoICFW3frry8vNjrnnfO +q80rWeub6Pu+KMu+ffv+mcxAUlNTVVxUpLm5Od2+fVt+n0/z8/PavHlz7BJsiWEYOnXqlDwej6qr +q1VVVaUHDx+qtbVVm7KztdHlktPp1I4dOxQIBDQ5OSmTySSXy6Vd1dWqrKxU8OZNnTl9Wrt27Yrd ++5w5c0YOh0NvNDYqPz9f7e3tqq6ultVq1YMHD+T3+3X+/HmNjIyourpaDodDDodDmzZt0uXLl/XO +O+9o//79qq+vV3Z2tiQ9dbvCwkLl5ubqypUrcjqd+vjjj+VyuSRJW7ZsUVlZmX755Rft3r1bDQ0N +MpvNCe33avoDAXV0dKi2pkY1u3erpLRU83Nz8vv9Ki4ultVq1eLiotrb2zU8PKz6+nrt3btXZWVl +j87wra0yDENut1tms/m557zavJK1vom875q9xFqSkZGhgwcP6t1335XdbtelS5f0xRdf6N69eyte +19PTo/T0dL322muyWCxKSUlRdVWVcnJzdaKtTXNzc7JYLHK5XMrKypLNZtOePXvkdrtjw6qsqJBh +GLo3Oho7e3R3dys9I0MWi0UbN25UQ0ODotFoLOC6ujo1NDQ8eXp9fDQ1m81xw4+3ndVqVWFhocrL +y3Xv3r0V914mk0l2u102m01VVVWyWCwJ7/ezDA0N6djRo3pz/365XC6ZzWb9yenU66+/rg8++EB2 +u12SdOHCBQUCATU1NWnDhg2yWCxKTU1VbW2tGhsb1d3drf/89NOjI+dzznm1eSVrfRN53zX7Me+K +Es1mFRcXKycnR6dOnZLP59OXX36pjz76SJmZmVpYWNCPP/6ocDisjo6OuD/jRjConY+fnVgsltiQ +l3M4HLEj/NLrsrOz9e3x42ppaZHb7Y77cNJifbFRPG276upqXb16VYFAQLW1tbGvDwwMaE9dXezs +9rz7/VuRSEQ//PCDamtrtWHDhqf+O2dmZnTu3DnVeb1KS0t74vuVlZU6e/asTp86pfKdO2OvSXTO +q0nW+ibb7xbI8rNJc3OzZDLJd+2aenp61NDQoKmpKYXDYR06dEhut1vRaDR2lF86SjztviXeUT8S +DscG/fbbb+vosWM6cuSIvF6v9uzZo9QkP/XevHmztm/fro6ODu0sL5fDblcoFNJPFy/qb++9F3vd +y+735OSk7t69q5plEcaz9AFJZkZG3O/b7Xbt2LlTly9d0vT0dNyInjXn1SRrfV/pj3mnp6cViUSe ++LrNZtNer1eS1HvtWuz6dPkATCaTzGZz7E8iw5MUG/ryZy8ul0t///BD7WtsVFdXl/515IhmZmaS +OliTyaSamhoZhqEbAwOxS6GqykrZbLYV1+Uvs98PHz58tJAJzmd2dvbpB6/09IT3L96cnyWZ6/vK +BjI4NPTEfcaStMeLsbQo6x5fJ48uu7Z8EeHHR5blv4ThcFh2u13eujodOnRI42Njunr1asI/MxJ9 +sQ/68vLylJObq3OdnVpcXNTFixe1bdu2Fa952f1eugQZGxt75uucTuejA1Jvb+yXNd6zBEnKzMx8 +oTk/a17JXN+XXac/LJBUh0NdXV1xP58ef7ygFRUVkqQN69fLnZ+vzs7OuEe5Bw8famJiYsXfw3FO +s4uLiyuOMAsLC7p0+XLs+263W6VlZU9su3SmW37aX7qJfjA/v+KsuPw18bZbvv1er1fjY2P6/vvv +lZ+fH7uGXvK8+/1b69ev1+acHHV2dsZ9znT37l3Nzs4qIyND9fX1mpmZkc/ni3updu3aNf15374V +l1eJznm1eSVrfRNdpzUZSHp6uvr6+vTtd99pZGREoVBIhmFoeHhYJ0+eVEVFhUpLS2M38fubmhQO +h/XN8eMaGRlROBxWKBTSnTt3dDMYjB0FZ2ZmNPzrrzIMY8WlkmEYGhwcjIURjUZltVp15vRp3b59 +W5FIRGNjYxq8eVNFRUUrbiBHRkZig10KOjMzU66NG+Xz+zU/P6/Z2Vn19vauut1yHo9HTqdTPT09 +KikpifvhRaL7HfdDAotFb+7fL5vNphMnTmh0dFSRSESGYSgYDOr+/ftKf3yW9nq9qqysVFtbm65c +uRL7JRwdHVXbiRPaXVOj2pqaFTf2ic55tXkla30TWac1+6BwYWFBP/f3y5mZqVu3bmngxg3NTE/L +4/GoqLhYWwsKYvUvL7+3t1d9fX2ypaRoa0GBSkpKlJWVJUnq6+vT119/vWKbt956S263W59//nns +5xmGIYfDoU8//VTt7e1KS0tTf3+/srKytGvXLuXm5kqSgsGg2tralJKSonA4LMMw5PF4dPDgwUeX +LuPjOt/ZqZGREe0sL1d1VZVSUlJW3W45n9+vyYkJ1dfXP/N+7Vn7vZqJiQn19vaqv79fZrNZhYWF +Ki0tfeJ5QCQS0dDQkAKBgG7cuCFJ2rp1q4qKimLPQF50ziaT6anzSub6JvK+a/ZJejIsfQKy/IYP +/ztzXkvra30VFy7RjwTxas55La0v/+UWIBCAQAACAQgEIBCAQAACAQgEIBAABAIQCEAgAIEABAIQ +CEAgAIEABAIQCAACAQgEIBCAQAACAQgEIBCAQAACAUAgAIEABAIQCEAgAIEABAIQCEAgAIEAIBCA +QAACAQgEIBCAQAACAQgEIBAABAIQCEAgAIEABAIQCEAgAIEABAIQCAACAQgEIBCAQAACAQgEIBCA +QAACAUAgAIEABAIQCEAgAIEABAIQCEAgAIEAIBCAQAACAQgEIBCAQAACAQgEIBAABAIQCEAgAIEA +BAIQCEAgAIEABAIQCAACAQgEIBCAQAACAQgEIBCAQAACAQgEAIEABAIQCEAgAIEABAIQCEAgAIEA +IBCAQICX9F8/bNVInwJ8BAAAAABJRU5ErkJggg==") + "The PNG data for a sensitive image placeholder.") + +(defun mastodon-media--process-image-response + (status-plist url marker image-options region-length) + "Callback function processing the url retrieve response for URL. +STATUS-PLIST is the usual plist of status events as per `url-retrieve'. +IMAGE-OPTIONS are the precomputed options to apply to the image. +MARKER is the marker to where the response should be visible. +REGION-LENGTH is the length of the region that should be replaced +with the image." + (when (marker-buffer marker) ; if buffer hasn't been killed + (let ((url-buffer (current-buffer)) + (is-error-response-p (eq :error (car status-plist)))) + (let* ((data (unless is-error-response-p + (goto-char (point-min)) + (search-forward "\n\n") + (buffer-substring (point) (point-max)))) + (image (when data + (apply #'create-image data ;; inbuilt scaling in 27.1: + (when (version< emacs-version "27.1") + (when image-options 'imagemagick)) + t image-options)))) + (when mastodon-media--enable-image-caching + (unless (url-is-cached url) ; cache if not already cached + (url-store-in-cache url-buffer))) + (with-current-buffer (marker-buffer marker) + ;; Save narrowing in our buffer + (let ((inhibit-read-only t)) + (save-restriction + (widen) + (put-text-property marker + (+ marker region-length) 'media-state 'loaded) + (when image + ;; We only set the image to display if we could load + ;; it; we already have set a default image when we + ;; added the tag. + (mastodon-media--display-image-or-sensitive + marker region-length image)) + ;; We are done with the marker; release it: + (set-marker marker nil))) + (kill-buffer url-buffer)))))) + +(defun mastodon-media--display-image-or-sensitive (marker region-length image) + "Display image using display property, or add sensitive mask. +MARKER, REGION-LENGTH and IMAGE are from +`mastodon-media--process-image-response'. +If the image is marked sensitive, the image is stored in +image-data prop so it can be toggled." + (if (or (not (eq t (get-text-property marker 'sensitive))) + (not mastodon-media--hide-sensitive-media)) + ;; display image + (put-text-property marker (+ marker region-length) + 'display image) + ;; display sensitive placeholder and save image data as prop: + (add-text-properties marker (+ marker region-length) + `(display + ;; (image :type png :data ,mastodon-media--sensitive-image-data) + ,(create-image + mastodon-media--sensitive-image-data nil t) + sensitive-state hidden image-data ,image)))) + +(defun mastodon-media--process-full-sized-image-response (status-plist url) + ;; FIXME: refactor this with but not into + ;; `mastodon-media--process-image-response'. + "Callback function processing the `url-retrieve' response for URL. +URL is a full-sized image URL attached to a timeline image. +STATUS-PLIST is a plist of status events as per `url-retrieve'." + (if-let (error-response (plist-get status-plist :error)) + (user-error "error in loading image: %S" error-response) + (when mastodon-media--enable-image-caching + (unless (url-is-cached url) ;; cache if not already cached + (url-store-in-cache))) + ;; thanks to rahguzar for this idea: + ;; https://codeberg.org/martianh/mastodon.el/issues/540 + (let* ((handle (mm-dissect-buffer t)) + (image (mm-get-image handle)) + (str (image-property image :data))) + (with-current-buffer (get-buffer-create "*masto-image*") + (let ((inhibit-read-only t)) + (erase-buffer) + (insert-image image str) + (special-mode) ; prevent image-mode loop bug + (image-mode) + (goto-char (point-min)) + (switch-to-buffer-other-window (current-buffer)) + (image-transform-fit-both)))))) + +(defun mastodon-media--image-or-cached (url process-fun args) + "Fetch URL from cache or fro host. +Call PROCESS-FUN on it with ARGS, a list of callback args as +specified by `url-retrieve'." + (if (and mastodon-media--enable-image-caching + (url-is-cached url)) ;; if cached, decompress and use: + (with-current-buffer (url-fetch-from-cache url) + (set-buffer-multibyte nil) + (goto-char (point-min)) + (zlib-decompress-region + (goto-char (search-forward "\n\n")) (point-max)) + (apply process-fun args)) ;; no status-plist arg from cache + ;; fetch as usual and process-image-response will cache it: + ;; cbargs fun will be called with status-plist by url-retrieve: + (url-retrieve url process-fun (cdr args)))) + +(defun mastodon-media--load-image-from-url (url media-type start region-length) + "Take a URL and MEDIA-TYPE and load the image asynchronously. +MEDIA-TYPE is a symbol and either `avatar' or `media-link'. +START is the position where we start loading the image. +REGION-LENGTH is the range from start to propertize." + (let ((image-options + (when (mastodon-tl--image-trans-check) + (cond ((eq media-type 'avatar) + `(:height ,mastodon-media--avatar-height)) + ((eq media-type 'media-link) + `(:max-height ,mastodon-media--preview-max-height))))) + (buffer (current-buffer)) + (marker (copy-marker start)) + (url-show-status nil)) ; stop url.el from spamming us about connecting + (condition-case nil + ;; catch errors in url-retrieve to not break our caller + (mastodon-media--image-or-cached + url + #'mastodon-media--process-image-response + (list nil url marker image-options region-length)) + (error (with-current-buffer buffer + ;; TODO: Add retries + (put-text-property marker (+ marker region-length) + 'media-state 'loading-failed) + :loading-failed))))) + +(defun mastodon-media--select-next-media-line (end-pos) + "Find coordinates of the next media to load before END-POS. +Returns the list of (`start' . `end', `media-symbol') points of +that line and string found or nil no more media links were +found." + (let ((next-pos (point))) + (while + (and + (setq next-pos (next-single-property-change next-pos 'media-state)) + (or (not (eq 'needs-loading (get-text-property next-pos 'media-state))) + (null (get-text-property next-pos 'media-url)) + (null (get-text-property next-pos 'media-type)))) + ;; do nothing - the loop will proceed + ) + (when (and next-pos (< next-pos end-pos)) + (let ((media-type (get-text-property next-pos 'media-type))) + (cond + ((eq media-type 'avatar) ; avatars are one character + (list next-pos (+ next-pos 1) 'avatar)) + ((eq media-type 'media-link) ; media links are 5 characters: [img] + (list next-pos (+ next-pos 5) 'media-link))))))) + +(defun mastodon-media--valid-link-p (link) + "Check if LINK is valid. +Checks to make sure the missing string has not been returned." + (and link + (> (length link) 8) + (or (string= "http://" (substring link 0 7)) + (string= "https://" (substring link 0 8))))) + +(defun mastodon-media--inline-images (search-start search-end) + "Find all `Media_Links:' in the range from SEARCH-START to SEARCH-END. +Replace them with the referenced image." + (save-excursion + (goto-char search-start) + (let (line-details) + (while (setq line-details + (mastodon-media--select-next-media-line search-end)) + (let* ((start (car line-details)) + (end (cadr line-details)) + (media-type (cadr (cdr line-details))) + (type (get-text-property start 'mastodon-media-type)) + (image-url (get-text-property start 'media-url))) + (if (not (mastodon-media--valid-link-p image-url)) + ;; mark it at least as not needing loading any more + (put-text-property start end 'media-state 'invalid-url) + ;; proceed to load this image asynchronously + (put-text-property start end 'media-state 'loading) + (mastodon-media--load-image-from-url + image-url media-type start (- end start)) + (when (or (string= type "gifv") + (string= type "video")) + (mastodon-media--moving-image-overlay start end)))))))) + +;; (defvar-local mastodon-media--overlays nil +;; "Holds a list of overlays in the buffer.") + +(defun mastodon-media--moving-image-overlay (start end) + "Add play symbol overlay to moving image media items. +START and END are the beginning and end of the media item to overlay." + (let ((ov (make-overlay start end))) + (overlay-put + ov + 'after-string + (propertize "" + 'help-echo "Video" + 'face + '((:height 3.5 :inherit font-lock-comment-face)))))) +;; (cl-pushnew ov mastodon-media--overlays))) + +(defun mastodon-media--get-avatar-rendering (avatar-url) + "Return the string to be written that renders the avatar at AVATAR-URL." + ;; We use just an empty space as the textual representation. + ;; This is what a user will see on a non-graphical display + ;; where not showing an avatar at all is preferable. + (let ((image-options (when (mastodon-tl--image-trans-check) + `(:height ,mastodon-media--avatar-height)))) + (concat + (propertize " " + 'media-url avatar-url + 'media-state 'needs-loading + 'media-type 'avatar + 'display + (apply #'create-image mastodon-media--generic-avatar-data + ;; inbuilt scaling in 27.1 + (when (version< emacs-version "27.1") + (when image-options 'imagemagick)) + t image-options)) + " "))) + +(defun mastodon-media--get-media-link-rendering + (media-url &optional full-remote-url type caption sensitive) + "Return the string to be written that renders the image at MEDIA-URL. +FULL-REMOTE-URL is used for `shr-browse-image'. +TYPE is the attachment's type field on the server. +CAPTION is the image caption if provided. +SENSITIVE is a flag from the item's JSON data." + (let* ((help-echo-base + (substitute-command-keys + (concat "\\`RET'/\\`i': load full image (prefix: copy URL), \\`+'/\\`-': zoom,\ + \\`r': rotate, \\`o': save preview" + (when (not (eq sensitive :json-false)) + ", \\`S': toggle sensitive media")))) + (help-echo (if caption + (concat help-echo-base + "\n\"" caption "\"") + help-echo-base))) + (concat + (mastodon-tl--propertize-img-str-or-url + "[img]" media-url full-remote-url type help-echo + (create-image mastodon-media--generic-broken-image-data nil t) + nil caption sensitive) + " "))) + +(provide 'mastodon-media) +;;; mastodon-media.el ends here diff --git a/elpa/mastodon-20241202.1839/mastodon-notifications.el b/elpa/mastodon-20241202.1839/mastodon-notifications.el new file mode 100644 index 00000000..c3b71beb --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-notifications.el @@ -0,0 +1,653 @@ +;;; mastodon-notifications.el --- Notification functions for mastodon.el -*- lexical-binding: t -*- + +;; Copyright (C) 2017-2019 Johnson Denen +;; Copyright (C) 2020-2024 Marty Hiatt +;; Author: Johnson Denen +;; Marty Hiatt +;; Maintainer: Marty Hiatt +;; Homepage: https://codeberg.org/martianh/mastodon.el + +;; This file is not part of GNU Emacs. + +;; This file is part of mastodon.el. + +;; mastodon.el 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. + +;; mastodon.el 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 mastodon.el. If not, see . + +;;; Commentary: + +;; mastodon-notification.el provides notification functions for Mastodon. + +;;; Code: + +(require 'subr-x) +(require 'cl-lib) +(require 'mastodon-widget) + +(autoload 'mastodon-http--api "mastodon-http") +(autoload 'mastodon-http--get-params-async-json "mastodon-http") +(autoload 'mastodon-http--post "mastodon-http") +(autoload 'mastodon-http--triage "mastodon-http") +(autoload 'mastodon-media--inline-images "mastodon-media") +(autoload 'mastodon-tl--byline "mastodon-tl") +(autoload 'mastodon-tl--byline-author "mastodon-tl") +(autoload 'mastodon-tl--clean-tabs-and-nl "mastodon-tl") +(autoload 'mastodon-tl--content "mastodon-tl") +(autoload 'mastodon-tl--field "mastodon-tl") +(autoload 'mastodon-tl--find-property-range "mastodon-tl") +(autoload 'mastodon-tl--has-spoiler "mastodon-tl") +(autoload 'mastodon-tl--init "mastodon-tl") +(autoload 'mastodon-tl--property "mastodon-tl") +(autoload 'mastodon-tl--reload-timeline-or-profile "mastodon-tl") +(autoload 'mastodon-tl--spoiler "mastodon-tl") +(autoload 'mastodon-tl--item-id "mastodon-tl") +(autoload 'mastodon-tl--update "mastodon-tl") +(autoload 'mastodon-views--view-follow-requests "mastodon-views") +(autoload 'mastodon-tl--current-filters "mastodon-views") +(autoload 'mastodon-tl--render-text "mastodon-tl") +(autoload 'mastodon-notifications-get "mastodon") +(autoload 'mastodon-tl--byline-uname-+-handle "mastodon-tl") +(autoload 'mastodon-tl--byline-handle "mastodon-tl") +(autoload 'mastodon-http--get-json "mastodon-http") +(autoload 'mastodon-media--get-avatar-rendering "mastodon-media") +(autoload 'mastodon-tl--image-trans-check "mastodon-tl") +(autoload 'mastodon-tl--symbol "mastodon-tl") +(autoload 'mastodon-tl--display-or-uname "mastodon-tl") +(autoload 'mastodon-tl--goto-next-item "mastodon-tl") +(autoload 'mastodon-tl--buffer-type-eq "mastodon-tl") +(autoload 'mastodon-tl--buffer-property "mastodon-tl") + +;; notifications defcustoms moved into mastodon.el +;; as some need to be available without loading this file + +(defvar mastodon-tl--buffer-spec) +(defvar mastodon-tl--display-media-p) +(defvar mastodon-mode-map) +(defvar mastodon-tl--fold-toots-at-length) +(defvar mastodon-tl--show-avatars) +(defvar mastodon-profile-note-in-foll-reqs) +(defvar mastodon-profile-note-in-foll-reqs-max-length) +(defvar mastodon-group-notifications) +(defvar mastodon-notifications-grouped-names-count) + +(defvar mastodon-notifications--types + '("all" "favourite" "reblog" "mention" "poll" + "follow_request" "follow" "status" "update") + ;; "severed_relationships" "moderation_warning") + "A list of notification types according to their name on the server, plus \"all\".") + +(defvar mastodon-notifications--filter-types-alist + '(("all" . mastodon-notifications-get) + ("favourite" . mastodon-notifications--get-favourites) + ("reblog" . mastodon-notifications--get-boosts) + ("mention" . mastodon-notifications--get-mentions) + ("poll" . mastodon-notifications--get-polls) + ("follow_request" . mastodon-notifications--get-follow-requests) + ("follow" . mastodon-notifications--get-follows) + ("status" . mastodon-notifications--get-statuses) + ("update" . mastodon-notifications--get-edits)) + "An alist of notification types and their corresponding load functions. +Notification types are named according to their name on the server.") + +(defvar mastodon-notifications--response-alist + '(("Followed" . "you") + ("Favourited" . "your post") + ("Boosted" . "your post") + ("Mentioned" . "you") + ("Posted a poll" . "that has now ended") + ("Requested to follow" . "you") + ("Posted" . "a post") + ("Edited" . "their post")) + "Alist of subjects for notification types.") + +(defvar mastodon-notifications--map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map mastodon-mode-map) + (define-key map (kbd "a") #'mastodon-notifications--follow-request-accept) + (define-key map (kbd "j") #'mastodon-notifications--follow-request-reject) + (define-key map (kbd "C-k") #'mastodon-notifications--clear-current) + (define-key map (kbd "C-c C-c") #'mastodon-notifications--cycle-type) + map) + "Keymap for viewing notifications.") + +(defun mastodon-notifications--byline-action-str (message) + "Return an action (top) byline string for TOOT with MESSAGE." + (concat " " + (propertize message 'face 'mastodon-boosted-face) + " " (cdr (assoc message mastodon-notifications--response-alist)) + "\n")) + +(defun mastodon-notifications--follow-request-process (&optional reject) + "Process the follow request at point. +With no argument, the request is accepted. Argument REJECT means +reject the request. Can be called in notifications view or in +follow-requests view." + (if (not (mastodon-tl--find-property-range 'item-json (point))) + (user-error "No follow request at point?") + (let* ((item-json (mastodon-tl--property 'item-json)) + (f-reqs-view-p (string= "follow_requests" + (plist-get mastodon-tl--buffer-spec 'endpoint))) + (f-req-p (or (string= "follow_request" + (mastodon-tl--property 'notification-type + :no-move)) + f-reqs-view-p))) + (if (not f-req-p) + (user-error "No follow request at point?") + (let-alist (or (alist-get 'account item-json) ;notifs + item-json) ;f-reqs + (if (not .id) + (user-error "No account result at point?") + (let ((response + (mastodon-http--post + (mastodon-http--api + (format "follow_requests/%s/%s" + .id (if reject "reject" "authorize")))))) + (mastodon-http--triage + response + (lambda (_) + (if f-reqs-view-p + (mastodon-views--view-follow-requests) + (mastodon-tl--reload-timeline-or-profile)) + (message "Follow request of %s (@%s) %s!" + .username .acct (if reject "rejected" "accepted"))))))))))) + +(defun mastodon-notifications--follow-request-accept () + "Accept a follow request. +Can be called in notifications view or in follow-requests view." + (interactive) + (mastodon-notifications--follow-request-process)) + +(defun mastodon-notifications--follow-request-reject () + "Reject a follow request. +Can be called in notifications view or in follow-requests view." + (interactive) + (mastodon-notifications--follow-request-process :reject)) + +(defun mastodon-notifications--comment-note-text (str) + "Add comment face to all text in STR with `shr-text' face only." + (with-temp-buffer + (insert str) + (goto-char (point-min)) + (let (prop) + (while (setq prop (text-property-search-forward 'face 'shr-text t)) + (add-text-properties (prop-match-beginning prop) + (prop-match-end prop) + '(face (font-lock-comment-face shr-text))))) + (buffer-string))) + +(defvar mastodon-notifications-grouped-types + '(follow reblog favourite) + "List of notification types for which grouping is implemented.") + +(defvar mastodon-notifications--action-alist + '((reblog . "Boosted") + (favourite . "Favourited") + (follow_request . "Requested to follow") + (follow . "Followed") + (mention . "Mentioned") + (status . "Posted") + (poll . "Posted a poll") + (update . "Edited")) + "Action strings keyed by notification type. +Types are those of the Mastodon API.") + +(defun mastodon-notifications--alist-by-value (str field json) + "From JSON, return the alist whose FIELD value matches STR. +JSON is a list of alists." + (cl-some (lambda (y) + (when (string= str (alist-get field y)) + y)) + json)) + +(defun mastodon-notifications--group-accounts (ids json) + "For IDS, return account data in JSON." + (cl-loop + for x in ids + collect (mastodon-notifications--alist-by-value x 'id json))) + +(defun mastodon-notifications--severance-body (group) + "Return a body for a severance notification GROUP." + ;; FIXME: actually implement this when we encounter one in the wild! + (let-alist (alist-get 'event group) + (concat .type ": " + .target_name + "\nRelationships affected: " + .relationships_count))) + +(defun mastodon-notifications--mod-warning-body (group) + "Return a body for a moderation warning notification GROUP." + (let-alist (alist-get 'moderation_warning group) + (concat .action ": " + .text + "\nStatuses: " + .status_ids + "\nfor account: " + .target_account))) + +(defun mastodon-notifications--format-note (note) + "Format for a NOTE, a non-grouped notification." + (let* ((type (intern (alist-get 'type note))) + (profile-note + (when (eq 'follow_request type) + (let ((str (mastodon-tl--field + 'note + (mastodon-tl--field 'account note)))) + (if mastodon-profile-note-in-foll-reqs-max-length + (string-limit str mastodon-profile-note-in-foll-reqs-max-length) + str)))) + (status (mastodon-tl--field 'status note)) + (follower (alist-get 'account note)) + (follower-name (or (alist-get 'display_name follower) + (alist-get 'username follower))) + (filtered (mastodon-tl--field 'filtered status)) + (filters (when filtered + (mastodon-tl--current-filters filtered)))) + (if (and filtered (assoc "hide" filters)) + nil + (mastodon-notifications--insert-note + ;; toot + ;; should always be note, otherwise notif data not avail + ;; later on: + note + ;; body + (mastodon-notifications--body-arg + type filters status profile-note follower-name) + ;; action-byline (top) + (mastodon-notifications--action-byline + type nil nil note follower-name) + ;; base toot (always provide) + status + nil nil nil type)))) + +(defun mastodon-notifications--format-group-note (group status accounts) + "Format for a GROUP notification. +STATUS is the status's JSON. +ACCOUNTS is data of the accounts that have reacted to the notification." + (let ((folded nil)) + ;; FIXME: apply/refactor filtering as per/with `mastodon-tl--toot' + (let-alist group + (let* ((type (intern .type)) + (profile-note + (when (member type '(follow_request)) + (let ((str (mastodon-tl--field 'note (car accounts)))) + (if mastodon-profile-note-in-foll-reqs-max-length + (string-limit str mastodon-profile-note-in-foll-reqs-max-length) + str)))) + (follower (when (member type '(follow follow_request)) + (car accounts))) + (follower-name (or (alist-get 'display_name follower) + (alist-get 'username follower))) + (filtered (mastodon-tl--field 'filtered status)) + (filters (when filtered + (mastodon-tl--current-filters filtered)))) + (unless (and filtered (assoc "hide" filters)) + (mastodon-notifications--insert-note + ;; toot + (if (member type '(follow follow_request)) + follower + status) + ;; body + (mastodon-notifications--body-arg + type filters status profile-note follower-name group) + ;; action-byline + (mastodon-notifications--action-byline + type accounts group) + ;; base toot (no need for update/poll/?) + (when (member type '(favourite reblog)) + status) + folded group accounts)))))) + +(defun mastodon-notifications--action-byline + (type &optional accounts group note follower-name) + "Return an action (top) byline for notification of TYPE. +ACCOUNTS and GROUP group are used by grouped notifications. +NOTE and FOLLOWER-NAME are used for non-grouped notifs." + (let ((action-str + (unless (member type '(follow follow_request mention)) + (downcase + (mastodon-notifications--byline-action-str + (alist-get type mastodon-notifications--action-alist))))) + (action-symbol (if (eq type 'mention) + "" + (mastodon-tl--symbol type))) + (action-authors + (if (member type '(follow follow_request mention)) + "" ;; mentions are normal statuses + (if group + (mastodon-notifications--byline-accounts accounts group) + (mastodon-tl--byline-handle note nil + follower-name + 'mastodon-display-name-face))))) + (propertize + (concat action-symbol " " action-authors action-str) + 'byline-top t))) + +(defun mastodon-notifications--body-arg + (type &optional filters status profile-note follower-name group) + "TYPE is a symbol, a member of `mastodon-notifiations--types'. +FILTERS STATUS PROFILE-NOTE FOLLOWER-NAME GROUP." + (let ((body + (if-let ((match (assoc "warn" filters))) + (mastodon-tl--spoiler status (cadr match)) + (mastodon-tl--clean-tabs-and-nl + (cond ((mastodon-tl--has-spoiler status) + (mastodon-tl--spoiler status)) + ((eq type 'follow_request) + (mastodon-tl--render-text profile-note)) + (t (mastodon-tl--content status))))))) + (cond + ((eq type 'follow) + (propertize "Congratulations, you have a new follower!" + 'face 'default)) + ((eq type 'follow_request) + (concat + (propertize (format "You have a follow request from %s" + follower-name) + 'face 'default) + (when mastodon-profile-note-in-foll-reqs + (concat + ":\n" + (mastodon-notifications--comment-note-text body))))) + ((eq type 'severed_relationships) + (mastodon-notifications--severance-body group)) + ((eq type 'moderation_warning) + (mastodon-notifications--mod-warning-body group)) + ((member type '(favourite reblog)) + (propertize + (mastodon-notifications--comment-note-text body))) + (t body)))) + +(defun mastodon-notifications--insert-note + (toot body action-byline + &optional base-toot unfolded group accounts type) + "Display the content and byline of timeline element TOOT. +BODY will form the section of the toot above the byline. +AUTHOR-BYLINE is an optional function for adding the author +portion of the byline that takes one variable. By default it is +`mastodon-tl--byline-author'. +ACTION-BYLINE is a string, obtained by calling +`mastodon-notifications--action-byline'. +BASE-TOOT is the JSON of the toot responded to. +UNFOLDED is a boolean meaning whether to unfold or fold item if +foldable. +GROUP is the notification group data. +ACCOUNTS is the notification accounts data. +TYPE is notification type, used for non-group notifs." + (let* ((type (if type + (symbol-name type) ;; non-group + (alist-get 'type group))) + (toot-foldable + (and mastodon-tl--fold-toots-at-length + (length> body mastodon-tl--fold-toots-at-length))) + (ts ;; types listed here use base item timestamp, else we use + ;; group's latest timestamp: + (when (and group + (not + (member type '("favourite" "reblog" "edit" "poll")))) + (mastodon-tl--field 'latest_page_notification_at group)))) + (insert + (propertize ;; top byline, body + byline: + (concat + (if (equal type "mention") ;; top (action) byline + "" + action-byline) + (propertize body ;; body only + 'toot-body t) ;; includes newlines etc. for folding + "\n" + ;; actual byline: + (mastodon-tl--byline toot nil nil base-toot group ts)) + 'item-type 'toot ;; for nav, actions, etc. + 'item-id (or (alist-get 'page_max_id group) ;; newest notif + (alist-get 'id toot)) ; toot id + 'base-item-id (mastodon-tl--item-id + ;; if status is a notif, get id from base-toot + ;; (-tl--item-id toot) will not work here: + (or base-toot + toot)) ; else normal toot with reblog check + 'item-json toot + 'base-toot base-toot + 'cursor-face 'mastodon-cursor-highlight-face + 'toot-foldable toot-foldable + 'toot-folded (and toot-foldable (not unfolded)) + ;; grouped notifs data: + 'notification-type type + 'notification-id (alist-get 'group_key group) + 'notification-group group + 'notification-accounts accounts + ;; for pagination: + 'notifications-min-id (alist-get 'page_min_id group) + 'notifications-max-id (alist-get 'page_max_id group)) + "\n"))) + +(defun mastodon-notifications--byline-accounts + (accounts group &optional avatar) + "Propertize author byline ACCOUNTS. +GROUP is the group notification data. +When AVATAR, include the account's avatar image. +When DOMAIN, force inclusion of user's domain in their handle." + (let ((total (alist-get 'notifications_count group)) + (accts mastodon-notifications-grouped-names-count)) + (concat + (string-trim ;; remove trailing newline + (cl-loop + for account in accounts + repeat accts + concat + (let-alist account + (concat + ;; avatar insertion moved up to `mastodon-tl--byline' by + ;; default to be outside 'byline propt. + (when (and avatar ; used by `mastodon-profile--format-user' + mastodon-tl--show-avatars + mastodon-tl--display-media-p + (mastodon-tl--image-trans-check)) + (mastodon-media--get-avatar-rendering .avatar)) + (let ((uname (mastodon-tl--display-or-uname account))) + (mastodon-tl--byline-handle account nil + uname 'mastodon-display-name-face)) + ", "))) + nil ", ") + (if (< accts total) + (let ((diff (- total accts))) + (propertize ;; help-echo remaining notifs authors: + (format " and %s other%s" diff (if (= 1 diff) "" "s")) + 'help-echo (mapconcat (lambda (a) + (propertize (alist-get 'username a) + 'face 'mastodon-display-name-face)) + (cddr accounts) ;; not first two + ", "))))))) + +(defun mastodon-notifications--render (json no-group) + "Display grouped notifications in JSON. +NO-GROUP means don't render grouped notifications." + ;; (setq masto-grouped-notifs json) + (if no-group + (cl-loop for x in json + do (mastodon-notifications--format-note x)) + (let ((groups (alist-get 'notification_groups json))) + (cl-loop + for g in groups + for start-pos = (point) + for accounts = (mastodon-notifications--group-accounts + (alist-get 'sample_account_ids g) + (alist-get 'accounts json)) + for status = (mastodon-notifications--alist-by-value + (or (alist-get 'status_id g) + ;; if no status_id, just try the first item? + (alist-get 'id + (car + (alist-get 'statuses json)))) + 'id + (alist-get 'statuses json)) + do (mastodon-notifications--format-group-note g status accounts) + (when mastodon-tl--display-media-p + ;; images-in-notifs custom is handeld in + ;; `mastodon-tl--media-attachment', not here + (mastodon-media--inline-images start-pos (point))))))) + +(defun mastodon-notifications--timeline (json &optional type) + "Format JSON in Emacs buffer. +Optionally specify TYPE." + (if (seq-empty-p json) + (user-error "Looks like you have no (more) notifications for now") + (mastodon-widget--create + "Filter" mastodon-notifications--types + (or type "all") + (lambda (widget &rest _ignore) + (let ((value (widget-value widget))) + (mastodon-notifications--get-type value))) + :newline) + (insert "\n") + (mastodon-notifications--render json (not mastodon-group-notifications)) + (goto-char (point-min)) + (mastodon-tl--goto-next-item))) + +(defun mastodon-notifications--get-type (&optional type) + "Read a notification type and load its timeline. +Optionally specify TYPE." + (let ((choice (or type + (completing-read + "View notifications: " + mastodon-notifications--filter-types-alist)))) + (funcall (alist-get + choice mastodon-notifications--filter-types-alist + nil nil #'equal)))) + +(defun mastodon-notifications--cycle-type (&optional prefix) + "Cycle the current notifications view. +With arg PREFIX, `completing-read' a type and load it." + (interactive "P") + ;; FIXME: do we need a sept buffer-type result for all notifs views? + (if (not (or (mastodon-tl--buffer-type-eq 'notifications) + (mastodon-tl--buffer-type-eq 'mentions))) + (user-error "Not in a notifications view") + (let* ((choice + (if prefix + (completing-read "Notifs by type: " + mastodon-notifications--types) + (mastodon-notifications--get-next-type))) + (fun (alist-get choice mastodon-notifications--filter-types-alist + nil nil #'equal))) + (funcall fun)))) + +(defun mastodon-notifications--get-next-type () + "Return the next notif type based on current buffer spec." + (let* ((update-params (mastodon-tl--buffer-property + 'update-params nil :no-error)) + (type (alist-get "types[]" update-params nil nil #'equal))) + (if (not update-params) + (cadr mastodon-notifications--types) + (or (cadr (member type mastodon-notifications--types)) + (car mastodon-notifications--types))))) + +(defun mastodon-notifications--get-mentions () + "Display mention notifications in buffer." + (interactive) + (mastodon-notifications-get "mention" "mentions")) + +(defun mastodon-notifications--get-favourites () + "Display favourite notifications in buffer." + (interactive) + (mastodon-notifications-get "favourite" "favourites")) + +(defun mastodon-notifications--get-boosts () + "Display boost notifications in buffer." + (interactive) + (mastodon-notifications-get "reblog" "boosts")) + +(defun mastodon-notifications--get-polls () + "Display poll notifications in buffer." + (interactive) + (mastodon-notifications-get "poll" "polls")) + +(defun mastodon-notifications--get-statuses () + "Display status notifications in buffer. +Status notifications are created when you call +`mastodon-tl--enable-notify-user-posts'." + (interactive) + (mastodon-notifications-get "status" "statuses")) + +(defun mastodon-notifications--get-follows () + "Display follow notifications in buffer." + (interactive) + (mastodon-notifications-get "follow" "follows")) + +(defun mastodon-notifications--get-follow-requests () + "Display follow request notifications in buffer." + (interactive) + (mastodon-notifications-get "follow_request" "follow-requests")) + +(defun mastodon-notifications--get-edits () + "Display edited post notifications in buffer." + (interactive) + (mastodon-notifications-get "update" "edits")) + +(defun mastodon-notifications--filter-types-list (type) + "Return a list of notification types with TYPE removed." + (remove type mastodon-notifications--types)) + +(defun mastodon-notifications--clear-all () + "Clear all notifications." + (interactive) + (when (y-or-n-p "Clear all notifications?") + (let ((response + (mastodon-http--post (mastodon-http--api "notifications/clear")))) + (mastodon-http--triage + response (lambda (_) + (when mastodon-tl--buffer-spec + (mastodon-tl--reload-timeline-or-profile)) + (message "All notifications cleared!")))))) + +(defun mastodon-notifications--clear-current () + "Dismiss the notification at point." + (interactive) + (let* ((id (or (or (mastodon-tl--property 'notification-id) ;; grouped + (mastodon-tl--property 'item-id) + (mastodon-tl--field + 'id + (mastodon-tl--property 'item-json))))) + (endpoint (mastodon-http--api + (format "notifications/%s/dismiss" id) + "v2")) + (response (mastodon-http--post endpoint))) + (mastodon-http--triage + response (lambda (_) + (when mastodon-tl--buffer-spec + (mastodon-tl--reload-timeline-or-profile)) + (message "Notification dismissed!"))))) + +(defun mastodon-notifications--get-single-notif () + "Return a single notification JSON for v2 notifs." + (interactive) + (let* ((id (mastodon-tl--property + 'notification-id)) ;; grouped, doesn't work for ungrouped! + ;; (key (format "ungrouped-%s" + ;; (mastodon-tl--property 'item-id))) + (endpoint (mastodon-http--api + (format "notifications/%s" id) + "v2")) + (response (mastodon-http--get-json endpoint))) + (mastodon-http--triage + response (lambda (_) + (message "%s" (prin1-to-string response)))))) + +(defun mastodon-notifications--get-unread-count () + "Return the number of unread notifications for the current account." + ;; params: limit - max 1000, default 100, types[], exclude_types[], account_id + (let* ((endpoint "notifications/unread_count") + (url (mastodon-http--api endpoint)) + (resp (mastodon-http--get-json url))) + (alist-get 'count resp))) + +(provide 'mastodon-notifications) +;;; mastodon-notifications.el ends here diff --git a/elpa/mastodon-20241202.1839/mastodon-pkg.el b/elpa/mastodon-20241202.1839/mastodon-pkg.el new file mode 100644 index 00000000..d3d938d4 --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-pkg.el @@ -0,0 +1,13 @@ +;; -*- no-byte-compile: t; lexical-binding: nil -*- +(define-package "mastodon" "20241202.1839" + "Client for fediverse services using the Mastodon API." + '((emacs "28.1") + (request "0.3.0") + (persist "0.4") + (tp "0.6")) + :url "https://codeberg.org/martianh/mastodon.el" + :commit "10be1f9c2845a6012cee84b68dc566ea92df40a6" + :revdesc "10be1f9c2845" + :authors '(("Johnson Denen" . "johnson.denen@gmail.com") + ("Marty Hiatt" . "mousebot@disroot.org")) + :maintainers '(("Marty Hiatt" . "mousebot@disroot.org"))) diff --git a/elpa/mastodon-20241202.1839/mastodon-profile.el b/elpa/mastodon-20241202.1839/mastodon-profile.el new file mode 100644 index 00000000..ee3f3d23 --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-profile.el @@ -0,0 +1,1094 @@ +;;; mastodon-profile.el --- Functions for inspecting Mastodon profiles -*- lexical-binding: t -*- + +;; Copyright (C) 2017-2019 Johnson Denen +;; Copyright (C) 2020-2024 Marty Hiatt +;; Author: Johnson Denen +;; Marty Hiatt +;; Maintainer: Marty Hiatt +;; Homepage: https://codeberg.org/martianh/mastodon.el + +;; This file is not part of GNU Emacs. + +;; This file is part of mastodon.el. + +;; mastodon.el 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. + +;; mastodon.el 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 mastodon.el. If not, see . + +;;; Commentary: + +;; mastodon-profile.el generates a stream of users toots. +;; To add +;; - Option to follow +;; - wheather they follow you or not +;; - Show only Media + +;;; Code: +(require 'seq) +(require 'cl-lib) +(require 'persist) +(require 'parse-time) +(require 'mastodon-http) +(eval-when-compile + (require 'mastodon-tl)) +(require 'mastodon-widget) + +(autoload 'mastodon-auth--get-account-id "mastodon-auth") +(autoload 'mastodon-auth--get-account-name "mastodon-auth.el") +(autoload 'mastodon-http--api "mastodon-http.el") +(autoload 'mastodon-http--get-json "mastodon-http.el") +(autoload 'mastodon-http--get-json-async "mastodon-http.el") +(autoload 'mastodon-http--get-response "mastodon-http") +(autoload 'mastodon-http--patch "mastodon-http") +(autoload 'mastodon-http--patch-json "mastodon-http") +(autoload 'mastodon-http--post "mastodon-http.el") +(autoload 'mastodon-http--triage "mastodon-http.el") +(autoload 'mastodon-kill-window "mastodon") +(autoload 'mastodon-media--get-media-link-rendering "mastodon-media.el") +(autoload 'mastodon-media--inline-images "mastodon-media.el") +(autoload 'mastodon-mode "mastodon.el") +(autoload 'mastodon-notifications--follow-request-accept "mastodon-notifications") +(autoload 'mastodon-notifications--follow-request-reject "mastodon-notifications") +(autoload 'mastodon-search--insert-users-propertized "mastodon-search") +(autoload 'mastodon-tl--as-string "mastodon-tl.el") +(autoload 'mastodon-tl--buffer-type-eq "mastodon tl") +(autoload 'mastodon-tl--byline-author "mastodon-tl.el") +(autoload 'mastodon-tl--find-property-range "mastodon-tl.el") +(autoload 'mastodon-tl--get-link-header-from-response "mastodon-tl") +(autoload 'mastodon-tl--init "mastodon-tl.el") +(autoload 'mastodon-tl--user-handles-get "mastodon-tl") +(autoload 'mastodon-tl--map-alist "mastodon-tl") +(autoload 'mastodon-tl--map-alist-vals-to-alist "mastodon-tl") +(autoload 'mastodon-tl--profile-buffer-p "mastodon tl") +(autoload 'mastodon-tl--property "mastodon-tl.el") +(autoload 'mastodon-tl--render-text "mastodon-tl.el") +(autoload 'mastodon-tl--set-buffer-spec "mastodon-tl") +(autoload 'mastodon-tl--set-face "mastodon-tl.el") +(autoload 'mastodon-tl--symbol "mastodon-tl") +(autoload 'mastodon-tl--timeline "mastodon-tl.el") +(autoload 'mastodon-tl--toot "mastodon-tl") +(autoload 'mastodon-tl--item-id "mastodon-tl") +(autoload 'mastodon-toot--count-toot-chars "mastodon-toot") +(autoload 'mastodon-toot--get-max-toot-chars "mastodon-toot") +(autoload 'mastodon-views--add-account-to-list "mastodon-views") +(autoload 'mastodon-return-credential-account "mastodon") +(autoload 'mastodon-tl--buffer-property "mastodon-tl") +(autoload 'mastodon-search--query "mastodon-search") +(autoload 'mastodon-tl--field-status "mastodon-tl") +(autoload 'mastodon-toot--with-toot-item "mastodon-toot" nil nil 'macro) +(autoload 'mastodon-tl--toot-or-base "mastodon-tl") + +(defvar mastodon-active-user) +(defvar mastodon-tl--horiz-bar) +(defvar mastodon-tl--update-point) +(defvar mastodon-toot--max-toot-chars) +(defvar mastodon-toot--visibility) +(defvar mastodon-toot--content-nsfw) +(defvar mastodon-tl--timeline-posts-count) + +(defvar-local mastodon-profile--account nil + "The data for the account being described in the current profile buffer.") + +(defvar mastodon-profile-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-c") #'mastodon-profile--account-view-cycle) + (define-key map (kbd "C-c C-s") #'mastodon-profile--account-search) + (define-key map (kbd "C-c #") #'mastodon-profile--open-statuses-tagged) + map) + "Keymap for `mastodon-profile-mode'.") + +(define-minor-mode mastodon-profile-mode + "Toggle mastodon profile minor mode. +This minor mode is used for mastodon profile pages and adds a couple of +extra keybindings." + :init-value nil + :lighter " Profile" + :keymap mastodon-profile-mode-map + :group 'mastodon + :global nil) + +(defvar mastodon-profile-credential-account nil + "Holds the JSON data of the CredentialAccount entity. +It contains details of the current user's account.") + +(defvar mastodon-profile-acccount-preferences-data nil + "Holds the JSON data of the current user's preferences.") + +(defvar mastodon-profile-update-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-c") #'mastodon-profile--user-profile-send-updated) + (define-key map (kbd "C-c C-k") #'mastodon-profile--update-profile-note-cancel) + map) + "Keymap for `mastodon-profile-update-mode'.") + +(persist-defvar mastodon-profile-account-settings nil + "An alist of account settings saved from the server. +Other clients can change these settings on the server at any +time, so this list is not the canonical source for settings. It +is updated on entering mastodon mode and on toggle any setting it +contains. +This variable is set from data in +`mastodon-profile-credential-account' not +`mastodon-profile-account-preferences-data'.") + +(define-minor-mode mastodon-profile-update-mode + "Minor mode to update user profile." + :group 'mastodon-profile + :keymap mastodon-profile-update-mode-map + :global nil) + +(defun mastodon-profile--item-json () + "Get the next item-json." + (mastodon-tl--property 'item-json)) + +(defun mastodon-profile--make-author-buffer + (account &optional no-reblogs no-replies only-media tag max-id) + "Take an ACCOUNT json and insert a user account into a new buffer. +NO-REBLOGS means do not display boosts in statuses. +NO-REPLIES means to exlude replies. +ONLY-MEDIA means show only posts containing attachments. +TAG is a hashtag to restrict posts to. +MAX-ID is a flag to include the max_id pagination parameter." + (mastodon-profile--make-profile-buffer-for + account "statuses" #'mastodon-tl--timeline no-reblogs nil + no-replies only-media tag max-id)) + +;;; PROFILE VIEW COMMANDS + +(defvar mastodon-profile--account-view-alist + '(("statuses" . mastodon-profile--open-statuses) + ("no boosts" . mastodon-profile--open-statuses-no-reblogs) + ("no replies" . mastodon-profile--open-statuses-no-replies) + ("only media" . mastodon-profile--open-statuses-only-media) + ("followers" . mastodon-profile--open-followers) + ("following" . mastodon-profile--open-following))) + +;; TODO: we shd just load all views' data then switch coz this is slow af: +(defun mastodon-profile--account-view-cycle (&optional prefix) + "Cycle through profile view: toots, toot sans boosts, followers, and following." + (interactive "P") + (if prefix + (let* ((choice + (completing-read "Profile view:" + mastodon-profile--account-view-alist)) + (fun (alist-get choice mastodon-profile--account-view-alist + nil nil #'equal))) + (funcall fun)) + (cond ((mastodon-tl--buffer-type-eq 'profile-statuses) + (mastodon-profile--open-statuses-no-reblogs)) + ((mastodon-tl--buffer-type-eq 'profile-statuses-no-boosts) + (mastodon-profile--open-statuses-no-replies)) + ((mastodon-tl--buffer-type-eq 'profile-statuses-no-replies) + (mastodon-profile--open-statuses-only-media)) + ((mastodon-tl--buffer-type-eq 'profile-statuses-only-media) + (mastodon-profile--open-followers)) + ((mastodon-tl--buffer-type-eq 'profile-followers) + (mastodon-profile--open-following)) + ((mastodon-tl--buffer-type-eq 'profile-following) + (mastodon-profile--open-statuses))))) + +(defun mastodon-profile--open-statuses () + "Open a profile showing statuses." + (interactive) + (if mastodon-profile--account + (mastodon-profile--make-author-buffer + mastodon-profile--account) + (user-error "Not in a mastodon profile"))) + +(defun mastodon-profile--open-statuses-no-replies () + "Open a profile buffer showing statuses without replies." + (interactive) + (if mastodon-profile--account + (mastodon-profile--make-author-buffer + mastodon-profile--account nil :no-replies) + (user-error "Not in a mastodon profile"))) + +(defun mastodon-profile--open-statuses-no-reblogs () + "Open a profile buffer showing statuses without reblogs." + (interactive) + (if mastodon-profile--account + (mastodon-profile--make-author-buffer + mastodon-profile--account :no-reblogs) + (user-error "Not in a mastodon profile"))) + +(defun mastodon-profile--open-statuses-only-media () + "Open a profile buffer showing only statuses with media." + (interactive) + (if mastodon-profile--account + (mastodon-profile--make-author-buffer + mastodon-profile--account nil nil :only-media) + (user-error "Not in a mastodon profile"))) + +(defun mastodon-profile--open-statuses-tagged () + "Prompt for a hashtag and display a profile with only statuses containing it." + (interactive) + (let ((tag (read-string "Statuses containing tag: "))) + (if mastodon-profile--account + (mastodon-profile--make-author-buffer + mastodon-profile--account nil nil nil tag) + (user-error "Not in a mastodon profile")))) + +(defun mastodon-profile--open-following () + "Open a profile buffer showing the accounts that current profile follows." + (interactive) + (if mastodon-profile--account + (mastodon-profile--make-profile-buffer-for + mastodon-profile--account "following" + #'mastodon-profile--format-user nil :headers) + (user-error "Not in a mastodon profile"))) + +(defun mastodon-profile--open-followers () + "Open a profile buffer showing the accounts following the current profile." + (interactive) + (if mastodon-profile--account + (mastodon-profile--make-profile-buffer-for + mastodon-profile--account "followers" + #'mastodon-profile--format-user nil :headers) + (user-error "Not in a mastodon profile"))) + +(defun mastodon-profile--view-favourites () + "Open a new buffer displaying the user's favourites." + (interactive) + (message "Loading your favourited toots...") + (mastodon-tl--init "favourites" "favourites" + 'mastodon-tl--timeline :headers)) + +(defun mastodon-profile--view-bookmarks () + "Open a new buffer displaying the user's bookmarks." + (interactive) + (message "Loading your bookmarked toots...") + (mastodon-tl--init "bookmarks" "bookmarks" + 'mastodon-tl--timeline :headers)) + +(defun mastodon-profile--add-account-to-list () + "Add account of current profile buffer to a list." + (interactive) + (if (not mastodon-profile--account) + (user-error "No profile to add?") + (let-alist mastodon-profile--account + (mastodon-views--add-account-to-list nil .id .acct)))) + +(defun mastodon-profile--account-search (query) + "Run a statuses search QUERY for the currently viewed account." + (interactive "sSearch account for: ") + (let* ((ep (mastodon-tl--buffer-property 'endpoint)) + (id (nth 1 (split-string ep "/")))) + (mastodon-search--query query "statuses" nil nil id))) + + +;;; ACCOUNT PREFERENCES + +(defun mastodon-profile--get-account-value (key function) + "Fetch KEY from data returned by FUNCTION. +If value is :json-false, return nil." + (let* ((response (funcall function)) + (value (alist-get key response))) + (if (eq value :json-false) nil value))) + +(defun mastodon-profile--get-json-value (key) + "Fetch value for KEY from account. +Account details are from `mastodon-return-credential-account'. +If value is :json-false, return nil." + (mastodon-profile--get-account-value + key #'mastodon-return-credential-account)) + +(defun mastodon-profile--get-source-values () + "Return the \"source\" preferences from the server." + (mastodon-profile--get-json-value 'source)) + +(defun mastodon-profile--get-source-value (pref) + "Return PREF erence from the account's \"source\" field." + (mastodon-profile--get-account-value + pref #'mastodon-profile--get-source-values)) + +(defun mastodon-profile--update-user-profile-note () + "Fetch user's profile note and display for editing." + (interactive) + (let* ((source (mastodon-profile--get-source-values)) + (note (alist-get 'note source)) + (buffer (get-buffer-create "*mastodon-update-profile*")) + (inhibit-read-only t) + (msg-str + (substitute-command-keys + "Edit your profile note. \\`C-c C-c' to send, \\`C-c C-k' to cancel."))) + (switch-to-buffer-other-window buffer) + (text-mode) + (mastodon-tl--set-buffer-spec (buffer-name buffer) + "accounts/verify_credentials" nil) + (setq-local header-line-format msg-str) + (mastodon-profile-update-mode t) + (insert (propertize (concat + (propertize "0" + 'note-counter t + 'display nil) + "/500 characters") + 'read-only t + 'face 'font-lock-comment-face + 'note-header t) + "\n") + (make-local-variable 'after-change-functions) + (cl-pushnew #'mastodon-profile--update-note-count after-change-functions) + (let ((start-point (point))) + (insert note) + (goto-char start-point)) + (delete-trailing-whitespace) ; remove all ^M's + (message msg-str))) + +(defun mastodon-profile--update-note-count (&rest _args) + "Display the character count of the profile note buffer." + (let* ((inhibit-read-only t) + (header-region (mastodon-tl--find-property-range 'note-header + (point-min))) + (count-region (mastodon-tl--find-property-range 'note-counter + (point-min))) + (count (number-to-string (mastodon-toot--count-toot-chars + (buffer-substring-no-properties + (cdr header-region) (point-max)))))) + (add-text-properties (car count-region) (cdr count-region) + (list 'display count)))) + +(defun mastodon-profile--update-profile-note-cancel () + "Cancel updating user profile and kill buffer and window." + (interactive) + (when (y-or-n-p "Cancel updating your profile note?") + (mastodon-kill-window))) + +(defun mastodon-profile--note-remove-header () + "Get the profile note, without the buffer header." + (let ((header-region (mastodon-tl--find-property-range 'note-header + (point-min)))) + (buffer-substring (cdr header-region) (point-max)))) + +(defun mastodon-profile--user-profile-send-updated () + "Send PATCH request with the updated profile note. +Ask for confirmation if length > 500 characters." + (interactive) + (let* ((note (mastodon-profile--note-remove-header)) + (url (mastodon-http--api "accounts/update_credentials"))) + (when (or (not (> (mastodon-toot--count-toot-chars note) 500)) + (y-or-n-p "Note is over mastodon's max for profile notes (500). Proceed?")) + (quit-window 'kill) + (mastodon-profile--user-profile-send-updated-do url note)))) + +(defun mastodon-profile--user-profile-send-updated-do (url note) + "Send PATCH request with the updated profile NOTE to URL." + (let ((response (mastodon-http--patch url `(("note" . ,note))))) + (mastodon-http--triage response + (lambda (_) (message "Profile note updated!"))))) + +(defun mastodon-profile--update-preference (pref val &optional source) + "Update account PREF erence to setting VAL. +Both args are strings. +SOURCE means that the preference is in the `source' part of the account JSON." + (let* ((url (mastodon-http--api "accounts/update_credentials")) + (pref-formatted (if source (concat "source[" pref "]") pref)) + (response (mastodon-http--patch url `((,pref-formatted . ,val))))) + (mastodon-http--triage response + (lambda (_) + (mastodon-profile--fetch-server-account-settings) + (message "Account setting %s updated to %s!" pref val))))) + +(defun mastodon-profile--get-pref (pref) + "Return PREF from `mastodon-profile-account-settings'." + (plist-get mastodon-profile-account-settings pref)) + +(defun mastodon-profile--update-preference-plist (pref val) + "Set local account preference plist preference PREF to VAL. +This is done after changing the setting on the server." + (setq mastodon-profile-account-settings + (plist-put mastodon-profile-account-settings pref val))) + +;; used in toot.el +(defun mastodon-profile--fetch-server-account-settings-maybe () + "Fetch account settings from the server. +Only do so if `mastodon-profile-account-settings' is nil." + (mastodon-profile--fetch-server-account-settings :no-force)) + +;; FIXME: this does one request per setting! should just do one request then +;; parse +(defun mastodon-profile--fetch-server-account-settings (&optional no-force) + "Fetch basic account settings from the server. +Store the values in `mastodon-profile-account-settings'. +Run in `mastodon-mode-hook'. +If NO-FORCE, only fetch if `mastodon-profile-account-settings' is nil." + (unless (and no-force mastodon-profile-account-settings) + (let ((keys '(locked discoverable display_name bot)) + (source-keys '(privacy sensitive language))) + (mapc (lambda (k) + (mastodon-profile--update-preference-plist + k (mastodon-profile--get-json-value k))) + keys) + (mapc (lambda (sk) + (mastodon-profile--update-preference-plist + sk (mastodon-profile--get-source-value sk))) + source-keys) + ;; hack for max toot chars: + (mastodon-toot--get-max-toot-chars :no-toot) + (mastodon-profile--update-preference-plist 'max_toot_chars + mastodon-toot--max-toot-chars) + ;; TODO: remove now redundant vars, replace with fetchers from the plist + (setq mastodon-toot--visibility (mastodon-profile--get-pref 'privacy) + mastodon-toot--content-nsfw (mastodon-profile--get-pref 'sensitive)) + mastodon-profile-account-settings))) + +(defun mastodon-profile--account-locked-toggle () + "Toggle the locked status of your account. +Locked means follow requests have to be approved." + (interactive) + (mastodon-profile--toggle-account-key 'locked)) + +(defun mastodon-profile--account-discoverable-toggle () + "Toggle the discoverable status of your account. +Discoverable means the account is listed in the server directory." + (interactive) + (mastodon-profile--toggle-account-key 'discoverable)) + +(defun mastodon-profile--account-bot-toggle () + "Toggle the bot status of your account." + (interactive) + (mastodon-profile--toggle-account-key 'bot)) + +(defun mastodon-profile--account-sensitive-toggle () + "Toggle the sensitive status of your account. +When enabled, statuses are marked as sensitive by default." + (interactive) + (mastodon-profile--toggle-account-key 'sensitive :source)) + +(defun mastodon-profile--toggle-account-key (key &optional source) + "Toggle the boolean account setting KEY. +SOURCE means the setting is located under \"source\" in the account JSON. +Current settings are fetched from the server." + (let* ((val (if source + (mastodon-profile--get-source-value key) + (mastodon-profile--get-json-value key))) + (prompt (format "Account setting %s is %s. Toggle?" key val))) + (when (y-or-n-p prompt) + (mastodon-profile--update-preference (symbol-name key) + (if val "false" "true") + source)))) + +(defun mastodon-profile--edit-string-value (key) + "Edit the string for account preference KEY." + (let* ((val (mastodon-profile--get-json-value key)) + (new-val (read-string (format "Edit account setting %s: " key) + val))) + (mastodon-profile--update-preference (symbol-name key) new-val))) + +(defun mastodon-profile--update-display-name () + "Update display name for your account." + (interactive) + (mastodon-profile--edit-string-value 'display_name)) + +(defun mastodon-profile--make-meta-fields-params (fields) + "Construct a parameter query string from metadata alist FIELDS. +Returns an alist." + (let ((keys + (cl-loop + for count from 1 to 5 + collect (cons (format "fields_attributes[%s][name]" count) + (format "fields_attributes[%s][value]" count))))) + (cl-loop for a-pair in keys + for b-pair in fields + append (list (cons (car a-pair) (car b-pair)) + (cons (cdr a-pair) (cdr b-pair)))))) + +(defun mastodon-profile--update-meta-fields () + "Prompt for new metadata fields information and PATCH the server." + (interactive) + (let* ((url (mastodon-http--api "accounts/update_credentials")) + (fields-updated (mastodon-profile--update-meta-fields-alist)) + (params (mastodon-profile--make-meta-fields-params fields-updated)) + (response (mastodon-http--patch url params))) + (mastodon-http--triage response + (lambda (_) + (mastodon-profile--fetch-server-account-settings) + (message "Metadata fields updated to %s!" + fields-updated))))) + +(defun mastodon-profile--update-meta-fields-alist () + "Prompt for new metadata fields information. +Returns the results as an alist." + (let ((fields-old (mastodon-profile--fields-get + nil ;; we must fetch the plaintext version: + (mastodon-profile--get-source-value 'fields)))) + ;; offer empty fields if user currently has less than four filled: + (while (< (length fields-old) 4) + (setq fields-old (append fields-old '(("" . ""))))) + (let* ((f-str "Metadata %s [%s/4] (max. 255 chars): ") + (alist + (cl-loop for f in fields-old + for x from 1 to 5 + collect + (cons (read-string (format f-str "key" x) (car f)) + (read-string (format f-str "value" x) (cdr f)))))) + (mapcar (lambda (x) + (cons (mastodon-profile--limit-to-255 (car x)) + (mastodon-profile--limit-to-255 (cdr x)))) + alist)))) + +(defun mastodon-profile--limit-to-255 (x) + "Limit string X to 255 chars max." + (if (> (length x) 255) (substring x 0 255) x)) + +;; used in tl.el and toot.el: +(defun mastodon-profile--get-preferences-pref (pref) + "Fetch PREF from the endpoint \"/preferences\". +If `mastodon-profile-acccount-preferences-data' is set, fetch +from that instead. +The endpoint only holds a few preferences. For others, see +`mastodon-profile--update-preference' and its endpoint, +\"/accounts/update_credentials.\"" + (alist-get pref + (or mastodon-profile-acccount-preferences-data + (setq mastodon-profile-acccount-preferences-data + (mastodon-http--get-json + (mastodon-http--api "preferences")))))) + +(defun mastodon-profile--view-preferences () + "View user preferences in another window." + (interactive) + (let* ((url (mastodon-http--api "preferences")) + (response (mastodon-http--get-json url)) + (buf (get-buffer-create "*mastodon-preferences*"))) + (with-mastodon-buffer buf #'special-mode :other-window + (mastodon-tl--set-buffer-spec (buffer-name buf) "preferences" nil) + (while-let ((el (pop response))) + (insert (format "%-30s %s" + (prin1-to-string (car el)) + (prin1-to-string (cdr el))) + "\n\n")) + (goto-char (point-min))))) + + +;;; PROFILE WIDGET + +(defvar mastodon-profile--view-types + '(statuses no-boosts no-replies only-media followers following tag)) + +(defvar mastodon-profile--load-funs-alist + `((statuses . mastodon-profile--open-statuses) + (no-boosts . mastodon-profile--open-statuses-no-reblogs) + (no-replies . mastodon-profile--open-statuses-no-replies) + (only-media . mastodon-profile--open-statuses-only-media) + (followers . mastodon-profile--open-followers) + (following . mastodon-profile--open-following) + (tag . mastodon-profile--open-statuses-tagged))) + +(defun mastodon-profile--view-fun-call (type) + "Call the function associated with TYPE. +Fetched from `mastodon-profile--load-funs-alist'." + (funcall + (alist-get type mastodon-profile--load-funs-alist))) + + +;;; PROFILE VIEW DETAILS + +(defun mastodon-profile--relationships-get (id) + "Fetch info about logged-in user's relationship to user with id ID." + (let* ((args `(("id[]" . ,id))) + (url (mastodon-http--api "accounts/relationships"))) + ;; FIXME: API takes array, we just get 1st + (car (mastodon-http--get-json url args)))) + +(defun mastodon-profile--fields-get (&optional account fields) + "Fetch the fields vector (aka profile metadata) from profile of ACCOUNT. +Returns an alist. +FIELDS means provide a fields vector fetched by other means." + (let ((fields (or fields (alist-get 'fields account)))) + (when fields + (mastodon-tl--map-alist-vals-to-alist 'name 'value fields)))) + +(defun mastodon-profile--fields-insert (fields) + "Format and insert field pairs (a.k.a profile metadata) in FIELDS." + (let* ((car-fields (mapcar #'car fields)) + (left-width (apply #'max (mapcar #'length car-fields)))) + (mapconcat (lambda (field) + (mastodon-tl--render-text + (concat + (format "_ %s " (car field)) + (make-string (- (+ 1 left-width) (length (car field))) ?_) + (format " :: %s" (cdr field))) + field)) ; hack to make links tabstops + fields ""))) + +(defun mastodon-profile--get-statuses-pinned (account) + "Fetch the pinned toots for ACCOUNT." + (let* ((id (alist-get 'id account)) + (args `(("pinned" . "true"))) + (url (mastodon-http--api (format "accounts/%s/statuses" id)))) + (mastodon-http--get-json url args))) + +(defun mastodon-profile--insert-statuses-pinned (pinned-statuses) + "Insert each of the PINNED-STATUSES for a given account." + (mapc (lambda (pinned-status) + (insert + (concat "\n " + (propertize " pinned " + 'face '(:inherit success :box t)) + " ")) + (mastodon-tl--toot pinned-status)) + pinned-statuses)) + +(defun mastodon-profile--follows-p (list) + "T if you have any relationship with the accounts in LIST." + (let (result) + (dolist (x list result) + (when (not (eq :json-false x)) + (setq result x))))) + +(defun mastodon-profile--render-roles (roles) + "Return a propertized string of badges for ROLES." + (mapconcat + (lambda (role) + (propertize (alist-get 'name role) + 'face `(:box t :foreground ,(alist-get 'color role)))) + roles)) + +(defun mastodon-profile--make-profile-buffer-for + (account endpoint-type update-function + &optional no-reblogs headers no-replies only-media tag max-id) + "Display profile of ACCOUNT, using ENDPOINT-TYPE and UPDATE-FUNCTION. +NO-REBLOGS means do not display boosts in statuses. +HEADERS means also fetch link headers for pagination. +NO-REPLIES means to exlude replies. +ONLY-MEDIA means show only posts containing attachments. +TAG is a hashtag to restrict posts to. +MAX-ID is a flag to include the max_id pagination parameter." + (let-alist account + (let* ((max-id-str (when max-id + (mastodon-tl--buffer-property 'max-id))) + (args `(("limit" . ,mastodon-tl--timeline-posts-count) + ,(when max-id `("max_id" . ,max-id-str)))) + (args (cond (no-reblogs + (push '("exclude_reblogs" . "t") args)) + (no-replies + (push '("exclude_replies" . "t") args)) + (only-media + (push '("only_media" . "t") args)) + (tag + (push `("tagged" . ,tag) args)) + (t args))) + (endpoint (format "accounts/%s/%s" .id endpoint-type)) + (url (mastodon-http--api endpoint)) + (buffer (concat "*mastodon-" .acct "-" + (concat endpoint-type + (cond (no-reblogs "-no-boosts") + (no-replies "-no-replies") + (only-media "-only-media") + (tag (format "-tagged-%s" tag)) + (t ""))) + "*")) + (response (if headers + (mastodon-http--get-response url args) + (mastodon-http--get-json url args))) + (json (if headers (car response) response)) + (link-header (when headers + (mastodon-tl--get-link-header-from-response + (cdr response)))) + (fields (mastodon-profile--fields-get account)) + (pinned (mastodon-profile--get-statuses-pinned account)) + (relationships (mastodon-profile--relationships-get .id))) + (with-mastodon-buffer buffer #'mastodon-mode nil + (mastodon-profile-mode) + (setq mastodon-profile--account account) + (mastodon-tl--set-buffer-spec buffer endpoint update-function + link-header args nil max-id-str) + (let* ((inhibit-read-only t)) + (insert + (propertize + (concat + "\n" + (mastodon-profile--image-from-account account 'avatar_static) + (mastodon-profile--image-from-account account 'header_static) + "\n" + (propertize .display_name 'face 'mastodon-display-name-face) + ;; roles + (when .roles + (concat " " (mastodon-profile--render-roles .roles))) + "\n" + (propertize (concat "@" .acct) 'face 'default) + (when (eq .locked t) + (concat " " (mastodon-tl--symbol 'locked))) + "\n " mastodon-tl--horiz-bar "\n" + ;; profile note: + (mastodon-tl--render-text .note account) ; account = tab-stops in profile + ;; meta fields: + (when fields + (concat "\n" (mastodon-tl--set-face + (mastodon-profile--fields-insert fields) + 'success))) + "\n" + ;; Joined date: + (propertize + (mastodon-profile--format-joined-date-string .created_at) + 'face 'success) + "\n\n") + 'profile-json account) + ;; insert counts + (mastodon-tl--set-face + (concat " " mastodon-tl--horiz-bar "\n" + " TOOTS: " (mastodon-tl--as-string .statuses_count) " | " + "FOLLOWERS: " (mastodon-tl--as-string .followers_count) " | " + "FOLLOWING: " (mastodon-tl--as-string .following_count) "\n" + " " mastodon-tl--horiz-bar "\n\n") + 'success) + ;; insert relationship (follows) + (let-alist relationships + (let* ((followsp (mastodon-profile--follows-p + (list .requested_by .following .followed_by))) + (rels (mastodon-profile--relationships-get .id)) + (langs-filtered (if-let ((langs (alist-get 'languages rels))) + (concat " (" + (mapconcat #'identity langs " ") + ")") + ""))) + (if followsp + (mastodon-tl--set-face + (concat (when (eq .following t) + (format " | FOLLOWED BY YOU%s" langs-filtered)) + (when (eq .followed_by t) + " | FOLLOWS YOU") + (when (eq .requested_by t) + " | REQUESTED TO FOLLOW YOU") + "\n\n") + 'success) + "")))) ; for insert call + (mastodon-media--inline-images (point-min) (point)) + ;; widget items description + (mastodon-widget--create + "View" mastodon-profile--view-types + (or (mastodon-profile--current-view-type + endpoint-type no-reblogs no-replies only-media tag) + 'statuses) + (lambda (widget &rest _ignore) + (let ((value (widget-value widget))) + (mastodon-profile--view-fun-call value)))) + (insert "\n") + (setq mastodon-tl--update-point (point)))) + ;; split insert of items from insert of profile: + (with-current-buffer buffer + (let* ((inhibit-read-only t)) + ;; insert pinned toots first + (when (and pinned (string= endpoint-type "statuses")) + (mastodon-profile--insert-statuses-pinned pinned) + (setq mastodon-tl--update-point (point))) ; updates after pinned toots + ;; insert items + (funcall update-function json) + (goto-char (point-min)) + (message + (substitute-command-keys + ;; "\\[mastodon-profile--account-view-cycle]" ; not always bound? + "\\`C-c C-c' to cycle profile views: toots, no replies, no boosts,\ + only media, followers, following. +\\`C-c C-s' to search user's toots, \\`C-c \#' to search user's posts for a hashtag."))))))) + +(defun mastodon-profile--current-view-type (type no-reblogs no-replies + only-media tag) + "Return the type of current profile view. +Return a member of `mastodon-profile--view-types', based on TYPE, +NO-REBLOGS, NO-REPLIES, ONLY-MEDIA and TAG." + (cond (no-reblogs 'no-boosts) + (no-replies 'no-replies) + (only-media 'only-media) + (tag 'tag) + (t (intern type)))) + +(defun mastodon-profile--format-joined-date-string (joined) + "Format a human-readable Joined string from timestamp JOINED. +JOINED is the `created_at' field in profile account JSON, and of +the format \"2000-01-31T00:00:00.000Z\"." + (format-time-string "Joined: %d %B %Y" + (parse-iso8601-time-string joined))) + +(defun mastodon-profile--get-toot-author (&optional max-id) + "Open profile of author of toot under point. +If toot is a boost, load the profile of the author of the original item. +MAX-ID is a flag to include the max_id pagination parameter." + (interactive) + (mastodon-tl--do-if-item + (let ((json (mastodon-tl--toot-or-base + (mastodon-profile--item-json)))) + (mastodon-profile--make-author-buffer + (alist-get 'account json) + nil nil nil nil max-id)))) + +(defun mastodon-profile--image-from-account (account img-type) + "Return a avatar image from ACCOUNT. +IMG-TYPE is the JSON key from the account data." + (let ((img (alist-get img-type account))) + (unless (string= img "/avatars/original/missing.png") + (mastodon-media--get-media-link-rendering img)))) + +(defun mastodon-profile--show-user (user-handle) + "Query for USER-HANDLE from current status and show that user's profile." + (interactive + (list + (if (and (not (mastodon-tl--profile-buffer-p)) + (not (mastodon-tl--property 'item-json :no-move))) + (user-error "Looks like there's no toot or user at point?") + (let ((user-handles (mastodon-profile--extract-users-handles + (mastodon-profile--item-json)))) + (completing-read "View profile of user [choose or enter any handle]: " + user-handles + nil ; predicate + 'confirm))))) + (if (not (or ; own profile has no need for item-json test: + (string= user-handle (mastodon-auth--get-account-name)) + (mastodon-tl--profile-buffer-p) + (mastodon-tl--property 'item-json :no-move))) + (user-error "Looks like there's no toot or user at point?") + (let ((account (mastodon-profile--lookup-account-in-status + user-handle (mastodon-profile--item-json)))) + (if (not account) + (user-error "Cannot find a user with handle %S" user-handle) + (progn + (message "Loading profile of user %s..." user-handle) + (mastodon-profile--make-author-buffer account)))))) + +(defun mastodon-profile--my-profile () + "Show the profile of the currently signed in user." + (interactive) + (message "Loading your profile...") + (let ((account (mastodon-profile--account-from-id + (mastodon-auth--get-account-id)))) + (mastodon-profile--make-author-buffer account))) + +(defun mastodon-profile--format-user (tootv) + "Convert TOOTV into author-bylines and insert. +Also insert their profile note. +Used to view a user's followers and those they're following." + (let ((inhibit-read-only t)) + (unless (seq-empty-p tootv) + (mapc + (lambda (toot) + (let ((start-pos (point))) + (insert + "\n" + (propertize + (mastodon-tl--byline-author `((account . ,toot)) :avatar) + 'byline 't + 'item-id (alist-get 'id toot) + 'base-item-id (mastodon-tl--item-id toot) + 'item-json toot)) + (mastodon-media--inline-images start-pos (point)) + (insert "\n" + (propertize + (mastodon-tl--render-text (alist-get 'note toot) nil) + 'item-json toot) + "\n"))) + tootv)))) + +(defun mastodon-profile--search-account-by-handle (handle) + "Return an account based on a user's HANDLE. +If the handle does not match a search return then retun NIL." + (let* ((handle (if (string= "@" (substring handle 0 1)) + (substring handle 1 (length handle)) + handle)) + (args `(("q" . ,handle) + ("type" . "accounts"))) + (result (mastodon-http--get-json + (mastodon-http--api-v2 "search") args)) + (matching-account (seq-remove + (lambda (x) + (not (string= handle (alist-get 'acct x)))) + (alist-get 'accounts result)))) + (when (eq 1 (length matching-account)) + (elt matching-account 0)))) + +(defun mastodon-profile--account-from-id (user-id) + "Request an account object relating to a USER-ID." + (mastodon-http--get-json + (mastodon-http--api (format "accounts/%s" user-id)))) + +(defun mastodon-profile--extract-users-handles (status) + "Return all user handles found in STATUS. +These include the author, author of reblogged entries and any user mentioned." + (when status + (let ((this-account (or (alist-get 'account status) ; status is a toot + status)) ; status is a user listing + (mentions (mastodon-tl--field-status 'mentions status)) + (reblog (mastodon-tl--field-status 'reblog status))) + (seq-remove + (lambda (x) (string= x mastodon-active-user)) + (seq-filter #'stringp + (seq-uniq + (seq-concatenate + 'list + (list (alist-get 'acct this-account)) + (mastodon-profile--extract-users-handles reblog) + (mastodon-tl--map-alist 'acct mentions)))))))) + +(defun mastodon-profile--lookup-account-in-status (handle status) + "Return account for HANDLE using hints in STATUS if possible." + (let* ((this-account (alist-get 'account status)) + (reblog-account (alist-get 'account (alist-get 'reblog status))) + (mention-id (seq-some + (lambda (mention) + (when (string= handle (alist-get 'acct mention)) + (alist-get 'id mention))) + (alist-get 'mentions status)))) + (cond ((string= handle (alist-get 'acct this-account)) + this-account) + ((string= handle (alist-get 'acct reblog-account)) + reblog-account) + (mention-id + (mastodon-profile--account-from-id mention-id)) + (t + (mastodon-profile--search-account-by-handle handle))))) + +;;; REMOVE + +(defun mastodon-profile--remove-user-from-followers (&optional id) + "Remove a user from your followers. +Optionally provide the ID of the account to remove." + (interactive) + (let* ((account (unless id (mastodon-tl--property 'item-json :no-move))) + (id (or id (alist-get 'id account))) + (handle (let ((account (or account + (mastodon-profile--account-from-id id)))) + (alist-get 'acct account))) + (url (mastodon-http--api + (format "accounts/%s/remove_from_followers" id)))) + (when (y-or-n-p (format "Remove follower %s? " handle)) + (let ((response (mastodon-http--post url))) + (mastodon-http--triage response + (lambda (_) + (message "Follower %s removed!" handle))))))) + +(defun mastodon-profile--remove-from-followers-at-point () + "Prompt for a user in the item at point and remove from followers." + (interactive) + (let* ((handles (mastodon-profile--extract-users-handles + (mastodon-profile--item-json))) + (handle (completing-read "Remove from followers: " handles)) + (account (mastodon-profile--lookup-account-in-status + handle (mastodon-profile--item-json))) + (id (alist-get 'id account))) + (mastodon-profile--remove-user-from-followers id))) + +(defun mastodon-profile--remove-from-followers-list () + "Select a user from your followers and remove from followers. +Currently limited to 100 handles. If not found, try +`mastodon-search--query'." + (interactive) + (let* ((endpoint (format "accounts/%s/followers" + (mastodon-auth--get-account-id))) + (url (mastodon-http--api endpoint)) + (response (mastodon-http--get-json url `(("limit" . "100")))) + (handles (mastodon-tl--map-alist-vals-to-alist 'acct 'id response)) + (choice (completing-read "Remove from followers: " handles)) + (id (alist-get choice handles))) + (mastodon-profile--remove-user-from-followers id))) + +;;; PRIVATE NOTES + +(defun mastodon-profile--add-private-note-to-account () + "Add a private note to an account. +Can be called from a profile page or normal timeline. +Send an empty note to clear an existing one." + (interactive) + (mastodon-profile--add-or-view-private-note + 'mastodon-profile--post-private-note-to-account + "add a note to")) + +(defun mastodon-profile--post-private-note-to-account (id handle note-old) + "POST a private note onto an account ID with user HANDLE on the server. +NOTE-OLD is the text of any existing note." + (let* ((note (read-string + (format "Add private note to account %s: " handle) + note-old)) + (params `(("comment" . ,note))) + (url (mastodon-http--api (format "accounts/%s/note" id))) + (response (mastodon-http--post url params))) + (mastodon-http--triage response + (lambda (_) + (message "Private note on %s added!" handle))))) + +(defun mastodon-profile--view-account-private-note () + "Display the private note about a user." + (interactive) + (mastodon-profile--add-or-view-private-note + 'mastodon-profile--display-private-note + "view private note of" + :view)) + +(defun mastodon-profile--display-private-note (note) + "Display private NOTE in a temporary buffer." + (with-output-to-temp-buffer "*mastodon-profile-private-note*" + (let ((inhibit-read-only t)) + (princ note)))) + +(defun mastodon-profile--profile-json () + "Return the profile-json property if we are in a profile buffer." + (if (not (mastodon-tl--profile-buffer-p)) + (error "Not viewing a profile") + (save-excursion + (goto-char (point-min)) + (or (mastodon-tl--property 'profile-json :no-move) + (error "No profile data found"))))) + +(defun mastodon-profile--add-or-view-private-note (action-fun + &optional message view) + "Add or view a private note for an account. +ACTION-FUN does the adding or viewing, MESSAGE is a prompt for +`mastodon-tl--user-handles-get', VIEW is a flag." + (let* ((profile-json (mastodon-profile--profile-json)) + (handle (if (mastodon-tl--profile-buffer-p) + (alist-get 'acct profile-json) + (mastodon-tl--user-handles-get message))) + (account (if (mastodon-tl--profile-buffer-p) + profile-json + (mastodon-profile--search-account-by-handle handle))) + (id (alist-get 'id account)) + (relationships (mastodon-profile--relationships-get id)) + (note (alist-get 'note relationships))) + (if view + (if (string-empty-p note) + (user-error "No private note for %s" handle) + ;; `mastodon-profile--display-private-note' takes 1 arg: + (funcall action-fun note)) + ;; `mastodon-profile--post-private-note-to-account' takes 3 args: + (funcall action-fun id handle note)))) + +;;; FAMILIAR FOLLOWERS + +(defun mastodon-profile--show-familiar-followers () + "Show a list of familiar followers. +Familiar followers are accounts that you follow, and that follow +the given account." + (interactive) + (let* ((profile-json (mastodon-profile--profile-json)) + (handle + (if (mastodon-tl--profile-buffer-p) + (alist-get 'acct profile-json) + (mastodon-tl--user-handles-get "show familiar followers of"))) + (account (if (mastodon-tl--profile-buffer-p) + profile-json + (mastodon-profile--search-account-by-handle handle))) + (id (alist-get 'id account))) + (mastodon-profile--get-familiar-followers id))) + +(defun mastodon-profile--get-familiar-followers (id) + "Return JSON data of familiar followers for account ID." + ;; the server handles multiple IDs, but we just handle one. + (let* ((params `(("id" . ,id))) + (url (mastodon-http--api "accounts/familiar_followers")) + (json (mastodon-http--get-json url params)) + (accounts (alist-get 'accounts (car json))) ; first id + (handles (mastodon-tl--map-alist 'acct accounts))) + (if (null handles) + (user-error "Looks like there are no familiar followers for this account") + (let ((choice (completing-read "Show profile of user: " handles))) + (mastodon-profile--show-user choice))))) + +(provide 'mastodon-profile) +;;; mastodon-profile.el ends here diff --git a/elpa/mastodon-20241202.1839/mastodon-search.el b/elpa/mastodon-20241202.1839/mastodon-search.el new file mode 100644 index 00000000..5f1e9809 --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-search.el @@ -0,0 +1,393 @@ +;;; mastodon-search.el --- Search functions for mastodon.el -*- lexical-binding: t -*- + +;; Copyright (C) 2017-2019 Marty Hiatt +;; Author: Marty Hiatt +;; Maintainer: Marty Hiatt +;; Homepage: https://codeberg.org/martianh/mastodon.el + +;; This file is not part of GNU Emacs. + +;; This file is part of mastodon.el. + +;; mastodon.el 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. + +;; mastodon.el 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 mastodon.el. If not, see . + +;;; Commentary: + +;; A basic search function for mastodon.el + +;;; Code: +(require 'json) +(require 'mastodon-tl) +(require 'mastodon-widget) + +(autoload 'mastodon-auth--access-token "mastodon-auth") +(autoload 'mastodon-http--api "mastodon-http") +(autoload 'mastodon-http--get-json "mastodon-http") +(autoload 'mastodon-http--get-search-json "mastodon-http") +(autoload 'mastodon-mode "mastodon") +(autoload 'mastodon-tl--as-string "mastodon-tl") +(autoload 'mastodon-tl--as-string "mastodon-tl") +(autoload 'mastodon-tl--render-text "mastodon-tl") +(autoload 'mastodon-tl--set-buffer-spec "mastodon-tl") +(autoload 'mastodon-tl--set-face "mastodon-tl") +(autoload 'mastodon-tl--timeline "mastodon-tl") +(autoload 'mastodon-tl--toot "mastodon-tl") +(autoload 'mastodon-tl--buffer-property "mastodon-tl") +(autoload 'mastodon-http--api-v2 "mastodon-http") + +(defvar mastodon-toot--completion-style-for-mentions) +(defvar mastodon-instance-url) +(defvar mastodon-tl--link-keymap) +(defvar mastodon-tl--horiz-bar) + +;; functions for completion of mentions in mastodon-toot + +(defun mastodon-search--get-user-info-@ (account) + "Get user handle, display name and account URL from ACCOUNT." + (list (concat "@" (cdr (assoc 'acct account))) + (cdr (assoc 'url account)) + (cdr (assoc 'display_name account)))) + +(defun mastodon-search--search-accounts-query (query) + "Prompt for a search QUERY and return accounts synchronously. +Returns a nested list containing user handle, display name, and URL." + (let* ((url (mastodon-http--api "accounts/search")) + (response + (mastodon-http--get-json + url + `(("q" . ,query) ;; NB: nil can break params (but works for me) + ,(when (string= "following" + mastodon-toot--completion-style-for-mentions) + '("following" . "true"))) + :silent))) + (mapcar #'mastodon-search--get-user-info-@ response))) + +;; functions for tags completion: + +(defun mastodon-search--search-tags-query (query) + "Return an alist containing tag strings plus their URLs. +QUERY is the string to search." + (let* ((url (mastodon-http--api-v2 "search")) + (params `(("q" . ,query) ("type" . "hashtags"))) + (response (mastodon-http--get-json url params :silent)) + (tags (alist-get 'hashtags response))) + (mapcar #'mastodon-search--get-hashtag-info tags))) + +;; trending tags + +(defun mastodon-search--trending-tags () + "Display a list of tags trending on your instance." + (interactive) + (mastodon-search--view-trending "tags" + #'mastodon-search--print-tags)) + +(defun mastodon-search--trending-statuses () + "Display a list of statuses trending on your instance." + (interactive) + (mastodon-search--view-trending "statuses" + #'mastodon-tl--timeline)) + +(defun mastodon-search--trending-links () + "Display a list of links trending on your instance." + (interactive) + (mastodon-search--view-trending "links" + #'mastodon-search--render-links)) + +(defun mastodon-search--render-links (links) + "Render trending LINKS." + (cl-loop for l in links + do (mastodon-search--render-link l))) + +(defun mastodon-search--render-link (link) + "Render a trending LINK." + (let-alist link + (insert + (propertize + (mastodon-tl--render-text + (concat "" .url "\n" .title) + link) + 'item-type 'link + 'item-json link + 'shr-url .url + 'byline t ;; nav + 'help-echo + (substitute-command-keys + "\\[`mastodon-search--load-link-posts'] to view a link's timeline")) + ;; TODO: display card link author here + "\n\n"))) + +(defun mastodon-search--load-link-posts () + "Load timeline of posts containing link at point." + (interactive) + (let* ((url (mastodon-tl--property 'shr-url))) + (mastodon-tl--link-timeline url))) + +(defun mastodon-search--view-trending (type print-fun) + "Display a list of tags trending on your instance. +TYPE is a string, either tags, statuses, or links. +PRINT-FUN is the function used to print the data from the response." + (let* ((url (mastodon-http--api (format "trends/%s" type))) + ;; max for statuses = 40, for others = 20 + (limit (if (string= type "statuses") + '("limit" . "40") + '("limit" . "20"))) + (offset '(("offset" . "0"))) + (params (push limit offset)) + (data (mastodon-http--get-json url params)) + (buffer (get-buffer-create + (format "*mastodon-trending-%s*" type)))) + (with-mastodon-buffer buffer #'mastodon-mode nil + (mastodon-tl--set-buffer-spec (buffer-name buffer) + (format "trends/%s" type) + print-fun nil params) + (mastodon-search--insert-heading "trending" type) + (funcall print-fun data) + (unless (string= type "statuses") + (goto-char (point-min)))))) + +;; functions for mastodon search + +(defun mastodon-search--insert-heading (str &optional type) + "Insert STR as a heading. +Optionally add string TYPE after HEADING." + (insert + (mastodon-search--format-heading str type))) + +(defun mastodon-search--format-heading (str &optional type no-newline) + "Format STR as a heading. +Optionally add string TYPE after HEADING. +NO-NEWLINE means don't add add a newline at end." + (mastodon-tl--set-face + (concat "\n " mastodon-tl--horiz-bar "\n " + (upcase str) " " + (when type (upcase type)) "\n" + " " mastodon-tl--horiz-bar (unless no-newline "\n")) + 'success)) + +(defvar mastodon-search-types + '("statuses" "accounts" "hashtags")) + +(defun mastodon-search--query (query &optional type limit + following account-id offset) + "Prompt for a search QUERY and return accounts, statuses, and hashtags. +TYPE is a member of `mastodon-search-types'. +LIMIT is a number as string, up to 40, with 40 the default. +FOLLOWING means limit to accounts followed, for \"accounts\" type only. +A single prefix arg also sets FOLLOWING to true. +ACCOUNT-ID means limit search to that account, for \"statuses\" type only. +OFFSET is a number as string, means to skip that many results. It +is used for pagination." + ;; TODO: handle no results + (interactive "sSearch mastodon for: ") + (let* ((url (mastodon-http--api-v2 "search")) + (following (when (or following (equal current-prefix-arg '(4))) + "true")) + (type (or type + (if (equal current-prefix-arg '(4)) + "accounts" ; if FOLLOWING, must be "accounts" + (completing-read "Search type: " + mastodon-search-types nil :match)))) + (limit (or limit "40")) + (offset (or offset "0")) + (buffer (format "*mastodon-search-%s-%s*" type query)) + (params (cl-remove nil + `(("q" . ,query) + ,(when type `("type" . ,type)) + ,(when limit `("limit" . ,limit)) + ,(when offset `("offset" . ,offset)) + ,(when following `("following" . ,following)) + ,(when account-id `("account_id" . ,account-id))))) + (response (mastodon-http--get-json url params)) + (items (alist-get (intern type) response))) + (with-mastodon-buffer buffer #'mastodon-mode nil + (mastodon-search-mode) + (mastodon-search--insert-heading "search") + (mastodon-widget--create + "Results" + '(accounts hashtags statuses) + (intern type) + (lambda (widget &rest _ignore) + (let ((value (widget-value widget))) + (mastodon-search--query query (symbol-name value))))) + (insert "\n\n") + (cond ((string= type "accounts") + (mastodon-search--render-response items type buffer params + 'mastodon-views--insert-users-propertized-note + 'mastodon-views--insert-users-propertized-note)) + ((string= type "hashtags") + (mastodon-search--render-response items type buffer params + 'mastodon-search--print-tags + 'mastodon-search--print-tags)) + ((string= type "statuses") + (mastodon-search--render-response items type buffer params + #'mastodon-tl--timeline + #'mastodon-tl--timeline))) + (goto-char (point-min)) + (message + (substitute-command-keys + "\\[mastodon-search--query-cycle] to cycle result types."))))) + +(defun mastodon-search-insert-no-results (&optional thing) + "Insert a no results message for object THING." + (let ((thing (or thing "items"))) + (insert + (propertize (format "Looks like search returned no %s." thing) + 'face 'font-lock-comment-face)))) + +(defun mastodon-search--render-response (data type buffer params + insert-fun update-fun) + "Call INSERT-FUN on DATA of result TYPE if non-nil. +BUFFER, PARAMS, and UPDATE-FUN are for `mastodon-tl--buffer-spec'." + (if (not data) + (mastodon-search-insert-no-results type) + (funcall insert-fun data)) + (mastodon-tl--set-buffer-spec buffer "search" + update-fun nil params)) + +(defun mastodon-search--buf-type () + "Return search buffer type, a member of `mastodon-search-types'." + ;; called in `mastodon-tl--get-buffer-type' + (let* ((spec (mastodon-tl--buffer-property 'update-params))) + (alist-get "type" spec nil nil #'string=))) + +(defun mastodon-search--query-cycle () + "Cycle through search types: accounts, hashtags, and statuses." + (interactive) + (let* ((spec (mastodon-tl--buffer-property 'update-params)) + (type (alist-get "type" spec nil nil #'string=)) + (query (alist-get "q" spec nil nil #'string=))) + (cond ((string= type "hashtags") + (mastodon-search--query query "accounts")) + ((string= type "accounts") + (mastodon-search--query query "statuses")) + ((string= type "statuses") + (mastodon-search--query query "hashtags"))))) + +(defun mastodon-search--query-accounts-followed (query) + "Run an accounts search QUERY, limited to your followers." + (interactive "sSearch mastodon for: ") + (mastodon-search--query query "accounts" :following)) + +(defun mastodon-search--insert-users-propertized (json &optional note) + "Insert users list into the buffer. +JSON is the data from the server. +If NOTE is non-nil, include user's profile note. This is also + called by `mastodon-tl--get-follow-suggestions' and + `mastodon-profile--insert-follow-requests'." + (mapc (lambda (acct) + (insert (concat (mastodon-search--propertize-user acct note) + mastodon-tl--horiz-bar + "\n\n"))) + json)) + +(defun mastodon-search--propertize-user (acct &optional note) + "Propertize display string for ACCT, optionally including profile NOTE." + (let* ((user (mastodon-search--get-user-info acct)) + (id (alist-get 'id acct))) + (propertize + (concat + (propertize (car user) + 'face 'mastodon-display-name-face + 'byline t + 'item-type 'user + 'item-id id) ; for prev/next nav + " : \n : " + (propertize (concat "@" (cadr user)) + 'face 'mastodon-handle-face + 'mouse-face 'highlight + 'mastodon-tab-stop 'user-handle + 'keymap mastodon-tl--link-keymap + 'mastodon-handle (concat "@" (cadr user)) + 'help-echo (concat "Browse user profile of @" (cadr user))) + " : \n" + (when note + (mastodon-tl--render-text (cadddr user) acct)) + "\n") + 'item-json acct))) ; for compat w other processing functions + +(defun mastodon-search--print-tags (tags) + "Print TAGS data as returned from a \"hashtags\" search query." + (let ((tags-list (mapcar #'mastodon-search--get-hashtag-info tags))) + (mastodon-search--print-tags-list tags-list))) + +(defun mastodon-search--print-tags-list (tags-list) + "Insert a propertized list of TAGS-LIST." + (mapc (lambda (el) + (insert + " : " + (propertize (concat "#" (car el)) + 'face '(:box t) + 'mouse-face 'highlight + 'mastodon-tag (car el) + 'mastodon-tab-stop 'hashtag + 'item-type 'tag ; for next/prev nav + 'byline t ; for next/prev nav + 'help-echo (concat "Browse tag #" (car el)) + 'keymap mastodon-tl--link-keymap) + " : \n\n")) + tags-list)) + +(defun mastodon-search--get-user-info (account) + "Get user handle, display name, account URL and profile note from ACCOUNT." + (list (mastodon-tl--display-or-uname account) + (alist-get 'acct account) + (alist-get 'url account) + (alist-get 'note account))) + +(defun mastodon-search--get-hashtag-info (tag) + "Get hashtag name and URL from TAG." + (list (alist-get 'name tag) + (alist-get 'url tag))) + +;; These functions are all unused! + +;; (defun mastodon-search--get-status-info (status) +;; "Get ID, timestamp, content, and spoiler from STATUS." +;; (list (alist-get 'id status) +;; (alist-get 'created_at status) +;; (alist-get 'spoiler_text status) +;; (alist-get 'content status))) + +;; (defun mastodon-search--id-from-status (status) +;; "Fetch the id from a STATUS returned by a search call to the server. +;; We use this to fetch the complete status from the server." +;; (alist-get 'id status)) + +;; (defun mastodon-search--full-status-from-id (id) +;; "Fetch the full status with id ID from the server. +;; This allows us to access the full account etc. details and to +;; render them properly." +;; (let* ((url (mastodon-http--api (format "statuses/%s" id))) +;; ;; (concat mastodon-instance-url "/api/v1/statuses/" +;; ;; (mastodon-tl--as-string id))) +;; (json (mastodon-http--get-json url))) +;; json)) + +(defvar mastodon-search-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-c") #'mastodon-search--query-cycle) + map) + "Keymap for `mastodon-search-mode'.") + +(define-minor-mode mastodon-search-mode + "Toggle mastodon search minor mode. +This minor mode is used for mastodon search pages to adds a keybinding." + :init-value nil + :lighter " Search" + :keymap mastodon-search-mode-map + :group 'mastodon + :global nil) + +(provide 'mastodon-search) +;;; mastodon-search.el ends here diff --git a/elpa/mastodon-20241202.1839/mastodon-tl.el b/elpa/mastodon-20241202.1839/mastodon-tl.el new file mode 100644 index 00000000..763569bb --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-tl.el @@ -0,0 +1,3458 @@ +;;; mastodon-tl.el --- Timeline functions for mastodon.el -*- lexical-binding: t -*- + +;; Copyright (C) 2017-2019 Johnson Denen +;; Copyright (C) 2020-2024 Marty Hiatt +;; Author: Johnson Denen +;; Marty Hiatt +;; Maintainer: Marty Hiatt +;; Homepage: https://codeberg.org/martianh/mastodon.el + +;; This file is not part of GNU Emacs. + +;; This file is part of mastodon.el. + +;; mastodon.el 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. + +;; mastodon.el 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 mastodon.el. If not, see . + +;;; Commentary: + +;; mastodon-tl.el provides timeline functions. + +;;; Code: + +(require 'shr) +(require 'thingatpt) ; for word-at-point +(require 'time-date) +(require 'cl-lib) +(require 'mastodon-iso) +(require 'mpv nil :no-error) +(require 'url-cache) + +(autoload 'mastodon-mode "mastodon") +(autoload 'mastodon-notifications-get "mastodon") +(autoload 'mastodon-url-lookup "mastodon") +(autoload 'mastodon-auth--get-account-id "mastodon-auth") +(autoload 'mastodon-auth--get-account-name "mastodon-auth") +(autoload 'mastodon-http--api "mastodon-http") +(autoload 'mastodon-http--build-array-params-alist "mastodon-http") +(autoload 'mastodon-http--build-params-string "mastodon-http") +(autoload 'mastodon-http--delete "mastodon-http") +(autoload 'mastodon-http--get-json "mastodon-http") +(autoload 'mastodon-http--get-json-async "mastodon-http") +(autoload 'mastodon-http--get-response-async "mastodon-http") +(autoload 'mastodon-http--post "mastodon-http") +(autoload 'mastodon-http--process-json "mastodon-http") +(autoload 'mastodon-http--put "mastodon-http") +(autoload 'mastodon-http--triage "mastodon-http") +(autoload 'mastodon-media--get-avatar-rendering "mastodon-media") +(autoload 'mastodon-media--get-media-link-rendering "mastodon-media") +(autoload 'mastodon-media--inline-images "mastodon-media") +(autoload 'mastodon-notifications--filter-types-list "mastodon-notifications") +(autoload 'mastodon-notifications--get-mentions "mastodon-notifications") +(autoload 'mastodon-profile--account-from-id "mastodon-profile") +(autoload 'mastodon-profile--extract-users-handles "mastodon-profile") +(autoload 'mastodon-profile--get-preferences-pref "mastodon-profile") +(autoload 'mastodon-profile--get-toot-author "mastodon-profile") +(autoload 'mastodon-profile--lookup-account-in-status "mastodon-profile") +(autoload 'mastodon-profile--make-author-buffer "mastodon-profile") +(autoload 'mastodon-profile--my-profile "mastodon-profile") +(autoload 'mastodon-profile--open-statuses-no-reblogs "mastodon-profile") +(autoload 'mastodon-profile--profile-json "mastodon-profile") +(autoload 'mastodon-profile--search-account-by-handle "mastodon-profile") +(autoload 'mastodon-profile--item-json "mastodon-profile") +(autoload 'mastodon-profile--view-author-profile "mastodon-profile") +(autoload 'mastodon-profile-mode "mastodon-profile") +(autoload 'mastodon-search--get-user-info "mastodon-search") +(autoload 'mastodon-search--insert-users-propertized "mastodon-search") +(autoload 'mastodon-search--propertize-user "mastodon-search") +(autoload 'mastodon-toot--compose-buffer "mastodon-toot") +(autoload 'mastodon-toot--delete-toot "mastodon-toot") +(autoload 'mastodon-toot--get-toot-edits "mastodon-toot") +(autoload 'mastodon-toot--iso-to-human "mastodon-toot") +(autoload 'mastodon-toot--schedule-toot "mastodon-toot") +(autoload 'mastodon-toot--set-toot-properties "mastodon-toot") +(autoload 'mastodon-toot--update-status-fields "mastodon-toot") +(autoload 'mastodon-search--buf-type "mastodon-search") +(autoload 'mastodon-views--insert-users-propertized-note "mastodon-views") ; for search pagination +(autoload 'mastodon-http--get-response "mastodon-http") +(autoload 'mastodon-search--insert-heading "mastodon-search") +(autoload 'mastodon-media--process-full-sized-image-response "mastodon-media") +(autoload 'mastodon-search--trending-statuses "mastodon-search") +(autoload 'mastodon-search--format-heading "mastodon-search") +(autoload 'mastodon-media--image-or-cached "mastodon-media") +(autoload 'mastodon-toot--base-toot-or-item-json "mastodon-toot") +(autoload 'mastodon-search--load-link-posts "mastodon-search") + +(defvar mastodon-toot--visibility) +(defvar mastodon-toot-mode) +(defvar mastodon-active-user) +(defvar mastodon-images-in-notifs) +(defvar mastodon-group-notifications) + +(when (require 'mpv nil :no-error) + (declare-function mpv-start "mpv")) +(defvar mastodon-mode-map) +(defvar mastodon-instance-url) +(defvar mastodon-toot-timestamp-format) +(defvar shr-use-fonts) ;; declare it since Emacs24 didn't have this +(defvar mastodon-media--enable-image-caching) +(defvar mastodon-media--generic-broken-image-data) +(defvar mastodon-media--sensitive-image-data) + + +;;; CUSTOMIZES + +(defgroup mastodon-tl nil + "Timelines in Mastodon." + :prefix "mastodon-tl-" + :group 'mastodon) + +(defcustom mastodon-tl--enable-relative-timestamps t + "Whether to show relative (to the current time) timestamps. +This will require periodic updates of a timeline buffer to +keep the timestamps current as time progresses." + :type '(boolean :tag "Enable relative timestamps and background updater task")) + +(defcustom mastodon-tl--enable-proportional-fonts nil + "Nonnil to enable using proportional fonts when rendering HTML. +By default fixed width fonts are used." + :type '(boolean :tag "Enable using proportional rather than fixed \ +width fonts when rendering HTML text")) + +(defcustom mastodon-tl--no-fill-on-render nil + "Non-nil to disable filling by shr.el while rendering toot body. +Use this if your setup isn't compatible with shr's window width filling." + :type '(boolean)) + +(defcustom mastodon-tl--display-media-p t + "A boolean value stating whether to show media in timelines." + :type 'boolean) + +(defcustom mastodon-tl--display-caption-not-url-when-no-media t + "Display an image's caption rather than URL. +Only has an effect when `mastodon-tl--display-media-p' is set to +nil." + :type 'boolean) + +(defcustom mastodon-tl--show-avatars nil + "Whether to enable display of user avatars in timelines." + :type '(boolean :tag "Whether to display user avatars in timelines")) + +(defcustom mastodon-tl--show-stats t + "Whether to show toot stats (faves, boosts, replies counts)." + :type 'boolean) + +(defcustom mastodon-tl--symbols + '((reply . ("💬" . "R")) + (boost . ("🔁" . "B")) + (reblog . ("🔁" . "B")) ;; server compat + (favourite . ("⭐" . "F")) + (bookmark . ("🔖" . "K")) + (media . ("📹" . "[media]")) + (verified . ("✓" . "V")) + (locked . ("🔒" . "[locked]")) + (private . ("🔒" . "[followers]")) + (mention . ("@" . "[mention]")) + (direct . ("✉" . "[direct]")) + (edited . ("✍" . "[edited]")) + (update . ("✍" . "[edited]")) ;; server compat + (status . ("✍" . "[posted]")) + (replied . ("⬇" . "↓")) + (reply-bar . ("┃" . "|")) + (poll . ("📊" . "")) + (follow . ("👤" . "+")) + (follow_request . ("👤" . "+"))) + "A set of symbols (and fallback strings) to be used in timeline. +If a symbol does not look right (tofu), it means your +font settings do not support it." + :type '(alist :key-type symbol :value-type string)) + +(defcustom mastodon-tl-position-after-update nil + "Defines where `point' should be located after a timeline update. +Valid values are: +- nil Top/bottom depending on timeline type +- keep-point Keep original position of point +- last-old-toot The last toot before the new ones" + :type '(choice (const :tag "Top/bottom depending on timeline type" nil) + (const :tag "Keep original position of point" keep-point) + (const :tag "The last toot before the new ones" last-old-toot))) + +(defcustom mastodon-tl--timeline-posts-count "20" + "Number of posts to display when loading a timeline. +Must be an integer between 20 and 40 inclusive." + :type '(string)) + +(defcustom mastodon-tl--hide-replies nil + "Whether to hide replies from the timelines. +Note that you can hide replies on a one-off basis by loading a +timeline with a simple prefix argument, `C-u'." + :type '(boolean :tag "Whether to hide replies from the timelines.")) + +(defcustom mastodon-tl--highlight-current-toot nil + "Whether to highlight the toot at point. Uses `cursor-face' special property." + :type '(boolean)) + +(defcustom mastodon-tl--expand-content-warnings 'server + "Whether to expand content warnings by default. +The API returns data about this setting on the server, but no +means to set it, so we roll our own option here to override the +server setting if desired. If you change the server setting and +want it to be respected by mastodon.el, you'll likely need to +either unset `mastodon-profile-acccount-preferences-data' and +re-load mastodon.el, or restart Emacs." + :type '(choice (const :tag "true" t) + (const :tag "false" nil) + (const :tag "follow server setting" server))) + +(defcustom mastodon-tl--tag-timeline-tags nil + "A list of up to four tags for use with `mastodon-tl--followed-tags-timeline'." + :type '(repeat string)) + +(defcustom mastodon-tl--load-full-sized-images-in-emacs t + "Whether to load full-sized images inside Emacs. +Full-sized images are loaded when you hit return on or click on +an image in a timeline. +If nil, mastodon.el will instead call `shr-browse-image', which +respects the user's `browse-url' settings." + :type '(boolean)) + +(defcustom mastodon-tl--remote-local-domains nil + "A list of domains to view the local timelines of. +See `mastodon-tl--get-remote-local-timeline' for view remote local domains." + :type '(repeat string)) + +(defcustom mastodon-tl--fold-toots-at-length 1200 + "Length, in characters, to fold a toot at. +Longer toots will be folded and the remainder replaced by a +\"read more\" button. If the value is nil, don't fold at all." + :type '(integer)) + + +;;; VARIABLES + +(defvar-local mastodon-tl--buffer-spec nil + "A unique identifier and functions for each mastodon buffer.") + +(defvar-local mastodon-tl--update-point nil + "When updating a mastodon buffer this is where new toots will be inserted. +If nil `(point-min)' is used instead.") + +(defvar-local mastodon-tl--after-update-marker nil + "Marker defining the position of point after the update is done.") + +(defvar-local mastodon-tl--timestamp-next-update nil + "The timestamp when the buffer should next be scanned to update the timestamps.") + +(defvar-local mastodon-tl--timestamp-update-timer nil + "The timer that, when set will scan the buffer to update the timestamps.") + +(defvar mastodon-tl--horiz-bar + (make-string 12 + (if (char-displayable-p ?―) ?― ?-))) + + +;;; KEYMAPS + +(defvar mastodon-tl--link-keymap + (let ((map (make-sparse-keymap))) + (define-key map [return] #'mastodon-tl--do-link-action-at-point) + (define-key map [mouse-2] #'mastodon-tl--do-link-action) + (define-key map [follow-link] 'mouse-face) + map) + "The keymap for link-like things in buffer (except for shr.el generate links). +This will make the region of text act like like a link with mouse +highlighting, mouse click action tabbing to next/previous link +etc.") + +(defvar mastodon-tl--shr-map-replacement + (let ((map (make-sparse-keymap))) + (set-keymap-parent map shr-map) + ;; Replace the move to next/previous link bindings with our + ;; version that knows about more types of links. + (define-key map [remap shr-next-link] #'mastodon-tl--next-tab-item) + (define-key map [remap shr-previous-link] #'mastodon-tl--previous-tab-item) + ;; keep new my-profile binding; shr 'O' doesn't work here anyway + (define-key map (kbd "O") #'mastodon-profile--my-profile) + ;; remove shr's u binding, as it the maybe-probe-and-copy-url + ;; is already bound to w also + (define-key map (kbd "u") #'mastodon-tl--update) + (define-key map [remap shr-browse-url] #'mastodon-url-lookup) + (define-key map (kbd "M-RET") #'mastodon-search--load-link-posts) + map) + "The keymap to be set for shr.el generated links that are not images. +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--shr-image-map-replacement + (let ((map (make-sparse-keymap))) + (set-keymap-parent map (if (boundp 'shr-image-map) + shr-image-map + shr-map)) + ;; Replace the move to next/previous link bindings with our + ;; version that knows about more types of links. + (define-key map [remap shr-next-link] #'mastodon-tl--next-tab-item) + (define-key map [remap shr-previous-link] #'mastodon-tl--previous-tab-item) + ;; browse-url loads the preview only, we want browse-image + ;; on RET to browse full sized image URL + (define-key map [remap shr-browse-url] #'mastodon-tl--view-full-image-or-play-video) + ;; remove shr's u binding, as it the maybe-probe-and-copy-url + ;; is already bound to w also + (define-key map (kbd "u") #'mastodon-tl--update) + ;; keep new my-profile binding; shr 'O' doesn't work here anyway + (define-key map (kbd "O") #'mastodon-profile--my-profile) + (define-key map (kbd "C") #'mastodon-tl--copy-image-caption) + (define-key map (kbd "S") #'mastodon-tl--toggle-sensitive-image) + (define-key map (kbd "") #'mastodon-tl--mpv-play-video-at-point) + (define-key map (kbd "") #'mastodon-tl--click-image-or-video) + map) + "The keymap to be set for shr.el generated image links. +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--byline-link-keymap + (when (require 'mpv nil :no-error) + (let ((map (make-sparse-keymap))) + (define-key map (kbd "") #'mastodon-tl--mpv-play-video-from-byline) + (define-key map (kbd "RET") #'mastodon-profile--get-toot-author) + (define-key map (kbd "S") #'mastodon-tl--toggle-sensitive-image) + map)) + "The keymap to be set for the author byline. +It is active where point is placed by `mastodon-tl--goto-next-item.'") + + +;;; MACROS + +(defmacro with-mastodon-buffer (buffer mode-fun other-window &rest body) + "Evaluate BODY in a new or existing buffer called BUFFER. +MODE-FUN is called to set the major mode. +OTHER-WINDOW means call `switch-to-buffer-other-window' rather +than `pop-to-buffer'." + (declare (debug t) + (indent 3)) + `(with-current-buffer (get-buffer-create ,buffer) + (let ((inhibit-read-only t)) + (erase-buffer) + (funcall ,mode-fun) + (remove-overlays) ; video overlays + ,@body + ;; return result of switching buffer: + (if ,other-window + (switch-to-buffer-other-window ,buffer) + (pop-to-buffer ,buffer '(display-buffer-same-window)))))) + +(defmacro mastodon-tl--do-if-item (&rest body) + "Execute BODY if we have an item at point." + (declare (debug t)) + `(if (and (not (mastodon-tl--profile-buffer-p)) + (not (mastodon-tl--property 'item-json))) ; includes users but not tags + (user-error "Looks like there's no item at point?") + ,@body)) + + +;;; NAV + +(defun mastodon-tl--scroll-up-command () + "Call `scroll-up-command', loading more toots if necessary. +If we hit `point-max', call `mastodon-tl--more' then `scroll-up-command'." + (interactive) + (if (not (eq (point) (point-max))) + (scroll-up-command) + (mastodon-tl--more) + (scroll-up-command))) + +(defun mastodon-tl--next-tab-item (&optional previous) + "Move to the next interesting item. +This could be the next toot, link, or image; whichever comes first. +Don't move if nothing to move to is found, i.e. near the end of the buffer. +This also skips tab items in invisible text, i.e. hidden spoiler text. +PREVIOUS means move to previous item." + (interactive) + (let (next-range + (search-pos (point))) + (while (and (setq next-range + (mastodon-tl--find-next-or-previous-property-range + 'mastodon-tab-stop search-pos previous)) + (get-text-property (car next-range) 'invisible) + (setq search-pos (if previous + (1- (car next-range)) + (1+ (cdr next-range))))) + ;; do nothing, all the action is in the while condition + ) + (if (null next-range) + (user-error "Nothing else here") + (goto-char (car next-range)) + (message "%s" (mastodon-tl--property 'help-echo :no-move))))) + +(defun mastodon-tl--previous-tab-item () + "Move to the previous interesting item. +This could be the previous toot, link, or image; whichever comes +first. Don't move if nothing else to move to is found, i.e. near +the start of the buffer. This also skips tab items in invisible +text, i.e. hidden spoiler text." + (interactive) + (mastodon-tl--next-tab-item :previous)) + +(defun mastodon-tl--goto-item-pos (find-pos refresh &optional pos) + "Search for item with function FIND-POS. +If search returns nil, execute REFRESH function. +Optionally start from POS." + (let* ((npos ; toot/user items have byline: + (funcall find-pos + (or pos (point)) + ;; FIXME: we need to fix item-type? + ;; 'item-type ; breaks nav to last item in a view? + 'byline + (current-buffer))) + (max-lisp-eval-depth 4)) ;; clamp down on endless loops + (if npos + (if (not (get-text-property npos 'item-type)) ; generic + ;; FIXME let's make refresh &optional and only call refresh/recur + ;; if non-nil: + (mastodon-tl--goto-item-pos find-pos refresh npos) + (goto-char npos) + ;; force display of help-echo on moving to a toot byline: + (mastodon-tl--message-help-echo)) + (condition-case nil + (funcall refresh) + (error "No more items"))))) + +(defun mastodon-tl--goto-next-item (&optional no-refresh) + "Jump to next item. +Load more items it no next item. +NO-REFRESH means do no not try to load more items if no next item +found." + (interactive) + (condition-case nil + (mastodon-tl--goto-item-pos 'next-single-property-change + (unless no-refresh 'mastodon-tl--more)) + (t (error "No more items")))) + +(defun mastodon-tl--goto-prev-item () + "Jump to previous item. +Update if no previous items" + (interactive) + (condition-case nil + (mastodon-tl--goto-item-pos 'previous-single-property-change + 'mastodon-tl--update) + (t (error "No more items")))) + +(defun mastodon-tl--goto-first-item () + "Jump to first toot or item in buffer. +Used on initializing a timeline or thread." + (goto-char (point-min)) + (condition-case nil + (mastodon-tl--goto-item-pos 'next-single-property-change + 'next-line) + (t (error "No item")))) + + +;;; TIMELINES + +(defun mastodon-tl--get-federated-timeline (&optional prefix local max-id) + "Open federated timeline. +If LOCAL, get only local timeline. +With a single PREFIX arg, hide-replies. +With a double PREFIX arg, only show posts with media." + (interactive "p") + (let ((params + (cl-remove + nil + `(("limit" . ,mastodon-tl--timeline-posts-count) + ,(when (eq prefix 16) + '("only_media" . "true")) + ,(when local + '("local" . "true")) + ,(when max-id + `("max_id" . ,(mastodon-tl--buffer-property 'max-id))))))) + (message "Loading federated timeline...") + (mastodon-tl--init (if local "local" "federated") + "timelines/public" 'mastodon-tl--timeline nil + params + (when (eq prefix 4) t)))) + +(defun mastodon-tl--get-home-timeline (&optional arg max-id) + "Open home timeline. +With a single prefix ARG, hide replies. +MAX-ID is a flag to add the max_id pagination parameter." + (interactive "p") + (let* ((params + `(("limit" . ,mastodon-tl--timeline-posts-count) + ,(when max-id + `("max_id" . ,(mastodon-tl--buffer-property 'max-id)))))) + (message "Loading home timeline...") + (mastodon-tl--init "home" "timelines/home" 'mastodon-tl--timeline nil + params + (when (eq arg 4) t)))) + +(defun mastodon-tl--get-remote-local-timeline (&optional endpoint) + "Prompt for an instance domain and try to display its local timeline. +You can enter any working instance domain. Domains that you want +to regularly load can be stored in +`mastodon-tl--remote-local-domains' for easy access with completion. +Note that some instances do not make their local timelines public, in +which case this will not work. +To interact with any item, you must view it from your own +instance, which you can do with +`mastodon-tl--view-item-on-own-instance'. +Optionally, provide API ENDPOINT." + (interactive) + (let* ((domain (completing-read "Domain for remote local tl: " + mastodon-tl--remote-local-domains)) + (params `(("limit" . ,mastodon-tl--timeline-posts-count) + ("local" . "true"))) + (buf (concat "remote-local-" domain)) + (known (member domain + (mastodon-http--get-json + (mastodon-http--api "instance/peers"))))) + ;; condition-case doesn't work here, so i added basic error handling to + ;; `mastodon-tl--init*' instead + (when (or known + (y-or-n-p + "Domain appears unknown to your instance. Proceed?")) + (mastodon-tl--init buf + (or endpoint "timelines/public") + 'mastodon-tl--timeline nil + params nil domain)))) + +(defun mastodon-tl--remote-tag-timeline (&optional tag) + "Call `mastodon-tl--get-remote-local-timeline' but for a TAG timeline." + (interactive) + (let* ((tag (or tag (read-string "Tag: "))) + (endpoint (format "timelines/tag/%s" tag))) + (mastodon-tl--get-remote-local-timeline endpoint))) + +(defun mastodon-tl--view-item-on-own-instance () + "Load current toot on your own instance. +Use this to re-load remote-local items in order to interact with them." + (interactive) + (mastodon-tl--do-if-item + (let* ((toot (mastodon-tl--property 'item-json)) + (uri (mastodon-tl--field 'uri toot))) + (mastodon-url-lookup uri)))) + +(defun mastodon-tl--get-local-timeline (&optional prefix max-id) + "Open local timeline. +With a single PREFIX arg, hide-replies. +With a double PREFIX arg, only show posts with media. +MAX-ID is a flag to add the max_id pagination parameter." + (interactive "p") + (message "Loading local timeline...") + (mastodon-tl--get-federated-timeline prefix :local max-id)) + +(defun mastodon-tl--get-tag-timeline (&optional prefix tag) + "Prompt for tag and opens its timeline. +Optionally load TAG timeline directly. +With a single PREFIX arg, only show posts with media. +With a double PREFIX arg, limit results to your own instance." + (interactive "p") + (let* ((word (or (word-at-point) "")) + (input (or tag (read-string + (format "Load timeline for tag (%s): " word)))) + (tag (or tag (if (string-empty-p input) word input)))) + (message "Loading timeline for #%s..." tag) + (mastodon-tl--show-tag-timeline prefix tag))) + +(defun mastodon-tl--show-tag-timeline (&optional prefix tag) + "Opens a new buffer showing the timeline of posts with hastag TAG. +If TAG is a list, show a timeline for all tags. +With a single PREFIX arg, only show posts with media. +With a double PREFIX arg, limit results to your own instance." + (let ((params + (cl-remove + nil + `(("limit" . ,mastodon-tl--timeline-posts-count) + ,(when (eq prefix 4) + '("only_media" . "true")) + ,(when (eq prefix 16) + '("local" . "true")))))) + (when (listp tag) + (let ((list (mastodon-http--build-array-params-alist "any[]" (cdr tag)))) + (while list + (push (pop list) params)))) + (mastodon-tl--init + (if (listp tag) "tags-multiple" (concat "tag-" tag)) + (concat "timelines/tag/" (if (listp tag) (car tag) tag)) ; must be /tag/:sth + 'mastodon-tl--timeline nil params))) + +(defun mastodon-tl--link-timeline (url) + "Load a link timeline, displaying posts containing URL." + (let ((params `(("url" . ,url)))) + (mastodon-tl--init "links" "timelines/link" + 'mastodon-tl--timeline nil + params))) + +(defun mastodon-tl--announcements () + "Display announcements from your instance." + (interactive) + (mastodon-tl--init "announcements" "announcements" + 'mastodon-tl--timeline nil nil nil nil :no-byline)) + + +;;; BYLINES, etc. + +(defun mastodon-tl--message-help-echo () + "Call message on `help-echo' property at point. +Do so if type of status at poins is not follow_request/follow." + (let ((type (alist-get 'type + (mastodon-tl--property 'item-json :no-move))) + (echo (mastodon-tl--property 'help-echo :no-move))) + (when (not (string= "" echo)) ; not for followers/following in profile + (unless (or (string= type "follow_request") + (string= type "follow")) ; no counts for these + (message "%s" echo))))) + +(defun mastodon-tl--byline-username (toot) + "Format a byline username from account in TOOT. +TOOT may be account data, or toot data, in which case acount data +is extracted from it." + (let ((data (or (alist-get 'account toot) + toot))) ;; grouped nofifs use account data directly + (let-alist data + (propertize (if (not (string-empty-p .display_name)) + .display_name + .username) + 'face 'mastodon-display-name-face + ;; enable playing of videos when point is on byline: + ;; 'attachments (mastodon-tl--get-attachments-for-byline toot) + 'keymap mastodon-tl--byline-link-keymap + ;; echo faves count when point on post author name: + ;; which is where --goto-next-toot puts point. + 'help-echo + ;; but don't add it to "following"/"follows" on + ;; profile views: we don't have a tl--buffer-spec + ;; yet: + (unless (or (string-suffix-p "-followers*" (buffer-name)) + (string-suffix-p "-following*" (buffer-name))) + (mastodon-tl--format-byline-help-echo data)))))) + +(defun mastodon-tl--byline-handle (toot &optional domain string face) + "Format a byline handle from account in TOOT. +DOMAIN is optionally added to the handle. +ACCOUNT is optionally acccount data to use. +STRING is optionally the string to propertize, it is used to make +username rather than handle buttons. +FACE is optionally the face to use. +The last two args allow for display a username as a clickable +handle." + (let-alist (or (alist-get 'account toot) + toot) ;; grouped notifs + (propertize (or string + (concat "@" .acct + (when domain + (concat "@" + (url-host + (url-generic-parse-url .url)))))) + 'face (or face 'mastodon-handle-face) + 'mouse-face 'highlight + 'mastodon-tab-stop 'user-handle + 'shr-url .url + 'keymap mastodon-tl--link-keymap + 'mastodon-handle (concat "@" .acct) + 'help-echo (concat "Browse user profile of @" .acct)))) + +(defun mastodon-tl--byline-uname-+-handle (data &optional domain) + "Concatenate a byline username and handle. +DATA is the (toot) data to use. +DOMAIN is optionally a domain for the handle. +ACCOUNT is optionally acccount data to use." + (concat (mastodon-tl--byline-username data) + " (" (mastodon-tl--byline-handle data domain) ")")) + +(defun mastodon-tl--display-or-uname (account) + "Return display name or username from ACCOUNT data." + (if (not (string-empty-p (alist-get 'display_name account))) + (alist-get 'display_name account) + (alist-get 'username account))) + +(defun mastodon-tl--byline-author (toot &optional avatar domain base) + "Propertize author of TOOT. +With arg AVATAR, include the account's avatar image. +When DOMAIN, force inclusion of user's domain in their handle. +BASE means to use data from the base item (reblog slot) if possible. +If BASE is nil, we are a boosted byline, so show less info. +ACCOUNT is optionally acccount data to use." + (let* ((data (if base + (mastodon-tl--toot-or-base toot) + toot)) + (account (alist-get 'account data)) + (uname (mastodon-tl--display-or-uname account))) + (concat + ;; avatar insertion moved up to `mastodon-tl--byline' by default to + ;; be outside 'byline propt. + (when (and avatar ; used by `mastodon-profile--format-user' + mastodon-tl--show-avatars + mastodon-tl--display-media-p + (mastodon-tl--image-trans-check)) + (mastodon-media--get-avatar-rendering + (map-nested-elt data '(account avatar)))) + (if (not base) + ;; boost symbol: + (concat (mastodon-tl--symbol 'boost) + " " + ;; username as button: + (mastodon-tl--byline-handle + data domain + ;; display uname not handle (for boosts): + uname 'mastodon-display-name-face)) + ;; normal combo author byline: + (mastodon-tl--byline-uname-+-handle data domain))))) + +(defun mastodon-tl--format-byline-help-echo (toot) + "Format a help-echo for byline of TOOT. +Displays a toot's media types and optionally the binding to play +moving image media from the byline. +Used when point is at the start of a byline, i.e. where +`mastodon-tl--goto-next-item' leaves point." + (let* ((toot-to-count + (or ; simply praying this order works + (alist-get 'status toot) ; notifications timeline + ;; fol-req notif, has 'type placed before boosts coz fol-reqs have + ;; a (useless) reblog entry: + (when (and (or (mastodon-tl--buffer-type-eq 'notifications) + (mastodon-tl--buffer-type-eq 'mentions)) + (alist-get 'type toot)) + toot) + (alist-get 'reblog toot) ; boosts + toot)) ; everything else + (fol-req-p (let ((type (alist-get 'type toot-to-count))) + (or (string= type "follow") + (string= type "follow_request"))))) + (unless fol-req-p + (let* ((media-types (mastodon-tl--get-media-types toot)) + (format-media (when media-types + (format "media: %s" + (mapconcat #'identity media-types " ")))) + (format-media-binding (when (and (or (member "video" media-types) + (member "gifv" media-types)) + (require 'mpv nil :no-error)) + " | C-RET to view with mpv"))) + (concat format-media format-media-binding))))) + +(defun mastodon-tl--get-media-types (toot) + "Return a list of the media attachment types of the TOOT at point." + (let* ((attachments (mastodon-tl--field 'media_attachments toot))) + (mastodon-tl--map-alist 'type attachments))) + +(defun mastodon-tl--get-attachments-for-byline (toot) + "Return a list of attachment URLs and types for TOOT. +The result is added as an attachments property to author-byline." + (let ((media (mastodon-tl--field 'media_attachments toot))) + (mapcar (lambda (attachment) + (let-alist attachment + (list :url (or .remote_url .url) ; fallback for notifications + :type .type))) + media))) + +(defun mastodon-tl--byline-booster (toot) + "Add author byline for booster from TOOT. +Only return something if TOOT contains a reblog." + (let ((reblog (alist-get 'reblog toot))) + (if reblog + (mastodon-tl--byline-author toot) + ""))) + +(defun mastodon-tl--byline-booster-str (toot) + "Format boosted string for action byline. +Only return string if TOOT contains a reblog." + (let ((reblog (alist-get 'reblog toot))) + (if reblog + (concat + " " (propertize "boosted" 'face 'mastodon-boosted-face) "\n") + ""))) + +(defun mastodon-tl--byline-boost (toot) + "Format a boost action-byline element for TOOT." + (concat (mastodon-tl--byline-booster toot) + (mastodon-tl--byline-booster-str toot))) + +(defun mastodon-tl--format-faved-or-boosted-byline (letter) + "Format the byline marker for a boosted or favourited status. +LETTER is a string, F for favourited, B for boosted, or K for bookmarked." + (let ((help-string (cond ((string= letter "F") + "favourited") + ((string= letter "B") + "boosted") + ((string= letter (or "🔖" "K")) + "bookmarked")))) + (format "(%s) " + (propertize letter 'face 'mastodon-boost-fave-face + ;; emojify breaks this for 🔖: + 'help-echo (format "You have %s this status." + help-string))))) + +(defun mastodon-tl--image-trans-check () + "Call `image-transforms-p', or `image-type-available-p' imagemagick." + (if (version< emacs-version "27.1") + (image-type-available-p 'imagemagick) + (image-transforms-p))) + +(defun mastodon-tl--byline (toot &optional detailed-p + domain base-toot group ts) + "Generate (bottom) byline for TOOT. +AUTHOR-BYLINE is a function for adding the author portion of +the byline that takes one variable. +DETAILED-P means display more detailed info. For now +this just means displaying toot client. +When DOMAIN, force inclusion of user's domain in their handle. +BASE-TOOT is JSON for the base toot, if any. +GROUP is the notification group if any. +ACCOUNT is the notification account if any. +TS is a timestamp from the server, if any." + (let* ((type (alist-get 'type (or group toot))) + (created-time + (or ts ;; mentions, statuses, folls/foll-reqs + ;; bosts, faves, edits, polls in notifs view use base item + ;; timestamp: + (mastodon-tl--field 'created_at + (mastodon-tl--field 'status toot)) + ;; all other toots, inc. boosts/faves in timelines: + ;; (mastodon-tl--field auto fetches from reblogs if needed): + (mastodon-tl--field 'created_at toot))) + (parsed-time (when created-time (date-to-time created-time))) + ;; non-grouped notifs now need to pull the following data from + ;; base toot: + (base-maybe (or base-toot ;; show edits for notifs + (mastodon-tl--toot-or-base toot))) ;; for boosts + (faved (eq t (mastodon-tl--field 'favourited base-maybe))) + (boosted (eq t (mastodon-tl--field 'reblogged base-maybe))) + (bookmarked (eq t (mastodon-tl--field 'bookmarked base-maybe))) + (visibility (mastodon-tl--field 'visibility base-maybe)) + (account (alist-get 'account base-maybe)) + (avatar-url (alist-get 'avatar account)) + (edited-time (alist-get 'edited_at base-maybe)) + (edited-parsed (when edited-time (date-to-time edited-time)))) + (concat + ;; Boosted/favourited markers are not technically part of the byline, so + ;; we don't propertize them with 'byline t', as per the rest. This + ;; ensures that `mastodon-tl--goto-next-item' puts point on + ;; author-byline, not before the (F) or (B) marker. Not propertizing like + ;; this makes the behaviour of these markers consistent whether they are + ;; displayed for an already boosted/favourited toot or as the result of + ;; the toot having just been favourited/boosted. + (concat (when boosted + (mastodon-tl--format-faved-or-boosted-byline + (mastodon-tl--symbol 'boost))) + (when faved + (mastodon-tl--format-faved-or-boosted-byline + (mastodon-tl--symbol 'favourite))) + (when bookmarked + (mastodon-tl--format-faved-or-boosted-byline + (mastodon-tl--symbol 'bookmark)))) + ;; we remove avatars from the byline also, so that they also do not + ;; mess with `mastodon-tl--goto-next-item': + (when (and mastodon-tl--show-avatars + mastodon-tl--display-media-p + (mastodon-tl--image-trans-check)) + (mastodon-media--get-avatar-rendering avatar-url)) + (propertize + (concat + ;; NB: action-byline (boost) is now added in insert-status, so no + ;; longer part of the byline. + ;; (base) author byline: + ;; we use base-toot if poss for fave/boost notifs that need to show + ;; base item in author byline + (mastodon-tl--byline-author (or base-toot toot) + nil domain :base) + ;; visibility: + (cond ((string= visibility "direct") + (propertize (concat " " (mastodon-tl--symbol 'direct)) + 'help-echo visibility)) + ((string= visibility "private") + (propertize (concat " " (mastodon-tl--symbol 'private)) + 'help-echo visibility))) + " " + ;; timestamp: + (let ((ts (format-time-string + mastodon-toot-timestamp-format parsed-time))) + (propertize ts + 'timestamp parsed-time + 'display + (if mastodon-tl--enable-relative-timestamps + (mastodon-tl--relative-time-description parsed-time) + parsed-time) + 'help-echo ts)) + ;; detailed: + (when detailed-p + (let* ((app-name (map-nested-elt toot '(application name))) + (app-url (map-nested-elt toot '(application website)))) + (when app-name + (concat + (propertize " via " 'face 'default) + (propertize app-name + 'face 'mastodon-display-name-face + 'follow-link t + 'mouse-face 'highlight + 'mastodon-tab-stop 'shr-url + 'shr-url app-url + 'help-echo app-url + 'keymap mastodon-tl--shr-map-replacement))))) + ;; edited: + (when edited-time + (concat + " " + (mastodon-tl--symbol 'edited) + " " + (propertize + (format-time-string mastodon-toot-timestamp-format + edited-parsed) + 'face 'font-lock-comment-face + 'timestamp edited-parsed + 'display (if mastodon-tl--enable-relative-timestamps + (mastodon-tl--relative-time-description edited-parsed) + edited-parsed)))) + (propertize (concat "\n " mastodon-tl--horiz-bar) + 'face 'default) + ;; stats: + (when (and mastodon-tl--show-stats + (not (member type '("follow" "follow_request")))) + (mastodon-tl--toot-stats toot)) + "\n") + 'favourited-p faved + 'boosted-p boosted + 'bookmarked-p bookmarked + ;; enable playing of videos when point is on byline: + 'attachments (mastodon-tl--get-attachments-for-byline toot) + 'edited edited-time + 'edit-history (when edited-time + (mastodon-toot--get-toot-edits + (alist-get 'id base-maybe))) + 'byline t)))) + + +;;; TIMESTAMPS + +(defun mastodon-tl--relative-time-details (timestamp &optional current-time) + "Return cons of (DESCRIPTIVE STRING . NEXT-CHANGE) for the TIMESTAMP. +Use the optional CURRENT-TIME as the current time (only used for +reliable testing). +The descriptive string is a human readable version relative to +the current time while the next change timestamp give the first +time that this description will change in the future. +TIMESTAMP is assumed to be in the past." + (let* ((time-difference (time-subtract current-time timestamp)) + (seconds-difference (float-time time-difference)) + (tmp (mastodon-tl--human-duration (max 0 seconds-difference)))) + ;; revert to old just now style for < 1 min + (cons (concat (car tmp) (if (string= "just now" (car tmp)) "" " ago")) + (time-add current-time (cdr tmp))))) + +(defun mastodon-tl--relative-time-description (timestamp &optional current-time) + "Return a string with a human readable TIMESTAMP relative to the current time. +Use the optional CURRENT-TIME as the current time (only used for +reliable testing). +E.g. this could return something like \"1 min ago\", \"yesterday\", etc. +TIME-STAMP is assumed to be in the past." + (car (mastodon-tl--relative-time-details timestamp current-time))) + + +;;; RENDERING HTML, LINKS, HASHTAGS, HANDLES + +(defun mastodon-tl--render-text (string &optional toot) + "Return a propertized text rendering the given HTML string STRING. +The contents comes from the given TOOT which is used in parsing +links in the text. If TOOT is nil no parsing occurs." + (when string ; handle rare empty notif server bug + (with-temp-buffer + (insert string) + (let ((shr-use-fonts mastodon-tl--enable-proportional-fonts) + (shr-width (when mastodon-tl--enable-proportional-fonts + (if mastodon-tl--no-fill-on-render + 0 + (- (window-width) 3))))) + (shr-render-region (point-min) (point-max))) + ;; Make all links a tab stop recognized by our own logic, make + ;; things point to our own logic (e.g. hashtags), and update keymaps + ;; where needed: + (when toot + (let (region) + (while (setq region (mastodon-tl--find-property-range + 'shr-url (or (cdr region) (point-min)))) + (mastodon-tl--process-link toot + (car region) (cdr region) + (get-text-property (car region) 'shr-url)) + (when (proper-list-p toot) ;; not on profile fields cons cells + ;; render card author maybe: + (let* ((card-url (map-nested-elt toot '(card url))) + (authors (map-nested-elt toot '(card authors))) + (url (buffer-substring (car region) (cdr region))) + (url-no-query (car (split-string url "?")))) + (when (and (string= url-no-query card-url) + ;; only if we have an account's data: + (alist-get 'account (car authors))) + (goto-char (point-max)) + (mastodon-tl--insert-card-authors authors))))))) + (buffer-string)))) + +(defun mastodon-tl--insert-card-authors (authors) + "Insert a string of card AUTHORS." + (let ((authors-str (format "Author%s: " + (if (< 1 (length authors)) "s" "")))) + (insert + (concat + "\n(" authors-str + (mapconcat #'mastodon-tl--format-card-author authors "\n") + ")\n")))) + +(defun mastodon-tl--format-card-author (data) + "Render card author DATA." + (when-let ((account (alist-get 'account data))) ;.account + (let-alist account ;.account + ;; FIXME: replace with refactored handle render fun + ;; in byline refactor branch: + (concat + (propertize .username + 'face 'mastodon-display-name-face + 'item-type 'user + 'item-id .id) + " " + (propertize (concat "@" .acct) + 'face 'mastodon-handle-face + 'mouse-face 'highlight + 'mastodon-tab-stop 'user-handle + 'keymap mastodon-tl--link-keymap + 'mastodon-handle (concat "@" .acct) + 'help-echo (concat "Browse user profile of @" .acct)))))) + +(defun mastodon-tl--process-link (toot start end url) + "Process link URL in TOOT as hashtag, userhandle, or normal link. +START and END are the boundaries of the link in the toot." + (let* (mastodon-tab-stop-type + keymap + (help-echo (get-text-property start 'help-echo)) + extra-properties + ;; handle calling this on non-toots, e.g. for profiles: + (toot-url (when (proper-list-p toot) + (mastodon-tl--field 'url toot))) + (toot-url (when toot-url (url-generic-parse-url toot-url))) + (toot-instance-url (if toot-url + (concat (url-type toot-url) "://" + (url-host toot-url)) + mastodon-instance-url)) + (link-str (buffer-substring-no-properties start end)) + (maybe-hashtag (mastodon-tl--hashtag-from-url + url toot-instance-url)) + (maybe-userhandle + (if (proper-list-p toot) ; fails for profile buffers? + (or (mastodon-tl--userhandle-from-mentions toot link-str) + (mastodon-tl--userhandle-from-url url link-str)) + (mastodon-tl--userhandle-from-url url link-str)))) + (cond (maybe-hashtag + (setq mastodon-tab-stop-type 'hashtag + keymap mastodon-tl--link-keymap + help-echo (concat "Browse tag #" maybe-hashtag) + extra-properties (list 'mastodon-tag maybe-hashtag))) + (maybe-userhandle ;; fails on mentions in profile notes: + (let ((maybe-userid (when (proper-list-p toot) + (mastodon-tl--extract-userid-toot + toot link-str)))) + (setq mastodon-tab-stop-type 'user-handle + keymap mastodon-tl--link-keymap + help-echo (concat "Browse user profile of " maybe-userhandle) + extra-properties (append + (list 'mastodon-handle maybe-userhandle) + (when maybe-userid + (list 'account-id maybe-userid)))))) + (t ;; Anything else (leave it as a url handled by shr.el): + (setq keymap (if (eq shr-map (get-text-property start 'keymap)) + mastodon-tl--shr-map-replacement + mastodon-tl--shr-image-map-replacement) + mastodon-tab-stop-type 'shr-url))) + (add-text-properties start end + (append + (list 'mastodon-tab-stop mastodon-tab-stop-type + 'keymap keymap + 'help-echo help-echo) + extra-properties)))) + +(defun mastodon-tl--userhandle-from-mentions (toot link) + "Extract a user handle from mentions in json TOOT. +LINK is maybe the `@handle' to search for." + (mastodon-tl--el-from-mentions 'acct toot link)) + +(defun mastodon-tl--extract-userid-toot (toot link) + "Extract a user id for an ACCT from mentions in a TOOT. +LINK is maybe the `@handle' to search for." + (mastodon-tl--el-from-mentions 'id toot link)) + +(defun mastodon-tl--el-from-mentions (el toot link) + "Extract element EL from TOOT mentions that matches LINK. +LINK should be a simple handle string with no domain, i.e. \"@user\". +Return nil if no matching element." + (let ((mentions (alist-get 'mentions toot))) + (when mentions + (let* ((mention (pop mentions)) + (name (substring-no-properties link 1 (length link))) ; cull @ + return) + (while mention + (when (string= name (alist-get 'username mention)) + (setq return (alist-get el mention))) + (setq mention (pop mentions))) + return)))) + +(defun mastodon-tl--userhandle-from-url (url buffer-text) + "Return the user hande the URL points to or nil if it is not a profile link. +BUFFER-TEXT is the text covered by the link with URL, for a user profile +this should be of the form , e.g. \"@Gargon\"." + (let* ((parsed-url (url-generic-parse-url url)) + (host (url-host parsed-url)) + (local-p (string= + (url-host (url-generic-parse-url mastodon-instance-url)) + host)) + (path (url-filename parsed-url))) + (when (and (string= "@" (substring buffer-text 0 1)) + ;; don't error on domain only url (rare): + (not (string= "" path)) + (string= (downcase buffer-text) + (downcase (substring path 1)))) + (if local-p + buffer-text ; no instance suffix for local mention + (concat buffer-text "@" host))))) + +(defun mastodon-tl--hashtag-from-url (url instance-url) + "Return the hashtag that URL points to or nil if URL is not a tag link. +INSTANCE-URL is the url of the instance for the toot that the link +came from (tag links always point to a page on the instance publishing +the toot)." + ;; TODO: do we rly need to check it against instance-url? + ;; test suggests we might + (let* ((instance-host (url-host + (url-generic-parse-url instance-url))) + (parsed (url-generic-parse-url url)) + (path (url-filename parsed)) + (split (split-string path "/"))) + (when (and (string= instance-host (url-host parsed)) + (string-prefix-p "/tag" path)) ;; "/tag/" or "/tags/" + (nth 2 split)))) + + +;;; HYPERLINKS + +(defun mastodon-tl--make-link (string link-type) + "Return a propertized version of STRING that will act like link. +LINK-TYPE is the type of link to produce." + (let ((help-text (cond ((eq link-type 'content-warning) + "Toggle hidden text") + ((or (eq link-type 'read-more) + (eq link-type 'read-less)) + "Toggle full post") + (t + (error "Unknown link type %s" link-type))))) + (propertize string + 'mastodon-tab-stop link-type + 'mouse-face 'highlight + 'keymap mastodon-tl--link-keymap + 'help-echo help-text))) + +(defun mastodon-tl--do-link-action-at-point (pos) + "Do the action of the link at POS. +Used for hitting RET on a given link." + (interactive "d") + (let ((link-type (get-text-property pos 'mastodon-tab-stop))) + (cond ((eq link-type 'content-warning) + (mastodon-tl--toggle-spoiler-text pos)) + ((eq link-type 'hashtag) + (mastodon-tl--show-tag-timeline + nil (get-text-property pos 'mastodon-tag))) + ;; 'account / 'account-id is not set for mentions, only bylines + ((eq link-type 'user-handle) + (let ((account-json (get-text-property pos 'account)) + (account-id (get-text-property pos 'account-id))) + (cond + (account-json + (mastodon-profile--make-author-buffer account-json)) + (account-id + (mastodon-profile--make-author-buffer + (mastodon-profile--account-from-id account-id))) + (t + (let ((account (mastodon-profile--search-account-by-handle + (get-text-property pos 'mastodon-handle)))) + ;; never call make-author-buffer on nil account: + (cond (account + (mastodon-profile--make-author-buffer account)) + ;; optional webfinger lookup: + ((y-or-n-p + "Search for account returned nothing. Perform URL lookup?") + (mastodon-url-lookup (get-text-property pos 'shr-url))) + (t + (error "Unable to find account")))))))) + ((eq link-type 'read-more) + (mastodon-tl--unfold-post)) + ((eq link-type 'read-less) + (mastodon-tl--fold-post)) + (t + (error "Unknown link type %s" link-type))))) + +(defun mastodon-tl--do-link-action (event) + "Do the action of the link at point. +Used for a mouse-click EVENT on a link." + (interactive "@e") + (mastodon-tl--do-link-action-at-point (posn-point (event-end event)))) + + +;;; CONTENT WARNINGS + +(defun mastodon-tl--has-spoiler (toot) + "Check if the given TOOT has a spoiler text. +Spoiler text should initially be shown only while the main +content should be hidden." + (let ((spoiler (mastodon-tl--field 'spoiler_text toot))) + (and spoiler (> (length spoiler) 0)))) + +(defun mastodon-tl--toggle-spoiler-text (position) + "Toggle the visibility of the spoiler text at/after POSITION." + (let* ((inhibit-read-only t) + (spoiler-region (mastodon-tl--find-property-range + 'mastodon-content-warning-body position nil)) + (new-state (not (get-text-property (car spoiler-region) + 'invisible)))) + (if (not spoiler-region) + (user-error "No spoiler text here") + (add-text-properties (car spoiler-region) (cdr spoiler-region) + (list 'invisible new-state)) + new-state))) ;; return what we set invisibility to + +(defun mastodon-tl--toggle-spoiler-text-in-toot () + "Toggle the visibility of the spoiler text in the current toot." + (interactive) + (let* ((toot-range (or (mastodon-tl--find-property-range + 'item-json (point)) + (mastodon-tl--find-property-range + 'item-json (point) t))) + (spoiler-range (when toot-range + (mastodon-tl--find-property-range + 'mastodon-content-warning-body + (car toot-range))))) + (cond ((null toot-range) + (user-error "No toot here")) + ((or (null spoiler-range) + (> (car spoiler-range) (cdr toot-range))) + (user-error "No content warning text here")) + (t + (mastodon-tl--toggle-spoiler-text (car spoiler-range)))))) + +(defun mastodon-tl--toggle-spoiler-in-thread () + "Toggler content warning for all posts in current thread." + (interactive) + (let ((thread-p (eq (mastodon-tl--buffer-property 'update-function) + 'mastodon-tl--thread))) + (if (not thread-p) + (user-error "Not in a thread") + (save-excursion + (goto-char (point-min)) + (while (not (string= "No more items" ; improve this hack test! + (mastodon-tl--goto-next-item :no-refresh))) + (let* ((json (mastodon-tl--property 'item-json :no-move)) + (cw (alist-get 'spoiler_text json))) + (when (not (string= "" cw)) + (let ((new-state + (pcase + (mastodon-tl--toggle-spoiler-text-in-toot) + ('t 'folded) + ('nil 'unfolded)))) + (plist-put mastodon-tl--buffer-spec + 'thread-unfolded new-state))))))))) + +(defun mastodon-tl--spoiler (toot &optional filter) + "Render TOOT with spoiler message. +This assumes TOOT is a toot with a spoiler message. +The main body gets hidden and only the spoiler text and the +content warning message are displayed. The content warning +message is a link which unhides/hides the main body. +FILTER is a string to use as a filter warning spoiler instead." + (let* ((spoiler (mastodon-tl--field 'spoiler_text toot)) + (string (mastodon-tl--set-face + (mastodon-tl--clean-tabs-and-nl + (mastodon-tl--render-text spoiler toot)) + 'default)) + (message (concat " " mastodon-tl--horiz-bar "\n " + (mastodon-tl--make-link + (if filter + (concat "Filtered: " filter) + (concat "CW: " string)) + 'content-warning) + "\n " + mastodon-tl--horiz-bar "\n")) + (cw (mastodon-tl--set-face message 'mastodon-cw-face))) + (concat + cw + (propertize + (mastodon-tl--content toot) + 'invisible + (or filter ;; filters = invis + (let ((cust mastodon-tl--expand-content-warnings)) + (if (not (eq 'server cust)) + (not cust) ;; opp to setting + ;; respect server setting: + ;; If something goes wrong reading prefs, + ;; just return t so CWs fold by default. + (condition-case nil + (if (eq :json-false + (mastodon-profile--get-preferences-pref + 'reading:expand:spoilers)) + t + nil) + (error t))))) + 'mastodon-content-warning-body t)))) + + +;;; MEDIA + +(defun mastodon-tl--media (toot) + "Retrieve a media attachment link for TOOT if one exists. +Else return an empty string." + (let* ((attachments (mastodon-tl--field 'media_attachments toot)) + (sensitive (mastodon-tl--field 'sensitive toot)) + (media-string (mapconcat + (lambda (x) + (mastodon-tl--media-attachment x sensitive)) + attachments ""))) + (if (not (and mastodon-tl--display-media-p + (string-empty-p media-string))) + (concat "\n" media-string) + ""))) + +(defun mastodon-tl--media-attachment (attachment sensitive) + "Return a propertized string for ATTACHMENT. +SENSITIVE is a flag from the item's JSON data." + (let-alist attachment + (let ((display-str + (concat "Media:: " + (if (and mastodon-tl--display-caption-not-url-when-no-media + .description) + .description + .preview_url))) + (remote-url (or .remote_url .url))) + (if (and mastodon-tl--display-media-p + ;; if in notifs, also check notifs images custom: + (if (or (mastodon-tl--buffer-type-eq 'notifications) + (mastodon-tl--buffer-type-eq 'mentions)) + mastodon-images-in-notifs + t)) + (mastodon-media--get-media-link-rendering ; placeholder: "[img]" + .preview_url remote-url ; for shr-browse-url + .type .description sensitive) + ;; return URL/caption: + (concat (mastodon-tl--propertize-img-str-or-url + (concat "Media:: " .preview_url) ; string + .preview_url remote-url .type .description + display-str 'shr-link .description sensitive) + "\n"))))) + +(defun mastodon-tl--propertize-img-str-or-url + (str media-url full-remote-url type help-echo + &optional display face caption sensitive) + "Propertize an media placeholder string \"[img]\" or media URL. +STR is the string to propertize, MEDIA-URL is the preview link, +FULL-REMOTE-URL is the link to the full resolution image on the +server, TYPE is the media type. +HELP-ECHO, DISPLAY, and FACE are the text properties to add. +CAPTION is the image caption, added as a text property. +SENSITIVE is a flag from the item's JSON data." + (propertize str + 'media-url media-url + 'media-state (when (string= str "[img]") 'needs-loading) + 'media-type 'media-link + 'mastodon-media-type type + 'display display + 'face face + 'mouse-face 'highlight + 'mastodon-tab-stop 'image ; for do-link-action-at-point + 'image-url (or full-remote-url media-url) ; for shr-browse-image + 'keymap mastodon-tl--shr-image-map-replacement + 'image-description caption + 'sensitive sensitive + 'help-echo (if (or (string= type "image") + (string= type nil) + (string= type "unknown")) ; handle borked images + help-echo + (concat help-echo "\nC-RET: play " type " with mpv")))) + +(defun mastodon-tl--view-full-image () + "Browse full-sized version of image at point in a new window." + (interactive) + (if (not (eq (mastodon-tl--property 'mastodon-tab-stop) 'image)) + (user-error "No image at point?") + (let* ((url (mastodon-tl--property 'image-url))) + (if (not mastodon-tl--load-full-sized-images-in-emacs) + (shr-browse-image) + (mastodon-media--image-or-cached + url + #'mastodon-media--process-full-sized-image-response + `(nil ,url)))))) + +(defun mastodon-tl--toggle-sensitive-image () + "Toggle dislay of sensitive image at point." + (interactive) + (if (not (eq t (mastodon-tl--property 'sensitive))) + (user-error "No sensitive media at point?") + (let ((data (mastodon-tl--property 'image-data :no-move)) + (inhibit-read-only t) + (end (next-single-property-change (point) 'sensitive-state))) + (add-text-properties + (point) end + (if (eq 'hidden (mastodon-tl--property 'sensitive-state :no-move)) + ;; display: + `( display ,data + sensitive-state showing) + ;; hide: + `( sensitive-state hidden + display + ,(create-image + mastodon-media--sensitive-image-data nil t))))))) + + +;; POLLS + +(defun mastodon-tl--format-poll-option (option counter length) + "Format poll OPTION. COUNTER is a counter. +LENGTH is of the longest option, for formatting." + (format "%s: %s%s%s\n" + counter + (propertize (alist-get 'title option) + 'face 'success) + (make-string (1+ (- length + (length (alist-get 'title option)))) + ?\ ) + ;; TODO: disambiguate no votes from hidden votes + (format "[%s votes]" (or (alist-get 'votes_count option) + "0")))) + +(defun mastodon-tl--format-poll (poll) + "From json poll data POLL, return a display string." + (let-alist poll + (let* ((options (mastodon-tl--map-alist 'title .options)) + (longest (car (sort (mapcar #'length options ) #'>))) + (counter 0)) + (concat "\nPoll: \n\n" + (mapconcat (lambda (option) + (setq counter (1+ counter)) + (mastodon-tl--format-poll-option + option counter longest)) + .options + "\n") + "\n" + (propertize + (cond (.voters_count ; sometimes it is nil + (format "%s %s | " .voters_count + (if (= .voters_count 1) "person" "people"))) + (.vote_count + (format "%s votes | " .vote_count)) + (t "")) + 'face 'font-lock-comment-face) + (let ((str (if (eq .expired :json-false) + (if (eq .expires_at nil) + "" + (mastodon-tl--format-poll-expiry .expires_at)) + "Poll expired."))) + (propertize str 'face 'font-lock-comment-face)) + "\n")))) + +(defconst mastodon-tl--time-units + '("sec" 60.0 ;; Use a float to convert `n' to float. + "min" 60 + "hour" 24 + "day" 7 + "week" 4.345 + "month" 12 + "year")) + +(defun mastodon-tl--format-poll-expiry (timestamp) + "Convert poll expiry TIMESTAMP into a descriptive string. +TIMESTAMP is from the expires_at field of a poll's JSON data, and +is in ISO 8601 Datetime format." + (let* ((ts (encode-time (parse-time-string timestamp))) + (seconds (time-to-seconds (time-subtract ts nil)))) + ;; FIXME: Use the `cdr' to update poll expiry times? + (concat (car (mastodon-tl--human-duration (max 0 seconds))) " left"))) + +(defun mastodon-tl--human-duration (seconds &optional resolution) + "Return a string describing SECONDS in a more human-friendly way. +The return format is (STRING . RES) where RES is the resolution of +this string, in seconds. +RESOLUTION is the finest resolution, in seconds, to use for the +second part of the output (defaults to 60, so that seconds are only +displayed when the duration is smaller than a minute)." + (cl-assert (>= seconds 0)) + (unless resolution (setq resolution 60)) + (let* ((units mastodon-tl--time-units) + (n1 seconds) (unit1 (pop units)) (res1 1) + n2 unit2 res2 + next) + (while (and units (> (truncate (setq next (/ n1 (car units)))) 0)) + (setq unit2 unit1) + (setq res2 res1) + (setq n2 (- n1 (* (car units) (truncate n1 (car units))))) + (setq n1 next) + (setq res1 (truncate (* res1 (car units)))) + (pop units) + (setq unit1 (pop units))) + (setq n1 (truncate n1)) + (if n2 (setq n2 (truncate n2))) + (cond + ((null n2) + ;; revert to old just now style for < 1 min: + (cons "just now" 60)) + ;; (cons (format "%d %s%s" n1 unit1 (if (> n1 1) "s" "")) + ;; (max resolution res1))) + ((< (* res2 n2) resolution) + (cons (format "%d %s%s" n1 unit1 (if (> n1 1) "s" "")) + (max resolution res2))) + ((< res2 resolution) + (let ((n2 (/ (* resolution (/ (* n2 res2) resolution)) res2))) + (cons (format "%d %s%s, %d %s%s" + n1 unit1 (if (> n1 1) "s" "") + n2 unit2 (if (> n2 1) "s" "")) + resolution))) + (t + (cons (format "%d %s%s, %d %s%s" + n1 unit1 (if (> n1 1) "s" "") + n2 unit2 (if (> n2 1) "s" "")) + (max res2 resolution)))))) + +(defun mastodon-tl--format-read-poll-option (options) + "Format poll OPTIONS for `completing-read'. +OPTIONS is an alist." + ;; we display option number and the option title + ;; but also store both as a cons cell as the cdr, as we need it later + (cl-loop for cell in options + collect (cons (format "%s | %s" (car cell) (cdr cell)) + cell))) + +(defun mastodon-tl--read-poll-option () + "Read a poll option to vote on a poll." + (let* ((toot (mastodon-tl--property 'item-json)) + (poll (mastodon-tl--field 'poll toot))) + (if (null poll) + (user-error "No poll here") + (let* ((options (mastodon-tl--field 'options poll)) + (titles (mastodon-tl--map-alist 'title options)) + (number-seq (number-sequence 1 (length options))) + (numbers (mapcar #'number-to-string number-seq)) + (options-alist (cl-mapcar #'cons numbers titles)) + (candidates (mastodon-tl--format-read-poll-option options-alist)) + (choice (completing-read "Poll option to vote for: " + candidates nil :match))) + (list (cdr (assoc choice candidates))))))) + +(defun mastodon-tl--poll-vote (option) + "If there is a poll at point, prompt user for OPTION to vote on it." + (interactive (mastodon-tl--read-poll-option)) + (let ((toot (mastodon-tl--property 'item-json))) + (if (null (mastodon-tl--field 'poll toot)) + (user-error "No poll here") + (let* ((poll (mastodon-tl--field 'poll toot)) + (id (alist-get 'id poll)) + (url (mastodon-http--api (format "polls/%s/votes" id))) + ;; zero-index our option: + (option-arg (number-to-string + (1- (string-to-number (car option))))) + (arg `(("choices[]" . ,option-arg))) + (response (mastodon-http--post url arg))) + (mastodon-http--triage response + (lambda (_) + (message "You voted for option %s: %s!" + (car option) (cdr option)))))))) + + +;; VIDEOS / MPV + +(defun mastodon-tl--find-first-video-in-attachments () + "Return the first media attachment that is a moving image." + (let ((attachments (mastodon-tl--property 'attachments)) + vids) + (mapc (lambda (x) + (let ((att-type (plist-get x :type))) + (when (or (string= "video" att-type) + (string= "gifv" att-type)) + (push x vids)))) + attachments) + (car vids))) + +(defun mastodon-tl--mpv-play-video-from-byline () + "Run `mastodon-tl--mpv-play-video-at-point' on first moving image in post." + (interactive) + (let* ((video (mastodon-tl--find-first-video-in-attachments)) + (url (plist-get video :url)) + (type (plist-get video :type))) + (mastodon-tl--mpv-play-video-at-point url type))) + +(defun mastodon-tl--view-full-image-or-play-video (_pos) + "View full sized version of image at point, or try to play video." + (interactive "d") + (if (mastodon-tl--media-video-p) + (mastodon-tl--mpv-play-video-at-point) + (mastodon-tl--view-full-image))) + +(defun mastodon-tl--click-image-or-video (event) + "Click to play video with `mpv.el'. +EVENT is a mouse-click arg." + (interactive "@e") + (mastodon-tl--view-full-image-or-play-video + (posn-point (event-end event)))) + +(defun mastodon-tl--media-video-p (&optional type) + "T if mastodon-media-type prop is \"gifv\" or \"video\". +TYPE is a mastodon media type." + (let ((type (or type (mastodon-tl--property 'mastodon-media-type :no-move)))) + (or (string= type "gifv") + (string= type "video")))) + +(defun mastodon-tl--mpv-play-video-at-point (&optional url type) + "Play the video or gif at point with an mpv process. +URL and TYPE are provided when called while point is on byline, +in which case play first video or gif from current toot." + (interactive) + (let ((url (or url ; point in byline: + (mastodon-tl--property 'image-url :no-move)))) ; point in toot + (if (or (not url) + (not (mastodon-tl--media-video-p type))) + (user-error "No moving image here?") + (message "'q' to kill mpv.") + (condition-case x + (mpv-start "--loop" url) + (void-function + (message "Looks like mpv.el not installed. Error: %s" + (error-message-string x))))))) + +(defun mastodon-tl--copy-image-caption () + "Copy the caption of the image at point." + (interactive) + (if-let ((desc (get-text-property (point) 'image-description))) + (progn + (kill-new desc) + (message "Image caption copied.")) + (message "No image caption."))) + + +;;; INSERT TOOTS + +(defun mastodon-tl--content (toot) + "Retrieve text content from TOOT. +Runs `mastodon-tl--render-text' and fetches poll or media." + (let* ((content (mastodon-tl--field 'content toot)) + (poll-p (mastodon-tl--field 'poll toot)) + (media-p (mastodon-tl--field 'media_attachments toot))) + (concat (mastodon-tl--render-text content toot) + (when poll-p + (mastodon-tl--format-poll + (mastodon-tl--field 'poll toot))) ;; toot or reblog + (when media-p + (mastodon-tl--media toot))))) + +(defun mastodon-tl--prev-item-id () + "Return the id of the last toot inserted into the buffer." + (let* ((prev-change + (save-excursion + (previous-single-property-change (point) 'base-item-id))) + (prev-pos (when prev-change (1- prev-change)))) + (when prev-pos + (get-text-property prev-pos 'base-item-id)))) + +(defun mastodon-tl--after-reply-status (reply-to-id) + "T if REPLY-TO-ID is equal to that of the last toot inserted in the bufer." + (let ((prev-id (mastodon-tl--prev-item-id))) + (string= reply-to-id prev-id))) + +(defun mastodon-tl--insert-status + (toot body &optional detailed-p thread domain unfolded no-byline + cw-expanded) + "Display the content and byline of timeline element TOOT. +BODY will form the section of the toot above the byline. +DETAILED-P means display more detailed info. For now +this just means displaying toot client. +THREAD means the status will be displayed in a thread view. +When DOMAIN, force inclusion of user's domain in their handle. +UNFOLDED is a boolean meaning whether to unfold or fold item if foldable. +NO-BYLINE means just insert toot body, used for folding. +CW-EXPANDED means treat content warnings as unfolded." + (let* ((reply-to-id (alist-get 'in_reply_to_id toot)) + (after-reply-status-p + (when (and thread reply-to-id) + (mastodon-tl--after-reply-status reply-to-id))) + ;; (type (alist-get 'type toot)) + (toot-foldable + (and mastodon-tl--fold-toots-at-length + (length> body mastodon-tl--fold-toots-at-length))) + (cw-p (not + (string-empty-p + (alist-get 'spoiler_text toot))))) + (insert + (propertize ;; body + byline: + (concat + (propertize ;; body only: + (concat + "\n" + (mastodon-tl--byline-boost toot) ;; top byline (boost) + ;; relpy symbol: + (when (and after-reply-status-p thread) + (concat (mastodon-tl--symbol 'replied) + "\n")) + ;; actual body: + (let ((bar (mastodon-tl--symbol 'reply-bar)) + (body (if (and toot-foldable (not unfolded)) + (mastodon-tl--fold-body body) + body))) + (if (and after-reply-status-p thread) + (propertize body + 'line-prefix bar + 'wrap-prefix bar) + body)) + (if (and toot-foldable unfolded cw-expanded) + (mastodon-tl--read-more-or-less + "LESS" cw-p (not cw-expanded)) + "")) + 'toot-body t) ;; includes newlines etc. for folding + ;; byline: + "\n" + (if no-byline + "" + (mastodon-tl--byline toot detailed-p domain))) + 'item-type 'toot + 'item-id (alist-get 'id toot) ; toot id + 'base-item-id (mastodon-tl--item-id toot) ; with reblog check + 'item-json toot + 'cursor-face 'mastodon-cursor-highlight-face + 'toot-foldable toot-foldable + 'toot-folded (and toot-foldable (not unfolded))) + (if no-byline "" "\n")))) + +(defun mastodon-tl--is-reply (toot) + "Check if the TOOT is a reply to another one (and not boosted). +Used as a predicate in `mastodon-tl--timeline'." + (and (mastodon-tl--field 'in_reply_to_id toot) + (eq :json-false (mastodon-tl--field 'reblogged toot)))) + +(defun mastodon-tl--filters-alist (filters) + "Parse filter data for FILTERS. +For each filter, return a list of action (warn or hide), filter +title, and context." + (cl-loop for x in filters ;; includes non filter elts! + for f = (alist-get 'filter x) + collect (list (alist-get 'filter_action f) + (alist-get 'title f) + (alist-get 'context f)))) + +(defun mastodon-tl--filter-by-context (context filters) + "Remove FILTERS that don't apply to the current CONTEXT." + (cl-remove-if-not + (lambda (x) + (member context (nth 2 x))) + filters)) + +(defun mastodon-tl--filters-context () + "Return a string of the current buffer's filter context. +Returns a member of `mastodon-views--filter-types'." + (let ((buf (mastodon-tl--get-buffer-type))) + (cond ((or (eq buf 'local) (eq buf 'federated)) + "public") + ((mastodon-tl--profile-buffer-p) + "profile") + ((eq buf 'list-timeline) + "home") ;; lists are "home" filter + (t ;; thread, notifs, home: + (symbol-name buf))))) + +(defun mastodon-tl--current-filters (filters) + "Return the filters from FILTERS data that apply in the current context. +For each filter, return a list of action (warn or hide), filter +title, and context." + (let ((context (mastodon-tl--filters-context)) + (filters-no-context (mastodon-tl--filters-alist filters))) + (mastodon-tl--filter-by-context context filters-no-context))) + +(defun mastodon-tl--toot (toot &optional detailed-p thread domain + unfolded no-byline cw-expanded) + "Format TOOT and insert it into the buffer. +DETAILED-P means display more detailed info. For now +this just means displaying toot client. +THREAD means the status will be displayed in a thread view. +When DOMAIN, force inclusion of user's domain in their handle. +UNFOLDED is a boolean meaning whether to unfold or fold item if foldable. +NO-BYLINE means just insert toot body, used for folding. +CW-EXPANDED means treat content warnings as unfolded." + (let* ((mastodon-tl--expand-content-warnings + (or cw-expanded mastodon-tl--expand-content-warnings)) + (filtered (mastodon-tl--field 'filtered toot)) + (filters (when filtered + (mastodon-tl--current-filters filtered))) + (spoiler-or-content (if-let ((match (assoc "warn" filters))) + (mastodon-tl--spoiler toot (cadr match)) + (if (mastodon-tl--has-spoiler toot) + (mastodon-tl--spoiler toot) + (mastodon-tl--content toot))))) + ;; If any filters are "hide", then we hide, + ;; even though item may also have a "warn" filter: + (unless (and filtered (assoc "hide" filters)) ;; no insert + (mastodon-tl--insert-status + toot (mastodon-tl--clean-tabs-and-nl spoiler-or-content) + detailed-p thread domain unfolded no-byline cw-expanded)))) + +(defun mastodon-tl--timeline (toots &optional thread domain no-byline) + "Display each toot in TOOTS. +This function removes replies if user required. +THREAD means the status will be displayed in a thread view. +When DOMAIN, force inclusion of user's domain in their handle. +NO-BYLINE means just insert toot body, used for folding." + (let ((start-pos (point)) + (toots ;; hack to *not* filter replies on profiles: + (if (eq (mastodon-tl--get-buffer-type) 'profile-statuses) + toots + (if (or ; we were called via --more*: + (mastodon-tl--buffer-property 'hide-replies nil :no-error) + ;; loading a tl with a prefix arg: + (mastodon-tl--hide-replies-p current-prefix-arg)) + (cl-remove-if-not #'mastodon-tl--is-reply toots) + toots)))) + (mapc (lambda (toot) + (mastodon-tl--toot toot nil thread domain nil no-byline)) + toots) + ;; media: + (when mastodon-tl--display-media-p + (mastodon-media--inline-images start-pos (point))) + (goto-char (point-min)))) + +;;; FOLDING + +(defun mastodon-tl--read-more-or-less (str cw invis) + "Return a read more or read less heading. +STR is an uppercase string, either MORE or LESS. +The heading is a link to toggle the fold status of the toot. +CW and INVIS are boolean values for the properties invisible and +mastodon-content-warning-body." + (let ((type (if (string= str "MORE") 'read-more 'read-less))) + (propertize + (mastodon-search--format-heading + (mastodon-tl--make-link (format "READ %s" str) type) + nil :no-newline) + 'mastodon-content-warning-body cw + 'invisible invis))) + +(defun mastodon-tl--fold-body (body) + "Fold toot BODY if it is very long. +Folding decided by `mastodon-tl--fold-toots-at-length'." + (let* ((invis (get-text-property (1- (length body)) 'invisible body)) + (cw (get-text-property (1- (length body)) + 'mastodon-content-warning-body body)) + (heading (mastodon-tl--read-more-or-less "MORE" cw invis)) + (display (concat (substring body 0 + mastodon-tl--fold-toots-at-length) + heading))) + (propertize display + 'read-more body))) + +(defun mastodon-tl--unfold-post (&optional fold) + "Unfold the toot at point if it is folded (read-more). +FOLD means to fold it instead." + (interactive) + (let ((at-byline (mastodon-tl--property 'byline :no-move))) + (if (save-excursion + (when (not at-byline) + (mastodon-tl--goto-next-item)) + (not (mastodon-tl--property 'toot-foldable :no-move))) + (user-error "No foldable item at point?") + (let* ((inhibit-read-only t) + (body-range (mastodon-tl--find-property-range 'toot-body + (point) :backward)) + (cw-range (mastodon-tl--find-property-range + 'mastodon-content-warning-body + (point) :backward)) + (cw-invis (when cw-range + (get-text-property (car cw-range) 'invisible))) + (toot (mastodon-tl--property 'item-json :no-move)) + ;; `replace-region-contents' is much too slow, our hack from + ;; fedi.el is much simpler and much faster: + (beg (car body-range)) + (end (cdr body-range)) + (last-point (point)) + (point-after-fold (> last-point + (+ beg mastodon-tl--fold-toots-at-length)))) + ;; save-excursion here useless actually: + ;; FIXME: because point goes to top of item, the screen gets scrolled + ;; by insertion + (goto-char beg) + (delete-region beg end) + (delete-char 1) ;; prevent newlines accumulating + ;; insert toot body: + (mastodon-tl--toot toot nil nil nil (not fold) :no-byline + (unless cw-invis :cw-expanded)) ;; respect CW state + ;; set toot-folded prop on entire toot (not just body): + (let ((toot-range ;; post fold action range: + (mastodon-tl--find-property-range 'item-json + (point) :backward))) + (add-text-properties (car toot-range) + (cdr toot-range) + `(toot-folded ,fold))) + ;; try to leave point somewhere sane: + (cond ((or at-byline + (and fold point-after-fold)) ;; point was in area now folded + (ignore-errors (forward-line -1)) ;; in case we are between + (mastodon-tl--goto-next-item)) ;; goto byline + (t + (goto-char last-point) + (when point-after-fold ;; point was in READ MORE heading: + (beginning-of-line)))) + (message (format "%s toot" (if fold "Fold" "Unfold"))))))) + +(defun mastodon-tl--fold-post () + "Fold post at point, if it is too long." + (interactive) + (mastodon-tl--unfold-post :fold)) + +(defun mastodon-tl--fold-post-toggle () + "Toggle the folding status of the toot at point." + (interactive) + (let* ((folded (mastodon-tl--property 'toot-folded :no-move))) + (mastodon-tl--unfold-post (not folded)))) + +;;; TOOT STATS + +;; calqued off mastodon-alt.el: +(defun mastodon-tl--toot-for-stats (&optional toot) + "Return the TOOT on which we want to extract stats. +If no TOOT is given, the one at point is considered." + (let* ((original-toot (or toot (get-text-property (point) 'item-json))) + (toot (or (alist-get 'status original-toot) + (when (alist-get 'type original-toot) + original-toot) + (alist-get 'reblog original-toot) + original-toot)) + (type (alist-get 'type (or toot)))) + (unless (member type '("follow" "follow_request")) + toot))) + +(defun mastodon-tl--toot-stats (toot) + "Return a right aligned string (using display align-to). +String is filled with TOOT statistics (boosts, favs, replies). +When the TOOT is a reblog (boost), statistics from reblogged +toots are returned. +To disable showing the stats, customize +`mastodon-tl--show-stats'." + (let-alist (mastodon-tl--toot-for-stats toot) + (let* ((faves-prop (propertize (format "%s" .favourites_count) + 'favourites-count .favourites_count)) + (boosts-prop (propertize (format "%s" .reblogs_count) + 'boosts-count .reblogs_count)) + (faves (format "%s %s" faves-prop (mastodon-tl--symbol 'favourite))) + (boosts (format "%s %s" boosts-prop (mastodon-tl--symbol 'boost))) + (replies (format "%s %s" .replies_count (mastodon-tl--symbol 'reply))) + (stats (concat + (propertize faves + 'favourited-p (eq t .favourited) + 'favourites-field t + 'help-echo (format "%s favourites" .favourites_count) + 'face 'font-lock-comment-face) + (propertize " | " 'face 'font-lock-comment-face) + (propertize boosts + 'boosted-p (eq t .reblogged) + 'boosts-field t + 'help-echo (format "%s boosts" .reblogs_count) + 'face 'font-lock-comment-face) + (propertize " | " 'face 'font-lock-comment-face) + (propertize replies + 'replies-field t + 'replies-count .replies_count + 'help-echo (format "%s replies" .replies_count) + 'face 'font-lock-comment-face))) + (right-spacing + (propertize " " + 'display + `(space :align-to (- right ,(+ (length stats) 7)))))) + (concat right-spacing stats)))) + + +;;; BUFFER SPEC + +(defun mastodon-tl--update-function (&optional buffer) + "Get the UPDATE-FUNCTION stored in `mastodon-tl--buffer-spec'. +Optionally get it for BUFFER." + (mastodon-tl--buffer-property 'update-function buffer)) + +(defun mastodon-tl--endpoint (&optional buffer no-error) + "Get the ENDPOINT stored in `mastodon-tl--buffer-spec'. +Optionally set it for BUFFER. +NO-ERROR means to fail silently." + (mastodon-tl--buffer-property 'endpoint buffer no-error)) + +(defun mastodon-tl--buffer-name (&optional buffer no-error) + "Get the BUFFER-NAME stored in `mastodon-tl--buffer-spec'. +Optionally get it for BUFFER. +NO-ERROR means to fail silently." + (mastodon-tl--buffer-property 'buffer-name buffer no-error)) + +(defun mastodon-tl--link-header (&optional buffer) + "Get the LINK HEADER stored in `mastodon-tl--buffer-spec'. +Optionally get it for BUFFER." + (mastodon-tl--buffer-property 'link-header buffer :no-error)) + +(defun mastodon-tl--update-params (&optional buffer) + "Get the UPDATE PARAMS stored in `mastodon-tl--buffer-spec'. +Optionally get it for BUFFER." + (mastodon-tl--buffer-property 'update-params buffer :no-error)) + +(defun mastodon-tl--buffer-property (property &optional buffer no-error) + "Get PROPERTY from `mastodon-tl--buffer-spec' in BUFFER or `current-buffer'. +If NO-ERROR is non-nil, do not error when property is empty." + (with-current-buffer (or buffer (current-buffer)) + (if no-error + (plist-get mastodon-tl--buffer-spec property) + (or (plist-get mastodon-tl--buffer-spec property) + (error "Mastodon-tl--buffer-spec not defined for buffer %s, prop %s" + (or buffer (current-buffer)) + property))))) + +(defun mastodon-tl--set-buffer-spec + (buffer endpoint update-fun + &optional link-header update-params hide-replies max-id + thread-item-id) + "Set `mastodon-tl--buffer-spec' for the current buffer. +BUFFER is buffer name, ENDPOINT is buffer's enpoint, +UPDATE-FUN is its update function. +LINK-HEADER is the http Link header if present. +UPDATE-PARAMS is any http parameters needed for the update function. +HIDE-REPLIES is a flag indicating if replies are hidden in the current buffer. +MAX-ID is the pagination parameter. +THREAD-ITEM-ID is the ID of the item in thread that we opened the thread with." + (setq mastodon-tl--buffer-spec + `( account ,(cons mastodon-active-user mastodon-instance-url) + buffer-name ,buffer + endpoint ,endpoint + update-function ,update-fun + link-header ,link-header + update-params ,update-params + hide-replies ,hide-replies + max-id ,max-id + thread-item-id ,thread-item-id))) + + +;;; BUFFERS + +(defun mastodon-tl--endpoint-str-= (str &optional type) + "Return T if STR is equal to the current buffer's endpoint. +TYPE may be :prefix or :suffix, in which case, T if STR is a prefix or suffix." + (let ((endpoint-fun (mastodon-tl--endpoint nil :no-error))) + (cond ((eq type :prefix) + (string-prefix-p str endpoint-fun)) + ((eq type :suffix) + (string-suffix-p str endpoint-fun)) + (t + (string= str endpoint-fun))))) + +(defun mastodon-tl--get-buffer-type () + "Return a symbol descriptive of current mastodon buffer type. +Should work in all mastodon buffers. +Note that for many buffers, this requires `mastodon-tl--buffer-spec' +to be set. It is set for almost all buffers, but you still have to +call this function after it is set or use something else." + (let ((buffer-name (mastodon-tl--buffer-name nil :no-error))) + (cond (mastodon-toot-mode + ;; composing/editing (no buffer spec): + (if (string= "*edit toot*" (buffer-name)) + 'edit-toot + 'new-toot)) + ;; main timelines: + ((mastodon-tl--endpoint-str-= "timelines/home") + 'home) + ((string= "*mastodon-local*" buffer-name) + 'local) + ((mastodon-tl--endpoint-str-= "timelines/public") + 'federated) + ((mastodon-tl--endpoint-str-= "timelines/tag/" :prefix) + 'tag-timeline) + ((mastodon-tl--endpoint-str-= "timelines/list/" :prefix) + 'list-timeline) + ;; notifs: + ((string-suffix-p "mentions*" buffer-name) + 'mentions) + ((mastodon-tl--endpoint-str-= "notifications") + 'notifications) + ;; threads: + ((mastodon-tl--endpoint-str-= "context" :suffix) + 'thread) + ((mastodon-tl--endpoint-str-= "statuses" :prefix) + 'single-status) + ;; profiles: + ((mastodon-tl--profile-buffer-p) + (cond + ;; an own profile option is needlessly confusing e.g. for + ;; `mastodon-profile--account-view-cycle' + ;; profile note: + ((string-suffix-p "update-profile*" buffer-name) + 'update-profile-note) + ;; posts inc. boosts: + ((string-suffix-p "no-boosts*" buffer-name) + 'profile-statuses-no-boosts) + ((string-suffix-p "no-replies*" buffer-name) + 'profile-statuses-no-replies) + ((string-suffix-p "only-media*" buffer-name) + 'profile-statuses-only-media) + ((string-match-p "-tagged-" buffer-name) + 'profile-statuses-tagged) + ((mastodon-tl--endpoint-str-= "statuses" :suffix) + 'profile-statuses) + ;; profile followers + ((mastodon-tl--endpoint-str-= "followers" :suffix) + 'profile-followers) + ;; profile following + ((mastodon-tl--endpoint-str-= "following" :suffix) + 'profile-following))) + ((mastodon-tl--endpoint-str-= "preferences") + 'preferences) + ;; search + ((mastodon-tl--search-buffer-p) + (cond ((string= "accounts" (mastodon-search--buf-type)) + 'search-accounts) + ((string= "hashtags" (mastodon-search--buf-type)) + 'search-hashtags) + ((string= "statuses" (mastodon-search--buf-type)) + 'search-statuses))) + ;; trends + ((mastodon-tl--endpoint-str-= "trends/statuses") + 'trending-statuses) + ((mastodon-tl--endpoint-str-= "trends/tags") + 'trending-tags) + ((mastodon-tl--endpoint-str-= "trends/links") + 'trending-links) + ;; User's views: + ((mastodon-tl--endpoint-str-= "filters") + 'filters) + ((mastodon-tl--endpoint-str-= "lists") + 'lists) + ((mastodon-tl--endpoint-str-= "suggestions") + 'follow-suggestions) + ((mastodon-tl--endpoint-str-= "favourites") + 'favourites) + ((mastodon-tl--endpoint-str-= "bookmarks") + 'bookmarks) + ((mastodon-tl--endpoint-str-= "follow_requests") + 'follow-requests) + ((mastodon-tl--endpoint-str-= "scheduled_statuses") + 'scheduled-statuses) + ;; instance description + ((mastodon-tl--endpoint-str-= "instance") + 'instance-description) + ((string= "*mastodon-toot-edits*" buffer-name) + 'toot-edits) + ((string= "*masto-image*" (buffer-name)) + 'mastodon-image) + ((mastodon-tl--endpoint-str-= "timelines/link") + 'link-timeline) + ((mastodon-tl--endpoint-str-= "announcements") + 'announcements)))) + +(defun mastodon-tl--buffer-type-eq (type) + "Return t if current buffer type is equal to symbol TYPE." + (eq (mastodon-tl--get-buffer-type) type)) + +(defun mastodon-tl--profile-buffer-p () + "Return t if current buffer is a profile buffer of any kind. +This includes the update profile note buffer, but not the preferences one." + (string-prefix-p "accounts" (mastodon-tl--endpoint nil :no-error))) + +(defun mastodon-tl--search-buffer-p () + "T if current buffer is a search buffer." + (string-suffix-p "search" (mastodon-tl--endpoint nil :no-error))) + +(defun mastodon-tl--timeline-proper-p () + "Return non-nil if the current buffer is a \"proper\" timeline. +A proper timeline excludes notifications, threads, profiles, and +other toot buffers that aren't strictly mastodon timelines." + (let ((timeline-buffers + '(home federated local tag-timeline list-timeline profile-statuses))) + (member (mastodon-tl--get-buffer-type) timeline-buffers))) + +(defun mastodon-tl--hide-replies-p (&optional prefix) + "Return non-nil if replies should be hidden in the timeline. +We hide replies if user explictly set the +`mastodon-tl--hide-replies' or used PREFIX combination to open a +timeline." + (and (mastodon-tl--timeline-proper-p) ; Only if we are in a proper timeline + (or mastodon-tl--hide-replies ; User configured to hide replies + (equal '(4) prefix)))) ; Timeline called with C-u prefix + + +;;; UTILITIES + +(defun mastodon-tl--clean-tabs-and-nl (string) + "Remove tabs and newlines from STRING." + (replace-regexp-in-string "[\t\n ]*\\'" "" string)) + +(defun mastodon-tl--map-alist (key alists &optional testfn) + "Return a list of values extracted from ALISTS with KEY. +Key is a symbol, as with `alist-get', or else compatible with TESTFN. +ALISTS is a list of alists." + ;; this actually for a list of alists, right? so change the arg? + (cl-loop for x in alists + collect (alist-get key x nil nil testfn))) + +(defun mastodon-tl--map-alist-vals-to-alist (key1 key2 alist) + "From ALIST, return an alist consisting of (val1 . val2) elements. +Values are accessed by `alist-get', using KEY1 and KEY2." + (cl-loop for x in alist + collect (cons (alist-get key1 x) + (alist-get key2 x)))) + +(defun mastodon-tl--symbol (name) + "Return the unicode symbol (as a string) corresponding to NAME. +If symbol is not displayable, an ASCII equivalent is returned. If +NAME is not part of the symbol table, '?' is returned." + (if-let* ((symbol (alist-get name mastodon-tl--symbols))) + (if (char-displayable-p (string-to-char (car symbol))) + (car symbol) + (cdr symbol)) + "?")) + +(defun mastodon-tl--set-face (string face) + "Return the propertized STRING with the face property set to FACE." + (propertize string 'face face)) + +(defun mastodon-tl--field (field toot) + "Return FIELD from TOOT. +Return value from boosted content if available." + (or (alist-get field (alist-get 'reblog toot)) + (alist-get field toot))) + +(defun mastodon-tl--field-status (field toot) + "Return FIELD from TOOT. +Return value from status field if available." + (or (alist-get field (alist-get 'status toot)) + (alist-get field toot))) + +(defun mastodon-tl--remove-html (toot) + "Remove unrendered tags from TOOT." + (let* ((t1 (replace-regexp-in-string "<\/p>" "\n\n" toot)) + (t2 (replace-regexp-in-string "<\/?span>" "" t1))) + (replace-regexp-in-string "" "" t2))) + +(defun mastodon-tl--property (prop &optional no-move backward) + "Get property PROP for toot at point. +Move forward (down) the timeline unless NO-MOVE is non-nil. +BACKWARD means move backward (up) the timeline." + (if no-move + (get-text-property (point) prop) + ;; NB: this doesn't differentiate absence of property from + ;; property set to zero, making flag props fraught: + (or (get-text-property (point) prop) + (save-excursion + (if backward + (mastodon-tl--goto-prev-item) + (mastodon-tl--goto-next-item)) + (get-text-property (point) prop))))) + +(defun mastodon-tl--newest-id () + "Return item-id from the top of the buffer. +If we are in a notifications view, return `notifications-max-id'." + (save-excursion + (goto-char (point-min)) + (mastodon-tl--property + (if (eq (mastodon-tl--get-buffer-type) + (member (mastodon-tl--get-buffer-type) + '(mentions notifications))) + 'notifications-max-id + 'item-id)))) + +(defun mastodon-tl--oldest-id () + "Return item-id from the bottom of the buffer. +If we are in a notifications view, return `notifications-min-id'." + (save-excursion + (goto-char (point-max)) + (mastodon-tl--property + (if (and mastodon-group-notifications + (member (mastodon-tl--get-buffer-type) + '(mentions notifications))) + 'notifications-min-id + 'item-id) + nil :backward))) + +(defun mastodon-tl--as-string (numeric) + "Convert NUMERIC to string." + (cond ((numberp numeric) + (number-to-string numeric)) + ((stringp numeric) numeric) + (t (error "Numeric: %s must be either a string or a number" + numeric)))) + +(defun mastodon-tl--item-id (json) + "Find approproiate toot id in JSON. +If the toot has been boosted use the id found in the +reblog portion of the toot. Otherwise, use the body of +the toot. This is the same behaviour as the mastodon.social +webapp" + (let-alist json + (if .reblog .reblog.id .id))) + +(defun mastodon-tl--toot-or-base (json) + "Return the base toot or just the toot from toot JSON." + (or (alist-get 'reblog json) json)) + + +;;; THREADS + +(defun mastodon-tl--single-toot (id) + "View toot at point in separate buffer. +ID is that of the toot to view." + (interactive) + (let* ((buffer (format "*mastodon-toot-%s*" id)) + (toot (mastodon-http--get-json + (mastodon-http--api (concat "statuses/" id))))) + (if (eq (caar toot) 'error) + (user-error "Error: %s" (cdar toot)) + (with-mastodon-buffer buffer #'mastodon-mode nil + (mastodon-tl--set-buffer-spec buffer (format "statuses/%s" id) + #'mastodon-tl--update-toot) + (mastodon-tl--toot toot :detailed-p) + (goto-char (point-min)) + (when mastodon-tl--display-media-p + (mastodon-media--inline-images (point-min) + (point-max))) + (mastodon-tl--goto-next-item :no-refresh))))) + +(defun mastodon-tl--update-toot (json) + "Call `mastodon-tl--single-toot' on id found in JSON." + (let ((id (alist-get 'id json))) + (mastodon-tl--single-toot id))) + +(defun mastodon-tl--view-whole-thread () + "From a thread view, view entire thread. +If you load a thread from a toot, only the branches containing +are displayed by default. Call this if you subsequently want to +view all branches of a thread." + (interactive) + (if (not (eq (mastodon-tl--get-buffer-type) 'thread)) + (user-error "You need to be viewing a thread to call this") + (goto-char (point-min)) + (let ((id (mastodon-tl--property 'base-item-id))) + (mastodon-tl--thread id)))) + +(defun mastodon-tl--thread (&optional thread-id) + "Open thread buffer for toot at point or with THREAD-ID. +UNFOLDED STATE is a boolean of whether the thread (that we are +reloading) is fully unfolded or folded, i.e. via +`mastodon-tl--toggle-spoiler-in-thread'." + (interactive) + (if (not (eq 'toot (mastodon-tl--property 'item-type :no-move))) + (user-error "Looks like there's no toot at point?") + (mastodon-tl--thread-do thread-id))) + +(defun mastodon-tl--thread-do (&optional thread-id) + "Open thread buffer for toot at point or with THREAD-ID. +UNFOLDED STATE is a boolean of whether the thread (that we are +reloading) is fully unfolded or folded, i.e. via +`mastodon-tl--toggle-spoiler-in-thread'. +This is the non-interactive version, so we can call it +programmatically and not crash into +`mastodon-toot--with-toot-item'." + ;; this function's var must not be id as the above macro binds id and even + ;; if we provide the arg (e.g. url-lookup), the macro definition overrides + ;; it, making the optional arg unusable! + (let* ((id (or thread-id (mastodon-tl--property 'base-item-id :no-move))) + (type (mastodon-tl--field 'type + (mastodon-tl--property 'item-json :no-move))) + (unfolded-state (mastodon-tl--buffer-property 'thread-unfolded + (current-buffer) :noerror)) + (mastodon-tl--expand-content-warnings + ;; if reloading and thread was explicitly (un)folded, respect it: + (or (pcase unfolded-state + ('folded nil) + ('unfolded t) + (_ mastodon-tl--expand-content-warnings))))) + (if (or (string= type "follow_request") + (string= type "follow")) ; no can thread these + (user-error "No thread") + (let* ((endpoint (format "statuses/%s/context" id)) + (url (mastodon-http--api endpoint)) + (buffer (format "*mastodon-thread-%s*" id)) + (toot (mastodon-http--get-json ; refetch in case we just faved/boosted: + (mastodon-http--api (concat "statuses/" id)) + nil :silent)) + (context (mastodon-http--get-json url nil :silent))) + (if (eq (caar toot) 'error) + (user-error "Error: %s" (cdar toot)) + (when (member (alist-get 'type toot) '("reblog" "favourite")) + (setq toot (alist-get 'status toot))) + (if (not (< 0 (+ (length (alist-get 'ancestors context)) + (length (alist-get 'descendants context))))) + ;; just print the lone toot: + (mastodon-tl--single-toot id) + ;; we have a thread: + (with-mastodon-buffer buffer #'mastodon-mode nil + (let ((marker (make-marker))) + (mastodon-tl--set-buffer-spec buffer endpoint + #'mastodon-tl--thread + nil nil nil nil id) + (when unfolded-state + (plist-put mastodon-tl--buffer-spec + 'thread-unfolded unfolded-state)) + (mastodon-tl--timeline (alist-get 'ancestors context) :thread) + (goto-char (point-max)) + (move-marker marker (point)) + ;; print re-fetched toot: + (mastodon-tl--toot toot :detailed-p :thread) + ;; inline images only for the toot + ;; (`mastodon-tl--timeline' handles the rest): + (when mastodon-tl--display-media-p + (mastodon-media--inline-images marker ;start-pos + (point))) + (mastodon-tl--timeline (alist-get 'descendants context) + :thread) + ;; put point at the toot: + (goto-char (marker-position marker)) + (mastodon-tl--goto-next-item))))))))) + +(defun mastodon-tl--mute-thread () + "Mute the thread displayed in the current buffer. +Note that you can only (un)mute threads you have posted in." + (interactive) + (mastodon-tl--mute-or-unmute-thread)) + +(defun mastodon-tl--unmute-thread () + "Unmute the thread displayed in the current buffer. +Note that you can only (un)mute threads you have posted in." + (interactive) + (mastodon-tl--mute-or-unmute-thread :unmute)) + +(defun mastodon-tl--thread-parent-id () + "Return the ID of the top item in a thread." + (save-excursion + (mastodon-tl--goto-first-item) + (mastodon-tl--property 'base-item-id :no-move))) + +(defun mastodon-tl--mute-or-unmute-thread (&optional unmute) + "Mute a thread. +If UNMUTE, unmute it." + (let ((mute-str (if unmute "unmute" "mute"))) + (when (or (mastodon-tl--buffer-type-eq 'thread) + (mastodon-tl--buffer-type-eq 'notifications)) + (let* ((id + ;; the id for `mastodon-tl--user-in-thread-p' ought to be the + ;; top-level item: + (if (mastodon-tl--buffer-type-eq 'notifications) + (mastodon-tl--property 'base-item-id :no-move) + (mastodon-tl--thread-parent-id))) + (we-posted-p (mastodon-tl--user-in-thread-p id)) + (url (mastodon-http--api (format "statuses/%s/%s" id mute-str)))) + (if (not we-posted-p) + (user-error "You can only (un)mute a thread you have posted in") + (when (y-or-n-p (format "%s this thread? " (capitalize mute-str))) + (let ((response (mastodon-http--post url))) + (mastodon-http--triage + response + (lambda (_) + (message (format "Thread %sd!" mute-str))))))))))) + +(defun mastodon-tl--map-account-id-from-toot (statuses) + "Return a list of the account IDs of the author of each toot in STATUSES." + (mapcar (lambda (status) + (map-nested-elt status '(account id))) + statuses)) + +(defun mastodon-tl--user-in-thread-p (id) + "Return non-nil if the logged-in user has posted to the current thread. +ID is that of the post the context is currently displayed for." + (let* ((context-json (mastodon-http--get-json + (mastodon-http--api (format "statuses/%s/context" id)) + nil :silent)) + (ancestors (alist-get 'ancestors context-json)) + (descendants (alist-get 'descendants context-json)) + (a-ids (mastodon-tl--map-account-id-from-toot ancestors)) + (d-ids (mastodon-tl--map-account-id-from-toot descendants))) + (or (member (mastodon-auth--get-account-id) a-ids) + (member (mastodon-auth--get-account-id) d-ids)))) + + +;;; FOLLOW/BLOCK/MUTE, ETC + +(defun mastodon-tl--follow-user (user-handle + &optional notify langs reblogs json) + "Query for USER-HANDLE from current status and follow that user. +If NOTIFY is \"true\", enable notifications when that user posts. +If NOTIFY is \"false\", disable notifications when that user posts. +Can be called to toggle NOTIFY on users already being followed. +LANGS is an array parameters alist of languages to filer user's posts by. +REBLOGS is a boolean string like NOTIFY, enabling or disabling +display of the user's boosts in your timeline. +JSON is a flag arg for `mastodon-http--post'." + (interactive (list (mastodon-tl--user-handles-get "follow"))) + (mastodon-tl--do-if-item + (mastodon-tl--do-user-action-and-response + user-handle "follow" nil notify langs reblogs json))) + +;; TODO: make this action "enable/disable notifications" +(defun mastodon-tl--enable-notify-user-posts (user-handle) + "Query for USER-HANDLE and enable notifications when they post." + (interactive (list (mastodon-tl--user-handles-get "enable"))) + (mastodon-tl--do-if-item + (mastodon-tl--follow-user user-handle "true"))) + +(defun mastodon-tl--disable-notify-user-posts (user-handle) + "Query for USER-HANDLE and disable notifications when they post." + (interactive (list (mastodon-tl--user-handles-get "disable"))) + (mastodon-tl--follow-user user-handle "false")) + +(defun mastodon-tl--follow-user-disable-boosts (user-handle) + "Prompt for a USER-HANDLE, and disable display of boosts in home timeline. +If they are also not yet followed, follow them." + (interactive (list (mastodon-tl--user-handles-get "disable boosts"))) + (mastodon-tl--follow-user user-handle nil nil "false")) + +(defun mastodon-tl--follow-user-enable-boosts (user-handle) + "Prompt for a USER-HANDLE, and enable display of boosts in home timeline. +If they are also not yet followed, follow them. +You only need to call this if you have previously disabled +display of boosts." + (interactive (list (mastodon-tl--user-handles-get "enable boosts"))) + (mastodon-tl--follow-user user-handle nil nil "true")) + +(defun mastodon-tl--filter-user-user-posts-by-language (user-handle) + "Query for USER-HANDLE and filter display of their posts by language. +If they are not already followed, they will be too. +To be filtered, a post has to be marked as in the language given. +This may mean that you will not see posts that are in your +desired language if they are not marked as such (or as anything)." + (interactive (list (mastodon-tl--user-handles-get "filter by language"))) + (let ((langs (mastodon-tl--read-filter-langs))) + (mastodon-tl--do-if-item + (if (string= "" (cdar langs)) + (mastodon-tl--unfilter-user-languages user-handle) + (mastodon-tl--follow-user user-handle nil langs))))) + +(defun mastodon-tl--unfilter-user-languages (user-handle) + "Remove any language filters for USER-HANDLE. +This means you will receive posts of theirs marked as being in +any or no language." + (interactive (list (mastodon-tl--user-handles-get "filter by language"))) + (let ((langs "languages[]")) + (mastodon-tl--do-if-item + ;; we need "languages[]" as a param, with no "=" and not json-encoded as + ;; a string + (mastodon-tl--follow-user user-handle nil langs nil :raw)))) + +(defun mastodon-tl--read-filter-langs (&optional langs) + "Read language choices and return an alist array parameter. +LANGS is the accumulated array param alist if we re-run recursively." + (let* ((iso-const mastodon-iso-639-1) + (iso (cons '("None (all)" . "") iso-const)) + (langs-alist langs) + (choice (completing-read "Filter user's posts by language: " + iso))) + (when choice + (setq langs-alist + (push `("languages[]" . ,(alist-get choice iso + nil nil #'string=)) + langs-alist)) + (if (y-or-n-p "Filter by another language? ") + (mastodon-tl--read-filter-langs langs-alist) + langs-alist)))) + +(defun mastodon-tl--unfollow-user (user-handle) + "Query for USER-HANDLE from current status and unfollow that user." + (interactive (list (mastodon-tl--user-handles-get "unfollow"))) + (mastodon-tl--do-if-item + (mastodon-tl--do-user-action-and-response user-handle "unfollow" t))) + +(defun mastodon-tl--block-user (user-handle) + "Query for USER-HANDLE from current status and block that user." + (interactive (list (mastodon-tl--user-handles-get "block"))) + (mastodon-tl--do-if-item + (mastodon-tl--do-user-action-and-response user-handle "block"))) + +(defun mastodon-tl--unblock-user (user-handle) + "Query for USER-HANDLE from list of blocked users and unblock that user." + (interactive (list (mastodon-tl--get-blocks-or-mutes-list "unblock"))) + (if (not user-handle) + (user-error "Looks like you have no blocks to unblock!") + (mastodon-tl--do-user-action-and-response user-handle "unblock" t))) + +(defun mastodon-tl--mute-user (user-handle) + "Query for USER-HANDLE from current status and mute that user." + (interactive (list (mastodon-tl--user-handles-get "mute"))) + (mastodon-tl--do-if-item + (mastodon-tl--do-user-action-and-response user-handle "mute"))) + +(defun mastodon-tl--unmute-user (user-handle) + "Query for USER-HANDLE from list of muted users and unmute that user." + (interactive (list (mastodon-tl--get-blocks-or-mutes-list "unmute"))) + (if (not user-handle) + (user-error "Looks like you have no mutes to unmute!") + (mastodon-tl--do-user-action-and-response user-handle "unmute" t))) + +(defun mastodon-tl--dm-user (user-handle) + "Query for USER-HANDLE from current status and compose a message to that user." + (interactive (list (mastodon-tl--user-handles-get "message"))) + (mastodon-tl--do-if-item + (mastodon-toot--compose-buffer (concat "@" user-handle)) + (setq mastodon-toot--visibility "direct") + (mastodon-toot--update-status-fields))) + +(defun mastodon-tl--user-handles-get (action) + "Get the list of user-handles for ACTION from the current toot." + (mastodon-tl--do-if-item + (let ((user-handles + (cond + ((or ; follow suggests / search / foll requests compat: + (member (mastodon-tl--get-buffer-type) + '( follow-suggestions search follow-requests + ;; profile follows/followers but not statuses: + profile-followers profile-following))) + ;; fetch 'item-json: + (list (alist-get 'acct + (mastodon-tl--property 'item-json :no-move)))) + ;; profile view, point in profile details, poss no toots + ;; needed for e.g. gup.pe groups which show no toots publically: + ((and (mastodon-tl--profile-buffer-p) + (get-text-property (point) 'profile-json)) + (list (alist-get 'acct + (mastodon-profile--profile-json)))) + ;; (grouped) notifications: + ((member (mastodon-tl--get-buffer-type) '(mentions notifications)) + (append ;; those acting on item: + (cl-remove-duplicates + (cl-loop for a in (mastodon-tl--property + 'notification-accounts :no-move) + collect (alist-get 'acct a))) + ;; mentions in item: + (mastodon-profile--extract-users-handles + (mastodon-profile--item-json)))) + (t + (mastodon-profile--extract-users-handles + (mastodon-profile--item-json)))))) + (completing-read + (cond ((or ; TODO: make this "enable/disable notifications" + (string= action "disable") + (string= action "enable")) + (format "%s notifications when user posts: " action)) + ((string-suffix-p "boosts" action) + (format "%s by user: " action)) + (t (format "Handle of user to %s: " action))) + user-handles nil ; predicate + 'confirm)))) + +(defun mastodon-tl--get-blocks-or-mutes-list (action) + "Fetch the list of accounts for ACTION from the server. +Action must be either \"unblock\" or \"unmute\"." + (let* ((endpoint (cond ((string= action "unblock") + "blocks") + ((string= action "unmute") + "mutes"))) + (url (mastodon-http--api endpoint)) + (json (mastodon-http--get-json url)) + (accts (mastodon-tl--map-alist 'acct json))) + (when accts + (completing-read (format "Handle of user to %s: " action) + accts nil :match)))) + +(defun mastodon-tl--do-user-action-and-response + (user-handle action &optional negp notify langs reblogs json) + "Do ACTION on user USER-HANDLE. +NEGP is whether the action involves un-doing something. +If NOTIFY is \"true\", enable notifications when that user posts. +If NOTIFY is \"false\", disable notifications when that user posts. +NOTIFY is only non-nil when called by `mastodon-tl--follow-user'. +LANGS is an array parameters alist of languages to filer user's posts by. +REBLOGS is a boolean string like NOTIFY, enabling or disabling +display of the user's boosts in your timeline." + (let* ((account + (cond + (negp ;; unmuting/unblocking, use mute/block list + (mastodon-profile--search-account-by-handle user-handle)) + ;; (grouped) notifications: + ((member (mastodon-tl--get-buffer-type) + '(mentions notifications)) + (let ((accounts (mastodon-tl--property 'notification-accounts))) + (or (cl-some (lambda (x) + (when (string= user-handle (alist-get 'acct x)) + x)) + accounts) + (mastodon-profile--lookup-account-in-status + user-handle + (mastodon-profile--item-json))))) + (t + (mastodon-profile--lookup-account-in-status + user-handle + (if (mastodon-tl--profile-buffer-p) + ;; profile view, use 'profile-json as status: + (mastodon-profile--profile-json) + ;; muting/blocking, select from handles in current status + (mastodon-profile--item-json)))))) + (user-id (alist-get 'id account)) + (name (mastodon-tl--display-or-uname account)) + (args (cond (notify `(("notify" . ,notify))) + (langs langs) + (reblogs `(("reblogs" . ,reblogs))) + (t nil))) + (url (mastodon-http--api (format "accounts/%s/%s" user-id action)))) + (if (not account) + (user-error "Cannot find a user with handle %S" user-handle) + (when (or (string= action "follow") ;; y-or-n for all but follow + (y-or-n-p (format "%s user %s? " action name))) + (mastodon-tl--do-user-action-function + url name user-handle action notify args reblogs json))))) + +(defun mastodon-tl--do-user-action-function + (url name user-handle action &optional notify args reblogs json) + "Post ACTION on user NAME/USER-HANDLE to URL. +NOTIFY is either \"true\" or \"false\", and used when we have been called +by `mastodon-tl--follow-user' to enable or disable notifications. +ARGS is an alist of any parameters to send with the request." + (let ((response (mastodon-http--post url args nil nil json))) + (mastodon-http--triage + response + (lambda (response) + (let ((json (with-current-buffer response + (mastodon-http--process-json)))) + ;; TODO: when > if, with failure msg + (cond ((string= notify "true") + (when (eq t (alist-get 'notifying json)) + (message "Receiving notifications for user %s (@%s)!" + name user-handle))) + ((string= notify "false") + (when (eq :json-false (alist-get 'notifying json)) + (message "Not receiving notifications for user %s (@%s)!" + name user-handle))) + ((string= reblogs "true") + (when (eq t (alist-get 'showing_reblogs json)) + (message "Receiving boosts by user %s (@%s)!" + name user-handle))) + ((string= reblogs "false") + (when (eq :json-false (alist-get 'showing_reblogs json)) + (message "Not receiving boosts by user %s (@%s)!" + name user-handle))) + ((or (string= action "mute") + (string= action "unmute")) + (message "User %s (@%s) %sd!" name user-handle action)) + ((string= args "languages[]") + (message "User %s language filters removed!" name)) + ((assoc "languages[]" args #'string=) + (message "User %s filtered by language(s): %s" name + (mapconcat #'cdr args " "))) + ((not (or notify reblogs)) + (if (and (string= action "follow") + (eq t (alist-get 'requested json))) + (message "Follow requested for user %s (@%s)!" name user-handle) + (message "User %s (@%s) %sed!" name user-handle action))))))))) + + +;; FOLLOW TAGS + +(defun mastodon-tl--get-tags-list () + "Return the list of tags of the toot at point." + (let* ((toot (mastodon-toot--base-toot-or-item-json)) + (tags (mastodon-tl--field 'tags toot))) + (mastodon-tl--map-alist 'name tags))) + +(defun mastodon-tl--follow-tag (&optional tag) + "Prompt for a tag (from post at point) and follow it. +If TAG provided, follow it." + (interactive) + (let* ((tags (unless tag (mastodon-tl--get-tags-list))) + (tag-at-point + (unless tag + (when (eq 'hashtag + (mastodon-tl--property 'mastodon-tab-stop :no-move)) + (mastodon-tl--property 'mastodon-tag :no-move)))) + (tag (or tag (completing-read + (format "Tag to follow [%s]: " tag-at-point) + tags nil nil nil nil tag-at-point))) + (url (mastodon-http--api (format "tags/%s/follow" tag))) + (response (mastodon-http--post url))) + (mastodon-http--triage response + (lambda (_) + (message "tag #%s followed!" tag))))) + +(defun mastodon-tl--followed-tags () + "Return JSON of tags followed." + (let ((url (mastodon-http--api (format "followed_tags")))) + (mastodon-http--get-json url))) + +(defun mastodon-tl--unfollow-tag (&optional tag) + "Prompt for a followed tag, and unfollow it. +If TAG is provided, unfollow it." + (interactive) + (let* ((followed-tags-json (unless tag (mastodon-tl--followed-tags))) + (tags (unless tag (mastodon-tl--map-alist 'name followed-tags-json))) + (tag (or tag (completing-read "Unfollow tag: " tags))) + (url (mastodon-http--api (format "tags/%s/unfollow" tag))) + (response (mastodon-http--post url))) + (mastodon-http--triage response + (lambda (_) + (message "tag #%s unfollowed!" tag))))) + +(defun mastodon-tl--list-followed-tags (&optional prefix) + "List followed tags. View timeline of tag user choses. +PREFIX is sent to `mastodon-tl--get-tag-timeline', which see." + (interactive "p") + (let* ((followed-tags-json (mastodon-tl--followed-tags)) + (tags (mastodon-tl--map-alist 'name followed-tags-json)) + (tag (completing-read "Tag: " tags nil))) + (if (null tag) + (user-error "You have to follow some tags first") + (mastodon-tl--get-tag-timeline prefix tag)))) + +(defun mastodon-tl--followed-tags-timeline (&optional prefix) + "Open a timeline of multiple tags. +With a single PREFIX arg, only show posts with media. +With a double PREFIX arg, limit results to your own instance. +If `mastodon-tl--tag-timeline-tags' is set, use its tags, else +fetch followed tags and load the first four of them." + (interactive "p") + (let* ((followed-tags-json (mastodon-tl--followed-tags)) + (tags (or mastodon-tl--tag-timeline-tags + (mastodon-tl--map-alist 'name followed-tags-json)))) + (mastodon-tl--show-tag-timeline prefix tags))) + +(defun mastodon-tl--some-followed-tags-timeline (&optional prefix) + "Prompt for some tags, and open a timeline for them. +The suggestions are from followed tags, but any other tags are also allowed. +PREFIX is for `mastodon-tl--show-tag-timeline', which see." + (interactive "p") + (let* ((followed-tags-json (mastodon-tl--followed-tags)) + (tags (mastodon-tl--map-alist 'name followed-tags-json)) + (selection (completing-read-multiple + "Tags' timelines to view [TAB to view, comma to separate]: " + tags))) + (mastodon-tl--show-tag-timeline prefix selection))) + + +;;; REPORT TO MODERATORS + +(defun mastodon-tl--instance-rules () + "Return the rules of the user's instance." + (let ((url (mastodon-http--api "instance/rules"))) + (mastodon-http--get-json url nil :silent))) + +(defun mastodon-tl--report-params (account toot) + "Query user and return report params alist. +ACCOUNT and TOOT are the data to use." + (let* ((account-id (alist-get 'id account)) + (comment (read-string "Add comment [optional]: ")) + (item-id (when (y-or-n-p "Also report status at point? ") + (mastodon-tl--item-id toot))) ; base toot if poss + (forward-p (when (y-or-n-p "Forward to remote admin? ") "true")) + (rules (when (y-or-n-p "Cite a rule broken? ") + (mastodon-tl--read-rules-ids))) + (cat (unless rules (if (y-or-n-p "Spam? ") "spam" "other")))) + (mastodon-tl--report-build-params account-id comment item-id + forward-p cat rules))) + +(defun mastodon-tl--report-build-params + (account-id comment item-id forward-p cat &optional rules) + "Build the parameters alist based on user responses. +ACCOUNT-ID, COMMENT, ITEM-ID, FORWARD-P, CAT, and RULES are all from +`mastodon-tl--report-params', which see." + (let ((params (cl-remove + nil + `(("account_id" . ,account-id) + ,(when comment `("comment" . ,comment)) + ,(when item-id `("status_ids[]" . ,item-id)) + ,(when forward-p `("forward" . ,forward-p)) + ,(when cat `("category" . ,cat)))))) + (if (not rules) + params + (let ((alist + (mastodon-http--build-array-params-alist "rule_ids[]" rules))) + (append alist params))))) + +(defun mastodon-tl--report-to-mods () + "Report the author of the toot at point to your instance moderators. +Optionally report the toot at point, add a comment, cite rules +that have been broken, forward the report to the remove admin, +report the account for spam." + (interactive) + (mastodon-tl--do-if-item + (when (y-or-n-p "Report author of toot at point?") + (let* ((url (mastodon-http--api "reports")) + (toot (mastodon-tl--toot-or-base + (mastodon-tl--property 'item-json :no-move))) + (account (alist-get 'account toot)) + (handle (alist-get 'acct account)) + (params (mastodon-tl--report-params account toot)) + (response (mastodon-http--post url params))) + (mastodon-http--triage response + (lambda (_) + (message "User %s reported!" handle))))))) + +(defvar crm-separator) + +(defun mastodon-tl--map-rules-alist (rules) + "Convert RULES text and id fields into an alist." + (mastodon-tl--map-alist-vals-to-alist 'text 'id rules)) + +(defun mastodon-tl--read-rules-ids () + "Prompt for a list of instance rules and return a list of selected ids." + (let* ((rules (mastodon-tl--instance-rules)) + (alist (mastodon-tl--map-rules-alist rules)) + (crm-separator (replace-regexp-in-string "," "|" crm-separator)) + (choices (completing-read-multiple + "rules [TAB for options, | to separate]: " + alist nil t))) + (mapcar (lambda (x) + (alist-get x alist nil nil #'string=)) + choices))) + + +;;; UPDATING, etc. + +(defun mastodon-tl--more-json (endpoint id) + "Return JSON for timeline ENDPOINT before ID." + (let* ((args `(("max_id" . ,(mastodon-tl--as-string id)))) + (url (mastodon-http--api endpoint))) + (mastodon-http--get-json url args))) + +(defun mastodon-tl--more-json-async + (endpoint id &optional params callback &rest cbargs) + "Return JSON for timeline ENDPOINT before ID. +Then run CALLBACK with arguments CBARGS. +PARAMS is used to send any parameters needed to correctly update +the current view." + (let* ((args `(("max_id" . ,(mastodon-tl--as-string id)))) + (args (append args params)) + (url (mastodon-http--api + endpoint + (when (or (and mastodon-group-notifications + (string= endpoint "notifications")) + (string-suffix-p "search" endpoint)) + "v2")))) + (apply #'mastodon-http--get-json-async url args callback cbargs))) + +(defun mastodon-tl--more-json-async-offset (endpoint &optional params + callback &rest cbargs) + "Return JSON for ENDPOINT, using the \"offset\" query param. +This is used for pagination with endpoints that implement the +\"offset\" parameter, rather than using link-headers or +\"max_id\". +PARAMS are the update parameters, see +`mastodon-tl--update-params'. These (\"limit\" and \"offset\") +must be set in `mastodon-tl--buffer-spec' for pagination to work. +Then run CALLBACK with arguments CBARGS." + (let* ((params (or params (mastodon-tl--update-params))) + (limit (string-to-number + (alist-get "limit" params nil nil #'string=))) + (offset (number-to-string + (+ limit ; limit + old offset = new offset + (string-to-number + (alist-get "offset" params nil nil #'string=))))) + (url (mastodon-http--api + endpoint + (when (string-suffix-p "search" endpoint) + "v2")))) + ;; increment: + (setf (alist-get "offset" params nil nil #'string=) offset) + (apply #'mastodon-http--get-json-async url params callback cbargs))) + +(defun mastodon-tl--updated-json (endpoint id &optional params) + "Return JSON for timeline ENDPOINT since ID. +PARAMS is used to send any parameters needed to correctly update +the current view." + (let* ((args `(("since_id" . ,(mastodon-tl--as-string id)))) + (args (append args params)) + (url (mastodon-http--api endpoint))) + (mastodon-http--get-json url args))) + +;; TODO: add this to new posts in some cases, e.g. in thread view. +(defun mastodon-tl--reload-timeline-or-profile (&optional pos) + "Reload the current timeline or profile page. +For use after e.g. deleting a toot. +POS is a number, where point will be placed. +Aims to respect any pagination in effect." + (let ((type (mastodon-tl--get-buffer-type)) + (max-id (mastodon-tl--buffer-property 'max-id nil :no-error))) + (cond ((eq type 'home) + (mastodon-tl--get-home-timeline nil max-id)) + ((eq type 'federated) + (mastodon-tl--get-federated-timeline nil nil max-id)) + ((eq type 'local) + (mastodon-tl--get-local-timeline nil max-id)) + ((eq type 'mentions) + (mastodon-notifications--get-mentions)) + ((eq type 'notifications) + (mastodon-notifications-get nil nil max-id)) + ((eq type 'profile-statuses-no-boosts) + ;; TODO: max-id arg needed here also + (mastodon-profile--open-statuses-no-reblogs)) + ((eq type 'profile-statuses) + (save-excursion + (goto-char (point-min)) + (mastodon-profile--get-toot-author max-id))) + ((eq type 'thread) + (let ((id (mastodon-tl--buffer-property + 'thread-item-id (current-buffer) :no-error))) + (mastodon-tl--thread-do id)))) + ;; TODO: sends point to where point was in buffer. This is very rough; we + ;; may have removed an item , so the buffer will be smaller, point will + ;; end up past where we were, etc. + (when pos + (goto-char pos) + (mastodon-tl--goto-prev-item)))) + +(defun mastodon-tl--build-link-header-url (str) + "Return a URL from STR, an http Link header." + (let* ((split (split-string str "; ")) + (url-base (string-trim (car split) "<" ">")) + (param (cadr split))) + (concat url-base "&" param))) + +(defun mastodon-tl--use-link-header-p () + "Return t if we are in a view needing Link header pagination. +Currently this includes favourites, bookmarks, follow requests, +and profile pages when showing followers or accounts followed." + (or (mastodon-tl--buffer-type-eq 'favourites) + (mastodon-tl--buffer-type-eq 'bookmarks) + (mastodon-tl--buffer-type-eq 'profile-followers) + (mastodon-tl--buffer-type-eq 'profile-following) + (mastodon-tl--buffer-type-eq 'follow-requests))) + +(defun mastodon-tl--get-link-header-from-response (headers) + "Get http Link header from list of http HEADERS." + ;; pleroma uses "link", so case-insensitive match required: + (when-let ((link-headers (alist-get "Link" headers nil nil #'cl-equalp))) + (split-string link-headers ", "))) + +(defun mastodon-tl--more () + "Append older toots to timeline, asynchronously." + (message "Loading...") + (if (mastodon-tl--use-link-header-p) + ;; link-header paginate: + ;; can't build a URL with --more-json-async, endpoint/id: + ;; ensure we have a "next" type here, otherwise the CAR will be the + ;; "prev" type! + (let ((link-header (mastodon-tl--link-header))) + (if (> 2 (length link-header)) + (user-error "No next page") + (let* ((next (car link-header)) + ;;(prev (cadr (mastodon-tl--link-header))) + (url (mastodon-tl--build-link-header-url next))) + (mastodon-http--get-response-async + url nil 'mastodon-tl--more* (current-buffer) (point) :headers)))) + (cond (;; no paginate + (or (mastodon-tl--buffer-type-eq 'follow-suggestions) + (mastodon-tl--buffer-type-eq 'filters) + (mastodon-tl--buffer-type-eq 'lists)) + (user-error "No more results")) + ;; offset paginate (search, trending, user lists, ...?): + ((or (string-prefix-p "*mastodon-trending-" (buffer-name)) + (mastodon-tl--search-buffer-p)) + (mastodon-tl--more-json-async-offset + (mastodon-tl--endpoint) + (mastodon-tl--update-params) + 'mastodon-tl--more* (current-buffer) (point))) + (t ;; max_id paginate (timelines, items with ids/timestamps): + (let ((max-id (mastodon-tl--oldest-id))) + (mastodon-tl--more-json-async + (mastodon-tl--endpoint) + max-id + (mastodon-tl--update-params) + 'mastodon-tl--more* (current-buffer) (point) nil max-id)))))) + +(defun mastodon-tl--more* (response buffer point-before + &optional headers max-id) + "Append older toots to timeline, asynchronously. +Runs the timeline's update function on RESPONSE, in BUFFER. +When done, places point at POINT-BEFORE. +HEADERS is the http headers returned in the response, if any. +MAX-ID is the pagination parameter, a string." + (with-current-buffer buffer + (if (not response) + (user-error "No more results") + (let* ((inhibit-read-only t) + (json (if headers (car response) response)) + ;; FIXME: max-id pagination works for statuses only, not other + ;; search results pages: + (json (if (not (mastodon-tl--search-buffer-p)) + json + (let ((type (mastodon-search--buf-type))) + (cond ((string= "statuses" type) + (cdr ; avoid repeat of last status + (alist-get 'statuses response))) + ((string= "hashtags" type) + (alist-get 'hashtags response)) + ((string= "accounts" type) + (alist-get 'accounts response)))))) + (headers (when headers (cdr response))) + (link-header + (mastodon-tl--get-link-header-from-response headers))) + (goto-char (point-max)) + (if (eq 'thread (mastodon-tl--get-buffer-type)) + ;; if thread fully unfolded, respect it: + ;; if thread view, call --thread with parent ID + (progn (goto-char (point-min)) + (mastodon-tl--goto-next-item) + (mastodon-tl--thread) + (goto-char point-before) + (message "Loaded full thread.")) + (if (not json) + (user-error "No more results") + (funcall (mastodon-tl--update-function) json) + (goto-char point-before) + ;; update buffer spec to new link-header or max-id: + ;; (other values should just remain as they were) + (mastodon-tl--set-buffer-spec (mastodon-tl--buffer-name) + (mastodon-tl--endpoint) + (mastodon-tl--update-function) + link-header nil nil max-id) + (message "Loading... done."))))))) + +(defun mastodon-tl--find-property-range (property start-point + &optional search-backwards) + "Return nil if no such range is found. +If PROPERTY is set at START-POINT returns a range around +START-POINT otherwise before/after START-POINT. +SEARCH-BACKWARDS determines whether we pick point +before (non-nil) or after (nil)" + (if (get-text-property start-point property) + ;; We are within a range, so look backwards for the start: + (cons (previous-single-property-change + (if (eq start-point (point-max)) start-point (1+ start-point)) + property nil (point-min)) + (next-single-property-change start-point property nil (point-max))) + (if search-backwards + (let* ((end (or (previous-single-property-change + (if (eq start-point (point-max)) + start-point + (1+ start-point)) + property) + ;; we may either be just before the range or there + ;; is nothing at all + (and (not (eq start-point (point-min))) + (get-text-property (1- start-point) property) + start-point))) + (start (and end (previous-single-property-change + end property nil (point-min))))) + (when end + (cons start end))) + (let* ((start (next-single-property-change start-point property)) + (end (and start (next-single-property-change + start property nil (point-max))))) + (when start + (cons start end)))))) + +(defun mastodon-tl--find-next-or-previous-property-range + (property start-point search-backwards) + "Find (start . end) property range after/before START-POINT. +Does so while PROPERTY is set to a consistent value (different +from the value at START-POINT if that is set). +Return nil if no such range exists. +If SEARCH-BACKWARDS is non-nil it find a region before +START-POINT otherwise after START-POINT." + (if (not (get-text-property start-point property)) + ;; If we are not within a range, we can just defer to + ;; mastodon-tl--find-property-range directly. + (mastodon-tl--find-property-range property start-point search-backwards) + ;; We are within a range, we need to start the search from + ;; before/after this range: + (let ((current-range + (mastodon-tl--find-property-range property start-point))) + (if search-backwards + (unless (eq (car current-range) (point-min)) + (mastodon-tl--find-property-range + property (1- (car current-range)) search-backwards)) + (unless (eq (cdr current-range) (point-max)) + (mastodon-tl--find-property-range + property (1+ (cdr current-range)) search-backwards)))))) + +(defun mastodon-tl--consider-timestamp-for-updates (timestamp) + "Take note that TIMESTAMP is used in buffer and ajust timers as needed. +This calculates the next time the text for TIMESTAMP will change +and may adjust existing or future timer runs should that time +before current plans to run the update function. +The adjustment is only made if it is significantly (a few +seconds) before the currently scheduled time. This helps reduce +the number of occasions where we schedule an update only to +schedule the next one on completion to be within a few seconds. +If relative timestamps are disabled (i.e. if +`mastodon-tl--enable-relative-timestamps' is nil), this is a +no-op." + (when mastodon-tl--enable-relative-timestamps + (let ((this-update (cdr (mastodon-tl--relative-time-details timestamp)))) + (when (time-less-p this-update + (time-subtract mastodon-tl--timestamp-next-update + (seconds-to-time 10))) + (setq mastodon-tl--timestamp-next-update this-update) + (when mastodon-tl--timestamp-update-timer + ;; We need to re-schedule for an earlier time + (cancel-timer mastodon-tl--timestamp-update-timer) + (setq mastodon-tl--timestamp-update-timer + (run-at-time (time-to-seconds (time-subtract this-update + (current-time))) + nil ;; don't repeat + #'mastodon-tl--update-timestamps-callback + (current-buffer) nil))))))) + +(defun mastodon-tl--update-timestamps-callback (buffer previous-marker) + "Update the next few timestamp displays in BUFFER. +Start searching for more timestamps from PREVIOUS-MARKER or +from the start if it is nil." + ;; only do things if the buffer hasn't been killed in the meantime + (when (and mastodon-tl--enable-relative-timestamps ; just in case + (buffer-live-p buffer)) + (save-excursion + (with-current-buffer buffer + (let ((previous-timestamp (if previous-marker + (marker-position previous-marker) + (point-min))) + (iteration 0) + next-timestamp-range) + (if previous-marker + ;; a follow-up call to process the next batch of timestamps. + ;; Release the marker to not slow things down. + (set-marker previous-marker nil) + ;; Otherwise this is a rew run, so let's initialize the next-run time. + (setq mastodon-tl--timestamp-next-update (time-add (current-time) + (seconds-to-time 300)) + mastodon-tl--timestamp-update-timer nil)) + (while (and (< iteration 5) + (setq next-timestamp-range + (mastodon-tl--find-property-range 'timestamp + previous-timestamp))) + (let* ((start (car next-timestamp-range)) + (end (cdr next-timestamp-range)) + (timestamp (get-text-property start 'timestamp)) + (current-display (get-text-property start 'display)) + (new-display (mastodon-tl--relative-time-description timestamp))) + (unless (string= current-display new-display) + (let ((inhibit-read-only t)) + (add-text-properties + start end + (list 'display + (mastodon-tl--relative-time-description timestamp))))) + (mastodon-tl--consider-timestamp-for-updates timestamp) + (setq iteration (1+ iteration) + previous-timestamp (1+ (cdr next-timestamp-range))))) + (if next-timestamp-range + ;; schedule the next batch from the previous location to + ;; start very soon in the future: + (run-at-time 0.1 nil #'mastodon-tl--update-timestamps-callback buffer + (copy-marker previous-timestamp)) + ;; otherwise we are done for now; schedule a new run for when needed + (setq mastodon-tl--timestamp-update-timer + (run-at-time (time-to-seconds + (time-subtract mastodon-tl--timestamp-next-update + (current-time))) + nil ;; don't repeat + #'mastodon-tl--update-timestamps-callback + buffer nil)))))))) + +(defun mastodon-tl--set-after-update-marker () + "Set `mastodon-tl--after-update-marker' to the after-update location. +This location is defined by a non-nil value of +`mastodon-tl-position-after-update'." + (if (not mastodon-tl-position-after-update) + (setq mastodon-tl--after-update-marker nil) + (let ((marker (make-marker))) + (set-marker marker + (cond + ((eq 'keep-point mastodon-tl-position-after-update) + (point)) + ((eq 'last-old-toot mastodon-tl-position-after-update) + (next-single-property-change + (or mastodon-tl--update-point (point-min)) + 'byline)) + (t + (error "Unknown mastodon-tl-position-after-update value %S" + mastodon-tl-position-after-update)))) + ;; Make the marker advance if text gets inserted there. + (set-marker-insertion-type marker t) + (setq mastodon-tl--after-update-marker marker)))) + +(defun mastodon-tl--update () + "Update timeline with new toots." + (interactive) + ;; FIXME: actually these buffers should just reload by calling their own + ;; load function (actually g is mostly mapped as such): + (if (or (member (mastodon-tl--get-buffer-type) + '(trending-statuses + trending-tags + follow-suggestions + lists + filters + scheduled-statuses)) + (mastodon-tl--search-buffer-p)) + (user-error "Update not available in this view") + ;; FIXME: handle update for search and trending buffers + (let* ((endpoint (mastodon-tl--endpoint)) + (update-function (mastodon-tl--update-function))) + ;; update a thread, without calling `mastodon-tl--updated-json': + (if (mastodon-tl--buffer-type-eq 'thread) + ;; load whole thread: + (progn (mastodon-tl--thread) + (message "Loaded full thread.")) + ;; update other timelines: + (let* ((id (mastodon-tl--newest-id)) + (params (mastodon-tl--update-params)) + (json (mastodon-tl--updated-json endpoint id params))) + (if (not json) + (user-error "Nothing to update") + (let ((inhibit-read-only t)) + (mastodon-tl--set-after-update-marker) + (goto-char (or mastodon-tl--update-point (point-min))) + (funcall update-function json) + (if mastodon-tl--after-update-marker + (goto-char mastodon-tl--after-update-marker) + (mastodon-tl--goto-next-item))))))))) + + +;;; LOADING TIMELINES + +(defun mastodon-tl--init + (buffer-name endpoint update-function &optional headers params + hide-replies instance no-byline) + "Initialize BUFFER-NAME with timeline targeted by ENDPOINT asynchronously. +UPDATE-FUNCTION is used to recieve more toots. +HEADERS means to also collect the response headers. Used for paginating +favourites and bookmarks. +PARAMS is any parameters to send with the request. +HIDE-REPLIES is a flag indicating if replies are hidden in the current buffer. +INSTANCE is a string of another instance domain we are displaying +a timeline from. +NO-BYLINE means just insert toot body, used for announcements." + (let ((url (if instance + (concat "https://" instance "/api/v1/" endpoint) + (mastodon-http--api endpoint))) + (buffer (concat "*mastodon-" buffer-name "*"))) + (funcall + (if headers + #'mastodon-http--get-response-async + #'mastodon-http--get-json-async) + url params 'mastodon-tl--init* + buffer endpoint update-function headers params hide-replies + instance no-byline))) + +(defun mastodon-tl--init* + (response buffer endpoint update-function &optional headers + update-params hide-replies instance no-byline) + "Initialize BUFFER with timeline targeted by ENDPOINT. +UPDATE-FUNCTION is used to recieve more toots. +RESPONSE is the data returned from the server by +`mastodon-http--process-json', with arg HEADERS a cons cell of +JSON and http headers, without it just the JSON. +NO-BYLINE means just insert toot body, used for announcements." + (let ((json (if headers (car response) response))) + (cond ((not json) ; praying this is right here, else try "\n[]" + ;; this means that whatever tl was inited won't load, which is not + ;; always wanted, as sometimes you still need the page to load so + ;; you can be in eg mastodon-mode, have keymap, search etc. + (message "Looks like nothing returned from endpoint: %s" endpoint) + ;; if we are a new account, home tl may have nothing, but then + ;; this clause means we can never load mastodon.el at all! + ;; so as a fallback, load trending statuses: + ;; FIXME: this could possibly be a fallback for all timelines not + ;; just home? + (when (string= endpoint "timelines/home") + (mastodon-search--trending-statuses))) + ((eq (caar json) 'error) + (user-error "Looks like the server bugged out: \"%s\"" (cdar json))) + (t + (let* ((headers (when headers (cdr response))) + (link-header + (mastodon-tl--get-link-header-from-response headers))) + (with-mastodon-buffer buffer #'mastodon-mode nil + (mastodon-tl--set-buffer-spec + buffer endpoint update-function + link-header update-params hide-replies + ;; awful hack to fix multiple reloads: + (alist-get "max_id" update-params nil nil #'string=)) + (mastodon-tl--do-init json update-function instance no-byline))))))) + +(defun mastodon-tl--init-sync + (buffer-name endpoint update-function &optional note-type params + headers view-name binding-str endpoint-version) + "Initialize BUFFER-NAME with timeline targeted by ENDPOINT. +UPDATE-FUNCTION is used to receive more toots. +Runs synchronously. +Optional arg NOTE-TYPE means only get that type of notification. +PARAMS is an alist of any params to include in the request. +HEADERS are any headers to send in the request. +VIEW-NAME is a string, to be used as a heading for the view. +BINDING-STR is a string explaining any bindins in the view. +ENDPOINT-VERSION is a string, format Vx, e.g. V2." + ;; Used by `mastodon-notifications-get' and in views.el + (let* ((notes-params (when note-type + (mastodon-http--build-array-params-alist + "types[]" (list note-type)))) + (params (append notes-params params)) + (url (mastodon-http--api endpoint endpoint-version)) + (buffer (concat "*mastodon-" buffer-name "*")) + (response (mastodon-http--get-response url params)) + (json (car response)) + (headers (when headers (cdr response))) + (link-header (when headers + (mastodon-tl--get-link-header-from-response headers)))) + (with-mastodon-buffer buffer #'mastodon-mode nil + ;; insert view-name/ heading-str + (when view-name + (mastodon-search--insert-heading view-name)) + (when binding-str + (insert (mastodon-tl--set-face (concat "[" binding-str "]\n\n") + 'font-lock-comment-face))) + (mastodon-tl--set-buffer-spec + buffer endpoint update-function + link-header params nil + ;; awful hack to fix multiple reloads: + (alist-get "max_id" params nil nil #'string=)) + (mastodon-tl--do-init json update-function nil nil note-type) + buffer))) + +(defun mastodon-tl--do-init (json update-fun &optional domain no-byline type) + "Utility function for `mastodon-tl--init*' and `mastodon-tl--init-sync'. +JSON is the data to call UPDATE-FUN on. +When DOMAIN, force inclusion of user's domain in their handle. +NO-BYLINE means just insert toot body, used for announcements." + (remove-overlays) ; video overlays + (cond (domain ;; maybe our update-fun doesn't always have 3 args...: + (funcall update-fun json nil domain)) + (type (funcall update-fun json type)) ;; notif types + (no-byline (funcall update-fun json nil nil no-byline)) + (t (funcall update-fun json))) + (setq + ;; Initialize with a minimal interval; we re-scan at least once + ;; every 5 minutes to catch any timestamps we may have missed + mastodon-tl--timestamp-next-update (time-add (current-time) + (seconds-to-time 300))) + (setq mastodon-tl--timestamp-update-timer + (when mastodon-tl--enable-relative-timestamps + (run-at-time (time-to-seconds + (time-subtract mastodon-tl--timestamp-next-update + (current-time))) + nil ;; don't repeat + #'mastodon-tl--update-timestamps-callback + (current-buffer) + nil))) + (unless (mastodon-tl--profile-buffer-p) + (mastodon-tl--goto-first-item))) + +;;; BOOKMARKS + +(require 'bookmark) + +(defun mastodon-tl--bookmark-handler (record) + "Jump to a bookmarked location in mastodon.el. +RECORD is the bookmark record." + (let ((id (bookmark-prop-get record 'id))) + ;; we need to handle thread and single toot for starters + (pop-to-buffer + (mastodon-tl--thread-do id)))) + +(defun mastodon-tl--bookmark-make-record () + "Return a bookmark record for the current mastodon buffer." + (let ((id (mastodon-tl--property 'item-id :no-move)) + (name (buffer-name))) + `(,name + (buf . ,name) + (id . ,id) + (handler . mastodon-tl--bookmark-handler)))) + +(add-hook 'mastodon-mode-hook + (lambda () + (setq-local bookmark-make-record-function + #'mastodon-tl--bookmark-make-record))) + +(provide 'mastodon-tl) +;;; mastodon-tl.el ends here diff --git a/elpa/mastodon-20241202.1839/mastodon-toot.el b/elpa/mastodon-20241202.1839/mastodon-toot.el new file mode 100644 index 00000000..1bc48c8c --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-toot.el @@ -0,0 +1,2113 @@ +;;; mastodon-toot.el --- Minor mode for sending Mastodon toots -*- lexical-binding: t -*- + +;; Copyright (C) 2017-2019 Johnson Denen +;; Copyright (C) 2020-2024 Marty Hiatt +;; Author: Johnson Denen +;; Marty Hiatt +;; Maintainer: Marty Hiatt +;; Homepage: https://codeberg.org/martianh/mastodon.el + +;; This file is not part of GNU Emacs. + +;; This file is part of mastodon.el. + +;; mastodon.el 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. + +;; mastodon.el 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 mastodon.el. If not, see . + +;;; Commentary: + +;; mastodon-toot.el supports POSTing status data to Mastodon. + +;;; Code: +(eval-when-compile (require 'subr-x)) + + +(defvar mastodon-use-emojify) +(require 'emojify nil :noerror) +(declare-function emojify-insert-emoji "emojify") +(declare-function emojify-set-emoji-data "emojify") +(declare-function emojify-mode "emojify") +(declare-function emojify-emojis-each "emojify") +(defvar emojify-emojis-dir) +(defvar emojify-user-emojis) +(defvar emojify-emoji-styles) + +(require 'cl-lib) +(require 'persist) +(require 'mastodon-iso) +(require 'facemenu) +(require 'text-property-search) + +(eval-when-compile + (require 'mastodon-tl)) + +(defvar mastodon-instance-url) +(defvar mastodon-tl--buffer-spec) +(defvar mastodon-tl--enable-proportional-fonts) +(defvar mastodon-profile-account-settings) +(defvar mastodon-profile-acccount-preferences-data) + +(autoload 'iso8601-parse "iso8601") +(autoload 'ht-get "ht") +(autoload 'mastodon-auth--user-acct "mastodon-auth") +(autoload 'mastodon-http--api "mastodon-http") +(autoload 'mastodon-http--build-array-params-alist "mastodon-http") +(autoload 'mastodon-http--delete "mastodon-http") +(autoload 'mastodon-http--get-json "mastodon-http") +(autoload 'mastodon-http--get-json-async "mastodon-http") +(autoload 'mastodon-http--post "mastodon-http") +(autoload 'mastodon-http--post-media-attachment "mastodon-http") +(autoload 'mastodon-http--process-json "mastodon-http") +(autoload 'mastodon-http--put "mastodon-http") +(autoload 'mastodon-http--read-file-as-string "mastodon-http") +(autoload 'mastodon-http--triage "mastodon-http") +(autoload 'mastodon-kill-window "mastodon") +(autoload 'mastodon-profile--fetch-server-account-settings "mastodon-profile") +(autoload 'mastodon-profile--fetch-server-account-settings-maybe "mastodon-profile") +(autoload 'mastodon-profile--get-source-pref "mastodon-profile") +(autoload 'mastodon-profile--show-user "mastodon-profile") +(autoload 'mastodon-profile--update-preference "mastodon-profile") +(autoload 'mastodon-search--search-accounts-query "mastodon-search") +(autoload 'mastodon-search--search-tags-query "mastodon-search") +(autoload 'mastodon-tl--as-string "mastodon-tl") +(autoload 'mastodon-tl--buffer-type-eq "mastodon-tl") +(autoload 'mastodon-tl--clean-tabs-and-nl "mastodon-tl") +(autoload 'mastodon-tl--field "mastodon-tl") +(autoload 'mastodon-tl--find-property-range "mastodon-tl") +(autoload 'mastodon-tl--find-property-range "mastodon-tl") +(autoload 'mastodon-tl--goto-next-item "mastodon-tl") +(autoload 'mastodon-tl--map-alist "mastodon-tl") +(autoload 'mastodon-tl--property "mastodon-tl") +(autoload 'mastodon-tl--reload-timeline-or-profile "mastodon-tl") +(autoload 'mastodon-tl--render-text "mastodon-tl") +(autoload 'mastodon-tl--set-buffer-spec "mastodon-tl") +(autoload 'mastodon-tl--symbol "mastodon-tl") +(autoload 'mastodon-tl--item-id "mastodon-tl") +(autoload 'mastodon-toot "mastodon") +(autoload 'mastodon-views--cancel-scheduled-toot "mastodon-views") +(autoload 'mastodon-views--view-scheduled-toots "mastodon-views") +(autoload 'org-read-date "org") +(autoload 'mastodon-tl--toot-or-base "mastodon-tl") +(autoload 'mastodon-profile--get-source-value "mastodon-toot") +(autoload 'mastodon-tl--get-buffer-type "mastodon-tl") +(autoload 'mastodon-tl--human-duration "mastodon-tl") +(autoload 'mastodon-profile--get-preferences-pref "mastodon-profile") +(autoload 'mastodon-views--get-own-instance "mastodon-views") +(autoload 'mastodon-tl--image-trans-check "mastodon-tl") +(autoload 'mastodon-instance-data "mastodon") +(autoload 'mastodon-create-poll "mastodon-transient") + +;; for mastodon-toot--translate-toot-text +(autoload 'mastodon-tl--content "mastodon-tl") +(when (require 'lingva nil :no-error) + (declare-function lingva-translate "lingva")) + +(defgroup mastodon-toot nil + "Tooting in Mastodon." + :prefix "mastodon-toot-" + :group 'mastodon) + +(defcustom mastodon-toot--default-media-directory "~/" + "The default directory when prompting for a media file to upload." + :type 'string) + +(defcustom mastodon-toot--attachment-height 80 + "Height of the attached images preview in the toot draft buffer." + :type 'integer) + +(defcustom mastodon-toot--enable-completion t + "Whether to enable completion of mentions and hashtags. +Used for completion in toot compose buffer." + :type 'boolean) + +(defcustom mastodon-toot--use-company-for-completion nil + "Whether to enable company for completion. +When non-nil, `company-mode' is enabled in the toot compose +buffer, and mastodon completion backends are added to +`company-capf'. + +You need to install company yourself to use this." + :type 'boolean) + +(defcustom mastodon-toot--completion-style-for-mentions "all" + "The company completion style to use for mentions." + :type '(choice + (const :tag "off" nil) + (const :tag "following only" "following") + (const :tag "all users" "all"))) + +(defcustom mastodon-toot-display-orig-in-reply-buffer nil + "Display a copy of the toot replied to in the compose buffer." + :type 'boolean) + +(defcustom mastodon-toot-orig-in-reply-length 191 + ;; three lines of divider width: (- (* 3 67) (length " Reply to: ")) + "Length to crop toot replied to in the compose buffer to." + :type 'integer) + +(defcustom mastodon-toot--default-reply-visibility "public" + "Default visibility settings when replying. +If the original toot visibility is different we use the more restricted one." + :type '(choice + (const :tag "public" "public") + (const :tag "unlisted" "unlisted") + (const :tag "followers only" "private") + (const :tag "direct" "direct"))) + +(defcustom mastodon-toot--enable-custom-instance-emoji nil + "Whether to enable your instance's custom emoji by default." + :type 'boolean) + +(defcustom mastodon-toot--proportional-fonts-compose nil + "Nonnil to enable using proportional fonts in the compose buffer. +By default fixed width fonts are used." + :type '(boolean :tag "Enable using proportional rather than fixed \ +width fonts")) + +(defcustom mastodon-toot-poll-use-transient t + "Whether to use the transient menu to create a poll." + :type '(boolean)) + +(defvar-local mastodon-toot--content-warning nil + "The content warning of the current toot.") + +(defvar-local mastodon-toot--content-nsfw nil + "A flag indicating whether the toot should be marked as NSFW.") + +(defvar mastodon-toot-visibility-list + '(public unlisted private direct) + "A list of the available toot visibility settings.") + +(defvar mastodon-toot-visibility-settings-list + '("public" "unlisted" "private") + "A list of the available default toot visibility settings. +Like `mastodon-toot-visibility-list' but without direct.") + +(defvar-local mastodon-toot--visibility nil + "A string indicating the visibility of the toot being composed. +Valid values are \"direct\", \"private\" (followers-only), +\"unlisted\", and \"public\". + +This is determined by the account setting on the server. To +change the setting on the server, see +`mastodon-toot--set-default-visibility'.") + +(defvar-local mastodon-toot--media-attachments nil + "A list of the media attachments of the toot being composed.") + +(defvar-local mastodon-toot--media-attachment-ids nil + "A list of any media attachment ids of the toot being composed.") + +(defvar mastodon-toot-poll nil + "A plist of poll options for the toot being composed.") + +(defvar-local mastodon-toot--language nil + "The language of the toot being composed, in ISO 639 (two-letter).") + +(defvar-local mastodon-toot--scheduled-for nil + "An ISO 8601 timestamp that specifying when the post should be published. +Should be at least 5 minutes into the future.") + +(defvar-local mastodon-toot--scheduled-id nil + "The id of the scheduled post that we are now editing.") + +(defvar-local mastodon-toot--reply-to-id nil + "Buffer-local variable to hold the id of the toot being replied to.") + +(defvar-local mastodon-toot--edit-item-id nil + "The id of the toot being edited.") + +(defvar-local mastodon-toot-previous-window-config nil + "A list of window configuration prior to composing a toot. +Takes its form from `window-configuration-to-register'.") + +(defvar mastodon-toot--max-toot-chars nil + "The maximum allowed characters count for a single toot.") + +(defvar-local mastodon-toot-completions nil + "The data of completion candidates for the current completion at point.") + +(defvar mastodon-toot-current-toot-text nil + "The text of the toot being composed.") + +(persist-defvar mastodon-toot-draft-toots-list nil + "A list of toots that have been saved as drafts. +For the moment we just put all composed toots in here, as we want +to also capture toots that are \"sent\" but that don't successfully +send.") + + +;;; REGEXES + +(defvar mastodon-toot-handle-regex + (rx (| (any ?\( "\n" "\t "" ") bol) ; preceding things + (group-n 2 (+ ?@ (* (any ?- ?_ ?. "A-Z" "a-z" "0-9" ))) ; handle + (? ?@ (* (not (any "\n" "\t" " "))))) ; optional domain + (| "'" word-boundary))) ; boundary or possessive + +(defvar mastodon-toot-tag-regex + (rx (| (any ?\( "\n" "\t" " ") bol) + (group-n 2 ?# (+ (any "A-Z" "a-z" "0-9"))) + (| "'" word-boundary))) ; boundary or possessive + +(defvar mastodon-toot-emoji-regex + (rx (| (any ?\( "\n" "\t" " ") bol) + (group-n 2 ?: ; opening : + (+ (any "A-Z" "a-z" "0-9" "_")) + (? ?:)) ; closing : + word-boundary)) ; boundary + +(defvar mastodon-toot-url-regex + ;; adapted from ffap-url-regexp + (concat + "\\(?2:\\(news\\(post\\)?:\\|mailto:\\|file:\\|\\(ftp\\|https?\\|telnet\\|gopher\\|www\\|wais\\)://\\)" ; uri prefix + "[^ \n\t]*\\)" ; any old thing, that is, i.e. we allow invalid/unwise chars + ;; "[ .,:;!?]\\b")) + ;; "/" ; poss an ending slash? incompat with boundary end: + "\\>")) ; boundary end + + +;;; UTILS + +(defun mastodon-toot--base-toot-or-item-json () + "Return the JSON data of either base-toot or item-json property. +The former is for boost or favourite notifications, returning +data about the item boosted or favourited." + (or (mastodon-tl--property 'base-toot :no-move) ; fave/boost notifs + (mastodon-tl--property 'item-json))) + +(defun mastodon-toot--inc-or-dec (count subtract) + "If SUBTRACT, decrement COUNT, else increment." + (if subtract + (1- count) + (1+ count))) + + +;;; MACRO + +(defmacro mastodon-toot--with-toot-item (&rest body) + "Execute BODY if we have a toot object at point. +Includes boosts, and notifications that display toots. +This macro makes the local variable ID available." + (declare (debug t)) + `(if (or (not (eq 'toot (mastodon-tl--property 'item-type :no-move))) + (member (mastodon-tl--property 'notification-type :no-move) + '("follow" "follow_request"))) + (user-error "Looks like there's no toot at point?") + (mastodon-tl--with-toot-helper + (lambda (id) + ,@body)))) + +(defun mastodon-tl--with-toot-helper (body-fun) + "Helper function for `mastodon-tl--with-toot-item'. +Extract any common variables needed, such as base-item-id +property, and call BODY-FUN on them." + (let ((id (mastodon-tl--property 'base-item-id))) + (funcall body-fun id))) + + +;;; MODE MAP + +(defvar mastodon-toot-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-c") #'mastodon-toot--send) + (define-key map (kbd "C-c C-k") #'mastodon-toot--cancel) + (define-key map (kbd "C-c C-w") #'mastodon-toot--set-content-warning) + (define-key map (kbd "C-c C-n") #'mastodon-toot--toggle-nsfw) + (define-key map (kbd "C-c C-v") #'mastodon-toot--change-visibility) + (define-key map (kbd "C-c C-e") #'mastodon-toot--insert-emoji) + (define-key map (kbd "C-c C-a") #'mastodon-toot--attach-media) + (define-key map (kbd "C-c !") #'mastodon-toot--clear-all-attachments) + (define-key map (kbd "C-c C-p") #'mastodon-toot--create-poll) + (define-key map (kbd "C-c C-o") #'mastodon-toot--clear-poll) + (define-key map (kbd "C-c C-l") #'mastodon-toot--set-toot-language) + (define-key map (kbd "C-c C-s") #'mastodon-toot--schedule-toot) + map) + "Keymap for `mastodon-toot'.") + +(defun mastodon-toot--set-default-visibility () + "Set the default visibility for toots on the server." + (interactive) + (let ((vis (completing-read "Set default visibility to:" + mastodon-toot-visibility-list + nil t))) + (mastodon-profile--update-preference "privacy" vis :source))) + +(defun mastodon-toot--get-max-toot-chars (&optional no-toot) + "Fetch max_toot_chars from `mastodon-instance-url' asynchronously. +NO-TOOT means we are not calling from a toot buffer." + (mastodon-http--get-json-async + (mastodon-http--api "instance") + nil + 'mastodon-toot--get-max-toot-chars-callback no-toot)) + +(defun mastodon-toot--get-max-toot-chars-callback (json-response + &optional no-toot) + "Set max_toot_chars returned in JSON-RESPONSE and display in new toot buffer. +NO-TOOT means we are not calling from a toot buffer." + (let ((max-chars + (or (alist-get 'max_toot_chars json-response) + (alist-get 'max_characters ; some servers have this instead + (alist-get 'statuses + (alist-get 'configuration + json-response)))))) + (setq mastodon-toot--max-toot-chars max-chars) + (unless no-toot + (with-current-buffer "*new toot*" + (mastodon-toot--update-status-fields))))) + +(defun mastodon-toot--action-success (marker byline-region remove &optional json) + "Insert/remove the text MARKER with `success' face in byline. +BYLINE-REGION is a cons of start and end pos of the byline to be +modified. +Remove MARKER if REMOVE is non-nil, otherwise add it. +JSON is added to the string as its item-json." + (let ((inhibit-read-only t) + (bol (car byline-region)) + (eol (cdr byline-region)) + (at-byline-p (eq t (mastodon-tl--property 'byline :no-move)))) + (save-excursion + (when remove + (goto-char bol) + (beginning-of-line) ;; The marker is not part of the byline + (if (search-forward (format "(%s) " marker) eol :no-error) + (replace-match "") + (user-error "Oops: could not find marker '(%s)'" marker))) + (unless remove + (goto-char bol) + (insert + (propertize + (format "(%s) " + (propertize marker + 'face 'success)) + 'cursor-face 'mastodon-cursor-highlight-face + 'item-json json)))) ;; for (un)folding items + (when at-byline-p + ;; leave point after the marker: + (unless remove + ;; if point is inside the byline, back up first so + ;; we don't move to the following toot: + (beginning-of-line) + (forward-line -1) + (mastodon-tl--goto-next-item))))) + +(defun mastodon-toot--action (action callback) + "Take ACTION, a string, on toot at point, then execute CALLBACK. +Makes a POST request to the server. Used for favouriting, +boosting, or bookmarking toots." + (let* ((id (mastodon-tl--property 'base-item-id)) + (url (mastodon-http--api + (concat "statuses/" (mastodon-tl--as-string id) "/" action))) + (response (mastodon-http--post url))) + (mastodon-http--triage response callback))) + +(defun mastodon-toot--toggle-boost-or-favourite (action) + "Toggle boost or favourite of toot at point. +ACTION is a symbol, either `favourite' or `boost.'" + (mastodon-toot--with-toot-item + (let* ((n-type (mastodon-tl--property 'notification-type :no-move)) + (byline-region (mastodon-tl--find-property-range 'byline (point))) + (boost-p (eq action 'boost)) + (action-str (symbol-name action)) + (item-json (mastodon-tl--property 'item-json)) + (vis (mastodon-tl--field 'vis item-json))) + (cond + ((not byline-region) + (user-error "Nothing to %s here?!?" action-str)) + ;; there's nothing wrong with faving/boosting own toots + ;; & nothing wrong with faving/boosting own toots from notifs, + ;; it boosts/faves the base toot, not the notif status + ((or (string= n-type "follow") + (string= n-type "follow_request")) + (user-error "Can't %s %s notifications" action n-type)) + ((and boost-p + (or (string= vis "direct") + (string= vis "private"))) + (user-error "Can't boost posts with visibility: %s" vis)) + (t + (let* ((boosted (when byline-region + (get-text-property (car byline-region) 'boosted-p))) + (faved (when byline-region + (get-text-property (car byline-region) 'favourited-p))) + (str-api (if boost-p "reblog" action-str)) + (action-str-api (mastodon-toot--str-negify str-api faved boosted)) + (action-pp (concat + (mastodon-toot--str-negify action-str faved boosted) + (if boost-p "ed" "d"))) + (remove-p (if boost-p boosted faved))) + (mastodon-toot--action + action-str-api + (lambda (_) + (let ((inhibit-read-only t)) + (add-text-properties (car byline-region) + (cdr byline-region) + (if boost-p + (list 'boosted-p (not boosted)) + (list 'favourited-p (not faved)))) + (mastodon-toot--update-stats-on-action action remove-p) + (mastodon-toot--action-success (mastodon-tl--symbol action) + byline-region remove-p item-json)) + (message "%s #%s" action-pp id))))))))) + +(defun mastodon-toot--str-negify (str faved boosted) + "Add \"un\" to STR if FAVED or BOOSTED is non-nil." + (if (or faved boosted) + (concat "un" str) + str)) + +(defun mastodon-toot--update-stats-on-action (action &optional subtract) + "Increment the toot stats display upon ACTION. +ACTION is a symbol, either `favourite' or `boost'. +SUBTRACT means we are un-favouriting or unboosting, so we decrement." + (if (not (symbolp action)) + (error "Invalid argument: symbolp %s" action) + (let* ((count-prop (if (eq action 'favourite) + 'favourites-count + 'boosts-count)) + (count-range (mastodon-tl--find-property-range count-prop (point))) + (count (get-text-property (car count-range) count-prop)) + (inhibit-read-only 1)) + ;; TODO another way to implement this would be to async fetch counts again + ;; and re-display from count-properties + (add-text-properties (car count-range) + (cdr count-range) + (list 'display + (number-to-string + (mastodon-toot--inc-or-dec count subtract)) + ;; update the count prop + ;; we rely on this for any subsequent actions: + count-prop + (mastodon-toot--inc-or-dec count subtract)))))) + +(defun mastodon-toot--toggle-boost () + "Boost/unboost toot at `point'." + (interactive) + (mastodon-toot--toggle-boost-or-favourite 'boost)) + +(defun mastodon-toot--toggle-favourite () + "Favourite/unfavourite toot at `point'." + (interactive) + (mastodon-toot--toggle-boost-or-favourite 'favourite)) + +;; TODO maybe refactor into boost/fave fun +(defun mastodon-toot--toggle-bookmark () + "Bookmark or unbookmark toot at point." + (interactive) + (mastodon-toot--with-toot-item + (let* ((n-type (mastodon-tl--property 'notification-type :no-move)) + (byline-region (mastodon-tl--find-property-range 'byline (point))) + (bookmarked-p (when byline-region + (get-text-property (car byline-region) 'bookmarked-p))) + (action (if bookmarked-p "unbookmark" "bookmark"))) + (cond ((or (string= n-type "follow") + (string= n-type "follow_request")) + (user-error "Can't bookmark %s notifications" n-type)) + ((not byline-region) + (user-error "Nothing to %s here?!?" action)) + (t + (let* ((bookmark-str (mastodon-tl--symbol 'bookmark)) + (message (if bookmarked-p + "Bookmark removed!" + "Toot bookmarked!")) + (item-json (mastodon-tl--property 'item-json))) + (mastodon-toot--action + action + (lambda (_) + (let ((inhibit-read-only t)) + (add-text-properties (car byline-region) + (cdr byline-region) + (list 'bookmarked-p (not bookmarked-p))) + (mastodon-toot--action-success bookmark-str + byline-region bookmarked-p item-json) + (message "%s #%s" message id)))))))))) + +(defun mastodon-toot--list-boosters () + "List the boosters of toot at point." + (interactive) + ;; use grouped notifs data if present: + ;; only send accounts as arg if type matches notif type we are acting + ;; on, to prevent showing accounts for a boost notif when asking for + ;; favers, and vice versa. + (let* ((type (mastodon-tl--property 'notification-type :no-move)) + (accounts (when (string= type "reblog") + (mastodon-tl--property 'notification-accounts :no-move)))) + (mastodon-toot--list-boosters-or-favers nil accounts))) + +(defun mastodon-toot--list-favouriters () + "List the favouriters of toot at point." + (interactive) + (let* ((type (mastodon-tl--property 'notification-type :no-move)) + (accounts (when (string= type "favourite") + (mastodon-tl--property 'notification-accounts :no-move)))) + (mastodon-toot--list-boosters-or-favers :favourite accounts))) + +(defun mastodon-toot--list-boosters-or-favers (&optional favourite accounts) + "List the favouriters or boosters of toot at point. +With FAVOURITE, list favouriters, else list boosters. +ACCOUNTS is notfications accounts if any." + (mastodon-toot--with-toot-item + (let* ((endpoint (unless accounts + (if favourite "favourited_by" "reblogged_by"))) + (url (unless accounts + (mastodon-http--api (format "statuses/%s/%s" id endpoint)))) + (params (unless accounts '(("limit" . "80")))) + (json (or accounts (mastodon-http--get-json url params)))) + (if (eq (caar json) 'error) + (user-error "%s (Status does not exist or is private)" + (alist-get 'error json)) + (let ((handles (mastodon-tl--map-alist 'acct json)) + (type-string (if favourite "Favouriters" "Boosters"))) + (if (not handles) + (user-error "Looks like this toot has no %s" type-string) + (let ((choice (completing-read + (format "%s (enter to view profile): " type-string) + handles nil t))) + (mastodon-profile--show-user choice)))))))) + +(defun mastodon-toot--copy-toot-url () + "Copy URL of toot at point. +If the toot is a fave/boost notification, copy the URL of the +base toot." + (interactive) + (let* ((url (mastodon-toot--toot-url))) + (kill-new url) + (message "Toot URL copied to the clipboard."))) + +(defun mastodon-toot--open-toot-url () + "Open URL of toot at point." + (interactive) + (browse-url (mastodon-toot--toot-url))) + +(defun mastodon-toot--toot-url () + "Return the URL of the base toot at point." + (let* ((toot (mastodon-toot--base-toot-or-item-json))) + (if (mastodon-tl--field 'reblog toot) + (alist-get 'url (alist-get 'reblog toot)) + (alist-get 'url toot)))) + +(defun mastodon-toot--copy-toot-text () + "Copy text of toot at point. +If the toot is a fave/boost notification, copy the text of the +base toot." + (interactive) + (let* ((toot (mastodon-toot--base-toot-or-item-json))) + (kill-new (mastodon-tl--content toot)) + (message "Toot content copied to the clipboard."))) + +(defun mastodon-toot--translate-toot-text () + "Translate text of toot at point. +Uses `lingva.el'." + (interactive) + (if mastodon-tl--buffer-spec + (if-let ((toot (mastodon-tl--property 'item-json))) + (condition-case x + (lingva-translate nil + (mastodon-tl--content toot) + (when mastodon-tl--enable-proportional-fonts + t)) + (void-function + (user-error "Looks like you need to install lingva.el. Error: %s" + (error-message-string x)))) + (user-error "No toot to translate?")) + (user-error "No mastodon buffer?"))) + +(defun mastodon-toot--own-toot-p (toot) + "Check if TOOT is user's own, for deleting, editing, or pinning it." + ;; this check needs to allow acting on own toots displayed as boosts, so we + ;; call `mastodon-tl--toot-or-base'. + (let ((json (mastodon-tl--toot-or-base toot))) + (string= (alist-get 'acct (alist-get 'account json)) + (mastodon-auth--user-acct)))) + +(defun mastodon-toot--pin-toot-toggle () + "Pin or unpin user's toot at point." + (interactive) + (let* ((toot (mastodon-toot--base-toot-or-item-json)) + (pinnable-p (mastodon-toot--own-toot-p toot)) + (pinned-p (eq t (alist-get 'pinned toot))) + (action (if pinned-p "unpin" "pin")) + (msg (if pinned-p "unpinned" "pinned"))) + (if (not pinnable-p) + (user-error "You can only pin your own toots") + (when (y-or-n-p (format "%s this toot? " (capitalize action))) + (mastodon-toot--action action + (lambda (_) + (when mastodon-tl--buffer-spec + (mastodon-tl--reload-timeline-or-profile)) + (message "Toot %s!" msg))))))) + + +;;; DELETE, DRAFT, REDRAFT + +(defun mastodon-toot--delete-toot () + "Delete user's toot at point synchronously." + (interactive) + (mastodon-toot--delete-and-redraft-toot t)) + +;; TODO: handle media/poll for redrafting toots +(defun mastodon-toot--delete-and-redraft-toot (&optional no-redraft) + "Delete and redraft user's toot at point synchronously. +NO-REDRAFT means delete toot only." + (interactive) + (let* ((toot (mastodon-toot--base-toot-or-item-json)) + (id (mastodon-tl--as-string (mastodon-tl--item-id toot))) + (url (mastodon-http--api (format "statuses/%s" id))) + (pos (point))) + (let-alist toot + (if (not (mastodon-toot--own-toot-p toot)) + (user-error "You can only delete (and redraft) your own toots") + (when (y-or-n-p (if no-redraft + (format "Delete this toot? ") + (format "Delete and redraft this toot? "))) + (let* ((response (mastodon-http--delete url))) + (mastodon-http--triage + response + (lambda (_) + (if no-redraft + (progn + (when mastodon-tl--buffer-spec + (mastodon-tl--reload-timeline-or-profile pos)) + (message "Toot deleted!")) + (mastodon-toot--redraft response + .in_reply_to_id + .visibility + .spoiler_text)))))))))) + +(defun mastodon-toot--set-cw (&optional cw) + "Set content warning to CW if it is non-nil." + (unless (or (null cw) ; cw is nil for `mastodon-tl--dm-user' + (string-empty-p cw)) + (setq mastodon-toot--content-warning cw))) + + +;;; REDRAFT + +(defun mastodon-toot--redraft (response &optional reply-id toot-visibility + toot-cw) + "Opens a new toot compose buffer using values from RESPONSE buffer. +REPLY-ID, TOOT-VISIBILITY, and TOOT-CW of deleted toot are preseved." + (with-current-buffer response + (let* ((response (mastodon-http--process-json)) + (content (alist-get 'text response))) + (mastodon-toot--compose-buffer) + (goto-char (point-max)) + (insert content) + ;; adopt reply-to-id, visibility and CW from deleted toot: + (mastodon-toot--set-toot-properties + reply-id toot-visibility toot-cw + ;; TODO set new lang/scheduled props here + nil)))) + +(defun mastodon-toot--set-toot-media-attachments (media) + "Set the media attachments variables. +MEDIA is the media_attachments data for a status from the server." + (mapcar (lambda (x) + (cl-pushnew (alist-get 'id x) + mastodon-toot--media-attachment-ids) + (cl-pushnew `((:contents . ,(mastodon-http--read-file-as-string + (alist-get 'url x) :url)) + (:description . ,(alist-get 'description x))) + mastodon-toot--media-attachments)) + media)) + +(defun mastodon-toot--set-toot-properties + (reply-id visibility cw lang &optional scheduled scheduled-id media poll) + "Set the toot properties for the current redrafted or edited toot. +REPLY-ID, VISIBILITY, CW, SCHEDULED, and LANG are the properties to set. +MEDIA is the media_attachments data for a status from the server." + (with-current-buffer "*edit toot*" + (when reply-id + (setq mastodon-toot--reply-to-id reply-id)) + (setq mastodon-toot--visibility visibility) + (setq mastodon-toot--scheduled-for scheduled) + (setq mastodon-toot--scheduled-id scheduled-id) + (when (not (string-empty-p lang)) + (setq mastodon-toot--language lang)) + (mastodon-toot--set-cw cw) + (when media + (mastodon-toot--set-toot-media-attachments media)) + (when poll + (mastodon-toot--server-poll-to-local poll)) + (mastodon-toot--refresh-attachments-display) + (mastodon-toot--update-status-fields))) + +(defun mastodon-toot--kill (&optional cancel) + "Kill `mastodon-toot-mode' buffer and window. +CANCEL means the toot was not sent, so we save the toot text as a draft." + (let ((prev-window-config mastodon-toot-previous-window-config)) + (unless (eq mastodon-toot-current-toot-text nil) + (when cancel + (cl-pushnew mastodon-toot-current-toot-text + mastodon-toot-draft-toots-list :test #'string=))) + ;; prevent some weird bug when cancelling a non-empty toot: + (delete #'mastodon-toot--save-toot-text after-change-functions) + (quit-window 'kill) + (mastodon-toot--restore-previous-window-config prev-window-config))) + +(defun mastodon-toot--cancel () + "Kill new-toot buffer/window. Does not POST content. +If toot is not empty, prompt to save text as a draft." + (interactive) + (when (and (not (mastodon-toot--empty-p)) + (y-or-n-p "Save draft toot?")) + (mastodon-toot--save-draft)) + (mastodon-toot--kill)) + +(defun mastodon-toot--save-draft () + "Save the current compose toot text as a draft. +Pushes `mastodon-toot-current-toot-text' to +`mastodon-toot-draft-toots-list'." + (interactive) + (unless (string= mastodon-toot-current-toot-text nil) + (cl-pushnew mastodon-toot-current-toot-text + mastodon-toot-draft-toots-list :test 'string=) + (message "Draft saved!"))) + +(defun mastodon-toot--empty-p (&optional text-only) + "Return t if toot has no text, attachments, or polls. +TEXT-ONLY means don't check for attachments or polls." + (and (if text-only + t + (and (not mastodon-toot--media-attachments) + (not mastodon-toot-poll))) + (string-empty-p (mastodon-tl--clean-tabs-and-nl + (mastodon-toot--remove-docs))))) + + +;;; EMOJIS + +(defun mastodon-toot--insert-emoji () + "Prompt to insert an emoji." + (interactive) + (if mastodon-use-emojify + (emojify-insert-emoji) + (emoji-search))) + +(defun mastodon-toot--emoji-dir () + "Return the file path for the mastodon custom emojis directory." + (concat (expand-file-name emojify-emojis-dir) + "/mastodon-custom-emojis/")) + +(defun mastodon-toot--download-custom-emoji () + "Download `mastodon-instance-url's custom emoji. +Emoji images are stored in a subdir of `emojify-emojis-dir'. +To use the downloaded emoji, run `mastodon-toot--enable-custom-emoji'." + (interactive) + (let* ((url (mastodon-http--api "custom_emojis")) + (custom-emoji (mastodon-http--get-json url)) + (mastodon-custom-emoji-dir (mastodon-toot--emoji-dir))) + (if (not (file-directory-p emojify-emojis-dir)) + (user-error "Looks like you need to set up emojify first") + (unless (file-directory-p mastodon-custom-emoji-dir) + (make-directory mastodon-custom-emoji-dir nil)) ; no add parent + (mapc (lambda (x) + (let ((url (alist-get 'url x)) + (shortcode (alist-get 'shortcode x))) + ;; skip anything that contains unexpected characters + (when (and url shortcode + (string-match-p "^[a-zA-Z0-9-_]+$" shortcode) + (string-match-p "^[a-zA-Z]+$" (file-name-extension url))) + (url-copy-file url + (concat mastodon-custom-emoji-dir + shortcode + "." + (file-name-extension url)) + t)))) + custom-emoji) + (message "Custom emoji for %s downloaded to %s" + mastodon-instance-url + mastodon-custom-emoji-dir)))) + +(defun mastodon-toot--collect-custom-emoji () + "Return a list of `mastodon-instance-url's custom emoji. +The list is formatted for `emojify-user-emojis', which see." + (let* ((mastodon-custom-emojis-dir (mastodon-toot--emoji-dir)) + (custom-emoji-files (directory-files mastodon-custom-emojis-dir + nil ; not full path + "^[^.]")) ; no dot files + mastodon-emojify-user-emojis) + (mapc (lambda (x) + (push + `(,(concat ":" + (file-name-base x) ":") + . (("name" . ,(file-name-base x)) + ("image" . ,(concat mastodon-custom-emojis-dir x)) + ("style" . "github"))) + mastodon-emojify-user-emojis)) + custom-emoji-files) + (reverse mastodon-emojify-user-emojis))) + +(defun mastodon-toot--enable-custom-emoji () + "Add `mastodon-instance-url's custom emoji to `emojify'. +Custom emoji must first be downloaded with +`mastodon-toot--download-custom-emoji'. Custom emoji are appended +to `emojify-user-emojis', and the emoji data is updated." + (interactive) + (unless (file-exists-p (mastodon-toot--emoji-dir)) + (when (y-or-n-p "Looks like you haven't downloaded your + instance's custom emoji yet. Download now? ") + (mastodon-toot--download-custom-emoji))) + (let ((masto-emojis (mastodon-toot--collect-custom-emoji))) + (unless (cl-find (car masto-emojis) + emojify-user-emojis + :test #'equal) + (setq emojify-user-emojis + (append masto-emojis + emojify-user-emojis)) + ;; if already loaded, reload + (when (featurep 'emojify) + ;; we now only do this within the unless test above, as it is extremely + ;; slow and runs in `mastodon-mode-hook'. + (emojify-set-emoji-data))))) + +(defun mastodon-toot--remove-docs () + "Get the body of a toot from the current compose buffer." + (let ((header-region (mastodon-tl--find-property-range 'toot-post-header + (point-min)))) + (string-trim-left + (buffer-substring (cdr header-region) (point-max))))) + +(defun mastodon-toot--build-poll-params () + "Return an alist of parameters for POSTing a poll status." + (if mastodon-toot-poll-use-transient + (let-alist mastodon-toot-poll + (append + (mastodon-http--build-array-params-alist + "poll[options][]" + (list .one .two .three .four)) + (list (cons "poll[expires_in]" .expiry) + (cons "poll[multiple]" .multi) + (cons "poll[hide_totals]" .hide)))) + (append + (mastodon-http--build-array-params-alist + "poll[options][]" + (plist-get mastodon-toot-poll :options)) + `(("poll[expires_in]" . ,(plist-get mastodon-toot-poll :expiry))) + `(("poll[multiple]" . ,(symbol-name (plist-get mastodon-toot-poll :multi)))) + `(("poll[hide_totals]" . ,(symbol-name (plist-get mastodon-toot-poll :hide))))))) + + +;;; SEND TOOT FUNCTION + +(defun mastodon-toot--send () + "POST contents of new-toot buffer to fediverse instance and kill buffer. +If media items have been attached and uploaded with +`mastodon-toot--attach-media', they are attached to the toot. +If `mastodon-toot--edit-item-id' is non-nil, PUT contents to +instance to edit a toot." + (interactive) + (let* ((toot (mastodon-toot--remove-docs)) + (scheduled mastodon-toot--scheduled-for) + (scheduled-id mastodon-toot--scheduled-id) + (edit-id mastodon-toot--edit-item-id) + (endpoint (mastodon-http--api (if edit-id ; we are sending an edit: + (format "statuses/%s" edit-id) + "statuses"))) + (args-no-media + (append + `(("status" . ,toot) + ("in_reply_to_id" . ,mastodon-toot--reply-to-id) + ("visibility" . ,mastodon-toot--visibility) + ("sensitive" . ,(when mastodon-toot--content-nsfw + (symbol-name t))) + ("spoiler_text" . ,mastodon-toot--content-warning) + ("language" . ,mastodon-toot--language)) + ;; Pleroma instances can't handle null-valued + ;; scheduled_at args, so only add if non-nil + (when scheduled `(("scheduled_at" . ,scheduled))))) + (args-media (when mastodon-toot--media-attachment-ids + (mastodon-http--build-array-params-alist + "media_ids[]" + mastodon-toot--media-attachment-ids))) + (args-poll (when mastodon-toot-poll + (mastodon-toot--build-poll-params))) + ;; media || polls: + (args (if mastodon-toot--media-attachment-ids + (append args-media args-no-media) + (if mastodon-toot-poll + (append args-no-media args-poll) + args-no-media))) + (prev-window-config mastodon-toot-previous-window-config)) + (cond ((and mastodon-toot--media-attachment-ids + ;; make sure we have media args + ;; and the same num of ids as attachments + (or (not args-media) + (not (= (length mastodon-toot--media-attachments) + (length mastodon-toot--media-attachment-ids))))) + (user-error "Something is wrong with your uploads. Wait for them to complete or try again")) + ((and mastodon-toot--max-toot-chars + (> (mastodon-toot--count-toot-chars toot mastodon-toot--content-warning) + mastodon-toot--max-toot-chars)) + (user-error "Looks like your toot (inc. CW) is longer than that maximum allowed length")) + ;; polls must have text, so we use poll as flag for text-only + ;; check here: + ((mastodon-toot--empty-p mastodon-toot-poll) + (user-error "Empty toot. Cowardly refusing to post this")) + (t + (let ((response (funcall (if edit-id ; we are sending an edit: + #'mastodon-http--put + #'mastodon-http--post) + endpoint args))) + (mastodon-http--triage + response + (lambda (_) + ;; kill buffer: + (mastodon-toot--kill) + ;; nil our poll var: + (setq mastodon-toot-poll nil) + (message "Toot %s!" (if scheduled "scheduled" "toot")) + ;; cancel scheduled toot if we were editing it: + (when scheduled-id + (mastodon-views--cancel-scheduled-toot + scheduled-id :no-confirm)) + ;; window config: + (mastodon-toot--restore-previous-window-config prev-window-config) + ;; reload: - when we have been editing + ;; - when we are in thread view + ;; (we don't reload in every case as it can be slow and we may + ;; lose our place in a timeline.) + (when (or edit-id + (eq 'thread (mastodon-tl--get-buffer-type))) + (let ((pos (marker-position (cadr prev-window-config)))) + (mastodon-tl--reload-timeline-or-profile pos)))))))))) + + +;;; EDITING TOOTS: + +(defun mastodon-toot--edit-toot-at-point () + "Edit the user's toot at point." + (interactive) + (mastodon-toot--with-toot-item + (let ((toot (mastodon-toot--base-toot-or-item-json))) + (if (not (mastodon-toot--own-toot-p toot)) + (user-error "You can only edit your own toots") + (let* ((source (mastodon-toot--get-toot-source id)) + (content (alist-get 'text source)) + (source-cw (alist-get 'spoiler_text source))) + (let-alist toot + (when (y-or-n-p "Edit this toot? ") + (mastodon-toot--compose-buffer nil .in_reply_to_id nil + content :edit) + (goto-char (point-max)) + ;; adopt reply-to-id, visibility, CW, language, and media: + (mastodon-toot--set-toot-properties .in_reply_to_id .visibility + source-cw .language nil nil + .media_attachments .poll) + (setq mastodon-toot--edit-item-id id)))))))) + +(defun mastodon-toot--get-toot-source (id) + "Fetch the source JSON of toot with ID." + (let ((url (mastodon-http--api (format "/statuses/%s/source" id)))) + (mastodon-http--get-json url nil :silent))) + +(defun mastodon-toot--get-toot-edits (id) + "Return the edit history of toot with ID." + (let* ((url (mastodon-http--api (format "statuses/%s/history" id)))) + (mastodon-http--get-json url))) + +(defun mastodon-toot--view-toot-edits () + "View editing history of the toot at point in a popup buffer." + (interactive) + (let ((id (mastodon-tl--property 'base-item-id)) + (history (mastodon-tl--property 'edit-history)) ;; at byline + (buf "*mastodon-toot-edits*")) + (if (not history) + (user-error "No editing history for this toot") + (with-mastodon-buffer buf #'special-mode :other-window + (cl-loop for count from 1 + for x in history + do (insert (propertize (if (= count 1) + (format "%s [original]:\n" count) + (format "%s:\n" count)) + 'face 'font-lock-comment-face) + (mastodon-toot--insert-toot-iter x) + "\n")) + (goto-char (point-min)) + (setq-local header-line-format + (propertize + (format "Edits to toot by %s:" + (alist-get 'username + (alist-get 'account (car history)))) + 'face 'font-lock-comment-face)) + (mastodon-tl--set-buffer-spec (buffer-name (current-buffer)) + (format "statuses/%s/history" id) + nil))))) + +(defun mastodon-toot--insert-toot-iter (it) + "Insert iteration IT of toot." + (let ((content (alist-get 'content it))) + ;; TODO: handle polls, media + (mastodon-tl--render-text content))) + +(defun mastodon-toot--restore-previous-window-config (config) + "Restore the window CONFIG after killing the toot compose buffer. +Buffer-local variable `mastodon-toot-previous-window-config' holds the config." + (set-window-configuration (car config)) + (goto-char (cadr config))) + +(defun mastodon-toot--mentions-to-string (mentions) + "Apply `mastodon-toot--process-local' function to each mention in MENTIONS. +Remove empty string (self) from result and joins the sequence with whitespace." + (let ((mentions (remove "" + (mapcar #'mastodon-toot--process-local mentions)))) + (mapconcat #'identity mentions " "))) + +(defun mastodon-toot--process-local (acct) + "Add domain to local ACCT and replace the curent user name with \"\". +Mastodon requires the full @user@domain, even in the case of local accts. +eg. \"user\" -> \"@user@local.social\" (when local.social is the domain of the +`mastodon-instance-url'). +eg. \"yourusername\" -> \"\" +eg. \"feduser@fed.social\" -> \"@feduser@fed.social\"." + (cond ((string-match-p "@" acct) (concat "@" acct)) ; federated acct + ((string= (mastodon-auth--user-acct) acct) "") ; your acct + (t + (concat "@" acct "@" ; local acct + (cadr + (split-string mastodon-instance-url "/" :omit-nulls)))))) + + +;;; COMPLETION (TAGS, MENTIONS) + +(defun mastodon-toot--mentions (status) + "Extract mentions (not the reply-to author or booster) from STATUS. +The mentioned users look like this: +Local user (including the logged in): `username`. +Federated user: `username@host.co`." + (let* ((mentions (mastodon-tl--field 'mentions status))) + ;; reverse does not work on vectors in 24.5 + (mastodon-tl--map-alist 'acct (reverse mentions)))) + +(defun mastodon-toot--get-bounds (regex) + "Get bounds of tag or handle before point using REGEX." + ;; # and @ are not part of any existing thing at point + (save-match-data + (save-excursion + ;; match full handle inc. domain, or tag including # + ;; (see the regexes for subexp 2) + (when (re-search-backward regex + (save-excursion (forward-whitespace -1) + (point)) + :no-error) + (cons (match-beginning 2) + (match-end 2)))))) + +(defun mastodon-toot--fetch-emojify-candidates () + "Get the candidates to be used for emojis completion. +The candidates are calculated according to currently active +`emojify-emoji-styles'. Hacked off +`emojify--get-completing-read-candidates'." + (let ((styles (mapcar #'symbol-name emojify-emoji-styles))) + (let ((emojis '())) + (emojify-emojis-each + (lambda (key value) + (when (seq-position styles (ht-get value "style")) + (push (cons key + (format "%s (%s)" + (ht-get value "name") + (ht-get value "style"))) + emojis)))) + emojis))) + +(defun mastodon-toot--fetch-candidates (start end &optional type) + "Search for a completion prefix from buffer positions START to END. +Return a list of candidates. +TYPE is the candidate type, it may be :tags, :handles, or :emoji." + ;; we can't save the first two-letter search then only filter the + ;; resulting list, as max results returned is 40. + (setq mastodon-toot-completions + (cond ((eq type :tags) + (let ((tags-list (mastodon-search--search-tags-query + (buffer-substring-no-properties start end)))) + (cl-loop for tag in tags-list + collect (cons (concat "#" (car tag)) + (cdr tag))))) + ((eq type :emoji) + (when (bound-and-true-p emojify-mode) + (mastodon-toot--fetch-emojify-candidates))) + (t + (mastodon-search--search-accounts-query + (buffer-substring-no-properties start end)))))) + +(defun mastodon-toot--make-capf (regex annot-fun type) + "Build a completion backend for `completion-at-point-functions'. +REGEX is the regex to match preceding text. +TYPE is a keyword symbol for `mastodon-toot--fetch-candidates'. +ANNOT-FUN is a function returning an annotatation from a single +arg, a candidate." + (let* ((bounds (mastodon-toot--get-bounds regex)) + (start (car bounds)) + (end (cdr bounds))) + (when bounds + (list start + end + (completion-table-dynamic ; only search when necessary + (lambda (_) + ;; Interruptible candidate computation, from minad/d mendler, thanks! + (let ((result + (while-no-input + (mastodon-toot--fetch-candidates + start end type)))) + (and (consp result) result)))) + :exclusive 'no + :annotation-function + (lambda (cand) + (concat " " (funcall annot-fun cand))))))) + +(defun mastodon-toot--mentions-capf () + "Build a mentions completion backend for `completion-at-point-functions'." + (mastodon-toot--make-capf mastodon-toot-handle-regex + #'mastodon-toot--mentions-annotation-fun + :handles)) + +(defun mastodon-toot--tags-capf () + "Build a tags completion backend for `completion-at-point-functions'." + (mastodon-toot--make-capf mastodon-toot-tag-regex + #'mastodon-toot--tags-annotation-fun + :tags)) + +(defun mastodon-toot--emoji-capf () + "Build an emoji completion backend for `completion-at-point-functions'." + (mastodon-toot--make-capf mastodon-toot-emoji-regex + #'mastodon-toot--emoji-annotation-fun + :emoji)) + +(defun mastodon-toot--mentions-annotation-fun (candidate) + "Given a handle completion CANDIDATE, return its annotation string, a username." + (caddr (assoc candidate mastodon-toot-completions))) + +(defun mastodon-toot--tags-annotation-fun (candidate) + "Given a tag string CANDIDATE, return an annotation, the tag's URL." + ;; TODO: check the list returned here? should be cadr + ;; or make it an alist and use cdr + (cadr (assoc candidate mastodon-toot-completions))) + +(defun mastodon-toot--emoji-annotation-fun (candidate) + "CANDIDATE." + ;; TODO: emoji image as annot + (cdr (assoc candidate mastodon-toot-completions))) + + +;;; REPLY + +(defun mastodon-toot--reply () + "Reply to toot at `point'. +Customize `mastodon-toot-display-orig-in-reply-buffer' to display +text of the toot being replied to in the compose buffer. +If the region is active, inject it into the reply buffer, +prefixed by >." + (interactive) + (mastodon-toot--with-toot-item + (let* ((quote (when (region-active-p) + (buffer-substring (region-beginning) + (region-end)))) + (toot (mastodon-toot--base-toot-or-item-json)) + (account (mastodon-tl--field 'account toot)) + (user (alist-get 'acct account)) + (mentions (mastodon-toot--mentions toot)) + (boosted (mastodon-tl--field 'reblog toot)) + (booster (when boosted + (alist-get 'acct + (alist-get 'account toot)))) + (mentions + (cond ((and booster ;; different booster, user and mentions: + (and (not (string= user booster)) + (not (member booster mentions)))) + (mastodon-toot--mentions-to-string + (append (list user booster) mentions nil))) + ((not (member user mentions)) ;; user not in mentions: + (mastodon-toot--mentions-to-string + (append (list user) mentions nil))) + (t ;; user already in mentions: + (mastodon-toot--mentions-to-string + (copy-sequence mentions)))))) + (mastodon-toot--compose-buffer mentions id toot quote)))) + + +;;; COMPOSE TOOT SETTINGS + +(defun mastodon-toot--set-content-warning () + "Set a content warning for the current toot." + (interactive) + (setq mastodon-toot--content-warning + (read-string "Warning: " mastodon-toot--content-warning)) + (mastodon-toot--update-status-fields)) + +(defun mastodon-toot--toggle-nsfw () + "Toggle `mastodon-toot--content-nsfw'." + (interactive) + (setq mastodon-toot--content-nsfw + (not mastodon-toot--content-nsfw)) + (message "NSFW flag is now %s" (if mastodon-toot--content-nsfw "on" "off")) + (mastodon-toot--update-status-fields)) + +(defun mastodon-toot--change-visibility () + "Change the current visibility to the next valid value." + (interactive) + (if (mastodon-tl--buffer-type-eq 'edit-toot) + (user-error "You can't change visibility when editing toots") + (setq mastodon-toot--visibility + (cond ((string= mastodon-toot--visibility "public") + "unlisted") + ((string= mastodon-toot--visibility "unlisted") + "private") + ((string= mastodon-toot--visibility "private") + "direct") + (t + "public"))) + (mastodon-toot--update-status-fields))) + +(defun mastodon-toot--set-toot-language () + "Prompt for a language and set `mastodon-toot--language'. +Return its two letter ISO 639 1 code." + (interactive) + (let* ((choice (completing-read "Language for this toot: " + mastodon-iso-639-1))) + (setq mastodon-toot--language + (alist-get choice mastodon-iso-639-1 nil nil #'string=)) + (message "Language set to %s" choice) + (mastodon-toot--update-status-fields))) + + +;;; ATTACHMENTS + +(defun mastodon-toot--clear-all-attachments () + "Remove all attachments from a toot draft." + (interactive) + (setq mastodon-toot--media-attachments nil) + (setq mastodon-toot--media-attachment-ids nil) + (mastodon-toot--refresh-attachments-display) + (mastodon-toot--update-status-fields)) + +(defun mastodon-toot--get-instance-max-attachments () + "Return the maximum attachments from `mastodon-active-user's instance. +If that fails, return 4 as a fallback" + ;; FIXME: this likely various for other server types: + ;; pleroma doesn't advertise this on "api/v1/instance" (checked + ;; fe.disroot.org) + (or + (let ((config (alist-get 'statuses + (alist-get 'configuration + (mastodon-views--get-own-instance))))) + (alist-get 'max_media_attachments config)) + 4)) ; mastodon default as fallback + +(defun mastodon-toot--attach-media (file description) + "Prompt for an attachment FILE with DESCRIPTION. +A preview is displayed in the new toot buffer, and the file +is uploaded asynchronously using `mastodon-toot--upload-attached-media'. +File is actually attached to the toot upon posting." + (interactive "fFilename: \nsDescription: ") + (let ((max-attachments (mastodon-toot--get-instance-max-attachments))) + (when (>= (length mastodon-toot--media-attachments) + max-attachments) + ;; warn + pop the oldest one: + (when (y-or-n-p + (format "Maximum attachments (%s) reached: remove first one?" + max-attachments)) + (pop mastodon-toot--media-attachments))) + (if (file-directory-p file) + (user-error "Looks like you chose a directory not a file") + (setq mastodon-toot--media-attachments + (nconc mastodon-toot--media-attachments + `(((:contents . ,(mastodon-http--read-file-as-string file)) + (:description . ,description) + (:filename . ,file))))) + (mastodon-toot--refresh-attachments-display) + ;; upload only most recent attachment: + (mastodon-toot--upload-attached-media + (car (last mastodon-toot--media-attachments)))))) + +(defun mastodon-toot--attachment-descriptions () + "Return a list of image descriptions for current attachments." + (mastodon-tl--map-alist :description mastodon-toot--media-attachments)) + +(defun mastodon-toot--attachment-from-desc (desc) + "Return an attachment based on its description DESC." + (car + (cl-member-if (lambda (x) + (rassoc desc x)) + mastodon-toot--media-attachments))) + +(defun mastodon-toot--edit-media-description () + "Prompt for an attachment, and update its description." + (interactive) + (let* ((descs (mastodon-toot--attachment-descriptions)) + (choice (completing-read "Attachment: " descs nil :match)) + (attachment (mastodon-toot--attachment-from-desc choice)) + (desc-new (read-string "Description: " choice))) + (setf (alist-get :description attachment) + desc-new) + (mastodon-toot--refresh-attachments-display))) + +(defun mastodon-toot--upload-attached-media (attachment) + "Upload a single ATTACHMENT using `mastodon-http--post-media-attachment'. +The item's id is added to `mastodon-toot--media-attachment-ids', +which is used to attach it to a toot when posting." + (let* ((filename (expand-file-name (alist-get :filename attachment))) + (caption (alist-get :description attachment)) + (url (concat mastodon-instance-url "/api/v2/media"))) + (message "Uploading %s... (please wait before starting further uploads)" + (file-name-nondirectory filename)) + (mastodon-http--post-media-attachment url filename caption))) + +(defun mastodon-toot--refresh-attachments-display () + "Update the display attachment previews in toot draft buffer." + (let ((inhibit-read-only t) + (attachments-region (mastodon-tl--find-property-range + 'toot-attachments (point-min))) + (display-specs (mastodon-toot--format-attachments))) + (dotimes (i (- (cdr attachments-region) (car attachments-region))) + (add-text-properties (+ i (car attachments-region)) + (+ i 1 (car attachments-region)) + (list 'display (or (nth i display-specs) "")))))) + +(defun mastodon-toot--format-attachments () + "Format the attachment previews for display in toot draft buffer." + (or + (let ((image-options (when (mastodon-tl--image-trans-check) + `(:height ,mastodon-toot--attachment-height)))) + (cl-loop for count from 1 + for att in mastodon-toot--media-attachments + nconc + (let* ((data (alist-get :contents att)) + (image (apply #'create-image data + (if (version< emacs-version "27.1") + (when image-options 'imagemagick) + nil) ; inbuilt scaling in 27.1 + t image-options)) + (desc (alist-get :description att))) + (list (format "\n %d: " count) + image + (format " \"%s\"" desc))))) + (list "None"))) + + +;;; POLL + +(defun mastodon-toot--fetch-max-poll-options (instance) + "Return the maximum number of poll options from JSON data INSTANCE." + (mastodon-toot--fetch-poll-field 'max_options instance)) + +(defun mastodon-toot--fetch-max-poll-option-chars (instance) + "Return the maximum number of characters a poll option may have. +INSTANCE is JSON." + (if (alist-get 'pleroma instance) + (mastodon-toot--fetch-poll-field 'max_option_chars instance) + (or (mastodon-toot--fetch-poll-field 'max_characters_per_option instance) + 50))) ; masto default + +(defun mastodon-toot--fetch-poll-field (field instance) + "Return FIELD from the poll settings from JSON data INSTANCE." + (let* ((polls (if (alist-get 'pleroma instance) + (alist-get 'poll_limits instance) + (alist-get 'polls + (alist-get 'configuration instance))))) + (alist-get field polls))) + +(defun mastodon-toot--read-poll-options-count (max) + "Read the user's choice of the number of options the poll should have. +MAX is the maximum number set by their instance." + (let ((number (read-number (format "Number of options [2-%s]: " max) 2))) + (if (> number max) + (user-error "You need to choose a number between 2 and %s" max) + number))) + +(defun mastodon-toot--create-poll () + "Prompt for new poll options and return as a list." + (interactive) + (if mastodon-toot-poll-use-transient + (call-interactively #'mastodon-create-poll) + (mastodon-toot--read-poll))) + +(defun mastodon-toot--read-poll () + "Read poll options." + (let* ((instance (mastodon-instance-data)) + (max-options (mastodon-toot--fetch-max-poll-options instance)) + (count (mastodon-toot--read-poll-options-count max-options)) + (length (mastodon-toot--fetch-max-poll-option-chars instance)) + (multiple-p (y-or-n-p "Multiple choice? ")) + (options (mastodon-toot--read-poll-options count length)) + (hide-totals (y-or-n-p "Hide votes until poll ends? ")) + (expiry (mastodon-toot--read-poll-expiry)) + (expiry-str (cdr expiry)) + (expiry-human (car expiry))) + (setq mastodon-toot-poll + `( :options ,options :length ,length :expiry-readable ,expiry-human + :expiry ,expiry-str :multi ,multiple-p :hide ,hide-totals)) + (message "poll created!") + (mastodon-toot--update-status-fields))) + +(defun mastodon-toot--read-poll-options (count length) + "Read a list of options for poll with COUNT options. +LENGTH is the maximum character length allowed for a poll option." + (let* ((choices + (cl-loop for x from 1 to count + collect (read-string + (format "Poll option [%s/%s] [max %s chars]: " + x count length)))) + (longest (apply #'max (mapcar #'length choices)))) + (if (not (> longest length)) + choices + (user-error "Looks like you went over the max length. Try again") + (sleep-for 2) + (mastodon-toot--read-poll-options count length)))) + +(defun mastodon-toot--read-poll-expiry () + "Prompt for a poll expiry time. +Return a cons of a human readable string, and a seconds-from-now string." + ;; API requires this in seconds + (let* ((options (mastodon-toot--poll-expiry-options-alist)) + (response (completing-read "poll ends in [or enter seconds]: " + options nil 'confirm))) + (or (assoc response options #'string=) + (if (< (string-to-number response) 600) + (car options))))) ;; min 5 mins + +(defun mastodon-toot--poll-expiry-options-alist () + "Return an alist of expiry options options in seconds." + `(("5 minutes" . ,(number-to-string (* 60 5))) + ("30 minutes" . ,(number-to-string (* 60 30))) + ("1 hour" . ,(number-to-string (* 60 60))) + ("6 hours" . ,(number-to-string (* 60 60 6))) + ("1 day" . ,(number-to-string (* 60 60 24))) + ("3 days" . ,(number-to-string (* 60 60 24 3))) + ("7 days" . ,(number-to-string (* 60 60 24 7))) + ("14 days" . ,(number-to-string (* 60 60 24 14))) + ("30 days" . ,(number-to-string (* 60 60 24 30))))) + +(defun mastodon-toot--clear-poll (&optional transient) + "Remove poll from toot compose buffer. +Sets `mastodon-toot-poll' to nil. +If TRANSIENT, we are called from a transient, so nil +`tp-transient-settings' too." + (interactive) + (let ((var (if transient + 'tp-transient-settings + 'mastodon-toot-poll))) + (if (not (symbol-value var)) + (user-error "No poll?") + (set var nil) + (when transient + (setq mastodon-toot-poll nil)) + (mastodon-toot--update-status-fields)))) + +(defun mastodon-toot--server-poll-to-local (json) + "Convert server poll data JSON to a `mastodon-toot-poll' plist." + (let-alist json + (let* ((expiry-seconds-rel + (time-to-seconds + (time-subtract + (encode-time + (parse-time-string .expires_at)) + (current-time)))) + (expiry-str (format-time-string "%s" expiry-seconds-rel)) + (expiry-human (car + (mastodon-tl--human-duration expiry-seconds-rel))) + (options (mastodon-tl--map-alist 'title .options)) + (multiple (if (eq :json-false .multiple) nil t))) + (if mastodon-toot-poll-use-transient + (setq mastodon-toot-poll + `((multi . ,multiple) + (expiry . ,expiry-str) + ;; (hide . ,hide) + (one . ,(nth 0 options)) + (two . ,(nth 1 options)) + (three . ,(nth 2 options)) + (four . ,(nth 3 options)))) + (setq mastodon-toot-poll + `( :options ,options :expiry-readable ,expiry-human + :expiry ,expiry-str :multi ,multiple)))))) + + +;;; SCHEDULE + +(defun mastodon-toot--schedule-toot (&optional reschedule) + "Read a date (+ time) in the minibuffer and schedule the current toot. +With RESCHEDULE, reschedule the scheduled toot at point without editing." + ;; original idea by christian tietze, thanks! + ;; https://codeberg.org/martianh/mastodon.el/issues/285 + (interactive) + (cond ((mastodon-tl--buffer-type-eq 'edit-toot) + (user-error "You can't schedule toots you're editing")) + ((not (or (mastodon-tl--buffer-type-eq 'new-toot) + (mastodon-tl--buffer-type-eq 'scheduled-statuses))) + (user-error "You can only schedule toots from the compose buffer or scheduled toots view")) + (t + (let* ((id (when reschedule (mastodon-tl--property 'id :no-move))) + (ts (when reschedule + (alist-get 'scheduled_at + (mastodon-tl--property 'scheduled-json :no-move)))) + (time-value + (org-read-date t t nil "Schedule toot:" + ;; default to scheduled timestamp if already set: + (mastodon-toot--iso-to-org + ;; we are rescheduling without editing: + (or ts + ;; we are maybe editing the scheduled toot: + mastodon-toot--scheduled-for)))) + (iso8601-str (format-time-string "%FT%T%z" time-value)) + (msg-str (format-time-string "%d-%m-%y at %H:%M[%z]" time-value))) + (if (not reschedule) + (progn + (setq-local mastodon-toot--scheduled-for iso8601-str) + (message "Toot scheduled for %s." msg-str)) + (let* ((args `(("scheduled_at" . ,iso8601-str))) + (url (mastodon-http--api (format "scheduled_statuses/%s" id))) + (response (mastodon-http--put url args))) + (mastodon-http--triage + response + (lambda (_) + ;; reschedule means we are in scheduled toots view: + (mastodon-views--view-scheduled-toots) + (message "Toot rescheduled for %s." msg-str))))))))) + +(defun mastodon-toot--iso-to-human (ts) + "Format an ISO8601 timestamp TS to be more human-readable." + (let* ((decoded (iso8601-parse ts)) + (encoded (encode-time decoded))) + (format-time-string "%d-%m-%y, %H:%M[%z]" encoded))) + +(defun mastodon-toot--iso-to-org (ts) + "Convert ISO8601 timestamp TS to something `org-read-date' can handle." + (when ts + (let* ((decoded (iso8601-parse ts))) + (encode-time decoded)))) + + +;;; DISPLAY KEYBINDINGS + +(defun mastodon-toot--get-kbinds () + "Get a list of the keybindings in the `mastodon-toot-mode'." + (let* ((binds (copy-tree mastodon-toot-mode-map)) + (prefix (car (cadr binds))) + (bindings (remove nil + (mapcar (lambda (i) + (when (listp i) i)) + (cadr binds))))) + (mapcar (lambda (b) + (setf (car b) (vector prefix (car b))) + b) + bindings))) + +(defun mastodon-toot--format-kbind-command (cmd) + "Format CMD to be more readable. +e.g. `mastodon-toot--send' -> Send." + (let* ((str (symbol-name cmd)) + (re "--\\(.*\\)$") + (str2 (save-match-data + (string-match re str) + (match-string 1 str)))) + (capitalize (replace-regexp-in-string "-" " " str2)))) + +(defun mastodon-toot--format-kbind (kbind) + "Format a single keybinding, KBIND, for display in documentation." + (let ((key (concat "\\`" + (help-key-description (car kbind) nil) + "'")) + (command (mastodon-toot--format-kbind-command (cdr kbind)))) + (substitute-command-keys + (format + (concat (mastodon-toot--comment " ") + "%s" + (mastodon-toot--comment " - %s")) + key command)))) + +(defun mastodon-toot--comment (str) + "Propertize STR with `mastodon-toot-docs-face'." + (propertize str + 'face 'mastodon-toot-docs-face)) + +(defun mastodon-toot--format-kbinds (kbinds) + "Format a list of keybindings, KBINDS, for display in documentation." + (mapcar #'mastodon-toot--format-kbind kbinds)) + +(defvar-local mastodon-toot--kbinds-pairs nil + "Contains a list of paired toot compose buffer keybindings for inserting.") + +(defun mastodon-toot--formatted-kbinds-pairs (kbinds-list longest) + "Return a list of strings each containing two formatted kbinds. +KBINDS-LIST is the list of formatted bindings to pair. +LONGEST is the length of the longest binding." + (when kbinds-list + (push (concat "\n" + (car kbinds-list) + (make-string (- (1+ longest) (length (car kbinds-list))) + ?\ ) + (cadr kbinds-list)) + mastodon-toot--kbinds-pairs) + (mastodon-toot--formatted-kbinds-pairs (cddr kbinds-list) longest)) + (reverse mastodon-toot--kbinds-pairs)) + +(defun mastodon-toot--kbinds-longest (kbinds-list) + "Return the length of the longest item in KBINDS-LIST." + (let ((lengths (mapcar #'length kbinds-list))) + (car (sort lengths #'>)))) + + +;;; DISPLAY DOCS + +(defun mastodon-toot--make-mode-docs () + "Create formatted documentation text for `mastodon-toot-mode'." + (let* ((kbinds (mastodon-toot--get-kbinds)) + (formatted (mastodon-toot--format-kbinds kbinds)) + (longest-kbind (mastodon-toot--kbinds-longest + formatted))) + (concat + (mastodon-toot--comment + " Compose a new toot here. The following keybindings are available:") + (mapconcat + #'identity + (mastodon-toot--formatted-kbinds-pairs formatted longest-kbind) + nil)))) + +(defun mastodon-toot--format-reply-in-compose (reply-text) + "Format a REPLY-TEXT for display in compose buffer docs." + (let* ((rendered (mastodon-tl--render-text reply-text)) + (no-props (substring-no-properties rendered)) + ;; FIXME: this replaces \n at end of every post, so we have to trim: + (no-newlines (string-trim + (replace-regexp-in-string "[\n]+" " " no-props))) + (reply-to (concat " Reply to: \"" no-newlines "\"")) + (crop (truncate-string-to-width reply-to + mastodon-toot-orig-in-reply-length))) + (if (> (length no-newlines) + (length crop)) ; we cropped: + (concat crop "\n") + (concat reply-to "\n")))) + +(defun mastodon-toot--display-docs-and-status-fields (&optional reply-text) + "Insert propertized text with documentation about `mastodon-toot-mode'. +Also includes and the status fields which will get updated based +on the status of NSFW, content warning flags, media attachments, etc. +REPLY-TEXT is the text of the toot being replied to." + (let ((divider + "|=================================================================|")) + (insert + (concat + (mastodon-toot--make-mode-docs) "\n" + (mastodon-toot--comment divider) "\n" + (propertize + (concat + " " + (propertize "Count" + 'toot-post-counter t) + " ⋅ " + (propertize "Visibility" + 'toot-post-visibility t) + " ⋅ " + (propertize "Language" + 'toot-post-language t) + " " + (propertize "Scheduled" + 'toot-post-scheduled t) + " " + (propertize "CW" + 'toot-post-cw-flag t) + " " + (propertize "POLL" + 'toot-post-poll-flag t) + " " + (propertize "NSFW" + 'toot-post-nsfw-flag t) + "\n" + " Attachments: " + (propertize "None " + 'toot-attachments t) + "\n" + (when reply-text + (propertize + (mastodon-toot--format-reply-in-compose reply-text) + 'toot-reply t)) + divider) + 'face 'mastodon-toot-docs-face + 'read-only "Edit your message below." + 'toot-post-header t)) + ;; allow us to enter text after read-only header: + (propertize "\n\n" + 'rear-nonsticky t)))) + +(defun mastodon-toot--most-restrictive-visibility (reply-visibility) + "Return REPLY-VISIBILITY or default visibility, whichever is more restrictive. +The default is given by `mastodon-toot--default-reply-visibility'." + (unless (null reply-visibility) + (let ((less-restrictive (member (intern mastodon-toot--default-reply-visibility) + mastodon-toot-visibility-list))) + (if (member (intern reply-visibility) less-restrictive) + reply-visibility + mastodon-toot--default-reply-visibility)))) + +(defun mastodon-toot--render-reply-region-str (str) + "Refill STR and prefix all lines with >, as reply-quote text." + (with-temp-buffer + (insert str) + ;; unfill first: + (let ((fill-column (point-max))) + (fill-region (point-min) (point-max))) + ;; then fill: + (fill-region (point-min) (point-max)) + ;; add our own prefix, pauschal: + (goto-char (point-min)) + (save-match-data + (while (re-search-forward "^" nil t) + (replace-match " > "))) + (buffer-substring-no-properties (point-min) (point-max)))) + +(defun mastodon-toot--setup-as-reply (reply-to-user reply-to-id + reply-json reply-region) + "If REPLY-TO-USER is provided, inject their handle into the message. +If REPLY-TO-ID is provided, set `mastodon-toot--reply-to-id'. +REPLY-JSON is the full JSON of the toot being replied to. +REPLY-REGION is a string to be injected into the buffer." + (let ((reply-visibility (mastodon-toot--most-restrictive-visibility + (alist-get 'visibility reply-json))) + (reply-cw (alist-get 'spoiler_text reply-json))) + (when reply-to-user + (when (> (length reply-to-user) 0) ; self is "" unforch + (insert (format "%s " reply-to-user))) + (when reply-region + (insert "\n" + (mastodon-toot--render-reply-region-str reply-region) + "\n")) + (setq mastodon-toot--reply-to-id reply-to-id) + (unless (string= mastodon-toot--visibility reply-visibility) + (setq mastodon-toot--visibility reply-visibility)) + (mastodon-toot--set-cw reply-cw)))) + +(defun mastodon-toot--update-status-fields (&rest _args) + "Update the status fields in the header based on the current state." + (ignore-errors ;; called from after-change-functions so let's not leak errors + (let* ((inhibit-read-only t) + (header-region (mastodon-tl--find-property-range 'toot-post-header + (point-min))) + (count-region (mastodon-tl--find-property-range 'toot-post-counter + (point-min))) + (vis-region (mastodon-tl--find-property-range + 'toot-post-visibility (point-min))) + (nsfw-region (mastodon-tl--find-property-range 'toot-post-nsfw-flag + (point-min))) + (cw-region (mastodon-tl--find-property-range 'toot-post-cw-flag + (point-min))) + (lang-region (mastodon-tl--find-property-range 'toot-post-language + (point-min))) + (sched-region (mastodon-tl--find-property-range 'toot-post-scheduled + (point-min))) + (poll-region (mastodon-tl--find-property-range 'toot-post-poll-flag + (point-min))) + (toot-string (buffer-substring-no-properties (cdr header-region) + (point-max)))) + (mastodon-toot--apply-fields-props + count-region + (format "%s/%s chars" + (mastodon-toot--count-toot-chars toot-string) + (number-to-string mastodon-toot--max-toot-chars))) + (mastodon-toot--apply-fields-props + vis-region + (format "%s" + (if (string= "private" mastodon-toot--visibility) + "followers-only" + mastodon-toot--visibility))) + ;; WHEN clauses don't work here, we need "" as display arg: + (mastodon-toot--apply-fields-props + lang-region + (if mastodon-toot--language + (format "Lang: %s ⋅" mastodon-toot--language) + "")) + (mastodon-toot--apply-fields-props + sched-region + (if mastodon-toot--scheduled-for + (format "Scheduled: %s ⋅" + (mastodon-toot--iso-to-human + mastodon-toot--scheduled-for)) + "")) + (mastodon-toot--apply-fields-props + nsfw-region + (if mastodon-toot--content-nsfw + (if mastodon-toot--media-attachments + "NSFW" "NSFW (attachments only)") + "") + 'mastodon-cw-face) + (mastodon-toot--apply-fields-props + poll-region + (if mastodon-toot-poll + "POLL" + "") + 'mastodon-cw-face + (prin1-to-string mastodon-toot-poll)) + (mastodon-toot--apply-fields-props + cw-region + (if (and mastodon-toot--content-warning + (not (string= "" mastodon-toot--content-warning))) + (format "CW: %s" mastodon-toot--content-warning) + " ") ;; hold the blank space + 'mastodon-cw-face)))) + +(defun mastodon-toot--apply-fields-props (region display &optional face help-echo) + "Apply DISPLAY props FACE and HELP-ECHO to REGION, a cons of beg and end." + (add-text-properties (car region) (cdr region) + `(display + ,display + ,@(when face `(face ,face)) + ,@(when help-echo `(help-echo ,help-echo))))) + +(defun mastodon-toot--count-toot-chars (toot-string &optional cw) + "Count the characters in TOOT-STRING. +URLs always = 23, and domain names of handles are not counted. +This is how mastodon does it. +CW is the content warning, which contributes to the character count." + ;; FIXME: URL chars is avail at /api/v1/instance + ;; for masto, it's .statuses.characters_reserved_per_url + (let* ((url-replacement (make-string 23 ?x)) + (count-str (replace-regexp-in-string ; handle @handles + mastodon-toot-handle-regex "\2" + (replace-regexp-in-string ; handle URLs + mastodon-toot-url-regex url-replacement toot-string)))) + (+ (length cw) + (length count-str)))) + + +;;; DRAFTS + +(defun mastodon-toot--save-toot-text (&rest _args) + "Save the current toot text in `mastodon-toot-current-toot-text'. +Added to `after-change-functions' in new toot buffers." + (let ((text (mastodon-toot--remove-docs))) + (unless (string-empty-p text) + (setq mastodon-toot-current-toot-text text)))) + +(defun mastodon-toot--open-draft-toot () + "Prompt for a draft and compose a toot with it." + (interactive) + (if mastodon-toot-draft-toots-list + (let ((text (completing-read "Select draft toot: " + mastodon-toot-draft-toots-list + nil t))) + (if (not (mastodon-toot--compose-buffer-p)) + (mastodon-toot--compose-buffer nil nil nil text) + (when (and (not (mastodon-toot--empty-p :text-only)) + (y-or-n-p "Replace current text with draft?")) + (cl-pushnew mastodon-toot-current-toot-text + mastodon-toot-draft-toots-list) + (goto-char + (cdr (mastodon-tl--find-property-range 'toot-post-header + (point-min)))) + (kill-region (point) (point-max)) + ;; to not save to kill-ring: + ;; (delete-region (point) (point-max)) + (insert text)))) + (unless (mastodon-toot--compose-buffer-p) + (mastodon-toot--compose-buffer)) + (message "No drafts available."))) + +(defun mastodon-toot--delete-draft-toot () + "Prompt for a draft toot and delete it." + (interactive) + (if (not mastodon-toot-draft-toots-list) + (user-error "No drafts to delete") + (let ((draft (completing-read "Select draft to delete: " + mastodon-toot-draft-toots-list + nil t))) + (setq mastodon-toot-draft-toots-list + (cl-delete draft mastodon-toot-draft-toots-list :test #'equal)) + (message "Draft deleted!")))) + +(defun mastodon-toot--delete-all-drafts () + "Delete all drafts." + (interactive) + (setq mastodon-toot-draft-toots-list nil) + (message "All drafts deleted!")) + + +;;; PROPERTIZE TAGS AND HANDLES + +(defun mastodon-toot--propertize-tags-and-handles (&rest _args) + "Propertize tags and handles in toot compose buffer. +Added to `after-change-functions'." + (when (mastodon-toot--compose-buffer-p) + (let ((header-region (mastodon-tl--find-property-range 'toot-post-header + (point-min))) + (face (when mastodon-toot--proportional-fonts-compose + 'variable-pitch))) + ;; cull any prev props: + ;; stops all text after a handle or mention being propertized: + (set-text-properties (cdr header-region) (point-max) `(face ,face)) + (mastodon-toot--propertize-item mastodon-toot-tag-regex + 'success + (cdr header-region)) + (mastodon-toot--propertize-item mastodon-toot-handle-regex + 'mastodon-display-name-face + (cdr header-region)) + (mastodon-toot--propertize-item mastodon-toot-url-regex + 'link + (cdr header-region))))) + +(defun mastodon-toot--propertize-item (regex face start) + "Propertize item matching REGEX with FACE starting from START." + (save-excursion + (goto-char start) + (cl-loop while (search-forward-regexp regex nil :noerror) + do (add-text-properties (match-beginning 2) + (match-end 2) + `(face ,face))))) + +(defun mastodon-toot--compose-buffer-p () + "Return t if compose buffer is current." + (or (mastodon-tl--buffer-type-eq 'edit-toot) + (mastodon-tl--buffer-type-eq 'new-toot))) + +(defun mastodon-toot--fill-reply-in-compose () + "Fill reply text in compose buffer to the width of the divider." + (save-excursion + (save-match-data + (let* ((fill-column 67)) + (goto-char (point-min)) + (when-let ((prop (text-property-search-forward 'toot-reply))) + (fill-region (prop-match-beginning prop) + (point))))))) + + +;;; COMPOSE BUFFER FUNCTION + +(defun mastodon-toot--compose-buffer + (&optional reply-to-user reply-to-id reply-json initial-text edit) + "Create a new buffer to capture text for a new toot. +If REPLY-TO-USER is provided, inject their handle into the message. +If REPLY-TO-ID is provided, set the `mastodon-toot--reply-to-id' var. +REPLY-JSON is the full JSON of the toot being replied to. +INITIAL-TEXT is used by `mastodon-toot-insert-draft-toot' to add +a draft into the buffer. +EDIT means we are editing an existing toot, not composing a new one." + (let* ((buffer-name (if edit "*edit toot*" "*new toot*")) + (buffer-exists (get-buffer buffer-name)) + (buffer (if (not buffer-exists) + (get-buffer-create buffer-name) + ;; if a user hits reply while a compose buffer is already + ;; open, we really ought to wipe it all and start over. + (switch-to-buffer-other-window buffer-exists) + (if (not (y-or-n-p "Overwrite existing compose buffer?")) + (user-error "Aborting") + (kill-buffer-and-window) + (get-buffer-create buffer-name)))) + (inhibit-read-only t) + (reply-text (alist-get 'content + (or (alist-get 'reblog reply-json) + reply-json))) + (previous-window-config (list (current-window-configuration) + (point-marker)))) + (switch-to-buffer-other-window buffer) + (text-mode) + (mastodon-toot-mode t) + ;; set visibility: + (setq mastodon-toot--visibility + (or (plist-get mastodon-profile-account-settings 'privacy) + ;; use toot visibility setting from the server: + (mastodon-profile--get-source-value 'privacy) + "public")) ; fallback + ;; default language: + ;; NB: this is not necessarily set in + ;; `mastodon-profile-credential-account' nor in + ;; `mastodon-profile-account-settings'! + (setq mastodon-toot--language + (mastodon-profile--get-preferences-pref 'posting:default:language)) + ;; display original toot: + (if mastodon-toot-display-orig-in-reply-buffer + (progn + (mastodon-toot--display-docs-and-status-fields reply-text) + (mastodon-toot--fill-reply-in-compose)) + (mastodon-toot--display-docs-and-status-fields)) + ;; `reply-to-user' (alone) is also used by `mastodon-tl--dm-user', so + ;; perhaps we should not always call --setup-as-reply, or make its + ;; workings conditional on reply-to-id. currently it only checks for + ;; reply-to-user. + (mastodon-toot--setup-as-reply reply-to-user reply-to-id reply-json + ;; only initial-text if reply (not edit): + (when reply-json initial-text)) + (unless mastodon-toot--max-toot-chars + ;; no need to fetch from `mastodon-profile-account-settings' as + ;; `mastodon-toot--max-toot-chars' is set when we set it + (mastodon-toot--get-max-toot-chars)) + ;; set up completion: + (setq-local completion-ignore-case t) + (when mastodon-toot--enable-completion + (set (make-local-variable 'completion-at-point-functions) + (add-to-list 'completion-at-point-functions + #'mastodon-toot--mentions-capf)) + (add-to-list 'completion-at-point-functions + #'mastodon-toot--tags-capf) + (add-to-list 'completion-at-point-functions + #'mastodon-toot--emoji-capf) + ;; company + (when (and mastodon-toot--use-company-for-completion + (require 'company nil :no-error)) + (declare-function company-mode-on "company") + (set (make-local-variable 'company-backends) + (add-to-list 'company-backends 'company-capf)) + (company-mode-on))) + ;; after-change: + (make-local-variable 'after-change-functions) + (cl-pushnew #'mastodon-toot--save-toot-text after-change-functions) + (cl-pushnew #'mastodon-toot--update-status-fields after-change-functions) + (mastodon-toot--update-status-fields) + (cl-pushnew #'mastodon-toot--propertize-tags-and-handles after-change-functions) + (mastodon-toot--propertize-tags-and-handles) + (mastodon-toot--refresh-attachments-display) + ;; draft toot text saving: + (setq mastodon-toot-current-toot-text nil) + ;; if we set this before changing modes, it gets nuked: + (setq mastodon-toot-previous-window-config previous-window-config) + (when mastodon-toot--proportional-fonts-compose + (facemenu-set-face 'variable-pitch)) + (when (and mastodon-use-emojify + ;; emojify loaded but poss not enabled in our buffer: + (boundp 'emojify-mode)) + (emojify-mode)) + (when (and initial-text + (not reply-json)) + (insert initial-text)))) + +;; flyspell ignore masto toot regexes: +(defvar flyspell-generic-check-word-predicate) + +(defun mastodon-toot-mode-flyspell-verify () + "A predicate function for `flyspell'. +Only text that is not one of these faces will be spell-checked." + (let ((faces '(mastodon-display-name-face + mastodon-toot-docs-face font-lock-comment-face + success link))) + (unless (eql (point) (point-min)) + ;; (point) is next char after the word. Must check one char before. + (let ((f (get-text-property (1- (point)) 'face))) + (not (memq f faces)))))) + +(defun mastodon-toot-mode-hook-fun () + "Function for code to run in `mastodon-toot-mode-hook'." + ;; disable auto-fill-mode: + (auto-fill-mode -1) + ;; add flyspell predicate function: + (setq flyspell-generic-check-word-predicate + #'mastodon-toot-mode-flyspell-verify)) + +(add-hook 'mastodon-toot-mode-hook #'mastodon-toot-mode-hook-fun) + +;;;###autoload +(add-hook 'mastodon-toot-mode-hook + #'mastodon-profile--fetch-server-account-settings-maybe) + + +(define-minor-mode mastodon-toot-mode + "Minor mode for composing toots." + :keymap mastodon-toot-mode-map + :global nil) + +(provide 'mastodon-toot) +;;; mastodon-toot.el ends here diff --git a/elpa/mastodon-20241202.1839/mastodon-transient.el b/elpa/mastodon-20241202.1839/mastodon-transient.el new file mode 100644 index 00000000..3e8ba5f8 --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-transient.el @@ -0,0 +1,433 @@ +;;; mastodon-transient.el --- transient menus for mastodon.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2024 martian hiatus + +;; Author: martian hiatus +;; Keywords: convenience + +;; 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 . + +;;; Commentary: + +;; + +;;; Code: + +(require 'tp) +(require 'transient) + +(defvar mastodon-active-user) +(defvar mastodon-toot-visibility-settings-list) +(defvar mastodon-iso-639-regional) +(defvar mastodon-toot-poll) + +(autoload 'mastodon-toot-visibility-settings-list "mastodon-toot") +(autoload 'mastodon-http--get-json "mastodon-http") +(autoload 'mastodon-http--api "mastodon-http") +(autoload 'mastodon-http--triage "mastodon-http") +(autoload 'mastodon-http--patch "mastodon-http") +(autoload 'mastodon-profile--update-user-profile-note "mastodon-profile") +(autoload 'mastodon-toot--fetch-max-poll-options "mastodon-toot") +(autoload 'mastodon-toot--fetch-max-poll-option-chars "mastodon-toot") +(autoload 'mastodon-instance-data "mastodon") +(autoload 'mastodon-toot--update-status-fields "mastodon-toot") +(autoload 'mastodon-toot--read-poll-expiry "mastodon-toot") +(autoload 'mastodon-toot--poll-expiry-options-alist "mastodon-toot") +(autoload 'mastodon-toot--clear-poll "mastodon-toot") + +;;; UTILS + +(transient-define-suffix mastodon-transient--prefix-inspect () + "Inspect a transient prefix's arguments and scope." + (interactive) + :transient 'transient--do-return + (let ((args (transient-args (oref transient-current-prefix command))) + (scope (oref transient-current-prefix scope))) + (message "prefix's scope: %s \ntransient-args: %s\n last: %s" + scope args + (length + (cl-member-if + (lambda (x) + (equal (car x) 'one)) + args))))) + +;; some JSON fields that are returned under the "source" field need to be +;; sent back in the format source[key], while some others are sent kust as +;; key: +(defun mastodon-transient-parse-source-key (key) + "Parse mastodon source KEY. +If KEY needs to be source[key], format like so, else just return +the inner key part." + (let* ((split (split-string key "[][]")) + (array-key (cadr split))) + (if (or (= 1 (length split)) ;; no split + (member array-key '("privacy" "sensitive" "language"))) + key + array-key))) + +(defun mastodon-transient-parse-source-keys (alist) + "Parse ALIST containing source[key] keys." + (cl-loop for a in alist + collect (cons (mastodon-transient-parse-source-key (car a)) + (cdr a)))) + +(defun mastodon-transient-get-creds () + "Fetch account data." + (mastodon-http--get-json + (mastodon-http--api "accounts/verify_credentials") + nil :silent)) + +;; fields utils: +;; to PATCH fields, we just need fields[x][name] and fields[x][value] + +(defun mastodon-transient--fields-alist (fields) + "Convert fields in FIELDS to numbered conses. +The keys in the data are not numbered, so we convert the key into +the format fields.X.keyname." + (cl-loop + for f in fields + for count from 1 to 5 + collect + (cl-loop for x in f + collect + (cons (concat "fields." (number-to-string count) + "." (symbol-name (car x))) + (cdr x))))) + +(defun mastodon-transient-field-dot-to-array (key) + "Convert KEY from tp dot annotation to array[key] annotation." + (tp-dot-to-array (symbol-name key) nil "_attributes")) + +(defun mastodon-transient-dot-fields-to-arrays (alist) + "Parse fields ALIST in dot notation to array notation." + (cl-loop for y in alist + collect + (cons (mastodon-transient-field-dot-to-array (car y)) + (cdr y)))) + +;;; TRANSIENTS + +;; FIXME: PATCHing source vals as JSON request body doesn't work! existing +;; `mastodon-profile--update-preference' doesn't use it! it just uses +;; query params! strange thing is it works for non-source params +(transient-define-suffix mastodon-user-settings-update (&optional args) + "Update current user settings on the server." + :transient 'transient--do-exit + (interactive (list (transient-args 'mastodon-user-settings))) + (let* ((parsed (tp-parse-args-for-send args :strings)) + (strs (mastodon-transient-parse-source-keys parsed)) + (url (mastodon-http--api "accounts/update_credentials")) + (resp (mastodon-http--patch url strs))) ;; :json fails + (mastodon-http--triage + resp + (lambda (_) + (message "Settings updated!\n%s" (pp-to-string strs)))))) + +(transient-define-prefix mastodon-user-settings () + "A transient for setting current user settings." + :value (lambda () (tp-return-data + #'mastodon-transient-get-creds)) + [:description + (lambda () + (format "User settings for %s" mastodon-active-user)) + (:info + "Note: use the empty string (\"\") to remove a value from an option.")] + ;; strings + ["Account info" + ("n" "display name" "display_name" :alist-key display_name :class tp-option-str) + ("t" "update profile note" mastodon-update-profile-note) + ("f" "update profile fields" mastodon-profile-fields)] + ;; "choice" booleans (so we can PATCH :json-false explicitly): + ["Account options" + ("l" "locked" "locked" :alist-key locked :class tp-bool) + ("b" "bot" "bot" :alist-key bot :class tp-bool) + ("d" "discoverable" "discoverable" :alist-key discoverable :class tp-bool) + ("c" "hide follower/following lists" "source.hide_collections" + :alist-key source.hide_collections :class tp-bool) + ("i" "indexable" "source.indexable" :alist-key source.indexable :class tp-bool) + ] + ["Tooting options" + ("p" "default privacy" "source.privacy" :alist-key source.privacy + :class tp-option + :choices (lambda () mastodon-toot-visibility-settings-list)) + ("s" "mark sensitive" "source.sensitive" :alist-key source.sensitive :class tp-bool) + ("g" "default language" "source.language" :alist-key source.language :class tp-option + :choices (lambda () mastodon-iso-639-regional)) + ] + ["Update" + ("C-c C-c" "Save settings" mastodon-user-settings-update) + ("C-c C-k" :info "Revert all changes")] + (interactive) + (if (or (not (boundp 'mastodon-active-user)) + (not mastodon-active-user)) + (user-error "User not set") + (transient-setup 'mastodon-user-settings))) + +(transient-define-suffix mastodon-update-profile-note () + "Update current user profile note." + :transient 'transient--do-exit + (interactive) + (mastodon-profile--update-user-profile-note)) + +(transient-define-suffix mastodon-profile-fields-update (args) + "Update current user profile fields." + :transient 'transient--do-return + (interactive (list (transient-args 'mastodon-profile-fields))) + (let* (;; FIXME: maybe only changed also won't work with fields, as + ;; perhaps what is PATCHed overwrites whatever is on the server? + ;; (only-changed (tp-only-changed-args alist)) + (arrays (mastodon-transient-dot-fields-to-arrays args)) + (endpoint "accounts/update_credentials") + (url (mastodon-http--api endpoint)) + (resp (mastodon-http--patch url arrays))) ; :json))) + (mastodon-http--triage + resp (lambda (_) (message "Fields updated!"))))) + +(defun mastodon-transient-fetch-fields () + "Fetch profile fields (metadata)." + (tp-return-data #'mastodon-transient-get-creds nil 'fields) + (setq tp-transient-settings + (mastodon-transient--fields-alist tp-transient-settings))) + +(transient-define-prefix mastodon-profile-fields () + "A transient for setting profile fields." + :value (lambda () (mastodon-transient-fetch-fields)) + [:description + "Fields" + ["Name" + ("1 n" "" "fields.1.name" :alist-key fields.1.name :class mastodon-transient-field) + ("2 n" "" "fields.2.name" :alist-key fields.2.name :class mastodon-transient-field) + ("3 n" "" "fields.3.name" :alist-key fields.3.name :class mastodon-transient-field) + ("4 n" "" "fields.4.name" :alist-key fields.4.name :class mastodon-transient-field)] + ["Value" + ("1 v" "" "fields.1.value" :alist-key fields.1.value :class mastodon-transient-field) + ("2 v" "" "fields.2.value" :alist-key fields.2.value :class mastodon-transient-field) + ("3 v" "" "fields.3.value" :alist-key fields.3.value :class mastodon-transient-field) + ("4 v" "" "fields.4.value" :alist-key fields.4.value :class mastodon-transient-field)]] + ["Update" + ("C-c C-c" "Save settings" mastodon-profile-fields-update) + ("C-c C-k" :info "Revert all changes")] + (interactive) + (if (not mastodon-active-user) + (user-error "User not set") + (transient-setup 'mastodon-profile-fields))) + +(defun mastodon-transient-max-poll-opts () + "Return max poll options of user's instance." + (let ((instance (mastodon-instance-data))) + (mastodon-toot--fetch-max-poll-options instance))) + +(defun mastodon-transient-max-poll-opt-chars () + "Return max poll option characters of user's instance." + (let ((instance (mastodon-instance-data))) + (mastodon-toot--fetch-max-poll-option-chars instance))) + +(transient-define-suffix mastodon-transient--choice-add () + "Add another poll choice if possible. +Do not add more than 9 choices. +Do not add more than the server's maximum setting." + (interactive) + :transient 'transient--do-stay + (let* ((args (transient-args (oref transient-current-prefix command))) + (choice-count (length + (cl-member-if + (lambda (x) + (equal (car x) 'one)) + args))) + (inc (1+ choice-count)) + (next (number-to-string inc)) + (next-symbol (pcase inc + (5 'five) + (6 'six) + (7 'seven) + (8 'eight) + (9 'nine)))) + (if (or (>= choice-count (mastodon-transient-max-poll-opts)) + (= choice-count 9)) + ;; FIXME when we hit '10', we get a binding clash with '1'. :/ + (message "Max choices reached") + (transient-append-suffix + 'mastodon-create-poll + '(2 -1) + `(,next "" ,next + :class mastodon-transient-poll-choice + :alist-key ,next-symbol + :transient t)))) + (transient-setup 'mastodon-create-poll)) + +(transient-define-prefix mastodon-create-poll () + "A transient for creating a poll." + :value (lambda () + ;; we set `tp-transient-settings' here to the poll value poss + ;; pulled from the server by + ;; `mastodon-toot--server-poll-to-local'. when we are done with + ;; the transient, we set `mastodon-toot-poll' again + (setq tp-transient-settings mastodon-toot-poll)) + ["Create poll" + (:info (lambda () + (format "Max options: %s" + (mastodon-transient-max-poll-opts)))) + (:info (lambda () + (format "Max option length: %s" + (mastodon-transient-max-poll-opt-chars))))] + ["Options" + ("m" "Multiple choice?" "multi" :alist-key multi + :class mastodon-transient-poll-bool) + ("h" "Hide vote count till expiry?" "hide" :alist-key hide + :class mastodon-transient-poll-bool) + ("e" "Expiry" "expiry" :alist-key expiry + :class mastodon-transient-expiry)] + ["Choices" + ("1" "" "1" :alist-key one :class mastodon-transient-poll-choice) + ("2" "" "2" :alist-key two :class mastodon-transient-poll-choice) + ("3" "" "3" :alist-key three :class mastodon-transient-poll-choice) + ("4" "" "4" :alist-key four :class mastodon-transient-poll-choice)] + ;; TODO: display the max number of options or add options cmd + ["Update" + ("C-c C-s" "Add another poll choice" mastodon-transient--choice-add + :if (lambda () (< 4 (mastodon-transient-max-poll-opts)))) + ("C-c C-c" "Save and done" mastodon-create-poll-done) + ("C-x C-k" :info "Revert all") + ("C-c C-k" "Delete all" mastodon-clear-poll)] + (interactive) + (if (not mastodon-active-user) + (user-error "User not set") + (transient-setup 'mastodon-create-poll))) + +(transient-define-suffix mastodon-clear-poll () + "Clear current poll data." + :transient 'transient--do-stay + (interactive) + (mastodon-toot--clear-poll :transient) + (transient-reset)) + +(transient-define-suffix mastodon-create-poll-done (args) + "Finish setting poll details." + :transient 'transient--do-exit + (interactive (list (transient-args 'mastodon-create-poll))) + (let* ((options (cl-member-if (lambda (x) + (eq (car x) 'one)) + args)) + (opt-vals (cl-loop for x in options + collect (cdr x))) + (lengths (mapcar #'length opt-vals)) + (vals (cl-remove 'nil + (cl-loop for x in args + collect (cdr x)))) + (opts-count (length (cl-remove 'nil opt-vals)))) + ;; this way of checking gets annoying if we want to just cancel out of + ;; the poll (but to actually cancel user should C-g, not C-c C-c): + (if (or (and (< 50 (apply #'max lengths)) + (not (y-or-n-p "Options longer than server max. Proceed? "))) + (and (not (alist-get 'expiry args)) + (not (y-or-n-p "No expiry. Proceed? "))) + (and (not (< 1 opts-count)) + (not (y-or-n-p "Need more than one option. Proceed? "))) + (and (> opts-count (mastodon-transient-max-poll-opts)) + (not (y-or-n-p "More options than server max. Proceed? ")))) + (call-interactively #'mastodon-create-poll) + ;; if we are called with no poll data, do not set: + (unless (not vals) + ;; we set `mastodon-toot-poll' here not `tp-transient-settings' + ;; as that is our var outside of our transient: + (setq mastodon-toot-poll + (tp-bools-to-strs args))) + (mastodon-toot--update-status-fields)))) + +;;; CLASSES + +(defclass mastodon-transient-field (tp-option-str) + ((always-read :initarg :always-read :initform t)) + "An infix option class for our options. +We always read.") + +(cl-defmethod transient-init-value ((obj mastodon-transient-field)) + "Initialize value of OBJ." + (let* ((prefix-val (oref transient--prefix value))) + ;; (arg (oref obj alist-key))) + (oset obj value + (tp-get-server-val obj prefix-val)))) + +(cl-defmethod tp-get-server-val ((obj mastodon-transient-field) data) + "Return the server value for OBJ from DATA. +If OBJ's key has dotted notation, drill down into the alist. Currently +only one level of nesting is supported." + ;; TODO: handle nested alist keys + (let* ((key (oref obj alist-key)) + (split (split-string (symbol-name key) "\\.")) + (num (string-to-number (cadr split)))) + (alist-get key + (nth (1- num) data) nil nil #'string=))) + +(cl-defmethod tp-arg-changed-p ((_obj mastodon-transient-field) cons) + "T if value of OBJ is changed from the server value. +CONS is a cons of the form \"(fields.1.name . val)\"." + (let* ((key-split (split-string + (symbol-name (car cons)) "\\.")) + (num (1- (string-to-number (nth 1 key-split)))) + (server-key (symbol-name (car cons))) + (server-elt (nth num tp-transient-settings))) + (not (equal (cdr cons) + (alist-get server-key server-elt nil nil #'string=))))) + +(defclass mastodon-transient-opt (tp-option tp-option-var) + (())) + +(defclass mastodon-transient-poll-bool (tp-bool tp-option-var) + ()) + +(defclass mastodon-transient-poll-choice (tp-option-str tp-option-var) + ()) + +(cl-defmethod transient-infix-read ((obj mastodon-transient-poll-choice)) + "Reader function for OBJ, a poll expiry." + (let* ((value (transient-infix-value obj)) + (prompt (transient-prompt obj)) + (str (read-string prompt (cdr value))) + (max (mastodon-transient-max-poll-opt-chars))) + (if (not (> (length str) max)) + str + (if (not + (y-or-n-p + (format "Poll option too long for server (%s/%s chars), retry?" + (length str) max))) + str + (oset obj value str) + (transient-infix-read obj))))) + +(defclass mastodon-transient-expiry (tp-option tp-option-var) + ()) + +(cl-defmethod transient-infix-read ((_obj mastodon-transient-expiry)) + "Reader function for OBJ, a poll expiry." + (cdr (mastodon-toot--read-poll-expiry))) + +(cl-defmethod transient-format-value ((obj mastodon-transient-expiry)) + "Format function for OBJ, a poll expiry." + (let* ((cons (transient-infix-value obj)) + (value (when cons (cdr cons)))) + (if (not value) + "" + (let ((readable + (or (car + (rassoc value + (mastodon-toot--poll-expiry-options-alist))) + (concat value " secs")))) ;; editing a poll wont match expiry list + (propertize readable + 'face (if (tp-arg-changed-p obj cons) + 'transient-value + 'transient-inactive-value)))))) + +(provide 'mastodon-transient) +;;; mastodon-transient.el ends here diff --git a/elpa/mastodon-20241202.1839/mastodon-views.el b/elpa/mastodon-20241202.1839/mastodon-views.el new file mode 100644 index 00000000..8d356fb1 --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-views.el @@ -0,0 +1,1063 @@ +;;; mastodon-views.el --- Minor views functions for mastodon.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2024 Marty Hiatt +;; Author: Marty Hiatt +;; Maintainer: Marty Hiatt +;; Homepage: https://codeberg.org/martianh/mastodon.el + +;; This file is not part of GNU Emacs. + +;; This file is part of mastodon.el. + +;; mastodon.el 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. + +;; mastodon.el 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 mastodon.el. If not, see . + +;;; Commentary: + +;; mastodon-views.el provides minor views functions. + +;; These are currently lists, follow suggestions, filters, scheduled toots, +;; follow requests, and instance descriptions. + +;; It doesn't include favourites, bookmarks, preferences, trending tags, followed tags, toot edits, + +;;; Code: + +(require 'cl-lib) +(require 'mastodon-http) +(eval-when-compile + (require 'mastodon-tl)) + +(defvar mastodon-mode-map) +(defvar mastodon-tl--horiz-bar) +(defvar mastodon-tl--timeline-posts-count) + +(autoload 'mastodon-mode "mastodon") +(autoload 'mastodon-tl--init "mastodon-tl") +(autoload 'mastodon-tl--init-sync "mastodon-tl") +(autoload 'mastodon-tl--field "mastodon-tl") +(autoload 'mastodon-tl--property "mastodon-tl") +(autoload 'mastodon-tl--set-face "mastodon-tl") +(autoload 'mastodon-tl--buffer-type-eq "mastodon-tl") +(autoload 'mastodon-tl--profile-buffer-p "mastodon-tl") +(autoload 'mastodon-tl--goto-first-item "mastodon-tl") +(autoload 'mastodon-tl--do-if-item "mastodon-tl") +(autoload 'mastodon-tl--set-buffer-spec "mastodon-tl") +(autoload 'mastodon-tl--render-text "mastodon-tl") +(autoload 'mastodon-notifications--follow-request-accept "mastodon-notifications") +(autoload 'mastodon-notifications--follow-request-reject "mastodon-notifications") +(autoload 'mastodon-auth--get-account-id "mastodon-auth") +(autoload 'mastodon-toot--iso-to-human "mastodon-toot") +(autoload 'mastodon-toot--schedule-toot "mastodon-toot") +(autoload 'mastodon-toot--compose-buffer "mastodon-toot") +(autoload 'mastodon-toot--set-toot-properties "mastodon-toot") +(autoload 'mastodon-search--propertize-user "mastodon-search") +(autoload 'mastodon-search--insert-users-propertized "mastodon-search") +(autoload 'mastodon-tl--map-alist "mastodon-tl") +(autoload 'mastodon-tl--map-alist-vals-to-alist "mastodon-tl") + + +;;; KEYMAPS + +;; we copy `mastodon-mode-map', as then all timeline functions are +;; available. this is helpful because if a minor view is the only buffer left +;; open, calling `mastodon' will switch to it, but then we will be unable to +;; switch to timlines without closing the minor view. + +;; copying the mode map however means we need to avoid/unbind/override any +;; 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. + +(defvar mastodon-views-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map mastodon-mode-map) + map) + "Base keymap for minor mastodon views.") + +(defvar mastodon-views--view-filters-keymap + (let ((map (make-sparse-keymap))) + (set-keymap-parent map mastodon-views-map) + (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.") + +(defvar mastodon-views--follow-suggestions-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map mastodon-views-map) + (define-key map (kbd "g") #'mastodon-views--view-follow-suggestions) + map) + "Keymap for viewing follow suggestions.") + +(defvar mastodon-views--view-lists-keymap + (let ((map (make-sparse-keymap))) + (set-keymap-parent map mastodon-views-map) + (define-key map (kbd "D") #'mastodon-views--delete-list) + (define-key map (kbd "C") #'mastodon-views--create-list) + (define-key map (kbd "A") #'mastodon-views--add-account-to-list) + (define-key map (kbd "R") #'mastodon-views--remove-account-from-list) + (define-key map (kbd "E") #'mastodon-views--edit-list) + (define-key map (kbd "g") #'mastodon-views--view-lists) + map) + "Keymap for viewing lists.") + +(defvar mastodon-views--list-name-keymap + (let ((map (make-sparse-keymap))) + (define-key map (kbd "RET") #'mastodon-views--view-timeline-list-at-point) + (define-key map (kbd "d") #'mastodon-views--delete-list-at-point) + (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.") + +(defvar mastodon-views--scheduled-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map mastodon-views-map) + (define-key map (kbd "r") #'mastodon-views--reschedule-toot) + (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.") + +(defvar mastodon-views--view-follow-requests-keymap + (let ((map (make-sparse-keymap))) + (set-keymap-parent map mastodon-views-map) + ;; make reject binding match the binding in notifs view + ;; 'r' is then reserved for replying, even tho it is not avail + ;; in foll-reqs view + (define-key map (kbd "j") #'mastodon-notifications--follow-request-reject) + (define-key map (kbd "a") #'mastodon-notifications--follow-request-accept) + (define-key map (kbd "g") #'mastodon-views--view-follow-requests) + map) + "Keymap for viewing follow requests.") + + +;;; GENERAL FUNCTION + +(defun mastodon-views--minor-view (view-name insert-fun data) + "Load a minor view named VIEW-NAME. +BINDINGS-STRING is a string explaining the view's local bindings. +INSERT-FUN is the function to call to insert the view's elements. +DATA is the argument to insert-fun, usually JSON returned in a +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 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) + 'face 'font-lock-comment-face + 'byline t + 'item-type 'no-item ; for nav + 'item-id "0")) ; so point can move here when no item + (funcall insert-fun data) + (goto-char (point-min))) + ;; (when data + ;; FIXME: this seems to trigger a new request, but ideally would run. + ;; (mastodon-tl--goto-next-item)) + ) + + +;;; LISTS + +(defun mastodon-views--view-lists () + "Show the user's lists in a new buffer." + (interactive) + (mastodon-tl--init-sync "lists" "lists" + 'mastodon-views--insert-lists + nil nil nil + "your lists" + "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") + (with-current-buffer "*mastodon-lists*" + (use-local-map mastodon-views--view-lists-keymap))) + +(defun mastodon-views--insert-lists (json) + "Insert the user's lists from JSON." + (mastodon-views--minor-view + "lists" + #'mastodon-views--print-list-set + json)) + +(defun mastodon-views--print-list-set (lists) + "Print each account plus a separator for each list in LISTS." + (mapc (lambda (x) + (mastodon-views--print-list-accounts x) + (insert (propertize (concat " " mastodon-tl--horiz-bar "\n\n") + 'face 'success))) + lists)) + +(defun mastodon-views--print-list-accounts (list) + "Insert the accounts in list named LIST, an alist." + (let-alist list + (let* ((accounts (mastodon-views--accounts-in-list .id))) + (insert + (propertize .title + 'byline t ; so we nav here + 'item-id "0" ; so we nav here + 'item-type 'list + '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-views--list-name-keymap + 'list-name .title + 'list-id .id) + (propertize (format " [replies: %s, exclusive %s]" + .replies_policy + (when (eq t .exclusive) "true")) + 'face 'font-lock-comment-face) + (propertize "\n\n" + 'list t + 'keymap mastodon-views--list-name-keymap + 'list-name .title + 'list-id .id) + (propertize + (mapconcat #'mastodon-search--propertize-user accounts + " ") + 'list t + 'keymap mastodon-views--list-name-keymap + 'list-name .title + 'list-id .id))))) + +(defun mastodon-views--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-views--get-lists-names () + "Return a list of the user's lists' names." + (let ((lists (mastodon-views--get-users-lists))) + (mastodon-tl--map-alist 'title lists))) + +(defun mastodon-views--get-list-by-name (name) + "Return the list data for list with NAME." + (let* ((lists (mastodon-views--get-users-lists))) + (cl-loop for list in lists + if (string= (alist-get 'title list) name) + return list))) + +(defun mastodon-views--get-list-id (name) + "Return id for list with NAME." + (let ((list (mastodon-views--get-list-by-name name))) + (alist-get 'id list))) + +(defun mastodon-views--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-views--edit-list-at-point () + "Edit list at point." + (interactive) + (let ((id (mastodon-tl--property 'list-id :no-move))) + (mastodon-views--edit-list id))) + +(defun mastodon-views--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-views--get-lists-names))) + (name-old (if id + (mastodon-tl--property 'list-name :no-move) + (completing-read "Edit list: " list-names))) + (id (or id (mastodon-views--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")) + (exclusive (if (y-or-n-p "Exclude items from home timeline? ") + "true" + "false")) + (url (mastodon-http--api (format "lists/%s" id))) + (response (mastodon-http--put url + `(("title" . ,name-choice) + ("replies_policy" . ,replies-policy) + ("exclusive" . ,exclusive))))) + (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-views--view-lists)))))) + +(defun mastodon-views--view-timeline-list-at-point () + "View timeline of list at point." + (interactive) + (let ((list-id (mastodon-tl--property 'list-id :no-move))) + (mastodon-views--view-list-timeline list-id))) + +(defun mastodon-views--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-views--get-lists-names))) + (list-name (unless id (completing-read "View list: " list-names))) + (id (or id (mastodon-views--get-list-id list-name))) + (endpoint (format "timelines/list/%s" id)) + (name (mastodon-views--get-list-name id)) + (buffer-name (format "list-%s" name))) + (mastodon-tl--init buffer-name endpoint + 'mastodon-tl--timeline nil + `(("limit" . ,mastodon-tl--timeline-posts-count))))) + +(defun mastodon-views--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 + (exclusive (when (y-or-n-p "Exclude items from home timeline? ") + "true")) + (response (mastodon-http--post (mastodon-http--api "lists") + `(("title" . ,title) + ("replies_policy" . ,replies-policy) + ("exclusive" . ,exclusive))))) + (mastodon-views--list-action-triage + response "list %s created!" title))) + +(defun mastodon-views--delete-list-at-point () + "Delete list at point." + (interactive) + (let ((id (mastodon-tl--property 'list-id :no-move))) + (mastodon-views--delete-list id))) + +(defun mastodon-views--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-views--get-lists-names))) + (name (if id + (mastodon-views--get-list-name id) + (completing-read "Delete list: " list-names))) + (id (or id (mastodon-views--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-views--list-action-triage + response "list %s deleted!" name))))) + +(defun mastodon-views--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-views--add-account-to-list-at-point () + "Prompt for account and add to list at point." + (interactive) + (let ((id (mastodon-tl--property 'list-id :no-move))) + (mastodon-views--add-account-to-list id))) + +(defun mastodon-views--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 + (mastodon-tl--property 'list-name :no-move) + (completing-read list-prompt + (mastodon-views--get-lists-names) nil t))) + (list-id (or id (mastodon-views--get-list-id list-name))) + (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))) + (url (mastodon-http--api (format "lists/%s/accounts" list-id))) + (response (mastodon-http--post url `(("account_ids[]" . ,account-id))))) + (mastodon-views--list-action-triage + response "%s added to list %s!" account list-name))) + +(defun mastodon-views--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 'item-json)) + (account (mastodon-tl--field 'account toot)) + (account-id (mastodon-tl--field 'id account)) + (handle (mastodon-tl--field 'acct account))) + (mastodon-views--add-account-to-list nil account-id handle))) + +(defun mastodon-views--remove-account-from-list-at-point () + "Prompt for account and remove from list at point." + (interactive) + (let ((id (mastodon-tl--property 'list-id :no-move))) + (mastodon-views--remove-account-from-list id))) + +(defun mastodon-views--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 + (mastodon-tl--property 'list-name :no-move) + (completing-read "Remove account from list: " + (mastodon-views--get-lists-names) nil t))) + (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-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))) + (response (mastodon-http--delete url args))) + (mastodon-views--list-action-triage + response "%s removed from list %s!" account list-name))) + +(defun mastodon-views--list-action-triage (response &rest args) + "Call `mastodon-http--triage' on RESPONSE and call message on ARGS." + (mastodon-http--triage response + (lambda (_) + (when (mastodon-tl--buffer-type-eq 'lists) + (mastodon-views--view-lists)) + (apply #'message args)))) + +(defun mastodon-views--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))) + + +;;; FOLLOW REQUESTS + +(defun mastodon-views--insert-follow-requests (json) + "Insert the user's current follow requests. +JSON is the data returned by the server." + (mastodon-views--minor-view + "follow requests" + #'mastodon-views--insert-users-propertized-note + json)) + +(defun mastodon-views--view-follow-requests () + "Open a new buffer displaying the user's follow requests." + (interactive) + (mastodon-tl--init-sync "follow-requests" + "follow_requests" + 'mastodon-views--insert-follow-requests + nil + '(("limit" . "40")) ; server max is 80 + :headers + "follow requests" + "a/j - accept/reject request at point\n\ + n/p - go to next/prev request") + (mastodon-tl--goto-first-item) + (with-current-buffer "*mastodon-follow-requests*" + (use-local-map mastodon-views--view-follow-requests-keymap))) + + +;;; SCHEDULED TOOTS + +(defun mastodon-views--view-scheduled-toots () + "Show the user's scheduled toots in a new buffer." + (interactive) + (mastodon-tl--init-sync "scheduled-toots" + "scheduled_statuses" + 'mastodon-views--insert-scheduled-toots + nil nil nil + "your scheduled toots" + "n/p - prev/next\n r - reschedule\n\ + e/RET - edit toot\n c - cancel") + (with-current-buffer "*mastodon-scheduled-toots*" + (use-local-map mastodon-views--scheduled-map))) + +(defun mastodon-views--insert-scheduled-toots (json) + "Insert the user's scheduled toots, from JSON." + (mastodon-views--minor-view + "scheduled toots" + #'mastodon-views--insert-scheduled-toots-list + json)) + +(defun mastodon-views--insert-scheduled-toots-list (scheduleds) + "Insert scheduled toots in SCHEDULEDS." + (mapc #'mastodon-views--insert-scheduled-toot scheduleds)) + +(defun mastodon-views--insert-scheduled-toot (toot) + "Insert scheduled TOOT into the buffer." + (let-alist toot + (insert + (propertize (concat (string-trim .params.text) + " | " + (mastodon-toot--iso-to-human .scheduled_at)) + 'byline t ; so we nav here + 'item-type 'scheduled ; so we nav here + 'face 'font-lock-comment-face + 'keymap mastodon-views--scheduled-map + 'item-json toot + 'id .id) + "\n"))) + +(defun mastodon-views--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-views--reschedule-toot () + "Reschedule the scheduled toot at point." + (interactive) + (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." + (interactive) + (let* ((toot (mastodon-tl--property 'toot :no-move)) + (params (alist-get 'params toot)) + (text (alist-get 'text params))) + (kill-new text))) + +(defun mastodon-views--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) + (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) + (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 + +(defun mastodon-views--view-filters () + "View the user's filters in a new buffer." + (interactive) + (mastodon-tl--init-sync "filters" "filters" + 'mastodon-views--insert-filters + nil nil nil + "current filters" + "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 a filter string plus a blank line. +JSON is the filters data." + (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-alist filter + (insert + ;; 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 (&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\". +Optionally, provide ID, TITLE, CONTEXT, TYPE, and TERMS to update a filter." + (interactive) + ;; 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 + (or context (completing-read-multiple + "Filter contexts [TAB for options, comma separated]: " + mastodon-views--filter-types nil :match))) + (contexts-processed + (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* ((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? " 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 +;; No pagination: max 80 results + +(defun mastodon-views--view-follow-suggestions () + "Display a buffer of suggested accounts to follow." + (interactive) + (mastodon-tl--init-sync "follow-suggestions" + "suggestions" + 'mastodon-views--insert-follow-suggestions + nil + '(("limit" . "80")) ; server max + nil + "suggested accounts") + (with-current-buffer "*mastodon-follow-suggestions*" + (use-local-map mastodon-views--follow-suggestions-map))) + +(defun mastodon-views--insert-follow-suggestions (json) + "Insert follow suggestions into buffer. +JSON is the data returned by the server." + (mastodon-views--minor-view + "suggested accounts" + #'mastodon-views--insert-users-propertized-note + json)) + +(defun mastodon-views--insert-users-propertized-note (json) + "Insert users list into the buffer, including profile note. +JSON is the users list data." + (mastodon-search--insert-users-propertized json :note)) + + +;;; INSTANCES + +(defun mastodon-views--view-own-instance (&optional brief) + "View details of your own instance. +BRIEF means show fewer details." + (interactive) + (mastodon-views--view-instance-description :user brief)) + +(defun mastodon-views--view-own-instance-brief () + "View brief details of your own instance." + (interactive) + (mastodon-views--view-instance-description :user :brief)) + +(defun mastodon-views--view-instance-description-brief () + "View brief details of the instance the current post's author is on." + (interactive) + (mastodon-views--view-instance-description nil :brief)) + +(defun mastodon-views--get-instance-url (url username &optional instance) + "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)) + ;; pleroma URL is https://instance.com/users/username + ((string-suffix-p "users/" (url-basepath url)) + (string-remove-suffix "/users/" + (url-basepath url))) + ;; friendica is https://instance.com/profile/user + ((string-suffix-p "profile/" (url-basepath url)) + (string-remove-suffix "/profile/" + (url-basepath url))) + ;; mastodon is https://instance.com/@user + (t + (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. +USER means to show the instance details for the logged in user. +BRIEF means to show fewer details. +INSTANCE is an instance domain name. +MISSKEY means the instance is a Misskey or derived server." + (interactive) + (if user + (let ((response (mastodon-views--get-own-instance))) + (mastodon-views--instance-response-fun response brief instance)) + (mastodon-tl--do-if-item + (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) + toot)) ; else `toot' is already an account listing. + ;; we may be at toots/boosts/users in a profile buffer. + ;; profile-json is a defacto test for if point is on the profile + ;; details at the top of a profile buffer. + (profile-note-p (and (mastodon-tl--profile-buffer-p) + ;; only call this in profile buffers: + (mastodon-tl--property 'profile-json))) + (url (if profile-note-p + (alist-get 'url toot) ; profile description + (alist-get 'url account))) + (username (if profile-note-p + (alist-get 'username toot) ;; profile + (alist-get 'username account))) + (instance (mastodon-views--get-instance-url url username instance))) + (if misskey + (let* ((params `(("detail" . ,(or brief t)))) + (headers '(("Content-Type" . "application/json"))) + (url (concat instance "/api/meta")) + (response + (with-current-buffer (mastodon-http--post url params headers t :json) + (mastodon-http--process-response)))) + (mastodon-views--instance-response-fun response brief instance :misskey)) + (let ((response (mastodon-http--get-json + (concat instance "/api/v1/instance") nil nil :vector))) + ;; if non-misskey attempt errors, try misskey instance: + ;; akkoma i guess should not error here. + (if (eq 'error (caar response)) + (mastodon-views--instance-desc-misskey) + (mastodon-views--instance-response-fun response brief instance)))))))) + +(defun mastodon-views--instance-desc-misskey (&optional user brief instance) + "Show instance description for a misskey/firefish server. +USER, BRIEF, and INSTANCE are all for +`mastodon-views--view-instance-description', which see." + (interactive) + (mastodon-views--view-instance-description user brief instance :miskey)) + +(defun mastodon-views--instance-response-fun (response brief instance + &optional misskey) + "Display instance description RESPONSE in a new buffer. +BRIEF means to show fewer details. +INSTANCE is the instance were are working with. +MISSKEY means the instance is a Misskey or derived server." + (when response + (let* ((domain (url-file-nondirectory instance)) + (buf (get-buffer-create + (format "*mastodon-instance-%s*" domain)))) + (with-mastodon-buffer buf #'special-mode :other-window + (if misskey + (mastodon-views--insert-json response) + (condition-case nil + (progn + (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-views--print-json-keys response) + (mastodon-tl--set-buffer-spec (buffer-name buf) "instance" nil) + (goto-char (point-min))) + (error ; just insert the raw response: + (mastodon-views--insert-json response)))))))) + +(defun mastodon-views--insert-json (response) + "Insert raw JSON RESPONSE in current buffer." + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (prin1-to-string response)) + (pp-buffer) + (goto-char (point-min)))) + +(defun mastodon-views--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-views--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+ (apply #'max (mapcar #'length cars))))) + (while response + (let ((el (pop response))) + (cond + ((and (vectorp (cdr el)) ; vector of alists (fields, instance rules): + (not (seq-empty-p (cdr el))) + (consp (seq-elt (cdr el) 0))) + (insert (mastodon-views--format-key el pad) + "\n\n") + (seq-do #'mastodon-views--print-instance-rules-or-fields (cdr el)) + (insert "\n")) + ((and (vectorp (cdr el)) ; vector of strings (media types): + (not (seq-empty-p (cdr el))) + (< 1 (seq-length (cdr el))) + (stringp (seq-elt (cdr el) 0))) + (when ind (indent-to ind)) + (insert (mastodon-views--format-key el pad) + "\n" + (seq-mapcat + (lambda (x) (concat x ", ")) + (cdr el) 'string) + "\n\n")) + ((consp (cdr el)) ; basic nesting: + (when ind (indent-to ind)) + (insert (mastodon-views--format-key el pad) + "\n\n") + (mastodon-views--print-json-keys + (cdr el) (if ind (+ ind 4) 4))) + (t ; basic handling of raw booleans: + (let ((val (cond ((eq (cdr el) :json-false) + "no") + ((eq (cdr el) t) + "yes") + (t + (cdr el))))) + (when ind (indent-to ind)) + (insert (mastodon-views--format-key el pad) + " " + (mastodon-views--newline-if-long (cdr el)) + ;; only send strings to --render-text (for hyperlinks): + (mastodon-tl--render-text + (if (stringp val) val (prin1-to-string val))) + "\n")))))))) + +(defun mastodon-views--print-instance-rules-or-fields (alist) + "Print ALIST of instance rules or contact account or emoji fields." + (let-alist alist + (let ((key (or .id .name .shortcode)) + (value (or .text .value .url))) + (indent-to 4) + (insert (format "%-5s: " + (propertize key 'face '(:underline t))) + (mastodon-views--newline-if-long value) + (format "%s" (mastodon-tl--render-text + value)) + "\n")))) + +(defun mastodon-views--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" + ""))) + +(provide 'mastodon-views) +;;; mastodon-views.el ends here diff --git a/elpa/mastodon-20241202.1839/mastodon-widget.el b/elpa/mastodon-20241202.1839/mastodon-widget.el new file mode 100644 index 00000000..e9376d8a --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon-widget.el @@ -0,0 +1,104 @@ +;;; mastodon-widget.el --- Widget utilities -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2024 Marty Hiatt +;; Author: Marty Hiatt +;; Maintainer: Marty Hiatt +;; Homepage: https://codeberg.org/martianh/mastodon.el + +;; This file is not part of GNU Emacs. + +;; This file is part of mastodon.el. + +;; mastodon.el 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. + +;; mastodon.el 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 mastodon.el. If not, see . + +;;; Commentary: + +;; some widget utilities for mastodon.el + +;;; Code: + +(require 'cl-lib) + +(defvar mastodon-widget-keymap + (let ((map (make-sparse-keymap))) + (define-key map [down-mouse-2] 'widget-button-click) + (define-key map [down-mouse-1] 'widget-button-click) + (define-key map [touchscreen-begin] 'widget-button-click) + ;; The following definition needs to avoid using escape sequences that + ;; might get converted to ^M when building loaddefs.el + (define-key map [(control ?m)] 'widget-button-press) + map) + "Keymap containing useful binding for buffers containing widgets. +Recommended as a parent keymap for modes using widgets. +Note that such modes will need to require wid-edit.") + +(defface mastodon-widget-face + '((t :inherit font-lock-function-name-face :weight bold :underline t)) + "Face for widgets." + :group 'mastodon) + +(defun mastodon-widget--return-item-widgets (list) + "Return a list of item widgets for each item, a string, in LIST." + (cl-loop for x in list + collect `(choice-item :value ,x :format "%[%v%] " + :keymap ,mastodon-widget-keymap))) + +(defun mastodon-widget--format (str &optional padding newline) + "Return a widget format string for STR, its name. +PADDING is an integer, for how much right-side padding to add." + (concat "%[" (propertize str + 'face 'mastodon-widget-face + 'mastodon-tab-stop t) + "%]: %v" + (make-string padding ? ) + (if newline "\n" ""))) + +(defun mastodon-widget--create (kind type value notify-fun + &optional newline) + "Return a widget of KIND, with TYPE elements, and default VALUE. +KIND is a string, either Listing, Sort, Items, or Inbox, and will +be used for the widget's tag. +VALUE is a string, a member of TYPE. +NOTIFY-FUN is the widget's notify function." + (let* ((val-length (length (if (symbolp value) + (symbol-name value) + value))) + (type-list (if (symbolp type) + (symbol-value type) + type)) + (longest (apply #'max + (mapcar #'length + (if (symbolp (car type-list)) + (mapcar #'symbol-name type-list) + type-list)))) + (padding (- longest val-length))) + (if (not (member value type-list)) + (user-error "%s is not a member of %s" value type-list) + (widget-create + 'menu-choice + :tag kind + :value value + :args (mastodon-widget--return-item-widgets type-list) + :help-echo (format "Select a %s kind" kind) + :format (mastodon-widget--format kind padding newline) + :notify notify-fun + ;; eg format of notify-fun: + ;; (lambda (widget &rest ignore) + ;; (let ((value (widget-value widget)) + ;; (tag (widget-get widget :tag))) + ;; (notify-fun value))) + :keymap mastodon-widget-keymap)))) + +(provide 'mastodon-widget) +;;; mastodon-widget.el ends here diff --git a/elpa/mastodon-20241202.1839/mastodon.el b/elpa/mastodon-20241202.1839/mastodon.el new file mode 100644 index 00000000..808cc656 --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon.el @@ -0,0 +1,549 @@ +;;; mastodon.el --- Client for fediverse services using the Mastodon API -*- lexical-binding: t -*- + +;; Copyright (C) 2017-2019 Johnson Denen +;; Copyright (C) 2020-2022 Marty Hiatt +;; Copyright (C) 2021 Abhiseck Paira +;; Author: Johnson Denen +;; Marty Hiatt +;; Maintainer: Marty Hiatt +;; Package-Version: 20241202.1839 +;; Package-Revision: 10be1f9c2845 +;; Package-Requires: ((emacs "28.1") (request "0.3.0") (persist "0.4") (tp "0.6")) +;; Homepage: https://codeberg.org/martianh/mastodon.el + +;; This file is not part of GNU Emacs. + +;; This file is part of mastodon.el. + +;; mastodon.el 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. + +;; mastodon.el 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 mastodon.el. If not, see . + +;;; Commentary: + +;; mastodon.el is a client for fediverse services that implement the Mastodon +;; API. See . + +;; For set up and usage details, see the Info documentation, or the readme +;; file at . + +;;; Code: +(require 'cl-lib) ; for `cl-some' call in mastodon +(eval-when-compile (require 'subr-x)) +(require 'url) +(require 'thingatpt) +(require 'shr) + +(require 'mastodon-http) +(require 'mastodon-toot) +(require 'mastodon-search) +(require 'mastodon-transient) + +(declare-function discover-add-context-menu "discover") +(declare-function emojify-mode "emojify") +(declare-function request "request") + +(autoload 'mastodon-auth--get-account-name "mastodon-auth") +(autoload 'mastodon-auth--user-acct "mastodon-auth") +(autoload 'mastodon-discover "mastodon-discover") +(autoload 'mastodon-notifications--follow-request-accept "mastodon-notifications") +(autoload 'mastodon-notifications--follow-request-reject "mastodon-notifications") +(autoload 'mastodon-notifications--get-mentions "mastodon-notifications") +(autoload 'mastodon-notifications--timeline "mastodon-notifications") +(autoload 'mastodon-profile--fetch-server-account-settings "mastodon-profile") +(autoload 'mastodon-profile--get-toot-author "mastodon-profile") +(autoload 'mastodon-profile--make-author-buffer "mastodon-profile") +(autoload 'mastodon-profile--my-profile "mastodon-profile") +(autoload 'mastodon-profile--show-user "mastodon-profile") +(autoload 'mastodon-profile--update-user-profile-note "mastodon-profile") +(autoload 'mastodon-profile--view-bookmarks "mastodon-profile") +(autoload 'mastodon-profile--view-favourites "mastodon-profile") +(autoload 'mastodon-tl--block-user "mastodon-tl") +(autoload 'mastodon-tl--follow-user "mastodon-tl") +(autoload 'mastodon-tl--followed-tags-timeline "mastodon-tl") +(autoload 'mastodon-tl--get-buffer-type "mastodon-tl") +(autoload 'mastodon-tl--get-federated-timeline "mastodon-tl") +(autoload 'mastodon-tl--get-home-timeline "mastodon-tl") +(autoload 'mastodon-tl--get-local-timeline "mastodon-tl") +(autoload 'mastodon-tl--get-tag-timeline "mastodon-tl") +(autoload 'mastodon-tl--goto-next-item "mastodon-tl") +(autoload 'mastodon-tl--goto-prev-item "mastodon-tl") +(autoload 'mastodon-tl--init-sync "mastodon-tl") +(autoload 'mastodon-tl--list-followed-tags "mastodon-tl") +(autoload 'mastodon-tl--mute-user "mastodon-tl") +(autoload 'mastodon-tl--next-tab-item "mastodon-tl") +(autoload 'mastodon-tl--poll-vote "mastodon-http") +(autoload 'mastodon-tl--previous-tab-item "mastodon-tl") +(autoload 'mastodon-tl--thread "mastodon-tl") +(autoload 'mastodon-tl--toggle-spoiler-text-in-toot "mastodon-tl") +(autoload 'mastodon-tl--unblock-user "mastodon-tl") +(autoload 'mastodon-tl--unfollow-user "mastodon-tl") +(autoload 'mastodon-tl--unmute-user "mastodon-tl") +(autoload 'mastodon-tl--report-to-mods "mastodon-tl") +(autoload 'mastodon-tl--update "mastodon-tl") +(autoload 'mastodon-toot--edit-toot-at-point "mastodon-toot") +(when (require 'lingva nil :no-error) + (autoload 'mastodon-toot--translate-toot-text "mastodon-toot")) +(autoload 'mastodon-toot--view-toot-history "mastodon-tl") +(autoload 'mastodon-views--view-follow-suggestions "mastodon-views") +(autoload 'mastodon-views--view-filters "mastodon-views") +(autoload 'mastodon-views--view-follow-requests "mastodon-views") +(autoload 'mastodon-views--view-instance-description "mastodon-views") +(autoload 'mastodon-views--view-lists "mastodon-views") +(autoload 'mastodon-views--view-scheduled-toots "mastodon-views") +(autoload 'mastodon-tl--dm-user "mastodon-tl") +(autoload 'mastodon-tl--scroll-up-command "mastodon-tl") +(autoload 'special-mode "simple") +(autoload 'mastodon-tl--thread-do "mastodon-tl") + +(defvar mastodon-tl--highlight-current-toot) +(defvar mastodon-notifications--map) + +(defgroup mastodon nil + "Interface with Mastodon." + :prefix "mastodon-" + :group 'external) + +(defcustom mastodon-instance-url "https://mastodon.social" + "Base URL for the fediverse instance you want to be active. +For example, if your username is +\"example_user@social.instance.org\", and you want this account +to be active, the value of this variable should be +\"https://social.instance.org\". + +Also for completeness, the value of `mastodon-active-user' should +be \"example_user\". + +After setting these variables you should restart Emacs for these +changes to take effect." + :type 'string) + +(defcustom mastodon-active-user nil + "Username of the active user. +For example, if your username is +\"example_user@social.instance.org\", and you want this account +to be active, the value of this variable should be +\"example_user\". + +Also for completeness, the value of `mastodon-instance-url' +should be \"https://social.instance.org\". + +After setting these variables you should restart Emacs for these +changes to take effect." + :type 'string) + +(defcustom mastodon-toot-timestamp-format "%F %T" + "Format to use for timestamps. +For valid formatting options see `format-time-string`. +The default value \"%F %T\" prints ISO8601-style YYYY-mm-dd HH:MM:SS. +Use. e.g. \"%c\" for your locale's date and time format." + :type 'string) + +(defcustom mastodon-use-emojify nil + "Whether to use emojify.el to display emojis. +From version 28, Emacs can display emojis natively. But +currently, it doesn't seem to have a way to handle custom emoji, +while emojify,el has this feature and mastodon.el implements it." + :type 'boolean) + +;; notifications customizes +;; moved here because we can load notifs without first loading mastodon.el +;; or mastodon-notifications.el + +(defcustom mastodon-profile-note-in-foll-reqs t + "If non-nil, show a user's profile note in follow request notifications." + :type '(boolean)) + +(defcustom mastodon-profile-note-in-foll-reqs-max-length nil + "The max character length for user profile note in follow requests. +Profile notes are only displayed if +`mastodon-profile-note-in-foll-reqs' is non-nil. +If unset, profile notes of any size will be displayed, which may +make them unweildy." + :type '(integer)) + +(defcustom mastodon-images-in-notifs nil + "Whether to display attached images in notifications." + :type '(boolean)) + +(defcustom mastodon-group-notifications nil + "Whether to use grouped notifications. +Requires that your instance actually implements grouped notifications. +Mastodon implemented them in 4.3." + :type '(boolean)) + +(defcustom mastodon-notifications-grouped-names-count 2 + "The number of notification authors to display. +A count of 2 for example means to display like so: \"Bob, Jenny +and X others...\"." + :type '(integer)) + +(defun mastodon-kill-window () + "Quit window and delete helper." + (interactive) + (quit-window 'kill)) + +(defvar mastodon-mode-map + (let ((map (make-sparse-keymap))) + ;; navigation inside a timeline + (define-key map (kbd "n") #'mastodon-tl--goto-next-item) + (define-key map (kbd "p") #'mastodon-tl--goto-prev-item) + (define-key map (kbd "M-n") #'mastodon-tl--next-tab-item) + (define-key map (kbd "M-p") #'mastodon-tl--previous-tab-item) + (define-key map [?\t] #'mastodon-tl--next-tab-item) + (define-key map [backtab] #'mastodon-tl--previous-tab-item) + (define-key map [?\S-\t] #'mastodon-tl--previous-tab-item) + (define-key map [?\M-\t] #'mastodon-tl--previous-tab-item) + (define-key map (kbd "l") #'recenter-top-bottom) + ;; navigation between timelines + (define-key map (kbd "#") #'mastodon-tl--get-tag-timeline) + (define-key map (kbd "\"") #'mastodon-tl--list-followed-tags) + (define-key map (kbd "'") #'mastodon-tl--followed-tags-timeline) + (define-key map (kbd "A") #'mastodon-profile--get-toot-author) + (define-key map (kbd "F") #'mastodon-tl--get-federated-timeline) + (define-key map (kbd "H") #'mastodon-tl--get-home-timeline) + (define-key map (kbd "L") #'mastodon-tl--get-local-timeline) + (define-key map (kbd "N") #'mastodon-notifications-get) + (define-key map (kbd "@") #'mastodon-notifications--get-mentions) + (define-key map (kbd "P") #'mastodon-profile--show-user) + (define-key map (kbd "s") #'mastodon-search--query) + (define-key map (kbd "/") #'mastodon-switch-to-buffer) + (define-key map (kbd "\\") #'mastodon-tl--get-remote-local-timeline) + ;; quitting mastodon + (define-key map (kbd "q") #'kill-current-buffer) + (define-key map (kbd "Q") #'mastodon-kill-window) + (define-key map (kbd "M-C-q") #'mastodon-kill-all-buffers) + ;; toot actions + (define-key map (kbd "c") #'mastodon-tl--toggle-spoiler-text-in-toot) + (define-key map (kbd "b") #'mastodon-toot--toggle-boost) + (define-key map (kbd "f") #'mastodon-toot--toggle-favourite) + (define-key map (kbd "k") #'mastodon-toot--toggle-bookmark) + (define-key map (kbd "r") #'mastodon-toot--reply) + (define-key map (kbd "C") #'mastodon-toot--copy-toot-url) + (define-key map (kbd "o") #'mastodon-toot--open-toot-url) + (define-key map (kbd "v") #'mastodon-tl--poll-vote) + (define-key map (kbd "E") #'mastodon-toot--view-toot-edits) + (define-key map (kbd "T") #'mastodon-tl--thread) + (define-key map (kbd "RET") #'mastodon-tl--thread) + (define-key map (kbd "m") #'mastodon-tl--dm-user) + (when (require 'lingva nil :no-error) + (define-key map (kbd "a") #'mastodon-toot--translate-toot-text)) + (define-key map (kbd ",") #'mastodon-toot--list-favouriters) + (define-key map (kbd ".") #'mastodon-toot--list-boosters) + (define-key map (kbd ";") #'mastodon-views--view-instance-description) + ;; override special mode binding + (define-key map (kbd "g") #'undefined) + (define-key map (kbd "g") #'mastodon-tl--update) + ;; this is now duplicated by 'g', cd remove/use for else: + (define-key map (kbd "u") #'mastodon-tl--update) + ;; own toot actions: + (define-key map (kbd "t") #'mastodon-toot) + (define-key map (kbd "d") #'mastodon-toot--delete-toot) + (define-key map (kbd "D") #'mastodon-toot--delete-and-redraft-toot) + (define-key map (kbd "i") #'mastodon-toot--pin-toot-toggle) + (define-key map (kbd "e") #'mastodon-toot--edit-toot-at-point) + ;; user actions + (define-key map (kbd "W") #'mastodon-tl--follow-user) + (define-key map (kbd "C-S-W") #'mastodon-tl--unfollow-user) + (define-key map (kbd "B") #'mastodon-tl--block-user) + (define-key map (kbd "C-S-B") #'mastodon-tl--unblock-user) + (define-key map (kbd "M") #'mastodon-tl--mute-user) + (define-key map (kbd "C-S-M") #'mastodon-tl--unmute-user) + (define-key map (kbd "Z") #'mastodon-tl--report-to-mods) + ;; own profile + (define-key map (kbd "O") #'mastodon-profile--my-profile) + (define-key map (kbd "U") #'mastodon-profile--update-user-profile-note) + (define-key map (kbd "V") #'mastodon-profile--view-favourites) + (define-key map (kbd "K") #'mastodon-profile--view-bookmarks) + (define-key map (kbd ":") #'mastodon-user-settings) + ;; minor views + (define-key map (kbd "R") #'mastodon-views--view-follow-requests) + (define-key map (kbd "S") #'mastodon-views--view-scheduled-toots) + (define-key map (kbd "I") #'mastodon-views--view-filters) + (define-key map (kbd "G") #'mastodon-views--view-follow-suggestions) + (define-key map (kbd "X") #'mastodon-views--view-lists) + (define-key map (kbd "SPC") #'mastodon-tl--scroll-up-command) + (define-key map (kbd "!") #'mastodon-tl--fold-post-toggle) + (define-key map (kbd "z") #'bury-buffer) + map) + "Keymap for `mastodon-mode'.") + +(defcustom mastodon-mode-hook nil + "Hook run when entering Mastodon mode." + :type 'hook + :options '(provide-discover-context-menu)) + +(defface mastodon-handle-face + '((t :inherit default)) + "Face used for user handles in bylines.") + +(defface mastodon-display-name-face + '((t :inherit warning)) + "Face used for user display names.") + +(defface mastodon-boosted-face + '((t :inherit success :weight bold)) + "Face to indicate that a toot is boosted.") + +(defface mastodon-boost-fave-face + '((t :inherit success)) + "Face to indicate that you have boosted or favourited a toot.") + +(defface mastodon-cw-face + '((t :inherit success)) + "Face used for content warning.") + +(defface mastodon-toot-docs-face + `((t :inherit font-lock-comment-face)) + "Face used for documentation in toot compose buffer. +If `mastodon-tl--enable-proportional-fonts' is changed, +mastodon.el needs to be re-loaded for this to be correctly set.") + +(defface mastodon-toot-docs-reply-text-face + `((t :inherit font-lock-comment-face + :family ,(face-attribute 'variable-pitch :family))) + "Face used for reply text in toot compose buffer. +See `mastodon-toot-display-orig-in-reply-buffer'.") + +(defface mastodon-cursor-highlight-face + `((t :inherit highlight :extend t)) + "Face for `mastodon-tl--highlight-current-toot'.") + +;;;###autoload +(defun mastodon () + "Connect client to `mastodon-instance-url' instance. +If there are any open mastodon.el buffers, switch to one instead. +Prority in switching is given to timeline views." + (interactive) + (let* ((tls (list "home" + "local" + "federated" + (concat (mastodon-auth--user-acct) "-statuses") ; own profile + "favourites" + "search")) + (buffer (or (cl-some (lambda (el) + (get-buffer (concat "*mastodon-" el "*"))) + tls) ; return first buff that exists + (cl-some (lambda (x) + (when (string-prefix-p "*mastodon-" + (buffer-name x)) + (get-buffer x))) + (buffer-list))))) ; catch any other masto buffer + (if buffer + (pop-to-buffer buffer '(display-buffer-same-window)) + ;; we need to update credential-account in case setting have been changed + ;; outside mastodon.el in the meantime: + (mastodon-return-credential-account :force) + (mastodon-tl--get-home-timeline) + (message "Loading fediverse account %s on %s..." + (mastodon-auth--user-acct) + mastodon-instance-url)))) + +(defvar mastodon-profile-credential-account nil) + +;; TODO: the get request in mastodon-http--get-response often returns nil +;; after waking from sleep, not sure how to fix, or if just my pc. +;; interestingly it only happens with this function tho. +(defun mastodon-return-credential-account (&optional force) + "Return the CredentialAccount entity. +Either from `mastodon-profile-credential-account' or from the +server if that var is nil. +FORCE means to fetch from the server in any case and update +`mastodon-profile-credential-account'." + (if (or force (not mastodon-profile-credential-account)) + (setq mastodon-profile-credential-account + ;; TODO: we should signal a quit condition after 5 secs here + (condition-case nil + (mastodon-http--get-json + (mastodon-http--api "accounts/verify_credentials") + nil :silent) + (t ; req fails, return old value + mastodon-profile-credential-account))) + ;; else just return the var: + mastodon-profile-credential-account)) + +(defvar mastodon-instance-data nil + "Instance data from the instance endpoint.") + +(defun mastodon-instance-data () + "Return `mastodon-instnace-data' or else fetch from instance endpoint." + (or mastodon-instance-data + (setq mastodon-instance-data + (mastodon-http--get-json (mastodon-http--api "instance"))))) + +(defun mastodon-instance-version () + "Return the version string of user's instance." + (alist-get 'version (mastodon-instance-data))) + +;;;###autoload +(defun mastodon-toot (&optional user reply-to-id reply-json) + "Update instance with new toot. Content is captured in a new buffer. +If USER is non-nil, insert after @ symbol to begin new toot. +If REPLY-TO-ID is non-nil, attach new toot to a conversation. +If REPLY-JSON is the json of the toot being replied to." + (interactive) + (mastodon-toot--compose-buffer user reply-to-id reply-json)) + +;;;###autoload +(defun mastodon-notifications-get (&optional type buffer-name max-id) + "Display NOTIFICATIONS in buffer. +Optionally only print notifications of type TYPE, a string. +BUFFER-NAME is added to \"*mastodon-\" to create the buffer name. +MAX-ID is a request parameter for pagination." + (interactive) + (let* ((buffer-name (or buffer-name "notifications")) + (buffer (concat "*mastodon-" buffer-name "*"))) + (message "Loading your notifications...") + (mastodon-tl--init-sync + buffer-name + "notifications" + 'mastodon-notifications--timeline + type + (when max-id + `(("max_id" . ,(mastodon-tl--buffer-property 'max-id)))) + nil nil nil + (if (or (not mastodon-group-notifications) + ;; if version less than 1st grouped notifs release: + (> 4.3 (string-to-number + (mastodon-instance-version)))) + "v1" + "v2")) + (with-current-buffer (get-buffer-create buffer) + (use-local-map mastodon-notifications--map)))) + +;; URL lookup: should be available even if `mastodon.el' not loaded: + +;;;###autoload +(defun mastodon-url-lookup (&optional query-url force) + "If a URL resembles a fediverse link, try to load in `mastodon.el'. +Does a WebFinger lookup on the server. +URL can be arg QUERY-URL, or URL at point, or provided by the user. +If a status or account is found, load it in `mastodon.el', if +not, just browse the URL in the normal fashion. +If FORCE, do a lookup regardless of the result of `mastodon--fedi-url-p'." + (interactive) + (let* ((query (or query-url + (mastodon-tl--property 'shr-url :no-move) + (thing-at-point-url-at-point) + (read-string "Lookup URL: ")))) + (if (and (not force) + (not (mastodon--fedi-url-p query))) + ;; (shr-browse-url query) ; doesn't work (keep our shr keymap) + (progn (message "Using external browser") + (browse-url query)) + (message "Performing lookup...") + (let* ((url (format "%s/api/v2/search" mastodon-instance-url)) + (params `(("q" . ,query) + ("resolve" . "t"))) ; webfinger + (response (mastodon-http--get-json url params :silent))) + (cond ((not (seq-empty-p (alist-get 'statuses response))) + (let* ((statuses (assoc 'statuses response)) + (status (seq-first (cdr statuses))) + (status-id (alist-get 'id status))) + (mastodon-tl--thread-do status-id))) + ((not (seq-empty-p (alist-get 'accounts response))) + (let* ((accounts (assoc 'accounts response)) + (account (seq-first (cdr accounts)))) + (mastodon-profile--make-author-buffer account))) + (t + (message "Lookup failed. Using external browser") + (browse-url query))))))) + +(defun mastodon-url-lookup-force () + "Call `mastodon-url-lookup' without checking if URL is fedi-like." + (interactive) + (mastodon-url-lookup nil :force)) + +(defun mastodon--fedi-url-p (query) + "Check if QUERY resembles a fediverse URL." + ;; calqued off https://github.com/tuskyapp/Tusky/blob/c8fc2418b8f5458a817bba221d025b822225e130/app/src/main/java/com/keylesspalace/tusky/BottomSheetActivity.kt + ;; thx to Conny Duck! + ;; mastodon at least seems to allow only [a-z0-9_] for usernames, plus "." + ;; but not at beginning or end, see https://github.com/mastodon/mastodon/issues/6830 + ;; objects may have - in them + (let* ((uri-parsed (url-generic-parse-url query)) + (query (url-filename uri-parsed))) + (save-match-data + (or (string-match "^/@[^/]+$" query) + (string-match "^/@[^/]+/[[:digit:]]+$" query) + (string-match "^/user[s]?/@?[[:alnum:]_]+$" query) ; @: pleroma or soapbox + (string-match "^/notice/[[:alnum:]]+$" query) + (string-match "^/objects/[-a-f0-9]+$" query) + (string-match "^/notes/[a-z0-9]+$" query) + (string-match "^/display/[-a-f0-9]+$" query) + (string-match "^/profile/[[:alpha:]_]+$" query) + (string-match "^/p/[[:alpha:]_]+/[[:digit:]]+$" query) + (string-match "^/[[:alpha:]_]+$" query) + (string-match "^/u/[[:alpha:]_]+$" query) + (string-match "^/c/[[:alnum:]_]+$" query) + (string-match "^/post/[[:digit:]]+$" query) + (string-match "^/comment/[[:digit:]]+$" query) ; lemmy + (string-match "^/@[^/]+/statuses/[[:alnum:]]" query) ; GTS + (string-match "^/user[s]?/[[:alnum:]_]+/statuses/[[:digit:]]+$" query) ; hometown + (string-match "^/notes/[[:alnum:]]+$" query))))) ; misskey post + +(defun mastodon-live-buffers () + "Return a list of open mastodon buffers. +Calls `mastodon-tl--get-buffer-type', which see." + (cl-loop for x in (buffer-list) + when (with-current-buffer x (mastodon-tl--get-buffer-type)) + collect (get-buffer x))) + +(defun mastodon-buffer-p (&optional buffer) + "Non-nil if BUFFER or `current-buffer' is a mastodon one." + (let ((buf (or buffer (current-buffer)))) + (member buf (mastodon-live-buffers)))) + +(defun mastodon-kill-all-buffers () + "Kill any and all open mastodon buffers, hopefully." + (interactive) + (let ((mastodon-buffers (mastodon-live-buffers))) + (cl-loop for x in mastodon-buffers + do (kill-buffer x)))) + +(defun mastodon-switch-to-buffer () + "Switch to a live mastodon buffer." + (interactive) + (let ((choice (completing-read + "Switch to mastodon buffer: " + (mapcar #'buffer-name (mastodon-live-buffers)) + nil :match))) + (switch-to-buffer choice))) + +(defun mastodon--url-at-point () + "`thing-at-point' provider function." + (get-text-property (point) 'shr-url)) + +(defun mastodon-mode-hook-fun () + "Function to add to `mastodon-mode-hook'." + (when (and mastodon-use-emojify + (require 'emojify nil :noerror)) + (emojify-mode t) + (when mastodon-toot--enable-custom-instance-emoji + (mastodon-toot--enable-custom-emoji))) + (mastodon-profile--fetch-server-account-settings) + (when mastodon-tl--highlight-current-toot + (cursor-face-highlight-mode)) ; 29.1 + ;; make `thing-at-point' functions work: + (setq-local thing-at-point-provider-alist + (append thing-at-point-provider-alist + '((url . mastodon--url-at-point))))) + +;;;###autoload +(add-hook 'mastodon-mode-hook #'mastodon-mode-hook-fun) + +(define-derived-mode mastodon-mode special-mode "Mastodon" + "Major mode for fediverse services using the Mastodon API." + (read-only-mode 1)) + +(provide 'mastodon) +;;; mastodon.el ends here diff --git a/elpa/mastodon-20241202.1839/mastodon.info b/elpa/mastodon-20241202.1839/mastodon.info new file mode 100644 index 00000000..6d44f1d5 --- /dev/null +++ b/elpa/mastodon-20241202.1839/mastodon.info @@ -0,0 +1,814 @@ +This is mastodon.info, produced by makeinfo version 6.8 from +mastodon.texi. + +INFO-DIR-SECTION Emacs +START-INFO-DIR-ENTRY +* Mastodon: (mastodon). Client for fediverse services using the Mastodon API. +END-INFO-DIR-ENTRY + + +File: mastodon.info, Node: Top, Next: README, Up: (dir) + +* Menu: + +* README:: + +— The Detailed Node Listing — + +README + +* Installation:: +* Usage:: +* Dependencies:: +* Network compatibility:: +* Contributing:: +* Supporting ‘mastodon.el’: Supporting mastodonel. +* Contributors:: +* screenshots:: + +Installation + +* ELPA:: +* MELPA:: +* Repo:: +* Emoji:: +* Discover:: + +Usage + +* Logging in to your instance:: +* Timelines:: +* Composing toots:: +* Other commands and account settings:: +* Customization:: +* Commands and variables index:: +* Alternative timeline layout:: +* mastodon hydra:: +* Live-updating timelines mastodon-async-mode:: +* Translating toots:: +* Bookmarks and ‘mastodon.el’: Bookmarks and mastodonel. + +Contributing + +* Bug reports:: +* Fixes and features:: +* Coding style:: + + + +File: mastodon.info, Node: README, Prev: Top, Up: Top + +1 README +******** + +‘mastodon.el’ is an Emacs client for the AcitivityPub social networks +that implement the Mastodon API. For info see joinmastodon.org +(https://joinmastodon.org/). + + NB: ‘mastodon.el’ now ships this readme as an .info file, so if you +have it installed you should be able to browse this readme inside emacs. +‘C-h i’ for info, then ‘m masto RET’ should load it for you. + +* Menu: + +* Installation:: +* Usage:: +* Dependencies:: +* Network compatibility:: +* Contributing:: +* Supporting ‘mastodon.el’: Supporting mastodonel. +* Contributors:: +* screenshots:: + + +File: mastodon.info, Node: Installation, Next: Usage, Up: README + +1.1 Installation +================ + +You can install ‘mastodon.el’ from ELPA, MELPA, or directly from this +repo. It is also available as a GUIX package. + +* Menu: + +* ELPA:: +* MELPA:: +* Repo:: +* Emoji:: +* Discover:: + + +File: mastodon.info, Node: ELPA, Next: MELPA, Up: Installation + +1.1.1 ELPA +---------- + +You should be able to directly install with: + + ‘M-x package-refresh-contents RET’ + + ‘M-x package-install RET mastodon RET’ + + +File: mastodon.info, Node: MELPA, Next: Repo, Prev: ELPA, Up: Installation + +1.1.2 MELPA +----------- + +Add ‘MELPA’ to your archives: + + (require 'package) + (add-to-list 'package-archives + '("melpa" . "http://melpa.org/packages/") t) + + Update and install: + + ‘M-x package-refresh-contents RET’ + + ‘M-x package-install RET mastodon RET’ + + +File: mastodon.info, Node: Repo, Next: Emoji, Prev: MELPA, Up: Installation + +1.1.3 Repo +---------- + +Clone this repository and add the lisp directory to your load path. +Then, require it and go. + + (add-to-list 'load-path "/path/to/mastodon.el/lisp") + (require 'mastodon) + + Or, with ‘use-package’: + + (use-package mastodon + :ensure t) + + The minimum Emacs version is now 28.1. But if you are running an +older version it shouldn’t be very hard to get it working. + + +File: mastodon.info, Node: Emoji, Next: Discover, Prev: Repo, Up: Installation + +1.1.4 Emoji +----------- + +Since Emacs 28, it has builtin emoji support with ‘emoji.el’. If you +prefer to use Emojify (https://github.com/iqbalansari/emacs-emojify), +‘require’ it and set ‘mastodon-use-emojify’ to non-nil to display emoji +in timelines and to use it when composing toots. ‘Emoji.el’ is the +better option, but for now only ‘emojify’ supports downloading and using +custom emoji from your instance. From personal experience, ‘emojify’ +also tends to result in less TOFU. + + +File: mastodon.info, Node: Discover, Prev: Emoji, Up: Installation + +1.1.5 Discover +-------------- + +‘mastodon-mode’ can provide a context menu for its keybindings if +Discover (https://github.com/mickeynp/discover.el) is installed. It is +not required. + + if you have Discover, add the following to your Emacs init +configuration: + + (require 'mastodon-discover) + (with-eval-after-load 'mastodon (mastodon-discover)) + + Or, with ‘use-package’: + + (use-package mastodon + :ensure t + :config + (mastodon-discover)) + + +File: mastodon.info, Node: Usage, Next: Dependencies, Prev: Installation, Up: README + +1.2 Usage +========= + +* Menu: + +* Logging in to your instance:: +* Timelines:: +* Composing toots:: +* Other commands and account settings:: +* Customization:: +* Commands and variables index:: +* Alternative timeline layout:: +* mastodon hydra:: +* Live-updating timelines mastodon-async-mode:: +* Translating toots:: +* Bookmarks and ‘mastodon.el’: Bookmarks and mastodonel. + + +File: mastodon.info, Node: Logging in to your instance, Next: Timelines, Up: Usage + +1.2.1 Logging in to your instance +--------------------------------- + +You need to set 2 variables in your init file to get started: + + 1. ‘mastodon-instance-url’ + 2. ‘mastodon-active-user’ + + (see their doc strings for details). For example If you want to post +toots as "example_user@social.instance.org", then put this in your init +file: + + (setq mastodon-instance-url "https://social.instance.org" + mastodon-active-user "example_user") + + Then *restart* Emacs and run ‘M-x mastodon’. Make sure you are +connected to internet before you do this. If you have multiple mastodon +accounts you can activate one at a time by changing those two variables +and restarting Emacs. + + If you were using mastodon.el before 2FA was implemented and the +above steps do not work, delete the old file specified by +‘mastodon-client--token-file’ and restart Emacs and follow the steps +again. + + +File: mastodon.info, Node: Timelines, Next: Composing toots, Prev: Logging in to your instance, Up: Usage + +1.2.2 Timelines +--------------- + +‘M-x mastodon’ + + Opens a ‘*mastodon-home*’ buffer in the major mode and displays +toots. If your credentials are not yet saved, you will be prompted for +email and password. The app registration process will take place if +your ‘mastodon-token-file’ does not contain ‘:client_id’ and +‘:client_secret’. + + 1. Keybindings + + For a full list of commands and variables, see mastodon-index.org + (mastodon-index.org). + + Key Action + ----------------------------------------------------------------------------------------------------------- + *Help* + ‘?’ Show discover menu of all bindings, if ‘discover’ is available + *Timeline actions* + ‘n’ Go to next item (toot, notification, user) + ‘p’ Go to previous item (toot, notification, user) + ‘M-n=/=’ Go to the next interesting thing that has an action + ‘M-p=/=’ Go to the previous interesting thing that has an action + ‘F’ Open federated timeline (1 prefix arg: hide-replies, 2 prefix args: media only) + ‘H’ Open home timeline (1 prefix arg: hide-replies) + ‘L’ Open local timeline (1 prefix arg: hide-replies, 2 prefix args: media only) + ‘N’ Open notifications timeline + ‘@’ Open mentions-only notifications timeline + ‘u’ Update current timeline + ‘T’ Open thread for toot at point + ‘#’ Prompt for tag and open its timeline + ‘A’ Open author profile of toot at point + ‘P’ Open profile of user attached to toot at point + ‘O’ View own profile + ‘U’ update your profile bio note + ‘;’ view instance description for toot at point + ‘:’ view followed tags and load a tag timeline + ‘C-:’ view timeline of all followed tags + ‘,’ view favouriters of toot at point + ‘.’ view boosters of toot at point + ‘/’ switch between mastodon buffers + ‘\’ prompt for an instance domain and view its local timeline (if poss) + ‘Z’ report user/toot at point to instances moderators + *Other views* + ‘s’ search (posts, users, tags) (NB: only posts you have interacted with) + ‘I’, ‘c’, ‘d’ view, create, and delete filters + ‘R’, ‘a’, ‘j’ view/accept/reject follow requests + ‘G’ view follow suggestions + ‘V’ view your favourited toots + ‘K’ view bookmarked toots + ‘X’ view/edit/create/delete lists + ‘S’ view your scheduled toots + *Toot actions* + ‘t’ Compose a new toot + ‘c’ Toggle content warning content + ‘b’ Boost toot under ‘point’ + ‘f’ Favourite toot under ‘point’ + ‘k’ toggle bookmark of toot at point + ‘r’ Reply to toot under ‘point’ + ‘v’ Vote on poll at point + ‘C’ copy url of toot at point + ‘C-RET’ play video/gif at point (requires ‘mpv’) + ‘e’ edit your toot at point + ‘E’ view edits of toot at point + ‘i’ (un)pin your toot at point + ‘d’ delete your toot at point, and reload current timeline + ‘D’ delete and redraft toot at point, preserving reply/CW/visibility + ‘!’ toggle folding of toot at point + (‘S-C-’) ‘W’, ‘M’, ‘B’ (un)follow, (un)mute, (un)block author of toot at point + *Profile view* + ‘C-c C-c’ cycle between statuses, statuses without boosts, followers, and following + ‘mastodon-profile--account-account-to-list’ (see lists view) + *Notifications view* + ‘a’, ‘j’ accept/reject follow request + ‘C-k’ clear notification at point + see ‘mastodon-notifications--get-*’ functions for filtered views + *Quitting* + ‘q’ Quit mastodon buffer, leave window open + ‘Q’ Quit mastodon buffer and kill window + ‘C-M-q’ Quit and kill all mastodon buffers + + 2. Toot byline legend + + Marker Meaning + -------------------------------------------- + ‘(🔁)’ (or I boosted this toot + ‘(B)’) + ‘(⭐)’ (or I favourited this toot + ‘(F)’) + ‘(🔖)’ (or I bookmarked this toot + (‘K’)) + + +File: mastodon.info, Node: Composing toots, Next: Other commands and account settings, Prev: Timelines, Up: Usage + +1.2.3 Composing toots +--------------------- + +‘M-x mastodon-toot’ (or ‘t’ from a mastodon.el buffer) opens a new +buffer/window in ‘text-mode’ and ‘mastodon-toot’ minor mode. Enter the +contents of your toot here. ‘C-c C-c’ sends the toot. ‘C-c C-k’ +cancels. Both actions kill the buffer and window. Further keybindings +are displayed in the buffer, and in the following subsection. + + Replies preserve visibility status/content warnings, and include +boosters by default. If the region is active when you start a reply, it +will be yanked into the compose buffer prefixed with ‘>’ to form a rough +reply quote. + + Server’s max toot length, with running char count, and attachment +previews, are shown. + + You can download and use your instance’s custom emoji +(‘mastodon-toot--download-custom-emoji’, +‘mastodon-toot--enable-custom-emoji’). + + If you want to view some of the toot being replied to in the compose +buffer, set ‘mastodon-toot-display-orig-in-reply-buffer’ to non-nil. + + The compose buffer uses ‘text-mode’ so any configuration you have for +that mode will be enabled. If any of your existing config conflicts +with ‘mastodon-toot’, you can disable it in the +‘mastodon-toot-mode-hook’. For example, the default value of that hook +is as follows: + + (add-hook 'mastodon-toot-mode-hook + (lambda () + (auto-fill-mode -1))) + + 1. Keybindings + + Key Action + --------------------------------------------- + ‘C-c C-c’ Send toot + ‘C-c C-k’ Cancel toot + ‘C-c C-w’ Add content warning + ‘C-c C-v’ Change toot visibility + ‘C-c C-n’ Add sensitive media/nsfw flag + ‘C-c C-a’ Upload attachment(s) + ‘C-c !’ Remove all attachments + ‘C-c C-e’ Insert emoji + ‘C-c C-p’ Create a poll + ‘C-c C-l’ Set toot language + ‘-C-c C-s’ Schedule toot + + 2. Autocompletion of mentions, tags and emoji + + Autocompletion of mentions, tags, and emojis is provided by + ‘completion-at-point-functions’ (capf) backends. + ‘mastodon-toot--enable-completion’ is enabled by default. + + To trigger completion, type a prefix followed by a few letters, ‘@’ + for mentions, ‘#’ for tags, and ‘:’ for emoji (for now this only + works when using ‘emojify.el’). + + If you want to enable ‘company-mode’ in the toot compose buffer, + set ‘mastodon-toot--use-company-for-completion’ to ‘t’. + (‘mastodon.el’ used to run its own native company backends, but + these have been removed in favour of capfs.) + + If you don’t run ‘company’ and want immediate, keyless completion, + you’ll need to have another completion engine running that handles + capfs. A common combination is ‘consult’ and ‘corfu’. + + 3. Draft toots + + • Compose buffer text is saved as you type, kept in + ‘mastodon-toot-current-toot-text’. + • ‘mastodon-toot--save-draft’: save the current toot as a draft. + • ‘mastodon-toot--open-draft-toot’: Open a compose buffer and + insert one of your draft toots. + • ‘mastodon-toot--delete-draft-toot’: Delete a draft toot. + • ‘mastodon-toot--delete-all-drafts’: Delete all your drafts. + + +File: mastodon.info, Node: Other commands and account settings, Next: Customization, Prev: Composing toots, Up: Usage + +1.2.4 Other commands and account settings: +------------------------------------------ + +In addition to ‘mastodon’, the following three functions are autoloaded +and should work without first loading a ‘mastodon.el’ buffer: + • ‘mastodon-toot’: Compose new toot + • ‘mastodon-notifications-get’: View all notifications + • ‘mastodon-url-lookup’: Attempt to load a URL in ‘mastodon.el’. URL + may be at point or provided in the minibuffer. + + • ‘mastodon-tl--view-instance-description’: View information about + the instance that the author of the toot at point is on. + • ‘mastodon-tl--view-own-instance’: View information about your own + instance. + • ‘mastodon-search--trending-tags’: View a list of trending hashtags + on your instance. + • ‘mastodon-search--trending-statuses’: View a list of trending + statuses on your instance. + + • ‘mastodon-tl--add-toot-account-at-point-to-list’: Add the account + of the toot at point to a list. + + • ‘mastodon-tl--dm-user’: Send a direct message to one of the users + at point. + + • ‘mastodon-profile--add-private-note-to-account’: Add a private note + to another user’s account. + • ‘mastodon-profile--view-account-private-note’: View a private note + on a user’s account. + + • ‘mastodon-profile--show-familiar-followers’: Show a list of + “familiar followers” for a given account. Familiar followers are + accounts that you follow, and that follow the account. + + • ‘mastodon-tl--follow-tag’: Follow a tag (works like following a + user) + • ‘mastodon-tl--unfollow-tag’: Unfollow a tag + • ‘mastodon-tl--list-followed-tags’: View a list of tags you’re + following. + • ‘mastodon-tl--followed-tags-timeline’: View a timeline of all your + followed tags. + • ‘mastodon-tl--some-followed-tags-timleine’: View a timeline of + multiple tags, from your followed tags or any other. + + • ‘mastodon-switch-to-buffer’: switch between mastodon buffers. + + • ‘mastodon-tl--get-remote-local-timeline’: View a local timeline of + a remote instance. + • ‘mastodon-tl--remote-tag-timeline’: View a tag timeline on a remote + instance. + + • ‘mastodon-profile--update-display-name’: Update the display name + for your account. + • ‘mastodon-profile--update-user-profile-note’: Update your bio note. + • ‘mastodon-profile--update-meta-fields’: Update your metadata + fields. + • ‘mastodon-profile--set-default-toot-visibility’: Set the default + visibility for your toots. + • ‘mastodon-profile--account-locked-toggle’: Toggle the locked status + of your account. Locked accounts have to manually approve follow + requests. + • ‘mastodon-profile--account-discoverable-toggle’: Toggle the + discoverable status of your account. Non-discoverable accounts are + not listed in the profile directory. + • ‘mastodon-profile--account-bot-toggle’: Toggle whether your account + is flagged as a bot. + • ‘mastodon-profile--account-sensitive-toggle’: Toggle whether your + posts are marked as sensitive (nsfw) by default. + + +File: mastodon.info, Node: Customization, Next: Commands and variables index, Prev: Other commands and account settings, Up: Usage + +1.2.5 Customization +------------------- + +See ‘M-x customize-group RET mastodon’ to view all customize options. + + • Timeline options: + • Use proportional fonts + • Default number of posts displayed + • Timestamp format + • Relative timestamps + • Display user avatars + • Avatar image height + • Enable image caching + • Hide replies in timelines + • Show toot stats in byline + + • Compose options: + • Completion style for mentions and tags + • Enable custom emoji + • Display toot being replied to + • Set default reply visibility + + • Nofitication options: + • Display user’s profile note in follow requests + + +File: mastodon.info, Node: Commands and variables index, Next: Alternative timeline layout, Prev: Customization, Up: Usage + +1.2.6 Commands and variables index +---------------------------------- + +An index of all user-facing commands and custom variables is available +here: mastodon-index.org (mastodon-index.org). + + You can also hit ‘?’ in any ‘mastodon.el’ buffer to see the available +bindings, or run ‘M-X’ (upper-case ‘X’) to view all commands in the +buffer with completion, and call one. + + +File: mastodon.info, Node: Alternative timeline layout, Next: mastodon hydra, Prev: Commands and variables index, Up: Usage + +1.2.7 Alternative timeline layout +--------------------------------- + +The incomparable Nicholas Rougier has written an alternative timeline +layout for ‘mastodon.el’. + + The repo is at mastodon-alt +(https://github.com/rougier/mastodon-alt). + + +File: mastodon.info, Node: mastodon hydra, Next: Live-updating timelines mastodon-async-mode, Prev: Alternative timeline layout, Up: Usage + +1.2.8 mastodon hydra +-------------------- + +A user made a hydra for handling basic mastodon.el commands. It’s +available at . + + +File: mastodon.info, Node: Live-updating timelines mastodon-async-mode, Next: Translating toots, Prev: mastodon hydra, Up: Usage + +1.2.9 Live-updating timelines: ‘mastodon-async-mode’ +---------------------------------------------------- + +(code taken from mastodon-future +(https://github.com/alexjgriffith/mastodon-future.el).) + + Works for federated, local, and home timelines and for notifications. +It’s a little touchy, one thing to avoid is trying to load a timeline +more than once at a time. It can go off the rails a bit, but it’s still +pretty cool. The current maintainer of ‘mastodon.el’ is unable to debug +or improve this feature. + + To enable, it, add ‘(require 'mastodon-async)’ to your ‘init.el’. +Then you can view a timeline with one of the commands that begin with +‘mastodon-async--stream-’. + + +File: mastodon.info, Node: Translating toots, Next: Bookmarks and mastodonel, Prev: Live-updating timelines mastodon-async-mode, Up: Usage + +1.2.10 Translating toots +------------------------ + +You can translate toots with ‘mastodon-toot--translate-toot-text’ (‘a’ +in a timeline). At the moment this requires lingva.el +(https://codeberg.org/martianh/lingva.el), a little interface I wrote to +lingva.ml (https://lingva.ml), to be installed to work. + + You could easily modify the simple function to use your Emacs +translator of choice (‘libretrans.el’ , ‘google-translate’, ‘babel’, +‘go-translate’, etc.), you just need to fetch the toot’s content with +‘(mastodon-tl--content toot)’ and pass it to your translator function as +its text argument. Here’s what ‘mastodon-toot--translate-toot-text’ +looks like: + + (defun mastodon-toot--translate-toot-text () + "Translate text of toot at point. + Uses `lingva.el'." + (interactive) + (let* ((toot (mastodon-tl--property 'item-json))) + (if toot + (lingva-translate nil (mastodon-tl--content toot)) + (message "No toot to translate?")))) + + +File: mastodon.info, Node: Bookmarks and mastodonel, Prev: Translating toots, Up: Usage + +1.2.11 Bookmarks and ‘mastodon.el’ +---------------------------------- + +‘mastodon.el’ implements a basic bookmark record and handler. +Currently, this means that you can bookmark a post item and later load +it in thread view. This could be expanded to any item with an id, but +probably not to things like timeline views. If you want to be able to +bookmark something, open an issue and ask, as it’s trivial to expand the +bookmarking code. + + +File: mastodon.info, Node: Dependencies, Next: Network compatibility, Prev: Usage, Up: README + +1.3 Dependencies +================ + +Hard dependencies (should all install with ‘mastodon.el’): + • ‘request’ (for uploading attachments), emacs-request + (https://github.com/tkf/emacs-request) + • ‘persist’ for storing some settings across sessions + + Optional dependencies (install yourself, ‘mastodon.el’ can use them): + • ‘emojify’ to use custom emoji (else we use builtin ‘emoji.el’) + • ‘mpv’ and ‘mpv.el’ for viewing videos and gifs + • ‘lingva.el’ for translating toots + + +File: mastodon.info, Node: Network compatibility, Next: Contributing, Prev: Dependencies, Up: README + +1.4 Network compatibility +========================= + +‘mastodon.el’ should work with ActivityPub servers that implement the +Mastodon API. + + Apart from Mastodon itself, it is currently known to work with: + • Pleroma (pleroma.social (https://pleroma.social/)) + • Akkoma (akkoma.social (https://akkoma.social/)) + • Gotosocial (gotosocial.org (https://gotosocial.org/)) + + It does not support the non-Mastodon API servers Misskey (misskey.io +(https://misskey.io/)), Firefish (joinfirefish.org +(https://joinfirefish.org/), formerly Calkey) and Friendica, but it +should fully support displaying and interacting with posts and users on +those platforms. + + If you attempt to use ‘mastodon.el’ with a server and run into +problems, feel free to open an issue. + + +File: mastodon.info, Node: Contributing, Next: Supporting mastodonel, Prev: Network compatibility, Up: README + +1.5 Contributing +================ + +PRs, issues, feature requests, and general feedback are very welcome! + + If you prefer emailing patches to the process described below, feel +free to send them on. Ideally they’d be patches that can be applied +with ‘git am’, if you want to actually contribute a commit. + +* Menu: + +* Bug reports:: +* Fixes and features:: +* Coding style:: + + +File: mastodon.info, Node: Bug reports, Next: Fixes and features, Up: Contributing + +1.5.1 Bug reports +----------------- + + 1. ‘mastodon.el’ has bugs, as well as lots of room for improvement. + 2. I receive very little feedback, so if I don’t run into the bug it + often doesn’t get fixed. + 3. If you run into something that seems broken, first try running + ‘mastodon.el’ in emacs with no init file (i.e. ‘emacs -q’ + (instructions and code for doing this are here + (https://codeberg.org/martianh/mastodon.el/issues/300)) to see if + it also happens independently of your own config (it probably + does). + 4. Else enable debug on error (‘toggle-debug-on-error’), make the bug + happen again, and copy the backtrace that appears. + 5. Open an issue here and explain what is going on. Provide your + emacs version and what kind of server your account is on. + + +File: mastodon.info, Node: Fixes and features, Next: Coding style, Prev: Bug reports, Up: Contributing + +1.5.2 Fixes and features +------------------------ + + 1. Create an issue (https://codeberg.org/martianh/mastodon.el/issues) + detailing what you’d like to do. + 2. Fork the repository and create a branch off of ‘develop’. + 3. Run the tests and ensure that your code doesn’t break any of them. + 4. Create a pull request (to develop) referencing the issue created in + step 1. + + +File: mastodon.info, Node: Coding style, Prev: Fixes and features, Up: Contributing + +1.5.3 Coding style +------------------ + + • This library uses an unconvential double dash (‘--’) between file + namespaces and function names, which contradicts normal Elisp + style. This needs to be respected until the whole library is + changed. + • Use ‘aggressive-indent-mode’ or similar to keep your code indented. + • Single spaces end sentences in docstrings. + • There’s no need for a blank line after the first docstring line + (one is added automatically when documentation is displayed). + + +File: mastodon.info, Node: Supporting mastodonel, Next: Contributors, Prev: Contributing, Up: README + +1.6 Supporting ‘mastodon.el’ +============================ + +If you’d like to support continued development of ‘mastodon.el’, I +accept donations via paypal: paypal.me/martianh +(https://paypal.me/martianh). If you would prefer a different payment +method, please write to me at and I can provide +IBAN or other bank account details. + + I don’t have a tech worker’s income, so even a small tip would help +out. + + +File: mastodon.info, Node: Contributors, Next: screenshots, Prev: Supporting mastodonel, Up: README + +1.7 Contributors +================ + +‘mastodon.el’ is the work of a number of people. + + Some significant contributors are: + + • [original author] + • + • + • + • + + +File: mastodon.info, Node: screenshots, Prev: Contributors, Up: README + +1.8 screenshots +=============== + +Here’s a (federated) timeline: + +[image src="screenshot-tl.png"] + + + Here’s a notifcations view plus a compose buffer: + +[image src="screenshot-notifs+compose.png"] + + + Here’s a user settings transient (active values green, current server +values commented and, if a boolean, underlined): + +[image src="screenshot-transient-1.jpg"] + + + Here’s a user profile fields transient (changed fields green, current +server values commented): + +[image src="screenshot-transient-2.jpg"] + + + + +Tag Table: +Node: Top219 +Node: README1006 +Node: Installation1656 +Node: ELPA1945 +Node: MELPA2173 +Node: Repo2553 +Node: Emoji3046 +Node: Discover3640 +Node: Usage4192 +Node: Logging in to your instance4654 +Node: Timelines5651 +Ref: Keybindings6126 +Ref: Toot byline legend10966 +Node: Composing toots11275 +Ref: Keybindings (1)12827 +Ref: Autocompletion of mentions tags and emoji13362 +Ref: Draft toots14287 +Node: Other commands and account settings14758 +Node: Customization18122 +Node: Commands and variables index19000 +Node: Alternative timeline layout19516 +Node: mastodon hydra19892 +Node: Live-updating timelines mastodon-async-mode20224 +Node: Translating toots21063 +Node: Bookmarks and mastodonel22247 +Node: Dependencies22789 +Node: Network compatibility23423 +Node: Contributing24305 +Node: Bug reports24801 +Node: Fixes and features25712 +Node: Coding style26213 +Node: Supporting mastodonel26837 +Node: Contributors27389 +Node: screenshots27824 + +End Tag Table + + +Local Variables: +coding: utf-8 +End: