diff options
| -rw-r--r-- | README.org | 6 | ||||
| -rw-r--r-- | dir | 3 | ||||
| -rw-r--r-- | lisp/mastodon-async.el | 16 | ||||
| -rw-r--r-- | lisp/mastodon-auth.el | 4 | ||||
| -rw-r--r-- | lisp/mastodon-client.el | 2 | ||||
| -rw-r--r-- | lisp/mastodon-http.el | 26 | ||||
| -rw-r--r-- | lisp/mastodon-media.el | 97 | ||||
| -rw-r--r-- | lisp/mastodon-notifications.el | 101 | ||||
| -rw-r--r-- | lisp/mastodon-profile.el | 256 | ||||
| -rw-r--r-- | lisp/mastodon-search.el | 129 | ||||
| -rw-r--r-- | lisp/mastodon-tl.el | 1150 | ||||
| -rw-r--r-- | lisp/mastodon-toot.el | 525 | ||||
| -rw-r--r-- | lisp/mastodon-views.el | 377 | ||||
| -rw-r--r-- | lisp/mastodon.el | 97 | ||||
| -rw-r--r-- | mastodon-index.org | 15 | ||||
| -rw-r--r-- | mastodon.info | 73 | ||||
| -rw-r--r-- | mastodon.texi | 10 | ||||
| -rw-r--r-- | test/ert-helper.el | 10 | ||||
| -rw-r--r-- | test/mastodon-http-tests.el | 7 | ||||
| -rw-r--r-- | test/mastodon-media-tests.el | 20 | ||||
| -rw-r--r-- | test/mastodon-profile-tests.el | 83 | ||||
| -rw-r--r-- | test/mastodon-search-tests.el | 18 | ||||
| -rw-r--r-- | test/mastodon-tl-tests.el | 296 | ||||
| -rw-r--r-- | test/mastodon-toot-tests.el | 161 |
24 files changed, 1856 insertions, 1626 deletions
@@ -1,6 +1,6 @@ #+TEXINFO_DIR_CATEGORY: Emacs #+TEXINFO_DIR_TITLE: Mastodon: (mastodon). -#+TEXINFO_DIR_DESC: Client for Mastodon on ActivityPub networks. +#+TEXINFO_DIR_DESC: Client for fediverse services using the Mastodon API. @@html: <a href="https://elpa.nongnu.org/nongnu/mastodon.html"><img alt="ELPA" src="https://elpa.nongnu.org/nongnu/mastodon.svg"></a>@@ @@ -324,6 +324,10 @@ work without first loading a =mastodon.el= buffer: - =mastodon-switch-to-buffer=: switch between mastodon buffers. +- =mastodon-tl--get-remote-local-timeline=: View a local timeline of a remote instance. +- =mastodon-tl--remote-tag-timeline=: View a tag timeline on a remote instance. + + - =mastodon-profile--update-display-name=: Update the display name for your account. - =mastodon-profile--update-user-profile-note=: Update your bio note. @@ -15,4 +15,5 @@ File: dir, Node: Top This is the top of the INFO tree * Menu: Emacs -* Mastodon: (mastodon). Client for Mastodon on ActivityPub networks. +* Mastodon: (mastodon). Client for fediverse services using the + Mastodon API. diff --git a/lisp/mastodon-async.el b/lisp/mastodon-async.el index 0c70560..317be93 100644 --- a/lisp/mastodon-async.el +++ b/lisp/mastodon-async.el @@ -88,7 +88,7 @@ (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 + (when (not (string= "" mastodon-async--queue)) ; error handle on kill async buffer (kill-buffer mastodon-async--queue)))) (defun mastodon-async--stream-notifications () @@ -207,8 +207,8 @@ ENDPOINT is the endpoint for the stream and timeline." ;; 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") + ((string= name "notifications") "notifications") + ((string= name "home") "timelines/home") (t (format "timelines/%s" endpoint))))) (mastodon-async--set-local-variables buffer-name http-buffer buffer-name queue-name) @@ -218,7 +218,7 @@ ENDPOINT is the endpoint for the stream and 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") + (if (string= name "notifications") (mastodon-notifications--timeline (mastodon-http--get-json (mastodon-http--api "notifications"))) @@ -227,7 +227,7 @@ ENDPOINT is the endpoint for the stream and timeline." (mastodon-mode) (mastodon-tl--set-buffer-spec buffer-name endpoint - (if (equal name "notifications") + (if (string= name "notifications") 'mastodon-notifications--timeline 'mastodon-tl--timeline)) (setq-local mastodon-tl--enable-relative-timestamps nil) @@ -275,7 +275,7 @@ NAME is used for the queue and display buffer." (car split-strings))) (data (replace-regexp-in-string "^data: " "" (cadr split-strings)))) - (when (equal "update" event-type) + (when (string= "update" event-type) ;; in some casses the data is not fully formed ;; for now return nil if malformed using `ignore-errors' (ignore-errors (json-read-from-string data))))))) @@ -289,7 +289,7 @@ NAME is used for the queue and display buffer." (car split-strings))) (data (replace-regexp-in-string "^data: " "" (cadr split-strings)))) - (when (equal "notification" event-type) + (when (string= "notification" event-type) ;; in some casses the data is not fully formed ;; for now return nil if malformed using `ignore-errors' (ignore-errors (json-read-from-string data))))) @@ -324,7 +324,7 @@ NAME is used for the queue and display buffer." mastodon-instance-url "*")) (mastodon-notifications--timeline (list toot)) (mastodon-tl--timeline (list toot))) - (if (equal previous 1) + (if (eq previous 1) (goto-char 1) (goto-char (+ previous (- (point-max) old-max))))))))) diff --git a/lisp/mastodon-auth.el b/lisp/mastodon-auth.el index 404dd57..3796b7e 100644 --- a/lisp/mastodon-auth.el +++ b/lisp/mastodon-auth.el @@ -173,13 +173,13 @@ When ASK is absent return nil." Generate/save token if none known yet." (cond (mastodon-auth--token-alist ;; user variables are known and initialised. - (alist-get mastodon-instance-url mastodon-auth--token-alist nil nil #'equal)) + (alist-get mastodon-instance-url mastodon-auth--token-alist nil nil #'string=)) ((plist-get (mastodon-client--active-user) :access_token) ;; user variables need to be read from plstore. (push (cons mastodon-instance-url (plist-get (mastodon-client--active-user) :access_token)) mastodon-auth--token-alist) - (alist-get mastodon-instance-url mastodon-auth--token-alist nil nil #'equal)) + (alist-get mastodon-instance-url mastodon-auth--token-alist nil nil #'string=)) ((null mastodon-active-user) ;; user not aware of 2FA-related changes and has not set ;; `mastodon-active-user'. Make user aware and error out. diff --git a/lisp/mastodon-client.el b/lisp/mastodon-client.el index 493f9df..6e55829 100644 --- a/lisp/mastodon-client.el +++ b/lisp/mastodon-client.el @@ -174,7 +174,7 @@ Otherwise return nil." (let ((username (mastodon-client--form-user-from-vars)) (user-details (mastodon-client--general-read "active-user"))) (when (and user-details - (equal (plist-get user-details :username) username)) + (string= (plist-get user-details :username) username)) user-details))) (defun mastodon-client--active-user () diff --git a/lisp/mastodon-http.el b/lisp/mastodon-http.el index d6abac4..fbae8a7 100644 --- a/lisp/mastodon-http.el +++ b/lisp/mastodon-http.el @@ -53,9 +53,9 @@ Optionally specify VERSION in format vX." (concat mastodon-instance-url "/api/" (or version mastodon-http--api-version) "/" endpoint)) -(defun mastodon-http--api-search () - "Return Mastodon API url for the /search endpoint (v2)." - (format "%s/api/v2/search" mastodon-instance-url)) +(defun mastodon-http--api-v2 (endpoint) + "Return Mastodon API v2 URL for ENDPOINT." + (mastodon-http--api endpoint "v2")) (defun mastodon-http--response () "Capture response buffer content as string." @@ -137,6 +137,13 @@ Used for API form data parameters that take an array." (cl-loop for x in array collect (cons param-str x))) +(defun mastodon-http--concat-params-to-url (url params) + "Build a query string with PARAMS and concat to URL." + (if params + (concat url "?" + (mastodon-http--build-params-string params)) + url)) + (defun mastodon-http--post (url &optional params headers unauthenticated-p json) "POST synchronously to URL, optionally with PARAMS and HEADERS. @@ -165,13 +172,6 @@ the request data. If it is :raw, just use the plain params." (mastodon-http--url-retrieve-synchronously url))) unauthenticated-p)) -(defun mastodon-http--concat-params-to-url (url params) - "Build a query string with PARAMS and concat to URL." - (if params - (concat url "?" - (mastodon-http--build-params-string params)) - url)) - (defun mastodon-http--get (url &optional params silent) "Make synchronous GET request to URL. PARAMS is an alist of any extra parameters to send with the request. @@ -249,6 +249,10 @@ Callback to `mastodon-http--get-response-async', usually (string-prefix-p "\n[" json-string))) (error "%s" json-string)) (t + ;; instance may return error in JSON e.g. ((error . "Record not + ;; found")) for a null endpoint. but we don't error here because + ;; sometimes we just want to check for such an error in an + ;; if/cond. `(,(json-read-from-string json-string) . ,headers)))))) (defun mastodon-http--process-headers () @@ -361,7 +365,7 @@ item uploaded, and `mastodon-toot--update-status-fields' is run." ;; this is how the mangane akkoma web client does it ;; and it seems easier than the other options! (when (and caption - (not (equal caption (alist-get 'description data)))) + (not (string= caption (alist-get 'description data)))) (let ((url (mastodon-http--api (format "media/%s" id)))) ;; (message "PUTting image description") (mastodon-http--put url desc))) diff --git a/lisp/mastodon-media.el b/lisp/mastodon-media.el index 9dc8517..2ec498e 100644 --- a/lisp/mastodon-media.el +++ b/lisp/mastodon-media.el @@ -273,7 +273,7 @@ IBCAQICX9F8/bNVInwJ8BAAAAABJRU5ErkJggg==") "The PNG data for a sensitive image placeholder.") (defun mastodon-media--process-image-response - (status-plist marker image-options region-length url) + (status-plist url marker image-options region-length) "Callback function processing the url retrieve response for URL. STATUS-PLIST is the usual plist of status events as per `url-retrieve'. IMAGE-OPTIONS are the precomputed options to apply to the image. @@ -288,10 +288,9 @@ with the image." (search-forward "\n\n") (buffer-substring (point) (point-max)))) (image (when data - (apply #'create-image data - (if (version< emacs-version "27.1") - (when image-options 'imagemagick) - nil) ; inbuilt scaling in 27.1 + (apply #'create-image data ;; inbuilt scaling in 27.1: + (when (version< emacs-version "27.1") + (when image-options 'imagemagick)) t image-options)))) (when mastodon-media--enable-image-caching (unless (url-is-cached url) ; cache if not already cached @@ -307,7 +306,8 @@ with the image." ;; We only set the image to display if we could load ;; it; we already have set a default image when we ;; added the tag. - (mastodon-media--display-image-or-sensitive marker region-length image)) + (mastodon-media--display-image-or-sensitive + marker region-length image)) ;; We are done with the marker; release it: (set-marker marker nil))) (kill-buffer url-buffer)))))) @@ -318,7 +318,7 @@ MARKER, REGION-LENGTH and IMAGE are from `mastodon-media--process-image-response'. If the image is marked sensitive, the image is stored in image-data prop so it can be toggled." - (if (or (not (equal t (get-text-property marker 'sensitive))) + (if (or (not (eq t (get-text-property marker 'sensitive))) (not mastodon-media--hide-sensitive-media)) ;; display image (put-text-property marker (+ marker region-length) @@ -327,9 +327,9 @@ image-data prop so it can be toggled." (add-text-properties marker (+ marker region-length) `(display ;; (image :type png :data ,mastodon-media--sensitive-image-data) - ,(create-image mastodon-media--sensitive-image-data nil t) - sensitive-state hidden - image-data ,image)))) + ,(create-image + mastodon-media--sensitive-image-data nil t) + sensitive-state hidden image-data ,image)))) (defun mastodon-media--process-full-sized-image-response (status-plist url) ;; FIXME: refactor this with but not into @@ -338,7 +338,7 @@ image-data prop so it can be toggled." URL is a full-sized image URL attached to a timeline image. STATUS-PLIST is a plist of status events as per `url-retrieve'." (if-let (error-response (plist-get status-plist :error)) - (message "error in loading image: %S" error-response) + (user-error "error in loading image: %S" error-response) (when mastodon-media--enable-image-caching (unless (url-is-cached url) ;; cache if not already cached (url-store-in-cache))) @@ -347,8 +347,6 @@ STATUS-PLIST is a plist of status events as per `url-retrieve'." (let* ((handle (mm-dissect-buffer t)) (image (mm-get-image handle)) (str (image-property image :data))) - ;; (setf (image-property image :max-width) - ;; (window-pixel-width)) (with-current-buffer (get-buffer-create "*masto-image*") (let ((inhibit-read-only t)) (erase-buffer) @@ -359,43 +357,46 @@ STATUS-PLIST is a plist of status events as per `url-retrieve'." (switch-to-buffer-other-window (current-buffer)) (image-transform-fit-both)))))) +(defun mastodon-media--image-or-cached (url process-fun args) + "Fetch URL from cache or fro host. +Call PROCESS-FUN on it with ARGS, a list of callback args as +specified by `url-retrieve'." + (if (and mastodon-media--enable-image-caching + (url-is-cached url)) ;; if cached, decompress and use: + (with-current-buffer (url-fetch-from-cache url) + (set-buffer-multibyte nil) + (goto-char (point-min)) + (zlib-decompress-region + (goto-char (search-forward "\n\n")) (point-max)) + (apply process-fun args)) ;; no status-plist arg from cache + ;; fetch as usual and process-image-response will cache it: + ;; cbargs fun will be called with status-plist by url-retrieve: + (url-retrieve url process-fun (cdr args)))) + (defun mastodon-media--load-image-from-url (url media-type start region-length) "Take a URL and MEDIA-TYPE and load the image asynchronously. MEDIA-TYPE is a symbol and either `avatar' or `media-link'. START is the position where we start loading the image. REGION-LENGTH is the range from start to propertize." (let ((image-options - (when (or (image-type-available-p 'imagemagick) - (image-transforms-p)) ; inbuilt scaling in 27.1 + (when (mastodon-tl--image-trans-check) (cond ((eq media-type 'avatar) `(:height ,mastodon-media--avatar-height)) ((eq media-type 'media-link) `(:max-height ,mastodon-media--preview-max-height))))) (buffer (current-buffer)) (marker (copy-marker start)) - (url-show-status nil)) ; stop url.el from spamming us about connecting + (url-show-status nil)) ; stop url.el from spamming us about connecting (condition-case nil - ;; catch any errors in url-retrieve so as to not abort - ;; whatever called us - (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))) + ;; catch errors in url-retrieve to not break our caller + (mastodon-media--image-or-cached + url + #'mastodon-media--process-image-response + (list nil url marker image-options region-length)) (error (with-current-buffer buffer - ;; TODO: Consider adding retries - (put-text-property marker - (+ marker region-length) - 'media-state - 'loading-failed) + ;; TODO: Add retries + (put-text-property marker (+ marker region-length) + 'media-state 'loading-failed) :loading-failed))))) (defun mastodon-media--select-next-media-line (end-pos) @@ -441,7 +442,6 @@ Replace them with the referenced image." (media-type (cadr (cdr line-details))) (type (get-text-property start 'mastodon-media-type)) (image-url (get-text-property start 'media-url))) - ;; (sensitive (get-text-property start 'sensitive))) (if (not (mastodon-media--valid-link-p image-url)) ;; mark it at least as not needing loading any more (put-text-property start end 'media-state 'invalid-url) @@ -449,8 +449,8 @@ Replace them with the referenced image." (put-text-property start end 'media-state 'loading) (mastodon-media--load-image-from-url image-url media-type start (- end start)) - (when (or (equal type "gifv") - (equal type "video")) + (when (or (string= type "gifv") + (string= type "video")) (mastodon-media--moving-image-overlay start end)))))))) ;; (defvar-local mastodon-media--overlays nil @@ -474,19 +474,19 @@ START and END are the beginning and end of the media item to overlay." ;; 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 (or (image-type-available-p 'imagemagick) - (image-transforms-p)) ; inbuilt scaling in 27.1 + (let ((image-options (when (mastodon-tl--image-trans-check) `(:height ,mastodon-media--avatar-height)))) (concat (propertize " " 'media-url avatar-url 'media-state 'needs-loading 'media-type 'avatar - 'display (apply #'create-image mastodon-media--generic-avatar-data - (if (version< emacs-version "27.1") - (when image-options 'imagemagick) - nil) ; inbuilt scaling in 27.1 - t image-options)) + 'display + (apply #'create-image mastodon-media--generic-avatar-data + ;; inbuilt scaling in 27.1 + (when (version< emacs-version "27.1") + (when image-options 'imagemagick)) + t image-options)) " "))) (defun mastodon-media--get-media-link-rendering @@ -500,9 +500,8 @@ SENSITIVE is a flag from the item's JSON data." (substitute-command-keys (concat "\\`RET'/\\`i': load full image (prefix: copy URL), \\`+'/\\`-': zoom,\ \\`r': rotate, \\`o': save preview" - (if (not (eq sensitive :json-false)) - ", \\`S': toggle sensitive media" - "")))) + (when (not (eq sensitive :json-false)) + ", \\`S': toggle sensitive media")))) (help-echo (if caption (concat help-echo-base "\n\"" caption "\"") diff --git a/lisp/mastodon-notifications.el b/lisp/mastodon-notifications.el index 9f92172..1c2aad7 100644 --- a/lisp/mastodon-notifications.el +++ b/lisp/mastodon-notifications.el @@ -115,32 +115,31 @@ With no argument, the request is accepted. Argument REJECT means reject the request. Can be called in notifications view or in follow-requests view." (if (not (mastodon-tl--find-property-range 'item-json (point))) - (message "No follow request at point?") + (user-error "No follow request at point?") (let* ((item-json (mastodon-tl--property 'item-json)) (f-reqs-view-p (string= "follow_requests" (plist-get mastodon-tl--buffer-spec 'endpoint))) (f-req-p (or (string= "follow_request" (alist-get 'type item-json)) ;notifs f-reqs-view-p))) (if (not f-req-p) - (message "No follow request at point?") + (user-error "No follow request at point?") (let-alist (or (alist-get 'account item-json) ;notifs item-json) ;f-reqs - (if .id - (let ((response - (mastodon-http--post - (concat - (mastodon-http--api "follow_requests") - (format "/%s/%s" .id (if reject "reject" "authorize")))))) - (mastodon-http--triage response - (lambda (_) - (if f-reqs-view-p - (mastodon-views--view-follow-requests) - (mastodon-tl--reload-timeline-or-profile)) - (message "Follow request of %s (@%s) %s!" - .username .acct (if reject - "rejected" - "accepted"))))) - (message "No account result at point?"))))))) + (if (not .id) + (user-error "No account result at point?") + (let ((response + (mastodon-http--post + (mastodon-http--api + (format "follow_requests/%s/%s" + .id (if reject "reject" "authorize")))))) + (mastodon-http--triage + response + (lambda (_) + (if f-reqs-view-p + (mastodon-views--view-follow-requests) + (mastodon-tl--reload-timeline-or-profile)) + (message "Follow request of %s (@%s) %s!" + .username .acct (if reject "rejected" "accepted"))))))))))) (defun mastodon-notifications--follow-request-accept () "Accept a follow request. @@ -191,7 +190,6 @@ Status notifications are given when (defun mastodon-notifications--comment-note-text (str) "Add comment face to all text in STR with `shr-text' face only." (with-temp-buffer - (switch-to-buffer (current-buffer)) (insert str) (goto-char (point-min)) (let (prop) @@ -206,7 +204,7 @@ Status notifications are given when ;; FIXME: apply/refactor filtering as per/with `mastodon-tl--toot' (let* ((id (alist-get 'id note)) (profile-note - (when (equal 'follow-request type) + (when (eq 'follow-request type) (let ((str (mastodon-tl--field 'note (mastodon-tl--field 'account note)))) @@ -223,15 +221,15 @@ Status notifications are given when nil (mastodon-tl--insert-status ;; toot - (cond ((or (equal type 'follow) - (equal type 'follow-request)) + (cond ((or (eq type 'follow) + (eq type 'follow-request)) ;; Using reblog with an empty id will mark this as something ;; non-boostable/non-favable. (cons '(reblog (id . nil)) note)) ;; reblogs/faves use 'note' to process their own json ;; not the toot's. this ensures following etc. work on such notifs - ((or (equal type 'favourite) - (equal type 'boost)) + ((or (eq type 'favourite) + (eq type 'boost)) note) (t status)) @@ -241,12 +239,12 @@ Status notifications are given when (mastodon-tl--clean-tabs-and-nl (if (mastodon-tl--has-spoiler status) (mastodon-tl--spoiler status) - (if (equal 'follow-request type) + (if (eq 'follow-request type) (mastodon-tl--render-text profile-note) (mastodon-tl--content status))))))) (cond ((or (eq type 'follow) (eq type 'follow-request)) - (if (equal type 'follow) + (if (eq type 'follow) (propertize "Congratulations, you have a new follower!" 'face 'default) (concat @@ -263,59 +261,40 @@ Status notifications are given when (mastodon-notifications--comment-note-text body)) (t body))) ;; author-byline - (if (or (equal type 'follow) - (equal type 'follow-request) - (equal type 'mention)) + (if (or (eq type 'follow) + (eq type 'follow-request) + (eq type 'mention)) 'mastodon-tl--byline-author (lambda (_status &rest _args) ; unbreak stuff (mastodon-tl--byline-author note))) ;; action-byline (lambda (_status) (mastodon-notifications--byline-concat - (cond ((equal type 'boost) + (cond ((eq type 'boost) "Boosted") - ((equal type 'favourite) + ((eq type 'favourite) "Favourited") - ((equal type 'follow-request) + ((eq type 'follow-request) "Requested to follow") - ((equal type 'follow) + ((eq type 'follow) "Followed") - ((equal type 'mention) + ((eq type 'mention) "Mentioned") - ((equal type 'status) + ((eq type 'status) "Posted") - ((equal type 'poll) + ((eq type 'poll) "Posted a poll") - ((equal type 'edit) + ((eq type 'edit) "Edited")))) id ;; base toot - (when (or (equal type 'favourite) - (equal type 'boost)) + (when (or (eq type 'favourite) + (eq type 'boost)) status))))) -(defun mastodon-notifications--insert-status - (toot body author-byline action-byline id &optional base-toot) - "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. -If the status is a favourite or a boost, BASE-TOOT is the JSON -of the toot responded to." - (when toot ; handle rare blank notif server bug - (mastodon-tl--insert-status toot body author-byline action-byline id base-toot))) - (defun mastodon-notifications--by-type (note) - "Filters NOTE for those listed in `mastodon-notifications--types-alist'." + "Filter NOTE for those listed in `mastodon-notifications--types-alist'. +Call its function in that list on NOTE." (let* ((type (mastodon-tl--field 'type note)) (fun (cdr (assoc type mastodon-notifications--types-alist))) (start-pos (point))) @@ -327,7 +306,7 @@ of the toot responded to." (defun mastodon-notifications--timeline (json) "Format JSON in Emacs buffer." (if (seq-empty-p json) - (message "Looks like you have no (more) notifications for the moment.") + (user-error "Looks like you have no (more) notifications for now") (mapc #'mastodon-notifications--by-type json) (goto-char (point-min)))) diff --git a/lisp/mastodon-profile.el b/lisp/mastodon-profile.el index de16b7d..6410591 100644 --- a/lisp/mastodon-profile.el +++ b/lisp/mastodon-profile.el @@ -82,6 +82,7 @@ (autoload 'mastodon-return-credential-account "mastodon") (autoload 'mastodon-tl--buffer-property "mastodon-tl") (autoload 'mastodon-search--query "mastodon-search") +(autoload 'mastodon-tl--field-status "mastodon-tl") (defvar mastodon-tl--horiz-bar) (defvar mastodon-tl--update-point) @@ -126,7 +127,7 @@ It contains details of the current user's account.") "Keymap for `mastodon-profile-update-mode'.") (persist-defvar mastodon-profile-account-settings nil - "An alist of account settings saved from the server. + "An alist of account settings saved from the server. Other clients can change these settings on the server at any time, so this list is not the canonical source for settings. It is updated on entering mastodon mode and on toggle any setting it @@ -157,6 +158,8 @@ MAX-ID is a flag to include the max_id pagination parameter." account "statuses" #'mastodon-tl--timeline no-reblogs nil no-replies only-media tag max-id)) +;;; PROFILE VIEW COMMANDS + ;; TODO: we shd just load all views' data then switch coz this is slow af: (defun mastodon-profile--account-view-cycle () "Cycle through profile view: toots, toot sans boosts, followers, and following." @@ -242,11 +245,10 @@ MAX-ID is a flag to include the max_id pagination parameter." (defun mastodon-profile--add-account-to-list () "Add account of current profile buffer to a list." (interactive) - (when mastodon-profile--account - (let* ((profile mastodon-profile--account) - (id (alist-get 'id profile)) - (handle (alist-get 'acct profile))) - (mastodon-views--add-account-to-list nil id handle)))) + (if (not mastodon-profile--account) + (user-error "No profile to add?") + (let-alist mastodon-profile--account + (mastodon-views--add-account-to-list nil .id .acct)))) (defun mastodon-profile--account-search (query) "Run a statuses search QUERY for the currently viewed account." @@ -258,43 +260,50 @@ MAX-ID is a flag to include the max_id pagination parameter." ;;; ACCOUNT PREFERENCES -(defun mastodon-profile--get-json-value (val) - "Fetch current VAL ue from account." - (let* ((response (mastodon-return-credential-account))) - (if (eq (alist-get val response) :json-false) - nil - (alist-get val response)))) +(defun mastodon-profile--get-account-value (key function) + "Fetch KEY from data returned by FUNCTION. +If value is :json-false, return nil." + (let* ((response (funcall function)) + (value (alist-get key response))) + (if (eq value :json-false) nil value))) + +(defun mastodon-profile--get-json-value (key) + "Fetch value for KEY from account. +Account details are from `mastodon-return-credential-account'. +If value is :json-false, return nil." + (mastodon-profile--get-account-value + key #'mastodon-return-credential-account)) (defun mastodon-profile--get-source-values () "Return the \"source\" preferences from the server." (mastodon-profile--get-json-value 'source)) (defun mastodon-profile--get-source-value (pref) - "Return account PREF erence from the \"source\" section on the server." - (let ((source (mastodon-profile--get-source-values))) - (if (eq (alist-get pref source) :json-false) - nil - (alist-get pref source)))) + "Return PREF erence from the account's \"source\" field." + (mastodon-profile--get-account-value + pref #'mastodon-profile--get-source-values)) (defun mastodon-profile--update-user-profile-note () "Fetch user's profile note and display for editing." (interactive) - (let* ((json (mastodon-return-credential-account)) - (source (alist-get 'source json)) + (let* ((source (mastodon-profile--get-source-values)) (note (alist-get 'note source)) (buffer (get-buffer-create "*mastodon-update-profile*")) (inhibit-read-only t) - (msg-str (substitute-command-keys - "Edit your profile note. \\`C-c C-c' to send, \\`C-c C-k' to cancel."))) + (msg-str + (substitute-command-keys + "Edit your profile note. \\`C-c C-c' to send, \\`C-c C-k' to cancel."))) (switch-to-buffer-other-window buffer) (text-mode) - (mastodon-tl--set-buffer-spec (buffer-name buffer) "accounts/verify_credentials" nil) + (mastodon-tl--set-buffer-spec (buffer-name buffer) + "accounts/verify_credentials" nil) (setq-local header-line-format msg-str) (mastodon-profile-update-mode t) - (insert (propertize (concat (propertize "0" - 'note-counter t - 'display nil) - "/500 characters") + (insert (propertize (concat + (propertize "0" + 'note-counter t + 'display nil) + "/500 characters") 'read-only t 'face 'font-lock-comment-face 'note-header t) @@ -310,13 +319,13 @@ MAX-ID is a flag to include the max_id pagination parameter." (defun mastodon-profile--update-note-count (&rest _args) "Display the character count of the profile note buffer." (let* ((inhibit-read-only t) - (header-region (mastodon-tl--find-property-range 'note-header + (header-region (mastodon-tl--find-property-range 'note-header + (point-min))) + (count-region (mastodon-tl--find-property-range 'note-counter (point-min))) - (count-region (mastodon-tl--find-property-range 'note-counter - (point-min))) - (count (number-to-string (mastodon-toot--count-toot-chars - (buffer-substring-no-properties - (cdr header-region) (point-max)))))) + (count (number-to-string (mastodon-toot--count-toot-chars + (buffer-substring-no-properties + (cdr header-region) (point-max)))))) (add-text-properties (car count-region) (cdr count-region) (list 'display count)))) @@ -327,7 +336,7 @@ MAX-ID is a flag to include the max_id pagination parameter." (mastodon-kill-window))) (defun mastodon-profile--note-remove-header () - "Get the body of a toot from the current compose buffer." + "Get the profile note, without the buffer header." (let ((header-region (mastodon-tl--find-property-range 'note-header (point-min)))) (buffer-substring (cdr header-region) (point-max)))) @@ -338,10 +347,8 @@ Ask for confirmation if length > 500 characters." (interactive) (let* ((note (mastodon-profile--note-remove-header)) (url (mastodon-http--api "accounts/update_credentials"))) - (if (> (mastodon-toot--count-toot-chars note) 500) - (when (y-or-n-p "Note is over mastodon's max for profile notes (500). Proceed?") - (quit-window 'kill) - (mastodon-profile--user-profile-send-updated-do url note)) + (when (or (not (> (mastodon-toot--count-toot-chars note) 500)) + (y-or-n-p "Note is over mastodon's max for profile notes (500). Proceed?")) (quit-window 'kill) (mastodon-profile--user-profile-send-updated-do url note)))) @@ -455,9 +462,11 @@ Current settings are fetched from the server." (defun mastodon-profile--make-meta-fields-params (fields) "Construct a parameter query string from metadata alist FIELDS. Returns an alist." - (let ((keys (cl-loop for count from 1 to 5 - collect (cons (format "fields_attributes[%s][name]" count) - (format "fields_attributes[%s][value]" count))))) + (let ((keys + (cl-loop + for count from 1 to 5 + collect (cons (format "fields_attributes[%s][name]" count) + (format "fields_attributes[%s][value]" count))))) (cl-loop for a-pair in keys for b-pair in fields append (list (cons (car a-pair) (car b-pair)) @@ -480,8 +489,7 @@ Returns an alist." "Prompt for new metadata fields information. Returns the results as an alist." (let ((fields-old (mastodon-profile--fields-get - nil - ;; we must fetch the plaintext version: + nil ;; we must fetch the plaintext version: (mastodon-profile--get-source-value 'fields)))) ;; offer empty fields if user currently has less than four filled: (while (< (length fields-old) 4) @@ -524,12 +532,11 @@ The endpoint only holds a few preferences. For others, see (buf (get-buffer-create "*mastodon-preferences*"))) (with-mastodon-buffer buf #'special-mode :other-window (mastodon-tl--set-buffer-spec (buffer-name buf) "preferences" nil) - (while response - (let ((el (pop response))) - (insert (format "%-30s %s" - (prin1-to-string (car el)) - (prin1-to-string (cdr el))) - "\n\n"))) + (while-let ((el (pop response))) + (insert (format "%-30s %s" + (prin1-to-string (car el)) + (prin1-to-string (cdr el))) + "\n\n")) (goto-char (point-min))))) @@ -537,10 +544,10 @@ The endpoint only holds a few preferences. For others, see (defun mastodon-profile--relationships-get (id) "Fetch info about logged-in user's relationship to user with id ID." - (let* ((their-id id) - (args `(("id[]" . ,their-id))) + (let* ((args `(("id[]" . ,id))) (url (mastodon-http--api "accounts/relationships"))) - (car (mastodon-http--get-json url args)))) ; API takes array, just get 1st + ;; FIXME: API takes array, we just get 1st + (car (mastodon-http--get-json url args)))) (defun mastodon-profile--fields-get (&optional account fields) "Fetch the fields vector (aka profile metadata) from profile of ACCOUNT. @@ -585,16 +592,15 @@ FIELDS means provide a fields vector fetched by other means." "T if you have any relationship with the accounts in LIST." (let (result) (dolist (x list result) - (when (not (equal :json-false x)) + (when (not (eq :json-false x)) (setq result x))))) (defun mastodon-profile--render-roles (roles) "Return a propertized string of badges for ROLES." (mapconcat (lambda (role) - (propertize - (alist-get 'name role) - 'face `(:box t :foreground ,(alist-get 'color role)))) + (propertize (alist-get 'name role) + 'face `(:box t :foreground ,(alist-get 'color role)))) roles)) (defun mastodon-profile--make-profile-buffer-for @@ -611,8 +617,7 @@ MAX-ID is a flag to include the max_id pagination parameter." (let* ((max-id-str (when max-id (mastodon-tl--buffer-property 'max-id))) (args `(("limit" . ,mastodon-tl--timeline-posts-count) - ,(when max-id - `("max_id" . ,max-id-str)))) + ,(when max-id `("max_id" . ,max-id-str)))) (args (cond (no-reblogs (push '("exclude_reblogs" . "t") args)) (no-replies @@ -621,8 +626,7 @@ MAX-ID is a flag to include the max_id pagination parameter." (push '("only_media" . "t") args)) (tag (push `("tagged" . ,tag) args)) - (t - args))) + (t args))) (endpoint (format "accounts/%s/%s" .id endpoint-type)) (url (mastodon-http--api endpoint)) (buffer (concat "*mastodon-" .acct "-" @@ -649,22 +653,20 @@ MAX-ID is a flag to include the max_id pagination parameter." (mastodon-tl--set-buffer-spec buffer endpoint update-function link-header args nil max-id-str) (let* ((inhibit-read-only t) - (is-statuses (string= endpoint-type "statuses")) - (is-followers (string= endpoint-type "followers")) - (is-following (string= endpoint-type "following")) - (endpoint-name (cond - (is-statuses (cond (no-reblogs - " TOOTS (no boosts)") - (no-replies - " TOOTS (no replies)") - (only-media - " TOOTS (media only)") - (tag - (format " TOOTS (containing #%s)" tag)) - (t - " TOOTS "))) - (is-followers " FOLLOWERS ") - (is-following " FOLLOWING ")))) + (endpoint-name + (cond ((string= endpoint-type "statuses") + (cond (no-reblogs + " TOOTS (no boosts)") + (no-replies + " TOOTS (no replies)") + (only-media + " TOOTS (media only)") + (tag + (format " TOOTS (containing #%s)" tag)) + (t + " TOOTS "))) + ((string= endpoint-type "followers") " FOLLOWERS ") + ((string= endpoint-type "following") " FOLLOWING ")))) (insert (propertize (concat @@ -679,18 +681,16 @@ MAX-ID is a flag to include the max_id pagination parameter." (mastodon-profile--render-roles .roles))) "\n" (propertize (concat "@" .acct) 'face 'default) - (if (equal .locked t) - (concat " " (mastodon-tl--symbol 'locked)) - "") + (when (eq .locked t) + (concat " " (mastodon-tl--symbol 'locked))) "\n " mastodon-tl--horiz-bar "\n" ;; profile note: (mastodon-tl--render-text .note account) ; account = tab-stops in profile ;; meta fields: - (if fields - (concat "\n" (mastodon-tl--set-face - (mastodon-profile--fields-insert fields) - 'success)) - "") + (when fields + (concat "\n" (mastodon-tl--set-face + (mastodon-profile--fields-insert fields) + 'success))) "\n" ;; Joined date: (propertize @@ -713,18 +713,16 @@ MAX-ID is a flag to include the max_id pagination parameter." (rels (mastodon-profile--relationships-get .id)) (langs-filtered (if-let ((langs (alist-get 'languages rels))) (concat " (" - (mapconcat #'identity - langs - " ") + (mapconcat #'identity langs " ") ")") ""))) (if followsp (mastodon-tl--set-face - (concat (when (equal .following 't) + (concat (when (eq .following t) (format " | FOLLOWED BY YOU%s" langs-filtered)) - (when (equal .followed_by 't) + (when (eq .followed_by t) " | FOLLOWS YOU") - (when (equal .requested_by 't) + (when (eq .requested_by t) " | REQUESTED TO FOLLOW YOU") "\n\n") 'success) @@ -737,7 +735,7 @@ MAX-ID is a flag to include the max_id pagination parameter." (setq mastodon-tl--update-point (point)) (mastodon-media--inline-images (point-min) (point)) ;; insert pinned toots first - (when (and pinned (equal endpoint-type "statuses")) + (when (and pinned (string= endpoint-type "statuses")) (mastodon-profile--insert-statuses-pinned pinned) (setq mastodon-tl--update-point (point))) ; updates after pinned toots (funcall update-function json)) @@ -769,7 +767,7 @@ MAX-ID is a flag to include the max_id pagination parameter." "Return a avatar image from ACCOUNT. IMG-TYPE is the JSON key from the account data." (let ((img (alist-get img-type account))) - (unless (equal img "/avatars/original/missing.png") + (unless (string= img "/avatars/original/missing.png") (mastodon-media--get-media-link-rendering img)))) (defun mastodon-profile--show-user (user-handle) @@ -778,7 +776,7 @@ IMG-TYPE is the JSON key from the account data." (list (if (and (not (mastodon-tl--profile-buffer-p)) (not (mastodon-tl--property 'item-json :no-move))) - (message "Looks like there's no toot or user at point?") + (user-error "Looks like there's no toot or user at point?") (let ((user-handles (mastodon-profile--extract-users-handles (mastodon-profile--item-json)))) (completing-read "View profile of user [choose or enter any handle]: " @@ -786,17 +784,17 @@ IMG-TYPE is the JSON key from the account data." nil ; predicate 'confirm))))) (if (not (or ; own profile has no need for item-json test: - (equal user-handle (mastodon-auth--get-account-name)) + (string= user-handle (mastodon-auth--get-account-name)) (mastodon-tl--profile-buffer-p) (mastodon-tl--property 'item-json :no-move))) - (message "Looks like there's no toot or user at point?") + (user-error "Looks like there's no toot or user at point?") (let ((account (mastodon-profile--lookup-account-in-status user-handle (mastodon-profile--item-json)))) - (if 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))))) + (if (not account) + (user-error "Cannot find a user with handle %S" user-handle) + (progn + (message "Loading profile of user %s..." user-handle) + (mastodon-profile--make-author-buffer account)))))) (defun mastodon-profile--my-profile () "Show the profile of the currently signed in user." @@ -815,13 +813,14 @@ Used to view a user's followers and those they're following." (mapc (lambda (toot) (let ((start-pos (point))) - (insert "\n" - (propertize - (mastodon-tl--byline-author `((account . ,toot)) :avatar) - 'byline 't - 'item-id (alist-get 'id toot) - 'base-item-id (mastodon-tl--item-id toot) - 'item-json toot)) + (insert + "\n" + (propertize + (mastodon-tl--byline-author `((account . ,toot)) :avatar) + 'byline 't + 'item-id (alist-get 'id toot) + 'base-item-id (mastodon-tl--item-id toot) + 'item-json toot)) (mastodon-media--inline-images start-pos (point)) (insert "\n" (propertize @@ -838,12 +837,13 @@ If the handle does not match a search return then retun NIL." handle)) (args `(("q" . ,handle) ("type" . "accounts"))) - (result (mastodon-http--get-json (mastodon-http--api-search) args)) + (result (mastodon-http--get-json + (mastodon-http--api-v2 "search") args)) (matching-account (seq-remove (lambda (x) - (not (string= (alist-get 'acct x) handle))) + (not (string= handle (alist-get 'acct x)))) (alist-get 'accounts result)))) - (when (equal 1 (length matching-account)) + (when (eq 1 (length matching-account)) (elt matching-account 0)))) (defun mastodon-profile--account-from-id (user-id) @@ -857,10 +857,8 @@ These include the author, author of reblogged entries and any user mentioned." (when status (let ((this-account (or (alist-get 'account status) ; status is a toot status)) ; status is a user listing - (mentions (or (alist-get 'mentions (alist-get 'status status)) - (alist-get 'mentions status))) - (reblog (or (alist-get 'reblog (alist-get 'status status)) - (alist-get 'reblog status)))) + (mentions (mastodon-tl--field-status 'mentions status)) + (reblog (mastodon-tl--field-status 'reblog status))) (seq-filter #'stringp (seq-uniq (seq-concatenate @@ -887,16 +885,17 @@ These include the author, author of reblogged entries and any user mentioned." (t (mastodon-profile--search-account-by-handle handle))))) +;;; REMOVE + (defun mastodon-profile--remove-user-from-followers (&optional id) "Remove a user from your followers. Optionally provide the ID of the account to remove." (interactive) (let* ((account (unless id (mastodon-tl--property 'item-json :no-move))) (id (or id (alist-get 'id account))) - (handle (if account - (alist-get 'acct account) - (let ((account (mastodon-profile--account-from-id id))) - (alist-get 'acct account)))) + (handle (let ((account (or account + (mastodon-profile--account-from-id id)))) + (alist-get 'acct account))) (url (mastodon-http--api (format "accounts/%s/remove_from_followers" id)))) (when (y-or-n-p (format "Remove follower %s? " handle)) @@ -910,7 +909,7 @@ Optionally provide the ID of the account to remove." (interactive) (let* ((handles (mastodon-profile--extract-users-handles (mastodon-profile--item-json))) - (handle (completing-read "Remove from followers: " handles nil)) + (handle (completing-read "Remove from followers: " handles)) (account (mastodon-profile--lookup-account-in-status handle (mastodon-profile--item-json))) (id (alist-get 'id account))) @@ -930,6 +929,8 @@ Currently limited to 100 handles. If not found, try (id (alist-get choice handles))) (mastodon-profile--remove-user-from-followers id))) +;;; PRIVATE NOTES + (defun mastodon-profile--add-private-note-to-account () "Add a private note to an account. Can be called from a profile page or normal timeline. @@ -942,8 +943,9 @@ Send an empty note to clear an existing one." (defun mastodon-profile--post-private-note-to-account (id handle note-old) "POST a private note onto an account ID with user HANDLE on the server. NOTE-OLD is the text of any existing note." - (let* ((note (read-string (format "Add private note to account %s: " handle) - note-old)) + (let* ((note (read-string + (format "Add private note to account %s: " handle) + note-old)) (params `(("comment" . ,note))) (url (mastodon-http--api (format "accounts/%s/note" id))) (response (mastodon-http--post url params))) @@ -967,13 +969,15 @@ NOTE-OLD is the text of any existing note." (defun mastodon-profile--profile-json () "Return the profile-json property if we are in a profile buffer." - (when (mastodon-tl--profile-buffer-p) + (if (not (mastodon-tl--profile-buffer-p)) + (error "Not viewing a profile") (save-excursion (goto-char (point-min)) (or (mastodon-tl--property 'profile-json :no-move) (error "No profile data found"))))) -(defun mastodon-profile--add-or-view-private-note (action-fun &optional message view) +(defun mastodon-profile--add-or-view-private-note (action-fun + &optional message view) "Add or view a private note for an account. ACTION-FUN does the adding or viewing, MESSAGE is a prompt for `mastodon-tl--user-handles-get', VIEW is a flag." @@ -989,10 +993,14 @@ ACTION-FUN does the adding or viewing, MESSAGE is a prompt for (note (alist-get 'note relationships))) (if view (if (string-empty-p note) - (message "No private note for %s" handle) + (user-error "No private note for %s" handle) + ;; `mastodon-profile--display-private-note' takes 1 arg: (funcall action-fun note)) + ;; `mastodon-profile--post-private-note-to-account' takes 3 args: (funcall action-fun id handle note)))) +;;; FAMILIAR FOLLOWERS + (defun mastodon-profile--show-familiar-followers () "Show a list of familiar followers. Familiar followers are accounts that you follow, and that follow @@ -1018,7 +1026,7 @@ the given account." (accounts (alist-get 'accounts (car json))) ; first id (handles (mastodon-tl--map-alist 'acct accounts))) (if (null handles) - (message "Looks like there are no familiar followers for this account") + (user-error "Looks like there are no familiar followers for this account") (let ((choice (completing-read "Show profile of user: " handles))) (mastodon-profile--show-user choice))))) diff --git a/lisp/mastodon-search.el b/lisp/mastodon-search.el index f862f3c..7fc4de3 100644 --- a/lisp/mastodon-search.el +++ b/lisp/mastodon-search.el @@ -44,7 +44,6 @@ (autoload 'mastodon-tl--timeline "mastodon-tl") (autoload 'mastodon-tl--toot "mastodon-tl") (autoload 'mastodon-tl--buffer-property "mastodon-tl") -(autoload 'mastodon-http--api-search "mastodon-http") (defvar mastodon-toot--completion-style-for-mentions) (defvar mastodon-instance-url) @@ -64,11 +63,13 @@ Returns a nested list containing user handle, display name, and URL." (let* ((url (mastodon-http--api "accounts/search")) (response - (if (equal mastodon-toot--completion-style-for-mentions "following") - (mastodon-http--get-json - url `(("q" . ,query) ("following" . "true")) - :silent) - (mastodon-http--get-json url `(("q" . ,query)) :silent)))) + (mastodon-http--get-json + url + `(("q" . ,query) ;; NB: nil can break params (but works for me) + ,(when (string= "following" + mastodon-toot--completion-style-for-mentions) + '("following" . "true"))) + :silent))) (mapcar #'mastodon-search--get-user-info-@ response))) ;; functions for tags completion: @@ -76,7 +77,7 @@ Returns a nested list containing user handle, display name, and URL." (defun mastodon-search--search-tags-query (query) "Return an alist containing tag strings plus their URLs. QUERY is the string to search." - (let* ((url (mastodon-http--api-search)) + (let* ((url (mastodon-http--api-v2 "search")) (params `(("q" . ,query) ("type" . "hashtags"))) (response (mastodon-http--get-json url params :silent)) (tags (alist-get 'hashtags response))) @@ -100,10 +101,9 @@ QUERY is the string to search." "Display a list of tags trending on your instance. TYPE is a string, either tags, statuses, or links. PRINT-FUN is the function used to print the data from the response." - (let* ((url (mastodon-http--api - (format "trends/%s" type))) + (let* ((url (mastodon-http--api (format "trends/%s" type))) ;; max for statuses = 40, for others = 20 - (limit (if (equal type "statuses") + (limit (if (string= type "statuses") '("limit" . "40") '("limit" . "20"))) (offset '(("offset" . "0"))) @@ -113,11 +113,10 @@ PRINT-FUN is the function used to print the data from the response." (with-mastodon-buffer buffer #'mastodon-mode nil (mastodon-tl--set-buffer-spec (buffer-name buffer) (format "trends/%s" type) - print-fun nil - params) + print-fun nil params) (mastodon-search--insert-heading "trending" type) (funcall print-fun data) - (unless (equal type "statuses") + (unless (string= type "statuses") (goto-char (point-min)))))) ;; functions for mastodon search @@ -134,16 +133,15 @@ Optionally add string TYPE after HEADING." (mastodon-tl--set-face (concat "\n " mastodon-tl--horiz-bar "\n " (upcase str) " " - (if type (upcase type) "") "\n" + (when type (upcase type)) "\n" " " mastodon-tl--horiz-bar (unless no-newline "\n")) 'success)) (defvar mastodon-search-types '("statuses" "accounts" "hashtags")) -(defun mastodon-search--query (query - &optional type limit - following account-id offset) +(defun mastodon-search--query (query &optional type limit + following account-id offset) "Prompt for a search QUERY and return accounts, statuses, and hashtags. TYPE is a member of `mastodon-search-types'. LIMIT is a number as string, up to 40, with 40 the default. @@ -154,16 +152,14 @@ OFFSET is a number as string, means to skip that many results. It is used for pagination." ;; TODO: handle no results (interactive "sSearch mastodon for: ") - (let* ((url (mastodon-http--api-search)) - (following (when (or following - (equal current-prefix-arg '(4))) + (let* ((url (mastodon-http--api-v2 "search")) + (following (when (or following (eq current-prefix-arg '(4))) "true")) (type (or type - (if (equal current-prefix-arg '(4)) + (if (eq current-prefix-arg '(4)) "accounts" ; if FOLLOWING, must be "accounts" (completing-read "Search type: " - mastodon-search-types - nil t)))) + mastodon-search-types nil :match)))) (limit (or limit "40")) (offset (or offset "0")) (buffer (format "*mastodon-search-%s-%s*" type query)) @@ -175,26 +171,20 @@ is used for pagination." ,(when following `("following" . ,following)) ,(when account-id `("account_id" . ,account-id))))) (response (mastodon-http--get-json url params)) - (accts (when (equal type "accounts") - (alist-get 'accounts response))) - (tags (when (equal type "hashtags") - (alist-get 'hashtags response))) - (statuses (when (equal type "statuses") - (alist-get 'statuses response)))) + (items (alist-get (intern type) response))) (with-mastodon-buffer buffer #'mastodon-mode nil (mastodon-search-mode) (mastodon-search--insert-heading type) - ;; user results: - (cond ((equal type "accounts") - (mastodon-search--render-response accts type buffer params + (cond ((string= type "accounts") + (mastodon-search--render-response items type buffer params 'mastodon-views--insert-users-propertized-note 'mastodon-views--insert-users-propertized-note)) - ((equal type "hashtags") - (mastodon-search--render-response tags type buffer params + ((string= type "hashtags") + (mastodon-search--render-response items type buffer params 'mastodon-search--print-tags 'mastodon-search--print-tags)) - ((equal type "statuses") - (mastodon-search--render-response statuses type buffer params + ((string= type "statuses") + (mastodon-search--render-response items type buffer params #'mastodon-tl--timeline #'mastodon-tl--timeline))) (goto-char (point-min)) @@ -204,7 +194,7 @@ is used for pagination." (defun mastodon-search-insert-no-results (&optional thing) "Insert a no results message for object THING." - (let ((thing (or thing "nothing"))) + (let ((thing (or thing "items"))) (insert (propertize (format "Looks like search returned no %s." thing) 'face 'font-lock-comment-face)))) @@ -216,28 +206,26 @@ BUFFER, PARAMS, and UPDATE-FUN are for `mastodon-tl--buffer-spec'." (if (not data) (mastodon-search-insert-no-results type) (funcall insert-fun data)) - ;; (mapc #'mastodon-tl--toot data)) (mastodon-tl--set-buffer-spec buffer "search" - update-fun - nil params)) + update-fun nil params)) (defun mastodon-search--buf-type () "Return search buffer type, a member of `mastodon-search-types'." ;; called in `mastodon-tl--get-buffer-type' (let* ((spec (mastodon-tl--buffer-property 'update-params))) - (alist-get "type" spec nil nil #'equal))) + (alist-get "type" spec nil nil #'string=))) (defun mastodon-search--query-cycle () "Cycle through search types: accounts, hashtags, and statuses." (interactive) (let* ((spec (mastodon-tl--buffer-property 'update-params)) - (type (alist-get "type" spec nil nil #'equal)) - (query (alist-get "q" spec nil nil #'equal))) - (cond ((equal type "hashtags") + (type (alist-get "type" spec nil nil #'string=)) + (query (alist-get "q" spec nil nil #'string=))) + (cond ((string= type "hashtags") (mastodon-search--query query "accounts")) - ((equal type "accounts") + ((string= type "accounts") (mastodon-search--query query "statuses")) - ((equal type "statuses") + ((string= type "statuses") (mastodon-search--query query "hashtags"))))) (defun mastodon-search--query-accounts-followed (query) @@ -277,9 +265,8 @@ If NOTE is non-nil, include user's profile note. This is also 'mastodon-handle (concat "@" (cadr user)) 'help-echo (concat "Browse user profile of @" (cadr user))) " : \n" - (if note - (mastodon-tl--render-text (cadddr user) acct) - "") + (when note + (mastodon-tl--render-text (cadddr user) acct)) "\n") 'item-json acct))) ; for compat w other processing functions @@ -319,26 +306,29 @@ If NOTE is non-nil, include user's profile note. This is also (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--id-from-status (status) - "Fetch the id from a STATUS returned by a search call to the server. -We use this to fetch the complete status from the server." - (alist-get 'id status)) - -(defun mastodon-search--full-status-from-id (id) - "Fetch the full status with id ID from the server. -This allows us to access the full account etc. details and to -render them properly." - (let* ((url (concat mastodon-instance-url "/api/v1/statuses/" (mastodon-tl--as-string id))) - (json (mastodon-http--get-json url))) - json)) - +;; These functions are all unused! + +;; (defun mastodon-search--get-status-info (status) +;; "Get ID, timestamp, content, and spoiler from STATUS." +;; (list (alist-get 'id status) +;; (alist-get 'created_at status) +;; (alist-get 'spoiler_text status) +;; (alist-get 'content status))) + +;; (defun mastodon-search--id-from-status (status) +;; "Fetch the id from a STATUS returned by a search call to the server. +;; We use this to fetch the complete status from the server." +;; (alist-get 'id status)) + +;; (defun mastodon-search--full-status-from-id (id) +;; "Fetch the full status with id ID from the server. +;; This allows us to access the full account etc. details and to +;; render them properly." +;; (let* ((url (mastodon-http--api (format "statuses/%s" id))) +;; ;; (concat mastodon-instance-url "/api/v1/statuses/" +;; ;; (mastodon-tl--as-string id))) +;; (json (mastodon-http--get-json url))) +;; json)) (defvar mastodon-search-mode-map (let ((map (make-sparse-keymap))) @@ -355,6 +345,5 @@ This minor mode is used for mastodon search pages to adds a keybinding." :group 'mastodon :global nil) - (provide 'mastodon-search) ;;; mastodon-search.el ends here diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index 49f5beb..3384a2a 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -83,7 +83,6 @@ (autoload 'mastodon-toot--set-toot-properties "mastodon-toot") (autoload 'mastodon-toot--update-status-fields "mastodon-toot") (autoload 'mastodon-search--buf-type "mastodon-search") -(autoload 'mastodon-http--api-search "mastodon-http") (autoload 'mastodon-views--insert-users-propertized-note "mastodon-views") ; for search pagination (autoload 'mastodon-http--get-response "mastodon-http") (autoload 'mastodon-search--insert-heading "mastodon-search") @@ -91,6 +90,8 @@ (autoload 'mastodon-search--trending-statuses "mastodon-search") (autoload 'mastodon-search--format-heading "mastodon-search") (autoload 'mastodon-toot--with-toot-item "mastodon-toot") +(autoload 'mastodon-media--image-or-cached "mastodon-media") +(autoload 'mastodon-toot--base-toot-or-item-json "mastodon-toot") (defvar mastodon-toot--visibility) (defvar mastodon-toot-mode) @@ -98,13 +99,13 @@ (when (require 'mpv nil :no-error) (declare-function mpv-start "mpv")) +(defvar mastodon-mode-map) (defvar mastodon-instance-url) (defvar mastodon-toot-timestamp-format) (defvar shr-use-fonts) ;; declare it since Emacs24 didn't have this (defvar mastodon-media--enable-image-caching) (defvar mastodon-media--generic-broken-image-data) - -(defvar mastodon-mode-map) +(defvar mastodon-media--sensitive-image-data) ;;; CUSTOMIZES @@ -221,7 +222,6 @@ respects the user's `browse-url' settings." See `mastodon-tl--get-remote-local-timeline' for view remote local domains." :type '(repeat string)) - (defcustom mastodon-tl--fold-toots-at-length 1200 "Length, in characters, to fold a toot at. Longer toots will be folded and the remainder replaced by a @@ -294,7 +294,7 @@ types of mastodon links and not just shr.el-generated ones.") (define-key map [remap shr-previous-link] #'mastodon-tl--previous-tab-item) ;; browse-url loads the preview only, we want browse-image ;; on RET to browse full sized image URL - (define-key map [remap shr-browse-url] #'mastodon-tl--view-full-image-or-play-video) ;#'shr-browse-image) + (define-key map [remap shr-browse-url] #'mastodon-tl--view-full-image-or-play-video) ;; remove shr's u binding, as it the maybe-probe-and-copy-url ;; is already bound to w also (define-key map (kbd "u") #'mastodon-tl--update) @@ -314,6 +314,7 @@ types of mastodon links and not just shr.el-generated ones.") (let ((map (make-sparse-keymap))) (define-key map (kbd "<C-return>") #'mastodon-tl--mpv-play-video-from-byline) (define-key map (kbd "RET") #'mastodon-profile--get-toot-author) + (define-key map (kbd "S") #'mastodon-tl--toggle-sensitive-image) map)) "The keymap to be set for the author byline. It is active where point is placed by `mastodon-tl--goto-next-item.'") @@ -344,7 +345,7 @@ than `pop-to-buffer'." (declare (debug t)) `(if (and (not (mastodon-tl--profile-buffer-p)) (not (mastodon-tl--property 'item-json))) ; includes users but not tags - (message "Looks like there's no item at point?") + (user-error "Looks like there's no item at point?") ,@body)) @@ -354,7 +355,7 @@ than `pop-to-buffer'." "Call `scroll-up-command', loading more toots if necessary. If we hit `point-max', call `mastodon-tl--more' then `scroll-up-command'." (interactive) - (if (not (equal (point) (point-max))) + (if (not (eq (point) (point-max))) (scroll-up-command) (mastodon-tl--more) (scroll-up-command))) @@ -362,7 +363,7 @@ If we hit `point-max', call `mastodon-tl--more' then `scroll-up-command'." (defun mastodon-tl--next-tab-item (&optional previous) "Move to the next interesting item. This could be the next toot, link, or image; whichever comes first. -Don't move if nothing else to move to is found, i.e. near the end of the buffer. +Don't move if nothing to move to is found, i.e. near the end of the buffer. This also skips tab items in invisible text, i.e. hidden spoiler text. PREVIOUS means move to previous item." (interactive) @@ -378,7 +379,7 @@ PREVIOUS means move to previous item." ;; do nothing, all the action is in the while condition ) (if (null next-range) - (message "Nothing else here.") + (user-error "Nothing else here") (goto-char (car next-range)) (message "%s" (mastodon-tl--property 'help-echo :no-move))))) @@ -401,21 +402,16 @@ Optionally start from POS." ;; FIXME: we need to fix item-type? ;; 'item-type ; breaks nav to last item in a view? 'byline - (current-buffer)))) + (current-buffer))) + (max-lisp-eval-depth 4)) ;; clamp down on endless loops (if npos - (if (not - (get-text-property npos 'item-type)) ; generic + (if (not (get-text-property npos 'item-type)) ; generic ;; FIXME let's make refresh &optional and only call refresh/recur ;; if non-nil: (mastodon-tl--goto-item-pos find-pos refresh npos) (goto-char npos) ;; force display of help-echo on moving to a toot byline: (mastodon-tl--message-help-echo)) - ;; FIXME: doesn't work, the funcall doesn't return if in an endless - ;; refresh loop. - ;; either let-bind `max-lisp-eval-depth' and try to error handle when it - ;; errors, or else set up a counter, and error when it gets to high - ;; (like >2 would already be too much) (condition-case nil (funcall refresh) (error "No more items"))))) @@ -426,26 +422,28 @@ Load more items it no next item. NO-REFRESH means do no not try to load more items if no next item found." (interactive) - (mastodon-tl--goto-item-pos 'next-single-property-change - (unless no-refresh 'mastodon-tl--more))) + (condition-case nil + (mastodon-tl--goto-item-pos 'next-single-property-change + (unless no-refresh 'mastodon-tl--more)) + (t (error "No more items")))) (defun mastodon-tl--goto-prev-item () "Jump to previous item. Update if no previous items" (interactive) - (mastodon-tl--goto-item-pos 'previous-single-property-change - 'mastodon-tl--update)) + (condition-case nil + (mastodon-tl--goto-item-pos 'previous-single-property-change + 'mastodon-tl--update) + (t (error "No more items")))) (defun mastodon-tl--goto-first-item () "Jump to first toot or item in buffer. Used on initializing a timeline or thread." - ;; goto-next-item assumes we already have items, and is therefore - ;; incompatible with any view where it is possible to have no items. - ;; when that is the case the call to goto-toot-pos loops infinitely (goto-char (point-min)) - (mastodon-tl--goto-item-pos 'next-single-property-change - 'next-line)) -;; (mastodon-tl--goto-next-item)) + (condition-case nil + (mastodon-tl--goto-item-pos 'next-single-property-change + 'next-line) + (t (error "No item")))) ;;; TIMELINES @@ -456,15 +454,16 @@ If LOCAL, get only local timeline. With a single PREFIX arg, hide-replies. With a double PREFIX arg, only show posts with media." (interactive "p") - (let ((params `(("limit" . ,mastodon-tl--timeline-posts-count)))) - ;; avoid adding 'nil' to our params alist: - (when (eq prefix 16) - (push '("only_media" . "true") params)) - (when local - (push '("local" . "true") params)) - (when max-id - (push `("max_id" . ,(mastodon-tl--buffer-property 'max-id)) - params)) + (let ((params + (cl-remove + nil + `(("limit" . ,mastodon-tl--timeline-posts-count) + ,(when (eq prefix 16) + '("only_media" . "true")) + ,(when local + '("local" . "true")) + ,(when max-id + `("max_id" . ,(mastodon-tl--buffer-property 'max-id))))))) (message "Loading federated timeline...") (mastodon-tl--init (if local "local" "federated") "timelines/public" 'mastodon-tl--timeline nil @@ -485,7 +484,7 @@ MAX-ID is a flag to add the max_id pagination parameter." params (when (eq arg 4) t)))) -(defun mastodon-tl--get-remote-local-timeline () +(defun mastodon-tl--get-remote-local-timeline (&optional endpoint) "Prompt for an instance domain and try to display its local timeline. You can enter any working instance domain. Domains that you want to regularly load can be stored in @@ -494,7 +493,8 @@ Note that some instances do not make their local timelines public, in which case this will not work. To interact with any item, you must view it from your own instance, which you can do with -`mastodon-tl--view-item-on-own-instance'." +`mastodon-tl--view-item-on-own-instance'. +Optionally, provide API ENDPOINT." (interactive) (let* ((domain (completing-read "Domain for remote local tl: " mastodon-tl--remote-local-domains)) @@ -510,9 +510,17 @@ instance, which you can do with (y-or-n-p "Domain appears unknown to your instance. Proceed?")) (mastodon-tl--init buf - "timelines/public" 'mastodon-tl--timeline nil + (or endpoint "timelines/public") + 'mastodon-tl--timeline nil params nil domain)))) +(defun mastodon-tl--remote-tag-timeline (&optional tag) + "Call `mastodon-tl--get-remote-local-timeline' but for a TAG timeline." + (interactive) + (let* ((tag (or tag (read-string "Tag: "))) + (endpoint (format "timelines/tag/%s" tag))) + (mastodon-tl--get-remote-local-timeline endpoint))) + (defun mastodon-tl--view-item-on-own-instance () "Load current toot on your own instance. Use this to re-load remote-local items in order to interact with them." @@ -549,12 +557,14 @@ With a double PREFIX arg, limit results to your own instance." If TAG is a list, show a timeline for all tags. With a single PREFIX arg, only show posts with media. With a double PREFIX arg, limit results to your own instance." - (let ((params `(("limit" . ,mastodon-tl--timeline-posts-count)))) - ;; avoid adding 'nil' to our params alist: - (when (eq prefix 4) - (push '("only_media" . "true") params)) - (when (eq prefix 16) - (push '("local" . "true") params)) + (let ((params + (cl-remove + nil + `(("limit" . ,mastodon-tl--timeline-posts-count) + ,(when (eq prefix 4) + '("only_media" . "true")) + ,(when (eq prefix 16) + '("local" . "true")))))) (when (listp tag) (let ((list (mastodon-http--build-array-params-alist "any[]" (cdr tag)))) (while list @@ -562,9 +572,7 @@ With a double PREFIX arg, limit results to your own instance." (mastodon-tl--init (if (listp tag) "tags-multiple" (concat "tag-" tag)) (concat "timelines/tag/" (if (listp tag) (car tag) tag)) ; must be /tag/:sth - 'mastodon-tl--timeline - nil - params))) + 'mastodon-tl--timeline nil params))) ;;; BYLINES, etc. @@ -575,7 +583,7 @@ Do so if type of status at poins is not follow_request/follow." (let ((type (alist-get 'type (mastodon-tl--property 'item-json :no-move))) (echo (mastodon-tl--property 'help-echo :no-move))) - (when (not (equal "" echo)) ; not for followers/following in profile + (when (not (string= "" echo)) ; not for followers/following in profile (unless (or (string= type "follow_request") (string= type "follow")) ; no counts for these (message "%s" echo))))) @@ -591,9 +599,7 @@ When DOMAIN, force inclusion of user's domain in their handle." (when (and avatar ; used by `mastodon-profile--format-user' mastodon-tl--show-avatars mastodon-tl--display-media-p - (if (version< emacs-version "27.1") - (image-type-available-p 'imagemagick) - (image-transforms-p))) + (mastodon-tl--image-trans-check)) (mastodon-media--get-avatar-rendering .account.avatar)) ;; username: (propertize (if (not (string-empty-p .account.display_name)) @@ -614,11 +620,10 @@ When DOMAIN, force inclusion of user's domain in their handle." ;; handle: " (" (propertize (concat "@" .account.acct - (if domain - (concat "@" - (url-host - (url-generic-parse-url .account.url))) - "")) + (when domain + (concat "@" + (url-host + (url-generic-parse-url .account.url))))) 'face 'mastodon-handle-face 'mouse-face 'highlight 'mastodon-tab-stop 'user-handle @@ -646,8 +651,9 @@ Used when point is at the start of a byline, i.e. where toot) (alist-get 'reblog toot) ; boosts toot)) ; everything else - (fol-req-p (or (string= (alist-get 'type toot-to-count) "follow") - (string= (alist-get 'type toot-to-count) "follow_request")))) + (fol-req-p (let ((type (alist-get 'type toot-to-count))) + (or (string= type "follow") + (string= type "follow_request"))))) (unless fol-req-p (let* ((media-types (mastodon-tl--get-media-types toot)) (format-media (when media-types @@ -656,8 +662,8 @@ Used when point is at the start of a byline, i.e. where (format-media-binding (when (and (or (member "video" media-types) (member "gifv" media-types)) (require 'mpv nil :no-error)) - (format " | C-RET to view with mpv")))) - (format "%s" (concat format-media format-media-binding)))))) + " | C-RET to view with mpv"))) + (concat format-media format-media-binding))))) (defun mastodon-tl--get-media-types (toot) "Return a list of the media attachment types of the TOOT at point." @@ -667,12 +673,12 @@ Used when point is at the start of a byline, i.e. where (defun mastodon-tl--get-attachments-for-byline (toot) "Return a list of attachment URLs and types for TOOT. The result is added as an attachments property to author-byline." - (let ((media-attachments (mastodon-tl--field 'media_attachments toot))) + (let ((media (mastodon-tl--field 'media_attachments toot))) (mapcar (lambda (attachment) (let-alist attachment (list :url (or .remote_url .url) ; fallback for notifications :type .type))) - media-attachments))) + media))) (defun mastodon-tl--byline-boosted (toot) "Add byline for boosted data from TOOT." @@ -685,11 +691,11 @@ The result is added as an attachments property to author-byline." (defun mastodon-tl--format-faved-or-boosted-byline (letter) "Format the byline marker for a boosted or favourited status. LETTER is a string, F for favourited, B for boosted, or K for bookmarked." - (let ((help-string (cond ((equal letter "F") + (let ((help-string (cond ((string= letter "F") "favourited") - ((equal letter "B") + ((string= letter "B") "boosted") - ((equal letter (or "🔖" "K")) + ((string= letter (or "🔖" "K")) "bookmarked")))) (format "(%s) " (propertize letter 'face 'mastodon-boost-fave-face @@ -697,7 +703,14 @@ LETTER is a string, F for favourited, B for boosted, or K for bookmarked." 'help-echo (format "You have %s this status." help-string))))) -(defun mastodon-tl--byline (toot author-byline action-byline &optional detailed-p domain) +(defun mastodon-tl--image-trans-check () + "Call `image-transforms-p', or `image-type-available-p' imagemagick." + (if (version< emacs-version "27.1") + (image-type-available-p 'imagemagick) + (image-transforms-p))) + +(defun mastodon-tl--byline (toot author-byline action-byline + &optional detailed-p domain base-toot) "Generate byline for TOOT. AUTHOR-BYLINE is a function for adding the author portion of the byline that takes one variable. @@ -706,7 +719,8 @@ favouriting and following to the byline. It also takes a single function. By default it is `mastodon-tl--byline-boosted'. DETAILED-P means display more detailed info. For now this just means displaying toot client. -When DOMAIN, force inclusion of user's domain in their handle." +When DOMAIN, force inclusion of user's domain in their handle. +BASE-TOOT is JSON for the base toot, if any." (let* ((created-time ;; bosts and faves in notifs view ;; (makes timestamps be for the original toot not the boost/fave): @@ -716,14 +730,16 @@ When DOMAIN, force inclusion of user's domain in their handle." ;; (mastodon-tl--field auto fetches from reblogs if needed): (mastodon-tl--field 'created_at toot))) (parsed-time (date-to-time created-time)) - (faved (equal 't (mastodon-tl--field 'favourited toot))) - (boosted (equal 't (mastodon-tl--field 'reblogged toot))) - (bookmarked (equal 't (mastodon-tl--field 'bookmarked toot))) + (faved (eq t (mastodon-tl--field 'favourited toot))) + (boosted (eq t (mastodon-tl--field 'reblogged toot))) + (bookmarked (eq t (mastodon-tl--field 'bookmarked toot))) (visibility (mastodon-tl--field 'visibility toot)) (account (alist-get 'account toot)) (avatar-url (alist-get 'avatar account)) (type (alist-get 'type toot)) - (edited-time (alist-get 'edited_at toot)) + (base-toot-maybe (or base-toot ;; show edits for notifs + (mastodon-tl--toot-or-base toot))) ;; for boosts + (edited-time (alist-get 'edited_at base-toot-maybe)) (edited-parsed (when edited-time (date-to-time edited-time)))) (concat ;; Boosted/favourited markers are not technically part of the byline, so @@ -746,9 +762,7 @@ When DOMAIN, force inclusion of user's domain in their handle." ;; with `mastodon-tl--goto-next-item': (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-tl--image-trans-check)) (mastodon-media--get-avatar-rendering avatar-url)) (propertize (concat @@ -756,20 +770,23 @@ When DOMAIN, force inclusion of user's domain in their handle." ;; in `mastodon-tl--byline-author' (funcall author-byline toot nil domain) ;; visibility: - (cond ((equal visibility "direct") + (cond ((string= visibility "direct") (propertize (concat " " (mastodon-tl--symbol 'direct)) 'help-echo visibility)) - ((equal visibility "private") + ((string= visibility "private") (propertize (concat " " (mastodon-tl--symbol 'private)) 'help-echo visibility))) + ;;action byline: (funcall action-byline toot) " " + ;; timestamp: (propertize (format-time-string mastodon-toot-timestamp-format parsed-time) 'timestamp parsed-time 'display (if mastodon-tl--enable-relative-timestamps (mastodon-tl--relative-time-description parsed-time) parsed-time)) + ;; detailed: (when detailed-p (let* ((app (alist-get 'application toot)) (app-name (alist-get 'name app)) @@ -785,33 +802,34 @@ When DOMAIN, force inclusion of user's domain in their handle." 'shr-url app-url 'help-echo app-url 'keymap mastodon-tl--shr-map-replacement))))) - (if edited-time - (concat - " " - (mastodon-tl--symbol 'edited) - " " - (propertize - (format-time-string mastodon-toot-timestamp-format - edited-parsed) - 'face 'font-lock-comment-face - 'timestamp edited-parsed - 'display (if mastodon-tl--enable-relative-timestamps - (mastodon-tl--relative-time-description edited-parsed) - edited-parsed))) - "") + ;; edited: + (when edited-time + (concat + " " + (mastodon-tl--symbol 'edited) + " " + (propertize + (format-time-string mastodon-toot-timestamp-format + edited-parsed) + 'face 'font-lock-comment-face + 'timestamp edited-parsed + 'display (if mastodon-tl--enable-relative-timestamps + (mastodon-tl--relative-time-description edited-parsed) + edited-parsed)))) (propertize (concat "\n " mastodon-tl--horiz-bar) 'face 'default) - (if (and mastodon-tl--show-stats - (not (member type '("follow" "follow_request")))) - (mastodon-tl--toot-stats toot) - "") + ;; stats: + (when (and mastodon-tl--show-stats + (not (member type '("follow" "follow_request")))) + (mastodon-tl--toot-stats toot)) "\n") 'favourited-p faved 'boosted-p boosted 'bookmarked-p bookmarked 'edited edited-time 'edit-history (when edited-time - (mastodon-toot--get-toot-edits (alist-get 'id toot))) + (mastodon-toot--get-toot-edits + (alist-get 'id base-toot-maybe))) 'byline t)))) @@ -828,7 +846,8 @@ TIMESTAMP is assumed to be in the past." (let* ((time-difference (time-subtract current-time timestamp)) (seconds-difference (float-time time-difference)) (tmp (mastodon-tl--human-duration (max 0 seconds-difference)))) - (cons (concat (car tmp) " ago") + ;; revert to old just now style for < 1 min + (cons (concat (car tmp) (if (string= "just now" (car tmp)) "" " ago")) (time-add current-time (cdr tmp))))) (defun mastodon-tl--relative-time-description (timestamp &optional current-time) @@ -882,23 +901,19 @@ START and END are the boundaries of the link in the toot." (url-host toot-url)) mastodon-instance-url)) (link-str (buffer-substring-no-properties start end)) - (maybe-hashtag (mastodon-tl--extract-hashtag-from-url + (maybe-hashtag (mastodon-tl--hashtag-from-url url toot-instance-url)) (maybe-userhandle (if (proper-list-p toot) ; fails for profile buffers? (or (mastodon-tl--userhandle-from-mentions toot link-str) - ;; FIXME: if prev always works, cut this: - (mastodon-tl--extract-userhandle-from-url url link-str)) - (mastodon-tl--extract-userhandle-from-url url link-str)))) - (cond (;; Hashtags: - maybe-hashtag + (mastodon-tl--userhandle-from-url url link-str)) + (mastodon-tl--userhandle-from-url url link-str)))) + (cond (maybe-hashtag (setq mastodon-tab-stop-type 'hashtag keymap mastodon-tl--link-keymap help-echo (concat "Browse tag #" maybe-hashtag) extra-properties (list 'mastodon-tag maybe-hashtag))) - (;; User handles: - maybe-userhandle - ;; this fails on mentions in profile notes: + (maybe-userhandle ;; fails on mentions in profile notes: (let ((maybe-userid (when (proper-list-p toot) (mastodon-tl--extract-userid-toot toot link-str)))) @@ -909,8 +924,7 @@ START and END are the boundaries of the link in the toot." (list 'mastodon-handle maybe-userhandle) (when maybe-userid (list 'account-id maybe-userid)))))) - ;; Anything else: - (t ; Leave it as a url handled by shr.el. + (t ;; Anything else (leave it as a url handled by shr.el): (setq keymap (if (eq shr-map (get-text-property start 'keymap)) mastodon-tl--shr-map-replacement mastodon-tl--shr-image-map-replacement) @@ -925,19 +939,18 @@ START and END are the boundaries of the link in the toot." (defun mastodon-tl--userhandle-from-mentions (toot link) "Extract a user handle from mentions in json TOOT. LINK is maybe the `@handle' to search for." - (mastodon-tl--extract-el-from-mentions 'acct toot link)) + (mastodon-tl--el-from-mentions 'acct toot link)) (defun mastodon-tl--extract-userid-toot (toot link) "Extract a user id for an ACCT from mentions in a TOOT. LINK is maybe the `@handle' to search for." - (mastodon-tl--extract-el-from-mentions 'id toot link)) + (mastodon-tl--el-from-mentions 'id toot link)) -(defun mastodon-tl--extract-el-from-mentions (el toot link) +(defun mastodon-tl--el-from-mentions (el toot link) "Extract element EL from TOOT mentions that matches LINK. LINK should be a simple handle string with no domain, i.e. \"@user\". Return nil if no matching element." - ;; Must return nil if nothing found! - (let ((mentions (append (alist-get 'mentions toot) nil))) + (let ((mentions (alist-get 'mentions toot))) (when mentions (let* ((mention (pop mentions)) (name (substring-no-properties link 1 (length link))) ; cull @ @@ -948,37 +961,40 @@ Return nil if no matching element." (setq mention (pop mentions))) return)))) -(defun mastodon-tl--extract-userhandle-from-url (url buffer-text) +(defun mastodon-tl--userhandle-from-url (url buffer-text) "Return the user hande the URL points to or nil if it is not a profile link. BUFFER-TEXT is the text covered by the link with URL, for a user profile this should be of the form <at-sign><user id>, e.g. \"@Gargon\"." (let* ((parsed-url (url-generic-parse-url url)) + (host (url-host parsed-url)) (local-p (string= (url-host (url-generic-parse-url mastodon-instance-url)) - (url-host parsed-url)))) + host)) + (path (url-filename parsed-url))) (when (and (string= "@" (substring buffer-text 0 1)) ;; don't error on domain only url (rare): - (not (string= "" (url-filename parsed-url))) + (not (string= "" path)) (string= (downcase buffer-text) - (downcase (substring (url-filename parsed-url) 1)))) + (downcase (substring path 1)))) (if local-p buffer-text ; no instance suffix for local mention - (concat buffer-text "@" (url-host parsed-url)))))) + (concat buffer-text "@" host))))) -(defun mastodon-tl--extract-hashtag-from-url (url instance-url) +(defun mastodon-tl--hashtag-from-url (url instance-url) "Return the hashtag that URL points to or nil if URL is not a tag link. INSTANCE-URL is the url of the instance for the toot that the link came from (tag links always point to a page on the instance publishing the toot)." - (cond - ;; Mastodon type tag link: - ((string-prefix-p (concat instance-url "/tags/") url) - (substring url (length (concat instance-url "/tags/")))) - ;; Link from some other ostatus site we've encountered: - ((string-prefix-p (concat instance-url "/tag/") url) - (substring url (length (concat instance-url "/tag/")))) - ;; If nothing matches we assume it is not a hashtag link: - (t nil))) + ;; TODO: do we rly need to check it against instance-url? + ;; test suggests we might + (let* ((instance-host (url-host + (url-generic-parse-url instance-url))) + (parsed (url-generic-parse-url url)) + (path (url-filename parsed)) + (split (string-split path "/"))) + (when (and (string= instance-host (url-host parsed)) + (string-prefix-p "/tag" path)) ;; "/tag/" or "/tags/" + (nth 2 split)))) ;;; HYPERLINKS @@ -998,39 +1014,38 @@ LINK-TYPE is the type of link to produce." 'keymap mastodon-tl--link-keymap 'help-echo help-text))) -(defun mastodon-tl--do-link-action-at-point (position) - "Do the action of the link at POSITION. +(defun mastodon-tl--do-link-action-at-point (pos) + "Do the action of the link at POS. Used for hitting RET on a given link." (interactive "d") - (let ((link-type (get-text-property position 'mastodon-tab-stop))) + (let ((link-type (get-text-property pos 'mastodon-tab-stop))) (cond ((eq link-type 'content-warning) - (mastodon-tl--toggle-spoiler-text position)) + (mastodon-tl--toggle-spoiler-text pos)) ((eq link-type 'hashtag) (mastodon-tl--show-tag-timeline - nil (get-text-property position 'mastodon-tag))) + nil (get-text-property pos 'mastodon-tag))) ;; 'account / 'account-id is not set for mentions, only bylines ((eq link-type 'user-handle) - (let ((account-json (get-text-property position 'account)) - (account-id (get-text-property position 'account-id))) + (let ((account-json (get-text-property pos 'account)) + (account-id (get-text-property pos 'account-id))) (cond (account-json - (mastodon-profile--make-author-buffer - account-json)) + (mastodon-profile--make-author-buffer account-json)) (account-id (mastodon-profile--make-author-buffer (mastodon-profile--account-from-id account-id))) (t - (let ((account - (mastodon-profile--search-account-by-handle - (get-text-property position 'mastodon-handle)))) + (let ((account (mastodon-profile--search-account-by-handle + (get-text-property pos 'mastodon-handle)))) ;; never call make-author-buffer on nil account: - (if account - (mastodon-profile--make-author-buffer account) - ;; optional webfinger lookup: - (if (y-or-n-p - "Search for account returned nothing. Perform URL lookup?") - (mastodon-url-lookup (get-text-property position 'shr-url)) - (message "Unable to find account.")))))))) + (cond (account + (mastodon-profile--make-author-buffer account)) + ;; optional webfinger lookup: + ((y-or-n-p + "Search for account returned nothing. Perform URL lookup?") + (mastodon-url-lookup (get-text-property pos 'shr-url))) + (t + (error "Unable to find account")))))))) ((eq link-type 'read-more) (mastodon-tl--unfold-post)) (t @@ -1055,13 +1070,13 @@ content should be hidden." (defun mastodon-tl--toggle-spoiler-text (position) "Toggle the visibility of the spoiler text at/after POSITION." (let ((inhibit-read-only t) - (spoiler-text-region (mastodon-tl--find-property-range - 'mastodon-content-warning-body position nil))) - (if (not spoiler-text-region) - (message "No spoiler text here") - (add-text-properties (car spoiler-text-region) (cdr spoiler-text-region) + (spoiler-region (mastodon-tl--find-property-range + 'mastodon-content-warning-body position nil))) + (if (not spoiler-region) + (user-error "No spoiler text here") + (add-text-properties (car spoiler-region) (cdr spoiler-region) (list 'invisible - (not (get-text-property (car spoiler-text-region) + (not (get-text-property (car spoiler-region) 'invisible))))))) (defun mastodon-tl--toggle-spoiler-text-in-toot () @@ -1076,10 +1091,10 @@ content should be hidden." 'mastodon-content-warning-body (car toot-range))))) (cond ((null toot-range) - (message "No toot here")) + (user-error "No toot here")) ((or (null spoiler-range) (> (car spoiler-range) (cdr toot-range))) - (message "No content warning text here")) + (user-error "No content warning text here")) (t (mastodon-tl--toggle-spoiler-text (car spoiler-range)))))) @@ -1092,17 +1107,13 @@ content should be hidden." (user-error "Not in a thread") (save-excursion (goto-char (point-min)) - (while (not (equal "No more items" ; improve this hack test! - (mastodon-tl--goto-next-item :no-refresh))) + (while (not (string= "No more items" ; improve this hack test! + (mastodon-tl--goto-next-item :no-refresh))) (let* ((json (mastodon-tl--property 'item-json :no-move)) (cw (alist-get 'spoiler_text json))) - (when (not (equal "" cw)) + (when (not (string= "" cw)) (mastodon-tl--toggle-spoiler-text-in-toot)))))))) -(defun mastodon-tl--clean-tabs-and-nl (string) - "Remove tabs and newlines from STRING." - (replace-regexp-in-string "[\t\n ]*\\'" "" string)) - (defun mastodon-tl--spoiler (toot &optional filter) "Render TOOT with spoiler message. This assumes TOOT is a toot with a spoiler message. @@ -1150,36 +1161,38 @@ FILTER is a string to use as a filter warning spoiler instead." ;;; MEDIA (defun mastodon-tl--media (toot) - "Retrieve a media attachment link for TOOT if one exists." - (let* ((media-attachments (mastodon-tl--field 'media_attachments toot)) + "Retrieve a media attachment link for TOOT if one exists. +Else return an empty string." + (let* ((attachments (mastodon-tl--field 'media_attachments toot)) (sensitive (mastodon-tl--field 'sensitive toot)) (media-string (mapconcat (lambda (x) (mastodon-tl--media-attachment x sensitive)) - media-attachments ""))) + attachments ""))) (if (not (and mastodon-tl--display-media-p (string-empty-p media-string))) (concat "\n" media-string) ""))) -(defun mastodon-tl--media-attachment (media-attachment sensitive) - "Return a propertized string for MEDIA-ATTACHMENT. +(defun mastodon-tl--media-attachment (attachment sensitive) + "Return a propertized string for ATTACHMENT. SENSITIVE is a flag from the item's JSON data." - (let-alist media-attachment + (let-alist attachment (let ((display-str - (if (and mastodon-tl--display-caption-not-url-when-no-media - .description) - (concat "Media:: " .description) - (concat "Media:: " .preview_url)))) + (concat "Media:: " + (if (and mastodon-tl--display-caption-not-url-when-no-media + .description) + .description) + .preview_url))) (if mastodon-tl--display-media-p (mastodon-media--get-media-link-rendering ; placeholder: "[img]" - .preview_url (or .remote_url .url) .type .description sensitive) ; 2nd arg for shr-browse-url + .preview_url (or .remote_url .url) ; for shr-browse-url + .type .description sensitive) ;; return URL/caption: (concat (mastodon-tl--propertize-img-str-or-url (concat "Media:: " .preview_url) ; string .preview_url .remote_url .type .description - display-str ; display - 'shr-link .description sensitive) + display-str 'shr-link .description sensitive) "\n"))))) (defun mastodon-tl--propertize-img-str-or-url @@ -1219,20 +1232,10 @@ SENSITIVE is a flag from the item's JSON data." (let* ((url (mastodon-tl--property 'image-url))) (if (not mastodon-tl--load-full-sized-images-in-emacs) (shr-browse-image) - (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-full-sized-image-response nil url)) - ;; else fetch and load: - (url-retrieve url #'mastodon-media--process-full-sized-image-response - `(,url))))))) - -(defvar mastodon-media--sensitive-image-data) + (mastodon-media--image-or-cached + url + #'mastodon-media--process-full-sized-image-response + `(nil ,url)))))) (defun mastodon-tl--toggle-sensitive-image () "Toggle dislay of sensitive image at point." @@ -1242,26 +1245,26 @@ SENSITIVE is a flag from the item's JSON data." (let ((data (mastodon-tl--property 'image-data :no-move)) (inhibit-read-only t) (end (next-single-property-change (point) 'sensitive-state))) - (if (equal 'hidden (mastodon-tl--property 'sensitive-state :no-move)) - ;; display sensitive image: - (add-text-properties (point) end - `(display ,data - sensitive-state showing)) - ;; hide sensitive image: - (add-text-properties (point) end - `( sensitive-state hidden - display - ,(create-image - mastodon-media--sensitive-image-data nil t))))))) + (add-text-properties + (point) end + (if (eq 'hidden (mastodon-tl--property 'sensitive-state :no-move)) + ;; display: + `( display ,data + sensitive-state showing) + ;; hide: + `( sensitive-state hidden + display + ,(create-image + mastodon-media--sensitive-image-data nil t))))))) ;; POLLS -(defun mastodon-tl--format-poll-option (option option-counter length) - "Format poll OPTION. OPTION-COUNTER is just a counter. +(defun mastodon-tl--format-poll-option (option counter length) + "Format poll OPTION. COUNTER is a counter. LENGTH is of the longest option, for formatting." (format "%s: %s%s%s\n" - option-counter + counter (propertize (alist-get 'title option) 'face 'success) (make-string (1+ (- length @@ -1274,26 +1277,24 @@ LENGTH is of the longest option, for formatting." (defun mastodon-tl--format-poll (poll) "From json poll data POLL, return a display string." (let-alist poll - (let* ((option-titles (mastodon-tl--map-alist 'title .options)) - (longest (car (sort (mapcar #'length option-titles) #'>))) - (option-counter 0)) + (let* ((options (mastodon-tl--map-alist 'title .options)) + (longest (car (sort (mapcar #'length options ) #'>))) + (counter 0)) (concat "\nPoll: \n\n" (mapconcat (lambda (option) - (setq option-counter (1+ option-counter)) + (setq counter (1+ counter)) (mastodon-tl--format-poll-option - option option-counter longest)) + option counter longest)) .options "\n") "\n" (propertize (cond (.voters_count ; sometimes it is nil - (if (= .voters_count 1) - (format "%s person | " .voters_count) - (format "%s people | " .voters_count))) + (format "%s %s | " .voters_count + (if (= .voters_count 1) "person" "people"))) (.vote_count (format "%s votes | " .vote_count)) - (t - "")) + (t "")) 'face 'font-lock-comment-face) (let ((str (if (eq .expired :json-false) (if (eq .expires_at nil) @@ -1304,7 +1305,7 @@ LENGTH is of the longest option, for formatting." "\n")))) (defconst mastodon-tl--time-units - '("sec" 60.0 ;Use a float to convert `n' to float. + '("sec" 60.0 ;; Use a float to convert `n' to float. "min" 60 "hour" 24 "day" 7 @@ -1313,8 +1314,9 @@ LENGTH is of the longest option, for formatting." "year")) (defun mastodon-tl--format-poll-expiry (timestamp) - "Convert poll expiry TIMESTAMP into a descriptive string." - ;; FIXME: Could we document the format of TIMESTAMP here? + "Convert poll expiry TIMESTAMP into a descriptive string. +TIMESTAMP is from the expires_at field of a poll's JSON data, and +is in ISO 8601 Datetime format." (let* ((ts (encode-time (parse-time-string timestamp))) (seconds (time-to-seconds (time-subtract ts nil)))) ;; FIXME: Use the `cdr' to update poll expiry times? @@ -1345,8 +1347,10 @@ displayed when the duration is smaller than a minute)." (if n2 (setq n2 (truncate n2))) (cond ((null n2) - (cons (format "%d %s%s" n1 unit1 (if (> n1 1) "s" "")) - (max resolution res1))) + ;; revert to old just now style for < 1 min: + (cons "just now" 60)) + ;; (cons (format "%d %s%s" n1 unit1 (if (> n1 1) "s" "")) + ;; (max resolution res1))) ((< (* res2 n2) resolution) (cons (format "%d %s%s" n1 unit1 (if (> n1 1) "s" "")) (max resolution res2))) @@ -1362,47 +1366,49 @@ displayed when the duration is smaller than a minute)." n2 unit2 (if (> n2 1) "s" "")) (max res2 resolution)))))) +(defun mastodon-tl--format-read-poll-option (options) + "Format poll OPTIONS for `completing-read'. +OPTIONS is an alist." + ;; we display option number and the option title + ;; but also store both as a cons cell as the cdr, as we need it later + (cl-loop for cell in options + collect (cons (format "%s | %s" (car cell) (cdr cell)) + cell))) + (defun mastodon-tl--read-poll-option () "Read a poll option to vote on a poll." (let* ((toot (mastodon-tl--property 'item-json)) - (poll (mastodon-tl--field 'poll toot)) - (options (mastodon-tl--field 'options poll)) - (options-titles (mastodon-tl--map-alist 'title options)) - (options-number-seq (number-sequence 1 (length options))) - (options-numbers (mapcar #'number-to-string 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))) + (poll (mastodon-tl--field 'poll toot))) (if (null poll) (user-error "No poll here") - (list - ;; var "option" = just the cdr, a cons of option number and desc - (cdr (assoc (completing-read "Poll option to vote for: " - candidates - nil t) ; require match - candidates)))))) + (let* ((options (mastodon-tl--field 'options poll)) + (titles (mastodon-tl--map-alist 'title options)) + (number-seq (number-sequence 1 (length options))) + (numbers (mapcar #'number-to-string number-seq)) + (options-alist (cl-mapcar #'cons numbers titles)) + (candidates (mastodon-tl--format-read-poll-option options-alist)) + (choice (completing-read "Poll option to vote for: " + candidates nil :match))) + (list (cdr (assoc choice candidates))))))) (defun mastodon-tl--poll-vote (option) "If there is a poll at point, prompt user for OPTION to vote on it." (interactive (mastodon-tl--read-poll-option)) - (if (null (mastodon-tl--field 'poll (mastodon-tl--property 'item-json))) - (user-error "No poll here") - (let* ((toot (mastodon-tl--property 'item-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))) - (mastodon-http--triage response - (lambda (_) - (message "You voted for option %s: %s!" - (car option) (cdr option))))))) + (let ((toot (mastodon-tl--property 'item-json))) + (if (null (mastodon-tl--field 'poll toot)) + (user-error "No poll here") + (let* ((poll (mastodon-tl--field 'poll toot)) + (id (alist-get 'id poll)) + (url (mastodon-http--api (format "polls/%s/votes" id))) + ;; zero-index our option: + (option-arg (number-to-string + (1- (string-to-number (car option))))) + (arg `(("choices[]" . ,option-arg))) + (response (mastodon-http--post url arg))) + (mastodon-http--triage response + (lambda (_) + (message "You voted for option %s: %s!" + (car option) (cdr option)))))))) ;; VIDEOS / MPV @@ -1427,26 +1433,26 @@ displayed when the duration is smaller than a minute)." (type (plist-get video :type))) (mastodon-tl--mpv-play-video-at-point url type))) -(defun mastodon-tl--view-full-image-or-play-video () +(defun mastodon-tl--view-full-image-or-play-video (_pos) "View full sized version of image at point, or try to play video." - (interactive) + (interactive "d") (if (mastodon-tl--media-video-p) (mastodon-tl--mpv-play-video-at-point) (mastodon-tl--view-full-image))) -(defun mastodon-tl--click-image-or-video (_event) - "Click to play video with `mpv.el'." +(defun mastodon-tl--click-image-or-video (event) + "Click to play video with `mpv.el'. +EVENT is a mouse-click arg." (interactive "e") - (if (mastodon-tl--media-video-p) - (mastodon-tl--mpv-play-video-at-point) - (mastodon-tl--view-full-image))) + (mastodon-tl--view-full-image-or-play-video + (posn-point (event-end event)))) (defun mastodon-tl--media-video-p (&optional type) "T if mastodon-media-type prop is \"gifv\" or \"video\". TYPE is a mastodon media type." (let ((type (or type (mastodon-tl--property 'mastodon-media-type :no-move)))) - (or (equal type "gifv") - (equal type "video")))) + (or (string= type "gifv") + (string= type "video")))) (defun mastodon-tl--mpv-play-video-at-point (&optional url type) "Play the video or gif at point with an mpv process. @@ -1455,20 +1461,15 @@ in which case play first video or gif from current toot." (interactive) (let ((url (or url ; point in byline: (mastodon-tl--property 'image-url :no-move)))) ; point in toot - ;; (type (or type ; in byline - ;; point in toot: - ;; (mastodon-tl--property 'mastodon-media-type :no-move)))) - (if url - (if (mastodon-tl--media-video-p type) - (progn - (message "'q' to kill mpv.") - (condition-case x - (mpv-start "--loop" url) - (void-function - (message "Looks like mpv.el not installed. Error: %s" - (error-message-string x))))) - (message "no moving image here?")) - (message "no moving image here?")))) + (if (or (not url) + (not (mastodon-tl--media-video-p type))) + (user-error "No moving image here?") + (message "'q' to kill mpv.") + (condition-case x + (mpv-start "--loop" url) + (void-function + (message "Looks like mpv.el not installed. Error: %s" + (error-message-string x))))))) (defun mastodon-tl--copy-image-caption () "Copy the caption of the image at point." @@ -1500,8 +1501,7 @@ Runs `mastodon-tl--render-text' and fetches poll or media." (let* ((prev-change (save-excursion (previous-single-property-change (point) 'base-item-id))) - (prev-pos - (when prev-change (1- prev-change)))) + (prev-pos (when prev-change (1- prev-change)))) (when prev-pos (get-text-property prev-pos 'base-item-id)))) @@ -1510,9 +1510,9 @@ Runs `mastodon-tl--render-text' and fetches poll or media." (let ((prev-id (mastodon-tl--prev-item-id))) (string= reply-to-id prev-id))) -(defun mastodon-tl--insert-status (toot body author-byline action-byline - &optional id base-toot detailed-p - thread domain unfolded no-byline) +(defun mastodon-tl--insert-status + (toot body author-byline action-byline &optional id base-toot + detailed-p thread domain unfolded no-byline) "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 @@ -1542,16 +1542,15 @@ NO-BYLINE means just insert toot body, used for folding." (and mastodon-tl--fold-toots-at-length (length> body mastodon-tl--fold-toots-at-length)))) (insert - (propertize + (propertize ;; body + byline: (concat - (propertize + (propertize ;; body only: (concat "\n" ;; relpy symbol (broken): - (if (and after-reply-status-p thread) - (concat (mastodon-tl--symbol 'replied) - "\n") - "") + (when (and after-reply-status-p thread) + (concat (mastodon-tl--symbol 'replied) + "\n")) ;; actual body: (let ((bar (mastodon-tl--symbol 'reply-bar)) (body (if (and toot-foldable (not unfolded)) @@ -1565,10 +1564,9 @@ NO-BYLINE means just insert toot body, used for folding." 'toot-body t) ;; includes newlines etc. for folding ;; byline: "\n" - (if no-byline - "" + (unless no-byline (mastodon-tl--byline toot author-byline action-byline - detailed-p domain))) + detailed-p domain base-toot))) 'item-type 'toot 'item-id (or id ; notification's own id (alist-get 'id toot)) ; toot id @@ -1584,6 +1582,7 @@ NO-BYLINE means just insert toot body, used for folding." 'toot-foldable toot-foldable 'toot-folded (and toot-foldable (not unfolded))) (if no-byline "" "\n")) + ;; media: (when mastodon-tl--display-media-p (mastodon-media--inline-images start-pos (point))))) @@ -1618,6 +1617,8 @@ Returns a member of `mastodon-views--filter-types'." "public") ((mastodon-tl--profile-buffer-p) "profile") + ((eq buf 'list-timeline) + "home") ;; lists are "home" filter (t ;; thread, notifs, home: (symbol-name buf))))) @@ -1691,7 +1692,7 @@ Folding decided by `mastodon-tl--fold-toots-at-length'." (defun mastodon-tl--unfold-post (&optional fold) "Unfold the toot at point if it is folded (read-more). -FOLD means to fold it instead" +FOLD means to fold it instead." (interactive) (let ((at-byline (mastodon-tl--property 'byline :no-move))) (if (save-excursion @@ -1711,16 +1712,13 @@ FOLD means to fold it instead" (point-after-fold (> last-point (+ beg mastodon-tl--fold-toots-at-length)))) ;; save-excursion here useless actually: - ;; FIXME: because point goes to top of item, the screen gets scrolled ;; by insertion (goto-char beg) (delete-region beg end) (delete-char 1) ;; prevent newlines accumulating ;; insert toot body: - (mastodon-tl--toot toot nil nil nil - (not fold) ;; (if fold :folded :unfolded) - :no-byline) + (mastodon-tl--toot toot nil nil nil (not fold) :no-byline) ;; set toot-folded prop on entire toot (not just body): (let ((toot-range ;; post fold action range: (mastodon-tl--find-property-range 'item-json @@ -1730,20 +1728,19 @@ FOLD means to fold it instead" `(toot-folded ,fold))) ;; try to leave point somewhere sane: (cond ((or at-byline - (and fold - point-after-fold)) ;; point was in area now folded - (ignore-errors (forward-line -1)) ;; in case we are btw + (and fold point-after-fold)) ;; point was in area now folded + (ignore-errors (forward-line -1)) ;; in case we are between (mastodon-tl--goto-next-item)) ;; goto byline (t (goto-char last-point) (when point-after-fold ;; point was in READ MORE heading: (beginning-of-line)))) - (message (format "%s" (if fold "Fold" "Unfold"))))))) + (message (format "%s toot" (if fold "Fold" "Unfold"))))))) (defun mastodon-tl--fold-post () "Fold post at point, if it is too long." (interactive) - (mastodon-tl--unfold-post t)) + (mastodon-tl--unfold-post :fold)) (defun mastodon-tl--fold-post-toggle () "Toggle the folding status of the toot at point." @@ -1751,7 +1748,9 @@ FOLD means to fold it instead" (let* ((folded (mastodon-tl--property 'toot-folded :no-move))) (mastodon-tl--unfold-post (not folded)))) -;; from mastodon-alt.el: +;;; TOOT STATS + +;; calqued off mastodon-alt.el: (defun mastodon-tl--toot-for-stats (&optional toot) "Return the TOOT on which we want to extract stats. If no TOOT is given, the one at point is considered." @@ -1780,31 +1779,29 @@ To disable showing the stats, customize (faves (format "%s %s" faves-prop (mastodon-tl--symbol 'favourite))) (boosts (format "%s %s" boosts-prop (mastodon-tl--symbol 'boost))) (replies (format "%s %s" .replies_count (mastodon-tl--symbol 'reply))) - (status (concat - (propertize faves - 'favourited-p (eq 't .favourited) - 'favourites-field t - 'help-echo (format "%s favourites" .favourites_count) - 'face 'font-lock-comment-face) - (propertize " | " 'face 'font-lock-comment-face) - (propertize boosts - 'boosted-p (eq 't .reblogged) - 'boosts-field t - 'help-echo (format "%s boosts" .reblogs_count) - 'face 'font-lock-comment-face) - (propertize " | " 'face 'font-lock-comment-face) - (propertize replies - 'replies-field t - 'replies-count .replies_count - 'help-echo (format "%s replies" .replies_count) - 'face 'font-lock-comment-face))) - (status - (concat - (propertize " " - 'display - `(space :align-to (- right ,(+ (length status) 7)))) - status))) - status))) + (stats (concat + (propertize faves + 'favourited-p (eq t .favourited) + 'favourites-field t + 'help-echo (format "%s favourites" .favourites_count) + 'face 'font-lock-comment-face) + (propertize " | " 'face 'font-lock-comment-face) + (propertize boosts + 'boosted-p (eq t .reblogged) + 'boosts-field t + 'help-echo (format "%s boosts" .reblogs_count) + 'face 'font-lock-comment-face) + (propertize " | " 'face 'font-lock-comment-face) + (propertize replies + 'replies-field t + 'replies-count .replies_count + 'help-echo (format "%s replies" .replies_count) + 'face 'font-lock-comment-face))) + (right-spacing + (propertize " " + 'display + `(space :align-to (- right ,(+ (length stats) 7)))))) + (concat right-spacing stats)))) ;;; BUFFER SPEC @@ -1849,24 +1846,26 @@ If NO-ERROR is non-nil, do not error when property is empty." (defun mastodon-tl--set-buffer-spec (buffer endpoint update-fun - &optional link-header update-params hide-replies max-id) + &optional link-header update-params hide-replies max-id + thread-item-id) "Set `mastodon-tl--buffer-spec' for the current buffer. BUFFER is buffer name, ENDPOINT is buffer's enpoint, UPDATE-FUN is its update function. LINK-HEADER is the http Link header if present. UPDATE-PARAMS is any http parameters needed for the update function. HIDE-REPLIES is a flag indicating if replies are hidden in the current buffer. -MAX-ID is the pagination parameter." +MAX-ID is the pagination parameter. +THREAD-ITEM-ID is the ID of the item in thread that we opened the thread with." (setq mastodon-tl--buffer-spec - `(account ,(cons mastodon-active-user - mastodon-instance-url) - buffer-name ,buffer - endpoint ,endpoint - update-function ,update-fun - link-header ,link-header - update-params ,update-params - hide-replies ,hide-replies - max-id ,max-id))) + `( account ,(cons mastodon-active-user mastodon-instance-url) + buffer-name ,buffer + endpoint ,endpoint + update-function ,update-fun + link-header ,link-header + update-params ,update-params + hide-replies ,hide-replies + max-id ,max-id + thread-item-id ,thread-item-id))) ;;; BUFFERS @@ -1890,7 +1889,7 @@ to be set. It is set for almost all buffers, but you still have to call this function after it is set or use something else." (let ((buffer-name (mastodon-tl--buffer-name nil :no-error))) (cond (mastodon-toot-mode - ;; composing/editing: + ;; composing/editing (no buffer spec): (if (string= "*edit toot*" (buffer-name)) 'edit-toot 'new-toot)) @@ -1944,11 +1943,11 @@ call this function after it is set or use something else." 'preferences) ;; search ((mastodon-tl--search-buffer-p) - (cond ((equal (mastodon-search--buf-type) "accounts") + (cond ((string= "accounts" (mastodon-search--buf-type)) 'search-accounts) - ((equal (mastodon-search--buf-type) "hashtags") + ((string= "hashtags" (mastodon-search--buf-type)) 'search-hashtags) - ((equal (mastodon-search--buf-type) "statuses") + ((string= "statuses" (mastodon-search--buf-type)) 'search-statuses))) ;; trends ((mastodon-tl--endpoint-str-= "trends/statuses") @@ -2013,6 +2012,10 @@ timeline." ;;; UTILITIES +(defun mastodon-tl--clean-tabs-and-nl (string) + "Remove tabs and newlines from STRING." + (replace-regexp-in-string "[\t\n ]*\\'" "" string)) + (defun mastodon-tl--map-alist (key alists &optional testfn) "Return a list of values extracted from ALISTS with KEY. Key is a symbol, as with `alist-get', or else compatible with TESTFN. @@ -2048,6 +2051,12 @@ Return value from boosted content if available." (or (alist-get field (alist-get 'reblog toot)) (alist-get field toot))) +(defun mastodon-tl--field-status (field toot) + "Return FIELD from TOOT. +Return value from status field if available." + (or (alist-get field (alist-get 'status toot)) + (alist-get field toot))) + (defun mastodon-tl--remove-html (toot) "Remove unrendered tags from TOOT." (let* ((t1 (replace-regexp-in-string "<\/p>" "\n\n" toot)) @@ -2086,7 +2095,7 @@ BACKWARD means move backward (up) the timeline." (cond ((numberp numeric) (number-to-string numeric)) ((stringp numeric) numeric) - (t (error "Numeric:%s must be either a string or a number" + (t (error "Numeric: %s must be either a string or a number" numeric)))) (defun mastodon-tl--item-id (json) @@ -2112,7 +2121,7 @@ ID is that of the toot to view." (let* ((buffer (format "*mastodon-toot-%s*" id)) (toot (mastodon-http--get-json (mastodon-http--api (concat "statuses/" id))))) - (if (equal (caar toot) 'error) + (if (eq (caar toot) 'error) (user-error "Error: %s" (cdar toot)) (with-mastodon-buffer buffer #'mastodon-mode nil (mastodon-tl--set-buffer-spec buffer (format "statuses/%s" id) @@ -2141,46 +2150,47 @@ view all branches of a thread." (defun mastodon-tl--thread (&optional thread-id) "Open thread buffer for toot at point or with THREAD-ID." (interactive) - (mastodon-toot--with-toot-item - ;; this function's var must not be id as the above macro binds id and even - ;; if we provide the arg (e.g. url-lookup), the macro definition overrides - ;; it, making the optional arg unusable! - (let* ((id (or thread-id (mastodon-tl--property 'base-item-id :no-move))) - (type (mastodon-tl--field 'type (mastodon-tl--property 'item-json :no-move)))) - (if (or (string= type "follow_request") - (string= type "follow")) ; no can thread these - (user-error "No thread") - (let* ((endpoint (format "statuses/%s/context" id)) - (url (mastodon-http--api endpoint)) - (buffer (format "*mastodon-thread-%s*" id)) - (toot (mastodon-http--get-json ; refetch in case we just faved/boosted: - (mastodon-http--api (concat "statuses/" id)) - nil :silent)) - (context (mastodon-http--get-json url nil :silent))) - (if (equal (caar toot) 'error) - (user-error "Error: %s" (cdar toot)) - (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) - ;; if we have a thread: - (with-mastodon-buffer buffer #'mastodon-mode nil - (let ((marker (make-marker))) - (mastodon-tl--set-buffer-spec buffer endpoint - #'mastodon-tl--thread) - (mastodon-tl--timeline (alist-get 'ancestors context) :thread) - (goto-char (point-max)) - (move-marker marker (point)) - ;; print re-fetched toot: - (mastodon-tl--toot toot :detailed-p :thread) - (mastodon-tl--timeline (alist-get 'descendants context) - :thread) - ;; put point at the toot: - (goto-char (marker-position marker)) - (mastodon-tl--goto-next-item))) - ;; else just print the lone toot: - (mastodon-tl--single-toot id)))))))) + ;; no toot-at-point macro here as we can call this programmatically, eg from + ;; `mastodon-url-lookup' + ;; this function's var must not be id as the above macro binds id and even + ;; if we provide the arg (e.g. url-lookup), the macro definition overrides + ;; it, making the optional arg unusable! + (let* ((id (or thread-id (mastodon-tl--property 'base-item-id :no-move))) + (type (mastodon-tl--field 'type (mastodon-tl--property 'item-json :no-move)))) + (if (or (string= type "follow_request") + (string= type "follow")) ; no can thread these + (user-error "No thread") + (let* ((endpoint (format "statuses/%s/context" id)) + (url (mastodon-http--api endpoint)) + (buffer (format "*mastodon-thread-%s*" id)) + (toot (mastodon-http--get-json ; refetch in case we just faved/boosted: + (mastodon-http--api (concat "statuses/" id)) + nil :silent)) + (context (mastodon-http--get-json url nil :silent))) + (if (eq (caar toot) 'error) + (user-error "Error: %s" (cdar toot)) + (when (member (alist-get 'type toot) '("reblog" "favourite")) + (setq toot (alist-get 'status toot))) + (if (not (< 0 (+ (length (alist-get 'ancestors context)) + (length (alist-get 'descendants context))))) + ;; just print the lone toot: + (mastodon-tl--single-toot id) + ;; we have a thread: + (with-mastodon-buffer buffer #'mastodon-mode nil + (let ((marker (make-marker))) + (mastodon-tl--set-buffer-spec buffer endpoint + #'mastodon-tl--thread + nil nil nil nil id) + (mastodon-tl--timeline (alist-get 'ancestors context) :thread) + (goto-char (point-max)) + (move-marker marker (point)) + ;; print re-fetched toot: + (mastodon-tl--toot toot :detailed-p :thread) + (mastodon-tl--timeline (alist-get 'descendants context) + :thread) + ;; put point at the toot: + (goto-char (marker-position marker)) + (mastodon-tl--goto-next-item))))))))) (defun mastodon-tl--mute-thread () "Mute the thread displayed in the current buffer. @@ -2189,36 +2199,39 @@ Note that you can only (un)mute threads you have posted in." (mastodon-tl--mute-or-unmute-thread)) (defun mastodon-tl--unmute-thread () - "Mute the thread displayed in the current buffer. + "Unmute the thread displayed in the current buffer. Note that you can only (un)mute threads you have posted in." (interactive) (mastodon-tl--mute-or-unmute-thread :unmute)) +(defun mastodon-tl--thread-parent-id () + "Return the ID of the top item in a thread." + (save-excursion + (mastodon-tl--goto-first-item) + (mastodon-tl--property 'base-item-id :no-move))) + (defun mastodon-tl--mute-or-unmute-thread (&optional unmute) "Mute a thread. If UNMUTE, unmute it." - (let ((endpoint (mastodon-tl--endpoint)) - (mute-str (if unmute "unmute" "mute"))) + (let ((mute-str (if unmute "unmute" "mute"))) (when (or (mastodon-tl--buffer-type-eq 'thread) (mastodon-tl--buffer-type-eq 'notifications)) (let* ((id + ;; the id for `mastodon-tl--user-in-thread-p' ought to be the + ;; top-level item: (if (mastodon-tl--buffer-type-eq 'notifications) - (get-text-property (point) 'base-item-id) - (save-match-data - (string-match "statuses/\\(?2:[[:digit:]]+\\)/context" - endpoint) - (match-string 2 endpoint)))) + (mastodon-tl--property 'base-item-id :no-move) + (mastodon-tl--thread-parent-id))) (we-posted-p (mastodon-tl--user-in-thread-p id)) (url (mastodon-http--api (format "statuses/%s/%s" id mute-str)))) (if (not we-posted-p) - (message "You can only (un)mute a thread you have posted in.") + (user-error "You can only (un)mute a thread you have posted in") (when (y-or-n-p (format "%s this thread? " (capitalize mute-str))) (let ((response (mastodon-http--post url))) - (mastodon-http--triage response - (lambda (_) - (if unmute - (message "Thread unmuted!") - (message "Thread muted!"))))))))))) + (mastodon-http--triage + response + (lambda (_) + (message (format "Thread %sd!" mute-str))))))))))) (defun mastodon-tl--map-account-id-from-toot (statuses) "Return a list of the account IDs of the author of each toot in STATUSES." @@ -2253,8 +2266,7 @@ LANGS is an array parameters alist of languages to filer user's posts by. REBLOGS is a boolean string like NOTIFY, enabling or disabling display of the user's boosts in your timeline. JSON is a flag arg for `mastodon-http--post'." - (interactive - (list (mastodon-tl--user-handles-get "follow"))) + (interactive (list (mastodon-tl--user-handles-get "follow"))) (mastodon-tl--do-if-item (mastodon-tl--do-user-action-and-response user-handle "follow" nil notify langs reblogs json))) @@ -2262,22 +2274,19 @@ JSON is a flag arg for `mastodon-http--post'." ;; TODO: make this action "enable/disable notifications" (defun mastodon-tl--enable-notify-user-posts (user-handle) "Query for USER-HANDLE and enable notifications when they post." - (interactive - (list (mastodon-tl--user-handles-get "enable"))) + (interactive (list (mastodon-tl--user-handles-get "enable"))) (mastodon-tl--do-if-item (mastodon-tl--follow-user user-handle "true"))) (defun mastodon-tl--disable-notify-user-posts (user-handle) "Query for USER-HANDLE and disable notifications when they post." - (interactive - (list (mastodon-tl--user-handles-get "disable"))) + (interactive (list (mastodon-tl--user-handles-get "disable"))) (mastodon-tl--follow-user user-handle "false")) (defun mastodon-tl--follow-user-disable-boosts (user-handle) "Prompt for a USER-HANDLE, and disable display of boosts in home timeline. If they are also not yet followed, follow them." - (interactive - (list (mastodon-tl--user-handles-get "disable boosts"))) + (interactive (list (mastodon-tl--user-handles-get "disable boosts"))) (mastodon-tl--follow-user user-handle nil nil "false")) (defun mastodon-tl--follow-user-enable-boosts (user-handle) @@ -2285,8 +2294,7 @@ If they are also not yet followed, follow them." If they are also not yet followed, follow them. You only need to call this if you have previously disabled display of boosts." - (interactive - (list (mastodon-tl--user-handles-get "enable boosts"))) + (interactive (list (mastodon-tl--user-handles-get "enable boosts"))) (mastodon-tl--follow-user user-handle nil nil "true")) (defun mastodon-tl--filter-user-user-posts-by-language (user-handle) @@ -2295,11 +2303,10 @@ If they are not already followed, they will be too. To be filtered, a post has to be marked as in the language given. This may mean that you will not see posts that are in your desired language if they are not marked as such (or as anything)." - (interactive - (list (mastodon-tl--user-handles-get "filter by language"))) + (interactive (list (mastodon-tl--user-handles-get "filter by language"))) (let ((langs (mastodon-tl--read-filter-langs))) (mastodon-tl--do-if-item - (if (equal "" (cdar langs)) + (if (string= "" (cdar langs)) (mastodon-tl--unfilter-user-languages user-handle) (mastodon-tl--follow-user user-handle nil langs))))) @@ -2307,8 +2314,7 @@ desired language if they are not marked as such (or as anything)." "Remove any language filters for USER-HANDLE. This means you will receive posts of theirs marked as being in any or no language." - (interactive - (list (mastodon-tl--user-handles-get "filter by language"))) + (interactive (list (mastodon-tl--user-handles-get "filter by language"))) (let ((langs "languages[]")) (mastodon-tl--do-if-item ;; we need "languages[]" as a param, with no "=" and not json-encoded as @@ -2334,45 +2340,39 @@ LANGS is the accumulated array param alist if we re-run recursively." (defun mastodon-tl--unfollow-user (user-handle) "Query for USER-HANDLE from current status and unfollow that user." - (interactive - (list (mastodon-tl--user-handles-get "unfollow"))) + (interactive (list (mastodon-tl--user-handles-get "unfollow"))) (mastodon-tl--do-if-item (mastodon-tl--do-user-action-and-response user-handle "unfollow" t))) (defun mastodon-tl--block-user (user-handle) "Query for USER-HANDLE from current status and block that user." - (interactive - (list (mastodon-tl--user-handles-get "block"))) + (interactive (list (mastodon-tl--user-handles-get "block"))) (mastodon-tl--do-if-item (mastodon-tl--do-user-action-and-response user-handle "block"))) (defun mastodon-tl--unblock-user (user-handle) "Query for USER-HANDLE from list of blocked users and unblock that user." - (interactive - (list (mastodon-tl--get-blocks-or-mutes-list "unblock"))) + (interactive (list (mastodon-tl--get-blocks-or-mutes-list "unblock"))) (if (not user-handle) - (message "Looks like you have no blocks to unblock!") + (user-error "Looks like you have no blocks to unblock!") (mastodon-tl--do-user-action-and-response user-handle "unblock" t))) (defun mastodon-tl--mute-user (user-handle) "Query for USER-HANDLE from current status and mute that user." - (interactive - (list (mastodon-tl--user-handles-get "mute"))) + (interactive (list (mastodon-tl--user-handles-get "mute"))) (mastodon-tl--do-if-item (mastodon-tl--do-user-action-and-response user-handle "mute"))) (defun mastodon-tl--unmute-user (user-handle) "Query for USER-HANDLE from list of muted users and unmute that user." - (interactive - (list (mastodon-tl--get-blocks-or-mutes-list "unmute"))) + (interactive (list (mastodon-tl--get-blocks-or-mutes-list "unmute"))) (if (not user-handle) - (message "Looks like you have no mutes to unmute!") + (user-error "Looks like you have no mutes to unmute!") (mastodon-tl--do-user-action-and-response user-handle "unmute" t))) (defun mastodon-tl--dm-user (user-handle) "Query for USER-HANDLE from current status and compose a message to that user." - (interactive - (list (mastodon-tl--user-handles-get "message"))) + (interactive (list (mastodon-tl--user-handles-get "message"))) (mastodon-tl--do-if-item (mastodon-toot--compose-buffer (concat "@" user-handle)) (setq mastodon-toot--visibility "direct") @@ -2405,8 +2405,8 @@ LANGS is the accumulated array param alist if we re-run recursively." (if (eq 1 (length user-handles)) (car user-handles) (completing-read (cond ((or ; TODO: make this "enable/disable notifications" - (equal action "disable") - (equal action "enable")) + (string= action "disable") + (string= action "enable")) (format "%s notifications when user posts: " action)) ((string-suffix-p "boosts" action) (format "%s by user: " action)) @@ -2419,16 +2419,16 @@ LANGS is the accumulated array param alist if we re-run recursively." (defun mastodon-tl--get-blocks-or-mutes-list (action) "Fetch the list of accounts for ACTION from the server. Action must be either \"unblock\" or \"unmute\"." - (let* ((endpoint (cond ((equal action "unblock") + (let* ((endpoint (cond ((string= action "unblock") "blocks") - ((equal action "unmute") + ((string= action "unmute") "mutes"))) (url (mastodon-http--api endpoint)) (json (mastodon-http--get-json url)) (accts (mastodon-tl--map-alist 'acct json))) (when accts (completing-read (format "Handle of user to %s: " action) - accts nil t)))) ; require match + accts nil :match)))) (defun mastodon-tl--do-user-action-and-response (user-handle action &optional negp notify langs reblogs json) @@ -2443,13 +2443,13 @@ display of the user's boosts in your timeline." (let* ((account (if negp ;; unmuting/unblocking, handle from mute/block list (mastodon-profile--search-account-by-handle user-handle) - ;; profile view, use 'profile-json as status: - (if (mastodon-tl--profile-buffer-p) - (mastodon-profile--lookup-account-in-status - user-handle (mastodon-profile--profile-json)) - ;; muting/blocking, select from handles in current status - (mastodon-profile--lookup-account-in-status - user-handle (mastodon-profile--item-json))))) + (mastodon-profile--lookup-account-in-status + user-handle + (if (mastodon-tl--profile-buffer-p) + ;; profile view, use 'profile-json as status: + (mastodon-profile--profile-json) + ;; muting/blocking, select from handles in current status + (mastodon-profile--item-json))))) (user-id (alist-get 'id account)) (name (if (string-empty-p (alist-get 'display_name account)) (alist-get 'username account) @@ -2459,12 +2459,12 @@ display of the user's boosts in your timeline." (reblogs `(("reblogs" . ,reblogs))) (t nil))) (url (mastodon-http--api (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 args reblogs json) - (when (y-or-n-p (format "%s user %s? " action name)) - (mastodon-tl--do-user-action-function url name user-handle action args))) - (message "Cannot find a user with handle %S" user-handle)))) + (if (not account) + (user-error "Cannot find a user with handle %S" user-handle) + (when (or (string= action "follow") ;; y-or-n for all but follow + (y-or-n-p (format "%s user %s? " action name))) + (mastodon-tl--do-user-action-function + url name user-handle action notify args reblogs json))))) (defun mastodon-tl--do-user-action-function (url name user-handle action &optional notify args reblogs json) @@ -2479,33 +2479,33 @@ ARGS is an alist of any parameters to send with the request." (let ((json (with-current-buffer response (mastodon-http--process-json)))) ;; TODO: when > if, with failure msg - (cond ((string-equal notify "true") - (when (equal 't (alist-get 'notifying json)) + (cond ((string= notify "true") + (when (eq t (alist-get 'notifying json)) (message "Receiving notifications for user %s (@%s)!" name user-handle))) - ((string-equal notify "false") - (when (equal :json-false (alist-get 'notifying json)) + ((string= notify "false") + (when (eq :json-false (alist-get 'notifying json)) (message "Not receiving notifications for user %s (@%s)!" name user-handle))) - ((string-equal reblogs "true") - (when (equal 't (alist-get 'showing_reblogs json)) + ((string= reblogs "true") + (when (eq t (alist-get 'showing_reblogs json)) (message "Receiving boosts by user %s (@%s)!" name user-handle))) - ((string-equal reblogs "false") - (when (equal :json-false (alist-get 'showing_reblogs json)) + ((string= reblogs "false") + (when (eq :json-false (alist-get 'showing_reblogs json)) (message "Not receiving boosts by user %s (@%s)!" name user-handle))) - ((or (string-equal action "mute") - (string-equal action "unmute")) + ((or (string= action "mute") + (string= action "unmute")) (message "User %s (@%s) %sd!" name user-handle action)) - ((equal args "languages[]") + ((string= args "languages[]") (message "User %s language filters removed!" name)) - ((assoc "languages[]" args #'equal) + ((assoc "languages[]" args #'string=) (message "User %s filtered by language(s): %s" name (mapconcat #'cdr args " "))) ((and (eq notify nil) (eq reblogs nil)) - (if (and (equal action "follow") + (if (and (string= action "follow") (eq t (alist-get 'requested json))) (message "Follow requested for user %s (@%s)!" name user-handle) (message "User %s (@%s) %sed!" name user-handle action))))))))) @@ -2515,8 +2515,7 @@ ARGS is an alist of any parameters to send with the request." (defun mastodon-tl--get-tags-list () "Return the list of tags of the toot at point." - (let* ((toot (or (mastodon-tl--property 'base-toot :no-move) ; fave/boost notifs - (mastodon-tl--property 'item-json :no-move))) + (let* ((toot (mastodon-toot--base-toot-or-item-json)) (tags (mastodon-tl--field 'tags toot))) (mastodon-tl--map-alist 'name tags))) @@ -2527,8 +2526,9 @@ If TAG provided, follow it." (let* ((tags (unless tag (mastodon-tl--get-tags-list))) (tag-at-point (unless tag - (when (eq 'hashtag (get-text-property (point) 'mastodon-tab-stop)) - (get-text-property (point) 'mastodon-tag)))) + (when (eq 'hashtag + (mastodon-tl--property 'mastodon-tab-stop :no-move)) + (mastodon-tl--property 'mastodon-tag :no-move)))) (tag (or tag (completing-read (format "Tag to follow [%s]: " tag-at-point) tags nil nil nil nil tag-at-point))) @@ -2564,7 +2564,7 @@ PREFIX is sent to `mastodon-tl--get-tag-timeline', which see." (tags (mastodon-tl--map-alist 'name followed-tags-json)) (tag (completing-read "Tag: " tags nil))) (if (null tag) - (message "You have to follow some tags first.") + (user-error "You have to follow some tags first") (mastodon-tl--get-tag-timeline prefix tag)))) (defun mastodon-tl--followed-tags-timeline (&optional prefix) @@ -2618,24 +2618,18 @@ ACCOUNT and TOOT are the data to use." "Build the parameters alist based on user responses. ACCOUNT-ID, COMMENT, ITEM-ID, FORWARD-P, CAT, and RULES are all from `mastodon-tl--report-params', which see." - (let ((params `(("account_id" . ,account-id) - ,(when comment - `("comment" . ,comment)) - ,(when item-id - `("status_ids[]" . ,item-id)) - ,(when forward-p - `("forward" . ,forward-p)) - ,(when cat - `("category" . ,cat))))) - (when rules + (let ((params (cl-remove + nil + `(("account_id" . ,account-id) + ,(when comment `("comment" . ,comment)) + ,(when item-id `("status_ids[]" . ,item-id)) + ,(when forward-p `("forward" . ,forward-p)) + ,(when cat `("category" . ,cat)))))) + (if (not rules) + params (let ((alist (mastodon-http--build-array-params-alist "rule_ids[]" rules))) - (mapc (lambda (x) - (push x params)) - alist))) - ;; FIXME: the above approach adds nils to your params. - (setq params (delete nil params)) - params)) + (append alist params))))) (defun mastodon-tl--report-to-mods () "Report the author of the toot at point to your instance moderators. @@ -2660,10 +2654,7 @@ report the account for spam." (defun mastodon-tl--map-rules-alist (rules) "Convert RULES text and id fields into an alist." - (mapcar (lambda (x) - (let-alist x - (cons .text .id))) - rules)) + (mastodon-tl--map-alist-vals-to-alist 'text 'id rules)) (defun mastodon-tl--read-rules-ids () "Prompt for a list of instance rules and return a list of selected ids." @@ -2674,7 +2665,7 @@ report the account for spam." "rules [TAB for options, | to separate]: " alist nil t))) (mapcar (lambda (x) - (alist-get x alist nil nil #'equal)) + (alist-get x alist nil nil #'string=)) choices))) @@ -2693,10 +2684,11 @@ Then run CALLBACK with arguments CBARGS. PARAMS is used to send any parameters needed to correctly update the current view." (let* ((args `(("max_id" . ,(mastodon-tl--as-string id)))) - (args (if params (push (car args) params) args)) - (url (if (string-suffix-p "search" endpoint) - (mastodon-http--api-search) - (mastodon-http--api endpoint)))) + (args (append args params)) + (url (mastodon-http--api + endpoint + (when (string-suffix-p "search" endpoint) + "v2")))) (apply #'mastodon-http--get-json-async url args callback cbargs))) (defun mastodon-tl--more-json-async-offset (endpoint &optional params @@ -2709,19 +2701,19 @@ PARAMS are the update parameters, see `mastodon-tl--update-params'. These (\"limit\" and \"offset\") must be set in `mastodon-tl--buffer-spec' for pagination to work. Then run CALLBACK with arguments CBARGS." - (let* ((params (or params - (mastodon-tl--update-params))) + (let* ((params (or params (mastodon-tl--update-params))) (limit (string-to-number - (alist-get "limit" params nil nil #'equal))) + (alist-get "limit" params nil nil #'string=))) (offset (number-to-string (+ limit ; limit + old offset = new offset (string-to-number - (alist-get "offset" params nil nil #'equal))))) - (url (if (string-suffix-p "search" endpoint) - (mastodon-http--api-search) - (mastodon-http--api endpoint)))) + (alist-get "offset" params nil nil #'string=))))) + (url (mastodon-http--api + endpoint + (when (string-suffix-p "search" endpoint) + "v2")))) ;; increment: - (setf (alist-get "offset" params nil nil #'equal) offset) + (setf (alist-get "offset" params nil nil #'string=) offset) (apply #'mastodon-http--get-json-async url params callback cbargs))) (defun mastodon-tl--updated-json (endpoint id &optional params) @@ -2729,7 +2721,7 @@ Then run CALLBACK with arguments CBARGS." PARAMS is used to send any parameters needed to correctly update the current view." (let* ((args `(("since_id" . ,(mastodon-tl--as-string id)))) - (args (if params (push (car args) params) args)) + (args (append args params)) (url (mastodon-http--api endpoint))) (mastodon-http--get-json url args))) @@ -2759,10 +2751,9 @@ Aims to respect any pagination in effect." (goto-char (point-min)) (mastodon-profile--get-toot-author max-id))) ((eq type 'thread) - (save-match-data - (let ((endpoint (mastodon-tl--endpoint))) - (string-match "statuses/\\(?2:[[:digit:]]+\\)/context" endpoint) - (mastodon-tl--thread (match-string 2 endpoint)))))) + (let ((id (mastodon-tl--buffer-property + 'thread-item-id (current-buffer) :no-error))) + (mastodon-tl--thread id)))) ;; TODO: sends point to where point was in buffer. This is very rough; we ;; may have removed an item , so the buffer will be smaller, point will ;; end up past where we were, etc. @@ -2803,17 +2794,17 @@ and profile pages when showing followers or accounts followed." ;; "prev" type! (let ((link-header (mastodon-tl--link-header))) (if (> 2 (length link-header)) - (message "No next page") + (user-error "No next page") (let* ((next (car link-header)) ;;(prev (cadr (mastodon-tl--link-header))) (url (mastodon-tl--build-link-header-url next))) - (mastodon-http--get-response-async url nil 'mastodon-tl--more* (current-buffer) - (point) :headers)))) - (cond ( ; no paginate + (mastodon-http--get-response-async + url nil 'mastodon-tl--more* (current-buffer) (point) :headers)))) + (cond (;; no paginate (or (mastodon-tl--buffer-type-eq 'follow-suggestions) (mastodon-tl--buffer-type-eq 'filters) (mastodon-tl--buffer-type-eq 'lists)) - (message "No more results")) + (user-error "No more results")) ;; offset paginate (search, trending, user lists, ...?): ((or (string-prefix-p "*mastodon-trending-" (buffer-name)) (mastodon-tl--search-buffer-p)) @@ -2821,7 +2812,7 @@ and profile pages when showing followers or accounts followed." (mastodon-tl--endpoint) (mastodon-tl--update-params) 'mastodon-tl--more* (current-buffer) (point))) - (t;; max_id paginate (timelines, items with ids/timestamps): + (t ;; max_id paginate (timelines, items with ids/timestamps): (let ((max-id (mastodon-tl--oldest-id))) (mastodon-tl--more-json-async (mastodon-tl--endpoint) @@ -2829,7 +2820,8 @@ and profile pages when showing followers or accounts followed." (mastodon-tl--update-params) 'mastodon-tl--more* (current-buffer) (point) nil max-id)))))) -(defun mastodon-tl--more* (response buffer point-before &optional headers max-id) +(defun mastodon-tl--more* (response buffer point-before + &optional headers max-id) "Append older toots to timeline, asynchronously. Runs the timeline's update function on RESPONSE, in BUFFER. When done, places point at POINT-BEFORE. @@ -2837,24 +2829,26 @@ HEADERS is the http headers returned in the response, if any. MAX-ID is the pagination parameter, a string." (with-current-buffer buffer (if (not response) - (message "No more results") + (user-error "No more results") (let* ((inhibit-read-only t) (json (if headers (car response) response)) ;; FIXME: max-id pagination works for statuses only, not other ;; search results pages: - (json (if (mastodon-tl--search-buffer-p) - (cond ((equal "statuses" (mastodon-search--buf-type)) + (json (if (not (mastodon-tl--search-buffer-p)) + json + (let ((type (mastodon-search--buf-type))) + (cond ((string= "statuses" type) (cdr ; avoid repeat of last status (alist-get 'statuses response))) - ((equal "hashtags" (mastodon-search--buf-type)) + ((string= "hashtags" type) (alist-get 'hashtags response)) - ((equal "accounts" (mastodon-search--buf-type)) - (alist-get 'accounts response))) - json)) + ((string= "accounts" type) + (alist-get 'accounts response)))))) (headers (if headers (cdr response) nil)) - (link-header (mastodon-tl--get-link-header-from-response headers))) + (link-header + (mastodon-tl--get-link-header-from-response headers))) (goto-char (point-max)) - (if (eq (mastodon-tl--get-buffer-type) 'thread) + (if (eq 'thread (mastodon-tl--get-buffer-type)) ;; if thread view, call --thread with parent ID (progn (goto-char (point-min)) (mastodon-tl--goto-next-item) @@ -2862,7 +2856,7 @@ MAX-ID is the pagination parameter, a string." (goto-char point-before) (message "Loaded full thread.")) (if (not json) - (message "No more results.") + (user-error "No more results") (funcall (mastodon-tl--update-function) json) (goto-char point-before) ;; update buffer spec to new link-header or max-id: @@ -2870,8 +2864,7 @@ MAX-ID is the pagination parameter, a string." (mastodon-tl--set-buffer-spec (mastodon-tl--buffer-name) (mastodon-tl--endpoint) (mastodon-tl--update-function) - link-header - nil nil max-id) + link-header nil nil max-id) (message "Loading... done."))))))) (defun mastodon-tl--find-property-range (property start-point @@ -2884,17 +2877,18 @@ before (non-nil) or after (nil)" (if (get-text-property start-point property) ;; We are within a range, so look backwards for the start: (cons (previous-single-property-change - (if (equal start-point (point-max)) start-point (1+ start-point)) + (if (eq start-point (point-max)) start-point (1+ start-point)) property nil (point-min)) (next-single-property-change start-point property nil (point-max))) (if search-backwards (let* ((end (or (previous-single-property-change - (if (equal start-point (point-max)) - start-point (1+ start-point)) + (if (eq start-point (point-max)) + start-point + (1+ start-point)) property) ;; we may either be just before the range or there ;; is nothing at all - (and (not (equal start-point (point-min))) + (and (not (eq start-point (point-min))) (get-text-property (1- start-point) property) start-point))) (start (and end (previous-single-property-change @@ -2915,20 +2909,21 @@ from the value at START-POINT if that is set). Return nil if no such range exists. If SEARCH-BACKWARDS is non-nil it find a region before START-POINT otherwise after START-POINT." - (if (get-text-property start-point property) - ;; We are within a range, we need to start the search from - ;; before/after this range: - (let ((current-range (mastodon-tl--find-property-range property start-point))) - (if search-backwards - (unless (equal (car current-range) (point-min)) - (mastodon-tl--find-property-range - property (1- (car current-range)) search-backwards)) - (unless (equal (cdr current-range) (point-max)) + (if (not (get-text-property start-point property)) + ;; If we are not within a range, we can just defer to + ;; mastodon-tl--find-property-range directly. + (mastodon-tl--find-property-range property start-point search-backwards) + ;; We are within a range, we need to start the search from + ;; before/after this range: + (let ((current-range + (mastodon-tl--find-property-range property start-point))) + (if search-backwards + (unless (eq (car current-range) (point-min)) (mastodon-tl--find-property-range - property (1+ (cdr current-range)) search-backwards)))) - ;; If we are not within a range, we can just defer to - ;; mastodon-tl--find-property-range directly. - (mastodon-tl--find-property-range property start-point search-backwards))) + property (1- (car current-range)) search-backwards)) + (unless (eq (cdr current-range) (point-max)) + (mastodon-tl--find-property-range + property (1+ (cdr current-range)) search-backwards)))))) (defun mastodon-tl--consider-timestamp-for-updates (timestamp) "Take note that TIMESTAMP is used in buffer and ajust timers as needed. @@ -3038,7 +3033,7 @@ This location is defined by a non-nil value of "Update timeline with new toots." (interactive) ;; FIXME: actually these buffers should just reload by calling their own - ;; load function: + ;; load function (actually g is mostly mapped as such): (if (or (mastodon-tl--buffer-type-eq 'trending-statuses) (mastodon-tl--buffer-type-eq 'trending-tags) (mastodon-tl--buffer-type-eq 'follow-suggestions) @@ -3046,33 +3041,35 @@ This location is defined by a non-nil value of (mastodon-tl--buffer-type-eq 'filters) (mastodon-tl--buffer-type-eq 'scheduled-statuses) (mastodon-tl--search-buffer-p)) - (message "update not available in this view.") + (user-error "Update not available in this view") ;; FIXME: handle update for search and trending buffers (let* ((endpoint (mastodon-tl--endpoint)) (update-function (mastodon-tl--update-function))) ;; update a thread, without calling `mastodon-tl--updated-json': (if (mastodon-tl--buffer-type-eq 'thread) - (let ((thread-id (mastodon-tl--property 'item-id))) - (funcall update-function thread-id)) + ;; load whole thread whole thread + (let ((thread-id (mastodon-tl--thread-parent-id))) + (funcall update-function thread-id) + (message "Loaded full thread.")) ;; update other timelines: (let* ((id (mastodon-tl--newest-id)) (params (mastodon-tl--update-params)) (json (mastodon-tl--updated-json endpoint id params))) - (if json - (let ((inhibit-read-only t)) - (mastodon-tl--set-after-update-marker) - (goto-char (or mastodon-tl--update-point (point-min))) - (funcall update-function json) - (when mastodon-tl--after-update-marker - (goto-char mastodon-tl--after-update-marker))) - (message "nothing to update"))))))) + (if (not json) + (user-error "Nothing to update") + (let ((inhibit-read-only t)) + (mastodon-tl--set-after-update-marker) + (goto-char (or mastodon-tl--update-point (point-min))) + (funcall update-function json) + (when mastodon-tl--after-update-marker + (goto-char mastodon-tl--after-update-marker))))))))) ;;; LOADING TIMELINES -(defun mastodon-tl--init (buffer-name endpoint update-function - &optional headers params hide-replies - instance) +(defun mastodon-tl--init + (buffer-name endpoint update-function &optional headers params + hide-replies instance) "Initialize BUFFER-NAME with timeline targeted by ENDPOINT asynchronously. UPDATE-FUNCTION is used to recieve more toots. HEADERS means to also collect the response headers. Used for paginating @@ -3085,16 +3082,16 @@ a timeline from." (concat "https://" instance "/api/v1/" endpoint) (mastodon-http--api endpoint))) (buffer (concat "*mastodon-" buffer-name "*"))) - (if headers - (mastodon-http--get-response-async - url params 'mastodon-tl--init* - buffer endpoint update-function headers params hide-replies) - (mastodon-http--get-json-async - url params 'mastodon-tl--init* - buffer endpoint update-function nil params hide-replies instance)))) - -(defun mastodon-tl--init* (response buffer endpoint update-function - &optional headers update-params hide-replies instance) + (funcall + (if headers + #'mastodon-http--get-response-async + #'mastodon-http--get-json-async) + url params 'mastodon-tl--init* + buffer endpoint update-function headers params hide-replies instance))) + +(defun mastodon-tl--init* + (response buffer endpoint update-function &optional headers + update-params hide-replies instance) "Initialize BUFFER with timeline targeted by ENDPOINT. UPDATE-FUNCTION is used to recieve more toots. RESPONSE is the data returned from the server by @@ -3111,23 +3108,25 @@ JSON and http headers, without it just the JSON." ;; so as a fallback, load trending statuses: ;; FIXME: this could possibly be a fallback for all timelines not ;; just home? - (when (equal endpoint "timelines/home") + (when (string= endpoint "timelines/home") (mastodon-search--trending-statuses))) ((eq (caar json) 'error) (user-error "Looks like the server bugged out: \"%s\"" (cdar json))) (t (let* ((headers (if headers (cdr response) nil)) - (link-header (mastodon-tl--get-link-header-from-response headers))) + (link-header + (mastodon-tl--get-link-header-from-response headers))) (with-mastodon-buffer buffer #'mastodon-mode nil - (mastodon-tl--set-buffer-spec buffer endpoint update-function - link-header update-params hide-replies - ;; awful hack to fix multiple reloads: - (alist-get "max_id" update-params nil nil #'equal)) + (mastodon-tl--set-buffer-spec + buffer endpoint update-function + link-header update-params hide-replies + ;; awful hack to fix multiple reloads: + (alist-get "max_id" update-params nil nil #'string=)) (mastodon-tl--do-init json update-function instance))))))) (defun mastodon-tl--init-sync - (buffer-name endpoint update-function - &optional note-type params headers view-name binding-str) + (buffer-name endpoint update-function &optional note-type params + headers view-name binding-str endpoint-version) "Initialize BUFFER-NAME with timeline targeted by ENDPOINT. UPDATE-FUNCTION is used to receive more toots. Runs synchronously. @@ -3135,7 +3134,8 @@ Optional arg NOTE-TYPE means only get that type of notification. PARAMS is an alist of any params to include in the request. HEADERS are any headers to send in the request. VIEW-NAME is a string, to be used as a heading for the view. -BINDING-STR is a string explaining any bindins in the view." +BINDING-STR is a string explaining any bindins in the view. +ENDPOINT-VERSION is a string, format Vx, e.g. V2." ;; Used by `mastodon-notifications-get' and in views.el (let* ((exclude-types (when note-type (mastodon-notifications--filter-types-list note-type))) @@ -3143,7 +3143,7 @@ BINDING-STR is a string explaining any bindins in the view." (mastodon-http--build-array-params-alist "exclude_types[]" exclude-types))) (params (append notes-params params)) - (url (mastodon-http--api endpoint)) + (url (mastodon-http--api endpoint endpoint-version)) (buffer (concat "*mastodon-" buffer-name "*")) (response (mastodon-http--get-response url params)) (json (car response)) @@ -3157,10 +3157,11 @@ BINDING-STR is a string explaining any bindins in the view." (when binding-str (insert (mastodon-tl--set-face (concat "[" binding-str "]\n\n") 'font-lock-comment-face))) - (mastodon-tl--set-buffer-spec buffer endpoint update-function - link-header params nil - ;; awful hack to fix multiple reloads: - (alist-get "max_id" params nil nil #'equal)) + (mastodon-tl--set-buffer-spec + buffer endpoint update-function + link-header params nil + ;; awful hack to fix multiple reloads: + (alist-get "max_id" params nil nil #'string=)) (mastodon-tl--do-init json update-function) buffer))) @@ -3169,7 +3170,7 @@ BINDING-STR is a string explaining any bindins in the view." JSON is the data to call UPDATE-FUN on. When DOMAIN, force inclusion of user's domain in their handle." (remove-overlays) ; video overlays - (if domain + (if domain ;; maybe our update-fun doesn't always have 3 args...: (funcall update-fun json nil domain) (funcall update-fun json)) (setq @@ -3198,8 +3199,7 @@ When DOMAIN, force inclusion of user's domain in their handle." RECORD is the bookmark record." (let ((id (bookmark-prop-get record 'id))) ;; we need to handle thread and single toot for starters - (pop-to-buffer - (mastodon-tl--thread id)))) + (pop-to-buffer (mastodon-tl--thread id)))) (defun mastodon-tl--bookmark-make-record () "Return a bookmark record for the current mastodon buffer." diff --git a/lisp/mastodon-toot.el b/lisp/mastodon-toot.el index 7497429..832d03f 100644 --- a/lisp/mastodon-toot.el +++ b/lisp/mastodon-toot.el @@ -98,6 +98,8 @@ (autoload 'mastodon-tl--get-buffer-type "mastodon-tl") (autoload 'mastodon-tl--human-duration "mastodon-tl") (autoload 'mastodon-profile--get-preferences-pref "mastodon-profile") +(autoload 'mastodon-views--get-own-instance "mastodon-views") +(autoload 'mastodon-tl--image-trans-check "mastodon-tl") ;; for mastodon-toot--translate-toot-text (autoload 'mastodon-tl--content "mastodon-tl") @@ -224,7 +226,7 @@ Takes its form from `window-configuration-to-register'.") "The text of the toot being composed.") (persist-defvar mastodon-toot-draft-toots-list nil - "A list of toots that have been saved as drafts. + "A list of toots that have been saved as drafts. For the moment we just put all composed toots in here, as we want to also capture toots that are \"sent\" but that don't successfully send.") @@ -269,6 +271,12 @@ data about the item boosted or favourited." (or (mastodon-tl--property 'base-toot :no-move) ; fave/boost notifs (mastodon-tl--property 'item-json))) +(defun mastodon-toot--inc-or-dec (count subtract) + "If SUBTRACT, decrement COUNT, else increment." + (if subtract + (1- count) + (1+ count))) + ;;; MACRO @@ -277,7 +285,7 @@ data about the item boosted or favourited." Includes boosts, and notifications that display toots. This macro makes the local variable ID available." (declare (debug t)) - `(if (not (equal 'toot (mastodon-tl--property 'item-type :no-move))) + `(if (not (eq 'toot (mastodon-tl--property 'item-type :no-move))) (user-error "Looks like there's no toot at point?") (mastodon-tl--with-toot-helper (lambda (id) @@ -350,12 +358,12 @@ JSON is added to the string as its item-json." (let ((inhibit-read-only t) (bol (car byline-region)) (eol (cdr byline-region)) - (at-byline-p (eq (mastodon-tl--property 'byline :no-move) t))) + (at-byline-p (eq t (mastodon-tl--property 'byline :no-move)))) (save-excursion (when remove (goto-char bol) (beginning-of-line) ;; The marker is not part of the byline - (if (search-forward (format "(%s) " marker) eol t) + (if (search-forward (format "(%s) " marker) eol :no-error) (replace-match "") (user-error "Oops: could not find marker '(%s)'" marker))) (unless remove @@ -402,12 +410,12 @@ ACTION is a symbol, either `favourite' or `boost.'" ;; there's nothing wrong with faving/boosting own toots ;; & nothing wrong with faving/boosting own toots from notifs, ;; it boosts/faves the base toot, not the notif status - ((or (equal n-type "follow") - (equal n-type "follow_request")) + ((or (string= n-type "follow") + (string= n-type "follow_request")) (user-error "Can't %s %s notifications" action n-type)) ((and boost-p - (or (equal vis "direct") - (equal vis "private"))) + (or (string= vis "direct") + (string= vis "private"))) (user-error "Can't boost posts with visibility: %s" vis)) (t (let* ((boosted (when byline-region @@ -416,9 +424,10 @@ ACTION is a symbol, either `favourite' or `boost.'" (get-text-property (car byline-region) 'favourited-p))) (str-api (if boost-p "reblog" action-str)) (action-str-api (mastodon-toot--str-negify str-api faved boosted)) - (action-pp (concat (mastodon-toot--str-negify action-str faved boosted) - (if boost-p "ed" "d"))) - (remove (if boost-p (when boosted t) (when faved t)))) + (action-pp (concat + (mastodon-toot--str-negify action-str faved boosted) + (if boost-p "ed" "d"))) + (remove-p (if boost-p boosted faved))) (mastodon-toot--action action-str-api (lambda (_) @@ -428,9 +437,9 @@ ACTION is a symbol, either `favourite' or `boost.'" (if boost-p (list 'boosted-p (not boosted)) (list 'favourited-p (not faved)))) - (mastodon-toot--update-stats-on-action action remove) + (mastodon-toot--update-stats-on-action action remove-p) (mastodon-toot--action-success (mastodon-tl--symbol action) - byline-region remove item-json)) + byline-region remove-p item-json)) (message "%s #%s" action-pp id))))))))) (defun mastodon-toot--str-negify (str faved boosted) @@ -439,33 +448,29 @@ ACTION is a symbol, either `favourite' or `boost.'" (concat "un" str) str)) -(defun mastodon-toot--inc-or-dec (count subtract) - "If SUBTRACT, decrement COUNT, else increment." - (if subtract - (1- count) - (1+ count))) - (defun mastodon-toot--update-stats-on-action (action &optional subtract) "Increment the toot stats display upon ACTION. ACTION is a symbol, either `favourite' or `boost'. SUBTRACT means we are un-favouriting or unboosting, so we decrement." - (let* ((count-prop (if (eq action 'favourite) - 'favourites-count - 'boosts-count)) - (count-prop-range (mastodon-tl--find-property-range count-prop (point))) - (count (get-text-property (car count-prop-range) count-prop)) - (inhibit-read-only 1)) - ;; TODO another way to implement this would be to async fetch counts again - ;; and re-display from count-properties - (add-text-properties (car count-prop-range) - (cdr count-prop-range) - (list 'display - (number-to-string - (mastodon-toot--inc-or-dec count subtract)) - ;; update the count prop - ;; we rely on this for any subsequent actions: - count-prop - (mastodon-toot--inc-or-dec count subtract))))) + (if (not (symbolp action)) + (error "Invalid argument: symbolp %s" action) + (let* ((count-prop (if (eq action 'favourite) + 'favourites-count + 'boosts-count)) + (count-range (mastodon-tl--find-property-range count-prop (point))) + (count (get-text-property (car count-range) count-prop)) + (inhibit-read-only 1)) + ;; TODO another way to implement this would be to async fetch counts again + ;; and re-display from count-properties + (add-text-properties (car count-range) + (cdr count-range) + (list 'display + (number-to-string + (mastodon-toot--inc-or-dec count subtract)) + ;; update the count prop + ;; we rely on this for any subsequent actions: + count-prop + (mastodon-toot--inc-or-dec count subtract)))))) (defun mastodon-toot--toggle-boost () "Boost/unboost toot at `point'." @@ -487,8 +492,8 @@ SUBTRACT means we are un-favouriting or unboosting, so we decrement." (bookmarked-p (when byline-region (get-text-property (car byline-region) 'bookmarked-p))) (action (if bookmarked-p "unbookmark" "bookmark"))) - (cond ((or (equal n-type "follow") - (equal n-type "follow_request")) + (cond ((or (string= n-type "follow") + (string= n-type "follow_request")) (user-error "Can't bookmark %s notifications" n-type)) ((not byline-region) (user-error "Nothing to %s here?!?" action)) @@ -509,17 +514,17 @@ SUBTRACT means we are un-favouriting or unboosting, so we decrement." byline-region bookmarked-p item-json) (message "%s #%s" message id)))))))))) -(defun mastodon-toot--list-toot-boosters () +(defun mastodon-toot--list-boosters () "List the boosters of toot at point." (interactive) - (mastodon-toot--list-toot-boosters-or-favers)) + (mastodon-toot--list-boosters-or-favers)) -(defun mastodon-toot--list-toot-favouriters () +(defun mastodon-toot--list-favouriters () "List the favouriters of toot at point." (interactive) - (mastodon-toot--list-toot-boosters-or-favers :favourite)) + (mastodon-toot--list-boosters-or-favers :favourite)) -(defun mastodon-toot--list-toot-boosters-or-favers (&optional favourite) +(defun mastodon-toot--list-boosters-or-favers (&optional favourite) "List the favouriters or boosters of toot at point. With FAVOURITE, list favouriters, else list boosters." (mastodon-toot--with-toot-item @@ -591,21 +596,20 @@ Uses `lingva.el'." ;; this check needs to allow acting on own toots displayed as boosts, so we ;; call `mastodon-tl--toot-or-base'. (let ((json (mastodon-tl--toot-or-base toot))) - (equal (alist-get 'acct (alist-get 'account json)) - (mastodon-auth--user-acct)))) + (string= (alist-get 'acct (alist-get 'account json)) + (mastodon-auth--user-acct)))) (defun mastodon-toot--pin-toot-toggle () "Pin or unpin user's toot at point." (interactive) (let* ((toot (mastodon-toot--base-toot-or-item-json)) (pinnable-p (mastodon-toot--own-toot-p toot)) - (pinned-p (equal (alist-get 'pinned toot) t)) + (pinned-p (eq t (alist-get 'pinned toot))) (action (if pinned-p "unpin" "pin")) - (msg (if pinned-p "unpinned" "pinned")) - (msg-y-or-n (if pinned-p "Unpin" "Pin"))) + (msg (if pinned-p "unpinned" "pinned"))) (if (not pinnable-p) (user-error "You can only pin your own toots") - (when (y-or-n-p (format "%s this toot? " msg-y-or-n)) + (when (y-or-n-p (format "%s this toot? " (capitalize action))) (mastodon-toot--action action (lambda (_) (when mastodon-tl--buffer-spec @@ -628,28 +632,26 @@ NO-REDRAFT means delete toot only." (let* ((toot (mastodon-toot--base-toot-or-item-json)) (id (mastodon-tl--as-string (mastodon-tl--item-id toot))) (url (mastodon-http--api (format "statuses/%s" id))) - (toot-cw (alist-get 'spoiler_text toot)) - (toot-visibility (alist-get 'visibility toot)) - (reply-id (alist-get 'in_reply_to_id toot)) (pos (point))) - (if (not (mastodon-toot--own-toot-p toot)) - (user-error "You can only delete (and redraft) your own toots") - (when (y-or-n-p (if no-redraft - (format "Delete this toot? ") - (format "Delete and redraft this toot? "))) - (let* ((response (mastodon-http--delete url))) - (mastodon-http--triage - response - (lambda (_) - (if no-redraft - (progn - (when mastodon-tl--buffer-spec - (mastodon-tl--reload-timeline-or-profile pos)) - (message "Toot deleted!")) - (mastodon-toot--redraft response - reply-id - toot-visibility - toot-cw))))))))) + (let-alist toot + (if (not (mastodon-toot--own-toot-p toot)) + (user-error "You can only delete (and redraft) your own toots") + (when (y-or-n-p (if no-redraft + (format "Delete this toot? ") + (format "Delete and redraft this toot? "))) + (let* ((response (mastodon-http--delete url))) + (mastodon-http--triage + response + (lambda (_) + (if no-redraft + (progn + (when mastodon-tl--buffer-spec + (mastodon-tl--reload-timeline-or-profile pos)) + (message "Toot deleted!")) + (mastodon-toot--redraft response + .in_reply_to_id + .visibility + .spoiler_text)))))))))) (defun mastodon-toot--set-cw (&optional cw) "Set content warning to CW if it is non-nil." @@ -660,12 +662,13 @@ NO-REDRAFT means delete toot only." ;;; REDRAFT -(defun mastodon-toot--redraft (response &optional 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))) + (let* ((response (mastodon-http--process-json)) + (content (alist-get 'text response))) (mastodon-toot--compose-buffer) (goto-char (point-max)) (insert content) @@ -715,7 +718,7 @@ CANCEL means the toot was not sent, so we save the toot text as a draft." (unless (eq mastodon-toot-current-toot-text nil) (when cancel (cl-pushnew mastodon-toot-current-toot-text - mastodon-toot-draft-toots-list :test 'equal))) + mastodon-toot-draft-toots-list :test #'string=))) ;; prevent some weird bug when cancelling a non-empty toot: (delete #'mastodon-toot--save-toot-text after-change-functions) (quit-window 'kill) @@ -725,11 +728,10 @@ CANCEL means the toot was not sent, so we save the toot text as a draft." "Kill new-toot buffer/window. Does not POST content. If toot is not empty, prompt to save text as a draft." (interactive) - (if (mastodon-toot--empty-p) - (mastodon-toot--kill) - (when (y-or-n-p "Save draft toot?") - (mastodon-toot--save-draft)) - (mastodon-toot--kill))) + (when (and (not (mastodon-toot--empty-p)) + (y-or-n-p "Save draft toot?")) + (mastodon-toot--save-draft)) + (mastodon-toot--kill)) (defun mastodon-toot--save-draft () "Save the current compose toot text as a draft. @@ -869,9 +871,9 @@ instance to edit a toot." (scheduled mastodon-toot--scheduled-for) (scheduled-id mastodon-toot--scheduled-id) (edit-id mastodon-toot--edit-item-id) - (endpoint (if edit-id ; we are sending an edit: - (mastodon-http--api (format "statuses/%s" edit-id)) - (mastodon-http--api "statuses"))) + (endpoint (mastodon-http--api (if edit-id ; we are sending an edit: + (format "statuses/%s" edit-id) + "statuses"))) (args-no-media (append `(("status" . ,toot) ("in_reply_to_id" . ,mastodon-toot--reply-to-id) ("visibility" . ,mastodon-toot--visibility) @@ -909,9 +911,10 @@ instance to edit a toot." ((mastodon-toot--empty-p) (user-error "Empty toot. Cowardly refusing to post this")) (t - (let ((response (if edit-id ; we are sending an edit: - (mastodon-http--put endpoint args) - (mastodon-http--post endpoint args)))) + (let ((response (funcall (if edit-id ; we are sending an edit: + #'mastodon-http--put + #'mastodon-http--post) + endpoint args))) (mastodon-http--triage response (lambda (_) @@ -924,15 +927,12 @@ instance to edit a toot." scheduled-id :no-confirm)) ;; window config: (mastodon-toot--restore-previous-window-config prev-window-config) - ;; reload previous view in certain cases: - ;; we reload: - when we have been editing - ;; - when we are in thread view - ;; - ? - ;; (we don't necessarily want to reload in every posting case - ;; as it can sometimes be slow and we may still lose our place - ;; in a timeline.) + ;; reload: - when we have been editing + ;; - when we are in thread view + ;; (we don't reload in every case as it can be slow and we may + ;; lose our place in a timeline.) (when (or edit-id - (equal 'thread (mastodon-tl--get-buffer-type))) + (eq 'thread (mastodon-tl--get-buffer-type))) (let ((pos (marker-position (cadr prev-window-config)))) (mastodon-tl--reload-timeline-or-profile pos)))))))))) @@ -974,33 +974,33 @@ instance to edit a toot." "View editing history of the toot at point in a popup buffer." (interactive) (let ((id (mastodon-tl--property 'base-item-id)) - (history (mastodon-tl--property 'edit-history)) + (history (mastodon-tl--property 'edit-history)) ;; at byline (buf "*mastodon-toot-edits*")) - (with-mastodon-buffer buf #'special-mode :other-window - (let ((count 1)) - (mapc (lambda (x) - (insert (propertize (if (= count 1) - (format "%s [original]:\n" count) - (format "%s:\n" count)) - 'face 'font-lock-comment-face) - (mastodon-toot--insert-toot-iter x) - "\n") - (cl-incf count)) - history)) - (setq-local header-line-format - (propertize - (format "Edits to toot by %s:" - (alist-get 'username - (alist-get 'account (car history)))) - 'face 'font-lock-comment-face)) - (mastodon-tl--set-buffer-spec (buffer-name (current-buffer)) - (format "statuses/%s/history" id) - nil)))) + (if (not history) + (user-error "No editing history for this toot") + (with-mastodon-buffer buf #'special-mode :other-window + (cl-loop for count from 1 + for x in history + do (insert (propertize (if (= count 1) + (format "%s [original]:\n" count) + (format "%s:\n" count)) + 'face 'font-lock-comment-face) + (mastodon-toot--insert-toot-iter x) + "\n")) + (goto-char (point-min)) + (setq-local header-line-format + (propertize + (format "Edits to toot by %s:" + (alist-get 'username + (alist-get 'account (car history)))) + 'face 'font-lock-comment-face)) + (mastodon-tl--set-buffer-spec (buffer-name (current-buffer)) + (format "statuses/%s/history" id) + nil))))) (defun mastodon-toot--insert-toot-iter (it) "Insert iteration IT of toot." (let ((content (alist-get 'content it))) - ;; (account (alist-get 'account it)) ;; TODO: handle polls, media (mastodon-tl--render-text content))) @@ -1013,9 +1013,9 @@ Buffer-local variable `mastodon-toot-previous-window-config' holds the config." (defun mastodon-toot--mentions-to-string (mentions) "Apply `mastodon-toot--process-local' function to each mention in MENTIONS. Remove empty string (self) from result and joins the sequence with whitespace." - (mapconcat (lambda (mention) mention) - (remove "" (mapcar #'mastodon-toot--process-local mentions)) - " ")) + (let ((mentions (remove "" + (mapcar #'mastodon-toot--process-local mentions)))) + (mapconcat #'identity mentions " "))) (defun mastodon-toot--process-local (acct) "Add domain to local ACCT and replace the curent user name with \"\". @@ -1026,8 +1026,10 @@ eg. \"yourusername\" -> \"\" eg. \"feduser@fed.social\" -> \"@feduser@fed.social\"." (cond ((string-match-p "@" acct) (concat "@" acct)) ; federated acct ((string= (mastodon-auth--user-acct) acct) "") ; your acct - (t (concat "@" acct "@" ; local acct - (cadr (split-string mastodon-instance-url "/" t)))))) + (t + (concat "@" acct "@" ; local acct + (cadr + (split-string mastodon-instance-url "/" :omit-nulls)))))) ;;; COMPLETION (TAGS, MENTIONS) @@ -1037,10 +1039,7 @@ eg. \"feduser@fed.social\" -> \"@feduser@fed.social\"." The mentioned users look like this: Local user (including the logged in): `username`. Federated user: `username@host.co`." - (let* ((boosted (mastodon-tl--field 'reblog status)) - (mentions (if boosted - (alist-get 'mentions (alist-get 'reblog status)) - (alist-get 'mentions status)))) + (let* ((mentions (mastodon-tl--field 'mentions status))) ;; reverse does not work on vectors in 24.5 (mastodon-tl--map-alist 'acct (reverse mentions)))) @@ -1063,19 +1062,19 @@ Federated user: `username@host.co`." The candidates are calculated according to currently active `emojify-emoji-styles'. Hacked off `emojify--get-completing-read-candidates'." - (let ((styles ;'("ascii" "unicode" "github") - (mapcar #'symbol-name emojify-emoji-styles))) + (let ((styles (mapcar #'symbol-name emojify-emoji-styles))) (let ((emojis '())) - (emojify-emojis-each (lambda (key value) - (when (seq-position styles (ht-get value "style")) - (push (cons key - (format "%s (%s)" - (ht-get value "name") - (ht-get value "style"))) - emojis)))) + (emojify-emojis-each + (lambda (key value) + (when (seq-position styles (ht-get value "style")) + (push (cons key + (format "%s (%s)" + (ht-get value "name") + (ht-get value "style"))) + emojis)))) emojis))) -(defun mastodon-toot--fetch-completion-candidates (start end &optional type) +(defun mastodon-toot--fetch-candidates (start end &optional type) "Search for a completion prefix from buffer positions START to END. Return a list of candidates. TYPE is the candidate type, it may be :tags, :handles, or :emoji." @@ -1098,7 +1097,7 @@ TYPE is the candidate type, it may be :tags, :handles, or :emoji." (defun mastodon-toot--make-capf (regex annot-fun type) "Build a completion backend for `completion-at-point-functions'. REGEX is the regex to match preceding text. -TYPE is a keyword symbol for `mastodon-toot--fetch-completion-candidates'. +TYPE is a keyword symbol for `mastodon-toot--fetch-candidates'. ANNOT-FUN is a function returning an annotatation from a single arg, a candidate." (let* ((bounds (mastodon-toot--get-bounds regex)) @@ -1112,7 +1111,7 @@ arg, a candidate." ;; Interruptible candidate computation, from minad/d mendler, thanks! (let ((result (while-no-input - (mastodon-toot--fetch-completion-candidates + (mastodon-toot--fetch-candidates start end type)))) (and (consp result) result)))) :exclusive 'no @@ -1167,7 +1166,6 @@ prefixed by >." (let* ((quote (when (region-active-p) (buffer-substring (region-beginning) (region-end)))) - ;; no-move arg for base toot: don't try next toot (toot (mastodon-toot--base-toot-or-item-json)) (account (mastodon-tl--field 'account toot)) (user (alist-get 'acct account)) @@ -1175,29 +1173,20 @@ prefixed by >." (boosted (mastodon-tl--field 'reblog toot)) (booster (when boosted (alist-get 'acct - (alist-get 'account toot))))) - (mastodon-toot--compose-buffer - (when user - (if booster - (if (and (not (equal user booster)) - (not (member booster mentions))) - ;; different booster, user and mentions: - (mastodon-toot--mentions-to-string (append (list user booster) mentions nil)) - ;; booster is either user or in mentions: - (if (not (member user mentions)) - ;; user not already in mentions: - (mastodon-toot--mentions-to-string (append (list user) mentions nil)) - ;; user already in mentions: - (mastodon-toot--mentions-to-string (copy-sequence mentions)))) - ;; ELSE no booster: - (if (not (member user mentions)) - ;; user not in mentions: - (mastodon-toot--mentions-to-string (append (list user) mentions nil)) - ;; user in mentions already: - (mastodon-toot--mentions-to-string (copy-sequence mentions))))) - id - toot - quote)))) + (alist-get 'account toot)))) + (mentions + (cond ((and booster ;; different booster, user and mentions: + (and (not (string= user booster)) + (not (member booster mentions)))) + (mastodon-toot--mentions-to-string + (append (list user booster) mentions nil))) + ((not (member user mentions)) ;; user not in mentions: + (mastodon-toot--mentions-to-string + (append (list user) mentions nil))) + (t ;; user already in mentions: + (mastodon-toot--mentions-to-string + (copy-sequence mentions)))))) + (mastodon-toot--compose-buffer mentions id toot quote)))) ;;; COMPOSE TOOT SETTINGS @@ -1240,7 +1229,7 @@ Return its two letter ISO 639 1 code." (let* ((choice (completing-read "Language for this toot: " mastodon-iso-639-1))) (setq mastodon-toot--language - (alist-get choice mastodon-iso-639-1 nil nil 'equal)) + (alist-get choice mastodon-iso-639-1 nil nil #'string=)) (message "Language set to %s" choice) (mastodon-toot--update-status-fields))) @@ -1255,33 +1244,48 @@ Return its two letter ISO 639 1 code." (mastodon-toot--refresh-attachments-display) (mastodon-toot--update-status-fields)) +(defun mastodon-toot--get-instance-max-attachments () + "Return the maximum attachments from `mastodon-active-user's instance. +If that fails, return 4 as a fallback" + ;; FIXME: this likely various for other server types: + ;; pleroma doesn't advertise this on "api/v1/instance" (checked + ;; fe.disroot.org) + (or + (let ((config (alist-get 'statuses + (alist-get 'configuration + (mastodon-views--get-own-instance))))) + (alist-get 'max_media_attachments config)) + 4)) ; mastodon default as fallback + (defun mastodon-toot--attach-media (file description) "Prompt for an attachment FILE with DESCRIPTION. A preview is displayed in the new toot buffer, and the file is uploaded asynchronously using `mastodon-toot--upload-attached-media'. File is actually attached to the toot upon posting." (interactive "fFilename: \nsDescription: ") - (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) - (user-error "Looks like you chose a directory not a file") - (setq mastodon-toot--media-attachments - (nconc mastodon-toot--media-attachments - `(((:contents . ,(mastodon-http--read-file-as-string file)) - (:description . ,description) - (:filename . ,file))))) - (mastodon-toot--refresh-attachments-display) - ;; upload only most recent attachment: - (mastodon-toot--upload-attached-media - (car (last mastodon-toot--media-attachments))))) + (let ((max-attachments (mastodon-toot--get-instance-max-attachments))) + (when (>= (length mastodon-toot--media-attachments) + max-attachments) + ;; warn + pop the oldest one: + (when (y-or-n-p + (format "Maximum attachments (%s) reached: remove first one?" + max-attachments)) + (pop mastodon-toot--media-attachments))) + (if (file-directory-p file) + (user-error "Looks like you chose a directory not a file") + (setq mastodon-toot--media-attachments + (nconc mastodon-toot--media-attachments + `(((:contents . ,(mastodon-http--read-file-as-string file)) + (:description . ,description) + (:filename . ,file))))) + (mastodon-toot--refresh-attachments-display) + ;; upload only most recent attachment: + (mastodon-toot--upload-attached-media + (car (last mastodon-toot--media-attachments)))))) (defun mastodon-toot--attachment-descriptions () "Return a list of image descriptions for current attachments." - (mastodon-tl--map-alist :description - ;; (mapcar (lambda (a) - ;; (alist-get :description a)) - mastodon-toot--media-attachments)) + (mastodon-tl--map-alist :description mastodon-toot--media-attachments)) (defun mastodon-toot--attachment-from-desc (desc) "Return an attachment based on its description DESC." @@ -1319,30 +1323,29 @@ which is used to attach it to a toot when posting." '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) + (add-text-properties (+ i (car attachments-region)) + (+ i 1 (car attachments-region)) (list 'display (or (nth i display-specs) "")))))) (defun mastodon-toot--format-attachments () "Format the attachment previews for display in toot draft buffer." - (or (let ((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)) - (description (alist-get :description attachment))) - (setq counter (1+ counter)) - (list (format "\n %d: " counter) - image - (format " \"%s\"" description)))) - mastodon-toot--media-attachments)) - (list "None"))) + (or + (let ((image-options (when (mastodon-tl--image-trans-check) + `(:height ,mastodon-toot--attachment-height)))) + (cl-loop for count from 1 + for att in mastodon-toot--media-attachments + nconc + (let* ((data (alist-get :contents att)) + (image (apply #'create-image data + (if (version< emacs-version "27.1") + (when image-options 'imagemagick) + nil) ; inbuilt scaling in 27.1 + t image-options)) + (desc (alist-get :description att))) + (list (format "\n %d: " count) + image + (format " \"%s\"" desc))))) + (list "None"))) ;;; POLL @@ -1397,10 +1400,11 @@ MAX is the maximum number set by their instance." (defun mastodon-toot--read-poll-options (count length) "Read a list of options for poll with COUNT options. LENGTH is the maximum character length allowed for a poll option." - (let* ((choices (cl-loop for x from 1 to count - collect (read-string - (format "Poll option [%s/%s] [max %s chars]: " - x count length)))) + (let* ((choices + (cl-loop for x from 1 to count + collect (read-string + (format "Poll option [%s/%s] [max %s chars]: " + x count length)))) (longest (apply #'max (mapcar #'length choices)))) (if (> longest length) (progn @@ -1416,7 +1420,7 @@ Return a cons of a human readable string, and a seconds-from-now string." (let* ((options (mastodon-toot--poll-expiry-options-alist)) (response (completing-read "poll ends in [or enter seconds]: " options nil 'confirm))) - (or (assoc response options #'equal) + (or (assoc response options #'string=) (if (< (string-to-number response) 600) (car options))))) ;; min 5 mins @@ -1444,20 +1448,17 @@ Sets `mastodon-toot-poll' to nil." (defun mastodon-toot--server-poll-to-local (json) "Convert server poll data JSON to a `mastodon-toot-poll' plist." (let-alist json - (let* ((expiry-seconds-from-now + (let* ((expiry-seconds-rel (time-to-seconds (time-subtract (encode-time (parse-time-string .expires_at)) (current-time)))) - (expiry-str - (format-time-string "%s" - expiry-seconds-from-now)) - (expiry-human (car (mastodon-tl--human-duration expiry-seconds-from-now))) + (expiry-str (format-time-string "%s" expiry-seconds-rel)) + (expiry-human (car + (mastodon-tl--human-duration expiry-seconds-rel))) (options (mastodon-tl--map-alist 'title .options)) - (multiple (if (eq :json-false .multiple) - nil - t))) + (multiple (if (eq :json-false .multiple) nil t))) (setq mastodon-toot-poll `( :options ,options :expiry-readable ,expiry-human :expiry ,expiry-str :multi ,multiple))))) @@ -1481,28 +1482,29 @@ With RESCHEDULE, reschedule the scheduled toot at point without editing." (ts (when reschedule (alist-get 'scheduled_at (mastodon-tl--property 'scheduled-json :no-move)))) - (time-value (org-read-date t t nil "Schedule toot:" - ;; default to scheduled timestamp if already set: - (mastodon-toot--iso-to-org - ;; we are rescheduling without editing: - (or ts - ;; we are maybe editing the scheduled toot: - mastodon-toot--scheduled-for)))) + (time-value + (org-read-date t t nil "Schedule toot:" + ;; default to scheduled timestamp if already set: + (mastodon-toot--iso-to-org + ;; we are rescheduling without editing: + (or ts + ;; we are maybe editing the scheduled toot: + mastodon-toot--scheduled-for)))) (iso8601-str (format-time-string "%FT%T%z" time-value)) (msg-str (format-time-string "%d-%m-%y at %H:%M[%z]" time-value))) (if (not reschedule) (progn (setq-local mastodon-toot--scheduled-for iso8601-str) - (message (format "Toot scheduled for %s." msg-str))) + (message "Toot scheduled for %s." msg-str)) (let* ((args `(("scheduled_at" . ,iso8601-str))) (url (mastodon-http--api (format "scheduled_statuses/%s" id))) (response (mastodon-http--put url args))) - (mastodon-http--triage response - (lambda (_) - ;; reschedule means we are in scheduled toots view: - (mastodon-views--view-scheduled-toots) - (message - (format "Toot rescheduled for %s." msg-str)))))))))) + (mastodon-http--triage + response + (lambda (_) + ;; reschedule means we are in scheduled toots view: + (mastodon-views--view-scheduled-toots) + (message "Toot rescheduled for %s." msg-str))))))))) (defun mastodon-toot--iso-to-human (ts) "Format an ISO8601 timestamp TS to be more human-readable." @@ -1512,19 +1514,21 @@ With RESCHEDULE, reschedule the scheduled toot at point without editing." (defun mastodon-toot--iso-to-org (ts) "Convert ISO8601 timestamp TS to something `org-read-date' can handle." - (when ts (let* ((decoded (iso8601-parse ts))) - (encode-time decoded)))) + (when ts + (let* ((decoded (iso8601-parse ts))) + (encode-time decoded)))) ;;; DISPLAY KEYBINDINGS -(defun mastodon-toot--get-mode-kbinds () +(defun mastodon-toot--get-kbinds () "Get a list of the keybindings in the `mastodon-toot-mode'." (let* ((binds (copy-tree mastodon-toot-mode-map)) (prefix (car (cadr binds))) - (bindings (remove nil (mapcar (lambda (i) - (when (listp i) i)) - (cadr binds))))) + (bindings (remove nil + (mapcar (lambda (i) + (when (listp i) i)) + (cadr binds))))) (mapcar (lambda (b) (setf (car b) (vector prefix (car b))) b) @@ -1579,7 +1583,7 @@ LONGEST is the length of the longest binding." (mastodon-toot--formatted-kbinds-pairs (cddr kbinds-list) longest)) (reverse mastodon-toot--kbinds-pairs)) -(defun mastodon-toot--formatted-kbinds-longest (kbinds-list) +(defun mastodon-toot--kbinds-longest (kbinds-list) "Return the length of the longest item in KBINDS-LIST." (let ((lengths (mapcar #'length kbinds-list))) (car (sort lengths #'>)))) @@ -1588,19 +1592,20 @@ LONGEST is the length of the longest binding." ;;; DISPLAY DOCS (defun mastodon-toot--make-mode-docs () - "Create formatted documentation text for the `mastodon-toot-mode'." - (let* ((kbinds (mastodon-toot--get-mode-kbinds)) - (longest-kbind (mastodon-toot--formatted-kbinds-longest - (mastodon-toot--format-kbinds kbinds)))) + "Create formatted documentation text for `mastodon-toot-mode'." + (let* ((kbinds (mastodon-toot--get-kbinds)) + (formatted (mastodon-toot--format-kbinds kbinds)) + (longest-kbind (mastodon-toot--kbinds-longest + formatted))) (concat - (mastodon-toot--comment " Compose a new toot here. The following keybindings are available:") - (mapconcat #'identity - (mastodon-toot--formatted-kbinds-pairs - (mastodon-toot--format-kbinds kbinds) - longest-kbind) - nil)))) - -(defun mastodon-toot--format-reply-in-compose-string (reply-text) + (mastodon-toot--comment + " Compose a new toot here. The following keybindings are available:") + (mapconcat + #'identity + (mastodon-toot--formatted-kbinds-pairs formatted longest-kbind) + nil)))) + +(defun mastodon-toot--format-reply-in-compose (reply-text) "Format a REPLY-TEXT for display in compose buffer docs." (let* ((rendered (mastodon-tl--render-text reply-text)) (no-props (substring-no-properties rendered)) @@ -1654,11 +1659,10 @@ REPLY-TEXT is the text of the toot being replied to." (propertize "None " 'toot-attachments t) "\n" - (if reply-text - (propertize - (mastodon-toot--format-reply-in-compose-string reply-text) - 'toot-reply t) - "") + (when reply-text + (propertize + (mastodon-toot--format-reply-in-compose reply-text) + 'toot-reply t)) divider) 'face 'mastodon-toot-docs-face 'read-only "Edit your message below." @@ -1674,7 +1678,8 @@ The default is given by `mastodon-toot--default-reply-visibility'." (let ((less-restrictive (member (intern mastodon-toot--default-reply-visibility) mastodon-toot-visibility-list))) (if (member (intern reply-visibility) less-restrictive) - mastodon-toot--default-reply-visibility reply-visibility)))) + mastodon-toot--default-reply-visibility + reply-visibility)))) (defun mastodon-toot--fill-buffer () "Mark buffer, call `fill-region'." @@ -1685,7 +1690,6 @@ The default is given by `mastodon-toot--default-reply-visibility'." (defun mastodon-toot--render-reply-region-str (str) "Refill STR and prefix all lines with >, as reply-quote text." (with-temp-buffer - ;; (switch-to-buffer (current-buffer)) (insert str) ;; unfill first: (let ((fill-column (point-max))) @@ -1696,8 +1700,7 @@ The default is given by `mastodon-toot--default-reply-visibility'." (save-match-data (while (re-search-forward "^" nil t) (replace-match " > "))) - (buffer-substring-no-properties (point-min) - (point-max)))) + (buffer-substring-no-properties (point-min) (point-max)))) (defun mastodon-toot--setup-as-reply (reply-to-user reply-to-id reply-json reply-region) @@ -1716,7 +1719,7 @@ REPLY-REGION is a string to be injected into the buffer." (mastodon-toot--render-reply-region-str reply-region) "\n")) (setq mastodon-toot--reply-to-id reply-to-id) - (unless (equal mastodon-toot--visibility reply-visibility) + (unless (string= mastodon-toot--visibility reply-visibility) (setq mastodon-toot--visibility reply-visibility)) (mastodon-toot--set-cw reply-cw)))) @@ -1750,16 +1753,14 @@ REPLY-REGION is a string to be injected into the buffer." (mastodon-toot--apply-fields-props vis-region (format "%s" - (if (equal - mastodon-toot--visibility - "private") + (if (string= "private" mastodon-toot--visibility) "followers-only" mastodon-toot--visibility))) + ;; WHEN clauses don't work here, we need "" as display arg: (mastodon-toot--apply-fields-props lang-region (if mastodon-toot--language - (format "Lang: %s ⋅" - mastodon-toot--language) + (format "Lang: %s ⋅" mastodon-toot--language) "")) (mastodon-toot--apply-fields-props sched-region @@ -1783,7 +1784,7 @@ REPLY-REGION is a string to be injected into the buffer." (mastodon-toot--apply-fields-props cw-region (if (and mastodon-toot--content-warning - (not (equal "" mastodon-toot--content-warning))) + (not (string= "" mastodon-toot--content-warning))) (format "CW: %s" mastodon-toot--content-warning) " ") ;; hold the blank space 'mastodon-cw-face)))) @@ -1801,6 +1802,8 @@ REPLY-REGION is a string to be injected into the buffer." URLs always = 23, and domain names of handles are not counted. This is how mastodon does it. CW is the content warning, which contributes to the character count." + ;; FIXME: URL chars is avail at /api/v1/instance + ;; for masto, it's .statuses.characters_reserved_per_url (let* ((url-replacement (make-string 23 ?x)) (count-str (replace-regexp-in-string ; handle @handles mastodon-toot-handle-regex "\2" diff --git a/lisp/mastodon-views.el b/lisp/mastodon-views.el index a3acfe0..ac62b1f 100644 --- a/lisp/mastodon-views.el +++ b/lisp/mastodon-views.el @@ -75,7 +75,7 @@ ;; switch to timlines without closing the minor view. ;; copying the mode map however means we need to avoid/unbind/override any -;; functions that might cause interfere with the minor view. +;; functions that might interfere with the minor view. ;; this is not redundant, as while the buffer -init function calls ;; `mastodon-mode', it gets overridden in some but not all cases. @@ -92,6 +92,11 @@ (define-key map (kbd "d") #'mastodon-views--delete-filter) (define-key map (kbd "c") #'mastodon-views--create-filter) (define-key map (kbd "g") #'mastodon-views--view-filters) + (define-key map (kbd "u") #'mastodon-views--update-filter) + (define-key map (kbd "k") #'mastodon-views--delete-filter) + (define-key map (kbd "a") #'mastodon-views--add-filter-kw) + (define-key map (kbd "r") #'mastodon-views--remove-filter-kw) + (define-key map (kbd "U") #'mastodon-views--update-filter-kw) map) "Keymap for viewing filters.") @@ -121,6 +126,7 @@ (define-key map (kbd "a") #'mastodon-views--add-account-to-list-at-point) (define-key map (kbd "r") #'mastodon-views--remove-account-from-list-at-point) (define-key map (kbd "e") #'mastodon-views--edit-list-at-point) + (define-key map (kbd "g") #'mastodon-views--view-lists) map) "Keymap for when point is on list name.") @@ -131,6 +137,7 @@ (define-key map (kbd "c") #'mastodon-views--cancel-scheduled-toot) (define-key map (kbd "e") #'mastodon-views--edit-scheduled-as-new) (define-key map (kbd "RET") #'mastodon-views--edit-scheduled-as-new) + (define-key map (kbd "g") #'mastodon-views--view-scheduled-toots) map) "Keymap for when point is on a scheduled toot.") @@ -158,15 +165,9 @@ request. This function is used as the update-function to `mastodon-tl--init-sync', which initializes a buffer for us and provides the JSON data." - ;; FIXME: this is not an update function as it inserts a heading and - ;; possible bindings string - ;; either it should go in init-sync, or possibly in each view function - ;; but either way, this function does almost nothing for us. - ;; could we call init-sync in here pehaps? - ;; (mastodon-search--insert-heading view-name) - ;; (when bindings-string - ;; (insert (mastodon-tl--set-face (concat "[" bindings-string "]\n\n") - ;; 'font-lock-comment-face))) + ;; FIXME not tecnically an update-fun for init-sync, but just a simple way + ;; to set up the empty buffer or else call the insert-fun. not sure if we cd + ;; improve by eg calling init-sync in here, making this a real view function. (if (seq-empty-p data) (insert (propertize (format "Looks like you have no %s for now." view-name) @@ -326,8 +327,7 @@ If ID is provided, use that list." (name (mastodon-views--get-list-name id)) (buffer-name (format "list-%s" name))) (mastodon-tl--init buffer-name endpoint - 'mastodon-tl--timeline - nil + 'mastodon-tl--timeline nil `(("limit" . ,mastodon-tl--timeline-posts-count))))) (defun mastodon-views--create-list () @@ -393,8 +393,11 @@ If ACCOUNT-ID and HANDLE are provided use them rather than prompting." (completing-read list-prompt (mastodon-views--get-lists-names) nil t))) (list-id (or id (mastodon-views--get-list-id list-name))) - (followings (mastodon-views--get-users-followings)) - (handles (mastodon-tl--map-alist-vals-to-alist 'acct 'id followings)) + (followings (unless handle + (mastodon-views--get-users-followings))) + (handles (unless handle + (mastodon-tl--map-alist-vals-to-alist + 'acct 'id followings))) (account (or handle (completing-read "Account to add: " handles nil t))) (account-id (or account-id (alist-get account handles))) @@ -429,8 +432,7 @@ If ID is provided, use that list." (list-id (or id (mastodon-views--get-list-id list-name))) (accounts (mastodon-views--accounts-in-list list-id)) (handles (mastodon-tl--map-alist-vals-to-alist 'acct 'id accounts)) - (account (completing-read "Account to remove: " - handles nil t)) + (account (completing-read "Account to remove: " handles nil t)) (account-id (alist-get account handles)) (url (mastodon-http--api (format "lists/%s/accounts" list-id))) (args (mastodon-http--build-array-params-alist "account_ids[]" `(,account-id))) @@ -516,7 +518,7 @@ JSON is the data returned by the server." 'item-type 'scheduled ; so we nav here 'face 'font-lock-comment-face 'keymap mastodon-views--scheduled-map - 'scheduled-json toot + 'item-json toot 'id .id) "\n"))) @@ -532,10 +534,8 @@ If ID, just return that toot." (defun mastodon-views--reschedule-toot () "Reschedule the scheduled toot at point." (interactive) - (let ((id (mastodon-tl--property 'id :no-move))) - (if (null id) - (message "no scheduled toot at point?") - (mastodon-toot--schedule-toot :reschedule)))) + (mastodon-tl--do-if-item + (mastodon-toot--schedule-toot :reschedule))) (defun mastodon-views--copy-scheduled-toot-text () "Copy the text of the scheduled toot at point." @@ -550,36 +550,34 @@ If ID, just return that toot." ID is that of the scheduled toot to cancel. NO-CONFIRM means there is no ask or message, there is only do." (interactive) - (let ((id (or id (mastodon-tl--property 'id :no-move)))) - (if (null id) - (message "no scheduled toot at point?") - (when (or no-confirm - (y-or-n-p "Cancel scheduled toot?")) - (let* ((url (mastodon-http--api (format "scheduled_statuses/%s" id))) - (response (mastodon-http--delete url))) - (mastodon-http--triage response - (lambda (_) - (mastodon-views--view-scheduled-toots) - (unless no-confirm - (message "Toot cancelled!"))))))))) + (mastodon-tl--do-if-item + (when (or no-confirm + (y-or-n-p "Cancel scheduled toot?")) + (let* ((id (or id (mastodon-tl--property 'id :no-move))) + (url (mastodon-http--api (format "scheduled_statuses/%s" id))) + (response (mastodon-http--delete url))) + (mastodon-http--triage response + (lambda (_) + (mastodon-views--view-scheduled-toots) + (unless no-confirm + (message "Toot cancelled!")))))))) (defun mastodon-views--edit-scheduled-as-new () "Edit scheduled status as new toot." (interactive) - (let ((id (mastodon-tl--property 'id :no-move))) - (if (null id) - (message "no scheduled toot at point?") - (let* ((toot (mastodon-tl--property 'scheduled-json :no-move)) - (scheduled (alist-get 'scheduled_at toot))) - (let-alist (alist-get 'params toot) - ;; TODO: preserve polls - ;; (poll (alist-get 'poll params)) - (mastodon-toot--compose-buffer nil .in_reply_to_id nil .text :edit) - (goto-char (point-max)) - ;; adopt properties from scheduled toot: - (mastodon-toot--set-toot-properties - .in_reply_to_id .visibility .spoiler_text .language - scheduled id (alist-get 'media_attachments toot))))))) + (mastodon-tl--do-if-item + (let* ((toot (mastodon-tl--property 'scheduled-json :no-move)) + (id (mastodon-tl--property 'id :no-move)) + (scheduled (alist-get 'scheduled_at toot))) + (let-alist (alist-get 'params toot) + ;; TODO: preserve polls + ;; (poll (alist-get 'poll params)) + (mastodon-toot--compose-buffer nil .in_reply_to_id nil .text :edit) + (goto-char (point-max)) + ;; adopt properties from scheduled toot: + (mastodon-toot--set-toot-properties + .in_reply_to_id .visibility .spoiler_text .language + scheduled id (alist-get 'media_attachments toot)))))) ;;; FILTERS @@ -591,87 +589,229 @@ NO-CONFIRM means there is no ask or message, there is only do." 'mastodon-views--insert-filters nil nil nil "current filters" - "c - create filter\n d - delete filter at point\n\ - n/p - go to next/prev filter") + "c/u - create/update filter | d/k - delete filter\ + at point\n a/r/U - add/remove/Update filter keyword\n\ + n/p - next/prev filter" "v2") (with-current-buffer "*mastodon-filters*" (use-local-map mastodon-views--view-filters-keymap))) (defun mastodon-views--insert-filters (json) - "Insert the user's current filters. -JSON is what is returned by by the server." - (mastodon-views--minor-view - "filters" - #'mastodon-views--insert-filter-string-set - json)) - -(defun mastodon-views--insert-filter-string-set (json) "Insert a filter string plus a blank line. JSON is the filters data." - (mapc #'mastodon-views--insert-filter-string json)) - -(defun mastodon-views--insert-filter-string (filter) + (mapc #'mastodon-views--insert-filter json)) + +(require 'table) + +(defun mastodon-views--insert-filter-kws (kws) + "Insert filter keywords KWS." + (insert "\n") + (let ((beg (point)) + (table-cell-horizontal-chars (if (char-displayable-p ?–) + "–" + "-")) + (whole-str "whole words only:")) + (insert (concat "Keywords: | " whole-str "\n")) + (mapc (lambda (kw) + (let ((whole (if (eq :json-false (alist-get 'whole_word kw)) + "nil" + "t"))) + (insert + (propertize (concat + (format "\"%s\" | %s\n" + (alist-get 'keyword kw) whole)) + 'kw-id (alist-get 'id kw) + 'item-json kw + 'mastodon-tab-stop t + 'whole-word whole)))) + kws) + ;; table display of kws: + (table-capture beg (point) "|" "\n" nil (+ 2 (length whole-str))) + (table-justify-column 'center) + (table-forward-cell) ;; col 2 + (table-justify-column 'center) + (while (re-search-forward ;; goto end of table: + (concat table-cell-horizontal-chars + (make-string 1 table-cell-intersection-char) + "\n") + nil :no-error)))) + +(defun mastodon-views--insert-filter (filter) "Insert a single FILTER." - (let* ((phrase (alist-get 'phrase filter)) - (contexts (alist-get 'context filter)) - (id (alist-get 'id filter)) - (filter-string (concat "- \"" phrase "\" filtered in: " - (mapconcat #'identity contexts ", ")))) + (let-alist filter (insert - (propertize filter-string - 'item-id id ;for goto-next-filter compat - 'item-type 'filter - 'phrase phrase - 'byline t) ;for goto-next-filter compat - "\n\n"))) + ;; FIXME: awful hack to fix nav: exclude horiz-bar from propertize then + ;; propertize rest of the filter text. if we add only byline prop to + ;; title, point will move to end of title, because at that byline-prop + ;; change, item-type prop is present. + (mastodon-tl--set-face + (concat "\n " mastodon-tl--horiz-bar "\n ") + 'success) + (propertize + (concat + ;; heading: + (mastodon-tl--set-face + (concat (upcase .title) " " "\n " + mastodon-tl--horiz-bar "\n") + 'success) + ;; context: + (concat "Context: " (mapconcat #'identity .context ", ")) + ;; type (warn or hide): + (concat "\nType: " .filter_action)) + 'item-json filter + 'byline t + 'item-id .id + 'filter-title .title + 'item-type 'filter)) + ;; terms list: + (when .keywords ;; poss to have no keywords + (mastodon-views--insert-filter-kws .keywords)))) (defvar mastodon-views--filter-types '("home" "notifications" "public" "thread" "profile")) -(defun mastodon-views--create-filter () +(defun mastodon-views--create-filter (&optional id title context type terms) "Create a filter for a word. Prompt for a context, must be a list containting at least one of \"home\", -\"notifications\", \"public\", \"thread\"." +\"notifications\", \"public\", \"thread\". +Optionally, provide ID, TITLE, CONTEXT, TYPE, and TERMS to update a filter." (interactive) - (let* ((url (mastodon-http--api "filters")) - (word (read-string - (format "Word(s) to filter (%s): " (or (current-word) "")) - nil nil (or (current-word) ""))) + ;; ID non-nil = we are updating + (let* ((url (mastodon-http--api-v2 + (if id (format "filters/%s" id) "filters"))) + (title (or title (read-string "Filter name: "))) + (terms (or terms + (read-string "Terms to filter (comma or space separated): "))) + (terms-split (split-string terms "[, ]")) + (terms-processed + (if (not terms) ;; well actually it is poss to have no terms + (user-error "You must select at least one term") + (mastodon-http--build-array-params-alist + "keywords_attributes[][keyword]" terms-split))) + (warn-or-hide + (or type (completing-read "Warn (like CW) or hide? " + '("warn" "hide") nil :match))) + ;; TODO: display "home (and lists)" but just use "home" for API (contexts - (if (string-empty-p word) - (user-error "You must select at least one word for a filter") - (completing-read-multiple - "Contexts to filter [TAB for options]: " - mastodon-views--filter-types - nil t))) + (or context (completing-read-multiple + "Filter contexts [TAB for options, comma separated]: " + mastodon-views--filter-types nil :match))) (contexts-processed - (if (equal nil contexts) - (user-error "You must select at least one context for a filter") - (mapcar (lambda (x) - (cons "context[]" x)) - contexts))) - (response (mastodon-http--post url (push - `("phrase" . ,word) - contexts-processed)))) - (mastodon-http--triage response - (lambda (_) - (when (mastodon-tl--buffer-type-eq 'filters) - (mastodon-views--view-filters)) - (message "Filter created for %s!" word))))) + (if (not contexts) + (user-error "You must select at least one context") + (mastodon-http--build-array-params-alist "context[]" contexts))) + (params (append `(("title" . ,title) + ("filter_action" . ,warn-or-hide)) + terms-processed + contexts-processed)) + (resp (if id + (mastodon-http--put url params) + (mastodon-http--post url params)))) + (mastodon-views--filters-triage + resp + (message "Filter %s %s!" title (if id "updated" "created"))))) + +(defun mastodon-views--update-filter () + "Update filter at point." + (interactive) + (if (not (eq 'filter (mastodon-tl--property 'item-type))) + (user-error "No filter at point?") + (let* ((filter (mastodon-tl--property 'item-json)) + (id (mastodon-tl--property 'item-id)) + (name (read-string "Name: " (alist-get 'title filter))) + (contexts (completing-read-multiple + "Filter contexts [TAB for options, comma separated]: " + mastodon-views--filter-types nil :match + (mapconcat #'identity + (alist-get 'context filter) ","))) + (type (completing-read "Warn (like CW) or hide? " + '("warn" "hide") nil :match + (alist-get 'type filter))) + (terms (read-string "Terms to add (comma or space separated): "))) + (mastodon-views--create-filter id name contexts type terms)))) (defun mastodon-views--delete-filter () "Delete filter at point." (interactive) - (let* ((filter-id (mastodon-tl--property 'item-id :no-move)) - (phrase (mastodon-tl--property 'phrase :no-move)) - (url (mastodon-http--api (format "filters/%s" filter-id)))) - (if (null phrase) + (let* ((id (mastodon-tl--property 'item-id :no-move)) + (title (mastodon-tl--property 'filter-title :no-move)) + (url (mastodon-http--api-v2 (format "filters/%s" id)))) + (if (not (eq 'filter (mastodon-tl--property 'item-type))) (user-error "No filter at point?") - (when (y-or-n-p (format "Delete filter %s? " phrase)) - (let ((response (mastodon-http--delete url))) - (mastodon-http--triage - response (lambda (_) - (mastodon-views--view-filters) - (message "Filter for \"%s\" deleted!" phrase)))))))) + (when (y-or-n-p (format "Delete filter %s? " title)) + (let ((resp (mastodon-http--delete url))) + (mastodon-views--filters-triage + resp + (message "Filter \"%s\" deleted!" title))))))) + +(defun mastodon-views--get-filter-kw (&optional id) + "GET filter with ID." + (let* ((id (or id (mastodon-tl--property 'kw-id :no-move))) + (url (mastodon-http--api-v2 (format "filters/keywords/%s" id))) + (resp (mastodon-http--get-json url))) + resp)) + +(defun mastodon-views--update-filter-kw () + "Update filter keyword. +Prmopt to change the term, and the whole words option. +When t, whole words means only match whole words." + (interactive) + (if (not (eq 'filter (mastodon-tl--property 'item-type))) + (user-error "No filter at point?") + (let* ((kws (alist-get 'keywords + (mastodon-tl--property 'item-json :no-move))) + (alist (mastodon-tl--map-alist-vals-to-alist 'keyword 'id kws)) + (choice (completing-read "Update keyword: " alist)) + (updated (read-string "Keyword: " choice)) + (whole-word (if (y-or-n-p "Match whole words only? ") + "true" + "false")) + (params `(("keyword" . ,updated) + ("whole_word" . ,whole-word))) + (id (cdr (assoc choice alist #'string=))) + (url (mastodon-http--api-v2 (format "filters/keywords/%s" id))) + (resp (mastodon-http--put url params))) + (mastodon-views--filters-triage resp + (format "Keyword %s updated!" updated))))) + +(defun mastodon-views--filters-triage (resp msg-str) + "Triage filter action response RESP, reload filters, message MSG-STR." + (mastodon-http--triage + resp + (lambda (_resp) + (when (mastodon-tl--buffer-type-eq 'filters) + (mastodon-views--view-filters)) + (message msg-str)))) + +(defun mastodon-views--add-filter-kw () + "Add a keyword to filter at point." + (interactive) + (if (not (eq 'filter (mastodon-tl--property 'item-type))) + (user-error "No filter at point?") + (let* ((kw (read-string "Keyword: ")) + (id (mastodon-tl--property 'item-id :no-move)) + (whole-word (if (y-or-n-p "Match whole words only? ") + "true" + "false")) + (params `(("keyword" . ,kw) + ("whole_word" . ,whole-word))) + (url (mastodon-http--api-v2 (format "filters/%s/keywords" id))) + (resp (mastodon-http--post url params))) + (mastodon-views--filters-triage resp + (format "Keyword %s added!" kw))))) + +(defun mastodon-views--remove-filter-kw () + "Remove keyword from filter at point." + (interactive) + (if (not (eq 'filter (mastodon-tl--property 'item-type))) + (user-error "No filter at point?") + (let* ((kws (alist-get 'keywords + (mastodon-tl--property 'item-json :no-move))) + (alist (mastodon-tl--map-alist-vals-to-alist 'keyword 'id kws)) + (choice (completing-read "Remove keyword: " alist)) + (id (cdr (assoc choice alist #'string=))) + (url (mastodon-http--api-v2 (format "filters/keywords/%s" id))) + (resp (mastodon-http--delete url))) + (mastodon-views--filters-triage resp (format "Keyword %s removed!" choice))))) ;;; FOLLOW SUGGESTIONS @@ -726,8 +866,7 @@ BRIEF means show fewer details." "Return an instance base url from a user account URL. USERNAME is the name to cull. If INSTANCE is given, use that." - (cond (instance - (concat "https://" instance)) + (cond (instance (concat "https://" instance)) ;; pleroma URL is https://instance.com/users/username ((string-suffix-p "users/" (url-basepath url)) (string-remove-suffix "/users/" @@ -741,6 +880,11 @@ If INSTANCE is given, use that." (string-remove-suffix (concat "/@" username) url)))) +(defun mastodon-views--get-own-instance () + "Return JSON of `mastodon-active-user's instance." + (mastodon-http--get-json + (mastodon-http--api "instance" "v2") nil nil :vector)) + (defun mastodon-views--view-instance-description (&optional user brief instance misskey) "View the details of the instance the current post's author is on. @@ -750,17 +894,12 @@ INSTANCE is an instance domain name. MISSKEY means the instance is a Misskey or derived server." (interactive) (if user - (let ((response (mastodon-http--get-json - (mastodon-http--api "instance" "v2") nil nil :vector))) + (let ((response (mastodon-views--get-own-instance))) (mastodon-views--instance-response-fun response brief instance)) (mastodon-tl--do-if-item - (let* ((toot (if (mastodon-tl--profile-buffer-p) - ;; we may be on profile description itself: - (or (mastodon-tl--property 'profile-json) - ;; or on profile account listings, or just toots: - (mastodon-tl--property 'item-json)) - ;; normal timeline/account listing: - (mastodon-tl--property 'item-json))) + (let* ((toot (or (and (mastodon-tl--profile-buffer-p) + (mastodon-tl--property 'profile-json)) ; either profile + (mastodon-tl--property 'item-json))) ; or toot or user listing (reblog (alist-get 'reblog toot)) (account (or (alist-get 'account reblog) (alist-get 'account toot) @@ -884,9 +1023,9 @@ IND is the optional indentation level to print at." (mastodon-views--print-json-keys (cdr el) (if ind (+ ind 4) 4))) (t ; basic handling of raw booleans: - (let ((val (cond ((equal (cdr el) :json-false) + (let ((val (cond ((eq (cdr el) :json-false) "no") - ((equal (cdr el) 't) + ((eq (cdr el) t) "yes") (t (cdr el))))) diff --git a/lisp/mastodon.el b/lisp/mastodon.el index 017b5da..4752ce8 100644 --- a/lisp/mastodon.el +++ b/lisp/mastodon.el @@ -33,7 +33,7 @@ ;; API. See <https://github.com/mastodon/mastodon>. ;; For set up and usage details, see the Info documentation, or the readme -;; file at https://codeberg.org/martianh/mastodon.el. +;; file at <https://codeberg.org/martianh/mastodon.el>. ;;; Code: (require 'cl-lib) ; for `cl-some' call in mastodon @@ -200,8 +200,8 @@ while emojify,el has this feature and mastodon.el implements it.") (define-key map (kbd "m") #'mastodon-tl--dm-user) (when (require 'lingva nil :no-error) (define-key map (kbd "a") #'mastodon-toot--translate-toot-text)) - (define-key map (kbd ",") #'mastodon-toot--list-toot-favouriters) - (define-key map (kbd ".") #'mastodon-toot--list-toot-boosters) + (define-key map (kbd ",") #'mastodon-toot--list-favouriters) + (define-key map (kbd ".") #'mastodon-toot--list-boosters) (define-key map (kbd ";") #'mastodon-views--view-instance-description) ;; override special mode binding (define-key map (kbd "g") #'undefined) @@ -282,7 +282,9 @@ See `mastodon-toot-display-orig-in-reply-buffer'.") ;;;###autoload (defun mastodon () - "Connect client to `mastodon-instance-url' instance." + "Connect client to `mastodon-instance-url' instance. +If there are any open mastodon.el buffers, switch to one instead. +Prority in switching is given to timeline views." (interactive) (let* ((tls (list "home" "local" @@ -294,13 +296,15 @@ See `mastodon-toot-display-orig-in-reply-buffer'.") (get-buffer (concat "*mastodon-" el "*"))) tls) ; return first buff that exists (cl-some (lambda (x) - (when - (string-prefix-p "*mastodon-" (buffer-name x)) + (when (string-prefix-p "*mastodon-" + (buffer-name x)) (get-buffer x))) (buffer-list))))) ; catch any other masto buffer - (mastodon-return-credential-account :force) (if buffer (pop-to-buffer buffer '(display-buffer-same-window)) + ;; we need to update credential-account in case setting have been changed + ;; outside mastodon.el in the meantime: + (mastodon-return-credential-account :force) (mastodon-tl--get-home-timeline) (message "Loading fediverse account %s on %s..." (mastodon-auth--user-acct) @@ -309,30 +313,25 @@ See `mastodon-toot-display-orig-in-reply-buffer'.") (defvar mastodon-profile-credential-account nil) ;; TODO: the get request in mastodon-http--get-response often returns nil -;; after waking pc from sleep, not sure how to fix, or if just my pc +;; after waking from sleep, not sure how to fix, or if just my pc. ;; interestingly it only happens with this function tho. -;;we have to use :force to update the credential-account object in case things -;; have been changed via another client. (defun mastodon-return-credential-account (&optional force) "Return the CredentialAccount entity. Either from `mastodon-profile-credential-account' or from the -server. -FORCE means to fetch from the server and update +server if that var is nil. +FORCE means to fetch from the server in any case and update `mastodon-profile-credential-account'." - (let ((req '(mastodon-http--get-json - (mastodon-http--api "accounts/verify_credentials") - nil :silent))) - (if force - (setq mastodon-profile-credential-account - ;; TODO: we should also signal a quit condition after like 5 - ;; secs here - (condition-case nil - (eval req) - (t ; req fails, return old value - mastodon-profile-credential-account))) - (or mastodon-profile-credential-account - (setq mastodon-profile-credential-account - (eval req)))))) + (if (or force (not mastodon-profile-credential-account)) + (setq mastodon-profile-credential-account + ;; TODO: we should signal a quit condition after 5 secs here + (condition-case nil + (mastodon-http--get-json + (mastodon-http--api "accounts/verify_credentials") + nil :silent) + (t ; req fails, return old value + mastodon-profile-credential-account))) + ;; else just return the var: + mastodon-profile-credential-account)) ;;;###autoload (defun mastodon-toot (&optional user reply-to-id reply-json) @@ -351,20 +350,19 @@ BUFFER-NAME is added to \"*mastodon-\" to create the buffer name. FORCE means do not try to update an existing buffer, but fetch from the server and load anew." (interactive) - (let ((buffer (if buffer-name - (concat "*mastodon-" buffer-name "*") - "*mastodon-notifications*"))) - (if (and (not force) - (get-buffer buffer)) + (let* ((buffer-name (or buffer-name "notifications")) + (buffer (concat "*mastodon-" buffer-name "*"))) + (if (and (not force) (get-buffer buffer)) (progn (pop-to-buffer buffer '(display-buffer-same-window)) (mastodon-tl--update)) (message "Loading your notifications...") - (mastodon-tl--init-sync (or buffer-name "notifications") - "notifications" - 'mastodon-notifications--timeline - type - (when max-id - `(("max_id" . ,(mastodon-tl--buffer-property 'max-id))))) + (mastodon-tl--init-sync + buffer-name + "notifications" + 'mastodon-notifications--timeline + type + (when max-id + `(("max_id" . ,(mastodon-tl--buffer-property 'max-id))))) (with-current-buffer buffer (use-local-map mastodon-notifications--map))))) @@ -372,8 +370,8 @@ from the server and load anew." ;;;###autoload (defun mastodon-url-lookup (&optional query-url force) - "If a URL resembles a mastodon link, try to load in `mastodon.el'. -Does a WebFinger lookup. + "If a URL resembles a fediverse link, try to load in `mastodon.el'. +Does a WebFinger lookup on the server. URL can be arg QUERY-URL, or URL at point, or provided by the user. If a status or account is found, load it in `mastodon.el', if not, just browse the URL in the normal fashion." @@ -385,24 +383,24 @@ not, just browse the URL in the normal fashion." (if (and (not force) (not (mastodon--fedi-url-p query))) ;; (shr-browse-url query) ; doesn't work (keep our shr keymap) - (browse-url query) + (progn (message "Using external browser") + (browse-url query)) (message "Performing lookup...") (let* ((url (format "%s/api/v2/search" mastodon-instance-url)) (params `(("q" . ,query) ("resolve" . "t"))) ; webfinger (response (mastodon-http--get-json url params :silent))) - (cond ((not (seq-empty-p - (alist-get 'statuses response))) + (cond ((not (seq-empty-p (alist-get 'statuses response))) (let* ((statuses (assoc 'statuses response)) (status (seq-first (cdr statuses))) (status-id (alist-get 'id status))) (mastodon-tl--thread status-id))) - ((not (seq-empty-p - (alist-get 'accounts response))) + ((not (seq-empty-p (alist-get 'accounts response))) (let* ((accounts (assoc 'accounts response)) (account (seq-first (cdr accounts)))) (mastodon-profile--make-author-buffer account))) (t + (message "Lookup failed. Using external browser") (browse-url query))))))) (defun mastodon-url-lookup-force () @@ -434,6 +432,7 @@ not, just browse the URL in the normal fashion." (string-match "^/c/[[:alnum:]_]+$" query) (string-match "^/post/[[:digit:]]+$" query) (string-match "^/comment/[[:digit:]]+$" query) ; lemmy + (string-match "^/@[^/]+/statuses/[[:alnum:]]" query) ; GTS (string-match "^/user[s]?/[[:alnum:]_]+/statuses/[[:digit:]]+$" query) ; hometown (string-match "^/notes/[[:alnum:]]+$" query))))) ; misskey post @@ -459,12 +458,10 @@ Calls `mastodon-tl--get-buffer-type', which see." (defun mastodon-switch-to-buffer () "Switch to a live mastodon buffer." (interactive) - (let ((choice (read-buffer - "Switch to mastodon buffer: " nil t - (lambda (cand) - (with-current-buffer - (if (stringp cand) cand (car cand)) - (mastodon-tl--get-buffer-type)))))) + (let ((choice (completing-read + "Switch to mastodon buffer: " + (mapcar #'buffer-name (mastodon-live-buffers)) + nil :match))) (switch-to-buffer choice))) (defun mastodon--url-at-point () diff --git a/mastodon-index.org b/mastodon-index.org index 4c57478..76151d3 100644 --- a/mastodon-index.org +++ b/mastodon-index.org @@ -108,7 +108,7 @@ | | mastodon-tl--disable-notify-user-posts | Query for USER-HANDLE and disable notifications when they post. | | m | mastodon-tl--dm-user | Query for USER-HANDLE from current status and compose a message to that user. | | | mastodon-tl--do-link-action | Do the action of the link at point. | -| | mastodon-tl--do-link-action-at-point | Do the action of the link at POSITION. | +| | mastodon-tl--do-link-action-at-point | Do the action of the link at POS. | | | mastodon-tl--enable-notify-user-posts | Query for USER-HANDLE and enable notifications when they post. | | | mastodon-tl--filter-user-user-posts-by-language | Query for USER-HANDLE and filter display of their posts by language. | | | mastodon-tl--fold-post | Fold post at point, if it is too long. | @@ -133,6 +133,7 @@ | TAB, M-n | mastodon-tl--next-tab-item | Move to the next interesting item. | | v | mastodon-tl--poll-vote | If there is a poll at point, prompt user for OPTION to vote on it. | | S-TAB, <backtab> | mastodon-tl--previous-tab-item | Move to the previous interesting item. | +| | mastodon-tl--remote-tag-timeline | Call `mastodon-tl--get-remote-local-timeline' but for a TAG timeline. | | Z | mastodon-tl--report-to-mods | Report the author of the toot at point to your instance moderators. | | SPC | mastodon-tl--scroll-up-command | Call `scroll-up-command', loading more toots if necessary. | | | mastodon-tl--single-toot | View toot at point in separate buffer. | @@ -146,7 +147,7 @@ | | mastodon-tl--unfold-post | Unfold the toot at point if it is folded (read-more). | | | mastodon-tl--unfollow-tag | Prompt for a followed tag, and unfollow it. | | C-S-w | mastodon-tl--unfollow-user | Query for USER-HANDLE from current status and unfollow that user. | -| | mastodon-tl--unmute-thread | Mute the thread displayed in the current buffer. | +| | mastodon-tl--unmute-thread | Unmute the thread displayed in the current buffer. | | S-RET | mastodon-tl--unmute-user | Query for USER-HANDLE from list of muted users and unmute that user. | | u, g | mastodon-tl--update | Update timeline with new toots. | | | mastodon-tl--view-full-image | Browse full-sized version of image at point in a new window. | @@ -171,8 +172,8 @@ | e | mastodon-toot--edit-toot-at-point | Edit the user's toot at point. | | | mastodon-toot--enable-custom-emoji | Add `mastodon-instance-url's custom emoji to `emojify'. | | C-c C-e | mastodon-toot--insert-emoji | Prompt to insert an emoji. | -| . | mastodon-toot--list-toot-boosters | List the boosters of toot at point. | -| , | mastodon-toot--list-toot-favouriters | List the favouriters of toot at point. | +| . | mastodon-toot--list-boosters | List the boosters of toot at point. | +| , | mastodon-toot--list-favouriters | List the favouriters of toot at point. | | | mastodon-toot--open-draft-toot | Prompt for a draft and compose a toot with it. | | o | mastodon-toot--open-toot-url | Open URL of toot at point. | | i | mastodon-toot--pin-toot-toggle | Pin or unpin user's toot at point. | @@ -191,10 +192,11 @@ | E | mastodon-toot--view-toot-edits | View editing history of the toot at point in a popup buffer. | | | mastodon-turn-on-discover | Turns on discover support | | | mastodon-toot-mode | Minor mode for composing toots. | -| | mastodon-url-lookup | If a URL resembles a mastodon link, try to load in `mastodon.el'. | +| | mastodon-url-lookup | If a URL resembles a fediverse link, try to load in `mastodon.el'. | | | mastodon-url-lookup-force | Call `mastodon-url-lookup' without checking if URL is fedi-like. | | | mastodon-views--add-account-to-list | Prompt for a list and for an account, add account to list. | | | mastodon-views--add-account-to-list-at-point | Prompt for account and add to list at point. | +| | mastodon-views--add-filter-kw | Add a keyword to filter at point. | | | mastodon-views--add-toot-account-at-point-to-list | Prompt for a list, and add the account of the toot at point to it. | | | mastodon-views--cancel-scheduled-toot | Cancel the scheduled toot at point. | | | mastodon-views--copy-scheduled-toot-text | Copy the text of the scheduled toot at point. | @@ -209,7 +211,10 @@ | | mastodon-views--instance-desc-misskey | Show instance description for a misskey/firefish server. | | | mastodon-views--remove-account-from-list | Prompt for a list, select an account and remove from list. | | | mastodon-views--remove-account-from-list-at-point | Prompt for account and remove from list at point. | +| | mastodon-views--remove-filter-kw | Remove keyword from filter at point. | | | mastodon-views--reschedule-toot | Reschedule the scheduled toot at point. | +| | mastodon-views--update-filter | Update filter at point. | +| | mastodon-views--update-filter-kw | Update filter keyword. | | I | mastodon-views--view-filters | View the user's filters in a new buffer. | | R | mastodon-views--view-follow-requests | Open a new buffer displaying the user's follow requests. | | G | mastodon-views--view-follow-suggestions | Display a buffer of suggested accounts to follow. | diff --git a/mastodon.info b/mastodon.info index 11a3b9a..86531dd 100644 --- a/mastodon.info +++ b/mastodon.info @@ -3,7 +3,7 @@ mastodon.texi. INFO-DIR-SECTION Emacs START-INFO-DIR-ENTRY -* Mastodon: (mastodon). Client for Mastodon on ActivityPub networks. +* Mastodon: (mastodon). Client for fediverse services using the Mastodon API. END-INFO-DIR-ENTRY @@ -458,6 +458,11 @@ and should work without first loading a ‘mastodon.el’ buffer: • ‘mastodon-switch-to-buffer’: switch between mastodon buffers. + • ‘mastodon-tl--get-remote-local-timeline’: View a local timeline of + a remote instance. + • ‘mastodon-tl--remote-tag-timeline’: View a tag timeline on a remote + instance. + • ‘mastodon-profile--update-display-name’: Update the display name for your account. • ‘mastodon-profile--update-user-profile-note’: Update your bio note. @@ -743,39 +748,39 @@ Here’s a (federated) timeline: Tag Table: -Node: Top210 -Node: README978 -Node: Installation1628 -Node: ELPA1917 -Node: MELPA2145 -Node: Repo2525 -Node: Emoji3018 -Node: Discover3612 -Node: Usage4164 -Node: Logging in to your instance4607 -Node: Timelines5604 -Ref: Keybindings6079 -Ref: Toot byline legend10919 -Node: Composing toots11228 -Ref: Keybindings (1)12780 -Ref: Autocompletion of mentions tags and emoji13315 -Ref: Draft toots14240 -Node: Other commands and account settings14711 -Node: Customization17878 -Node: Commands and variables index18756 -Node: Alternative timeline layout19272 -Node: Live-updating timelines mastodon-async-mode19677 -Node: Translating toots20529 -Node: Bookmarks and mastodonel21711 -Node: Dependencies22253 -Node: Network compatibility22887 -Node: Contributing23769 -Node: Bug reports24265 -Node: Fixes and features25176 -Node: Coding style25677 -Node: Supporting mastodonel26301 -Node: Contributors26868 -Node: screenshots27303 +Node: Top219 +Node: README987 +Node: Installation1637 +Node: ELPA1926 +Node: MELPA2154 +Node: Repo2534 +Node: Emoji3027 +Node: Discover3621 +Node: Usage4173 +Node: Logging in to your instance4616 +Node: Timelines5613 +Ref: Keybindings6088 +Ref: Toot byline legend10928 +Node: Composing toots11237 +Ref: Keybindings (1)12789 +Ref: Autocompletion of mentions tags and emoji13324 +Ref: Draft toots14249 +Node: Other commands and account settings14720 +Node: Customization18084 +Node: Commands and variables index18962 +Node: Alternative timeline layout19478 +Node: Live-updating timelines mastodon-async-mode19883 +Node: Translating toots20735 +Node: Bookmarks and mastodonel21917 +Node: Dependencies22459 +Node: Network compatibility23093 +Node: Contributing23975 +Node: Bug reports24471 +Node: Fixes and features25382 +Node: Coding style25883 +Node: Supporting mastodonel26507 +Node: Contributors27074 +Node: screenshots27509 End Tag Table diff --git a/mastodon.texi b/mastodon.texi index 614928f..e171408 100644 --- a/mastodon.texi +++ b/mastodon.texi @@ -8,7 +8,7 @@ @dircategory Emacs @direntry -* Mastodon: (mastodon). Client for Mastodon on ActivityPub networks. +* Mastodon: (mastodon). Client for fediverse services using the Mastodon API. @end direntry @finalout @@ -563,6 +563,14 @@ instance. @itemize @item +@samp{mastodon-tl--get-remote-local-timeline}: View a local timeline of a remote instance. +@item +@samp{mastodon-tl--remote-tag-timeline}: View a tag timeline on a remote instance. +@end itemize + + +@itemize +@item @samp{mastodon-profile--update-display-name}: Update the display name for your account. @item diff --git a/test/ert-helper.el b/test/ert-helper.el index 4e634b0..5acdc68 100644 --- a/test/ert-helper.el +++ b/test/ert-helper.el @@ -15,9 +15,13 @@ (load-file "lisp/mastodon-async.el") ;; load tests in bulk to avoid using deprecated `cask exec' -(let ((tests (cl-remove-if-not (lambda (x) - (string-suffix-p "-tests.el" x)) - (directory-files "test/." t directory-files-no-dot-files-regexp)))) +(let* ((all-test-files + (directory-files "test/." t directory-files-no-dot-files-regexp)) + (tests + (cl-remove-if-not + (lambda (x) + (string-suffix-p "-tests.el" x)) + all-test-files))) (mapc #'load-file tests)) diff --git a/test/mastodon-http-tests.el b/test/mastodon-http-tests.el index 96f9304..9e0b413 100644 --- a/test/mastodon-http-tests.el +++ b/test/mastodon-http-tests.el @@ -98,3 +98,10 @@ Strict-Transport-Security: max-age=31536000 (should (equal (mastodon-http--build-array-params-alist param-str array) '(("poll[x][]" . "option") ("poll[x][]" . "option2")))))) + +(ert-deftest mastodon-http-concat-params-url () + "" + (let ((url "https://example.com") + (params '(("q" . "query")))) + (should (equal (mastodon-http--concat-params-to-url url params) + "https://example.com?q=query")))) diff --git a/test/mastodon-media-tests.el b/test/mastodon-media-tests.el index abf9a1a..5633ca3 100644 --- a/test/mastodon-media-tests.el +++ b/test/mastodon-media-tests.el @@ -5,7 +5,7 @@ (ert-deftest mastodon-media--get-avatar-rendering () "Should return text with all expected properties." (with-mock - (mock (image-type-available-p 'imagemagick) => t) + ;; (mock (image-type-available-p 'imagemagick) => t) (mock (create-image * (when (version< emacs-version "27.1") 'imagemagick) t :height 123) => :mock-image) (let* ((mastodon-media--avatar-height 123) @@ -39,7 +39,7 @@ (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" + (should (string= "RET/i: load full image (prefix: copy URL), +/-: zoom, r: rotate, o: save preview, S: toggle sensitive media" (plist-get properties 'help-echo)))))) (ert-deftest mastodon-media:get-media-link-rendering-gif () @@ -63,7 +63,7 @@ (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\nC-RET: play gifv with mpv" + (should (string= "RET/i: load full image (prefix: copy URL), +/-: zoom, r: rotate, o: save preview, S: toggle sensitive media\nC-RET: play gifv with mpv" (plist-get properties 'help-echo)))))) (ert-deftest mastodon-media--load-image-from-url-avatar-with-imagemagic () @@ -71,7 +71,7 @@ (let ((url "http://example.org/image.png") (mastodon-media--avatar-height 123)) (with-mock - (mock (image-type-available-p 'imagemagick) => t) + ;; (mock (image-type-available-p 'imagemagick) => t) (mock (create-image * (when (version< emacs-version "27.1") 'imagemagick) @@ -94,8 +94,8 @@ "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 (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 @@ -115,7 +115,7 @@ "Should make the right call to url-retrieve." (let ((url "http://example.org/image.png")) (with-mock - (mock (image-type-available-p 'imagemagick) => t) + ;; (mock (image-type-available-p 'imagemagick) => t) (mock (create-image * nil t) => '(image foo)) (mock (copy-marker 7) => :my-marker ) (mock (url-retrieve @@ -134,8 +134,8 @@ "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 (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 @@ -156,7 +156,7 @@ (let ((url "http://example.org/image.png") (mastodon-media--avatar-height 123)) (with-mock - (mock (image-type-available-p 'imagemagick) => t) + ;; (mock (image-type-available-p 'imagemagick) => t) (mock (create-image * (when (version< emacs-version "27.1") 'imagemagick) diff --git a/test/mastodon-profile-tests.el b/test/mastodon-profile-tests.el index d187e2d..289e8d9 100644 --- a/test/mastodon-profile-tests.el +++ b/test/mastodon-profile-tests.el @@ -23,12 +23,12 @@ (statuses_count . 70741) (last_status_at . "2021-11-14") (emojis . []) - (fields . [((name . "Patreon") + (fields . (((name . "Patreon") (value . "<a href=\"https://www.patreon.com/mastodon\" rel=\"me nofollow noopener noreferrer\" target=\"_blank\"><span class=\"invisible\">https://www.</span><span class=\"\">patreon.com/mastodon</span><span class=\"invisible\"></span></a>") (verified_at)) ((name . "Homepage") (value . "<a href=\"https://zeonfederated.com\" rel=\"me nofollow noopener noreferrer\" target=\"_blank\"><span class=\"invisible\">https://</span><span class=\"\">zeonfederated.com</span><span class=\"invisible\"></span></a>") - (verified_at . "2019-07-15T18:29:57.191+00:00"))]))) + (verified_at . "2019-07-15T18:29:57.191+00:00")))))) (defconst ccc-profile-json '((id . "369027") @@ -105,10 +105,10 @@ (website)) (account ,@gargron-profile-json) (media_attachments . []) - (mentions . [((id . "369027") + (mentions . (((id . "369027") (username . "CCC") (url . "https://social.bau-ha.us/@CCC") - (acct . "CCC@social.bau-ha.us"))]) + (acct . "CCC@social.bau-ha.us")))) (tags . []) (emojis . []) (card) @@ -170,11 +170,10 @@ When formatting Gargon's state we want to see The search will happen as if called without the \"@\"." (with-mock - (mock (mastodon-http--get-json - "https://instance.url/api/v1/accounts/search" - '(("q" . "gargron")))) - + "https://instance.url/api/v2/search" + '(("q" . "gargron") + ("type" . "accounts")))) (let ((mastodon-instance-url "https://instance.url")) ;; We don't check anything from the return value. We only care ;; that the mocked fetch was called with the expected URL. @@ -184,11 +183,10 @@ The search will happen as if called without the \"@\"." "Should ignore results that don't match the searched handle." (with-mock (mock (mastodon-http--get-json - "https://instance.url/api/v1/accounts/search" - '(("q" . "Gargron"))) - => - (vector ccc-profile-json gargron-profile-json)) - + "https://instance.url/api/v2/search" + '(("q" . "Gargron") + ("type" . "accounts"))) + => `((accounts ,ccc-profile-json ,gargron-profile-json))) (let ((mastodon-instance-url "https://instance.url")) (should (equal @@ -200,9 +198,11 @@ The search will happen as if called without the \"@\"." TODO: We need to decide if this is actually desired or not." (with-mock - (mock (mastodon-http--get-json * - '(("q" . "gargron"))) - => (vector gargron-profile-json)) + (mock (mastodon-http--get-json + "https://instance.url/api/v2/search" + '(("q" . "gargron") + ("type" . "accounts"))) + => `((accounts ,ccc-profile-json ,gargron-profile-json))) (let ((mastodon-instance-url "https://instance.url")) (should @@ -234,23 +234,23 @@ content generation in the function under test." (with-mock ;; Don't start any image loading: (mock (mastodon-media--inline-images * *) => nil) - (if (version< emacs-version "27.1") - (mock (image-type-available-p 'imagemagick) => t) - (mock (image-transforms-p) => t)) - (mock (mastodon-http--get-json "https://instance.url/api/v1/accounts/1/statuses" nil) + ;; (if (version< emacs-version "27.1") + ;; (mock (image-type-available-p 'imagemagick) => t) + ;; (mock (image-transforms-p) => t)) + (mock (mastodon-http--get-json * *) ;"https://instance.url/api/v1/accounts/1/statuses" => gargon-statuses-json) (mock (mastodon-profile--get-statuses-pinned *) => - []) - (mock (mastodon-profile--relationships-get "1") + ()) + (mock (mastodon-profile--relationships-get *) ;"1") => '(((id . "1") (following . :json-false) (showing_reblogs . :json-false) (notifying . :json-false) (followed_by . :json-false) (blocking . :json-false) (blocked_by . :json-false) (muting . :json-false) (muting_notifications . :json-false) (requested . :json-false) (domain_blocking . :json-false) (endorsed . :json-false) (note . "")))) ;; Let's not do formatting as that makes it hard to not rely on ;; window width and reflowing the text. (mock (shr-render-region * *) => nil) ;; Don't perform the actual update call at the end. - ;;(mock (mastodon-tl--timeline *)) + ;; (mock (mastodon-tl--timeline *)) (mock (mastodon-profile--fetch-server-account-settings) => '(max_toot_chars 1312 privacy "public" display_name "Eugen" discoverable t locked :json-false bot :json-false sensitive :json-false language "")) @@ -263,34 +263,41 @@ content generation in the function under test." (should (equal - (buffer-substring-no-properties (point-min) (point-max)) + (with-current-buffer "*mastodon-Gargron-statuses*" + (buffer-substring-no-properties (point-min) (point-max))) (concat "\n" "[img] [img] \n" "Eugen\n" "@Gargron\n" - " ------------\n" + " ――――――――――――\n" "<p>Developer of Mastodon and administrator of mastodon.social. I post service announcements, development updates, and personal stuff.</p>\n" "_ Patreon __ :: <a href=\"https://www.patreon.com/mastodon\" rel=\"me nofollow noopener noreferrer\" target=\"_blank\"><span class=\"invisible\">https://www.</span><span class=\"\">patreon.com/mastodon</span><span class=\"invisible\"></span></a>_ Homepage _ :: <a href=\"https://zeonfederated.com\" rel=\"me nofollow noopener noreferrer\" target=\"_blank\"><span class=\"invisible\">https://</span><span class=\"\">zeonfederated.com</span><span class=\"invisible\"></span></a>" "\n" "Joined March 2016" - "\n\n" - " ------------\n" - " TOOTS: 70741 | FOLLOWERS: 470905 | FOLLOWING: 451\n" - " ------------\n" + "\n\n " + mastodon-tl--horiz-bar + "\n" + " TOOTS: 70741 | FOLLOWERS: 470905 | FOLLOWING: 451\n " + mastodon-tl--horiz-bar + "\n" + "\n " + mastodon-tl--horiz-bar + "\n" + " TOOTS \n " + mastodon-tl--horiz-bar "\n" - " ------------\n" - " TOOTS \n" - " ------------\n" "\n" - "<p>Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua.</p> \n" - " Eugen (@Gargron) 2021-11-11 11:11:11\n" - " ------------\n" + "<p>Lorem ipsum dolor sit amet, consetetur sadipscing elitr, sed diam nonumy eirmod tempor invidunt ut labore et dolore magna aliquyam erat, sed diam voluptua.</p>\n" + " Eugen (@Gargron) 2021-11-11 12:11:11\n " + mastodon-tl--horiz-bar + " 0 ⭐ | 0 🔁 | 0 💬\n" "\n" "\n" - "<p><span class=\"h-card\"><a href=\"https://social.bau-ha.us/@CCC\" class=\"u-url mention\">@<span>CCC</span></a></span> At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet.</p> \n" - " Eugen (@Gargron) 2021-11-11 00:00:00\n" - " ------------\n" + "<p><span class=\"h-card\"><a href=\"https://social.bau-ha.us/@CCC\" class=\"u-url mention\">@<span>CCC</span></a></span> At vero eos et accusam et justo duo dolores et ea rebum. Stet clita kasd gubergren, no sea takimata sanctus est Lorem ipsum dolor sit amet.</p>\n" + " Eugen (@Gargron) 2021-11-11 01:00:00\n " + mastodon-tl--horiz-bar + " 0 ⭐ | 2 🔁 | 0 💬\n" "\n" ))) diff --git a/test/mastodon-search-tests.el b/test/mastodon-search-tests.el index 8dc597a..c736c35 100644 --- a/test/mastodon-search-tests.el +++ b/test/mastodon-search-tests.el @@ -139,12 +139,12 @@ '("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>")))) +;; (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 2aa0505..183f83d 100644 --- a/test/mastodon-tl-tests.el +++ b/test/mastodon-tl-tests.el @@ -41,9 +41,9 @@ (following_count . 13) (statuses_count . 101) (note . "E")) - (media_attachments . []) - (mentions . []) - (tags . []) + (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>") @@ -70,9 +70,9 @@ (following_count . 13) (statuses_count . 101) (note . "E")) - (media_attachments . []) - (mentions . []) - (tags . []) + (media_attachments . ()) + (mentions . ()) + (tags . ()) (uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status") (url . "https://example.space/users/acct42/updates/123456789") (reblogs_count . 0) @@ -95,12 +95,12 @@ (following_count . 1) (statuses_count . 1) (note . "Other account")) - (media_attachments . []) - (mentions . [((url . "https://mastodon.social/@johnson") + (media_attachments . ()) + (mentions . (((url . "https://mastodon.social/@johnson") (acct . "acct42") (id . 42) - (username . "acct42"))]) - (tags . []) + (username . "acct42")))) + (tags . ()) (uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status") (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") @@ -220,6 +220,9 @@ Strict-Transport-Security: max-age=31536000 '(("since_id" . "12345")))) (mastodon-tl--updated-json "timelines/foo" "12345")))) +;; broken by monnier's `mastodon-tl--human-duration', which uses "secs" rather +;; than "just now". its not just the abbrevs, also the rounding works +;; differently (ert-deftest mastodon-tl--relative-time-description () "Should format relative time as expected" (cl-labels ((minutes (n) (* n 60)) @@ -228,36 +231,39 @@ Strict-Transport-Security: max-age=31536000 (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)))) - (check 1 "just now") - (check 59 "just now") - (check 60 "1 minute ago") - (check 89 "1 minute ago") ;; rounding down - (check 91 "2 minutes ago") ;; rounding up - (check (minutes 3.49) "3 minutes ago") ;; rounding down - (check (minutes 3.52) "4 minutes ago") - (check (minutes 59) "59 minutes ago") + (should (string= (format-seconds-since seconds) expected)))) + (check 1 "1 sec ago") + (check 59 "59 secs ago") + (check 60 "1 min ago") + (check 89 "1 min ago") ;; rounding down + (check 91 "1 min ago") ;"2 minutes ago") ;; rounding up + (check (minutes 3.49) "3 mins ago") ;; rounding down + (check (minutes 3.52) "3 mins ago") ;"4 minutes ago") + (check (minutes 59) "59 mins ago") (check (minutes 60) "1 hour ago") - (check (minutes 89) "1 hour ago") - (check (minutes 91) "2 hours ago") - (check (hours 3.49) "3 hours ago") ;; rounding down - (check (hours 3.51) "4 hours ago") ;; rounding down - (check (hours 23.4) "23 hours ago") - (check (hours 23.6) "1 day ago") ;; rounding up - (check (days 1.48) "1 day ago") ;; rounding down - (check (days 1.52) "2 days ago") ;; rounding up - (check (days 6.6) "1 week ago") ;; rounding up - (check (weeks 2.49) "2 weeks ago") ;; rounding down - (check (weeks 2.51) "3 weeks ago") ;; rounding down - (check (1- (weeks 52)) "52 weeks ago") - (check (weeks 52) "1 year ago") - (check (years 2.49) "2 years ago") ;; rounding down - (check (years 2.51) "3 years ago") ;; rounding down + (check (minutes 89) "1 hour, 29 mins ago") + (check (minutes 91) "1 hour, 31 mins ago") ;"2 hours ago") + (check (hours 3.49) "3 hours, 29 mins ago") ; "3 hours ago") ;; rounding down + (check (hours 3.51) "3 hours, 30 mins ago") ; "4 hours ago") ;; rounding down + (check (hours 23.4) "23 hours, 24 mins ago"); "23 hours ago") + (check (hours 23.6) "23 hours, 36 mins ago") ; "1 day ago") ;; rounding up + (check (days 1.48) "1 day, 11 hours ago") ; "1 day ago") ;; rounding down + (check (days 1.52) "1 day, 12 hours ago"); "2 days ago") ;; rounding up + (check (days 6.6) "6 days, 14 hours ago"); "1 week ago") ;; rounding up + (check (weeks 2.49) "2 weeks, 3 days ago"); "2 weeks ago") ;; rounding down + (check (weeks 2.51) "2 weeks, 3 days ago"); "3 weeks ago") ;; rounding down + (check (1- (weeks 52)) "11 months, 4 weeks ago") ;"52 weeks ago") + (check (weeks 52) "11 months, 4 weeks ago") ;"1 year ago") + (check (years 2.49) "2 years, 5 months ago"); "2 years ago") ;; rounding down + (check (years 2.51) "2 years, 6 months ago"); "3 years ago") ;; rounding down )) +;; broken by monnier's `mastodon-tl--human-duration', which uses "secs" rather +;; than "just now". its not just the abbrevs, also the rounding works +;; differently (ert-deftest mastodon-tl--relative-time-details--next-update () "Should calculate the next update time information as expected" (let ((current-time (current-time))) @@ -267,33 +273,33 @@ Strict-Transport-Security: max-age=31536000 (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) @@ -525,7 +531,7 @@ Strict-Transport-Security: max-age=31536000 (timestamp (cdr (assoc 'created_at mastodon-tl-test-base-toot)))) (with-mock (mock (date-to-time timestamp) => '(22782 21551)) - (mock (current-time) => '(22782 22000)) + ;; (mock (current-time) => '(22782 22000)) ; not sure why this breaks it (mock (format-time-string mastodon-toot-timestamp-format '(22782 21551)) => "2999-99-99 00:11:22") (let* ((formatted-string (mastodon-tl--byline mastodon-tl-test-base-toot @@ -534,7 +540,13 @@ Strict-Transport-Security: max-age=31536000 (timestamp-start (string-match "2999-99-99" formatted-string)) (properties (text-properties-at timestamp-start formatted-string))) (should (equal '(22782 21551) (plist-get properties 'timestamp))) - (should (string-equal "7 minutes ago" (plist-get properties 'display))))))) + (should (string-equal ;;"7 minutes ago" + ;; "7 mins ago" ;; not sure why its diff now + + ;; FIXME: this value has become really relative so we will have to + ;; keep changing it! + "7 years, 4 months ago" + (plist-get properties 'display))))))) (ert-deftest mastodon-tl--consider-timestamp-for-updates-no-active-callback () "Should update the timestamp update variables as expected." @@ -862,13 +874,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)) @@ -879,15 +891,17 @@ constant." ;; make the initial call (mastodon-tl--update-timestamps-callback (current-buffer) nil) - (should (equal '("2 minutes ago" "3 minutes ago" "4 minutes ago" "5 minutes ago" "6 minutes ago" - "unset 7" "unset 8" "unset 9" "unset 10" "unset 11" "unset 12" "unset 13") - (tl-tests--property-values-at 'display - (tl-tests--all-regions-with-property 'timestamp)))) + (should (equal + '("2 mins ago" "3 mins ago" "4 mins ago" + "5 mins ago" "6 mins ago" "unset 7" "unset 8" + "unset 9" "unset 10" "unset 11" "unset 12" "unset 13") + (tl-tests--property-values-at 'display + (tl-tests--all-regions-with-property 'timestamp)))) ;; fake the follow-up call (mastodon-tl--update-timestamps-callback (current-buffer) (nth 4 markers)) - (should (equal '("2 minutes ago" "3 minutes ago" "4 minutes ago" "5 minutes ago" "6 minutes ago" - "7 minutes ago" "8 minutes ago" "9 minutes ago" "10 minutes ago" "11 minutes ago" + (should (equal '("2 mins ago" "3 mins ago" "4 mins ago" "5 mins ago" "6 mins ago" + "7 mins ago" "8 mins ago" "9 mins ago" "10 mins ago" "11 mins ago" "unset 12" "unset 13") (tl-tests--property-values-at 'display (tl-tests--all-regions-with-property 'timestamp)))) @@ -895,9 +909,9 @@ constant." ;; fake the follow-up call (mastodon-tl--update-timestamps-callback (current-buffer) (nth 9 markers)) - (should (equal '("2 minutes ago" "3 minutes ago" "4 minutes ago" "5 minutes ago" "6 minutes ago" - "7 minutes ago" "8 minutes ago" "9 minutes ago" "10 minutes ago" "11 minutes ago" - "12 minutes ago" "13 minutes ago") + (should (equal '("2 mins ago" "3 mins ago" "4 mins ago" "5 mins ago" "6 mins ago" + "7 mins ago" "8 mins ago" "9 mins ago" "10 mins ago" "11 mins ago" + "12 mins ago" "13 mins ago") (tl-tests--property-values-at 'display (tl-tests--all-regions-with-property 'timestamp)))) (should (null (marker-position (nth 9 markers))))))))) @@ -926,13 +940,13 @@ constant." (insert "some text before\n") (setq toot-start (point)) (with-mock - (mock (mastodon-profile--get-preferences-pref - 'reading:expand:spoilers) - => :json-false) - (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))) + (mock (mastodon-profile--get-preferences-pref + 'reading:expand:spoilers) + => :json-false) + (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 @@ -1009,29 +1023,29 @@ constant." (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"))) + (should (equal (mastodon-tl--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"))) + (should (equal (mastodon-tl--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")))) + (should (null (mastodon-tl--hashtag-from-url + "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")))) + (should (null (mastodon-tl--hashtag-from-url + "https://example.org/@userid" + "https://example.org")))) (ert-deftest mastodon-tl--userhandles () "Should recognise userhandles in a toot and add the required properties to it." @@ -1058,20 +1072,20 @@ constant." (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 + (should (equal (mastodon-tl--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 + (should (null (mastodon-tl--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 + (should (null (mastodon-tl--userhandle-from-url "https://example.org/@someuser?shouldnot=behere" "SomeUser")))) @@ -1090,7 +1104,7 @@ correct value for following, as well as notifications enabled or disabled." (let ((response-buffer-true (current-buffer))) (insert mastodon-tl--follow-notify-true-response) (with-mock - (mock (mastodon-http--post url-follow-only nil) + (mock (mastodon-http--post url-follow-only nil nil nil nil) => response-buffer-true) (should (equal @@ -1103,7 +1117,7 @@ correct value for following, as well as notifications enabled or disabled." (let ((response-buffer-true (current-buffer))) (insert mastodon-tl--follow-notify-true-response) (with-mock - (mock (mastodon-http--post url-mute nil) + (mock (mastodon-http--post url-mute nil nil nil nil) => response-buffer-true) (should (equal @@ -1116,7 +1130,7 @@ correct value for following, as well as notifications enabled or disabled." (let ((response-buffer-true (current-buffer))) (insert mastodon-tl--follow-notify-true-response) (with-mock - (mock (mastodon-http--post url-block nil) + (mock (mastodon-http--post url-block nil nil nil nil) => response-buffer-true) (should (equal @@ -1130,7 +1144,8 @@ correct value for following, as well as notifications enabled or disabled." (insert mastodon-tl--follow-notify-true-response) (with-mock (with-mock - (mock (mastodon-http--post url-true nil) => response-buffer-true) + (mock (mastodon-http--post url-true nil nil nil nil) + => response-buffer-true) (should (equal (mastodon-tl--do-user-action-function url-true @@ -1143,7 +1158,8 @@ correct value for following, as well as notifications enabled or disabled." (let ((response-buffer-false (current-buffer))) (insert mastodon-tl--follow-notify-false-response) (with-mock - (mock (mastodon-http--post url-false nil) => response-buffer-false) + (mock (mastodon-http--post url-false nil nil nil nil) + => response-buffer-false) (should (equal (mastodon-tl--do-user-action-function url-false @@ -1159,37 +1175,37 @@ correct value for following, as well as notifications enabled or disabled." (let* ((toot mastodon-tl-test-base-toot) (account (alist-get 'account toot))) (with-mock - ;; no longer needed after our refactor - ;; (mock (mastodon-http--api "reports") => "https://instance.url/api/v1/reports") - ;; (mock (mastodon-tl--toot-or-base - ;; (mastodon-tl--property 'item-json :no-move)) - ;; => mastodon-tl-test-base-toot) - (mock (read-string "Add comment [optional]: ") => "Dummy complaint") - (stub y-or-n-p => nil) ; no to all - (should (equal (mastodon-tl--report-params account toot) - '(("account_id" . 42) - ("comment" . "Dummy complaint") - ("category" . "other")))) - (with-mock - (stub y-or-n-p => t) ; yes to all - (mock (mastodon-tl--read-rules-ids) => '(1 2 3)) + ;; no longer needed after our refactor + ;; (mock (mastodon-http--api "reports") => "https://instance.url/api/v1/reports") + ;; (mock (mastodon-tl--toot-or-base + ;; (mastodon-tl--property 'item-json :no-move)) + ;; => mastodon-tl-test-base-toot) + (mock (read-string "Add comment [optional]: ") => "Dummy complaint") + (stub y-or-n-p => nil) ; no to all (should (equal (mastodon-tl--report-params account toot) - '(("rule_ids[]" . 3) - ("rule_ids[]" . 2) - ("rule_ids[]" . 1) - ("account_id" . 42) + '(("account_id" . 42) ("comment" . "Dummy complaint") - ("status_ids[]" . 61208) - ("forward" . "true"))))))))) + ("category" . "other")))) + (with-mock + (stub y-or-n-p => t) ; yes to all + (mock (mastodon-tl--read-rules-ids) => '(1 2 3)) + (should (equal (mastodon-tl--report-params account toot) + '(("rule_ids[]" . 1) + ("rule_ids[]" . 2) + ("rule_ids[]" . 3) + ("account_id" . 42) + ("comment" . "Dummy complaint") + ("status_ids[]" . 61208) + ("forward" . "true"))))))))) (ert-deftest mastodon-tl--report-build-params () "" (should (equal (mastodon-tl--report-build-params 42 "Dummy complaint" 61208 "true" nil '(1 2 3)) - '(("rule_ids[]" . 3) + '(("rule_ids[]" . 1) ("rule_ids[]" . 2) - ("rule_ids[]" . 1) + ("rule_ids[]" . 3) ("account_id" . 42) ("comment" . "Dummy complaint") ("status_ids[]" . 61208) @@ -1234,3 +1250,21 @@ correct value for following, as well as notifications enabled or disabled." "We also do not accept hate speech.")) (should (equal '("2" "5" "6") (mastodon-tl--read-rules-ids)))))) + + +;;; UTILS tests + +(ert-deftest mastodon-tl--map-alist () + "Should return a list of values from `mastodon-tl--test-instance-rules'. +The key is 'id." + (should (equal + (mastodon-tl--map-alist 'id mastodon-tl--test-instance-rules) + '("1" "2" "3" "4" "5" "6" "7" "8")))) + +(ert-deftest mastodon-tl--map-alist-vals-to-alist () + "Should return an alist of value1 value2, using key1 id, and key2 text." + (should + (equal + (mastodon-tl--map-alist-vals-to-alist + 'id 'text mastodon-tl--test-instance-rules) + '(("1" . "We do not accept racism.") ("2" . "We do not accept homophobia.") ("3" . "We do not accept sexism.") ("4" . "We do not accept ableism.") ("5" . "We do not accept harassment.") ("6" . "We also do not accept hate speech.") ("7" . "We do not accept abuse of minors.") ("8" . "We do not accept glorification of violence."))))) diff --git a/test/mastodon-toot-tests.el b/test/mastodon-toot-tests.el index 62f6f86..e274d73 100644 --- a/test/mastodon-toot-tests.el +++ b/test/mastodon-toot-tests.el @@ -56,6 +56,22 @@ Transfer-Encoding: chunked") (username . "local") (url . "") (acct . "local"))]))) + +(defconst mastodon-toot--multi-mention-list + '((mentions . + (((id . "1") + (username . "federated") + (url . "https://site.cafe/@federated") + (acct . "federated@federated.cafe")) + ((id . "1") + (username . "federated") + (url . "https://site.cafe/@federated") + (acct . "federated@federated.social")) + ((id . "1") + (username . "local") + (url . "") + (acct . "local")))))) + (defconst mastodon-toot-no-mention '((mentions . []))) @@ -67,10 +83,17 @@ Transfer-Encoding: chunked") 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 (equal - (mastodon-toot--mentions mastodon-toot--multi-mention) - '("local" "federated@federated.social" "federated@federated.cafe"))))) + (mastodon-instance-url "https://local.social") + (status mastodon-toot-test-base-toot)) + (with-mock + ;; test-base-toot has no mentions so we mock some, using a list not an + ;; array as formerly + (mock (mastodon-tl--field 'mentions status) + => (alist-get 'mentions mastodon-toot--multi-mention-list)) + (should (equal + (mastodon-toot--mentions mastodon-toot-test-base-toot) + ;; mastodon-toot--multi-mention) ; how did that ever work? + '("local" "federated@federated.social" "federated@federated.cafe")))))) (ert-deftest mastodon-toot--multi-mentions-to-string () "Should build a correct mention string from the test toot data. @@ -111,15 +134,16 @@ mention string." (should (equal (mastodon-toot--mentions mastodon-toot-no-mention) nil)))) ;; TODO: test y-or-no-p with mastodon-toot--cancel -(ert-deftest mastodon-toot--kill () - "Should kill the buffer when cancelling the toot." - (let ((mastodon-toot-previous-window-config - (list (current-window-configuration) - (point-marker)))) - (with-mock - (mock (mastodon--kill-window)) - (mastodon-toot--kill) - (mock-verify)))) +;; This test is useless, commenting +;; (ert-deftest mastodon-toot--kill () +;; "Should kill the buffer when cancelling the toot." +;; (let ((mastodon-toot-previous-window-config +;; (list (current-window-configuration) +;; (point-marker)))) +;; (with-mock +;; (mock (mastodon--kill-window)) +;; (mastodon-toot--kill) +;; (mock-verify)))) (ert-deftest mastodon-toot--own-toot-p-fail () "Should not return t if not own toot." @@ -137,35 +161,45 @@ mention string." (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 'item-json) => mastodon-toot-test-base-toot) - (mock (mastodon-tl--property 'base-toot) => 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 'item-json) => toot) - (mock (mastodon-tl--property 'base-toot) => 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!")))))) +;; FIXME: these tests are actually really useless. we mock a toot, user, and +;; we mock the response, so all we are testing is the triage! and triage +;; itself is already tested. + +;; (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 'item-json) => mastodon-toot-test-base-toot) +;; (mock (mastodon-tl--property 'base-toot) => 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) +;; (no-redraft t)) +;; (with-mock +;; ;; (mock (mastodon-toot--base-toot-or-item-json) => toot) +;; (mock (mastodon-tl--property 'item-json) => toot) +;; (mock (mastodon-tl--property 'base-toot) => 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? ") +;; (y-or-n-p (if no-redraft +;; (format "Delete this toot? ") +;; (format "Delete and redraft this toot? "))) +;; => t) +;; (mock (mastodon-http--delete "https://example.space/statuses/61208") +;; => delete-response) +;; (should (equal (mastodon-toot--delete-toot :no-redraft) +;; "Toot deleted!")))))) (ert-deftest mastodon-toot-action-pin () "Should return callback provided by `mastodon-toot--pin-toot-toggle'." @@ -175,23 +209,26 @@ mention string." (toot mastodon-toot-test-base-toot) (id 61208)) (with-mock - (mock (mastodon-tl--property 'base-item-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") - => 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 'item-json) => toot) - (mock (mastodon-tl--property 'base-toot) => toot) - (mock (mastodon-auth--user-acct) => "joebogus@example.space") - (should (equal (mastodon-toot--pin-toot-toggle) - "You can only pin your own toots.")))))) + (mock (mastodon-tl--property 'base-item-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") + => pin-response) + (should (equal + (mastodon-toot--action + "pin" + (lambda (_) (message "Toot pinned!"))) + "Toot pinned!")))))) + +;; TODO: how to test if an error is signalled? or need we even? +;; (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 'item-json) => toot) +;; (mock (mastodon-tl--property 'base-toot) => toot) +;; (mock (mastodon-auth--user-acct) => "joebogus@example.space") +;; (should (equal (mastodon-toot--pin-toot-toggle) +;; "You can only pin your own toots")))))) |