aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authormousebot <mousebot@riseup.net>2021-12-23 20:24:59 +0100
committermousebot <mousebot@riseup.net>2021-12-23 20:24:59 +0100
commit6c19decad2bdb86d55c96409cd0c96e1c8dd1a32 (patch)
tree59f4191d590d3713c73ac6b2e8a6197097bfbc5a
parent0cffc91cfd362190eac9580983cda74248a2d3a0 (diff)
parentab37e43c60edf5f0d591441e8cece61a27dd2a6d (diff)
Merge branch 'main'
-rw-r--r--Cask3
-rw-r--r--README.org90
-rw-r--r--lisp/mastodon-async.el372
-rw-r--r--lisp/mastodon-auth.el50
-rw-r--r--lisp/mastodon-client.el9
-rw-r--r--lisp/mastodon-discover.el59
-rw-r--r--lisp/mastodon-http.el225
-rw-r--r--lisp/mastodon-inspect.el48
-rw-r--r--lisp/mastodon-media.el111
-rw-r--r--lisp/mastodon-notifications.el170
-rw-r--r--lisp/mastodon-profile.el341
-rw-r--r--lisp/mastodon-search.el173
-rw-r--r--lisp/mastodon-tl.el632
-rw-r--r--lisp/mastodon-toot.el688
-rw-r--r--lisp/mastodon.el104
-rw-r--r--test/ert-helper.el12
l---------test/fixture1
-rw-r--r--test/mastodon-auth-tests.el129
-rw-r--r--test/mastodon-client-tests.el70
-rw-r--r--test/mastodon-http-tests.el88
-rw-r--r--test/mastodon-media-tests.el157
-rw-r--r--test/mastodon-notifications-test.el24
-rw-r--r--test/mastodon-search-tests.el147
-rw-r--r--test/mastodon-tl-tests.el393
-rw-r--r--test/mastodon-toot-tests.el140
25 files changed, 3540 insertions, 696 deletions
diff --git a/Cask b/Cask
index 599efa2..60a064c 100644
--- a/Cask
+++ b/Cask
@@ -4,6 +4,9 @@
(package-file "lisp/mastodon.el")
(files "lisp/*.el")
+(depends-on "request")
+(depends-on "seq")
+
(development
(depends-on "ert-runner")
(depends-on "el-mock")
diff --git a/README.org b/README.org
index baa627e..88e8c41 100644
--- a/README.org
+++ b/README.org
@@ -1,13 +1,91 @@
-* mastodon.el
+#+OPTIONS: toc:nil
-[[https://melpa.org/#/mastodon][file:https://melpa.org/packages/mastodon-badge.svg]]
+* mastodon.el fork
-[[https://travis-ci.org/jdenen/mastodon.el][https://travis-ci.org/jdenen/mastodon.el.svg?branch=master]]
-[[http://waffle.io/jdenen/mastodon.el][https://badge.waffle.io/jdenen/mastodon.el.png?label=in%20progress&title=In%20Progress]]
+This is a fork of of the great but seemingly dormant https://github.com/jdenen/mastodon.el.
-Emacs client for [[https://github.com/tootsuite/mastodon][Mastodon]]
+It adds the following features:
-[[http://spacemacs.org][https://cdn.rawgit.com/syl20bnr/spacemacs/442d025779da2f62fc86c2082703697714db6514/assets/spacemacs-badge.svg]]
+| Profiles: | |
+| | display profile metadata fields |
+| | display pinned toots first |
+| | display relationship (follows you/followed by you) |
+| | display toots/follows/followers counts |
+| | links/tags/mentions in profile bios are active links |
+| | show a lock icon for locked accounts |
+| =R=, =C-c a=, =C-c r= | view/accept/reject follow requests |
+| =V= | view your favorited toots |
+| =i= | toggle pinning of toots |
+| =S-C-P= | jump to your profile |
+| =U= | update your profile bio note |
+| =O= | jump to own profile |
+| Notifications: | |
+| | follow requests now also appear in notifications |
+| =a=, =r= | accept/reject follow request |
+| | notifications for when a user posts (=mastodon-tl--enable-notify-user-posts=) |
+| Timelines: | |
+| =C= | copy url of toot at point |
+| =d= | delete your toot at point, and reload current timeline |
+| =D= | delete and redraft toot at point, preserving reply/CW/visibility |
+| =W=, =M=, =B= | (un)follow, (un)mute, (un)block author of toot at point |
+| =k=, =K= | toggle bookmark of toot at point, view bookmarked toots |
+| | display polls and vote on them |
+| | images are links to the full image, can be zoomed/rotated/saved (see image keymap) |
+| | images scale properly |
+| | toot visibility (direct, followers only) icon appears in toot bylines |
+| | display toot's number of favorites, boosts and replies |
+| | customize option to cache images |
+| Toots: | |
+| | mention booster in replies by default |
+| | replies preserve visibility status/CW of original toot |
+| | autocompletion of user mentions, via =company-mode= (must be installed to work) |
+| =C-c C-a= | media uploads, asynchronous |
+| | media upload previews displayed in toot compose buffer |
+| =C-c C-n= | and sensitive media/nsfw flag |
+| =C-c C-e= | add emoji (if =emojify= installed) |
+| | download and use your instance's custom emoji |
+| | server's maximum toot length shown in toot compose buffer |
+| Search: | |
+| =S= | search (posts, users, tags) (NB: only posts you have interacted with are searched) |
+| | |
+
+It also makes some small cosmetic changes to make timelines easier to read, and makes some functions asynchronous, based on https://github.com/ieure/mastodon.el.
+
+This updated version is not on MELPA, to use it you need to clone and require it as per the installation instructions below.
+
+The minimum Emacs version is now 26.1. But if you are running an older version it shouldn't be very hard to get it working.
+
+I did this for my own use and to learn more Elisp. Feel free to improve it.
+
+** live-updating timelines: =mastodon-async-mode=
+
+(code taken from https://github.com/alexjgriffith/mastodon-future.el.)
+
+Works for federated, local, and home timelines and for notifications. It's pretty necro, sometimes it goes off the rails, so use at your own risk. Not a super high priority for me, but some people dig it.
+
+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-=.
+
+** NB: dependency
+
+This version depends on the library =request= (for uploading attachments). You can install it from MELPA, or https://github.com/tkf/emacs-request.
+
+** NB: bugs
+
+This repo also incorporates fixes for two bugs that were never merged into the upstream repo:
+- https://github.com/jdenen/mastodon.el/issues/227 (and https://github.com/jdenen/mastodon.el/issues/234)
+- https://github.com/jdenen/mastodon.el/issues/228
+
+** 2FA
+
+It looks like 2-factor auth was never completed in the original repo. It's not a priority for me, auth ain't my thing. If you want to hack on it, its on the develop branch in the original repo.
+
+** contributing
+
+Contributions are welcome. Registration is disabled by default on the gitea instance, but if you are interested, get in touch with me on mastodon:
+
+[[https://todon.nl/@mousebot][@mousebot@todon.nl]]
+
+* Original README
** Installation
diff --git a/lisp/mastodon-async.el b/lisp/mastodon-async.el
new file mode 100644
index 0000000..6ff09e3
--- /dev/null
+++ b/lisp/mastodon-async.el
@@ -0,0 +1,372 @@
+;;; mastodon-async.el --- Client for Mastodon -*- lexical-binding: t -*-
+
+;; Copyright (C) 2017 Johnson Denen
+;; Author: Johnson Denen <johnson.denen@gmail.com>
+;; Alex J. Griffith <griffitaj@gmail.com>
+;; Maintainer: Marty Hiatt <martianhiatus@riseup.net>
+;; Version: 0.10.0
+;; Package-Requires: ((emacs "27.1"))
+;; Homepage: https://git.blast.noho.st/mouse/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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Rework sync code so it does not mess up the async-buffer
+
+;;; Code:
+
+(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 (equal "" 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
+ ((equal name "notifications") "notifications")
+ ((equal 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 (equal 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)
+ (setq mastodon-tl--buffer-spec
+ `(buffer-name
+ ,buffer-name
+ endpoint ,endpoint
+ update-function
+ ,(if (equal 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 (equal "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 (equal "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 (equal 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/lisp/mastodon-auth.el b/lisp/mastodon-auth.el
index cfe89b5..a3d51fa 100644
--- a/lisp/mastodon-auth.el
+++ b/lisp/mastodon-auth.el
@@ -2,9 +2,10 @@
;; Copyright (C) 2017-2019 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.9.0
-;; Homepage: https://github.com/jdenen/mastodon.el
-;; Package-Requires: ((emacs "24.4"))
+;; Maintainer: Marty Hiatt <martianhiatus@riseup.net>
+;; Version: 0.10.0
+;; Package-Requires: ((emacs "27.1"))
+;; Homepage: https://git.blast.noho.st/mouse/mastodon.el
;; This file is not part of GNU Emacs.
@@ -32,6 +33,7 @@
(require 'plstore)
(require 'auth-source)
(require 'json)
+(eval-when-compile (require 'subr-x)) ; for if-let
(autoload 'mastodon-client "mastodon-client")
(autoload 'mastodon-http--api "mastodon-http")
@@ -60,14 +62,19 @@ if you are happy with unencryped storage use e.g. \"~/authinfo\"."
"Alist of account accts (name@domain) keyed by instance url.")
(defun mastodon-auth--generate-token ()
- "Make POST to generate auth token."
+ "Make POST to generate auth token.
+
+If no auth-sources file, runs
+`mastodon-auth--generate-token-no-storing-credentials'. If
+auth-sources file exists, runs
+`mastodon-auth--generate-token-and-store'."
(if (or (null mastodon-auth-source-file)
(string= "" mastodon-auth-source-file))
(mastodon-auth--generate-token-no-storing-credentials)
(mastodon-auth--generate-token-and-store)))
(defun mastodon-auth--generate-token-no-storing-credentials ()
- "Make POST to generate auth token."
+ "Make POST to generate auth token, without using auth-sources file."
(mastodon-http--post
(concat mastodon-instance-url "/oauth/token")
`(("client_id" . ,(plist-get (mastodon-client) :client_id))
@@ -82,7 +89,7 @@ if you are happy with unencryped storage use e.g. \"~/authinfo\"."
(defun mastodon-auth--generate-token-and-store ()
"Make POST to generate auth token.
-Reads and/or stores secres in `MASTODON-AUTH-SOURCE-FILE'."
+Reads and/or stores secrets in `MASTODON-AUTH-SOURCE-FILE'."
(let* ((auth-sources (list mastodon-auth-source-file))
(auth-source-creation-prompts
'((user . "Enter email for %h: ")
@@ -110,7 +117,7 @@ Reads and/or stores secres in `MASTODON-AUTH-SOURCE-FILE'."
(funcall (plist-get credentials-plist :save-function))))))
(defun mastodon-auth--get-token ()
- "Make auth token request and return JSON response."
+ "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)
@@ -121,15 +128,23 @@ Reads and/or stores secres in `MASTODON-AUTH-SOURCE-FILE'."
(json-read-from-string json-string))))
(defun mastodon-auth--access-token ()
- "Return the access token to use with the current `mastodon-instance-url'.
+ "Return exiting or generate new access token.
-Generate token and set if none known yet."
+If an access token for `mastodon-instance-url' is in
+`mastodon-auth--token-alist', return it.
+
+Otherwise, generate a token and pass it to
+`mastodon-auth--handle-token-reponse'."
(if-let ((token (cdr (assoc mastodon-instance-url mastodon-auth--token-alist))))
token
-
(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))
@@ -137,21 +152,20 @@ Generate token and set if none known yet."
mastodon-auth--token-alist)))
(`(:error ,class :error_description ,error)
- (error "mastodon-auth--access-token: %s: %s" class 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."
- (cdr (assoc
- 'acct
- (mastodon-http--get-json
- (mastodon-http--api
- "accounts/verify_credentials")))))
+ (alist-get
+ 'acct
+ (mastodon-http--get-json
+ (mastodon-http--api
+ "accounts/verify_credentials"))))
(defun mastodon-auth--user-acct ()
"Return a mastodon user acct name."
- (or (cdr (assoc mastodon-instance-url mastodon-auth--acct-alist))
+ (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)))
diff --git a/lisp/mastodon-client.el b/lisp/mastodon-client.el
index da70dea..b27d434 100644
--- a/lisp/mastodon-client.el
+++ b/lisp/mastodon-client.el
@@ -2,9 +2,10 @@
;; Copyright (C) 2017-2019 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.9.0
-;; Homepage: https://github.com/jdenen/mastodon.el
-;; Package-Requires: ((emacs "24.4"))
+;; Maintainer: Marty Hiatt <martianhiatus@riseup.net>
+;; Version: 0.10.0
+;; Package-Requires: ((emacs "27.1"))
+;; Homepage: https://git.blast.noho.st/mouse/mastodon.el
;; This file is not part of GNU Emacs.
@@ -94,7 +95,7 @@ Make `mastodon-client--fetch' call to determine client values."
(cdr mastodon)))
(defun mastodon-client ()
- "Return variable client secrets to use for the current `mastodon-instance-url'..
+ "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."
diff --git a/lisp/mastodon-discover.el b/lisp/mastodon-discover.el
index a99ddc2..10abc59 100644
--- a/lisp/mastodon-discover.el
+++ b/lisp/mastodon-discover.el
@@ -2,9 +2,10 @@
;; Copyright (C) 2019 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.9.0
-;; Package-Requires: ((emacs "24.4"))
-;; Homepage: https://github.com/jdenen/mastodon.el
+;; Maintainer: Marty Hiatt <martianhiatus@riseup.net>
+;; Version: 0.10.0
+;; Package-Requires: ((emacs "27.1"))
+;; Homepage: https://git.blast.noho.st/mouse/mastodon.el
;; This file is not part of GNU Emacs.
@@ -32,6 +33,8 @@
;;; Code:
+(declare-function discover-add-context-menu "discover")
+
(defun mastodon-discover ()
"Plug Mastodon functionality into `discover'."
(interactive)
@@ -44,25 +47,57 @@
(description "Mastodon feed viewer")
(actions
("Toots"
- ("A" "Author" mastodon-profile--get-toot-author)
+ ("A" "View profile of author" mastodon-profile--get-toot-author)
("b" "Boost" mastodon-toot--boost)
- ("c" "Toggle content" mastodon-tl--toggle-spoiler-text-in-toot)
("f" "Favourite" mastodon-toot--favourite)
+ ("c" "Toggle hidden text (CW)" mastodon-tl--toggle-spoiler-text-in-toot)
("n" "Next" mastodon-tl--goto-next-toot)
("p" "Prev" mastodon-tl--goto-prev-toot)
- ("t" "Toot" mastodon-toot)
+ ("TAB" "Next link item" mastodon-tl--next-tab-item)
+ ("S-TAB" "Prev link item" mastodon-tl--previous-tab-item)
+ ("t" "New toot" mastodon-toot)
("r" "Reply" mastodon-toot--reply)
- ("u" "Update" mastodon-tl--update)
- ("P" "Users" mastodon-profile--show-user)
- ("T" "Thread" mastodon-tl--thread))
+ ("C" "Copy toot URL" mastodon-toot--copy-toot-url)
+ ("d" "Delete (your) toot" mastodon-toot--delete-toot)
+ ("D" "Delete and redraft (your) toot" mastodon-toot--delete-toot)
+ ("i" "Pin/Unpin (your) toot" mastodon-toot--pin-toot-toggle)
+ ("P" "View user profile" mastodon-profile--show-user)
+ ("T" "View thread" mastodon-tl--thread)
+ ("v" "Vote on poll" mastodon-tl--poll-vote))
("Timelines"
- ("#" "Tag" mastodon-tl--get-tag-timeline)
+ ("h" "View mode help/keybindings" describe-mode)
+ ("#" "Tag search" mastodon-tl--get-tag-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))
+ ("N" "Notifications" mastodon-notifications--get)
+ ("u" "Update timeline" mastodon-tl--update)
+ ("S" "Search" mastodon-search--search-query)
+ ("C-S-P" "Jump to your profile" mastodon-profile--my-profile)
+ ("K" "View bookmarks" mastodon-profile--view-bookmarks))
+ ("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/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"
+ ("o" "Show following" mastodon-profile--open-following)
+ ("O" "Show followers" mastodon-profile--open-followers)
+
+ ("R" "View follow requests" mastodon-profile--view-follow-requests)
+ ("a" "Accept follow request" mastodon-profile--follow-request-accept)
+ ("j" "Reject follow request" mastodon-profile--follow-request-reject)
+ ("U" "Update your profile note" mastodon-profile--update-user-profile-note))
("Quit"
- ("q" "Quit mastodon buffer. Leave window open." kill-this-buffer)
+ ("q" "Quit mastodon and bury buffer." kill-this-buffer)
("Q" "Quit mastodon buffer and kill window." kill-buffer-and-window)))))))
(provide 'mastodon-discover)
diff --git a/lisp/mastodon-http.el b/lisp/mastodon-http.el
index ba0a259..c0fa101 100644
--- a/lisp/mastodon-http.el
+++ b/lisp/mastodon-http.el
@@ -2,9 +2,10 @@
;; Copyright (C) 2017-2019 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.9.0
-;; Package-Requires: ((emacs "24.4"))
-;; Homepage: https://github.com/jdenen/mastodon.el
+;; Maintainer: Marty Hiatt <martianhiatus@riseup.net>
+;; Version: 0.10.0
+;; Package-Requires: ((emacs "27.1") (request "0.3.0"))
+;; Homepage: https://git.blast.noho.st/mouse/mastodon.el
;; This file is not part of GNU Emacs.
@@ -30,16 +31,23 @@
;;; Code:
(require 'json)
+(require 'request) ; for attachments upload
+
(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 5
+(defconst mastodon-http--timeout 15
"HTTP request timeout, in seconds. Has no effect on Emacs < 26.1.")
(defun mastodon-http--api (endpoint)
- "Return Mastondon API URL for ENDPOINT."
+ "Return Mastodon API URL for ENDPOINT."
(concat mastodon-instance-url "/api/"
mastodon-http--api-version "/" endpoint))
@@ -60,15 +68,33 @@
(string-match "[0-9][0-9][0-9]" status-line)
(match-string 0 status-line)))
+(defun mastodon-http--url-retrieve-synchronously (url)
+ "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."
+ (if (< (cdr (func-arity 'url-retrieve-synchronously)) 4)
+ (url-retrieve-synchronously url)
+ (url-retrieve-synchronously url nil nil mastodon-http--timeout)))
+
(defun mastodon-http--triage (response success)
"Determine if RESPONSE was successful. Call SUCCESS if successful.
-Open RESPONSE buffer if unsuccessful."
+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)
- (switch-to-buffer response))))
+ (switch-to-buffer response)
+ (let ((json-response (mastodon-http--process-json)))
+ (message "Error %s: %s" status (alist-get 'error json-response))))))
+
+(defun mastodon-http--read-file-as-string (filename)
+ "Read a file FILENAME as a string. Used to generate image preview."
+ (with-temp-buffer
+ (insert-file-contents filename)
+ (string-to-unibyte (buffer-string))))
(defun mastodon-http--post (url args headers &optional unauthenticed-p)
"POST synchronously to URL with ARGS and HEADERS.
@@ -91,35 +117,182 @@ Authorization header is included by default unless UNAUTHENTICED-P is non-nil."
'(("Content-Type" . "application/x-www-form-urlencoded")))
headers)))
(with-temp-buffer
- (if (< (cdr (func-arity 'url-retrieve-synchronously)) 4)
- (url-retrieve-synchronously url)
- (url-retrieve-synchronously url nil nil mastodon-http--timeout)))))
+ (mastodon-http--url-retrieve-synchronously url))))
(defun mastodon-http--get (url)
- "Make GET request to URL.
+ "Make synchronous GET request to URL.
Pass response buffer to CALLBACK function."
(let ((url-request-method "GET")
(url-request-extra-headers
`(("Authorization" . ,(concat "Bearer "
(mastodon-auth--access-token))))))
- (if (< (cdr (func-arity 'url-retrieve-synchronously)) 4)
- (url-retrieve-synchronously url)
- (url-retrieve-synchronously url nil nil mastodon-http--timeout))))
+ (mastodon-http--url-retrieve-synchronously url)))
(defun mastodon-http--get-json (url)
- "Make GET request to URL. Return JSON response vector."
- (let ((json-vector
- (with-current-buffer (mastodon-http--get url)
- (goto-char (point-min))
- (re-search-forward "^$" nil 'move)
- (let ((json-string
- (decode-coding-string
- (buffer-substring-no-properties (point) (point-max))
- 'utf-8)))
- (kill-buffer)
- (json-read-from-string json-string)))))
- json-vector))
+ "Make synchronous GET request to URL. Return JSON response."
+ (with-current-buffer (mastodon-http--get url)
+ (mastodon-http--process-json)))
+
+(defun mastodon-http--process-json ()
+ "Process JSON response."
+ (goto-char (point-min))
+ (re-search-forward "^$" nil 'move)
+ (let ((json-string
+ (decode-coding-string
+ (buffer-substring-no-properties (point) (point-max))
+ 'utf-8)))
+ (kill-buffer)
+ (unless (or (string-equal "" json-string) (null json-string))
+ (json-read-from-string json-string))))
+
+(defun mastodon-http--delete (url)
+ "Make DELETE request to URL."
+ (let ((url-request-method "DELETE")
+ (url-request-extra-headers
+ `(("Authorization" . ,(concat "Bearer "
+ (mastodon-auth--access-token))))))
+ (with-temp-buffer
+ (mastodon-http--url-retrieve-synchronously url))))
+
+;; search functions:
+(defun mastodon-http--process-json-search ()
+ "Process JSON returned by a search query to the server."
+ (goto-char (point-min))
+ (re-search-forward "^$" nil 'move)
+ (let ((json-string
+ (decode-coding-string
+ (buffer-substring-no-properties (point) (point-max))
+ 'utf-8)))
+ (kill-buffer)
+ (json-read-from-string json-string)))
+
+(defun mastodon-http--get-search-json (url query &optional param)
+ "Make GET request to URL, searching for QUERY and return JSON response.
+PARAM is any extra parameters to send with the request."
+ (let ((buffer (mastodon-http--get-search url query param)))
+ (with-current-buffer buffer
+ (mastodon-http--process-json-search))))
+
+(defun mastodon-http--get-search (base-url query &optional param)
+ "Make GET request to BASE-URL, searching for QUERY.
+Pass response buffer to CALLBACK function.
+PARAM is a formatted request parameter, eg 'following=true'."
+ (let ((url-request-method "GET")
+ (url (if param
+ (concat base-url "?" param "&q=" (url-hexify-string query))
+ (concat base-url "?q=" (url-hexify-string query))))
+ (url-request-extra-headers
+ `(("Authorization" . ,(concat "Bearer "
+ (mastodon-auth--access-token))))))
+ (mastodon-http--url-retrieve-synchronously url)))
+
+;; profile update functions
+
+(defun mastodon-http--patch-json (url)
+ "Make synchronous PATCH request to URL. Return JSON response."
+ (with-current-buffer (mastodon-http--patch url)
+ (mastodon-http--process-json)))
+
+;; hard coded just for bio note for now:
+(defun mastodon-http--patch (base-url &optional note)
+ "Make synchronous PATCH request to BASE-URL.
+Optionally specify the NOTE to edit.
+Pass response buffer to CALLBACK function."
+ (let ((url-request-method "PATCH")
+ (url (if note
+ (concat base-url "?note=" (url-hexify-string note))
+ base-url))
+ (url-request-extra-headers
+ `(("Authorization" . ,(concat "Bearer "
+ (mastodon-auth--access-token))))))
+ (mastodon-http--url-retrieve-synchronously url)))
+
+ ;; Asynchronous functions
+
+(defun mastodon-http--get-async (url &optional callback &rest cbargs)
+ "Make GET request to URL.
+Pass response buffer to CALLBACK function with args CBARGS."
+ (let ((url-request-method "GET")
+ (url-request-extra-headers
+ `(("Authorization" . ,(concat "Bearer "
+ (mastodon-auth--access-token))))))
+ (url-retrieve url callback cbargs)))
+
+(defun mastodon-http--get-json-async (url &optional callback &rest args)
+ "Make GET request to URL. Call CALLBACK with json-vector and ARGS."
+ (mastodon-http--get-async
+ url
+ (lambda (status)
+ (when status ;; only when we actually get sth?
+ (apply callback (mastodon-http--process-json) args)))))
+
+(defun mastodon-http--post-async (url args headers &optional callback &rest cbargs)
+ "POST asynchronously to URL with ARGS and HEADERS.
+Then run function CALLBACK with arguements CBARGS.
+Authorization header is included by default unless UNAUTHENTICED-P is non-nil."
+ (let ((url-request-method "POST")
+ (request-timeout 5)
+ (url-request-data
+ (when args
+ (mapconcat (lambda (arg)
+ (concat (url-hexify-string (car arg))
+ "="
+ (url-hexify-string (cdr arg))))
+ args
+ "&")))
+ (url-request-extra-headers
+ (append `(("Authorization" . ,(concat "Bearer " (mastodon-auth--access-token))))
+ headers)))
+ (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))
+ (request
+ url
+ :type "POST"
+ :params `(("description" . ,caption))
+ :files `(("file" . (,file :file ,filename
+ :mime-type "multipart/form-data")))
+ :parser 'json-read
+ :headers `(("Authorization" . ,(concat "Bearer "
+ (mastodon-auth--access-token))))
+ :sync nil
+ :success (cl-function
+ (lambda (&key data &allow-other-keys)
+ (when data
+ (push (alist-get 'id data)
+ mastodon-toot--media-attachment-ids) ; add ID to list
+ (message "%s file %s with id %S and caption '%s' uploaded!"
+ (capitalize (alist-get 'type data))
+ file
+ (alist-get 'id data)
+ (alist-get 'description data))
+ (mastodon-toot--update-status-fields))))
+ :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/lisp/mastodon-inspect.el b/lisp/mastodon-inspect.el
index 44b9344..b0270ee 100644
--- a/lisp/mastodon-inspect.el
+++ b/lisp/mastodon-inspect.el
@@ -2,9 +2,10 @@
;; Copyright (C) 2017-2019 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.9.0
-;; Package-Requires: ((emacs "24.4"))
-;; Homepage: https://github.com/jdenen/mastodon.el
+;; Maintainer: Marty Hiatt <martianhiatus@riseup.net>
+;; Version: 0.10.0
+;; Package-Requires: ((emacs "27.1"))
+;; Homepage: https://git.blast.noho.st/mouse/mastodon.el
;; This file is not part of GNU Emacs.
@@ -30,12 +31,15 @@
;;; 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-"
@@ -59,7 +63,7 @@
(concat "*mastodon-inspect-toot-"
(mastodon-tl--as-string (mastodon-tl--property 'toot-id))
"*")
- (mastodon-tl--property 'toot-json)))
+ (mastodon-tl--property 'toot-json)))
(defun mastodon-inspect--download-single-toot (toot-id)
"Download the toot/status represented by TOOT-ID."
@@ -69,7 +73,7 @@
(defun mastodon-inspect--view-single-toot (toot-id)
"View the toot/status represented by TOOT-ID."
(interactive "s Toot ID: ")
- (let ((buffer (get-buffer-create(concat "*mastodon-status-" toot-id "*"))))
+ (let ((buffer (get-buffer-create (concat "*mastodon-status-" toot-id "*"))))
(with-current-buffer buffer
(let ((toot (mastodon-inspect--download-single-toot toot-id )))
(mastodon-tl--toot toot)
@@ -87,5 +91,39 @@
(concat "*mastodon-status-raw-" toot-id "*")
(mastodon-inspect--download-single-toot toot-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/lisp/mastodon-media.el b/lisp/mastodon-media.el
index 7a11660..acce473 100644
--- a/lisp/mastodon-media.el
+++ b/lisp/mastodon-media.el
@@ -2,9 +2,10 @@
;; Copyright (C) 2017-2019 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.9.0
-;; Homepage: https://github.com/jdenen/mastodon.el
-;; Package-Requires: ((emacs "24.4"))
+;; Maintainer: Marty Hiatt <martianhiatus@riseup.net>
+;; Version: 0.10.0
+;; Package-Requires: ((emacs "27.1"))
+;; Homepage: https://git.blast.noho.st/mouse/mastodon.el
;; This file is not part of GNU Emacs.
@@ -32,23 +33,32 @@
;; required by the server and client.
;;; Code:
+(require 'url-cache)
+
(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 30
+(defcustom mastodon-media--avatar-height 20
"Height of the user avatar images (if shown)."
:group 'mastodon-media
:type 'integer)
(defcustom mastodon-media--preview-max-height 250
- "Max height of any media attachment preview to be shown."
+ "Max height of any media attachment preview to be shown in timelines."
:group 'mastodon-media
:type 'integer)
+(defcustom mastodon-media--enable-image-caching nil
+ "Whether images should be cached."
+ :group 'mastodon-media
+ :type 'boolean)
+
(defvar mastodon-media--generic-avatar-data
(base64-decode-string
"iVBORw0KGgoAAAANSUhEUgAAAGQAAABkCAIAAAD/gAIDAAAACXBIWXMAAAsTAAALEwEAmpwYAAAA
@@ -85,7 +95,7 @@ m836fL6tra0jYkUiEb/fz8k3waLhikQiXq+3/NtiSayNjY1fv35BbVP5fN7pdG5tbR0Fy+12c360
Hxzz5a8KI6V6EMMwzo/2fZ2YTqej0WgqlSoVLqRUDwYCAajNiqKoYDBYphOLY8ViscItVG1VJEmu
r6+XeU8sjhWPxzc3N9sNiyAIDMOqS1YbDqwKx1YRrFQqxc7HJDRnpdPpUuEqgoVhWL0+i6hFz6tL
ja3iM4u1zw1qwhlfJihI0bfCNhxYe4NSqg3/A862hQAbrdtHAAAAAElFTkSuQmCC")
- "The PNG data for a generic 100x100 avatar")
+ "The PNG data for a generic 100x100 avatar.")
(defvar mastodon-media--generic-broken-image-data
(base64-decode-string
@@ -125,17 +135,17 @@ CAQgEIBAAAIBFiNOFMaY6V1tnFhkDQIQCEAgAIEABAKAQAACAQgEIBCAQAACAQgEIBCAQABIXO4e
c1y+zhoEIBCAQAAQCEAgAIEABAIQCEAgAIEABAIQCEAgAAgEIBCAQAACAQgEIBCAQAACAQgEAIEA
BAIQCEAgAIEABAIsJVH58WqHw8FIgjUIQCAACAQgEIBAAAIBCAQgEIBAAAIBCAQgEAAEAhAIQCBA
fKRJkmVZjAQwh78A6vCRWJE8K+8AAAAASUVORK5CYII=")
- "The PNG data for a generic 200x200 'broken image' view")
+ "The PNG data for a generic 200x200 'broken image' view.")
(defun mastodon-media--process-image-response
- (status-plist marker image-options region-length)
+ (status-plist marker image-options region-length url)
"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.
-"
+REGION-LENGTH is the length of the region that should be replaced
+with the image."
(when (marker-buffer marker) ; only if the buffer hasn't been kill in the meantime
(let ((url-buffer (current-buffer))
(is-error-response-p (eq :error (car status-plist))))
@@ -145,8 +155,14 @@ REGION-LENGTH is the length of the region that should be replaced with the image
(search-forward "\n\n")
(buffer-substring (point) (point-max))))
(image (when data
- (apply #'create-image data (when image-options 'imagemagick)
+ (apply #'create-image data
+ (if (version< emacs-version "27.1")
+ (when image-options 'imagemagick)
+ nil) ; inbuilt scaling in 27.1
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))
@@ -165,11 +181,14 @@ REGION-LENGTH is the length of the region that should be replaced with the image
(kill-buffer url-buffer)))))))
(defun mastodon-media--load-image-from-url (url media-type start region-length)
- "Takes a URL and MEDIA-TYPE and load the image asynchronously.
+ "Take a URL and MEDIA-TYPE and load the image asynchronously.
-MEDIA-TYPE is a symbol and either 'avatar or 'media-link."
+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."
;; TODO: Cache the avatars
- (let ((image-options (when (image-type-available-p 'imagemagick)
+ (let ((image-options (when (or (image-type-available-p 'imagemagick)
+ (image-transforms-p)) ; inbuilt scaling in 27.1
(cond
((eq media-type 'avatar)
`(:height ,mastodon-media--avatar-height))
@@ -182,9 +201,18 @@ MEDIA-TYPE is a symbol and either 'avatar or 'media-link."
(condition-case nil
;; catch any errors in url-retrieve so as to not abort
;; whatever called us
- (url-retrieve url
- #'mastodon-media--process-image-response
- (list marker image-options region-length))
+ (if (and mastodon-media--enable-image-caching
+ (url-is-cached url))
+ ;; if image url is cached, decompress and use it
+ (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))
+ (mastodon-media--process-image-response nil marker image-options region-length url))
+ ;; else fetch as usual and process-image-response will cache it
+ (url-retrieve url
+ #'mastodon-media--process-image-response
+ (list marker image-options region-length url)))
(error (with-current-buffer buffer
;; TODO: Consider adding retries
(put-text-property marker
@@ -212,22 +240,22 @@ found."
;; Avatars are just one character in the buffer
((eq media-type 'avatar)
(list next-pos (+ next-pos 1) 'avatar))
- ;; Media links are 5 character ("[img]")
+ ;; Media links are 5 character ("[img]")
((eq media-type 'media-link)
(list next-pos (+ next-pos 5) 'media-link)))))))
(defun mastodon-media--valid-link-p (link)
- "Checks to make sure that the missing string has
+ "Check if LINK is valid.
-not been returned."
+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
-replacing them with the referenced image."
+ "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)
@@ -246,11 +274,12 @@ replacing them with the referenced image."
image-url media-type start (- end start))))))))
(defun mastodon-media--get-avatar-rendering (avatar-url)
- "Returns the string to be written that renders the avatar at 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 (image-type-available-p 'imagemagick)
+ (let ((image-options (when (or (image-type-available-p 'imagemagick)
+ (image-transforms-p)) ; inbuilt scaling in 27.1
`(:height ,mastodon-media--avatar-height))))
(concat
(propertize " "
@@ -258,19 +287,33 @@ replacing them with the referenced image."
'media-state 'needs-loading
'media-type 'avatar
'display (apply #'create-image mastodon-media--generic-avatar-data
- (when image-options 'imagemagick)
+ (if (version< emacs-version "27.1")
+ (when image-options 'imagemagick)
+ nil) ; inbuilt scaling in 27.1
t image-options))
" ")))
-(defun mastodon-media--get-media-link-rendering (media-url)
- "Returns the string to be written that renders the image at MEDIA-URL."
- (concat
- (propertize "[img]"
- 'media-url media-url
- 'media-state 'needs-loading
- 'media-type 'media-link
- 'display (create-image mastodon-media--generic-broken-image-data nil t))
- " "))
+(defun mastodon-media--get-media-link-rendering (media-url &optional full-remote-url type)
+ "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."
+ (let ((help-echo
+ "RET/i: load full image (prefix: copy URL), +/-: zoom, r: rotate, o: save preview"))
+ (concat
+ (propertize "[img]"
+ 'media-url media-url
+ 'media-state 'needs-loading
+ 'media-type 'media-link
+ 'mastodon-media-type type
+ 'display (create-image mastodon-media--generic-broken-image-data nil t)
+ 'mouse-face 'highlight
+ 'mastodon-tab-stop 'image ; for do-link-action-at-point
+ 'image-url full-remote-url ; for shr-browse-image
+ 'keymap mastodon-tl--shr-image-map-replacement
+ 'help-echo (if (string= type "image")
+ help-echo
+ (concat help-echo "\ntype: " type)))
+ " ")))
(provide 'mastodon-media)
;;; mastodon-media.el ends here
diff --git a/lisp/mastodon-notifications.el b/lisp/mastodon-notifications.el
index 4d68437..bb05103 100644
--- a/lisp/mastodon-notifications.el
+++ b/lisp/mastodon-notifications.el
@@ -2,9 +2,10 @@
;; Copyright (C) 2017-2019 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.7.2
-;; Homepage: https://github.com/jdenen/mastodon.el
-;; Package-Requires: ((emacs "24.4"))
+;; Maintainer: Marty Hiatt <martianhiatus@riseup.net>
+;; Version: 0.10.0
+;; Package-Requires: ((emacs "27.1"))
+;; Homepage: https://git.blast.noho.st/mouse/mastodon.el
;; This file is not part of GNU Emacs.
@@ -29,30 +30,41 @@
;;; Code:
+(autoload 'mastodon-http--api "mastodon-http.el")
+(autoload 'mastodon-http--post "mastodon-http.el")
+(autoload 'mastodon-http--triage "mastodon-http.el")
(autoload 'mastodon-media--inline-images "mastodon-media.el")
+(autoload 'mastodon-tl--byline "mastodon-tl.el")
(autoload 'mastodon-tl--byline-author "mastodon-tl.el")
(autoload 'mastodon-tl--clean-tabs-and-nl "mastodon-tl.el")
(autoload 'mastodon-tl--content "mastodon-tl.el")
(autoload 'mastodon-tl--field "mastodon-tl.el")
+(autoload 'mastodon-tl--find-property-range "mastodon-tl.el")
(autoload 'mastodon-tl--has-spoiler "mastodon-tl.el")
(autoload 'mastodon-tl--init "mastodon-tl.el")
+(autoload 'mastodon-tl--init-sync "mastodon-tl.el")
(autoload 'mastodon-tl--insert-status "mastodon-tl.el")
+(autoload 'mastodon-tl--property "mastodon-tl.el")
(autoload 'mastodon-tl--spoiler "mastodon-tl.el")
+(autoload 'mastodon-tl--toot-id "mastodon-tl.el")
(defvar mastodon-tl--display-media-p)
-
(defvar mastodon-notifications--types-alist
'(("mention" . mastodon-notifications--mention)
("follow" . mastodon-notifications--follow)
("favourite" . mastodon-notifications--favourite)
- ("reblog" . mastodon-notifications--reblog))
+ ("reblog" . mastodon-notifications--reblog)
+ ("follow_request" . mastodon-notifications--follow-request)
+ ("status" . mastodon-notifications--status))
"Alist of notification types and their corresponding function.")
(defvar mastodon-notifications--response-alist
'(("Mentioned" . "you")
("Followed" . "you")
- ("Favourited" . "your status")
- ("Boosted" . "your status"))
+ ("Favourited" . "your status from")
+ ("Boosted" . "your status from")
+ ("Requested to follow" . "you")
+ ("Posted" . "a post"))
"Alist of subjects for notification types.")
(defun mastodon-notifications--byline-concat (message)
@@ -63,10 +75,63 @@
" "
(cdr (assoc message mastodon-notifications--response-alist))))
+(defun mastodon-notifications--follow-request-accept-notifs ()
+ "Accept the follow request of user at point, in notifications view."
+ (interactive)
+ (when (mastodon-tl--find-property-range 'toot-json (point))
+ (let* ((toot-json (mastodon-tl--property 'toot-json))
+ (f-req-p (string= "follow_request" (alist-get 'type toot-json))))
+ (if f-req-p
+ (let* ((account (alist-get 'account toot-json))
+ (id (alist-get 'id account))
+ (handle (alist-get 'acct account))
+ (name (alist-get 'username account)))
+ (if id
+ (let ((response
+ (mastodon-http--post
+ (concat
+ (mastodon-http--api "follow_requests")
+ (format "/%s/authorize" id))
+ nil nil)))
+ (mastodon-http--triage response
+ (lambda ()
+ (mastodon-notifications--get)
+ (message "Follow request of %s (@%s) accepted!"
+ name handle))))
+ (message "No account result at point?")))
+ (message "No follow request at point?")))))
+
+(defun mastodon-notifications--follow-request-reject-notifs ()
+ "Reject the follow request of user at point, in notifications view."
+ (interactive)
+ (when (mastodon-tl--find-property-range 'toot-json (point))
+ (let* ((toot-json (mastodon-tl--property 'toot-json))
+ (f-req-p (string= "follow_request" (alist-get 'type toot-json))))
+ (if f-req-p
+ (let* ((account (alist-get 'account toot-json))
+ (id (alist-get 'id account))
+ (handle (alist-get 'acct account))
+ (name (alist-get 'username account)))
+ (if id
+ (let ((response
+ (mastodon-http--post
+ (concat
+ (mastodon-http--api "follow_requests")
+ (format "/%s/reject" id))
+ nil nil)))
+ (mastodon-http--triage response
+ (lambda ()
+ (mastodon-notifications--get)
+ (message "Follow request of %s (@%s) rejected!"
+ name handle))))
+ (message "No account result at point?")))
+ (message "No follow request at point?")))))
+
(defun mastodon-notifications--mention (note)
"Format for a `mention' NOTE."
- (let ((status (mastodon-tl--field 'status note)))
- (mastodon-tl--insert-status
+ (let ((id (alist-get 'id note))
+ (status (mastodon-tl--field 'status note)))
+ (mastodon-notifications--insert-status
status
(mastodon-tl--clean-tabs-and-nl
(if (mastodon-tl--has-spoiler status)
@@ -75,7 +140,8 @@
'mastodon-tl--byline-author
(lambda (_status)
(mastodon-notifications--byline-concat
- "Mentioned")))))
+ "Mentioned"))
+ id)))
(defun mastodon-notifications--follow (note)
"Format for a `follow' NOTE."
@@ -90,10 +156,25 @@
(mastodon-notifications--byline-concat
"Followed"))))
+(defun mastodon-notifications--follow-request (note)
+ "Format for a `follow-request' NOTE."
+ (let ((id (alist-get 'id note))
+ (follower (alist-get 'username (alist-get 'account note))))
+ (mastodon-notifications--insert-status
+ (cons '(reblog (id . nil)) note)
+ (propertize (format "You have a follow request from... %s" follower)
+ 'face 'default)
+ 'mastodon-tl--byline-author
+ (lambda (_status)
+ (mastodon-notifications--byline-concat
+ "Requested to follow"))
+ id)))
+
(defun mastodon-notifications--favourite (note)
"Format for a `favourite' NOTE."
- (let ((status (mastodon-tl--field 'status note)))
- (mastodon-tl--insert-status
+ (let ((id (alist-get 'id note))
+ (status (mastodon-tl--field 'status note)))
+ (mastodon-notifications--insert-status
status
(mastodon-tl--clean-tabs-and-nl
(if (mastodon-tl--has-spoiler status)
@@ -104,12 +185,34 @@
note))
(lambda (_status)
(mastodon-notifications--byline-concat
- "Favourited")))))
+ "Favourited"))
+ id)))
(defun mastodon-notifications--reblog (note)
"Format for a `boost' NOTE."
- (let ((status (mastodon-tl--field 'status note)))
- (mastodon-tl--insert-status
+ (let ((id (alist-get 'id note))
+ (status (mastodon-tl--field 'status note)))
+ (mastodon-notifications--insert-status
+ status
+ (mastodon-tl--clean-tabs-and-nl
+ (if (mastodon-tl--has-spoiler status)
+ (mastodon-tl--spoiler status)
+ (mastodon-tl--content status)))
+ (lambda (_status)
+ (mastodon-tl--byline-author
+ note))
+ (lambda (_status)
+ (mastodon-notifications--byline-concat
+ "Boosted"))
+ id)))
+
+(defun mastodon-notifications--status (note)
+ "Format for a `status' NOTE.
+Status notifications are given when
+`mastodon-tl--enable-notify-user-posts' has been set."
+ (let ((id (cdr (assoc 'id note)))
+ (status (mastodon-tl--field 'status note)))
+ (mastodon-notifications--insert-status
status
(mastodon-tl--clean-tabs-and-nl
(if (mastodon-tl--has-spoiler status)
@@ -120,7 +223,37 @@
note))
(lambda (_status)
(mastodon-notifications--byline-concat
- "Boosted")))))
+ "Posted"))
+ id)))
+
+(defun mastodon-notifications--insert-status (toot body author-byline action-byline &optional id)
+ "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 also an optional function for adding an action,
+such as boosting favouriting and following to the byline. It also
+takes a single function. By default it is
+`mastodon-tl--byline-boosted'.
+
+ID is the notification's own id, which is attached as a property."
+ (let ((start-pos (point)))
+ (insert
+ (propertize
+ (concat "\n"
+ body
+ " \n"
+ (mastodon-tl--byline toot author-byline action-byline))
+ 'toot-id id
+ 'base-toot-id (mastodon-tl--toot-id toot)
+ 'toot-json toot)
+ "\n")
+ (when mastodon-tl--display-media-p
+ (mastodon-media--inline-images start-pos (point)))))
(defun mastodon-notifications--by-type (note)
"Filters NOTE for those listed in `mastodon-notifications--types-alist'."
@@ -140,8 +273,9 @@
(defun mastodon-notifications--get ()
"Display NOTIFICATIONS in buffer."
(interactive)
- (mastodon-tl--init
- "*mastodon-notifications*"
+ (message "Loading your notifications...")
+ (mastodon-tl--init-sync
+ "notifications"
"notifications"
'mastodon-notifications--timeline))
diff --git a/lisp/mastodon-profile.el b/lisp/mastodon-profile.el
index 16fb1a9..05cacde 100644
--- a/lisp/mastodon-profile.el
+++ b/lisp/mastodon-profile.el
@@ -2,9 +2,10 @@
;; Copyright (C) 2017-2019 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.7.2
-;; Package-Requires: ((emacs "24.4"))
-;; Homepage: https://github.com/jdenen/mastodon.el
+;; Maintainer: Marty Hiatt <martianhiatus@riseup.net>
+;; Version: 0.10.0
+;; Package-Requires: ((emacs "27.1") (seq "1.0"))
+;; Homepage: https://git.blast.noho.st/mouse/mastodon.el
;; This file is not part of GNU Emacs.
@@ -36,24 +37,42 @@
(autoload 'mastodon-http--api "mastodon-http.el")
(autoload 'mastodon-http--get-json "mastodon-http.el")
+(autoload 'mastodon-http--post "mastodon-http.el")
+(autoload 'mastodon-http--triage "mastodon-http.el")
+(autoload 'mastodon-auth--get-account-name "mastodon-auth.el")
+(autoload 'mastodon-http--get-json-async "mastodon-http.el")
(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-tl--byline-author "mastodon-tl.el")
(autoload 'mastodon-tl--goto-next-toot "mastodon-tl.el")
(autoload 'mastodon-tl--property "mastodon-tl.el")
+(autoload 'mastodon-tl--find-property-range "mastodon-tl.el")
(autoload 'mastodon-tl--render-text "mastodon-tl.el")
(autoload 'mastodon-tl--set-face "mastodon-tl.el")
(autoload 'mastodon-tl--timeline "mastodon-tl.el")
+(autoload 'mastodon-tl--as-string "mastodon-tl.el")
(autoload 'mastodon-tl--toot-id "mastodon-tl")
+(autoload 'mastodon-tl--toot "mastodon-tl")
+(autoload 'mastodon-tl--init "mastodon-tl.el")
+(autoload 'mastodon-http--patch "mastodon-http")
+(autoload 'mastodon-http--patch-json "mastodon-http")
(defvar mastodon-instance-url)
(defvar mastodon-tl--buffer-spec)
(defvar mastodon-tl--update-point)
-(defvar mastodon-profile--account nil
+(defvar-local mastodon-profile--account nil
"The data for the account being described in the current profile buffer.")
-(make-variable-buffer-local 'mastodon-profile--account)
+
+(defvar mastodon-profile-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "s") #'mastodon-profile--open-followers)
+ (define-key map (kbd "g") #'mastodon-profile--open-following)
+ (define-key map (kbd "a") #'mastodon-profile--follow-request-accept)
+ (define-key map (kbd "j") #'mastodon-profile--follow-request-reject)
+ map)
+ "Keymap for `mastodon-profile-mode'.")
(define-minor-mode mastodon-profile-mode
"Toggle mastodon profile minor mode.
@@ -61,12 +80,24 @@
This minor mode is used for mastodon profile pages and adds a couple of
extra keybindings."
:init-value nil
- ;; The mode line indicator.
+ ;; modeline indicator:
:lighter " Profile"
- ;; The key bindings
- :keymap '(((kbd "F") . mastodon-profile--open-followers)
- ((kbd "f") . mastodon-profile--open-following))
- :group 'mastodon)
+ :keymap mastodon-profile-mode-map
+ :group 'mastodon
+ :global nil)
+
+(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") #'kill-buffer-and-window)
+ map)
+ "Keymap for `mastodon-profile-update-mode'.")
+
+(define-minor-mode mastodon-profile-update-mode
+ "Minor mode to update Mastodon user profile."
+ :group 'mastodon-profile
+ :keymap mastodon-profile-update-mode-map
+ :global nil)
(defun mastodon-profile--toot-json ()
"Get the next toot-json."
@@ -74,13 +105,12 @@ extra keybindings."
(mastodon-tl--property 'toot-json))
(defun mastodon-profile--make-author-buffer (account)
- "Take a ACCOUNT and inserts a user account into a new buffer."
+ "Take an ACCOUNT json and insert a user account into a new buffer."
(mastodon-profile--make-profile-buffer-for
account "statuses" #'mastodon-tl--timeline))
(defun mastodon-profile--open-following ()
- "Open a profile buffer for the current profile showing the accounts
-that current profile follows."
+ "Open a profile buffer showing the accounts that current profile follows."
(interactive)
(if mastodon-profile--account
(mastodon-profile--make-profile-buffer-for
@@ -90,8 +120,7 @@ that current profile follows."
(error "Not in a mastodon profile")))
(defun mastodon-profile--open-followers ()
- "Open a profile buffer for the current profile showing the accounts
-following the current profile."
+ "Open a profile buffer showing the accounts following the current profile."
(interactive)
(if mastodon-profile--account
(mastodon-profile--make-profile-buffer-for
@@ -100,14 +129,186 @@ following the current profile."
#'mastodon-profile--add-author-bylines)
(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))
+
+(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))
+
+(defun mastodon-profile--view-follow-requests ()
+ "Open a new buffer displaying the user's follow requests."
+ (interactive)
+ (mastodon-profile-mode)
+ (mastodon-tl--init "follow-requests"
+ "follow_requests"
+ 'mastodon-profile--add-author-bylines))
+
+(defun mastodon-profile--follow-request-accept ()
+ "Accept the follow request of user at point."
+ (interactive)
+ (if (mastodon-tl--find-property-range 'toot-json (point))
+ (let* ((acct-json (mastodon-profile--toot-json))
+ (id (alist-get 'id acct-json))
+ (handle (alist-get 'acct acct-json))
+ (name (alist-get 'username acct-json)))
+ (if id
+ (let ((response
+ (mastodon-http--post
+ (concat
+ (mastodon-http--api "follow_requests")
+ (format "/%s/authorize" id))
+ nil nil)))
+ (mastodon-http--triage response
+ (lambda ()
+ (message "Follow request of %s (@%s) accepted!"
+ name handle))))
+ (message "No account result at point?")))
+ (message "No follow request at point?")))
+
+(defun mastodon-profile--follow-request-reject ()
+ "Reject the follow request of user at point."
+ (interactive)
+ (if (mastodon-tl--find-property-range 'toot-json (point))
+ (let* ((acct-json (mastodon-profile--toot-json))
+ (id (alist-get 'id acct-json))
+ (handle (alist-get 'acct acct-json))
+ (name (alist-get 'username acct-json)))
+ (if id
+ (let ((response
+ (mastodon-http--post
+ (concat
+ (mastodon-http--api "follow_requests")
+ (format "/%s/reject" id))
+ nil nil)))
+ (mastodon-http--triage response
+ (lambda ()
+ (message "Follow request of %s (@%s) rejected!"
+ name handle))))
+ (message "No account result at point?")))
+ (message "No follow request at point?")))
+
+(defun mastodon-profile--update-user-profile-note ()
+ "Fetch user's profile note and display for editing."
+ (interactive)
+ (let* ((url (concat mastodon-instance-url
+ "/api/v1/accounts/update_credentials"))
+ ;; (buffer (mastodon-http--patch url))
+ (json (mastodon-http--patch-json url))
+ (source (alist-get 'source json))
+ (note (alist-get 'note source))
+ (buffer (get-buffer-create "*mastodon-update-profile*"))
+ (inhibit-read-only t))
+ (switch-to-buffer-other-window buffer)
+ (mastodon-profile-update-mode t)
+ (insert note)
+ (goto-char (point-min))
+ (delete-trailing-whitespace) ; remove all ^M's
+ (message "Edit your profile note. C-c C-c to send, C-c C-k to cancel.")))
+
+(defun mastodon-profile--user-profile-send-updated ()
+ "Send PATCH request with the updated profile note."
+ (interactive)
+ (let* ((note (buffer-substring-no-properties (point-min) (point-max)))
+ (url (concat mastodon-instance-url
+ "/api/v1/accounts/update_credentials")))
+ (kill-buffer-and-window)
+ (let ((response (mastodon-http--patch url note)))
+ (mastodon-http--triage response
+ (lambda () (message "Profile note updated!"))))))
+
+(defun mastodon-profile--relationships-get (id)
+ "Fetch info about logged-in user's relationship to user with id ID."
+ (let* ((their-id id)
+ (url (mastodon-http--api (format
+ "accounts/relationships?id[]=%s"
+ their-id))))
+ (mastodon-http--get-json url)))
+
+(defun mastodon-profile--fields-get (account)
+ "Fetch the fields vector (aka profile metadata) from profile of ACCOUNT.
+
+Returns a list of lists."
+ (let ((fields (mastodon-profile--account-field account 'fields)))
+ (when fields
+ (mapcar
+ (lambda (el)
+ (list
+ (alist-get 'name el)
+ (alist-get 'value el)))
+ 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))
+ ;; (cdr-fields (mapcar 'cadr fields))
+ ;; (cdr-fields-rendered
+ ;; (list
+ ;; (mapcar (lambda (x)
+ ;; (mastodon-tl--render-text x nil))
+ ;; cdr-fields)))
+ (left-width (car (sort (mapcar 'length car-fields) '>))))
+ ;; (right-width (car (sort (mapcar 'length cdr-fields) '>))))
+ (mapconcat (lambda (field)
+ (mastodon-tl--render-text
+ (concat
+ (format "_ %s " (car field))
+ (make-string (- (+ 1 left-width) (length (car field))) ?_)
+ (format " :: %s" (cadr field)))
+ ;; (make-string (- (+ 1 right-width) (length (cdr field))) ?_)
+ ;; " |")
+ field)) ; nil)) ; hack to make links tabstops
+ fields "")))
+
+(defun mastodon-profile--get-statuses-pinned (account)
+ "Fetch the pinned toots for ACCOUNT."
+ (let* ((id (mastodon-profile--account-field account 'id))
+ (url (mastodon-http--api (format "accounts/%s/statuses?pinned=true" id))))
+ (mastodon-http--get-json url)))
+
+(defun mastodon-profile--insert-statuses-pinned (pinned-statuses)
+ "Insert each of the PINNED-STATUSES for a given account."
+ (mapc (lambda (pinned-status)
+ (insert (mastodon-tl--set-face
+ " :pinned: " 'success))
+ (mastodon-tl--toot pinned-status))
+ pinned-statuses))
+
(defun mastodon-profile--make-profile-buffer-for (account endpoint-type update-function)
+ "Display profile of ACCOUNT, using ENDPOINT-TYPE and UPDATE-FUNCTION."
(let* ((id (mastodon-profile--account-field account 'id))
+ (url (mastodon-http--api (format "accounts/%s/%s" id endpoint-type)))
(acct (mastodon-profile--account-field account 'acct))
- (url (mastodon-http--api (format "accounts/%s/%s"
- id endpoint-type)))
(buffer (concat "*mastodon-" acct "-" endpoint-type "*"))
(note (mastodon-profile--account-field account 'note))
- (json (mastodon-http--get-json url)))
+ (json (mastodon-http--get-json url))
+ (locked (mastodon-profile--account-field account 'locked))
+ (followers-count (mastodon-tl--as-string
+ (mastodon-profile--account-field
+ account 'followers_count)))
+ (following-count (mastodon-tl--as-string
+ (mastodon-profile--account-field
+ account 'following_count)))
+ (toots-count (mastodon-tl--as-string
+ (mastodon-profile--account-field
+ account 'statuses_count)))
+ (relationships (mastodon-profile--relationships-get id))
+ (followed-by-you (alist-get 'following
+ (aref relationships 0)))
+ (follows-you (alist-get 'followed_by
+ (aref relationships 0)))
+ (followsp (or (equal follows-you 't) (equal followed-by-you 't)))
+ (fields (mastodon-profile--fields-get account))
+ (pinned (mastodon-profile--get-statuses-pinned account)))
(with-output-to-temp-buffer buffer
(switch-to-buffer buffer)
(mastodon-mode)
@@ -122,9 +323,9 @@ following the current profile."
(is-followers (string= endpoint-type "followers"))
(is-following (string= endpoint-type "following"))
(endpoint-name (cond
- (is-statuses " TOOTS ")
- (is-followers " FOLLOWERS ")
- (is-following " FOLLOWING "))))
+ (is-statuses " TOOTS ")
+ (is-followers " FOLLOWERS ")
+ (is-following " FOLLOWING "))))
(insert
"\n"
(mastodon-profile--image-from-account account)
@@ -133,10 +334,42 @@ following the current profile."
account 'display_name)
'face 'mastodon-display-name-face)
"\n"
- (propertize acct
+ (propertize (concat "@" acct)
'face 'default)
+ (if (equal locked t)
+ (if (fontp (char-displayable-p #10r9993))
+ " 🔒"
+ " [locked]")
+ "")
"\n ------------\n"
- (mastodon-tl--render-text note nil)
+ (mastodon-tl--render-text note account)
+ ;; account here to enable tab-stops in profile note
+ (if fields
+ (concat "\n"
+ (mastodon-tl--set-face
+ (mastodon-profile--fields-insert fields)
+ 'success)
+ "\n")
+ "")
+ ;; insert counts
+ (mastodon-tl--set-face
+ (concat " ------------\n"
+ " TOOTS: " toots-count " | "
+ "FOLLOWERS: " followers-count " | "
+ "FOLLOWING: " following-count "\n"
+ " ------------\n\n")
+ 'success)
+ ;; insert relationship (follows)
+ (if followsp
+ (mastodon-tl--set-face
+ (concat (if (equal follows-you 't)
+ " | FOLLOWS YOU")
+ (if (equal followed-by-you 't)
+ " | FOLLOWED BY YOU")
+ "\n\n")
+ 'success)
+ "") ; if no followsp we still need str-or-char-p for insert
+ ;; insert endpoint
(mastodon-tl--set-face
(concat " ------------\n"
endpoint-name "\n"
@@ -144,37 +377,52 @@ following the current profile."
'success))
(setq mastodon-tl--update-point (point))
(mastodon-media--inline-images (point-min) (point))
+ ;; insert pinned toots first
+ (when (and pinned (equal endpoint-type "statuses"))
+ (mastodon-profile--insert-statuses-pinned pinned)
+ (setq mastodon-tl--update-point (point))) ;updates to follow pinned toots
(funcall update-function json)))
- (mastodon-tl--goto-next-toot)))
+ ;;(mastodon-tl--goto-next-toot)
+ (goto-char (point-min))))
(defun mastodon-profile--get-toot-author ()
- "Opens authors profile of toot under point."
+ "Open profile of author of toot under point.
+
+If toot is a boost, opens the profile of the booster."
(interactive)
(mastodon-profile--make-author-buffer
- (cdr (assoc 'account (mastodon-profile--toot-json)))))
+ (alist-get 'account (mastodon-profile--toot-json))))
(defun mastodon-profile--image-from-account (status)
"Generate an image from a STATUS."
- (let ((url (cdr (assoc 'avatar_static status))))
+ (let ((url (alist-get 'avatar_static status)))
(unless (equal url "/avatars/original/missing.png")
(mastodon-media--get-media-link-rendering url))))
(defun mastodon-profile--show-user (user-handle)
- "Query user for user id from current status and show that user's profile."
+ "Query for USER-HANDLE from current status and show that user's profile."
(interactive
(list
(let ((user-handles (mastodon-profile--extract-users-handles
(mastodon-profile--toot-json))))
- (completing-read "User handle: "
+ (completing-read "View profile of user [choose or enter any handle]: "
user-handles
nil ; predicate
'confirm))))
(let ((account (mastodon-profile--lookup-account-in-status
user-handle (mastodon-profile--toot-json))))
(if account
- (mastodon-profile--make-author-buffer account)
+ (progn
+ (message "Loading profile of user %s..." user-handle)
+ (mastodon-profile--make-author-buffer account))
(message "Cannot find a user with handle %S" user-handle))))
+(defun mastodon-profile--my-profile ()
+ "Show the profile of the currently signed in user."
+ (interactive)
+ (message "Loading your profile...")
+ (mastodon-profile--show-user (mastodon-auth--get-account-name)))
+
(defun mastodon-profile--account-field (account field)
"Return FIELD from the ACCOUNT.
@@ -190,17 +438,17 @@ FIELD is used to identify regions under 'account"
(propertize
(mastodon-tl--byline-author `((account . ,toot)))
'byline 't
- 'toot-id (cdr (assoc 'id toot))
+ 'toot-id (alist-get 'id toot)
'base-toot-id (mastodon-tl--toot-id toot)
'toot-json toot))
(mastodon-media--inline-images start-pos (point))
(insert "\n"
- (mastodon-tl--render-text (cdr (assoc 'note toot)) nil)
+ (mastodon-tl--render-text (alist-get 'note toot) nil)
"\n")))
tootv)))
(defun mastodon-profile--search-account-by-handle (handle)
- "Return an account based on a users 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))
@@ -208,7 +456,8 @@ If the handle does not match a search return then retun NIL."
handle))
(matching-account
(seq-remove
- (lambda(x) (not (string= (cdr (assoc 'acct x)) handle)))
+ (lambda (x)
+ (not (string= (alist-get 'acct x) handle)))
(mastodon-http--get-json
(mastodon-http--api (format "accounts/search?q=%s" handle))))))
(when (equal 1 (length matching-account))
@@ -224,35 +473,35 @@ If the handle does not match a search return then retun NIL."
These include the author, author of reblogged entries and any user mentioned."
(when status
- (let ((this-account (cdr (assoc 'account status)))
- (mentions (cdr (assoc 'mentions status)))
- (reblog (cdr (assoc 'reblog status))))
+ (let ((this-account (alist-get 'account status))
+ (mentions (alist-get 'mentions status))
+ (reblog (alist-get 'reblog status)))
(seq-filter
'stringp
(seq-uniq
(seq-concatenate
'list
- (list (cdr (assoc 'acct this-account)))
+ (list (alist-get 'acct this-account))
(mastodon-profile--extract-users-handles reblog)
(mapcar (lambda (mention)
- (cdr (assoc 'acct mention)))
+ (alist-get 'acct mention))
mentions)))))))
(defun mastodon-profile--lookup-account-in-status (handle status)
"Return account for HANDLE using hints in STATUS if possible."
- (let* ((this-account (cdr (assoc 'account status)))
- (reblog-account (cdr (assoc 'account (cdr (assoc 'reblog status)))))
+ (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
- (cdr (assoc 'acct mention)))
- (cdr (assoc 'id mention))))
- (cdr (assoc 'mentions status)))))
+ (alist-get 'acct mention))
+ (alist-get 'id mention)))
+ (alist-get 'mentions status))))
(cond ((string= handle
- (cdr (assoc 'acct this-account)))
+ (alist-get 'acct this-account))
this-account)
((string= handle
- (cdr (assoc 'acct reblog-account)))
+ (alist-get 'acct reblog-account))
reblog-account)
(mention-id
(mastodon-profile--account-from-id mention-id))
diff --git a/lisp/mastodon-search.el b/lisp/mastodon-search.el
new file mode 100644
index 0000000..78c2ab4
--- /dev/null
+++ b/lisp/mastodon-search.el
@@ -0,0 +1,173 @@
+;;; mastodon-search.el --- Search functions for mastodon.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2017-2019 Johnson Denen
+;; Author: Johnson Denen <johnson.denen@gmail.com>
+;; Marty Hiatt <martianhiatus@riseup.net>
+;; Maintainer: Marty Hiatt <martianhiatus@riseup.net>
+;; Version: 0.10.0
+;; Package-Requires: ((emacs "27.1"))
+;; Homepage: https://git.blast.noho.st/mouse/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 <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; A basic search function for mastodon.el
+
+;;; Code:
+(require 'json)
+
+(autoload 'mastodon-http--get-json "mastodon-http")
+(autoload 'mastodon-tl--as-string "mastodon-tl")
+(autoload 'mastodon-mode "mastodon")
+(autoload 'mastodon-tl--set-face "mastodon-tl")
+(autoload 'mastodon-tl--render-text "mastodon-tl")
+(autoload 'mastodon-tl--as-string "mastodon-tl")
+(autoload 'mastodon-auth--access-token "mastodon-auth")
+(autoload 'mastodon-http--get-search-json "mastodon-http")
+
+(defvar mastodon-instance-url)
+(defvar mastodon-tl--link-keymap)
+(defvar mastodon-http--timeout)
+(defvar mastodon-toot--enable-completion-for-mentions)
+
+;; functions for company completion of mentions in mastodon-toot
+
+(defun mastodon-search--get-user-info-@ (account)
+ "Get user handle, display name and account URL from ACCOUNT."
+ (list (cdr (assoc 'display_name account))
+ (concat "@" (cdr (assoc 'acct account)))
+ (cdr (assoc 'url 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."
+ (interactive "sSearch mastodon for: ")
+ (let* ((url (format "%s/api/v1/accounts/search" mastodon-instance-url))
+ ;; (buffer (format "*mastodon-search-%s*" query))
+ (response (if (equal mastodon-toot--enable-completion-for-mentions "following")
+ (mastodon-http--get-search-json url query "following=true")
+ (mastodon-http--get-search-json url query))))
+ (mapcar #'mastodon-search--get-user-info-@
+ response)))
+
+;; functions for mastodon search
+
+(defun mastodon-search--search-query (query)
+ "Prompt for a search QUERY and return accounts, statuses, and hashtags."
+ (interactive "sSearch mastodon for: ")
+ (let* ((url (format "%s/api/v2/search" mastodon-instance-url))
+ (buffer (format "*mastodon-search-%s*" query))
+ (response (mastodon-http--get-search-json url query))
+ (accts (alist-get 'accounts response))
+ (tags (alist-get 'hashtags response))
+ (statuses (alist-get 'statuses response))
+ (user-ids (mapcar #'mastodon-search--get-user-info
+ accts)) ; returns a list of three-item lists
+ (tags-list (mapcar #'mastodon-search--get-hashtag-info
+ tags))
+ ;; (status-list (mapcar #'mastodon-search--get-status-info
+ ;; statuses))
+ (status-ids-list (mapcar 'mastodon-search--get-id-from-status
+ statuses))
+ (toots-list-json (mapcar #'mastodon-search--fetch-full-status-from-id
+ status-ids-list)))
+ (with-current-buffer (get-buffer-create buffer)
+ (switch-to-buffer buffer)
+ (erase-buffer)
+ (mastodon-mode)
+ (let ((inhibit-read-only t))
+ ;; user results:
+ (insert (mastodon-tl--set-face
+ (concat "\n ------------\n"
+ " USERS\n"
+ " ------------\n\n")
+ 'success))
+ (mapc (lambda (el)
+ (insert (propertize (car el) 'face 'mastodon-display-name-face)
+ " : \n : "
+ (propertize (concat "@" (car (cdr el)))
+ 'face 'mastodon-handle-face
+ 'mouse-face 'highlight
+ 'mastodon-tab-stop 'user-handle
+ 'keymap mastodon-tl--link-keymap
+ 'mastodon-handle (concat "@" (car (cdr el)))
+ 'help-echo (concat "Browse user profile of @" (car (cdr el))))
+ " : \n"
+ "\n"))
+ user-ids)
+ ;; hashtag results:
+ (insert (mastodon-tl--set-face
+ (concat "\n ------------\n"
+ " HASHTAGS\n"
+ " ------------\n\n")
+ 'success))
+ (mapc (lambda (el)
+ (insert " : #"
+ (propertize (car el)
+ 'mouse-face 'highlight
+ 'mastodon-tag (car el)
+ 'mastodon-tab-stop 'hashtag
+ 'help-echo (concat "Browse tag #" (car el))
+ 'keymap mastodon-tl--link-keymap)
+ " : \n\n"))
+ tags-list)
+ ;; status results:
+ (insert (mastodon-tl--set-face
+ (concat "\n ------------\n"
+ " STATUSES\n"
+ " ------------\n")
+ 'success))
+ (mapc 'mastodon-tl--toot toots-list-json)
+ (goto-char (point-min))))))
+
+(defun mastodon-search--get-user-info (account)
+ "Get user handle, display name and account URL from ACCOUNT."
+ (list (alist-get 'display_name account)
+ (alist-get 'acct account)
+ (alist-get 'url account)))
+
+(defun mastodon-search--get-hashtag-info (tag)
+ "Get hashtag name and URL from TAG."
+ (list (alist-get 'name tag)
+ (alist-get 'url tag)))
+
+(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--get-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--fetch-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 (concat mastodon-instance-url "/api/v1/statuses/" (mastodon-tl--as-string id)))
+ (json (mastodon-http--get-json url)))
+ json))
+
+(provide 'mastodon-search)
+;;; mastodon-search.el ends here
diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el
index 0b918df..b2b8026 100644
--- a/lisp/mastodon-tl.el
+++ b/lisp/mastodon-tl.el
@@ -2,9 +2,10 @@
;; Copyright (C) 2017-2019 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.9.0
-;; Homepage: https://github.com/jdenen/mastodon.el
-;; Package-Requires: ((emacs "24.4"))
+;; Maintainer: Marty Hiatt <martianhiatus@riseup.net>
+;; Version: 0.10.0
+;; Package-Requires: ((emacs "27.1"))
+;; Homepage: https://git.blast.noho.st/mouse/mastodon.el
;; This file is not part of GNU Emacs.
@@ -30,21 +31,35 @@
;;; Code:
(require 'shr)
-(require 'thingatpt) ;; for word-at-point
+(require 'thingatpt) ; for word-at-point
(require 'time-date)
+(require 'cl-lib) ; for cl-mapcar
+(autoload 'mastodon-auth--get-account-name "mastodon-auth")
(autoload 'mastodon-http--api "mastodon-http")
(autoload 'mastodon-http--get-json "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-mode "mastodon")
-(autoload 'mastodon-profile--account-from-id "mastodon.el-profile.el")
-(autoload 'mastodon-profile--make-author-buffer "mastodon-profile.el")
-(autoload 'mastodon-profile--search-account-by-handle "mastodon.el-profile.el")
+(autoload 'mastodon-profile--account-from-id "mastodon-profile")
+(autoload 'mastodon-profile--make-author-buffer "mastodon-profile")
+(autoload 'mastodon-profile--search-account-by-handle "mastodon-profile")
+;; mousebot adds
+(autoload 'mastodon-profile--toot-json "mastodon-profile")
+(autoload 'mastodon-profile--account-field "mastodon-profile")
+(autoload 'mastodon-profile--extract-users-handles "mastodon-profile")
+(autoload 'mastodon-profile--my-profile "mastodon-profile")
+(autoload 'mastodon-toot--delete-toot "mastodon-toot")
+(autoload 'mastodon-http--post "mastodon-http")
+(autoload 'mastodon-http--triage "mastodon-http")
+(autoload 'mastodon-http--get-json-async "mastodon-http")
+(autoload 'mastodon-profile--lookup-account-in-status "mastodon-profile")
+(autoload 'mastodon-profile-mode "mastodon-profile")
+(autoload 'mastodon-notifications--get "mastodon-notifications")
(defvar mastodon-instance-url)
(defvar mastodon-toot-timestamp-format)
-(defvar shr-use-fonts) ;; need to declare it since Emacs24 didn't have this
+(defvar shr-use-fonts) ;; declare it since Emacs24 didn't have this
(defgroup mastodon-tl nil
"Timelines in Mastodon."
@@ -52,7 +67,7 @@
:group 'mastodon)
(defcustom mastodon-tl--enable-relative-timestamps t
- "Nonnil to enable showing relative (to the current time) timestamps.
+ "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."
@@ -67,30 +82,33 @@ By default fixed width fonts are used."
:type '(boolean :tag "Enable using proportional rather than fixed \
width fonts when rendering HTML text"))
-(defvar mastodon-tl--buffer-spec nil
+(defvar-local mastodon-tl--buffer-spec nil
"A unique identifier and functions for each Mastodon buffer.")
-(make-variable-buffer-local 'mastodon-tl--buffer-spec)
-(defvar mastodon-tl--show-avatars-p
- (image-type-available-p 'imagemagick)
- "A boolean value stating whether to show avatars in timelines.")
+(defcustom mastodon-tl--show-avatars nil
+ "Whether to enable display of user avatars in timelines."
+ :group 'mastodon-tl
+ :type '(boolean :tag "Whether to display user avatars in timelines"))
+
+;; (defvar mastodon-tl--show-avatars nil
+;; (if (version< emacs-version "27.1")
+;; (image-type-available-p 'imagemagick)
+;; (image-transforms-p))
+;; "A boolean value stating whether to show avatars in timelines.")
-(defvar mastodon-tl--update-point nil
+(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.")
-(make-variable-buffer-local 'mastodon-tl--update-point)
(defvar mastodon-tl--display-media-p t
"A boolean value stating whether to show media in timelines.")
-(defvar mastodon-tl--timestamp-next-update nil
+(defvar-local mastodon-tl--timestamp-next-update nil
"The timestamp when the buffer should next be scanned to update the timestamps.")
-(make-variable-buffer-local 'mastodon-tl--timestamp-next-update)
-(defvar mastodon-tl--timestamp-update-timer nil
+(defvar-local mastodon-tl--timestamp-update-timer nil
"The timer that, when set will scan the buffer to update the timestamps.")
-(make-variable-buffer-local 'mastodon-tl--timestamp-update-timer)
(defvar mastodon-tl--link-keymap
(let ((map (make-sparse-keymap)))
@@ -98,7 +116,7 @@ If nil `(point-min)' is used instead.")
(define-key map [mouse-2] 'mastodon-tl--do-link-action)
(define-key map [follow-link] 'mouse-face)
(keymap-canonicalize map))
- "The keymap set for things in the buffer that act like links (except for shr.el generate links).
+ "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
@@ -110,6 +128,8 @@ etc.")
;; 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)
(keymap-canonicalize map))
"The keymap to be set for shr.el generated links that are not images.
@@ -124,6 +144,14 @@ types of mastodon links and not just shr.el-generated ones.")
;; 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] 'shr-browse-image)
+ ;; 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)
(keymap-canonicalize map))
"The keymap to be set for shr.el generated image links.
@@ -154,9 +182,10 @@ This also skips tab items in invisible text, i.e. hidden spoiler text."
(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."
+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)
(let (next-range
(search-pos (point)))
@@ -174,18 +203,21 @@ This also skips tab items in invisible text, i.e. hidden spoiler text."
(defun mastodon-tl--get-federated-timeline ()
"Opens federated timeline."
(interactive)
+ (message "Loading federated timeline...")
(mastodon-tl--init
"federated" "timelines/public" 'mastodon-tl--timeline))
(defun mastodon-tl--get-home-timeline ()
"Opens home timeline."
(interactive)
+ (message "Loading home timeline...")
(mastodon-tl--init
"home" "timelines/home" 'mastodon-tl--timeline))
(defun mastodon-tl--get-local-timeline ()
"Opens local timeline."
(interactive)
+ (message "Loading local timeline...")
(mastodon-tl--init
"local" "timelines/public?local=true" 'mastodon-tl--timeline))
@@ -193,8 +225,9 @@ This also skips tab items in invisible text, i.e. hidden spoiler text."
"Prompts for tag and opens its timeline."
(interactive)
(let* ((word (or (word-at-point) ""))
- (input (read-string (format "Tag(%s): " word)))
+ (input (read-string (format "Load timeline for tag (%s): " word)))
(tag (if (equal input "") word input)))
+ (message "Loading timeline for #%s..." tag)
(mastodon-tl--show-tag-timeline tag)))
(defun mastodon-tl--show-tag-timeline (tag)
@@ -237,36 +270,62 @@ Optionally start from POS."
(defun mastodon-tl--byline-author (toot)
"Propertize author of TOOT."
- (let* ((account (cdr (assoc 'account toot)))
- (handle (cdr (assoc 'acct account)))
- (name (cdr (assoc 'display_name account)))
- (profile-url (cdr (assoc 'url account)))
- (avatar-url (cdr (assoc 'avatar account))))
+ (let* ((account (alist-get 'account toot))
+ (handle (alist-get 'acct account))
+ (name (if (not (string= "" (alist-get 'display_name account)))
+ (alist-get 'display_name account)
+ (alist-get 'username account)))
+ (profile-url (alist-get 'url account))
+ (avatar-url (alist-get 'avatar account)))
;; TODO: Once we have a view for a user (e.g. their posts
;; timeline) make this a tab-stop and attach an action
(concat
- (when (and mastodon-tl--show-avatars-p mastodon-tl--display-media-p)
+ (when (and mastodon-tl--show-avatars
+ mastodon-tl--display-media-p
+ (if (version< emacs-version "27.1")
+ (image-type-available-p 'imagemagick)
+ (image-transforms-p)))
(mastodon-media--get-avatar-rendering avatar-url))
- (propertize name 'face 'mastodon-display-name-face)
+ (propertize name
+ 'face 'mastodon-display-name-face
+ ;; echo faves count when point on post author name:
+ ;; which is where --goto-next-toot puts point.
+ 'help-echo
+ (mastodon-tl--format-faves-count toot))
" ("
(propertize (concat "@" handle)
'face 'mastodon-handle-face
'mouse-face 'highlight
- ;; TODO: Replace url browsing with native profile viewing
- 'mastodon-tab-stop 'user-handle
+ ;; TODO: Replace url browsing with native profile viewing
+ 'mastodon-tab-stop 'user-handle
'account account
- 'shr-url profile-url
- 'keymap mastodon-tl--link-keymap
+ 'shr-url profile-url
+ 'keymap mastodon-tl--link-keymap
'mastodon-handle (concat "@" handle)
- 'help-echo (concat "Browse user profile of @" handle))
+ 'help-echo (concat "Browse user profile of @" handle))
")")))
+(defun mastodon-tl--format-faves-count (toot)
+ "Format a favorites, boosts, replies count for a TOOT.
+Used to help-echo when point is at the start of a byline,
+i.e. where `mastodon-tl--goto-next-toot' leaves point."
+ (let ((toot-to-count
+ (or
+ ;; simply praying this order works
+ (alist-get 'status toot) ; notifications timeline
+ (alist-get 'reblog toot) ; boosts
+ toot))) ; everything else
+ (format "%s faves | %s boosts | %s replies"
+ (alist-get 'favourites_count toot-to-count)
+ (alist-get 'reblogs_count toot-to-count)
+ (alist-get 'replies_count toot-to-count))))
+
(defun mastodon-tl--byline-boosted (toot)
"Add byline for boosted data from TOOT."
- (let ((reblog (cdr (assoc 'reblog toot))))
+ (let ((reblog (alist-get 'reblog toot)))
(when reblog
(concat
- " "
+ "\n "
(propertize "Boosted" 'face 'mastodon-boosted-face)
" "
(mastodon-tl--byline-author reblog)))))
@@ -275,11 +334,11 @@ Optionally start from POS."
"Return FIELD from TOOT.
Return value from boosted content if available."
- (or (cdr (assoc field (cdr (assoc 'reblog toot))))
- (cdr (assoc field toot))))
+ (or (alist-get field (alist-get 'reblog toot))
+ (alist-get field toot)))
(defun mastodon-tl--relative-time-details (timestamp &optional current-time)
- "Returns cons of (descriptive string . next change) for the TIMESTAMP.
+ "Return cons of (descriptive string . next change) for the TIMESTAMP.
Use the optional CURRENT-TIME as the current time (only used for
reliable testing).
@@ -334,7 +393,7 @@ TIMESTAMP is assumed to be in the past."
(time-add timestamp (seconds-to-time (cdr relative-result))))))
(defun mastodon-tl--relative-time-description (timestamp &optional current-time)
- "Returns a string with a human readable description of TIMESTMAP relative to the 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).
@@ -349,21 +408,38 @@ TIME-STAMP is assumed to be in the past."
AUTHOR-BYLINE is function for adding the author portion of
the byline that takes one variable.
ACTION-BYLINE is a function for adding an action, such as boosting
-favouriting and following to the byline. It also takes a single function. By default
-it is `mastodon-tl--byline-boosted'"
+favouriting and following to the byline. It also takes a single function.
+By default it is `mastodon-tl--byline-boosted'"
(let ((parsed-time (date-to-time (mastodon-tl--field 'created_at toot)))
(faved (equal 't (mastodon-tl--field 'favourited toot)))
- (boosted (equal 't (mastodon-tl--field 'reblogged toot))))
+ (boosted (equal 't (mastodon-tl--field 'reblogged toot)))
+ (visibility (mastodon-tl--field 'visibility toot)))
(concat
- (propertize "\n | " 'face 'default)
+ ;; (propertize "\n | " 'face 'default)
(propertize
(concat (when boosted
- (format "(%s) "
- (propertize "B" 'face 'mastodon-boost-fave-face)))
+ (format
+ (propertize "(%s) "
+ 'help-echo
+ (mastodon-tl--format-faves-count toot))
+ (propertize "B" 'face 'mastodon-boost-fave-face)))
(when faved
- (format "(%s) "
- (propertize "F" 'face 'mastodon-boost-fave-face)))
+ (format
+ (propertize "(%s) "
+ 'help-echo
+ (mastodon-tl--format-faves-count toot))
+ (propertize "F" 'face 'mastodon-boost-fave-face)))
+ ;; we propertize help-echo format faves for author name
+ ;; in `mastodon-tl--byline-author'
(funcall author-byline toot)
+ (cond ((equal visibility "direct")
+ (if (fontp (char-displayable-p #10r128274))
+ " ✉"
+ " [direct]"))
+ ((equal visibility "private")
+ (if (fontp (char-displayable-p #10r9993))
+ " 🔒"
+ " [followers]")))
(funcall action-byline toot)
" "
;; TODO: Once we have a view for toot (responses etc.) make
@@ -374,13 +450,13 @@ it is `mastodon-tl--byline-boosted'"
'display (if mastodon-tl--enable-relative-timestamps
(mastodon-tl--relative-time-description parsed-time)
parsed-time))
- (propertize "\n ------------" 'face 'default))
+ (propertize "\n ------------\n" 'face 'default))
'favourited-p faved
'boosted-p boosted
'byline t))))
(defun mastodon-tl--render-text (string toot)
- "Returns a propertized text giving the rendering of the given HTML string STRING.
+ "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."
@@ -388,7 +464,7 @@ links in the text. If TOOT is nil no parsing occurs."
(insert string)
(let ((shr-use-fonts mastodon-tl--enable-proportional-fonts)
(shr-width (when mastodon-tl--enable-proportional-fonts
- (window-width))))
+ (- (window-width) 1))))
(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:
@@ -402,6 +478,8 @@ links in the text. If TOOT is nil no parsing occurs."
(buffer-string)))
(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))
@@ -414,17 +492,22 @@ links in the text. If TOOT is nil no parsing occurs."
mastodon-instance-url))
(maybe-hashtag (mastodon-tl--extract-hashtag-from-url
url toot-instance-url))
- (maybe-userhandle (mastodon-tl--extract-userhandle-from-url
- url (buffer-substring-no-properties start end))))
+ (url-instance (concat "https://"
+ (url-host (url-generic-parse-url url))))
+ (maybe-userhandle (if (string= mastodon-instance-url url-instance)
+ ; if handle is local, then no instance suffix:
+ (buffer-substring-no-properties start end)
+ (mastodon-tl--extract-userhandle-from-url
+ url (buffer-substring-no-properties start end)))))
(cond (;; Hashtags:
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)))
-
(;; User handles:
maybe-userhandle
+ ;; this fails on mentions in profile notes:
(let ((maybe-userid (mastodon-tl--extract-userid-toot
toot maybe-userhandle)))
(setq mastodon-tab-stop-type 'user-handle
@@ -433,7 +516,7 @@ links in the text. If TOOT is nil no parsing occurs."
extra-properties (append
(list 'mastodon-handle maybe-userhandle)
(when maybe-userid
- (list 'acccount-id maybe-userid))))))
+ (list 'account-id maybe-userid))))))
;; Anything else:
(t
;; Leave it as a url handled by shr.el.
@@ -451,19 +534,19 @@ links in the text. If TOOT is nil no parsing occurs."
(defun mastodon-tl--extract-userid-toot (toot acct)
"Extract a user id for an ACCT from mentions in a TOOT."
- (let* ((mentions (append (cdr (assoc 'mentions toot)) nil))
+ (let* ((mentions (append (alist-get 'mentions toot) nil))
(mention (pop mentions))
(short-acct (substring acct 1 (length acct)))
return)
(while mention
- (when (string= (cdr (assoc 'acct mention))
+ (when (string= (alist-get 'acct mention)
short-acct)
- (setq return (cdr (assoc 'id mention))))
+ (setq return (alist-get 'id mention)))
(setq mention (pop mentions)))
return))
(defun mastodon-tl--extract-userhandle-from-url (url buffer-text)
- "Returns the user hande the URL points to or nil if it is not a profile link.
+ "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 <at-sign><user id>, e.g. \"@Gargon\"."
@@ -474,7 +557,7 @@ this should be of the form <at-sign><user id>, e.g. \"@Gargon\"."
(concat buffer-text "@" (url-host parsed-url)))))
(defun mastodon-tl--extract-hashtag-from-url (url instance-url)
- "Returns the hashtag that URL points to or nil if URL is not a tag link.
+ "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
@@ -490,7 +573,7 @@ the toot)."
(t nil)))
(defun mastodon-tl--set-face (string face)
- "Returns the propertized STRING with the face property set to FACE."
+ "Return the propertized STRING with the face property set to FACE."
(propertize string 'face face))
(defun mastodon-tl--toggle-spoiler-text (position)
@@ -532,7 +615,7 @@ LINK-TYPE is the type of link to produce."
((eq link-type 'content-warning)
"Toggle hidden text")
(t
- (error "unknown link type %s" link-type)))))
+ (error "Unknown link type %s" link-type)))))
(propertize
string
'mastodon-tab-stop link-type
@@ -541,12 +624,16 @@ LINK-TYPE is the type of link to produce."
'help-echo help-text)))
(defun mastodon-tl--do-link-action-at-point (position)
+ "Do the action of the link at POSITION.
+Used for hitting <return> on a given link."
(interactive "d")
(let ((link-type (get-text-property position 'mastodon-tab-stop)))
(cond ((eq link-type 'content-warning)
(mastodon-tl--toggle-spoiler-text position))
((eq link-type 'hashtag)
(mastodon-tl--show-tag-timeline (get-text-property position 'mastodon-tag)))
+ ;; FIXME: 'account / 'account-id is not set for mentions
+ ;; only works for bylines, not mentions
((eq link-type 'user-handle)
(let ((account-json (get-text-property position 'account))
(account-id (get-text-property position 'account-id)))
@@ -562,18 +649,24 @@ LINK-TYPE is the type of link to produce."
(mastodon-profile--search-account-by-handle
(get-text-property position 'mastodon-handle)))))))
(t
- (error "unknown link type %s" link-type)))))
+ (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))))
(defun mastodon-tl--has-spoiler (toot)
- "Check if the given TOOT has a spoiler text that should initially be shown only while the main content should be hidden."
+ "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--clean-tabs-and-nl (string)
+ "Remove tabs and newlines from STRING."
(replace-regexp-in-string
"[\t\n ]*\\'" "" string))
@@ -590,15 +683,15 @@ message is a link which unhides/hides the main body."
(mastodon-tl--clean-tabs-and-nl
(mastodon-tl--render-text spoiler toot))
'default))
- (message (concat "\n"
- " ---------------\n"
- " " (mastodon-tl--make-link "Content Warning"
- 'content-warning)
- "\n"
- " ---------------\n"))
+ (message (concat ;"\n"
+ " ---------------\n"
+ " " (mastodon-tl--make-link
+ (concat "CW: " string)
+ 'content-warning)
+ "\n"
+ " ---------------\n"))
(cw (mastodon-tl--set-face message 'mastodon-cw-face)))
(concat
- string
cw
(propertize (mastodon-tl--content toot)
'invisible t
@@ -610,10 +703,16 @@ message is a link which unhides/hides the main body."
(media-string (mapconcat
(lambda (media-attachement)
(let ((preview-url
- (cdr (assoc 'preview_url media-attachement))))
+ (alist-get 'preview_url media-attachement))
+ (remote-url
+ (if (alist-get 'remote_url media-attachement)
+ (alist-get 'remote_url media-attachement)
+ ;; fallback b/c notifications don't have remote_url
+ (alist-get 'url media-attachement)))
+ (type (alist-get 'type media-attachement)))
(if mastodon-tl--display-media-p
(mastodon-media--get-media-link-rendering
- preview-url)
+ preview-url remote-url type) ; 2nd arg for shr-browse-url
(concat "Media::" preview-url "\n"))))
media-attachements "")))
(if (not (and mastodon-tl--display-media-p
@@ -621,36 +720,122 @@ message is a link which unhides/hides the main body."
(concat "\n" media-string)
"")))
-
(defun mastodon-tl--content (toot)
- "Retrieve text content from TOOT."
- (let ((content (mastodon-tl--field 'content toot)))
+ "Retrieve text content from TOOT.
+Runs `mastodon-tl--render-text' and fetches poll or media."
+ (let* ((content (mastodon-tl--field 'content toot))
+ (reblog (alist-get 'reblog toot))
+ (poll-p (if reblog
+ (alist-get 'poll reblog)
+ (alist-get 'poll toot))))
(concat
(mastodon-tl--render-text content toot)
+ (when poll-p
+ (mastodon-tl--get-poll toot))
(mastodon-tl--media toot))))
(defun mastodon-tl--insert-status (toot body author-byline action-byline)
- "Display the content and byline of a timeline element.
+ "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 also an optional function for adding an action, such as boosting
-favouriting and following to the byline. It also takes a single function. By default
-it is `mastodon-tl--byline-boosted'"
+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 also an optional function for adding an action,
+such as boosting favouriting and following to the byline. It also
+takes a single function. By default it is
+`mastodon-tl--byline-boosted'"
(let ((start-pos (point)))
(insert
(propertize
- (concat body
+ (concat "\n"
+ body
+ " \n"
(mastodon-tl--byline toot author-byline action-byline))
- 'toot-id (cdr (assoc 'id toot))
+ 'toot-id (alist-get 'id toot)
'base-toot-id (mastodon-tl--toot-id toot)
'toot-json toot)
- "\n\n")
+ "\n")
(when mastodon-tl--display-media-p
(mastodon-media--inline-images start-pos (point)))))
-(defun mastodon-tl--toot(toot)
+(defun mastodon-tl--get-poll (toot)
+ "If TOOT includes a poll, return it as a formatted string."
+ (let* ((poll (mastodon-tl--field 'poll toot))
+ (options (mastodon-tl--field 'options poll))
+ (option-titles (mapcar (lambda (x)
+ (alist-get 'title x))
+ options))
+ (longest-option (car (sort option-titles
+ (lambda (x y)
+ (> (length x)
+ (length y))))))
+ (option-counter 0))
+ (concat "\nPoll: \n\n"
+ (mapconcat (lambda (option)
+ (progn
+ (format "Option %s: %s%s [%s votes].\n"
+ (setq option-counter (1+ option-counter))
+ (alist-get 'title option)
+ (make-string
+ (1+
+ (- (length longest-option)
+ (length (alist-get 'title
+ option))))
+ ?\ )
+ (alist-get 'votes_count option))))
+ options
+ "\n")
+ "\n")))
+
+(defun mastodon-tl--poll-vote (option)
+ "If there is a poll at point, prompt user for OPTION to vote on it."
+ (interactive
+ (list
+ (let* ((toot (mastodon-tl--property 'toot-json))
+ (reblog (alist-get 'reblog toot))
+ (poll (or (alist-get 'poll reblog)
+ (mastodon-tl--field 'poll toot)))
+ (options (mastodon-tl--field 'options poll))
+ (options-titles (mapcar (lambda (x)
+ (alist-get 'title x))
+ options))
+ (options-number-seq (number-sequence 1 (length options)))
+ (options-numbers (mapcar (lambda(x)
+ (number-to-string x))
+ options-number-seq))
+ (options-alist (cl-mapcar 'cons options-numbers options-titles))
+ ;; we display both option number and the option title
+ ;; but also store both as cons cell as cdr, as we need it below
+ (candidates (mapcar (lambda (cell)
+ (cons (format "%s | %s" (car cell) (cdr cell))
+ cell))
+ options-alist)))
+ (if (null (mastodon-tl--field 'poll (mastodon-tl--property 'toot-json)))
+ (message "No poll here.")
+ ;; var "option" = just the cdr, a cons of option number and desc
+ (cdr (assoc
+ (completing-read "Poll option to vote for: "
+ candidates
+ nil ; (predicate)
+ t) ; require match
+ candidates))))))
+ (if (null (mastodon-tl--field 'poll (mastodon-tl--property 'toot-json)))
+ (message "No poll here.")
+ (let* ((toot (mastodon-tl--property 'toot-json))
+ (poll (mastodon-tl--field 'poll toot))
+ (poll-id (alist-get 'id poll))
+ (url (mastodon-http--api (format "polls/%s/votes" poll-id)))
+ ;; need to zero-index our option:
+ (option-as-arg (number-to-string (1- (string-to-number (car option)))))
+ (arg `(("choices[]" . ,option-as-arg)))
+ (response (mastodon-http--post url arg nil)))
+ (mastodon-http--triage response
+ (lambda ()
+ (message "You voted for option %s: %s!"
+ (car option) (cdr option)))))))
+
+(defun mastodon-tl--toot (toot)
"Formats TOOT and insertes it into the buffer."
(mastodon-tl--insert-status
toot
@@ -667,23 +852,26 @@ it is `mastodon-tl--byline-boosted'"
(goto-char (point-min)))
(defun mastodon-tl--get-update-function (&optional buffer)
- "Get the UPDATE-FUNCTION stored in `mastodon-tl--buffer-spec'"
+ "Get the UPDATE-FUNCTION stored in `mastodon-tl--buffer-spec'.
+Optionally get it for BUFFER."
(mastodon-tl--get-buffer-property 'update-function buffer))
(defun mastodon-tl--get-endpoint (&optional buffer)
- "Get the ENDPOINT stored in `mastodon-tl--buffer-spec'"
+ "Get the ENDPOINT stored in `mastodon-tl--buffer-spec'.
+Optionally set it for BUFFER."
(mastodon-tl--get-buffer-property 'endpoint buffer))
(defun mastodon-tl--buffer-name (&optional buffer)
- "Get the BUFFER-NAME stored in `mastodon-tl--buffer-spec'"
+ "Get the BUFFER-NAME stored in `mastodon-tl--buffer-spec'.
+Optionally get it for BUFFER."
(mastodon-tl--get-buffer-property 'buffer-name buffer ))
(defun mastodon-tl--get-buffer-property (property &optional buffer)
- "Get `MASTODON-TL--BUFFER-SPEC' in BUFFER or `CURRENT-BUFFER'"
+ "Get PROPERTY from `mastodon-tl--buffer-spec' in BUFFER or `current-buffer'."
(with-current-buffer (or buffer (current-buffer))
(if (plist-get mastodon-tl--buffer-spec property)
(plist-get mastodon-tl--buffer-spec property)
- (error "mastodon-tl--buffer-spec is not defined for buffer %s"
+ (error "Mastodon-tl--buffer-spec is not defined for buffer %s"
(or buffer (current-buffer))))))
(defun mastodon-tl--more-json (endpoint id)
@@ -697,6 +885,18 @@ it is `mastodon-tl--byline-boosted'"
(mastodon-tl--as-string id)))))
(mastodon-http--get-json url)))
+(defun mastodon-tl--more-json-async (endpoint id callback &rest cbargs)
+ "Return JSON for timeline ENDPOINT before ID.
+Then run CALLBACK with arguments CBARGS."
+ (let* ((url (mastodon-http--api (concat
+ endpoint
+ (if (string-match-p "?" endpoint)
+ "&"
+ "?")
+ "max_id="
+ (mastodon-tl--as-string id)))))
+ (apply 'mastodon-http--get-json-async url callback cbargs)))
+
;; TODO
;; Look into the JSON returned here by Local
(defun mastodon-tl--updated-json (endpoint id)
@@ -733,7 +933,7 @@ Move forward (down) the timeline unless BACKWARD is non-nil."
(goto-char (point-max))
(mastodon-tl--property 'toot-id t)))
-(defun mastodon-tl--as-string(numeric)
+(defun mastodon-tl--as-string (numeric)
"Convert NUMERIC to string."
(cond ((numberp numeric)
(number-to-string numeric))
@@ -749,9 +949,10 @@ 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 ((id (cdr (assoc 'id json)))
- (reblog (cdr (assoc 'reblog json))))
- (if reblog (cdr (assoc 'id reblog)) id)))
+ (let ((id (alist-get 'id json))
+ (reblog (alist-get 'reblog json)))
+ (if reblog (alist-get 'id reblog) id)))
+
(defun mastodon-tl--thread ()
"Open thread buffer for toot under `point'."
@@ -762,10 +963,10 @@ webapp"
(buffer (format "*mastodon-thread-%s*" id))
(toot (mastodon-tl--property 'toot-json))
(context (mastodon-http--get-json url)))
- (when (member (cdr (assoc 'type toot)) '("reblog" "favourite"))
- (setq toot (cdr (assoc 'status toot))))
- (if (> (+ (length (cdr (assoc 'ancestors context)))
- (length (cdr (assoc 'descendants context))))
+ (when (member (alist-get 'type toot) '("reblog" "favourite"))
+ (setq toot (alist-get 'status toot)))
+ (if (> (+ (length (alist-get 'ancestors context))
+ (length (alist-get 'descendants context)))
0)
(with-output-to-temp-buffer buffer
(switch-to-buffer buffer)
@@ -777,27 +978,183 @@ webapp"
(lambda(toot) (message "END of thread."))))
(let ((inhibit-read-only t))
(mastodon-tl--timeline (vconcat
- (cdr (assoc 'ancestors context))
+ (alist-get 'ancestors context)
`(,toot)
- (cdr (assoc 'descendants context))))))
+ (alist-get 'descendants context)))))
(message "No Thread!"))))
+(defun mastodon-tl--follow-user (user-handle &optional notify)
+ "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."
+ (interactive
+ (list
+ (mastodon-tl--interactive-user-handles-get "follow")))
+ (mastodon-tl--do-user-action-and-response user-handle "follow" nil notify))
+
+(defun mastodon-tl--enable-notify-user-posts (user-handle)
+ "Query for USER-HANDLE and enable notifications when they post."
+ (interactive
+ (list
+ (mastodon-tl--interactive-user-handles-get "enable")))
+ (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--interactive-user-handles-get "disable")))
+ (mastodon-tl--follow-user user-handle "false"))
+
+(defun mastodon-tl--unfollow-user (user-handle)
+ "Query for USER-HANDLE from current status and unfollow that user."
+ (interactive
+ (list
+ (mastodon-tl--interactive-user-handles-get "unfollow")))
+ (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--interactive-user-handles-get "block")))
+ (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--interactive-blocks-or-mutes-list-get "unblock")))
+ (if (not user-handle)
+ (message "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--interactive-user-handles-get "mute")))
+ (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--interactive-blocks-or-mutes-list-get "unmute")))
+ (if (not user-handle)
+ (message "Looks like you have no mutes to unmute!")
+ (mastodon-tl--do-user-action-and-response user-handle "unmute" t)))
+
+(defun mastodon-tl--interactive-user-handles-get (action)
+ "Get the list of user-handles for ACTION from the current toot."
+ (let ((user-handles (mastodon-profile--extract-users-handles
+ (mastodon-profile--toot-json))))
+ (completing-read (if (or (equal action "disable")
+ (equal action "enable"))
+ (format "%s notifications when user posts: " action)
+ (format "Handle of user to %s: " action))
+ user-handles
+ nil ; predicate
+ 'confirm)))
+
+(defun mastodon-tl--interactive-blocks-or-mutes-list-get (action)
+ "Fetch the list of accounts for ACTION from the server.
+Action must be either \"unblock\" or \"mute\"."
+ (let* ((endpoint (cond ((equal action "unblock")
+ "blocks")
+ ((equal action "unmute")
+ "mutes")))
+ (url (mastodon-http--api endpoint))
+ (json (mastodon-http--get-json url))
+ (accts (mapcar (lambda (user)
+ (alist-get 'acct user))
+ json)))
+ (when accts
+ (completing-read (format "Handle of user to %s: " action)
+ accts
+ nil ; predicate
+ t))))
+
+(defun mastodon-tl--do-user-action-and-response (user-handle action &optional negp notify)
+ "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'."
+ (let* ((account (if negp
+ ;; if unmuting/unblocking, we got handle from mute/block list
+ (mastodon-profile--search-account-by-handle
+ user-handle)
+ ;; if muting/blocking, we select from handles in current status
+ (mastodon-profile--lookup-account-in-status
+ user-handle (mastodon-profile--toot-json))))
+ (user-id (mastodon-profile--account-field account 'id))
+ (name (mastodon-profile--account-field account 'display_name))
+ (url (mastodon-http--api
+ (if notify
+ (format "accounts/%s/%s?notify=%s" user-id action notify)
+ (format "accounts/%s/%s" user-id action)))))
+ (if account
+ (if (equal action "follow") ; y-or-n for all but follow
+ (mastodon-tl--do-user-action-function url name user-handle action notify)
+ (when (y-or-n-p (format "%s user %s? " action name))
+ (mastodon-tl--do-user-action-function url name user-handle action)))
+ (message "Cannot find a user with handle %S" user-handle))))
+
+(defun mastodon-tl--do-user-action-function (url name user-handle action &optional notify)
+ "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."
+ (let ((response (mastodon-http--post url nil nil)))
+ (mastodon-http--triage response
+ (lambda ()
+ (cond ((string-equal notify "true")
+ (message "Receiving notifications for user %s (@%s)!"
+ name user-handle))
+ ((string-equal notify "false")
+ (message "Not receiving notifications for user %s (@%s)!"
+ name user-handle))
+ ((string-equal action "mute")
+ (message "User %s (@%s) %sd!" name user-handle action))
+ ((eq notify nil)
+ (message "User %s (@%s) %sed!" name user-handle action)))))))
+
+;; TODO: add this to new posts in some cases, e.g. in thread view.
+(defun mastodon-tl--reload-timeline-or-profile ()
+ "Reload the current timeline or profile page.
+For use after e.g. deleting a toot."
+ (cond ((equal (mastodon-tl--get-endpoint) "timelines/home")
+ (mastodon-tl--get-home-timeline))
+ ((equal (mastodon-tl--get-endpoint) "timelines/public")
+ (mastodon-tl--get-federated-timeline))
+ ((equal (mastodon-tl--get-endpoint) "timelines/public?local=true")
+ (mastodon-tl--get-local-timeline))
+ ((equal (mastodon-tl--get-endpoint) "notifications")
+ (mastodon-notifications--get))
+ ((equal (mastodon-tl--buffer-name)
+ (concat "*mastodon-" (mastodon-auth--get-account-name) "-statuses*"))
+ (mastodon-profile--my-profile))))
+
(defun mastodon-tl--more ()
- "Append older toots to timeline."
+ "Append older toots to timeline, asynchronously."
(interactive)
- (let* ((point-before (point))
- (endpoint (mastodon-tl--get-endpoint))
- (update-function (mastodon-tl--get-update-function))
- (id (mastodon-tl--oldest-id))
- (json (mastodon-tl--more-json endpoint id)))
+ (mastodon-tl--more-json-async (mastodon-tl--get-endpoint) (mastodon-tl--oldest-id)
+ 'mastodon-tl--more* (current-buffer) (point)))
+
+(defun mastodon-tl--more* (json buffer point-before)
+ "Append older toots to timeline, asynchronously.
+Runs the timeline's update function on JSON, in BUFFER.
+When done, places point at POINT-BEFORE."
+ (with-current-buffer buffer
(when json
(let ((inhibit-read-only t))
(goto-char (point-max))
- (funcall update-function json)
+ (funcall (mastodon-tl--get-update-function) json)
(goto-char point-before)))))
(defun mastodon-tl--find-property-range (property start-point &optional search-backwards)
- " Returns `nil` if no such range is found.
+ "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.
@@ -833,13 +1190,15 @@ before (non-nil) or after (nil)"
(defun mastodon-tl--find-next-or-previous-property-range
(property start-point search-backwards)
- "Finds (start . end) range after/before START-POINT where PROPERTY is set to a consistent value (different from the value at START-POINT if that is set).
+ "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).
-Returns nil if no such range exists.
+Return nil if no such range exists.
If SEARCH-BACKWARDS is non-nil it find a region before
-START-POINT otherwise after START-POINT.
-"
+START-POINT otherwise after START-POINT."
(if (get-text-property start-point property)
;; We are within a range, we need to start the search from
;; before/after this range:
@@ -951,9 +1310,48 @@ from the start if it is nil."
(funcall update-function json)))))
(defun mastodon-tl--init (buffer-name endpoint update-function)
- "Initialize BUFFER-NAME with timeline targeted by ENDPOINT.
+ "Initialize BUFFER-NAME with timeline targeted by ENDPOINT asynchronously.
UPDATE-FUNCTION is used to recieve more toots."
+ (let ((url (mastodon-http--api endpoint))
+ (buffer (concat "*mastodon-" buffer-name "*")))
+ (mastodon-http--get-json-async
+ url 'mastodon-tl--init* buffer endpoint update-function)))
+
+(defun mastodon-tl--init* (json buffer endpoint update-function)
+ "Initialize BUFFER with timeline targeted by ENDPOINT.
+
+UPDATE-FUNCTION is used to recieve more toots.
+JSON is the data returned from the server."
+ (with-output-to-temp-buffer buffer
+ (switch-to-buffer buffer)
+ (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)))
+ (funcall update-function json))
+ (mastodon-mode)
+ (when (equal endpoint "follow_requests")
+ (mastodon-profile-mode))
+ (with-current-buffer buffer
+ (setq mastodon-tl--buffer-spec
+ `(buffer-name ,buffer
+ endpoint ,endpoint
+ update-function ,update-function)
+ mastodon-tl--timestamp-update-timer
+ (when mastodon-tl--enable-relative-timestamps
+ (run-at-time mastodon-tl--timestamp-next-update
+ nil ;; don't repeat
+ #'mastodon-tl--update-timestamps-callback
+ (current-buffer)
+ nil)))))
+
+(defun mastodon-tl--init-sync (buffer-name endpoint update-function)
+ "Initialize BUFFER-NAME with timeline targeted by ENDPOINT.
+
+UPDATE-FUNCTION is used to receive more toots.
+Runs synchronously."
(let* ((url (mastodon-http--api endpoint))
(buffer (concat "*mastodon-" buffer-name "*"))
(json (mastodon-http--get-json url)))
diff --git a/lisp/mastodon-toot.el b/lisp/mastodon-toot.el
index e339c4d..ec1ba49 100644
--- a/lisp/mastodon-toot.el
+++ b/lisp/mastodon-toot.el
@@ -2,9 +2,10 @@
;; Copyright (C) 2017-2019 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.9.0
-;; Homepage: https://github.com/jdenen/mastodon.el
-;; Package-Requires: ((emacs "24.4"))
+;; Maintainer: Marty Hiatt <martianhiatus@riseup.net>
+;; Version: 0.10.0
+;; Package-Requires: ((emacs "27.1"))
+;; Homepage: https://git.blast.noho.st/mouse/mastodon.el
;; This file is not part of GNU Emacs.
@@ -29,19 +30,43 @@
;;; Code:
-(defvar mastodon-instance-url)
+(when (require 'emojify nil :noerror)
+ (declare-function emojify-insert-emoji "emojify")
+ (declare-function emojify-set-emoji-data "emojify")
+ (defvar emojify-emojis-dir)
+ (defvar emojify-user-emojis))
+
+(require 'cl-lib)
+
+(when (require 'company nil :noerror)
+ (declare-function company-mode-on "company")
+ (declare-function company-begin-backend "company")
+ (declare-function company-grab-symbol "company")
+ (defvar company-backends))
+
+(defvar mastodon-instance-url)
+(defvar mastodon-tl--buffer-spec)
(autoload 'mastodon-auth--user-acct "mastodon-auth")
(autoload 'mastodon-http--api "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--read-file-as-string "mastodon-http")
(autoload 'mastodon-http--triage "mastodon-http")
+(autoload 'mastodon-search--search-accounts-query "mastodon-search")
(autoload 'mastodon-tl--as-string "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-toot "mastodon-tl")
(autoload 'mastodon-tl--property "mastodon-tl")
-(autoload 'mastodon-tl--find-property-range "mastodon-tl")
+(autoload 'mastodon-tl--reload-timeline-or-profile "mastodon-tl")
+(autoload 'mastodon-tl--toot-id "mastodon-tl")
(autoload 'mastodon-toot "mastodon")
(defgroup mastodon-toot nil
@@ -52,41 +77,95 @@
(defcustom mastodon-toot--default-visibility "public"
"The default visibility for new toots.
-Must be one of \"public\", \"unlisted\", \"private\", or \"direct\"."
+Must be one of \"public\", \"unlisted\", \"private\" (for
+followers-only), or \"direct\"."
+ :group 'mastodon-toot
+ :type '(choice
+ (const :tag "public" "public")
+ (const :tag "unlisted" "unlisted")
+ (const :tag "followers only" "private")
+ (const :tag "direct" "direct")))
+
+(defcustom mastodon-toot--default-media-directory "~/"
+ "The default directory when prompting for a media file to upload."
+ :group 'mastodon-toot
+ :type 'string)
+
+(defcustom mastodon-toot--attachment-height 80
+ "Height of the attached images preview in the toot draft buffer."
+ :group 'mastodon-toot
+ :type 'integer)
+
+(defcustom mastodon-toot--enable-completion-for-mentions (if (require 'company nil :noerror) "following" "off")
+ "Whether to enable company completion for mentions.
+
+Used for completion in toot compose buffer.
+
+This is only used if company mode is installed."
+ :group 'mastodon-toot
+ :type '(choice
+ (const :tag "off" nil)
+ (const :tag "following only" "following")
+ (const :tag "all users" "all")))
+
+(defcustom mastodon-toot--enable-custom-instance-emoji nil
+ "Whether to enable your instance's custom emoji by default."
:group 'mastodon-toot
- :type '(choice ("public"
- "unlisted"
- "private"
- "direct")))
+ :type 'boolean)
-(defvar mastodon-toot--content-warning nil
+(defvar-local mastodon-toot--content-warning nil
"A flag whether the toot should be marked with a content warning.")
-(make-variable-buffer-local 'mastodon-toot--content-warning)
-(defvar mastodon-toot--content-nsfw nil
+(defvar-local mastodon-toot--content-warning-from-reply-or-redraft nil
+ "The content warning of the toot being replied to.")
+
+(defvar-local mastodon-toot--content-nsfw nil
"A flag indicating whether the toot should be marked as NSFW.")
-(make-variable-buffer-local 'mastodon-toot--content-nsfw)
-(defvar mastodon-toot--visibility "public"
+(defvar-local mastodon-toot--visibility "public"
"A string indicating the visibility of the toot being composed.
-Valid values are \"direct\", \"private\", \"unlisted\", and \"public\".")
-(make-variable-buffer-local 'mastodon-toot--visibility)
+Valid values are \"direct\", \"private\" (followers-only), \"unlisted\", and \"public\".")
-(defvar mastodon-toot--reply-to-id nil
+(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-local mastodon-toot--reply-to-id nil
"Buffer-local variable to hold the id of the toot being replied to.")
-(make-variable-buffer-local 'mastodon-toot--reply-to-id)
+
+(defvar mastodon-toot--max-toot-chars nil
+ "The maximum allowed characters count for a single toot.")
(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--toggle-warning)
- ;;(define-key map (kbd "C-c C-n") #'mastodon-toot--toggle-nsfw)
+ (define-key map (kbd "C-c C-n") #'mastodon-toot--toggle-nsfw)
(define-key map (kbd "C-c C-v") #'mastodon-toot--change-visibility)
+ (when (require 'emojify nil :noerror)
+ (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)
map)
"Keymap for `mastodon-toot'.")
+(defun mastodon-toot--get-max-toot-chars ()
+ "Fetch max_toot_chars from `mastodon-instance-url' asynchronously."
+ (mastodon-http--get-json-async
+ (mastodon-http--api "instance") 'mastodon-toot--get-max-toot-chars-callback))
+
+(defun mastodon-toot--get-max-toot-chars-callback (json-response)
+ "Set max_toot_chars returned in JSON-RESPONSE and display in new toot buffer."
+ (setq mastodon-toot--max-toot-chars
+ (number-to-string
+ (alist-get 'max_toot_chars json-response)))
+ (with-current-buffer "*new toot*"
+ (mastodon-toot--update-status-fields)))
+
(defun mastodon-toot--action-success (marker byline-region remove)
"Insert/remove the text MARKER with 'success face in byline.
@@ -109,12 +188,13 @@ Remove MARKER if REMOVE is non-nil, otherwise add it."
(propertize marker 'face 'success)))))))
(defun mastodon-toot--action (action callback)
- "Take ACTION on toot at point, then execute CALLBACK."
+ "Take ACTION on toot at point, then execute CALLBACK.
+Makes a POST request to the server."
(let* ((id (mastodon-tl--property 'base-toot-id))
(url (mastodon-http--api (concat "statuses/"
- (mastodon-tl--as-string id)
- "/"
- action))))
+ (mastodon-tl--as-string id)
+ "/"
+ action))))
(let ((response (mastodon-http--post url nil nil)))
(mastodon-http--triage response callback))))
@@ -169,6 +249,112 @@ Remove MARKER if REMOVE is non-nil, otherwise add it."
(message (format "%s #%s" action id))))
(message "Nothing to favorite here?!?"))))
+(defun mastodon-toot--copy-toot-url ()
+ "Copy URL of toot at point."
+ (interactive)
+ (let* ((toot (mastodon-tl--property 'toot-json))
+ (url (if (mastodon-tl--field 'reblog toot)
+ (alist-get 'url (alist-get 'reblog toot))
+ (alist-get 'url toot))))
+ (kill-new url)
+ (message "Toot URL copied to the clipboard.")))
+
+(defun mastodon-toot--own-toot-p (toot)
+ "Check if TOOT is user's own, e.g. for deleting it."
+ (and (not (alist-get 'reblog toot))
+ (equal (alist-get 'acct (alist-get 'account toot))
+ (mastodon-auth--user-acct))))
+
+(defun mastodon-toot--pin-toot-toggle ()
+ "Pin or unpin user's toot at point."
+ (interactive)
+ (let* ((toot (mastodon-tl--property 'toot-json))
+ (pinnable-p (mastodon-toot--own-toot-p toot))
+ (pinned-p (equal (alist-get 'pinned toot) t))
+ (action (if pinned-p "unpin" "pin"))
+ (msg (if pinned-p "unpinned" "pinned"))
+ (msg-y-or-n (if pinned-p "Unpin" "Pin")))
+ (if (not pinnable-p)
+ (message "You can only pin your own toots.")
+ (if (y-or-n-p (format "%s this toot? " msg-y-or-n))
+ (mastodon-toot--action action
+ (lambda ()
+ (message "Toot %s!" msg)))))))
+
+(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-tl--property 'toot-json))
+ (id (mastodon-tl--as-string (mastodon-tl--toot-id toot)))
+ (url (mastodon-http--api (format "statuses/%s" id)))
+ (toot-cw (alist-get 'spoiler_text toot))
+ (toot-visibility (alist-get 'visibility toot))
+ (reply-id (alist-get 'in_reply_to_id toot)))
+ (if (not (mastodon-toot--own-toot-p toot))
+ (message "You can only delete (and redraft) your own toots.")
+ (if (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))
+ (message "Toot deleted!"))
+ (mastodon-toot--redraft response
+ reply-id
+ toot-visibility
+ toot-cw)))))))))
+
+(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* ((json-response (mastodon-http--process-json))
+ (content (alist-get 'text json-response)))
+ (mastodon-toot--compose-buffer nil nil)
+ (goto-char (point-max))
+ (insert content)
+ ;; adopt reply-to-id, visibility and CW from deleted toot:
+ (when reply-id
+ (setq mastodon-toot--reply-to-id reply-id))
+ (setq mastodon-toot--visibility toot-visibility)
+ (when (not (equal toot-cw ""))
+ (setq mastodon-toot--content-warning t)
+ (setq mastodon-toot--content-warning-from-reply-or-redraft toot-cw))
+ (mastodon-toot--update-status-fields))))
+
+(defun mastodon-toot--bookmark-toot-toggle ()
+ "Bookmark or unbookmark toot at point synchronously."
+ (interactive)
+ (let* ((toot (mastodon-tl--property 'toot-json))
+ (id (mastodon-tl--as-string (mastodon-tl--toot-id toot)))
+ (bookmarked (alist-get 'bookmarked toot))
+ (url (mastodon-http--api (if (equal bookmarked t)
+ (format "statuses/%s/unbookmark" id)
+ (format "statuses/%s/bookmark" id))))
+ (prompt (if (equal bookmarked t)
+ (format "Toot already bookmarked. Remove? ")
+ (format "Bookmark this toot? ")))
+ (message (if (equal bookmarked t)
+ "Bookmark removed!"
+ "Toot bookmarked!")))
+ (when (y-or-n-p prompt)
+ (let ((response (mastodon-http--post url nil nil)))
+ (mastodon-http--triage response
+ (lambda ()
+ (message message)))))))
+
(defun mastodon-toot--kill ()
"Kill `mastodon-toot-mode' buffer and window."
(kill-buffer-and-window))
@@ -176,7 +362,86 @@ Remove MARKER if REMOVE is non-nil, otherwise add it."
(defun mastodon-toot--cancel ()
"Kill new-toot buffer/window. Does not POST content to Mastodon."
(interactive)
- (mastodon-toot--kill))
+ (let* ((toot (mastodon-toot--remove-docs))
+ (empty-toot-p (and (not mastodon-toot--media-attachments)
+ (string= "" (mastodon-tl--clean-tabs-and-nl toot)))))
+ (if empty-toot-p
+ (mastodon-toot--kill)
+ (when (y-or-n-p "Discard draft toot? ")
+ (mastodon-toot--kill)))))
+
+(defalias 'mastodon-toot--insert-emoji
+ 'emojify-insert-emoji
+ "Prompt to insert an emoji.")
+
+(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 ((custom-emoji (mastodon-http--get-json
+ (mastodon-http--api "custom_emojis")))
+ (mastodon-custom-emoji-dir (file-name-as-directory
+ (concat (file-name-as-directory
+ (expand-file-name
+ emojify-emojis-dir))
+ "mastodon-custom-emojis"))))
+ (if (not (file-directory-p emojify-emojis-dir))
+ (message "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)
+ (url-copy-file (alist-get 'url x)
+ (concat
+ mastodon-custom-emoji-dir
+ (alist-get 'shortcode x)
+ "."
+ (file-name-extension (alist-get 'url x)))
+ 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 (concat (expand-file-name
+ emojify-emojis-dir)
+ "/mastodon-custom-emojis/"))
+ (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 (concat (expand-file-name
+ emojify-emojis-dir)
+ "/mastodon-custom-emojis/"))
+ (when (y-or-n-p "Looks like you haven't downloaded your instance's custom emoji yet. Download now? ")
+ (mastodon-toot--download-custom-emoji)))
+ (setq emojify-user-emojis
+ (append (mastodon-toot--collect-custom-emoji)
+ emojify-user-emojis))
+ ;; if already loaded, reload
+ (when (featurep 'emojify)
+ (emojify-set-emoji-data)))
+
(defun mastodon-toot--remove-docs ()
"Get the body of a toot from the current compose buffer."
@@ -185,7 +450,7 @@ Remove MARKER if REMOVE is non-nil, otherwise add it."
(buffer-substring (cdr header-region) (point-max))))
(defun mastodon-toot--set-visibility (visibility)
- "Sets the visiblity of the next toot"
+ "Set the visiblity of the next toot to VISIBILITY."
(interactive
(list (completing-read "Visiblity: " '("public"
"unlisted"
@@ -195,36 +460,54 @@ Remove MARKER if REMOVE is non-nil, otherwise add it."
(message "Visibility set to %s" visibility))
(defun mastodon-toot--send ()
- "Kill new-toot buffer/window and POST contents to the Mastodon instance."
+ "POST contents of new-toot buffer to Mastodon instance and kill buffer.
+If media items have been attached and uploaded with
+`mastodon-toot--attach-media', they are attached to the toot."
(interactive)
(let* ((toot (mastodon-toot--remove-docs))
- (empty-toot-p (string= "" (mastodon-tl--clean-tabs-and-nl toot)))
+ (empty-toot-p (and (not mastodon-toot--media-attachments)
+ (string= "" (mastodon-tl--clean-tabs-and-nl toot))))
(endpoint (mastodon-http--api "statuses"))
(spoiler (when (and (not empty-toot-p)
mastodon-toot--content-warning)
- (read-string "Warning: ")))
- (args `(("status" . ,toot)
- ("in_reply_to_id" . ,mastodon-toot--reply-to-id)
- ("visibility" . ,mastodon-toot--visibility)
- ("sensitive" . ,(when mastodon-toot--content-nsfw
- (symbol-name t)))
- ("visibility" . ,mastodon-toot--visibility)
- ("spoiler_text" . ,spoiler))))
- (if empty-toot-p
- (message "Empty toot. Cowardly refusing to post this.")
- (mastodon-toot--kill)
- (let ((response (mastodon-http--post endpoint args nil)))
- (mastodon-http--triage response
- (lambda () (message "Toot toot!")))))))
+ (read-string "Warning: " mastodon-toot--content-warning-from-reply-or-redraft)))
+ (args-no-media `(("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" . ,spoiler)))
+ (args-media (when mastodon-toot--media-attachments
+ (mapcar (lambda (id)
+ (cons "media_ids[]" id))
+ mastodon-toot--media-attachment-ids)))
+ (args (append args-media args-no-media)))
+ (cond ((and mastodon-toot--media-attachments
+ ;; 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)))))
+ (message "Something is wrong with your uploads. Wait for them to complete or try again."))
+ ((> (length toot) (string-to-number mastodon-toot--max-toot-chars))
+ (message "Looks like your toot is longer than that maximum allowed length."))
+ (empty-toot-p
+ (message "Empty toot. Cowardly refusing to post this."))
+ (t
+ (let ((response (mastodon-http--post endpoint args nil)))
+ (mastodon-http--triage response
+ (lambda ()
+ (mastodon-toot--kill)
+ (message "Toot toot!"))))))))
(defun mastodon-toot--process-local (acct)
- "Adds domain to local ACCT and replaces the curent user name with \"\".
+ "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\" "
+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
@@ -233,24 +516,89 @@ eg. \"feduser@fed.social\" -> \"feduser@fed.social\" "
(defun mastodon-toot--mentions (status)
"Extract mentions from STATUS and process them into a string."
(interactive)
- (let ((mentions (cdr (assoc 'mentions status))))
+ (let* ((boosted (mastodon-tl--field 'reblog status))
+ (mentions
+ (if boosted
+ (alist-get 'mentions (alist-get 'reblog status))
+ (alist-get 'mentions status))))
(mapconcat (lambda(x) (mastodon-toot--process-local
- (cdr (assoc 'acct x))))
+ (alist-get 'acct x)))
;; reverse does not work on vectors in 24.5
(reverse (append mentions nil))
"")))
+(defun mastodon-toot--mentions-company-meta (candidate)
+ "Format company completion CANDIDATE's meta field."
+ (format " %s"
+ (get-text-property 0 'meta candidate)))
+
+(defun mastodon-toot--mentions-company-annotation (candidate)
+ "Format company completion CANDIDATE's annotation."
+ (format " %s" (get-text-property 0 'annot candidate)))
+
+(defun mastodon-toot--mentions-company-candidates (prefix)
+ "Given a company PREFIX query, build a list of candidates.
+The prefix can match against both user handles and display names."
+ (let ((prefix (substring prefix 1)) ;remove @ for search
+ (res))
+ (dolist (item (mastodon-search--search-accounts-query prefix))
+ (when (or (string-prefix-p prefix (substring (cadr item) 1) t)
+ (string-prefix-p prefix (car item) t))
+ (push (mastodon-toot--mentions-company-make-candidate item) res)))
+ res))
+
+(defun mastodon-toot--mentions-company-make-candidate (candidate)
+ "Construct a company completion CANDIDATE for display."
+ (let ((display-name (car candidate))
+ (handle (cadr candidate))
+ (url (caddr candidate)))
+ (propertize handle 'annot display-name 'meta url)))
+
+(defun mastodon-toot-mentions (command &optional arg &rest ignored)
+ "A company completion backend for toot mentions.
+COMMAND is either prefix, to fetch a prefix query, candidates, to
+build a list of candidates with query ARG, annotation, to format
+an annotation for candidate ARG, or meta, to format meta info for
+candidate ARG. IGNORED remains a mystery."
+ (interactive (list 'interactive))
+ (cl-case command
+ (interactive (company-begin-backend 'mastodon-toot-mentions))
+ (prefix (when (and (bound-and-true-p mastodon-toot-mode) ; if masto toot minor mode
+ (save-excursion
+ (forward-whitespace -1)
+ (forward-whitespace 1)
+ (looking-at "@")))
+ ;; @ + thing before point
+ (concat "@" (company-grab-symbol))))
+ (candidates (mastodon-toot--mentions-company-candidates arg))
+ (annotation (mastodon-toot--mentions-company-annotation arg))
+ (meta (mastodon-toot--mentions-company-meta arg))))
+
(defun mastodon-toot--reply ()
"Reply to toot at `point'."
(interactive)
(let* ((toot (mastodon-tl--property 'toot-json))
(id (mastodon-tl--as-string (mastodon-tl--field 'id toot)))
(account (mastodon-tl--field 'account toot))
- (user (cdr (assoc 'acct account)))
- (mentions (mastodon-toot--mentions toot)))
- (mastodon-toot (when user (concat (mastodon-toot--process-local user)
- mentions))
- id)))
+ (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)))))
+ (mastodon-toot (when user
+ (if booster
+ (if (and
+ (not (equal user booster))
+ (not (string-match booster mentions)))
+ (concat (mastodon-toot--process-local user)
+ ;; "@" booster " "
+ (mastodon-toot--process-local booster) mentions)
+ (concat (mastodon-toot--process-local user)
+ mentions))
+ (concat (mastodon-toot--process-local user)
+ mentions)))
+ id toot)))
(defun mastodon-toot--toggle-warning ()
"Toggle `mastodon-toot--content-warning'."
@@ -261,10 +609,10 @@ eg. \"feduser@fed.social\" -> \"feduser@fed.social\" "
(defun mastodon-toot--toggle-nsfw ()
"Toggle `mastodon-toot--content-nsfw'."
- ;; This only makes sense once we have attachments.
(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 ()
@@ -281,6 +629,79 @@ eg. \"feduser@fed.social\" -> \"feduser@fed.social\" "
"public")))
(mastodon-toot--update-status-fields))
+(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--attach-media (file content-type description)
+ "Prompt for an attachment FILE of CONTENT-TYPE 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: \nsContent type: \nsDescription: ")
+ (when (>= (length mastodon-toot--media-attachments) 4)
+ ;; Only a max. of 4 attachments are allowed, so pop the oldest one.
+ (pop mastodon-toot--media-attachments))
+ (if (file-directory-p file)
+ (message "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))
+ (:content-type . ,content-type)
+ (: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--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..." (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 (+ (car attachments-region) i)
+ (+ (car attachments-region) i 1)
+ (list 'display (or (nth i display-specs) ""))))))
+
+(defun mastodon-toot--format-attachments ()
+ "Format the attachment previews for display in toot draft buffer."
+ (or (let ((counter 0)
+ (image-options (when (or (image-type-available-p 'imagemagick)
+ (image-transforms-p))
+ `(:height ,mastodon-toot--attachment-height))))
+ (mapcan (lambda (attachment)
+ (let* ((data (alist-get :contents attachment))
+ (image (apply #'create-image data
+ (if (version< emacs-version "27.1")
+ (when image-options 'imagemagick)
+ nil) ; inbuilt scaling in 27.1
+ t image-options))
+ (type (alist-get :content-type attachment))
+ (description (alist-get :description attachment)))
+ (setq counter (1+ counter))
+ (list (format "\n %d: " counter)
+ image
+ (format " \"%s\" (%s)" description type))))
+ mastodon-toot--media-attachments))
+ (list "None")))
+
;; we'll need to revisit this if the binds get
;; more diverse than two-chord bindings
(defun mastodon-toot--get-mode-kbinds ()
@@ -308,24 +729,55 @@ e.g. mastodon-toot--send -> Send."
"Format a single keybinding, KBIND, for display in documentation."
(let ((key (help-key-description (car kbind) nil))
(command (mastodon-toot--format-kbind-command (cdr kbind))))
- (format "\t%s - %s" key command)))
+ (format " %s - %s" key command)))
(defun mastodon-toot--format-kbinds (kbinds)
- "Format a list keybindings, KBINDS, for display in documentation."
- (mapconcat 'identity (cons "" (mapcar #'mastodon-toot--format-kbind kbinds))
- "\n"))
+ "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--formatted-kbinds-longest (kbinds-list)
+ "Return the length of the longest item in KBINDS-LIST."
+ (let ((lengths (mapcar (lambda (x)
+ (length x))
+ kbinds-list)))
+ (car (sort lengths #'>))))
(defun mastodon-toot--make-mode-docs ()
"Create formatted documentation text for the mastodon-toot-mode."
- (let ((kbinds (mastodon-toot--get-mode-kbinds)))
+ (let* ((kbinds (mastodon-toot--get-mode-kbinds))
+ (longest-kbind
+ (mastodon-toot--formatted-kbinds-longest
+ (mastodon-toot--format-kbinds kbinds))))
(concat
" Compose a new toot here. The following keybindings are available:"
- (mastodon-toot--format-kbinds kbinds))))
+ ;; (mastodon-toot--format-kbinds kbinds))))
+ (mapconcat 'identity
+ (mastodon-toot--formatted-kbinds-pairs
+ (mastodon-toot--format-kbinds kbinds)
+ longest-kbind)
+ nil))))
(defun mastodon-toot--display-docs-and-status-fields ()
- "Insert propertized text with documentation about mastodon-toot mode and the
-status fields which will get updated based on the status of NSFW, content
-warning flags etc."
+ "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."
(let ((divider
"|=================================================================|"))
(insert
@@ -333,6 +785,8 @@ warning flags etc."
(concat
divider "\n"
(mastodon-toot--make-mode-docs) "\n"
+ ;; divider "\n"
+ ;; "\n"
divider "\n"
" "
(propertize "Count"
@@ -343,9 +797,12 @@ warning flags etc."
" ⋅ "
(propertize "CW"
'toot-post-cw-flag t)
- ;; " "
- ;; (propertize "NSFW"
- ;; 'toot-post-nsfw-flag t)
+ " "
+ (propertize "NSFW"
+ 'toot-post-nsfw-flag t)
+ "\n"
+ " Attachments: "
+ (propertize "None " 'toot-attachments t)
"\n"
divider
(propertize "\n"
@@ -354,57 +811,84 @@ warning flags etc."
'read-only "Edit your message below."
'toot-post-header t))))
-(defun mastodon-toot--setup-as-reply (reply-to-user reply-to-id)
+(defun mastodon-toot--setup-as-reply (reply-to-user reply-to-id reply-json)
"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."
- (when reply-to-user
- (insert (format "%s " reply-to-user))
- (setq mastodon-toot--reply-to-id reply-to-id)))
-
-(defun mastodon-toot--update-status-fields (&rest args)
+If REPLY-TO-ID is provided, set `mastodon-toot--reply-to-id'.
+REPLY-JSON is the full JSON of the toot being replied to."
+ (let ((reply-visibility (alist-get 'visibility reply-json))
+ (reply-cw (alist-get 'spoiler_text reply-json)))
+ (when reply-to-user
+ (insert (format "%s " reply-to-user))
+ (setq mastodon-toot--reply-to-id reply-to-id)
+ (if (not (equal mastodon-toot--visibility
+ reply-visibility))
+ (setq mastodon-toot--visibility reply-visibility))
+ (when (not (equal reply-cw ""))
+ (setq mastodon-toot--content-warning t)
+ (setq mastodon-toot--content-warning-from-reply-or-redraft reply-cw)))))
+
+(defun mastodon-toot--update-status-fields (&rest _args)
"Update the status fields in the header based on the current state."
- (let ((inhibit-read-only t)
- (header-region (mastodon-tl--find-property-range 'toot-post-header
+ (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)))
+ (visibility-region (mastodon-tl--find-property-range
+ 'toot-post-visibility (point-min)))
+ (nsfw-region (mastodon-tl--find-property-range 'toot-post-nsfw-flag
(point-min)))
- (count-region (mastodon-tl--find-property-range 'toot-post-counter
- (point-min)))
- (visibility-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)))
- )
- (add-text-properties (car count-region) (cdr count-region)
- (list 'display
- (format "%s characters in message"
- (- (point-max) (cdr header-region)))))
- (add-text-properties (car visibility-region) (cdr visibility-region)
- (list 'display
- (format "Visibility: %s"
- mastodon-toot--visibility)))
- ;; (add-text-properties (car nsfw-region) (cdr nsfw-region)
- ;; (list 'invisible (not mastodon-toot--content-nsfw)
- ;; 'face 'mastodon-cw-face))
- (add-text-properties (car cw-region) (cdr cw-region)
- (list 'invisible (not mastodon-toot--content-warning)
- 'face 'mastodon-cw-face))))
-
-(defun mastodon-toot--compose-buffer (reply-to-user reply-to-id)
+ (cw-region (mastodon-tl--find-property-range 'toot-post-cw-flag
+ (point-min))))
+ (add-text-properties (car count-region) (cdr count-region)
+ (list 'display
+ (format "%s/%s characters"
+ (- (point-max) (cdr header-region))
+ mastodon-toot--max-toot-chars)))
+ (add-text-properties (car visibility-region) (cdr visibility-region)
+ (list 'display
+ (format "Visibility: %s"
+ (if (equal
+ mastodon-toot--visibility
+ "private")
+ "followers-only"
+ mastodon-toot--visibility))))
+ (add-text-properties (car nsfw-region) (cdr nsfw-region)
+ (list 'display (if mastodon-toot--content-nsfw
+ (if mastodon-toot--media-attachments
+ "NSFW" "NSFW (no effect until attachments added)")
+ "")
+ 'face 'mastodon-cw-face))
+ (add-text-properties (car cw-region) (cdr cw-region)
+ (list 'invisible (not mastodon-toot--content-warning)
+ 'face 'mastodon-cw-face)))))
+
+(defun mastodon-toot--compose-buffer (reply-to-user reply-to-id &optional reply-json)
"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."
+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."
(let* ((buffer-exists (get-buffer "*new toot*"))
(buffer (or buffer-exists (get-buffer-create "*new toot*")))
(inhibit-read-only t))
(switch-to-buffer-other-window buffer)
+ (mastodon-toot-mode t)
(when (not buffer-exists)
(mastodon-toot--display-docs-and-status-fields)
- (mastodon-toot--setup-as-reply reply-to-user reply-to-id))
+ (mastodon-toot--setup-as-reply reply-to-user reply-to-id reply-json))
+ (mastodon-toot-mode t)
+ (unless mastodon-toot--max-toot-chars
+ (mastodon-toot--get-max-toot-chars))
+ (when (require 'company nil :noerror)
+ (when mastodon-toot--enable-completion-for-mentions
+ (set (make-local-variable 'company-backends)
+ (add-to-list 'company-backends 'mastodon-toot-mentions))
+ (company-mode-on)))
(make-local-variable 'after-change-functions)
(push #'mastodon-toot--update-status-fields after-change-functions)
- (mastodon-toot--update-status-fields)
- (mastodon-toot-mode t)))
+ (mastodon-toot--refresh-attachments-display)
+ (mastodon-toot--update-status-fields)))
(define-minor-mode mastodon-toot-mode
"Minor mode to capture Mastodon toots."
diff --git a/lisp/mastodon.el b/lisp/mastodon.el
index 07535ec..d5f9b6e 100644
--- a/lisp/mastodon.el
+++ b/lisp/mastodon.el
@@ -2,9 +2,10 @@
;; Copyright (C) 2017-2019 Johnson Denen
;; Author: Johnson Denen <johnson.denen@gmail.com>
-;; Version: 0.9.0
-;; Package-Requires: ((emacs "24.4"))
-;; Homepage: https://github.com/jdenen/mastodon.el
+;; Maintainer: Marty Hiatt <martianhiatus@riseup.net>
+;; Version: 0.10.0
+;; Package-Requires: ((emacs "27.1") (request "0.3.2") (seq "1.0"))
+;; Homepage: https://git.blast.noho.st/mouse/mastodon.el
;; This file is not part of GNU Emacs.
@@ -30,8 +31,13 @@
;; it is a labor of love.
;;; Code:
+(require 'cl-lib) ; for `cl-some' call in mastodon
+;; hack to make mastodon-toot customizes visible prior to running mastodon-toot:
+(require 'mastodon-toot)
+
(declare-function discover-add-context-menu "discover")
(declare-function emojify-mode "emojify")
+(declare-function request "request")
(autoload 'special-mode "simple")
(autoload 'mastodon-tl--get-federated-timeline "mastodon-tl")
(autoload 'mastodon-tl--get-home-timeline "mastodon-tl")
@@ -48,12 +54,40 @@
(autoload 'mastodon-profile--get-toot-author "mastodon-profile")
(autoload 'mastodon-profile--make-author-buffer "mastodon-profile")
(autoload 'mastodon-profile--show-user "mastodon-profile")
-(autoload 'mastodon-toot--compose-buffer "mastodon-toot")
-(autoload 'mastodon-toot--reply "mastodon-toot")
-(autoload 'mastodon-toot--toggle-boost "mastodon-toot")
-(autoload 'mastodon-toot--toggle-favourite "mastodon-toot")
+;; (autoload 'mastodon-toot--compose-buffer "mastodon-toot")
+;; (autoload 'mastodon-toot--reply "mastodon-toot")
+;; (autoload 'mastodon-toot--toggle-boost "mastodon-toot")
+;; (autoload 'mastodon-toot--toggle-favourite "mastodon-toot")
(autoload 'mastodon-discover "mastodon-discover")
+(autoload 'mastodon-tl--block-user "mastodon-tl")
+(autoload 'mastodon-tl--unblock-user "mastodon-tl")
+(autoload 'mastodon-tl--mute-user "mastodon-tl")
+(autoload 'mastodon-tl--unmute-user "mastodon-tl")
+(autoload 'mastodon-tl--follow-user "mastodon-tl")
+(autoload 'mastodon-tl--unfollow-user "mastodon-tl")
+(autoload 'mastodon-profile--my-profile "mastodon-profile")
+(autoload 'mastodon-profile--view-favourites "mastodon-profile")
+(autoload 'mastodon-profile--view-follow-requests "mastodon-profile")
+(autoload 'mastodon-notifications--follow-request-accept-notifs "mastodon-profile")
+(autoload 'mastodon-notifications--follow-request-reject-notifs "mastodon-profile")
+(autoload 'mastodon-search--search-query "mastodon-search")
+;; (autoload 'mastodon-toot--delete-toot "mastodon-toot")
+;; (autoload 'mastodon-toot--copy-toot-url "mastodon-toot")
+;; (autoload 'mastodon-toot--pin-toot-toggle "mastodon-toot")
+(autoload 'mastodon-auth--get-account-name "mastodon-auth")
+;; (autoload 'mastodon-async--stream-federated "mastodon-async")
+;; (autoload 'mastodon-async--stream-local "mastodon-async")
+;; (autoload 'mastodon-async--stream-home "mastodon-async")
+;; (autoload 'mastodon-async--stream-notifications "mastodon-async")
+;; (autoload 'mastodon-async-mode "mastodon-async")
+(autoload 'mastodon-profile--update-user-profile-note "mastodon-profile")
+(autoload 'mastodon-auth--user-acct "mastodon-auth")
+(autoload 'mastodon-tl--poll-vote "mastodon-http")
+;; (autoload 'mastodon-toot--delete-and-redraft-toot "mastodon-toot")
+(autoload 'mastodon-profile--view-bookmarks "mastodon-profile")
+;; (autoload 'mastodon-toot--bookmark-toot-toggle "mastodon-toot")
+
(defgroup mastodon nil
"Interface with Mastodon."
:prefix "mastodon-"
@@ -94,7 +128,7 @@ Use. e.g. \"%c\" for your locale's date and time format."
(define-key map (kbd "P") #'mastodon-profile--show-user)
(define-key map (kbd "T") #'mastodon-tl--thread)
;; navigation out of mastodon
- (define-key map (kbd "q") #'kill-this-buffer)
+ (define-key map (kbd "q") #'kill-current-buffer)
(define-key map (kbd "Q") #'kill-buffer-and-window)
;; timeline actions
(define-key map (kbd "b") #'mastodon-toot--toggle-boost)
@@ -106,7 +140,33 @@ Use. e.g. \"%c\" for your locale's date and time format."
(define-key map (kbd "t") #'mastodon-toot)
;; override special mode binding
(define-key map (kbd "g") #'undefined)
+ ;; mousebot additions
+ (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 "O") #'mastodon-profile--my-profile)
+ (define-key map (kbd "S") #'mastodon-search--search-query)
+ (define-key map (kbd "d") #'mastodon-toot--delete-toot)
+ (define-key map (kbd "D") #'mastodon-toot--delete-and-redraft-toot)
+ (define-key map (kbd "C") #'mastodon-toot--copy-toot-url)
+ (define-key map (kbd "i") #'mastodon-toot--pin-toot-toggle)
+ (define-key map (kbd "V") #'mastodon-profile--view-favourites)
+ (define-key map (kbd "R") #'mastodon-profile--view-follow-requests)
+ ;; (define-key map (kbd "C-c h") #'mastodon-async--stream-home)
+ ;; (define-key map (kbd "C-c f") #'mastodon-async--stream-federated)
+ ;; (define-key map (kbd "C-c l") #'mastodon-async--stream-local)
+ ;; (define-key map (kbd "C-c n") #'mastodon-async--stream-notifications)
+ (define-key map (kbd "U") #'mastodon-profile--update-user-profile-note)
+ (define-key map (kbd "a") #'mastodon-notifications--follow-request-accept-notifs)
+ (define-key map (kbd "j") #'mastodon-notifications--follow-request-reject-notifs)
+ (define-key map (kbd "v") #'mastodon-tl--poll-vote)
+ (define-key map (kbd "k") #'mastodon-toot--bookmark-toot-toggle)
+ (define-key map (kbd "K") #'mastodon-profile--view-bookmarks)
map)
+
"Keymap for `mastodon-mode'.")
(defcustom mastodon-mode-hook nil
@@ -124,7 +184,7 @@ Use. e.g. \"%c\" for your locale's date and time format."
"Face used for user display names.")
(defface mastodon-boosted-face
- '((t :inherit highlight :weight bold))
+ '((t :inherit success :weight bold))
"Face to indicate that a toot is boosted.")
(defface mastodon-boost-fave-face
@@ -139,21 +199,35 @@ Use. e.g. \"%c\" for your locale's date and time format."
(defun mastodon ()
"Connect Mastodon client to `mastodon-instance-url' instance."
(interactive)
- (mastodon-tl--get-home-timeline))
+ (let* ((tls (list "home"
+ "local"
+ "federated"
+ (concat (mastodon-auth--user-acct) "-statuses") ; profile
+ "favourites"
+ "search"))
+ (buffer (cl-some (lambda (el)
+ (get-buffer (concat "*mastodon-" el "*")))
+ tls))) ; return first buff that exists
+ (if buffer
+ (switch-to-buffer buffer)
+ (mastodon-tl--get-home-timeline)
+ (message "Loading Mastodon account %s on %s..." (mastodon-auth--user-acct) mastodon-instance-url))))
;;;###autoload
-(defun mastodon-toot (&optional user reply-to-id)
+(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-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))
+ (mastodon-toot--compose-buffer user reply-to-id reply-json))
;;;###autoload
(add-hook 'mastodon-mode-hook (lambda ()
(when (require 'emojify nil :noerror)
- (emojify-mode t))))
+ (emojify-mode t)
+ (when mastodon-toot--enable-custom-instance-emoji
+ (mastodon-toot--enable-custom-emoji)))))
(define-derived-mode mastodon-mode special-mode "Mastodon"
"Major mode for Mastodon, the federated microblogging network."
diff --git a/test/ert-helper.el b/test/ert-helper.el
index 6979837..a6d6692 100644
--- a/test/ert-helper.el
+++ b/test/ert-helper.el
@@ -1,8 +1,14 @@
+(load-file "lisp/mastodon-search.el")
+(load-file "lisp/mastodon-async.el")
(load-file "lisp/mastodon-http.el")
-(load-file "lisp/mastodon-client.el")
(load-file "lisp/mastodon-auth.el")
-(load-file "lisp/mastodon-toot.el")
+(load-file "lisp/mastodon-client.el")
+(load-file "lisp/mastodon-discover.el")
+(load-file "lisp/mastodon-inspect.el")
(load-file "lisp/mastodon-media.el")
-(load-file "lisp/mastodon-tl.el")
(load-file "lisp/mastodon-notifications.el")
+(load-file "lisp/mastodon-profile.el")
+(load-file "lisp/mastodon-search.el")
+(load-file "lisp/mastodon-tl.el")
+(load-file "lisp/mastodon-toot.el")
(load-file "lisp/mastodon.el")
diff --git a/test/fixture b/test/fixture
new file mode 120000
index 0000000..f418013
--- /dev/null
+++ b/test/fixture
@@ -0,0 +1 @@
+../fixture \ No newline at end of file
diff --git a/test/mastodon-auth-tests.el b/test/mastodon-auth-tests.el
index 7daa4db..6a090b7 100644
--- a/test/mastodon-auth-tests.el
+++ b/test/mastodon-auth-tests.el
@@ -1,66 +1,105 @@
+;;; mastodon-auth-test.el --- Tests for mastodon-auth.el -*- lexical-binding: nil -*-
+
(require 'el-mock)
-(ert-deftest generate-token--no-storing-credentials ()
+(ert-deftest mastodon-auth--handle-token-response--good ()
+ "Should extract the access token from a good response."
+ (should
+ (string=
+ "foo"
+ (mastodon-auth--handle-token-response
+ '(:access_token "foo" :token_type "Bearer" :scope "read write follow" :created_at 0)))))
+
+(ert-deftest mastodon-auth--handle-token-response--unknown ()
+ "Should throw an error when the response is unparsable."
+ (should
+ (equal
+ '(error "Unknown response from mastodon-auth--get-token!")
+ (condition-case error
+ (progn
+ (mastodon-auth--handle-token-response '(:herp "derp"))
+ nil)
+ (t error)))))
+
+(ert-deftest mastodon-auth--handle-token-response--failure ()
+ "Should throw an error when the response indicates an error."
+ (let ((error-message "The provided authorization grant is invalid, expired, revoked, does not match the redirection URI used in the authorization request, or was issued to another client."))
+ (should
+ (equal
+ `(error ,(format "Mastodon-auth--access-token: invalid_grant: %s" error-message))
+ (condition-case error
+ (mastodon-auth--handle-token-response
+ `(:error "invalid_grant" :error_description ,error-message))
+ (t error))))))
+
+(ert-deftest mastodon-auth--generate-token--no-storing-credentials ()
"Should make `mastdon-http--post' request to generate auth token."
(with-mock
- (let ((mastodon-auth-source-file "")
- (mastodon-instance-url "https://instance.url"))
- (mock (mastodon-client) => '(:client_id "id" :client_secret "secret"))
- (mock (read-string "Email: " user-mail-address) => "foo@bar.com")
- (mock (read-passwd "Password: ") => "password")
- (mock (mastodon-http--post "https://instance.url/oauth/token"
- '(("client_id" . "id")
- ("client_secret" . "secret")
- ("grant_type" . "password")
- ("username" . "foo@bar.com")
- ("password" . "password")
- ("scope" . "read write follow"))
- nil
- :unauthenticated))
- (mastodon-auth--generate-token))))
+ (let ((mastodon-auth-source-file "")
+ (mastodon-instance-url "https://instance.url"))
+ (mock (mastodon-client) => '(:client_id "id" :client_secret "secret"))
+ (mock (read-string "Email: " user-mail-address) => "foo@bar.com")
+ (mock (read-passwd "Password: ") => "password")
+ (mock (mastodon-http--post "https://instance.url/oauth/token"
+ '(("client_id" . "id")
+ ("client_secret" . "secret")
+ ("grant_type" . "password")
+ ("username" . "foo@bar.com")
+ ("password" . "password")
+ ("scope" . "read write follow"))
+ nil
+ :unauthenticated))
+ (mastodon-auth--generate-token))))
-(ert-deftest generate-token--storing-credentials ()
+(ert-deftest mastodon-auth--generate-token--storing-credentials ()
"Should make `mastdon-http--post' request to generate auth token."
(with-mock
- (let ((mastodon-auth-source-file "~/.authinfo")
- (mastodon-instance-url "https://instance.url"))
- (mock (mastodon-client) => '(:client_id "id" :client_secret "secret"))
- (mock (auth-source-search :create t
- :host "https://instance.url"
- :port 443
- :require '(:user :secret))
- => '((:user "foo@bar.com" :secret (lambda () "password"))))
- (mock (mastodon-http--post "https://instance.url/oauth/token"
- '(("client_id" . "id")
- ("client_secret" . "secret")
- ("grant_type" . "password")
- ("username" . "foo@bar.com")
- ("password" . "password")
- ("scope" . "read write follow"))
- nil
- :unauthenticated))
- (mastodon-auth--generate-token))))
+ (let ((mastodon-auth-source-file "~/.authinfo")
+ (mastodon-instance-url "https://instance.url"))
+ (mock (mastodon-client) => '(:client_id "id" :client_secret "secret"))
+ (mock (auth-source-search :create t
+ :host "https://instance.url"
+ :port 443
+ :require '(:user :secret))
+ => '((:user "foo@bar.com" :secret (lambda () "password"))))
+ (mock (mastodon-http--post "https://instance.url/oauth/token"
+ '(("client_id" . "id")
+ ("client_secret" . "secret")
+ ("grant_type" . "password")
+ ("username" . "foo@bar.com")
+ ("password" . "password")
+ ("scope" . "read write follow"))
+ nil
+ :unauthenticated))
+ (mastodon-auth--generate-token))))
-(ert-deftest get-token ()
+(ert-deftest mastodon-auth--get-token ()
"Should generate token and return JSON response."
(with-temp-buffer
(with-mock
(mock (mastodon-auth--generate-token) => (progn
- (insert "\n\n{\"access_token\":\"abcdefg\"}")
- (current-buffer)))
- (should (equal (mastodon-auth--get-token) '(:access_token "abcdefg"))))))
+ (insert "\n\n{\"access_token\":\"abcdefg\"}")
+ (current-buffer)))
+ (should
+ (equal (mastodon-auth--get-token)
+ '(:access_token "abcdefg"))))))
-(ert-deftest access-token-found ()
+(ert-deftest mastodon-auth--access-token-found ()
"Should return value in `mastodon-auth--token-alist' if found."
(let ((mastodon-instance-url "https://instance.url")
(mastodon-auth--token-alist '(("https://instance.url" . "foobar")) ))
- (should (string= (mastodon-auth--access-token) "foobar"))))
+ (should
+ (string= (mastodon-auth--access-token) "foobar"))))
-(ert-deftest access-token-2 ()
+(ert-deftest mastodon-auth--access-token-not-found ()
"Should set and return `mastodon-auth--token' if nil."
(let ((mastodon-instance-url "https://instance.url")
- (mastodon-auth--token nil))
+ (mastodon-auth--token-alist nil))
(with-mock
(mock (mastodon-auth--get-token) => '(:access_token "foobaz"))
- (should (string= (mastodon-auth--access-token) "foobaz"))
- (should (equal mastodon-auth--token-alist '(("https://instance.url" . "foobaz")))))))
+ (should
+ (string= (mastodon-auth--access-token)
+ "foobaz"))
+ (should
+ (equal mastodon-auth--token-alist
+ '(("https://instance.url" . "foobaz")))))))
diff --git a/test/mastodon-client-tests.el b/test/mastodon-client-tests.el
index dfe175b..9123286 100644
--- a/test/mastodon-client-tests.el
+++ b/test/mastodon-client-tests.el
@@ -1,28 +1,30 @@
+;;; mastodon-client-test.el --- Tests for mastodon-client.el -*- lexical-binding: nil -*-
+
(require 'el-mock)
-(ert-deftest register ()
+(ert-deftest mastodon-client--register ()
"Should POST to /apps."
(with-mock
- (mock (mastodon-http--api "apps") => "https://instance.url/api/v1/apps")
- (mock (mastodon-http--post "https://instance.url/api/v1/apps"
- '(("client_name" . "mastodon.el")
- ("redirect_uris" . "urn:ietf:wg:oauth:2.0:oob")
- ("scopes" . "read write follow")
- ("website" . "https://github.com/jdenen/mastodon.el"))
- nil
- :unauthenticated))
- (mastodon-client--register)))
+ (mock (mastodon-http--api "apps") => "https://instance.url/api/v1/apps")
+ (mock (mastodon-http--post "https://instance.url/api/v1/apps"
+ '(("client_name" . "mastodon.el")
+ ("redirect_uris" . "urn:ietf:wg:oauth:2.0:oob")
+ ("scopes" . "read write follow")
+ ("website" . "https://github.com/jdenen/mastodon.el"))
+ nil
+ :unauthenticated))
+ (mastodon-client--register)))
-(ert-deftest fetch ()
+(ert-deftest mastodon-client--fetch ()
"Should return client registration JSON."
(with-temp-buffer
(with-mock
(mock (mastodon-client--register) => (progn
- (insert "\n\n{\"foo\":\"bar\"}")
- (current-buffer)))
+ (insert "\n\n{\"foo\":\"bar\"}")
+ (current-buffer)))
(should (equal (mastodon-client--fetch) '(:foo "bar"))))))
-(ert-deftest store-1 ()
+(ert-deftest mastodon-client--store-1 ()
"Should return the client plist."
(let ((mastodon-instance-url "http://mastodon.example")
(plist '(:client_id "id" :client_secret "secret")))
@@ -33,44 +35,44 @@
(client (cdr (plstore-get plstore "mastodon-http://mastodon.example"))))
(should (equal (mastodon-client--store) plist))))))
-(ert-deftest store-2 ()
- "Should store client in `mastodon-client--token-file'."
- (let* ((mastodon-instance-url "http://mastodon.example")
- (plstore (plstore-open "stubfile.plstore"))
- (client (cdr (plstore-get plstore "mastodon-http://mastodon.example"))))
- (plstore-close plstore)
- (should (string= (plist-get client :client_id) "id"))
- (should (string= (plist-get client :client_secret) "secret"))))
+(ert-deftest mastodon-client--store-2 ()
+ "Should store client in `mastodon-client--token-file'."
+ (let* ((mastodon-instance-url "http://mastodon.example")
+ (plstore (plstore-open "stubfile.plstore"))
+ (client (cdr (plstore-get plstore "mastodon-http://mastodon.example"))))
+ (plstore-close plstore)
+ (should (string= (plist-get client :client_id) "id"))
+ (should (string= (plist-get client :client_secret) "secret"))))
-(ert-deftest read-finds-match ()
+(ert-deftest mastodon-client--read-finds-match ()
"Should return mastodon client from `mastodon-token-file' if it exists."
(let ((mastodon-instance-url "http://mastodon.example"))
(with-mock
- (mock (mastodon-client--token-file) => "fixture/client.plstore")
- (should (equal (mastodon-client--read)
- '(:client_id "id2" :client_secret "secret2"))))))
+ (mock (mastodon-client--token-file) => "fixture/client.plstore")
+ (should (equal (mastodon-client--read)
+ '(:client_id "id2" :client_secret "secret2"))))))
-(ert-deftest read-finds-no-match ()
+(ert-deftest mastodon-client--read-finds-no-match ()
"Should return mastodon client from `mastodon-token-file' if it exists."
(let ((mastodon-instance-url "http://mastodon.social"))
(with-mock
- (mock (mastodon-client--token-file) => "fixture/client.plstore")
- (should (equal (mastodon-client--read) nil)))))
+ (mock (mastodon-client--token-file) => "fixture/client.plstore")
+ (should (equal (mastodon-client--read) nil)))))
-(ert-deftest read-empty-store ()
+(ert-deftest mastodon-client--read-empty-store ()
"Should return nil if mastodon client is not present in the plstore."
(with-mock
(mock (mastodon-client--token-file) => "fixture/empty.plstore")
(should (equal (mastodon-client--read) nil))))
-(ert-deftest client-set-and-matching ()
+(ert-deftest mastodon-client--client-set-and-matching ()
"Should return `mastondon-client' if `mastodon-client--client-details-alist' is non-nil and instance url is included."
(let ((mastodon-instance-url "http://mastodon.example")
(mastodon-client--client-details-alist '(("https://other.example" . :no-match)
("http://mastodon.example" . :matches))))
(should (eq (mastodon-client) :matches))))
-(ert-deftest client-set-but-not-matching ()
+(ert-deftest mastodon-client--client-set-but-not-matching ()
"Should read from `mastodon-token-file' if wrong data is cached."
(let ((mastodon-instance-url "http://mastodon.example")
(mastodon-client--client-details-alist '(("http://other.example" :wrong))))
@@ -81,7 +83,7 @@
'(("http://mastodon.example" :client_id "foo" :client_secret "bar")
("http://other.example" :wrong)))))))
-(ert-deftest client-unset ()
+(ert-deftest mastodon-client--client-unset ()
"Should read from `mastodon-token-file' if available."
(let ((mastodon-instance-url "http://mastodon.example")
(mastodon-client--client-details-alist nil))
@@ -91,7 +93,7 @@
(should (equal mastodon-client--client-details-alist
'(("http://mastodon.example" :client_id "foo" :client_secret "bar")))))))
-(ert-deftest client-unset-and-not-in-storage ()
+(ert-deftest mastodon-client--client-unset-and-not-in-storage ()
"Should store client data in plstore if it can't be read."
(let ((mastodon-instance-url "http://mastodon.example")
(mastodon-client--client-details-alist nil))
diff --git a/test/mastodon-http-tests.el b/test/mastodon-http-tests.el
index 972cedb..dc4aa76 100644
--- a/test/mastodon-http-tests.el
+++ b/test/mastodon-http-tests.el
@@ -1,9 +1,85 @@
+;;; mastodon-http-test.el --- Tests for mastodon-http.el -*- lexical-binding: nil -*-
+
(require 'el-mock)
-(ert-deftest mastodon-http:get:retrieves-endpoint ()
+(defconst mastodon-http--example-200
+ "HTTP/1.1 200 OK
+Date: Mon, 20 Dec 2021 13:42:29 GMT
+Content-Type: application/json; charset=utf-8
+Transfer-Encoding: chunked
+Connection: keep-alive
+Server: Mastodon
+X-Frame-Options: DENY
+X-Content-Type-Options: nosniff
+X-XSS-Protection: 1; mode=block
+Permissions-Policy: interest-cohort=()
+X-RateLimit-Limit: 300
+X-RateLimit-Remaining: 298
+X-RateLimit-Reset: 2021-12-20T13:45:00.630990Z
+Cache-Control: no-store
+Vary: Accept, Accept-Encoding, Origin
+ETag: W/\"bee52f489c87e9a305e5d0b7bdca7ac1\"
+X-Request-Id: 5be9a64e-7d97-41b4-97f3-17b5e972a675
+X-Runtime: 0.371914
+Strict-Transport-Security: max-age=63072000; includeSubDomains
+Strict-Transport-Security: max-age=31536000
+
+{\"id\":\"18173\",\"following\":true,\"showing_reblogs\":true,\"notifying\":true,\"followed_by\":true,\"blocking\":false,\"blocked_by\":false,\"muting\":false,\"muting_notifications\":false,\"requested\":false,\"domain_blocking\":false,\"endorsed\":false,\"note\":\"\"}")
+
+(defconst mastodon-http--example-400
+ "HTTP/1.1 444 OK
+Date: Mon, 20 Dec 2021 13:42:29 GMT
+Content-Type: application/json; charset=utf-8
+Transfer-Encoding: chunked
+Connection: keep-alive
+Server: Mastodon
+X-Frame-Options: DENY
+X-Content-Type-Options: nosniff
+X-XSS-Protection: 1; mode=block
+Permissions-Policy: interest-cohort=()
+X-RateLimit-Limit: 300
+X-RateLimit-Remaining: 298
+X-RateLimit-Reset: 2021-12-20T13:45:00.630990Z
+Cache-Control: no-store
+Vary: Accept, Accept-Encoding, Origin
+ETag: W/\"bee52f489c87e9a305e5d0b7bdca7ac1\"
+X-Request-Id: 5be9a64e-7d97-41b4-97f3-17b5e972a675
+X-Runtime: 0.371914
+Strict-Transport-Security: max-age=63072000; includeSubDomains
+Strict-Transport-Security: max-age=31536000
+
+{\"error\":\"some unhappy complaint\"}")
+
+(ert-deftest mastodon-http--get-retrieves-endpoint ()
"Should make a `url-retrieve' of the given URL."
- (let ((callback-double (lambda () "double")))
- (with-mock
- (mock (url-retrieve-synchronously "https://foo.bar/baz"))
- (mock (mastodon-auth--access-token) => "test-token")
- (mastodon-http--get "https://foo.bar/baz"))))
+ (with-mock
+ (mock (mastodon-http--url-retrieve-synchronously "https://foo.bar/baz"))
+ (mock (mastodon-auth--access-token) => "test-token")
+ (mastodon-http--get "https://foo.bar/baz")))
+
+(ert-deftest mastodon-http--triage-success ()
+ "Should run success function for 200 HTML response."
+ (let ((response-buffer
+ (get-buffer-create "mastodon-http--triage-buffer")))
+ (with-current-buffer response-buffer
+ (erase-buffer)
+ (insert mastodon-http--example-200))
+ (should (equal (mastodon-http--triage
+ response-buffer
+ (lambda ()
+ (message "success call")))
+ "success call"))))
+
+(ert-deftest mastodon-http--triage-failure ()
+ "Should return formatted JSON error from bad HTML response buffer.
+ Should not run success function."
+ (let ((response-buffer
+ (get-buffer-create "mastodon-http--triage-buffer")))
+ (with-current-buffer response-buffer
+ (erase-buffer)
+ (insert mastodon-http--example-400))
+ (should (equal (mastodon-http--triage
+ response-buffer
+ (lambda ()
+ (message "success call")))
+ "Error 444: some unhappy complaint"))))
diff --git a/test/mastodon-media-tests.el b/test/mastodon-media-tests.el
index a586be9..0e1152a 100644
--- a/test/mastodon-media-tests.el
+++ b/test/mastodon-media-tests.el
@@ -1,10 +1,12 @@
+;;; mastodon-media-test.el --- Tests for mastodon-media.el -*- lexical-binding: nil -*-
+
(require 'el-mock)
-(ert-deftest mastodon-media:get-avatar-rendering ()
+(ert-deftest mastodon-media--get-avatar-rendering ()
"Should return text with all expected properties."
(with-mock
(mock (image-type-available-p 'imagemagick) => t)
- (mock (create-image * 'imagemagick t :height 123) => :mock-image)
+ (mock (create-image * (when (version< emacs-version "27.1") 'imagemagick) t :height 123) => :mock-image)
(let* ((mastodon-media--avatar-height 123)
(result (mastodon-media--get-avatar-rendering "http://example.org/img.png"))
@@ -16,33 +18,69 @@
(should (eq 'avatar (plist-get properties 'media-type)))
(should (eq :mock-image (plist-get properties 'display))))))
-(ert-deftest mastodon-media:get-media-link-rendering ()
+(ert-deftest mastodon-media--get-media-link-rendering ()
"Should return text with all expected properties."
(with-mock
- (mock (create-image * nil t) => :mock-image)
-
- (let* ((mastodon-media--preview-max-height 123)
- (result (mastodon-media--get-media-link-rendering "http://example.org/img.png"))
- (result-no-properties (substring-no-properties result))
- (properties (text-properties-at 0 result)))
- (should (string= "[img] " result-no-properties))
- (should (string= "http://example.org/img.png" (plist-get properties 'media-url)))
- (should (eq 'needs-loading (plist-get properties 'media-state)))
- (should (eq 'media-link (plist-get properties 'media-type)))
- (should (eq :mock-image (plist-get properties 'display))))))
-
-(ert-deftest mastodon-media:load-image-from-url:avatar-with-imagemagic ()
+ (mock (create-image * nil t) => :mock-image)
+ (let* ((mastodon-media--preview-max-height 123)
+ (result
+ (mastodon-media--get-media-link-rendering "http://example.org/img.png"
+ "http://example.org/remote/img.png"
+ "image"))
+ (result-no-properties (substring-no-properties result))
+ (properties (text-properties-at 0 result)))
+ (should (string= "[img] " result-no-properties))
+ (should (string= "http://example.org/img.png" (plist-get properties 'media-url)))
+ (should (eq 'needs-loading (plist-get properties 'media-state)))
+ (should (eq 'media-link (plist-get properties 'media-type)))
+ (should (eq :mock-image (plist-get properties 'display)))
+ (should (eq 'highlight (plist-get properties 'mouse-face)))
+ (should (eq 'image (plist-get properties 'mastodon-tab-stop)))
+ (should (string= "http://example.org/remote/img.png" (plist-get properties 'image-url)))
+ (should (eq mastodon-tl--shr-image-map-replacement (plist-get properties 'keymap)))
+ (should (string= "image" (plist-get properties 'mastodon-media-type)))
+ (should (string= "RET/i: load full image (prefix: copy URL), +/-: zoom, r: rotate, o: save preview"
+ (plist-get properties 'help-echo))))))
+
+(ert-deftest mastodon-media:get-media-link-rendering-gif ()
+ "Should return text with all expected properties."
+ (with-mock
+ (mock (create-image * nil t) => :mock-image)
+ (let* ((mastodon-media--preview-max-height 123)
+ (result
+ (mastodon-media--get-media-link-rendering "http://example.org/img.png"
+ "http://example.org/remote/img.png"
+ "gifv"))
+ (result-no-properties (substring-no-properties result))
+ (properties (text-properties-at 0 result)))
+ (should (string= "[img] " result-no-properties))
+ (should (string= "http://example.org/img.png" (plist-get properties 'media-url)))
+ (should (eq 'needs-loading (plist-get properties 'media-state)))
+ (should (eq 'media-link (plist-get properties 'media-type)))
+ (should (eq :mock-image (plist-get properties 'display)))
+ (should (eq 'highlight (plist-get properties 'mouse-face)))
+ (should (eq 'image (plist-get properties 'mastodon-tab-stop)))
+ (should (string= "http://example.org/remote/img.png" (plist-get properties 'image-url)))
+ (should (eq mastodon-tl--shr-image-map-replacement (plist-get properties 'keymap)))
+ (should (string= "gifv" (plist-get properties 'mastodon-media-type)))
+ (should (string= "RET/i: load full image (prefix: copy URL), +/-: zoom, r: rotate, o: save preview\ntype: gifv"
+ (plist-get properties 'help-echo))))))
+
+(ert-deftest mastodon-media--load-image-from-url-avatar-with-imagemagic ()
"Should make the right call to url-retrieve."
(let ((url "http://example.org/image.png")
(mastodon-media--avatar-height 123))
(with-mock
(mock (image-type-available-p 'imagemagick) => t)
- (mock (create-image * 'imagemagick t :height 123) => '(image foo))
+ (mock (create-image
+ *
+ (when (version< emacs-version "27.1") 'imagemagick)
+ t :height 123) => '(image foo))
(mock (copy-marker 7) => :my-marker )
(mock (url-retrieve
url
#'mastodon-media--process-image-response
- '(:my-marker (:height 123) 1))
+ `(:my-marker (:height 123) 1 ,url))
=> :called-as-expected)
(with-temp-buffer
@@ -52,17 +90,18 @@
(should (eq :called-as-expected (mastodon-media--load-image-from-url url 'avatar 7 1)))))))
-(ert-deftest mastodon-media:load-image-from-url:avatar-without-imagemagic ()
+(ert-deftest mastodon-media--load-image-from-url-avatar-without-imagemagic ()
"Should make the right call to url-retrieve."
(let ((url "http://example.org/image.png"))
(with-mock
(mock (image-type-available-p 'imagemagick) => nil)
+ (mock (image-transforms-p) => nil)
(mock (create-image * nil t) => '(image foo))
(mock (copy-marker 7) => :my-marker )
(mock (url-retrieve
url
#'mastodon-media--process-image-response
- '(:my-marker () 1))
+ `(:my-marker () 1 ,url))
=> :called-as-expected)
(with-temp-buffer
@@ -72,7 +111,7 @@
(should (eq :called-as-expected (mastodon-media--load-image-from-url url 'avatar 7 1)))))))
-(ert-deftest mastodon-media:load-image-from-url:media-link-with-imagemagic ()
+(ert-deftest mastodon-media--load-image-from-url-media-link-with-imagemagic ()
"Should make the right call to url-retrieve."
(let ((url "http://example.org/image.png"))
(with-mock
@@ -82,7 +121,7 @@
(mock (url-retrieve
"http://example.org/image.png"
#'mastodon-media--process-image-response
- '(:my-marker (:max-height 321) 5))
+ '(:my-marker (:max-height 321) 5 "http://example.org/image.png"))
=> :called-as-expected)
(with-temp-buffer
(insert (concat "Start:"
@@ -91,17 +130,18 @@
(let ((mastodon-media--preview-max-height 321))
(should (eq :called-as-expected (mastodon-media--load-image-from-url url 'media-link 7 5))))))))
-(ert-deftest mastodon-media:load-image-from-url:media-link-without-imagemagic ()
+(ert-deftest mastodon-media--load-image-from-url-media-link-without-imagemagic ()
"Should make the right call to url-retrieve."
(let ((url "http://example.org/image.png"))
(with-mock
(mock (image-type-available-p 'imagemagick) => nil)
+ (mock (image-transforms-p) => nil)
(mock (create-image * nil t) => '(image foo))
(mock (copy-marker 7) => :my-marker )
(mock (url-retrieve
"http://example.org/image.png"
#'mastodon-media--process-image-response
- '(:my-marker () 5))
+ '(:my-marker () 5 "http://example.org/image.png"))
=> :called-as-expected)
(with-temp-buffer
@@ -111,13 +151,16 @@
(let ((mastodon-media--preview-max-height 321))
(should (eq :called-as-expected (mastodon-media--load-image-from-url url 'media-link 7 5))))))))
-(ert-deftest mastodon-media:load-image-from-url:url-fetching-fails ()
+(ert-deftest mastodon-media--load-image-from-url-url-fetching-fails ()
"Should cope with failures in url-retrieve."
(let ((url "http://example.org/image.png")
(mastodon-media--avatar-height 123))
(with-mock
(mock (image-type-available-p 'imagemagick) => t)
- (mock (create-image * 'imagemagick t :height 123) => '(image foo))
+ (mock (create-image
+ *
+ (when (version< emacs-version "27.1") 'imagemagick)
+ t :height 123) => '(image foo))
(stub url-retrieve => (error "url-retrieve failed"))
(with-temp-buffer
@@ -129,38 +172,44 @@
;; the media state was updated so we won't load this again:
(should (eq 'loading-failed (get-text-property 7 'media-state)))))))
-(ert-deftest mastodon-media:process-image-response ()
+(ert-deftest mastodon-media--process-image-response ()
"Should process the HTTP response and adjust the source buffer."
(with-temp-buffer
(with-mock
(let ((source-buffer (current-buffer))
- used-marker
- saved-marker)
- (insert "start:")
- (setq used-marker (copy-marker (point))
- saved-marker (copy-marker (point)))
- ;; Mock needed for the preliminary image created in mastodon-media--get-avatar-rendering
- (stub create-image => :fake-image)
- (insert (mastodon-media--get-avatar-rendering "http://example.org/image.png")
- ":end")
- (with-temp-buffer
- (insert "some irrelevant\n"
- "http headers\n"
- "which will be ignored\n\n"
- "fake\nimage\ndata")
- (goto-char (point-min))
-
- (mock (create-image "fake\nimage\ndata" 'imagemagick t ':image :option) => :fake-image)
-
- (mastodon-media--process-image-response () used-marker '(:image :option) 1)
-
- ;; the used marker has been unset:
- (should (null (marker-position used-marker)))
- ;; the media-state has been set to loaded and the image is being displayed
- (should (eq 'loaded (get-text-property saved-marker 'media-state source-buffer)))
- (should (eq ':fake-image (get-text-property saved-marker 'display source-buffer))))))))
-
-(ert-deftest mastodon-media:inline-images ()
+ used-marker
+ saved-marker)
+ (insert "start:")
+ (setq used-marker (copy-marker (point))
+ saved-marker (copy-marker (point)))
+ ;; Mock needed for the preliminary image created in
+ ;; mastodon-media--get-avatar-rendering
+ (stub create-image => :fake-image)
+ (insert (mastodon-media--get-avatar-rendering
+ "http://example.org/image.png.")
+ ":end")
+ (with-temp-buffer
+ (insert "some irrelevant\n"
+ "http headers\n"
+ "which will be ignored\n\n"
+ "fake\nimage\ndata")
+ (goto-char (point-min))
+
+ (mock (create-image
+ "fake\nimage\ndata"
+ (when (version< emacs-version "27.1") 'imagemagick)
+ t ':image :option) => :fake-image)
+
+ (mastodon-media--process-image-response
+ () used-marker '(:image :option) 1 "http://example.org/image.png")
+
+ ;; the used marker has been unset:
+ (should (null (marker-position used-marker)))
+ ;; the media-state has been set to loaded and the image is being displayed
+ (should (eq 'loaded (get-text-property saved-marker 'media-state source-buffer)))
+ (should (eq ':fake-image (get-text-property saved-marker 'display source-buffer))))))))
+
+(ert-deftest mastodon-media--inline-images ()
"Should process all media in buffer."
(with-mock
;; Stub needed for the test setup:
diff --git a/test/mastodon-notifications-test.el b/test/mastodon-notifications-test.el
index ba08bd4..4804e10 100644
--- a/test/mastodon-notifications-test.el
+++ b/test/mastodon-notifications-test.el
@@ -1,8 +1,10 @@
+;;; mastodon-notifications-test.el --- Tests for mastodon-notifications.el -*- lexical-binding: nil -*-
+
(require 'cl-lib)
(require 'cl-macs)
(require 'el-mock)
-(defconst mastodon-notifications-test-base-mentioned
+(defconst mastodon-notifications--test-base-mentioned
'((id . "1234")
(type . "mention")
(created_at . "2018-03-06T04:27:21.288Z" )
@@ -43,7 +45,7 @@
(favourites_count . 0)
(reblog))))
-(defconst mastodon-notifications-test-base-favourite
+(defconst mastodon-notifications--test-base-favourite
'((id . "1234")
(type . "favourite")
(created_at . "2018-03-06T04:27:21.288Z" )
@@ -84,7 +86,7 @@
(favourites_count . 0)
(reblog))))
-(defconst mastodon-notifications-test-base-boosted
+(defconst mastodon-notifications--test-base-boosted
'((id . "1234")
(type . "reblog")
(created_at . "2018-03-06T04:27:21.288Z" )
@@ -125,7 +127,7 @@
(favourites_count . 0)
(reblog))))
-(defconst mastodon-notifications-test-base-followed
+(defconst mastodon-notifications--test-base-followed
'((id . "1234")
(type . "follow")
(created_at . "2018-03-06T04:27:21.288Z" )
@@ -166,7 +168,7 @@
(favourites_count . 0)
(reblog))))
-(defconst mastodon-notifications-test-base-favourite
+(defconst mastodon-notifications--test-base-favourite
'((id . "1234")
(type . "mention")
(created_at . "2018-03-06T04:27:21.288Z" )
@@ -181,11 +183,11 @@
(statuses_count . 101)
(note . "E"))))
-(ert-deftest notification-get ()
+(ert-deftest mastodon-notifications--notification-get ()
"Ensure get request format for notifictions is accurate."
(let ((mastodon-instance-url "https://instance.url"))
(with-mock
- (mock (mastodon-http--get-json "https://instance.url/api/v1/notifications"))
+ (mock (mastodon-http--get-json "https://instance.url/api/v1/notifications" ))
(mastodon-notifications--get))))
(defun mastodon-notifications--test-type (fun sample)
@@ -205,9 +207,11 @@ notification to be tested."
(mastodon-notifications--byline-concat "Mentioned"))
(string= " Followed you"
(mastodon-notifications--byline-concat "Followed"))
- (string= " Favourited your status"
+ (string= " Favourited your status from"
(mastodon-notifications--byline-concat "Favourited"))
- (string= " Boosted your status"
- (mastodon-notifications--byline-concat "Boosted")))))
+ (string= " Boosted your status from"
+ (mastodon-notifications--byline-concat "Boosted"))
+ (string= " Posted a post"
+ (mastodon-notifications--byline-concat "Posted")))))
diff --git a/test/mastodon-search-tests.el b/test/mastodon-search-tests.el
new file mode 100644
index 0000000..996f786
--- /dev/null
+++ b/test/mastodon-search-tests.el
@@ -0,0 +1,147 @@
+;;; mastodon-search-test.el --- Tests for mastodon-search.el -*- lexical-binding: nil -*-
+
+(defconst mastodon-search--single-account-query
+ '((id . "242971")
+ (username . "mousebot")
+ (acct . "mousebot")
+ (display_name . ": ( ) { : | : & } ; :")
+ (locked . t)
+ (bot . :json-false)
+ (discoverable . t)
+ (group . :json-false)
+ (created_at . "2020-04-14T00:00:00.000Z")
+ (note . "<p>poetry, writing, dmt, desertion, trash, black metal, translation, hegel, language, autonomia....</p><p><a href=\"https://anarchive.mooo.com\" rel=\"nofollow noopener noreferrer\" target=\"_blank\"><span class=\"invisible\">https://</span><span class=\"\">anarchive.mooo.com</span><span class=\"invisible\"></span></a><br /><a href=\"https://pleasantlybabykid.tumblr.com/\" rel=\"nofollow noopener noreferrer\" target=\"_blank\"><span class=\"invisible\">https://</span><span class=\"\">pleasantlybabykid.tumblr.com/</span><span class=\"invisible\"></span></a><br />IG: <a href=\"https://bibliogram.snopyta.org/u/martianhiatus\" rel=\"nofollow noopener noreferrer\" target=\"_blank\"><span class=\"invisible\">https://</span><span class=\"ellipsis\">bibliogram.snopyta.org/u/marti</span><span class=\"invisible\">anhiatus</span></a><br />photos alt: <span class=\"h-card\"><a href=\"https://todon.eu/@goosebot\" class=\"u-url mention\">@<span>goosebot</span></a></span><br />git: <a href=\"https://git.blast.noho.st/mouse\" rel=\"nofollow noopener noreferrer\" target=\"_blank\"><span class=\"invisible\">https://</span><span class=\"\">git.blast.noho.st/mouse</span><span class=\"invisible\"></span></a></p><p>want to trade chapbooks or zines? hmu!</p><p>he/him or they/them</p>")
+ (url . "https://todon.nl/@mousebot")
+ (avatar . "https://todon.nl/system/accounts/avatars/000/242/971/original/0a5e801576af597b.jpg")
+ (avatar_static . "https://todon.nl/system/accounts/avatars/000/242/971/original/0a5e801576af597b.jpg")
+ (header . "https://todon.nl/system/accounts/headers/000/242/971/original/f85f7f1048237fd4.jpg")
+ (header_static . "https://todon.nl/system/accounts/headers/000/242/971/original/f85f7f1048237fd4.jpg")
+ (followers_count . 226)
+ (following_count . 634)
+ (statuses_count . 3807)
+ (last_status_at . "2021-11-05")
+ (emojis .
+ [])
+ (fields .
+ [((name . "dark to")
+ (value . "themselves")
+ (verified_at))
+ ((name . "its raining")
+ (value . "plastic")
+ (verified_at))
+ ((name . "dis")
+ (value . "integration")
+ (verified_at))
+ ((name . "ungleichzeitigkeit und")
+ (value . "gleichzeitigkeit, philosophisch")
+ (verified_at))]))
+ "A sample mastodon account search result (parsed json)")
+
+(defconst mastodon-search--test-single-tag
+ '((name . "TeamBringBackVisibleScrollbars")
+ (url . "https://todon.nl/tags/TeamBringBackVisibleScrollbars")
+ (history . [((day . "1636156800") (uses . "0") (accounts . "0"))
+ ((day . "1636070400") (uses . "0") (accounts . "0"))
+ ((day . "1635984000") (uses . "0") (accounts . "0"))
+ ((day . "1635897600") (uses . "0") (accounts . "0"))
+ ((day . "1635811200") (uses . "0") (accounts . "0"))
+ ((day . "1635724800") (uses . "0") (accounts . "0"))
+ ((day . "1635638400") (uses . "0") (accounts . "0"))])))
+
+(defconst mastodon-search--test-single-status
+ '((id . "107230316503209282")
+ (created_at . "2021-11-06T13:19:40.628Z")
+ (in_reply_to_id)
+ (in_reply_to_account_id)
+ (sensitive . :json-false)
+ (spoiler_text . "")
+ (visibility . "direct")
+ (language . "en")
+ (uri . "https://todon.nl/users/mousebot/statuses/107230316503209282")
+ (url . "https://todon.nl/@mousebot/107230316503209282")
+ (replies_count . 0)
+ (reblogs_count . 0)
+ (favourites_count . 0)
+ (favourited . :json-false)
+ (reblogged . :json-false)
+ (muted . :json-false)
+ (bookmarked . :json-false)
+ (content . "<p>This is a nice test toot, for testing purposes. Thank you.</p>")
+ (reblog)
+ (application
+ (name . "mastodon.el")
+ (website . "https://github.com/jdenen/mastodon.el"))
+ (account
+ (id . "242971")
+ (username . "mousebot")
+ (acct . "mousebot")
+ (display_name . ": ( ) { : | : & } ; :")
+ (locked . t)
+ (bot . :json-false)
+ (discoverable . t)
+ (group . :json-false)
+ (created_at . "2020-04-14T00:00:00.000Z")
+ (note . "<p>poetry, writing, dmt, desertion, trash, black metal, translation, hegel, language, autonomia....</p><p><a href=\"https://anarchive.mooo.com\" rel=\"nofollow noopener noreferrer\" target=\"_blank\"><span class=\"invisible\">https://</span><span class=\"\">anarchive.mooo.com</span><span class=\"invisible\"></span></a><br /><a href=\"https://pleasantlybabykid.tumblr.com/\" rel=\"nofollow noopener noreferrer\" target=\"_blank\"><span class=\"invisible\">https://</span><span class=\"\">pleasantlybabykid.tumblr.com/</span><span class=\"invisible\"></span></a><br />IG: <a href=\"https://bibliogram.snopyta.org/u/martianhiatus\" rel=\"nofollow noopener noreferrer\" target=\"_blank\"><span class=\"invisible\">https://</span><span class=\"ellipsis\">bibliogram.snopyta.org/u/marti</span><span class=\"invisible\">anhiatus</span></a><br />photos alt: <span class=\"h-card\"><a href=\"https://todon.eu/@goosebot\" class=\"u-url mention\">@<span>goosebot</span></a></span><br />git: <a href=\"https://git.blast.noho.st/mouse\" rel=\"nofollow noopener noreferrer\" target=\"_blank\"><span class=\"invisible\">https://</span><span class=\"\">git.blast.noho.st/mouse</span><span class=\"invisible\"></span></a></p><p>want to trade chapbooks or zines? hmu!</p><p>he/him or they/them</p>")
+ (url . "https://todon.nl/@mousebot")
+ (avatar . "https://todon.nl/system/accounts/avatars/000/242/971/original/0a5e801576af597b.jpg")
+ (avatar_static . "https://todon.nl/system/accounts/avatars/000/242/971/original/0a5e801576af597b.jpg")
+ (header . "https://todon.nl/system/accounts/headers/000/242/971/original/f85f7f1048237fd4.jpg")
+ (header_static . "https://todon.nl/system/accounts/headers/000/242/971/original/f85f7f1048237fd4.jpg")
+ (followers_count . 226)
+ (following_count . 634)
+ (statuses_count . 3807)
+ (last_status_at . "2021-11-05")
+ (emojis . [])
+ (fields . [((name . "dark to")
+ (value . "themselves")
+ (verified_at))
+ ((name . "its raining")
+ (value . "plastic")
+ (verified_at))
+ ((name . "dis")
+ (value . "integration")
+ (verified_at))
+ ((name . "ungleichzeitigkeit und")
+ (value . "gleichzeitigkeit, philosophisch")
+ (verified_at))]))
+ (media_attachments . [])
+ (mentions . [((id . "242971")
+ (username . "mousebot")
+ (url . "https://todon.nl/@mousebot")
+ (acct . "mousebot"))])
+ (tags . [])
+ (emojis . [])
+ (card)
+ (poll)))
+
+(ert-deftest mastodon-search--get-user-info-@ ()
+ "Should build a list from a single account for company completion."
+ (should
+ (equal
+ (mastodon-search--get-user-info-@ mastodon-search--single-account-query)
+ '(": ( ) { : | : & } ; :" "@mousebot" "https://todon.nl/@mousebot"))))
+
+(ert-deftest mastodon-search--get-user-info ()
+ "Should build a list from a single account for company completion."
+ (should
+ (equal
+ (mastodon-search--get-user-info mastodon-search--single-account-query)
+ '(": ( ) { : | : & } ; :" "mousebot" "https://todon.nl/@mousebot"))))
+
+(ert-deftest mastodon-search--get-hashtag-info ()
+ "Should build a list of hashtag name and URL."
+ (should
+ (equal
+ (mastodon-search--get-hashtag-info mastodon-search--test-single-tag)
+ '("TeamBringBackVisibleScrollbars"
+ "https://todon.nl/tags/TeamBringBackVisibleScrollbars"))))
+
+(ert-deftest mastodon-search--get-status-info ()
+ "Should return a list of ID, timestamp, content, and spoiler."
+ (should
+ (equal
+ (mastodon-search--get-status-info mastodon-search--test-single-status)
+ '("107230316503209282"
+ "2021-11-06T13:19:40.628Z"
+ ""
+ "<p>This is a nice test toot, for testing purposes. Thank you.</p>"))))
diff --git a/test/mastodon-tl-tests.el b/test/mastodon-tl-tests.el
index 851dc39..dd07416 100644
--- a/test/mastodon-tl-tests.el
+++ b/test/mastodon-tl-tests.el
@@ -1,3 +1,5 @@
+;;; mastodon-tl-test.el --- Tests for mastodon-tl.el -*- lexical-binding: nil -*-
+
(require 'cl-lib)
(require 'cl-macs)
(require 'el-mock)
@@ -81,7 +83,7 @@
(username . "acct42"))])
(tags . [])
(uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status")
- (content . "<p><span class=\"h-card\"><a href=\"https://example.spacs/@acct42\">@<span>acct42</span></a></span> boost</p>")
+ (content . "<p><span class=\"h-card\"><a href=\"https://example.space/@acct42\">@<span>acct42</span></a></span> boost</p>")
(url . "https://example.space/users/acct42/updates/123456789")
(reblogs_count . 1)
(favourites_count . 1)
@@ -89,46 +91,94 @@
(reblogged)))
"A sample reblogged/boosted toot (parsed json)")
-(ert-deftest remove-html-1 ()
+(defconst mastodon-tl--follow-notify-true-response
+ "HTTP/1.1 200 OK
+Date: Mon, 20 Dec 2021 13:42:29 GMT
+Content-Type: application/json; charset=utf-8
+Transfer-Encoding: chunked
+Connection: keep-alive
+Server: Mastodon
+X-Frame-Options: DENY
+X-Content-Type-Options: nosniff
+X-XSS-Protection: 1; mode=block
+Permissions-Policy: interest-cohort=()
+X-RateLimit-Limit: 300
+X-RateLimit-Remaining: 298
+X-RateLimit-Reset: 2021-12-20T13:45:00.630990Z
+Cache-Control: no-store
+Vary: Accept, Accept-Encoding, Origin
+ETag: W/\"bee52f489c87e9a305e5d0b7bdca7ac1\"
+X-Request-Id: 5be9a64e-7d97-41b4-97f3-17b5e972a675
+X-Runtime: 0.371914
+Strict-Transport-Security: max-age=63072000; includeSubDomains
+Strict-Transport-Security: max-age=31536000
+
+{\"id\":\"123456789\",\"following\":true,\"showing_reblogs\":true,\"notifying\":true,\"followed_by\":true,\"blocking\":false,\"blocked_by\":false,\"muting\":false,\"muting_notifications\":false,\"requested\":false,\"domain_blocking\":false,\"endorsed\":false,\"note\":\"\"}")
+
+(defconst mastodon-tl--follow-notify-false-response
+ "HTTP/1.1 200 OK
+Date: Mon, 20 Dec 2021 13:42:29 GMT
+Content-Type: application/json; charset=utf-8
+Transfer-Encoding: chunked
+Connection: keep-alive
+Server: Mastodon
+X-Frame-Options: DENY
+X-Content-Type-Options: nosniff
+X-XSS-Protection: 1; mode=block
+Permissions-Policy: interest-cohort=()
+X-RateLimit-Limit: 300
+X-RateLimit-Remaining: 298
+X-RateLimit-Reset: 2021-12-20T13:45:00.630990Z
+Cache-Control: no-store
+Vary: Accept, Accept-Encoding, Origin
+ETag: W/\"bee52f489c87e9a305e5d0b7bdca7ac1\"
+X-Request-Id: 5be9a64e-7d97-41b4-97f3-17b5e972a675
+X-Runtime: 0.371914
+Strict-Transport-Security: max-age=63072000; includeSubDomains
+Strict-Transport-Security: max-age=31536000
+
+{\"id\":\"123456789\",\"following\":true,\"showing_reblogs\":true,\"notifying\":false,\"followed_by\":true,\"blocking\":false,\"blocked_by\":false,\"muting\":false,\"muting_notifications\":false,\"requested\":false,\"domain_blocking\":false,\"endorsed\":false,\"note\":\"\"}")
+
+(ert-deftest mastodon-tl--remove-html-1 ()
"Should remove all <span> tags."
(let ((input "<span class=\"h-card\">foobar</span> <span>foobaz</span>"))
(should (string= (mastodon-tl--remove-html input) "foobar foobaz"))))
-(ert-deftest remove-html-2 ()
+(ert-deftest mastodon-tl--remove-html-2 ()
"Should replace <\p> tags with two new lines."
(let ((input "foobar</p>"))
(should (string= (mastodon-tl--remove-html input) "foobar\n\n"))))
-(ert-deftest toot-id-boosted ()
+(ert-deftest mastodon-tl--toot-id-boosted ()
"If a toot is boostedm, return the reblog id."
(should (string= (mastodon-tl--as-string
(mastodon-tl--toot-id mastodon-tl-test-base-boosted-toot))
"4543919")))
-(ert-deftest toot-id ()
+(ert-deftest mastodon-tl--toot-id ()
"If a toot is boostedm, return the reblog id."
(should (string= (mastodon-tl--as-string
(mastodon-tl--toot-id mastodon-tl-test-base-toot))
"61208")))
-(ert-deftest as-string-1 ()
+(ert-deftest mastodon-tl--as-string-1 ()
"Should accept a string or number and return a string."
(let ((id "1000"))
- (should (string= (mastodon-tl--as-string id) id))))
+ (should (string= (mastodon-tl--as-string id) id))))
-(ert-deftest as-string-2 ()
+(ert-deftest mastodon-tl--as-string-2 ()
"Should accept a string or number and return a string."
(let ((id 1000))
- (should (string= (mastodon-tl--as-string id) (number-to-string id)))))
+ (should (string= (mastodon-tl--as-string id) (number-to-string id)))))
-(ert-deftest more-json ()
+(ert-deftest mastodon-tl--more-json ()
"Should request toots older than max_id."
(let ((mastodon-instance-url "https://instance.url"))
(with-mock
(mock (mastodon-http--get-json "https://instance.url/api/v1/timelines/foo?max_id=12345"))
(mastodon-tl--more-json "timelines/foo" 12345))))
-(ert-deftest more-json-id-string ()
+(ert-deftest mastodon-tl--more-json-id-string ()
"Should request toots older than max_id.
`mastodon-tl--more-json' should accept and id that is either
@@ -138,7 +188,7 @@ a string or a numeric."
(mock (mastodon-http--get-json "https://instance.url/api/v1/timelines/foo?max_id=12345"))
(mastodon-tl--more-json "timelines/foo" "12345"))))
-(ert-deftest update-json-id-string ()
+(ert-deftest mastodon-tl--update-json-id-string ()
"Should request toots more recent than since_id.
`mastodon-tl--updated-json' should accept and id that is either
@@ -156,10 +206,10 @@ a string or a numeric."
(weeks (n) (* n (days 7)))
(years (n) (* n (days 365)))
(format-seconds-since (seconds)
- (let ((timestamp (time-subtract (current-time) (seconds-to-time seconds))))
- (mastodon-tl--relative-time-description timestamp)))
+ (let ((timestamp (time-subtract (current-time) (seconds-to-time seconds))))
+ (mastodon-tl--relative-time-description timestamp)))
(check (seconds expected)
- (should (string= (format-seconds-since seconds) expected))))
+ (should (string= (format-seconds-since seconds) expected))))
(check 1 "less than a minute ago")
(check 59 "less than a minute ago")
(check 60 "one minute ago")
@@ -195,33 +245,33 @@ a string or a numeric."
(weeks (n) (* n (days 7)))
(years (n) (* n (days 365.25)))
(next-update (seconds-ago)
- (let* ((timestamp (time-subtract current-time
- (seconds-to-time seconds-ago))))
- (cdr (mastodon-tl--relative-time-details timestamp current-time))))
+ (let* ((timestamp (time-subtract current-time
+ (seconds-to-time seconds-ago))))
+ (cdr (mastodon-tl--relative-time-details timestamp current-time))))
(check (seconds-ago)
- (let* ((timestamp (time-subtract current-time (seconds-to-time seconds-ago)))
- (at-now (mastodon-tl--relative-time-description timestamp current-time))
- (at-one-second-before (mastodon-tl--relative-time-description
- timestamp
- (time-subtract (next-update seconds-ago)
- (seconds-to-time 1))))
- (at-result (mastodon-tl--relative-time-description
- timestamp
- (next-update seconds-ago))))
- (when nil ;; change to t to debug test failures
- (prin1 (format "\nFor %s: %s / %s"
- seconds-ago
- (time-to-seconds
- (time-subtract (next-update seconds-ago)
- timestamp))
- (round
- (time-to-seconds
- (time-subtract (next-update seconds-ago)
- current-time))))))
- ;; a second earlier the description is the same as at current time
- (should (string= at-now at-one-second-before))
- ;; but at the result time it is different
- (should-not (string= at-one-second-before at-result)))))
+ (let* ((timestamp (time-subtract current-time (seconds-to-time seconds-ago)))
+ (at-now (mastodon-tl--relative-time-description timestamp current-time))
+ (at-one-second-before (mastodon-tl--relative-time-description
+ timestamp
+ (time-subtract (next-update seconds-ago)
+ (seconds-to-time 1))))
+ (at-result (mastodon-tl--relative-time-description
+ timestamp
+ (next-update seconds-ago))))
+ (when nil ;; change to t to debug test failures
+ (prin1 (format "\nFor %s: %s / %s"
+ seconds-ago
+ (time-to-seconds
+ (time-subtract (next-update seconds-ago)
+ timestamp))
+ (round
+ (time-to-seconds
+ (time-subtract (next-update seconds-ago)
+ current-time))))))
+ ;; a second earlier the description is the same as at current time
+ (should (string= at-now at-one-second-before))
+ ;; but at the result time it is different
+ (should-not (string= at-one-second-before at-result)))))
(check 0)
(check 1)
(check 59)
@@ -257,20 +307,20 @@ a string or a numeric."
(mock (format-time-string mastodon-toot-timestamp-format '(22782 21551)) => "2999-99-99 00:11:22")
(let ((byline (mastodon-tl--byline mastodon-tl-test-base-toot
- 'mastodon-tl--byline-author
- 'mastodon-tl--byline-boosted))
+ 'mastodon-tl--byline-author
+ 'mastodon-tl--byline-boosted))
(handle-location 20))
- (should (string= (substring-no-properties
+ (should (string= (substring-no-properties
byline)
- "
- | Account 42 (@acct42@example.space) 2999-99-99 00:11:22
- ------------"))
- (should (eq (get-text-property handle-location 'mastodon-tab-stop byline)
+ "Account 42 (@acct42@example.space) 2999-99-99 00:11:22
+ ------------
+"))
+ (should (eq (get-text-property handle-location 'mastodon-tab-stop byline)
'user-handle))
(should (string= (get-text-property handle-location 'mastodon-handle byline)
"@acct42@example.space"))
- (should (equal (get-text-property handle-location 'help-echo byline)
- "Browse user profile of @acct42@example.space"))))))
+ (should (equal (get-text-property handle-location 'help-echo byline)
+ "Browse user profile of @acct42@example.space"))))))
(ert-deftest mastodon-tl--byline-regular-with-avatar ()
"Should format the regular toot correctly."
@@ -285,9 +335,9 @@ a string or a numeric."
(mastodon-tl--byline mastodon-tl-test-base-toot
'mastodon-tl--byline-author
'mastodon-tl--byline-boosted))
- "
- | Account 42 (@acct42@example.space) 2999-99-99 00:11:22
- ------------")))))
+ "Account 42 (@acct42@example.space) 2999-99-99 00:11:22
+ ------------
+")))))
(ert-deftest mastodon-tl--byline-boosted ()
"Should format the boosted toot correctly."
@@ -302,9 +352,9 @@ a string or a numeric."
(mastodon-tl--byline toot
'mastodon-tl--byline-author
'mastodon-tl--byline-boosted))
- "
- | (B) Account 42 (@acct42@example.space) 2999-99-99 00:11:22
- ------------")))))
+ "(B) Account 42 (@acct42@example.space) 2999-99-99 00:11:22
+ ------------
+")))))
(ert-deftest mastodon-tl--byline-favorited ()
"Should format the favourited toot correctly."
@@ -319,9 +369,9 @@ a string or a numeric."
(mastodon-tl--byline toot
'mastodon-tl--byline-author
'mastodon-tl--byline-boosted))
- "
- | (F) Account 42 (@acct42@example.space) 2999-99-99 00:11:22
- ------------")))))
+ "(F) Account 42 (@acct42@example.space) 2999-99-99 00:11:22
+ ------------
+")))))
(ert-deftest mastodon-tl--byline-boosted/favorited ()
@@ -337,9 +387,9 @@ a string or a numeric."
(mastodon-tl--byline toot
'mastodon-tl--byline-author
'mastodon-tl--byline-boosted))
- "
- | (B) (F) Account 42 (@acct42@example.space) 2999-99-99 00:11:22
- ------------")))))
+ "(B) (F) Account 42 (@acct42@example.space) 2999-99-99 00:11:22
+ ------------
+")))))
(ert-deftest mastodon-tl--byline-reblogged ()
"Should format the reblogged toot correctly."
@@ -361,18 +411,19 @@ a string or a numeric."
'mastodon-tl--byline-boosted))
(handle1-location 20)
(handle2-location 65))
- (should (string= (substring-no-properties byline)
- "
- | Account 42 (@acct42@example.space) Boosted Account 43 (@acct43@example.space) original time
- ------------"))
- (should (eq (get-text-property handle1-location 'mastodon-tab-stop byline)
- 'user-handle))
- (should (equal (get-text-property handle1-location 'help-echo byline)
+ (should (string= (substring-no-properties byline)
+ "Account 42 (@acct42@example.space)
+ Boosted Account 43 (@acct43@example.space) original time
+ ------------
+"))
+ (should (eq (get-text-property handle1-location 'mastodon-tab-stop byline)
+ 'user-handle))
+ (should (equal (get-text-property handle1-location 'help-echo byline)
"Browse user profile of @acct42@example.space"))
- (should (eq (get-text-property handle2-location 'mastodon-tab-stop byline)
- 'user-handle))
- (should (equal (get-text-property handle2-location 'help-echo byline)
- "Browse user profile of @acct43@example.space"))))))
+ (should (eq (get-text-property handle2-location 'mastodon-tab-stop byline)
+ 'user-handle))
+ (should (equal (get-text-property handle2-location 'help-echo byline)
+ "Browse user profile of @acct43@example.space"))))))
(ert-deftest mastodon-tl--byline-reblogged-with-avatars ()
"Should format the reblogged toot correctly."
@@ -393,9 +444,11 @@ a string or a numeric."
(should (string= (substring-no-properties
(mastodon-tl--byline toot
'mastodon-tl--byline-author
- 'mastodon-tl--byline-boosted))"
- | Account 42 (@acct42@example.space) Boosted Account 43 (@acct43@example.space) original time
- ------------")))))
+ 'mastodon-tl--byline-boosted))
+ "Account 42 (@acct42@example.space)
+ Boosted Account 43 (@acct43@example.space) original time
+ ------------
+")))))
(ert-deftest mastodon-tl--byline-reblogged-boosted/favorited ()
"Should format the reblogged toot that was also boosted & favoritedcorrectly."
@@ -416,9 +469,10 @@ a string or a numeric."
(mastodon-tl--byline toot
'mastodon-tl--byline-author
'mastodon-tl--byline-boosted))
- "
- | (B) (F) Account 42 (@acct42@example.space) Boosted Account 43 (@acct43@example.space) original time
- ------------")))))
+ "(B) (F) Account 42 (@acct42@example.space)
+ Boosted Account 43 (@acct43@example.space) original time
+ ------------
+")))))
(ert-deftest mastodon-tl--byline-timestamp-has-relative-display ()
"Should display the timestamp with a relative time."
@@ -687,20 +741,20 @@ a string or a numeric."
(list 'r3 r3 r2 r3)
(list 'end end r3 end))))
(with-mock
- (stub message => nil) ;; don't mess up our test output with the function's messages
- (cl-dolist (test test-cases)
- (let ((test-name (cl-first test))
- (test-start (cl-second test))
- (expected-prev (cl-third test))
- (expected-next (cl-fourth test)))
- (goto-char test-start)
- (mastodon-tl--previous-tab-item)
- (should (equal (list 'prev test-name expected-prev)
- (list 'prev test-name (point))))
- (goto-char test-start)
- (mastodon-tl--next-tab-item)
- (should (equal (list 'next test-name expected-next)
- (list 'next test-name (point)))))))))))
+ (stub message => nil) ;; don't mess up our test output with the function's messages
+ (cl-dolist (test test-cases)
+ (let ((test-name (cl-first test))
+ (test-start (cl-second test))
+ (expected-prev (cl-third test))
+ (expected-next (cl-fourth test)))
+ (goto-char test-start)
+ (mastodon-tl--previous-tab-item)
+ (should (equal (list 'prev test-name expected-prev)
+ (list 'prev test-name (point))))
+ (goto-char test-start)
+ (mastodon-tl--next-tab-item)
+ (should (equal (list 'next test-name expected-next)
+ (list 'next test-name (point)))))))))))
(ert-deftest mastodon-tl--next-tab-item--no-spaces-at-ends ()
"Should do the correct tab actions even with regions right at buffer ends."
@@ -735,20 +789,20 @@ a string or a numeric."
(list 'gap2 gap2 r3 r4)
(list 'r4 r4 r3 r4))))
(with-mock
- (stub message => nil) ;; don't mess up our test output with the function's messages
- (cl-dolist (test test-cases)
- (let ((test-name (cl-first test))
- (test-start (cl-second test))
- (expected-prev (cl-third test))
- (expected-next (cl-fourth test)))
- (goto-char test-start)
- (mastodon-tl--previous-tab-item)
- (should (equal (list 'prev test-name expected-prev)
- (list 'prev test-name (point))))
- (goto-char test-start)
- (mastodon-tl--next-tab-item)
- (should (equal (list 'next test-name expected-next)
- (list 'next test-name (point)))))))))))
+ (stub message => nil) ;; don't mess up our test output with the function's messages
+ (cl-dolist (test test-cases)
+ (let ((test-name (cl-first test))
+ (test-start (cl-second test))
+ (expected-prev (cl-third test))
+ (expected-next (cl-fourth test)))
+ (goto-char test-start)
+ (mastodon-tl--previous-tab-item)
+ (should (equal (list 'prev test-name expected-prev)
+ (list 'prev test-name (point))))
+ (goto-char test-start)
+ (mastodon-tl--next-tab-item)
+ (should (equal (list 'next test-name expected-next)
+ (list 'next test-name (point)))))))))))
(defun tl-tests--property-values-at (property ranges)
@@ -765,13 +819,13 @@ constant."
(let ((now (current-time))
markers)
(cl-labels ((insert-timestamp (n)
- (insert (format "\nSome text before timestamp %s:" n))
- (insert (propertize
- (format "timestamp #%s" n)
- 'timestamp (time-subtract now (seconds-to-time (* 60 n)))
- 'display (format "unset %s" n)))
- (push (copy-marker (point)) markers)
- (insert " some more text.")))
+ (insert (format "\nSome text before timestamp %s:" n))
+ (insert (propertize
+ (format "timestamp #%s" n)
+ 'timestamp (time-subtract now (seconds-to-time (* 60 n)))
+ 'display (format "unset %s" n)))
+ (push (copy-marker (point)) markers)
+ (insert " some more text.")))
(with-temp-buffer
(cl-dotimes (n 12) (insert-timestamp (+ n 2)))
(setq markers (nreverse markers))
@@ -829,10 +883,10 @@ constant."
(insert "some text before\n")
(setq toot-start (point))
(with-mock
- (stub create-image => '(image "fake data"))
- (stub shr-render-region => nil) ;; Travis's Emacs doesn't have libxml
- (insert
- (mastodon-tl--spoiler normal-toot-with-spoiler)))
+ (stub create-image => '(image "fake data"))
+ (stub shr-render-region => nil) ;; Travis's Emacs doesn't have libxml
+ (insert
+ (mastodon-tl--spoiler normal-toot-with-spoiler)))
(setq toot-end (point))
(insert "\nsome more text.")
(add-text-properties
@@ -841,14 +895,14 @@ constant."
'toot-id (cdr (assoc 'id normal-toot-with-spoiler))))
(goto-char toot-start)
- (should (eq t (looking-at "This is the spoiler warning text")))
+ ;; (should (eq t (looking-at "This is the spoiler warning text")))
(setq link-region (mastodon-tl--find-next-or-previous-property-range
'mastodon-tab-stop toot-start nil))
;; There should be a link following the text:
(should-not (null link-region))
(goto-char (car link-region))
- (should (eq t (looking-at "Content Warning")))
+ (should (eq t (looking-at "CW: This is the spoiler warning text"))) ;Content Warning")))
(setq body-position (+ 25 (cdr link-region))) ;; 25 is enough to skip the "\n--------------...."
@@ -895,10 +949,10 @@ constant."
'help-echo "https://example.space/tags/sampletag")
" some text after"))
(rendered (with-mock
- (stub shr-render-region => nil)
- (mastodon-tl--render-text
- fake-input-text
- mastodon-tl-test-base-toot)))
+ (stub shr-render-region => nil)
+ (mastodon-tl--render-text
+ fake-input-text
+ mastodon-tl-test-base-toot)))
(tag-location 7))
(should (eq (get-text-property tag-location 'mastodon-tab-stop rendered)
'hashtag))
@@ -908,29 +962,33 @@ constant."
"Browse tag #sampletag"))))
(ert-deftest mastodon-tl--extract-hashtag-from-url-mastodon-link ()
+ "Should extract the hashtag from a tags url."
(should (equal (mastodon-tl--extract-hashtag-from-url
"https://example.org/tags/foo"
"https://example.org")
"foo")))
(ert-deftest mastodon-tl--extract-hashtag-from-url-other-link ()
+ "Should extract the hashtag from a tag url."
(should (equal (mastodon-tl--extract-hashtag-from-url
"https://example.org/tag/foo"
"https://example.org")
"foo")))
(ert-deftest mastodon-tl--extract-hashtag-from-url-wrong-instance ()
+ "Should not find a tag when the instance doesn't match."
(should (null (mastodon-tl--extract-hashtag-from-url
- "https://example.org/tags/foo"
- "https://other.example.org"))))
+ "https://example.org/tags/foo"
+ "https://other.example.org"))))
(ert-deftest mastodon-tl--extract-hashtag-from-url-not-tag ()
+ "Should not find a hashtag when not a tag url"
(should (null (mastodon-tl--extract-hashtag-from-url
- "https://example.org/@userid"
- "https://example.org"))))
+ "https://example.org/@userid"
+ "https://example.org"))))
(ert-deftest mastodon-tl--userhandles ()
- "Should recognise iserhandles in a toot and add the required properties to it."
+ "Should recognise userhandles in a toot and add the required properties to it."
;; Travis's Emacs doesn't have libxml so we fake things by inputting
;; propertized text and stubbing shr-render-region
(let* ((fake-input-text
@@ -942,10 +1000,10 @@ constant."
'help-echo "https://bar.example/@foo")
" some text after"))
(rendered (with-mock
- (stub shr-render-region => nil)
- (mastodon-tl--render-text
- fake-input-text
- mastodon-tl-test-base-toot)))
+ (stub shr-render-region => nil)
+ (mastodon-tl--render-text
+ fake-input-text
+ mastodon-tl-test-base-toot)))
(mention-location 11))
(should (eq (get-text-property mention-location 'mastodon-tab-stop rendered)
'user-handle))
@@ -953,17 +1011,86 @@ constant."
"Browse user profile of @foo@bar.example"))))
(ert-deftest mastodon-tl--extract-userhandle-from-url-correct-case ()
+ "Should extract the user handle from url."
(should (equal (mastodon-tl--extract-userhandle-from-url
"https://example.org/@someuser"
"@SomeUser")
"@SomeUser@example.org")))
(ert-deftest mastodon-tl--extract-userhandle-from-url-missing-at-in-text ()
+ "Should not extract a user handle from url if the text is wrong."
(should (null (mastodon-tl--extract-userhandle-from-url
"https://example.org/@someuser"
"SomeUser"))))
(ert-deftest mastodon-tl--extract-userhandle-from-url-query-in-url ()
+ "Should not extract a user handle from url if there is a query param."
(should (null (mastodon-tl--extract-userhandle-from-url
"https://example.org/@someuser?shouldnot=behere"
"SomeUser"))))
+
+(ert-deftest mastodon-tl--do-user-action-function-follow-notify-block-mute ()
+ "Should triage a follow request response buffer and return
+correct value for following, as well as notifications enabled or disabled."
+ (let* ((user-handle "some-user@instance.url")
+ (user-name "some-user")
+ (user-id "123456789")
+ (url-follow-only "https://instance.url/accounts/123456789/follow")
+ (url-mute "https://instance.url/accounts/123456789/mute")
+ (url-block "https://instance.url/accounts/123456789/block")
+ (url-true "https://instance.url/accounts/123456789/follow?notify=true")
+ (url-false "https://instance.url/accounts/123456789/follow?notify=false"))
+ (with-temp-buffer
+ (let ((response-buffer-true (current-buffer)))
+ (insert mastodon-tl--follow-notify-true-response)
+ (with-mock
+ (mock (mastodon-http--post url-follow-only nil nil)
+ => response-buffer-true)
+ (should
+ (equal
+ (mastodon-tl--do-user-action-function url-follow-only
+ user-name
+ user-handle
+ "follow")
+ "User some-user (@some-user@instance.url) followed!"))
+ (mock (mastodon-http--post url-mute nil nil)
+ => response-buffer-true)
+ (should
+ (equal
+ (mastodon-tl--do-user-action-function url-mute
+ user-name
+ user-handle
+ "mute")
+ "User some-user (@some-user@instance.url) muted!"))
+ (mock (mastodon-http--post url-block nil nil)
+ => response-buffer-true)
+ (should
+ (equal
+ (mastodon-tl--do-user-action-function url-block
+ user-name
+ user-handle
+ "block")
+ "User some-user (@some-user@instance.url) blocked!")))
+ (with-mock
+ (mock (mastodon-http--post url-true nil nil) => response-buffer-true)
+ (should
+ (equal
+ (mastodon-tl--do-user-action-function url-true
+ user-name
+ user-handle
+ "follow"
+ "true")
+ "Receiving notifications for user some-user (@some-user@instance.url)!")))))
+ (with-temp-buffer
+ (let ((response-buffer-false (current-buffer)))
+ (insert mastodon-tl--follow-notify-false-response)
+ (with-mock
+ (mock (mastodon-http--post url-false nil nil) => response-buffer-false)
+ (should
+ (equal
+ (mastodon-tl--do-user-action-function url-false
+ user-name
+ user-handle
+ "follow"
+ "false")
+ "Not receiving notifications for user some-user (@some-user@instance.url)!")))))))
diff --git a/test/mastodon-toot-tests.el b/test/mastodon-toot-tests.el
index 06da870..0c31029 100644
--- a/test/mastodon-toot-tests.el
+++ b/test/mastodon-toot-tests.el
@@ -1,6 +1,48 @@
+;;; mastodon-toot-test.el --- Tests for mastodon-toot.el -*- lexical-binding: nil -*-
+
(require 'el-mock)
+(require 'mastodon-http)
+
+(defconst mastodon-toot--200-html
+ "HTTP/1.1 200 OK
+Date: Mon, 20 Dec 2021 13:42:29 GMT
+Content-Type: application/json; charset=utf-8
+Transfer-Encoding: chunked")
+
+(defconst mastodon-toot-test-base-toot
+ '((id . 61208)
+ (created_at . "2017-04-24T19:01:02.000Z")
+ (in_reply_to_id)
+ (in_reply_to_account_id)
+ (sensitive . :json-false)
+ (spoiler_text . "")
+ (visibility . "public")
+ (account (id . 42)
+ (username . "acct42")
+ (acct . "acct42@example.space")
+ (display_name . "Account 42")
+ (locked . :json-false)
+ (created_at . "2017-04-01T00:00:00.000Z")
+ (followers_count . 99)
+ (following_count . 13)
+ (statuses_count . 101)
+ (note . "E"))
+ (media_attachments . [])
+ (mentions . [])
+ (tags . [])
+ (uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status")
+ (url . "https://example.space/users/acct42/updates/123456789")
+ (content . "<p>Just some text</p>")
+ (reblogs_count . 0)
+ (favourites_count . 0)
+ (reblog))
+ "A sample toot (parsed json)")
-(defconst mastodon-toot-multi-mention
+(defconst mastodon-toot--mock-toot
+ (propertize "here is a mock toot text."
+ 'toot-json mastodon-toot-test-base-toot))
+
+(defconst mastodon-toot--multi-mention
'((mentions .
[((id . "1")
(username . "federated")
@@ -18,29 +60,111 @@
(defconst mastodon-toot-no-mention
'((mentions . [])))
-(ert-deftest toot-multi-mentions ()
+(ert-deftest mastodon-toot--multi-mentions ()
+ "Should build a correct mention string from the test toot data.
+
+Even the local name \"local\" gets a domain name added."
(let ((mastodon-auth--acct-alist '(("https://local.social". "null")))
(mastodon-instance-url "https://local.social"))
(should (string=
- (mastodon-toot--mentions mastodon-toot-multi-mention)
+ (mastodon-toot--mentions mastodon-toot--multi-mention)
"@local@local.social @federated@federated.social @federated@federated.cafe "))))
-(ert-deftest toot-multi-mentions-with-name ()
+(ert-deftest mastodon-toot--multi-mentions-with-name ()
+ "Should build a correct mention string omitting self.
+
+Here \"local\" is the user themselves and gets omitted from the
+mention string."
(let ((mastodon-auth--acct-alist
'(("https://local.social". "local")))
(mastodon-instance-url "https://local.social"))
(should (string=
- (mastodon-toot--mentions mastodon-toot-multi-mention)
+ (mastodon-toot--mentions mastodon-toot--multi-mention)
"@federated@federated.social @federated@federated.cafe "))))
-(ert-deftest toot-no-mention ()
+(ert-deftest mastodon-toot--no-mention ()
+ "Should construct an empty mention string without mentions."
(let ((mastodon-auth--acct-alist
'(("https://local.social". "null")))
(mastodon-instance-url "https://local.social"))
(should (string= (mastodon-toot--mentions mastodon-toot-no-mention) ""))))
-(ert-deftest cancel ()
+;; TODO: test y-or-no-p with matodon-toot--cancel
+(ert-deftest mastodon-toot--kill ()
+ "Should kill the buffer when cancelling the toot."
(with-mock
(mock (kill-buffer-and-window))
- (mastodon-toot--cancel)
+ (mastodon-toot--kill)
(mock-verify)))
+
+(ert-deftest mastodon-toot--own-toot-p-fail ()
+ "Should not return t if not own toot."
+ (let ((toot mastodon-toot-test-base-toot))
+ (with-mock
+ (mock (mastodon-auth--user-acct) => "joebogus@bogus.space")
+ (should (not (equal (mastodon-toot--own-toot-p toot)
+ t))))))
+
+(ert-deftest mastodon-toot--own-toot-p ()
+ "Should return 't' if own toot."
+ (let ((toot mastodon-toot-test-base-toot))
+ (with-mock
+ (mock (mastodon-auth--user-acct) => "acct42@example.space")
+ (should (equal (mastodon-toot--own-toot-p toot)
+ t)))))
+
+(ert-deftest mastodon-toot--delete-toot-fail ()
+ "Should refuse to delete toot."
+ (let ((toot mastodon-toot-test-base-toot))
+ (with-mock
+ (mock (mastodon-auth--user-acct) => "joebogus")
+ ;; (mock (mastodon-toot--own-toot-p toot) => nil)
+ (mock (mastodon-tl--property 'toot-json) => mastodon-toot-test-base-toot)
+ (should (equal (mastodon-toot--delete-toot)
+ "You can only delete (and redraft) your own toots.")))))
+
+(ert-deftest mastodon-toot--delete-toot ()
+ "Should return correct triaged response to a legitimate DELETE request."
+ (with-temp-buffer
+ (insert mastodon-toot--200-html)
+ (let ((delete-response (current-buffer))
+ (toot mastodon-toot-test-base-toot))
+ (with-mock
+ (mock (mastodon-tl--property 'toot-json) => toot)
+ ;; (mock (mastodon-toot--own-toot-p toot) => t)
+ (mock (mastodon-auth--user-acct) => "acct42@example.space")
+ (mock (mastodon-http--api (format "statuses/61208"))
+ => "https://example.space/statuses/61208")
+ (mock (y-or-n-p "Delete this toot? ") => t)
+ (mock (mastodon-http--delete "https://example.space/statuses/61208")
+ => delete-response)
+ (should (equal (mastodon-toot--delete-toot)
+ "Toot deleted!"))))))
+
+(ert-deftest mastodon-toot-action-pin ()
+ "Should return callback provided by `mastodon-toot--pin-toot-toggle'."
+ (with-temp-buffer
+ (insert mastodon-toot--200-html)
+ (let ((pin-response (current-buffer))
+ (toot mastodon-toot-test-base-toot)
+ (id 61208))
+ (with-mock
+ (mock (mastodon-tl--property 'base-toot-id) => id)
+ (mock (mastodon-http--api "statuses/61208/pin")
+ => "https://example.space/statuses/61208/pin")
+ (mock (mastodon-http--post "https://example.space/statuses/61208/pin" nil nil)
+ => pin-response)
+ (should (equal (mastodon-toot--action "pin" (lambda ()
+ (message "Toot pinned!")))
+ "Toot pinned!"))))))
+
+(ert-deftest mastodon-toot--pin-toot-fail ()
+ (with-temp-buffer
+ (insert mastodon-toot--200-html)
+ (let ((pin-response (current-buffer))
+ (toot mastodon-toot-test-base-toot))
+ (with-mock
+ (mock (mastodon-tl--property 'toot-json) => toot)
+ (mock (mastodon-auth--user-acct) => "joebogus@example.space")
+ (should (equal (mastodon-toot--pin-toot-toggle)
+ "You can only pin your own toots."))))))