diff options
| -rw-r--r-- | README.org | 39 | ||||
| -rw-r--r-- | fixture/client.plstore | 3 | ||||
| -rw-r--r-- | lisp/mastodon-auth.el | 44 | ||||
| -rw-r--r-- | lisp/mastodon-client.el | 38 | ||||
| -rw-r--r-- | lisp/mastodon-http.el | 14 | ||||
| -rw-r--r-- | lisp/mastodon-inspect.el | 4 | ||||
| -rw-r--r-- | lisp/mastodon-media.el | 71 | ||||
| -rw-r--r-- | lisp/mastodon-tl.el | 581 | ||||
| -rw-r--r-- | lisp/mastodon-toot.el | 50 | ||||
| -rw-r--r-- | lisp/mastodon.el | 11 | ||||
| -rw-r--r-- | test/mastodon-auth-tests.el | 15 | ||||
| -rw-r--r-- | test/mastodon-client-tests.el | 72 | ||||
| -rw-r--r-- | test/mastodon-tl-tests.el | 589 | ||||
| -rw-r--r-- | test/mastodon-toot-tests.el | 39 |
14 files changed, 1378 insertions, 192 deletions
@@ -73,24 +73,27 @@ Opens a =*mastodon-home*= buffer in the major mode so you can see toots. You wil **** Keybindings -|-----+------------------------------------------------| -| Key | Action | -|-----+------------------------------------------------| -| =?= | Open context menu (if =discover= is available) | -| =b= | Boost toot under =point= | -| =f= | Favourite toot under =point= | -| =F= | Open federated timeline | -| =H= | Open home timeline | -| =j= | Go to next toot | -| =k= | Go to previous toot | -| =L= | Open local timeline | -| =n= | Switch to =mastodon-toot= buffer | -| =q= | Quit mastodon buffer. Leave window open. | -| =Q= | Quit mastodon buffer and kill window. | -| =r= | Reply to toot under =point=. | -| =t= | Open thread buffer for toot under =point=. | -| =T= | Prompt for tag and open its timeline | -|-----+------------------------------------------------| +|--------------------------+-----------------------------------------------------------------------------------| +| Key | Action | +|--------------------------+-----------------------------------------------------------------------------------| +| =?= | Open context menu (if =discover= is available) | +| =b= | Boost toot under =point= | +| =f= | Favourite toot under =point= | +| =F= | Open federated timeline | +| =H= | Open home timeline | +| =j= | Go to next toot | +| =k= | Go to previous toot | +| =L= | Open local timeline | +| =n= | Switch to =mastodon-toot= buffer | +| =q= | Quit mastodon buffer. Leave window open. | +| =Q= | Quit mastodon buffer and kill window. | +| =r= | Reply to toot under =point=. | +| =t= | Open thread buffer for toot under =point=. | +| =T= | Prompt for tag and open its timeline | +| =<tab>= | Go to the next interesting thing that has an action. | +| =<S-tab>= | Go to the previous interesting thing that has an action. | +| =<return>= / =<mouse-2>= | Perform action for the thing under point (or under mouse for =<mouse-2>=) if any. | +|--------------------------+-----------------------------------------------------------------------------------| **** Legend diff --git a/fixture/client.plstore b/fixture/client.plstore index 3514ed9..e050018 100644 --- a/fixture/client.plstore +++ b/fixture/client.plstore @@ -1,2 +1,3 @@ ;;; public entries -*- mode: plstore -*- -(("mastodon" :client_id "id" :client_secret "secret")) +(("mastodon-http://other.example" :client_id "id1" :client_secret "secret1") + ("mastodon-http://mastodon.example" :client_id "id2" :client_secret "secret2")) diff --git a/lisp/mastodon-auth.el b/lisp/mastodon-auth.el index 83d7d04..e9889d9 100644 --- a/lisp/mastodon-auth.el +++ b/lisp/mastodon-auth.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen <johnson.denen@gmail.com> -;; Version: 0.7.1 +;; Version: 0.7.2 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) @@ -40,8 +40,11 @@ :prefix "mastodon-auth-" :group 'mastodon) -(defvar mastodon-auth--token nil - "User access token.") +(defvar mastodon-auth--token-alist nil + "Alist of User access tokens keyed by instance url.") + +(defvar mastodon-auth--acct-alist nil + "Alist of account accts (name@domain) keyed by instance url.") (defun mastodon-auth--generate-token () "Make POST to generate auth token." @@ -53,7 +56,8 @@ ("username" . ,(read-string "Email: ")) ("password" . ,(read-passwd "Password: ")) ("scope" . "read write follow")) - nil)) + nil + :unauthenticated)) (defun mastodon-auth--get-token () "Make auth token request and return JSON response." @@ -67,13 +71,31 @@ (json-read-from-string json-string)))) (defun mastodon-auth--access-token () - "Return `mastodon-auth--token'. - -Generate token and set `mastodon-auth--token' if nil." - (or mastodon-auth--token - (let* ((json (mastodon-auth--get-token)) - (token (plist-get json :access_token))) - (setq mastodon-auth--token token)))) + "Return the access token to use with the current `mastodon-instance-url'. + +Generate token and set if none known yet." + (let ((token + (cdr (assoc mastodon-instance-url mastodon-auth--token-alist)))) + (unless token + (let ((json (mastodon-auth--get-token))) + (setq token (plist-get json :access_token)) + (push (cons mastodon-instance-url token) mastodon-auth--token-alist))) + token)) + +(defun mastodon-auth--get-account-name () + "Request user credentials and return an account name." + (cdr (assoc + 'acct + (mastodon-http--get-json + (mastodon-http--api + "accounts/verify_credentials"))))) + +(defun mastodon-auth--user-acct () + "Return a mastodon user acct name." + (or (cdr (assoc mastodon-instance-url mastodon-auth--acct-alist)) + (let ((acct (mastodon-auth--get-account-name))) + (push (cons mastodon-instance-url acct) mastodon-auth--acct-alist) + acct))) (provide 'mastodon-auth) ;;; mastodon-auth.el ends here diff --git a/lisp/mastodon-client.el b/lisp/mastodon-client.el index b97197e..968cdf3 100644 --- a/lisp/mastodon-client.el +++ b/lisp/mastodon-client.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen <johnson.denen@gmail.com> -;; Version: 0.7.1 +;; Version: 0.7.2 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) @@ -30,6 +30,7 @@ ;;; Code: (require 'plstore) +(defvar mastodon-instance-url) (autoload 'mastodon-http--api "mastodon-http") (autoload 'mastodon-http--post "mastodon-http") @@ -39,8 +40,8 @@ :group 'mastodon :type 'file) -(defvar mastodon-client--client-details nil - "Client id and secret.") +(defvar mastodon-client--client-details-alist nil + "An alist of Client id and secrets keyed by the instance url.") (defun mastodon-client--register () "POST client to Mastodon." @@ -50,7 +51,8 @@ ("redirect_uris" . "urn:ietf:wg:oauth:2.0:oob") ("scopes" . "read write follow") ("website" . "https://github.com/jdenen/mastodon.el")) - nil)) + nil + :unauthenticated)) (defun mastodon-client--fetch () "Return JSON from `mastodon-client--register' call." @@ -72,8 +74,13 @@ Make `mastodon-client--fetch' call to determine client values." (let ((plstore (plstore-open (mastodon-client--token-file))) - (client (mastodon-client--fetch))) - (plstore-put plstore "mastodon" client nil) + (client (mastodon-client--fetch)) + ;; alexgriffith reported seeing ellipses in the saved output + ;; which indicate some output truncating. Nothing in `plstore-save' + ;; seems to ensure this cannot happen so let's do that ourselves: + (print-length nil) + (print-level nil)) + (plstore-put plstore (concat "mastodon-" mastodon-instance-url) client nil) (plstore-save plstore) (plstore-close plstore) client)) @@ -81,19 +88,24 @@ Make `mastodon-client--fetch' call to determine client values." (defun mastodon-client--read () "Retrieve client_id and client_secret from `mastodon-client--token-file'." (let* ((plstore (plstore-open (mastodon-client--token-file))) - (mastodon (plstore-get plstore "mastodon"))) - (when mastodon - (delete "mastodon" mastodon)))) + (mastodon (plstore-get plstore (concat "mastodon-" mastodon-instance-url)))) + (cdr mastodon))) (defun mastodon-client () - "Return variable `mastodon-client--client-details' plist. + "Return variable client secrets to use for the current `mastodon-instance-url'.. Read plist from `mastodon-client--token-file' if variable is nil. Fetch and store plist if `mastodon-client--read' returns nil." - (or mastodon-client--client-details - (setq mastodon-client--client-details + (let ((client-details + (cdr (assoc mastodon-instance-url mastodon-client--client-details-alist)))) + (unless client-details + (setq client-details (or (mastodon-client--read) - (mastodon-client--store))))) + (mastodon-client--store))) + (push (cons mastodon-instance-url client-details) + mastodon-client--client-details-alist)) + client-details)) (provide 'mastodon-client) ;;; mastodon-client.el ends here + diff --git a/lisp/mastodon-http.el b/lisp/mastodon-http.el index 75cca2f..3240eef 100644 --- a/lisp/mastodon-http.el +++ b/lisp/mastodon-http.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen <johnson.denen@gmail.com> -;; Version: 0.7.1 +;; Version: 0.7.2 ;; Package-Requires: ((emacs "24.4")) ;; Homepage: https://github.com/jdenen/mastodon.el @@ -31,7 +31,6 @@ (require 'json) (defvar mastodon-instance-url) -(defvar mastodon-auth--token) (autoload 'mastodon-auth--access-token "mastodon-auth") (defvar mastodon-http--api-version "v1") @@ -68,10 +67,10 @@ Open RESPONSE buffer if unsuccessful." (funcall success) (switch-to-buffer response)))) -(defun mastodon-http--post (url args headers) +(defun mastodon-http--post (url args headers &optional unauthenticed-p) "POST synchronously to URL with ARGS and HEADERS. -Authorization header is included by default." +Authorization header is included by default unless UNAUTHENTICED-P is non-nil." (let ((url-request-method "POST") (url-request-data (when args @@ -82,8 +81,10 @@ Authorization header is included by default." args "&"))) (url-request-extra-headers - `(("Authorization" . ,(concat "Bearer " mastodon-auth--token)) - ,headers))) + (append + (unless unauthenticed-p + `(("Authorization" . ,(concat "Bearer " (mastodon-auth--access-token))))) + headers))) (with-temp-buffer (url-retrieve-synchronously url)))) @@ -107,6 +108,7 @@ Pass response buffer to CALLBACK function." (decode-coding-string (buffer-substring-no-properties (point) (point-max)) 'utf-8))) + (kill-buffer) (json-read-from-string json-string))))) json-vector)) diff --git a/lisp/mastodon-inspect.el b/lisp/mastodon-inspect.el index a44fb2c..62a91b5 100644 --- a/lisp/mastodon-inspect.el +++ b/lisp/mastodon-inspect.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen <johnson.denen@gmail.com> -;; Version: 0.7.1 +;; Version: 0.7.2 ;; Package-Requires: ((emacs "24.4")) ;; Homepage: https://github.com/jdenen/mastodon.el @@ -55,7 +55,7 @@ (interactive) (mastodon-inspect--dump-json-in-buffer (concat "*mastodon-inspect-toot-" - (int-to-string (mastodon-tl--property 'toot-id)) + (mastodon-tl--as-string (mastodon-tl--property 'toot-id)) "*") (mastodon-tl--property 'toot-json))) diff --git a/lisp/mastodon-media.el b/lisp/mastodon-media.el index 612fad5..2decce4 100644 --- a/lisp/mastodon-media.el +++ b/lisp/mastodon-media.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen <johnson.denen@gmail.com> -;; Version: 0.7.1 +;; Version: 0.7.2 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) @@ -32,6 +32,8 @@ ;; required by the server and client. ;;; Code: +(defvar url-show-status) + (defgroup mastodon-media nil "Inline Mastadon media." :prefix "mastodon-media-" @@ -125,7 +127,8 @@ BAIQCEAgAIEABAIsJVH58WqHw8FIgjUIQCAACAQgEIBAAAIBCAQgEIBAAAIBCAQgEAAEAhAIQCBA fKRJkmVZjAQwh78A6vCRWJE8K+8AAAAASUVORK5CYII=") "The PNG data for a generic 200x200 'broken image' view") -(defun mastodon-media--process-image-response (status-plist marker image-options region-length) +(defun mastodon-media--process-image-response + (status-plist 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'. @@ -133,31 +136,33 @@ IMAGE-OPTIONS are the precomputed options to apply to the image. MARKER is the marker to where the response should be visible. REGION-LENGTH is the length of the region that should be replaced with the image. " - (let ((url-buffer (current-buffer)) - (is-error-response-p (eq :error (car status-plist)))) - (unwind-protect - (let* ((data (unless is-error-response-p - (goto-char (point-min)) - (search-forward "\n\n") - (buffer-substring (point) (point-max)))) - (image (when data - (apply #'create-image data (when image-options 'imagemagick) - t image-options)))) - (switch-to-buffer (marker-buffer marker)) - ;; Save narrowing in our buffer - (let ((inhibit-read-only t)) - (save-restriction - (widen) - (put-text-property marker (+ marker region-length) 'media-state 'loaded) - (when image - ;; We only set the image to display if we could load - ;; it; we already have set a default image when we - ;; added the tag. - (put-text-property marker (+ marker region-length) - 'display image)) - ;; We are done with the marker; release it: - (set-marker marker nil))) - (kill-buffer url-buffer))))) + (when (marker-buffer marker) ; only if the buffer hasn't been kill in the meantime + (let ((url-buffer (current-buffer)) + (is-error-response-p (eq :error (car status-plist)))) + (unwind-protect + (let* ((data (unless is-error-response-p + (goto-char (point-min)) + (search-forward "\n\n") + (buffer-substring (point) (point-max)))) + (image (when data + (apply #'create-image data (when image-options 'imagemagick) + t image-options)))) + (with-current-buffer (marker-buffer marker) + ;; Save narrowing in our buffer + (let ((inhibit-read-only t)) + (save-restriction + (widen) + (put-text-property marker + (+ marker region-length) 'media-state 'loaded) + (when image + ;; We only set the image to display if we could load + ;; it; we already have set a default image when we + ;; added the tag. + (put-text-property marker (+ marker region-length) + 'display image)) + ;; We are done with the marker; release it: + (set-marker marker nil))) + (kill-buffer url-buffer))))))) (defun mastodon-media--load-image-from-url (url media-type start region-length) "Takes a URL and MEDIA-TYPE and load the image asynchronously. @@ -171,7 +176,9 @@ MEDIA-TYPE is a symbol and either 'avatar or 'media-link." ((eq media-type 'media-link) `(:max-height ,mastodon-media--preview-max-height)))))) (let ((buffer (current-buffer)) - (marker (copy-marker start))) + (marker (copy-marker start)) + ;; Keep url.el from spamming us with messages about connecting to hosts: + (url-show-status nil)) (condition-case nil ;; catch any errors in url-retrieve so as to not abort ;; whatever called us @@ -180,7 +187,10 @@ MEDIA-TYPE is a symbol and either 'avatar or 'media-link." (list 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) + (put-text-property marker + (+ marker region-length) + 'media-state + 'loading-failed) :loading-failed)))))) (defun mastodon-media--select-next-media-line () @@ -230,7 +240,8 @@ not been returned." (put-text-property start end 'media-state 'invalid-url) ;; proceed to load this image asynchronously (put-text-property start end 'media-state 'loading) - (mastodon-media--load-image-from-url image-url media-type start (- end start))))))) + (mastodon-media--load-image-from-url + image-url media-type start (- end start))))))) (defun mastodon-media--get-avatar-rendering (avatar-url) "Returns the string to be written that renders the avatar at AVATAR-URL." diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index 66452dd..252cefd 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen <johnson.denen@gmail.com> -;; Version: 0.7.1 +;; Version: 0.7.2 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) @@ -40,19 +40,130 @@ (autoload 'mastodon-media--inline-images "mastodon-media") (autoload 'mastodon-mode "mastodon") (defvar mastodon-toot-timestamp-format) +(defvar shr-use-fonts) ;; need to declare it since Emacs24 didn't have this (defgroup mastodon-tl nil "Timelines in Mastodon." :prefix "mastodon-tl-" :group 'mastodon) +(defcustom mastodon-tl--enable-relative-timestamps t + "Nonnil to enable showing relative (to the current time) timestamps. + +This will require periodic updates of a timeline buffer to +keep the timestamps current as time progresses." + :group 'mastodon-tl + :type '(boolean :tag "Enable relative timestamps and background updater task")) + +(defcustom mastodon-tl--enable-proportional-fonts nil + "Nonnil to enable using proportional fonts when rendering HTML. + +By default fixed width fonts are used." + :group 'mastodon-tl + :type '(boolean :tag "Enable using proportional rather than fixed \ +width fonts when rendering HTML text")) + (defvar mastodon-tl--buffer-spec nil "A unique identifier and functions for each Mastodon buffer.") +(make-variable-buffer-local 'mastodon-tl--buffer-spec) (defvar mastodon-tl--show-avatars-p (image-type-available-p 'imagemagick) "A boolean value stating whether to show avatars in timelines.") +(defvar mastodon-tl--display-media-p t + "A boolean value stating whether to show media in timelines.") + +(defvar mastodon-tl--timestamp-next-update nil + "The timestamp when the buffer should next be scanned to update the timestamps.") +(make-variable-buffer-local 'mastodon-tl--timestamp-next-update) + +(defvar mastodon-tl--timestamp-update-timer nil + "The timer that, when set will scan the buffer to update the timestamps.") +(make-variable-buffer-local 'mastodon-tl--timestamp-update-timer) + +(defvar mastodon-tl--link-keymap + (let ((map (make-sparse-keymap))) + (define-key map [return] 'mastodon-tl--do-link-action-at-point) + (define-key map [mouse-2] 'mastodon-tl--do-link-action) + (define-key map [follow-link] 'mouse-face) + (define-key map [tab] 'mastodon-tl--next-tab-item) + (define-key map [M-tab] 'mastodon-tl--previous-tab-item) + (define-key map [S-tab] 'mastodon-tl--previous-tab-item) + (define-key map [backtab] 'mastodon-tl--previous-tab-item) + (keymap-canonicalize map)) + "The keymap set for things in the buffer that act like links (except for shr.el generate links). + +This will make the region of text act like like a link with mouse +highlighting, mouse click action tabbing to next/previous link +etc.") + +(defvar mastodon-tl--shr-map-replacement + (let ((map (copy-keymap shr-map))) + ;; Replace the move to next/previous link bindings with our + ;; version that knows about more types of links. + (define-key map [remap shr-next-link] 'mastodon-tl--next-tab-item) + (define-key map [remap shr-previous-link] 'mastodon-tl--previous-tab-item) + (keymap-canonicalize map)) + "The keymap to be set for shr.el generated links that are not images. + +We need to override the keymap so tabbing will navigate to all +types of mastodon links and not just shr.el-generated ones.") + +(defvar mastodon-tl--shr-image-map-replacement + (let ((map (copy-keymap (if (boundp 'shr-image-map) + shr-image-map + shr-map)))) + ;; Replace the move to next/previous link bindings with our + ;; version that knows about more types of links. + (define-key map [remap shr-next-link] 'mastodon-tl--next-tab-item) + (define-key map [remap shr-previous-link] 'mastodon-tl--previous-tab-item) + (keymap-canonicalize map)) + "The keymap to be set for shr.el generated image links. + +We need to override the keymap so tabbing will navigate to all +types of mastodon links and not just shr.el-generated ones.") + +(defun mastodon-tl--next-tab-item () + "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. +This also skips tab items in invisible text, i.e. hidden spoiler text." + (interactive) + (let (next-range + (search-pos (point))) + (while (and (setq next-range (mastodon-tl--find-next-or-previous-property-range + 'mastodon-tab-stop search-pos nil)) + + (get-text-property (car next-range) 'invisible) + (setq search-pos (1+ (cdr next-range)))) + ;; do nothing, all the action in in the while condition + ) + (if (null next-range) + (message "Nothing else here.") + (goto-char (car next-range)) + (message "%s" (get-text-property (point) 'help-echo))))) + +(defun mastodon-tl--previous-tab-item () + "Move to the previous interesting item. + +This could be the previous toot, link, or image; whichever comes first. +Don't move if nothing else to move to is found, i.e. near the start of the buffer. +This also skips tab items in invisible text, i.e. hidden spoiler text." + (interactive) + (let (next-range + (search-pos (point))) + (while (and (setq next-range (mastodon-tl--find-next-or-previous-property-range + 'mastodon-tab-stop search-pos t)) + (get-text-property (car next-range) 'invisible) + (setq search-pos (1- (car next-range)))) + ;; do nothing, all the action in in the while condition + ) + (if (null next-range) + (message "Nothing else before this.") + (goto-char (car next-range)) + (message "%s" (get-text-property (point) 'help-echo))))) (defun mastodon-tl--get-federated-timeline () "Opens federated timeline." @@ -120,8 +231,10 @@ Optionally start from POS." (handle (cdr (assoc 'acct account))) (name (cdr (assoc 'display_name account))) (avatar-url (cdr (assoc 'avatar account)))) + ;; TODO: Once we have a view for a user (e.g. their posts + ;; timeline) make this a tab-stop and attach an action (concat - (when mastodon-tl--show-avatars-p + (when (and mastodon-tl--show-avatars-p mastodon-tl--display-media-p) (mastodon-media--get-avatar-rendering avatar-url)) (propertize name 'face 'mastodon-display-name-face) (propertize (concat " (@" @@ -146,54 +259,204 @@ Return value from boosted content if available." (or (cdr (assoc field (cdr (assoc 'reblog toot)))) (cdr (assoc field toot)))) +(defun mastodon-tl--relative-time-details (timestamp &optional current-time) + "Returns cons of (descriptive string . next change) for the TIMESTAMP. + +Use the optional CURRENT-TIME as the current time (only used for +reliable testing). + +The descriptive string is a human readable version relative to +the current time while the next change timestamp give the first +time that this description will change in the future. + +TIMESTAMP is assumed to be in the past." + (let* ((now (or current-time (current-time))) + (time-difference (time-subtract now timestamp)) + (seconds-difference (float-time time-difference)) + (regular-response + (lambda (seconds-difference multiplier unit-name) + (let ((n (floor (+ 0.5 (/ seconds-difference multiplier))))) + (cons (format "%d %ss ago" n unit-name) + (* (+ 0.5 n) multiplier))))) + (relative-result + (cond + ((< seconds-difference 60) + (cons "less than a minute ago" + 60)) + ((< seconds-difference (* 1.5 60)) + (cons "one minute ago" + 90)) ;; at 90 secs + ((< seconds-difference (* 60 59.5)) + (funcall regular-response seconds-difference 60 "minute")) + ((< seconds-difference (* 1.5 60 60)) + (cons "one hour ago" + (* 60 90))) ;; at 90 minutes + ((< seconds-difference (* 60 60 23.5)) + (funcall regular-response seconds-difference (* 60 60) "hour")) + ((< seconds-difference (* 1.5 60 60 24)) + (cons "one day ago" + (* 1.5 60 60 24))) ;; at a day and a half + ((< seconds-difference (* 60 60 24 6.5)) + (funcall regular-response seconds-difference (* 60 60 24) "day")) + ((< seconds-difference (* 1.5 60 60 24 7)) + (cons "one week ago" + (* 1.5 60 60 24 7))) ;; a week and a half + ((< seconds-difference (* 60 60 24 7 52)) + (if (= 52 (floor (+ 0.5 (/ seconds-difference 60 60 24 7)))) + (cons "52 weeks ago" + (* 60 60 24 7 52)) + (funcall regular-response seconds-difference (* 60 60 24 7) "week"))) + ((< seconds-difference (* 1.5 60 60 24 365)) + (cons "one year ago" + (* 60 60 24 365 1.5))) ;; a year and a half + (t + (funcall regular-response seconds-difference (* 60 60 24 365.25) "year"))))) + (cons (car relative-result) + (time-add timestamp (seconds-to-time (cdr relative-result)))))) + +(defun mastodon-tl--relative-time-description (timestamp &optional current-time) + "Returns a string with a human readable description of TIMESTMAP relative to the current time. + +Use the optional CURRENT-TIME as the current time (only used for +reliable testing). + +E.g. this could return something like \"1 min ago\", \"yesterday\", etc. +TIME-STAMP is assumed to be in the past." + (car (mastodon-tl--relative-time-details timestamp current-time))) + (defun mastodon-tl--byline (toot) "Generate byline for TOOT." (let ((id (cdr (assoc 'id toot))) - (timestamp (mastodon-tl--field 'created_at toot)) - (faved (mastodon-tl--field 'favourited toot)) - (boosted (mastodon-tl--field 'reblogged toot))) + (parsed-time (date-to-time (mastodon-tl--field 'created_at toot))) + (faved (equal 't (mastodon-tl--field 'favourited toot))) + (boosted (equal 't (mastodon-tl--field 'reblogged toot)))) + (concat + (propertize "\n | " 'face 'default) + (propertize + (concat (when boosted + (format "(%s) " + (propertize "B" 'face 'mastodon-boost-fave-face))) + (when faved + (format "(%s) " + (propertize "F" 'face 'mastodon-boost-fave-face))) + (mastodon-tl--byline-author toot) + (mastodon-tl--byline-boosted toot) + " " + ;; TODO: Once we have a view for toot (responses etc.) make + ;; this a tab stop and attach an action. + (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)) + (propertize "\n ------------" 'face 'default)) + 'favourited-p faved + 'boosted-p boosted + 'toot-id id + 'toot-json toot)))) + +(defun mastodon-tl--render-text (string) + "Returns a propertized text giving the rendering of the given HTML string." + (with-temp-buffer + (insert string) + (let ((shr-use-fonts mastodon-tl--enable-proportional-fonts) + (shr-width (when mastodon-tl--enable-proportional-fonts + (window-width)))) + (shr-render-region (point-min) (point-max))) + ;; Make all links a tab stop recognized by our own logic and + ;; update keymaps where needed. + ;; + ;; TODO: Once we have views for users and tags we need to + ;; recognize these links and turn them into links to our own + ;; views. + (let (region) + (while (setq region (mastodon-tl--find-property-range + 'shr-url (or (cdr region) (point-min)))) + (let* ((start (car region)) + (end (cdr region)) + (keymap (if (eq shr-map (get-text-property start 'keymap)) + mastodon-tl--shr-map-replacement + mastodon-tl--shr-image-map-replacement))) + (add-text-properties start end + (list 'mastodon-tab-stop 'shr-url + 'keymap keymap))))) + (buffer-string))) + +(defun mastodon-tl--set-face (string face) + "Returns the propertized STRING with the face property set to FACE." + (propertize string 'face face)) + +(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) + (list 'invisible + (not (get-text-property (car spoiler-text-region) + 'invisible))))))) +(defun mastodon-tl--make-link (string link-type) + "Return a propertized version of STRING that will act like link. + +LINK-TYPE is the type of link to produce." + (let ((help-text (cond + ((eq link-type 'content-warning) + "Toggle hidden text") + (t + (error "unknown link type %s" link-type))))) (propertize - (concat (propertize "\n | " 'face 'default) - (when boosted - (format "(%s) " - (propertize "B" 'face 'mastodon-boost-fave-face))) - (when faved - (format "(%s) " - (propertize "F" 'face 'mastodon-boost-fave-face))) - (mastodon-tl--byline-author toot) - (mastodon-tl--byline-boosted toot) - " " - (format-time-string mastodon-toot-timestamp-format (date-to-time timestamp)) - (propertize "\n ------------" 'face 'default)) - 'favourited-p faved - 'boosted-p boosted - 'toot-id id - 'toot-json toot))) - -(defun mastodon-tl--set-face (string face render) - "Set the face of a string. If `render' is not nil -also render the html" - (propertize - (with-temp-buffer - (insert string) - (when render - (let ((shr-use-fonts nil)) - (shr-render-region (point-min) (point-max)))) - (buffer-string)) - 'face face)) + string + 'mastodon-tab-stop link-type + 'mouse-face 'highlight + 'keymap mastodon-tl--link-keymap + 'help-echo help-text))) + +(defun mastodon-tl--do-link-action-at-point (position) + (interactive "d") + (let ((link-type (get-text-property position 'mastodon-tab-stop))) + (cond ((eq link-type 'content-warning) + (mastodon-tl--toggle-spoiler-text position)) + (t + (error "unknown link type %s" link-type))))) + +(defun mastodon-tl--do-link-action (event) + (interactive "e") + (mastodon-tl--do-link-action-at-point (posn-point (event-end event)))) + +(defun mastodon-tl--has-spoiler (toot) + "Check if the given TOOT has a spoiler text that should initially be shown only while the main content should be hidden." + (let ((spoiler (mastodon-tl--field 'spoiler_text toot))) + (and spoiler (> (length spoiler) 0)))) (defun mastodon-tl--spoiler (toot) - "Retrieve spoiler message from TOOT." + "Render TOOT with spoiler message. + +This assumes TOOT is a toot with a spoiler message. +The main body gets hidden and only the spoiler text and the +content warning message are displayed. The content warning +message is a link which unhides/hides the main body." (let* ((spoiler (mastodon-tl--field 'spoiler_text toot)) - (string (mastodon-tl--set-face spoiler 'default t)) - (message (concat "\n ---------------" - "\n Content Warning" - "\n ---------------\n")) - (cw (mastodon-tl--set-face message 'mastodon-cw-face nil))) - (if (> (length string) 0) - (replace-regexp-in-string "\n\n\n ---------------" - "\n ---------------" (concat string cw)) - ""))) + (string (mastodon-tl--set-face + ;; remove trailing whitespace + (replace-regexp-in-string "[\t\n ]*\\'" "" + (mastodon-tl--render-text spoiler)) + 'default)) + (message (concat "\n" + " ---------------\n" + " " (mastodon-tl--make-link "Content Warning" + 'content-warning) + "\n" + " ---------------\n")) + (cw (mastodon-tl--set-face message 'mastodon-cw-face))) + (concat + string + cw + (propertize (mastodon-tl--content toot) + 'invisible t + 'mastodon-content-warning-body t)))) (defun mastodon-tl--media (toot) "Retrieve a media attachment link for TOOT if one exists." @@ -202,32 +465,35 @@ also render the html" (lambda (media-attachement) (let ((preview-url (cdr (assoc 'preview_url media-attachement)))) - (mastodon-media--get-media-link-rendering - preview-url))) + (if mastodon-tl--display-media-p + (mastodon-media--get-media-link-rendering + preview-url) + (concat "Media::" preview-url "\n")))) media-attachements ""))) - (if (not (equal media-string "")) - (concat "\n" media-string ) ""))) + (if (not (and mastodon-tl--display-media-p + (equal media-string ""))) + (concat "\n" media-string) + ""))) (defun mastodon-tl--content (toot) "Retrieve text content from TOOT." - (let ((content (mastodon-tl--field 'content toot)) - (shr-use-fonts nil)) - (propertize (with-temp-buffer - (insert content) - (shr-render-region (point-min) (point-max)) - (buffer-string)) - 'face 'default))) + (let ((content (mastodon-tl--field 'content toot))) + (concat + (mastodon-tl--render-text content) + (mastodon-tl--media toot)))) (defun mastodon-tl--toot (toot) "Display TOOT content and byline." (insert (concat - (mastodon-tl--spoiler toot) - ;; remove two trailing newlines - (substring (mastodon-tl--content toot) 0 -2) - (mastodon-tl--media toot) - "\n\n" + ;; remove trailing whitespace + + (replace-regexp-in-string + "[\t\n ]*\\'" "" + (if (mastodon-tl--has-spoiler toot) + (mastodon-tl--spoiler toot) + (mastodon-tl--content toot))) (mastodon-tl--byline toot) "\n\n"))) @@ -237,7 +503,8 @@ also render the html" (goto-char (point-min)) (while (search-forward "\n\n\n | " nil t) (replace-match "\n | ")) - (mastodon-media--inline-images)) + (when mastodon-tl--display-media-p + (mastodon-media--inline-images))) (defun mastodon-tl--get-update-function (&optional buffer) "Get the UPDATE-FUNCTION stored in `mastodon-tl--buffer-spec'" @@ -267,7 +534,7 @@ also render the html" "&" "?") "max_id=" - (number-to-string id))))) + (mastodon-tl--as-string id))))) (mastodon-http--get-json url))) ;; TODO @@ -280,7 +547,7 @@ also render the html" "&" "?") "since_id=" - (number-to-string id))))) + (mastodon-tl--as-string id))))) (mastodon-http--get-json url))) (defun mastodon-tl--property (prop &optional backward) @@ -304,21 +571,47 @@ Move forward (down) the timeline unless BACKWARD is non-nil." (goto-char (point-max)) (mastodon-tl--property 'toot-id t)) +(defun mastodon-tl--as-string(numeric) + "Convert NUMERIC to string." + (cond ((numberp numeric) + (number-to-string numeric)) + ((stringp numeric) numeric) + (t (error + "Numeric:%s must be either a string or a number" + numeric)))) + +(defun mastodon-tl--toot-id (json) + "Find approproiate toot id in JSON. + +If the toot has been boosted use the id found in the +reblog portion of the toot. Otherwise, use the body of +the toot. This is the same behaviour as the mastodon.social +webapp" + (let ((id (cdr (assoc 'id json))) + (reblog (cdr (assoc 'reblog json)))) + (if reblog (cdr (assoc 'id reblog)) id))) + (defun mastodon-tl--thread () "Open thread buffer for toot under `point'." (interactive) - (let* ((id (number-to-string (mastodon-tl--property 'toot-id))) + (let* ((id (mastodon-tl--as-string (mastodon-tl--toot-id + (mastodon-tl--property 'toot-json)))) (url (mastodon-http--api (format "statuses/%s/context" id))) (buffer (format "*mastodon-thread-%s*" id)) (toot (mastodon-tl--property 'toot-json)) (context (mastodon-http--get-json url))) (with-output-to-temp-buffer buffer (switch-to-buffer buffer) + (mastodon-mode) + (setq mastodon-tl--buffer-spec + `(buffer-name ,buffer + endpoint ,(format "statuses/%s/context" id) + update-function + (lambda(toot) (message "END of thread.")))) (mastodon-tl--timeline (vconcat (cdr (assoc 'ancestors context)) `(,toot) - (cdr (assoc 'descendants context))))) - (mastodon-mode))) + (cdr (assoc 'descendants context))))))) (defun mastodon-tl--more () "Append older toots to timeline." @@ -334,6 +627,148 @@ Move forward (down) the timeline unless BACKWARD is non-nil." (funcall update-function json) (goto-char point-before))))) +(defun mastodon-tl--find-property-range (property start-point &optional search-backwards) + " Returns `nil` if no such range is found. + +If PROPERTY is set at START-POINT returns a range around +START-POINT otherwise before/after START-POINT. + +SEARCH-BACKWARDS determines whether we pick point +before (non-nil) or after (nil)" + (if (get-text-property start-point property) + ;; We are within a range, so look backwards for the start: + (cons (previous-single-property-change + (if (equal 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)) + property) + ;; we may either be just before the range or there + ;; is nothing at all + (and (not (equal start-point (point-min))) + (get-text-property (1- start-point) property) + start-point))) + (start (and + end + (previous-single-property-change end property nil (point-min))))) + (when end + (cons start end))) + (let* ((start (next-single-property-change start-point property)) + (end (and start + (next-single-property-change start property nil (point-max))))) + (when start + (cons start end)))))) + +(defun mastodon-tl--find-next-or-previous-property-range + (property start-point search-backwards) + "Finds (start . end) range after/before START-POINT where PROPERTY is set to a consistent value (different from the value at START-POINT if that is set). + +Returns 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)) + (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))) + +(defun mastodon-tl--consider-timestamp-for-updates (timestamp) + "Take note that TIMESTAMP is used in buffer and ajust timers as needed. + +This calculates the next time the text for TIMESTAMP will change +and may adjust existing or future timer runs should that time +before current plans to run the update function. + +The adjustment is only made if it is significantly (a few +seconds) before the currently scheduled time. This helps reduce +the number of occasions where we schedule an update only to +schedule the next one on completion to be within a few seconds. + +If relative timestamps are +disabled (`mastodon-tl--enable-relative-timestamps` is nil) this +is a no-op." + (when mastodon-tl--enable-relative-timestamps + (let ((this-update (cdr (mastodon-tl--relative-time-details timestamp)))) + (when (time-less-p this-update + (time-subtract mastodon-tl--timestamp-next-update + (seconds-to-time 10))) + (setq mastodon-tl--timestamp-next-update this-update) + (when mastodon-tl--timestamp-update-timer + ;; We need to re-schedule for an earlier time + (cancel-timer mastodon-tl--timestamp-update-timer) + (setq mastodon-tl--timestamp-update-timer + (run-at-time this-update + nil ;; don't repeat + #'mastodon-tl--update-timestamps-callback + (current-buffer) nil))))))) + +(defun mastodon-tl--update-timestamps-callback (buffer previous-marker) + "Update the next few timestamp displays in BUFFER. + +Start searching for more timestamps from PREVIOUS-MARKER or +from the start if it is nil." + ;; only do things if the buffer hasn't been killed in the meantime + (when (and mastodon-tl--enable-relative-timestamps ;; should be true but just in case... + (buffer-live-p buffer)) + (save-excursion + (with-current-buffer buffer + (let ((previous-timestamp (if previous-marker + (marker-position previous-marker) + (point-min))) + (iteration 0) + next-timestamp-range) + (if previous-marker + ;; This is a follow-up call to process the next batch of + ;; timestamps. + ;; Release the marker to not slow things down. + (set-marker previous-marker nil) + ;; Otherwise this is a rew run, so let's initialize the next-run time. + (setq mastodon-tl--timestamp-next-update (time-add (current-time) + (seconds-to-time 300)) + mastodon-tl--timestamp-update-timer nil)) + (while (and (< iteration 5) + (setq next-timestamp-range + (mastodon-tl--find-property-range 'timestamp + previous-timestamp))) + (let* ((start (car next-timestamp-range)) + (end (cdr next-timestamp-range)) + (timestamp (get-text-property start 'timestamp)) + (current-display (get-text-property start 'display)) + (new-display (mastodon-tl--relative-time-description timestamp))) + (unless (string= current-display new-display) + (let ((inhibit-read-only t)) + (add-text-properties + start end (list 'display + (mastodon-tl--relative-time-description timestamp))))) + (mastodon-tl--consider-timestamp-for-updates timestamp) + (setq iteration (1+ iteration) + previous-timestamp (1+ (cdr next-timestamp-range))))) + (if next-timestamp-range + ;; schedule the next batch from the previous location to + ;; start very soon in the future: + (run-at-time 0.1 nil #'mastodon-tl--update-timestamps-callback buffer + (copy-marker previous-timestamp)) + ;; otherwise we are done for now; schedule a new run for when needed + (setq mastodon-tl--timestamp-update-timer + (run-at-time mastodon-tl--timestamp-next-update + nil ;; don't repeat + #'mastodon-tl--update-timestamps-callback + buffer nil)))))))) + (defun mastodon-tl--update () "Update timeline with new toots." (interactive) @@ -346,7 +781,6 @@ Move forward (down) the timeline unless BACKWARD is non-nil." (goto-char (point-min)) (funcall update-function json))))) - (defun mastodon-tl--init (buffer-name endpoint update-function) "Initialize BUFFER-NAME with timeline targeted by ENDPOINT. @@ -356,14 +790,25 @@ UPDATE-FUNCTION is used to recieve more toots." (json (mastodon-http--get-json url))) (with-output-to-temp-buffer buffer (switch-to-buffer buffer) + (setq + ;; Initialize with a minimal interval; we re-scan at least once + ;; every 5 minutes to catch any timestamps we may have missed + mastodon-tl--timestamp-next-update (time-add (current-time) + (seconds-to-time 300))) (funcall update-function json)) (mastodon-mode) (with-current-buffer buffer - (make-local-variable 'mastodon-tl--buffer-spec) (setq mastodon-tl--buffer-spec `(buffer-name ,buffer-name endpoint ,endpoint update-function - ,update-function))) + ,update-function) + mastodon-tl--timestamp-update-timer + (when mastodon-tl--enable-relative-timestamps + (run-at-time mastodon-tl--timestamp-next-update + nil ;; don't repeat + #'mastodon-tl--update-timestamps-callback + (current-buffer) + nil)))) buffer)) (provide 'mastodon-tl) diff --git a/lisp/mastodon-toot.el b/lisp/mastodon-toot.el index 6ec3174..5db9d32 100644 --- a/lisp/mastodon-toot.el +++ b/lisp/mastodon-toot.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen <johnson.denen@gmail.com> -;; Version: 0.7.1 +;; Version: 0.7.2 ;; Homepage: https://github.com/jdenen/mastodon.el ;; Package-Requires: ((emacs "24.4")) @@ -48,7 +48,6 @@ map) "Keymap for `mastodon-toot'.") - (defun mastodon-toot--action-success (marker &optional rm) "Insert MARKER with 'success face in byline. @@ -70,7 +69,7 @@ Remove MARKER if RM is non-nil." "Take ACTION on toot at point, then execute CALLBACK." (let* ((id (mastodon-tl--property 'toot-id)) (url (mastodon-http--api (concat "statuses/" - (number-to-string id) + (mastodon-tl--as-string id) "/" action)))) (let ((response (mastodon-http--post url nil nil))) @@ -79,7 +78,8 @@ Remove MARKER if RM is non-nil." (defun mastodon-toot--toggle-boost () "Boost/unboost toot at `point'." (interactive) - (let* ((id (mastodon-tl--property 'toot-id)) + (let* ((id (mastodon-tl--as-string + (mastodon-tl--property 'toot-id))) (boosted (get-text-property (point) 'boosted-p)) (action (if boosted "unreblog" "reblog")) (msg (if boosted "unboosted" "boosted")) @@ -87,19 +87,20 @@ Remove MARKER if RM is non-nil." (mastodon-toot--action action (lambda () (mastodon-toot--action-success "B" remove) - (message (format "%s #%d" msg id)))))) + (message (format "%s #%s" msg id)))))) (defun mastodon-toot--toggle-favourite () "Favourite/unfavourite toot at `point'." (interactive) - (let* ((id (mastodon-tl--property 'toot-id)) + (let* ((id (mastodon-tl--as-string + (mastodon-tl--property 'toot-id))) (faved (get-text-property (point) 'favourited-p)) (action (if faved "unfavourite" "favourite")) (remove (when faved t))) (mastodon-toot--action action (lambda () (mastodon-toot--action-success "F" remove) - (message (format "%sd #%d" action id)))))) + (message (format "%s #%s" action id)))))) (defun mastodon-toot--kill () "Kill `mastodon-toot-mode' buffer and window. @@ -140,14 +141,40 @@ Set `mastodon-toot--content-warning' to nil." (mastodon-http--triage response (lambda () (message "Toot toot!")))))) +(defun mastodon-toot--process-local (acct) + "Adds domain to local ACCT and replaces the curent user name with \"\". + +Mastodon requires the full user@domain, even in the case of local accts. +eg. \"user\" -> \"user@local.social \" (when local.social is the domain of the +mastodon-instance-url). +eg. \"yourusername\" -> \"\" +eg. \"feduser@fed.social\" -> \"feduser@fed.social\" " + (cond ((string-match-p "@" acct) (concat "@" acct " ")) ; federated acct + ((string= (mastodon-auth--user-acct) acct) "") ; your acct + (t (concat "@" acct "@" ; local acct + (cadr (split-string mastodon-instance-url "/" t)) " ")))) + +(defun mastodon-toot--mentions (status) + "Extract mentions from STATUS and process them into a string." + (interactive) + (let ((mentions (cdr (assoc 'mentions status)))) + (mapconcat (lambda(x) (mastodon-toot--process-local + (cdr (assoc 'acct x)))) + ;; reverse does not work on vectors in 24.5 + (reverse (append mentions nil)) + ""))) + (defun mastodon-toot--reply () "Reply to toot at `point'." (interactive) (let* ((toot (mastodon-tl--property 'toot-json)) - (id (number-to-string (mastodon-tl--field 'id toot))) + (id (mastodon-tl--as-string (mastodon-tl--field 'id toot))) (account (mastodon-tl--field 'account toot)) - (user (cdr (assoc 'username account)))) - (mastodon-toot user id))) + (user (cdr (assoc 'acct account))) + (mentions (mastodon-toot--mentions toot))) + (mastodon-toot (when user (concat (mastodon-toot--process-local user) + mentions)) + id))) (defun mastodon-toot--toggle-warning () "Toggle `mastodon-toot--content-warning'." @@ -209,7 +236,8 @@ e.g. mastodon-toot--send -> Send." "If REPLY-TO-USER is provided, inject their handle into the message. If REPLY-TO-ID is provided, set the MASTODON-TOOT--REPLY-TO-ID var." (when reply-to-user - (insert (format "@%s " reply-to-user)) + (insert (format "%s " reply-to-user)) + (make-variable-buffer-local 'mastodon-toot--reply-to-id) (setq mastodon-toot--reply-to-id reply-to-id))) (defun mastodon-toot--compose-buffer (reply-to-user reply-to-id) diff --git a/lisp/mastodon.el b/lisp/mastodon.el index c031774..7f02295 100644 --- a/lisp/mastodon.el +++ b/lisp/mastodon.el @@ -2,7 +2,7 @@ ;; Copyright (C) 2017 Johnson Denen ;; Author: Johnson Denen <johnson.denen@gmail.com> -;; Version: 0.7.1 +;; Version: 0.7.2 ;; Package-Requires: ((emacs "24.4")) ;; Homepage: https://github.com/jdenen/mastodon.el @@ -38,6 +38,8 @@ (autoload 'mastodon-tl--get-tag-timeline "mastodon-tl") (autoload 'mastodon-tl--goto-next-toot "mastodon-tl") (autoload 'mastodon-tl--goto-prev-toot "mastodon-tl") +(autoload 'mastodon-tl--next-tab-item "mastodon-tl") +(autoload 'mastodon-tl--previous-tab-item "mastodon-tl") (autoload 'mastodon-tl--thread "mastodon-tl") (autoload 'mastodon-tl--update "mastodon-tl") (autoload 'mastodon-toot--compose-buffer "mastodon-toot") @@ -131,7 +133,12 @@ If REPLY-TO-ID is non-nil, attach new toot to a conversation." (define-key map (kbd "r") #'mastodon-toot--reply) (define-key map (kbd "t") #'mastodon-tl--thread) (define-key map (kbd "T") #'mastodon-tl--get-tag-timeline) - (define-key map (kbd "u") #'mastodon-tl--update))) + (define-key map (kbd "u") #'mastodon-tl--update) + (define-key map [?\t] #'mastodon-tl--next-tab-item) + (define-key map [backtab] #'mastodon-tl--previous-tab-item) + (define-key map [?\S-\t] #'mastodon-tl--previous-tab-item) + (define-key map [?\M-\t] #'mastodon-tl--previous-tab-item) + )) (with-eval-after-load 'mastodon (when (require 'discover nil :noerror) diff --git a/test/mastodon-auth-tests.el b/test/mastodon-auth-tests.el index 70c63d8..719a56c 100644 --- a/test/mastodon-auth-tests.el +++ b/test/mastodon-auth-tests.el @@ -14,7 +14,8 @@ ("username" . "foo@bar.com") ("password" . "password") ("scope" . "read write follow")) - nil)) + nil + :unauthenticated)) (mastodon-auth--generate-token)))) (ert-deftest get-token () @@ -26,15 +27,17 @@ (current-buffer))) (should (equal (mastodon-auth--get-token) '(:access_token "abcdefg")))))) -(ert-deftest access-token-1 () - "Should return `mastodon-auth--token' if non-nil." - (let ((mastodon-auth--token "foobar")) +(ert-deftest access-token-found () + "Should return value in `mastodon-auth--token-alist' if found." + (let ((mastodon-instance-url "https://instance.url") + (mastodon-auth--token-alist '(("https://instance.url" . "foobar")) )) (should (string= (mastodon-auth--access-token) "foobar")))) (ert-deftest access-token-2 () "Should set and return `mastodon-auth--token' if nil." - (let ((mastodon-auth--token nil)) + (let ((mastodon-instance-url "https://instance.url") + (mastodon-auth--token nil)) (with-mock (mock (mastodon-auth--get-token) => '(:access_token "foobaz")) (should (string= (mastodon-auth--access-token) "foobaz")) - (should (string= mastodon-auth--token "foobaz"))))) + (should (equal mastodon-auth--token-alist '(("https://instance.url" . "foobaz"))))))) diff --git a/test/mastodon-client-tests.el b/test/mastodon-client-tests.el index c339efa..dfe175b 100644 --- a/test/mastodon-client-tests.el +++ b/test/mastodon-client-tests.el @@ -9,7 +9,8 @@ ("redirect_uris" . "urn:ietf:wg:oauth:2.0:oob") ("scopes" . "read write follow") ("website" . "https://github.com/jdenen/mastodon.el")) - nil)) + nil + :unauthenticated)) (mastodon-client--register))) (ert-deftest fetch () @@ -23,53 +24,80 @@ (ert-deftest store-1 () "Should return the client plist." - (let ((plist '(:client_id "id" :client_secret "secret"))) + (let ((mastodon-instance-url "http://mastodon.example") + (plist '(:client_id "id" :client_secret "secret"))) (with-mock (mock (mastodon-client--token-file) => "stubfile.plstore") (mock (mastodon-client--fetch) => '(:client_id "id" :client_secret "secret")) (let* ((plstore (plstore-open "stubfile.plstore")) - (client (delete "mastodon" (plstore-get plstore "mastodon")))) - (should (equal (mastodon-client--store) plist)) - )))) + (client (cdr (plstore-get plstore "mastodon-http://mastodon.example")))) + (should (equal (mastodon-client--store) plist)))))) (ert-deftest store-2 () "Should store client in `mastodon-client--token-file'." - (let* ((plstore (plstore-open "stubfile.plstore")) - (client (delete "mastodon" (plstore-get plstore "mastodon")))) + (let* ((mastodon-instance-url "http://mastodon.example") + (plstore (plstore-open "stubfile.plstore")) + (client (cdr (plstore-get plstore "mastodon-http://mastodon.example")))) (plstore-close plstore) (should (string= (plist-get client :client_id) "id")) (should (string= (plist-get client :client_secret) "secret")))) -(ert-deftest read-1 () +(ert-deftest read-finds-match () "Should return mastodon client from `mastodon-token-file' if it exists." - (with-mock - (mock (mastodon-client--token-file) => "fixture/client.plstore") - (should (equal (mastodon-client--read) '(:client_id "id" :client_secret "secret"))))) + (let ((mastodon-instance-url "http://mastodon.example")) + (with-mock + (mock (mastodon-client--token-file) => "fixture/client.plstore") + (should (equal (mastodon-client--read) + '(:client_id "id2" :client_secret "secret2")))))) + +(ert-deftest read-finds-no-match () + "Should return mastodon client from `mastodon-token-file' if it exists." + (let ((mastodon-instance-url "http://mastodon.social")) + (with-mock + (mock (mastodon-client--token-file) => "fixture/client.plstore") + (should (equal (mastodon-client--read) nil))))) -(ert-deftest read-2 () +(ert-deftest read-empty-store () "Should return nil if mastodon client is not present in the plstore." (with-mock (mock (mastodon-client--token-file) => "fixture/empty.plstore") (should (equal (mastodon-client--read) nil)))) -(ert-deftest client-1 () - "Should return `mastondon-client' if non-nil." - (let ((mastodon-client--client-details t)) - (should (eq (mastodon-client) t)))) +(ert-deftest client-set-and-matching () + "Should return `mastondon-client' if `mastodon-client--client-details-alist' is non-nil and instance url is included." + (let ((mastodon-instance-url "http://mastodon.example") + (mastodon-client--client-details-alist '(("https://other.example" . :no-match) + ("http://mastodon.example" . :matches)))) + (should (eq (mastodon-client) :matches)))) + +(ert-deftest client-set-but-not-matching () + "Should read from `mastodon-token-file' if wrong data is cached." + (let ((mastodon-instance-url "http://mastodon.example") + (mastodon-client--client-details-alist '(("http://other.example" :wrong)))) + (with-mock + (mock (mastodon-client--read) => '(:client_id "foo" :client_secret "bar")) + (should (equal (mastodon-client) '(:client_id "foo" :client_secret "bar"))) + (should (equal mastodon-client--client-details-alist + '(("http://mastodon.example" :client_id "foo" :client_secret "bar") + ("http://other.example" :wrong))))))) -(ert-deftest client-2 () +(ert-deftest client-unset () "Should read from `mastodon-token-file' if available." - (let ((mastodon-client--client-details nil)) + (let ((mastodon-instance-url "http://mastodon.example") + (mastodon-client--client-details-alist nil)) (with-mock (mock (mastodon-client--read) => '(:client_id "foo" :client_secret "bar")) (should (equal (mastodon-client) '(:client_id "foo" :client_secret "bar"))) - (should (equal mastodon-client--client-details '(:client_id "foo" :client_secret "bar")))))) + (should (equal mastodon-client--client-details-alist + '(("http://mastodon.example" :client_id "foo" :client_secret "bar"))))))) -(ert-deftest client-3 () +(ert-deftest client-unset-and-not-in-storage () "Should store client data in plstore if it can't be read." - (let ((mastodon-client--client-details nil)) + (let ((mastodon-instance-url "http://mastodon.example") + (mastodon-client--client-details-alist nil)) (with-mock (mock (mastodon-client--read)) (mock (mastodon-client--store) => '(:client_id "foo" :client_secret "baz")) (should (equal (mastodon-client) '(:client_id "foo" :client_secret "baz"))) - (should (equal mastodon-client--client-details '(:client_id "foo" :client_secret "baz")))))) + (should (equal mastodon-client--client-details-alist + '(("http://mastodon.example" :client_id "foo" :client_secret "baz"))))))) diff --git a/test/mastodon-tl-tests.el b/test/mastodon-tl-tests.el index 8c706f5..189916d 100644 --- a/test/mastodon-tl-tests.el +++ b/test/mastodon-tl-tests.el @@ -1,3 +1,5 @@ +(require 'cl-lib) +(require 'cl-macs) (require 'el-mock) (defconst mastodon-tl-test-base-toot @@ -6,7 +8,7 @@ (in_reply_to_id) (in_reply_to_account_id) (sensitive . :json-false) - (spoiler_text . "Spoiler text") + (spoiler_text . "") (visibility . "public") (account (id . 42) (username . "acct42") @@ -23,6 +25,7 @@ (tags . []) (uri . "tag:example.space,2017-04-24:objectId=654321:objectType=Status") (url . "https://example.space/users/acct42/updates/123456789") + (content . "<p>Just some text</p>") (reblogs_count . 0) (favourites_count . 0) (reblog)) @@ -34,7 +37,7 @@ (in_reply_to_id) (in_reply_to_account_id) (sensitive . :json-false) - (spoiler_text . "Spoiler text") + (spoiler_text . "") (visibility . "public") (account (id . 42) (username . "acct42") @@ -96,6 +99,28 @@ (let ((input "foobar</p>")) (should (string= (mastodon-tl--remove-html input) "foobar\n\n")))) +(ert-deftest toot-id-boosted () + "If a toot is boostedm, return the reblog id." + (should (string= (mastodon-tl--as-string + (mastodon-tl--toot-id mastodon-tl-test-base-boosted-toot)) + "4543919"))) + +(ert-deftest toot-id () + "If a toot is boostedm, return the reblog id." + (should (string= (mastodon-tl--as-string + (mastodon-tl--toot-id mastodon-tl-test-base-toot)) + "61208"))) + +(ert-deftest as-string-1 () + "Should accept a string or number and return a string." + (let ((id "1000")) + (should (string= (mastodon-tl--as-string id) id)))) + +(ert-deftest as-string-2 () + "Should accept a string or number and return a string." + (let ((id 1000)) + (should (string= (mastodon-tl--as-string id) (number-to-string id))))) + (ert-deftest more-json () "Should request toots older than max_id." (let ((mastodon-instance-url "https://instance.url")) @@ -103,6 +128,126 @@ (mock (mastodon-http--get-json "https://instance.url/api/v1/timelines/foo?max_id=12345")) (mastodon-tl--more-json "timelines/foo" 12345)))) +(ert-deftest more-json-id-string () + "Should request toots older than max_id. + +`mastodon-tl--more-json' should accept and id that is either +a string or a numeric." + (let ((mastodon-instance-url "https://instance.url")) + (with-mock + (mock (mastodon-http--get-json "https://instance.url/api/v1/timelines/foo?max_id=12345")) + (mastodon-tl--more-json "timelines/foo" "12345")))) + +(ert-deftest update-json-id-string () + "Should request toots more recent than since_id. + +`mastodon-tl--updated-json' should accept and id that is either +a string or a numeric." + (let ((mastodon-instance-url "https://instance.url")) + (with-mock + (mock (mastodon-http--get-json "https://instance.url/api/v1/timelines/foo?since_id=12345")) + (mastodon-tl--updated-json "timelines/foo" "12345")))) + +(ert-deftest mastodon-tl--relative-time-description () + "Should format relative time as expected" + (cl-labels ((minutes (n) (* n 60)) + (hours (n) (* n (minutes 60))) + (days (n) (* n (hours 24))) + (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))) + (check (seconds expected) + (should (string= (format-seconds-since seconds) expected)))) + (check 1 "less than a minute ago") + (check 59 "less than a minute ago") + (check 60 "one minute ago") + (check 89 "one 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") + (check (minutes 60) "one hour ago") + (check (minutes 89) "one 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) "one day ago") ;; rounding up + (check (days 1.48) "one day ago") ;; rounding down + (check (days 1.52) "2 days ago") ;; rounding up + (check (days 6.6) "one 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) "one year ago") + (check (years 2.49) "2 years ago") ;; rounding down + (check (years 2.51) "3 years ago") ;; rounding down + )) + +(ert-deftest mastodon-tl--relative-time-details--next-update () + "Should calculate the next update time information as expected" + (let ((current-time (current-time))) + (cl-labels ((minutes (n) (* n 60)) + (hours (n) (* n (minutes 60))) + (days (n) (* n (hours 24))) + (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)))) + (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))))) + (check 0) + (check 1) + (check 59) + (check 60) + (check 89) + (check 90) + (check 149) + (check 150) + (check (1- (hours 1.5))) ;; just before we switch from "one hour" to "2 hours" + (check (hours 1.5)) + (check (hours 2.1)) + (check (1- (hours 23.5))) ;; just before "23 hours" -> "one day" + (check (hours 23.5)) + (check (1- (days 1.5))) ;; just before "one day" -> "2 days" + (check (days 1.5)) ;; just before "one day" -> "2 days" + (check (days 2.1)) + (check (1- (days 6.5))) ;; just before "6 days" -> "one week" + (check (days 6.5)) ;; "one week" -> "2 weeks" + (check (weeks 2.1)) + (check (1- (weeks 52))) ;; just before "52 weeks" -> "one year" + (check (weeks 52)) + (check (days 365)) + (check (days 366)) + (check (years 2.1)) + ))) + (ert-deftest mastodon-tl--byline-regular () "Should format the regular toot correctly." (let ((mastodon-tl--show-avatars-p nil) @@ -236,3 +381,443 @@ | (B) (F) Account 42 (@acct42@example.space) Boosted Account 43 (@acct43@example.space) original time ------------"))))) +(ert-deftest mastodon-tl--byline-timestamp-has-relative-display () + "Should display the timestamp with a relative time." + (let ((mastodon-tl--show-avatars-p nil) + (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 (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)) + (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))))))) + +(ert-deftest mastodon-tl--consider-timestamp-for-updates-no-active-callback () + "Should update the timestamp update variables as expected." + + (let* ((now (current-time)) + (soon-in-the-future (time-add now (seconds-to-time 10000))) + (long-in-the-future (time-add now (seconds-to-time 10000000)))) + (with-temp-buffer + ;; start with timer way into the future and no active callback + (setq mastodon-tl--timestamp-next-update long-in-the-future + mastodon-tl--timestamp-update-timer nil) + + ;; something a later update doesn't update: + (with-mock + (mock (mastodon-tl--relative-time-details 'fake-timestamp) => + (cons "xxx ago" (time-add long-in-the-future (seconds-to-time 100)))) + + (mastodon-tl--consider-timestamp-for-updates 'fake-timestamp) + + (should (null mastodon-tl--timestamp-update-timer)) + (should (eq mastodon-tl--timestamp-next-update long-in-the-future))) + + ;; something only shortly sooner doesn't update: + (with-mock + (mock (mastodon-tl--relative-time-details 'fake-timestamp) => + (cons "xxx ago" (time-subtract long-in-the-future (seconds-to-time 9)))) + + (mastodon-tl--consider-timestamp-for-updates 'fake-timestamp) + + (should (null mastodon-tl--timestamp-update-timer)) + (should (eq mastodon-tl--timestamp-next-update long-in-the-future))) + + ;; something much sooner, does update + (with-mock + (mock (mastodon-tl--relative-time-details 'fake-timestamp) => + (cons "xxx ago" soon-in-the-future)) + + (mastodon-tl--consider-timestamp-for-updates 'fake-timestamp) + + (should (null mastodon-tl--timestamp-update-timer)) + (should (eq mastodon-tl--timestamp-next-update soon-in-the-future))) + ))) + +(ert-deftest mastodon-tl--consider-timestamp-for-updates-with-active-callback () + "Should update the timestamp update variables as expected." + + (let* ((now (current-time)) + (soon-in-the-future (time-add now (seconds-to-time 10000))) + (long-in-the-future (time-add now (seconds-to-time 10000000)))) + (with-temp-buffer + ;; start with timer way into the future and no active callback + (setq mastodon-tl--timestamp-next-update long-in-the-future + mastodon-tl--timestamp-update-timer 'initial-timer) + + ;; something a later update doesn't update: + (with-mock + (mock (mastodon-tl--relative-time-details 'fake-timestamp) => + (cons "xxx ago" (time-add long-in-the-future (seconds-to-time 100)))) + + (mastodon-tl--consider-timestamp-for-updates 'fake-timestamp) + + (should (eq 'initial-timer mastodon-tl--timestamp-update-timer)) + (should (eq mastodon-tl--timestamp-next-update long-in-the-future))) + + ;; something much sooner, does update + (with-mock + (mock (mastodon-tl--relative-time-details 'fake-timestamp) => + (cons "xxx ago" soon-in-the-future)) + (mock (cancel-timer 'initial-timer)) + (mock (run-at-time soon-in-the-future nil + #'mastodon-tl--update-timestamps-callback + (current-buffer) nil) => 'new-timer) + + (mastodon-tl--consider-timestamp-for-updates 'fake-timestamp) + + (should (eq 'new-timer mastodon-tl--timestamp-update-timer)) + (should (eq mastodon-tl--timestamp-next-update soon-in-the-future))) + ))) + +(ert-deftest mastodon-tl--find-property-range--no-tag () + "Should cope with a buffer completely lacking the tag." + (with-temp-buffer + (insert "Just some random text") + (insert (propertize "More text with a different property" 'other-property 'set)) + + (should (null (mastodon-tl--find-property-range 'test-property 2 nil))) + (should (null (mastodon-tl--find-property-range 'test-property 2 t))))) + +(ert-deftest mastodon-tl--find-property-range--earlier-tag () + "Should cope with a buffer completely lacking the tag." + (with-temp-buffer + (insert (propertize "Just some text with a the sought property" 'test-property 'set)) + (let ((end-of-region (point))) + (insert "More random text") + + (should (null (mastodon-tl--find-property-range 'test-property end-of-region nil))) + (should (equal (cons (point-min) end-of-region) + (mastodon-tl--find-property-range 'test-property end-of-region t)))))) + +(ert-deftest mastodon-tl--find-property-range--successful-finding () + "Should find the sought tag in all expected circumstances." + (with-temp-buffer + (insert "Previous text") + (let ((start-of-region (point)) + end-of-region) + (insert (propertize "Just some text with a the sought property" 'test-property 'set)) + (setq end-of-region (point)) + (insert "More random text") + + ;; before the region + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property 1 nil))) + (should (null (mastodon-tl--find-property-range 'test-property 1 t))) + ;; in the region + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property (+ 2 start-of-region) nil))) + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property (+ 2 start-of-region) t))) + ;; at end of region + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property (1- end-of-region) nil))) + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property (1- end-of-region) t)))))) + +(ert-deftest mastodon-tl--find-property-range--successful-finding-consecutive-ranges () + "Should find the sought tag even from in between consecutive ranges." + (with-temp-buffer + (insert "Previous text") + (let ((start-of-region-1 (point)) + between-regions + end-of-region-2) + (insert (propertize "region1" 'test-property 'region1)) + (setq between-regions (point)) + (insert (propertize "region2" 'test-property 'region2)) + (setq end-of-region-2 (point)) + (insert "More random text") + + + ;; before + (should (equal (cons start-of-region-1 between-regions) + (mastodon-tl--find-property-range 'test-property 1 nil))) + (should (null (mastodon-tl--find-property-range 'test-property 1 t))) + + ;; between the regions + (should (equal (cons between-regions end-of-region-2) + (mastodon-tl--find-property-range 'test-property between-regions nil))) + (should (equal (cons between-regions end-of-region-2) + (mastodon-tl--find-property-range 'test-property between-regions t))) + ;; after + (should (null (mastodon-tl--find-property-range 'test-property end-of-region-2 nil))) + (should (equal (cons between-regions end-of-region-2) + (mastodon-tl--find-property-range 'test-property end-of-region-2 t)))))) + +(ert-deftest mastodon-tl--find-property-range--successful-finding-at-start () + "Should cope with a tag at start." + (with-temp-buffer + (insert (propertize "Just some text with a the sought property" 'test-property 'set)) + (let ((end-of-region (point))) + (insert "More random text") + + ;; at start of the region + (should (equal (cons 1 end-of-region) + (mastodon-tl--find-property-range 'test-property 1 nil))) + (should (equal (cons 1 end-of-region) + (mastodon-tl--find-property-range 'test-property 1 t))) + ;; in the region + (should (equal (cons 1 end-of-region) + (mastodon-tl--find-property-range 'test-property 3 nil))) + (should (equal (cons 1 end-of-region) + (mastodon-tl--find-property-range 'test-property 3 t))) + ;; at end of region + (should (equal (cons 1 end-of-region) + (mastodon-tl--find-property-range 'test-property (1- end-of-region) t)))))) + +(ert-deftest mastodon-tl--find-property-range--successful-finding-at-end () + "Should cope with a tag at end." + (with-temp-buffer + (insert "More random text") + (let ((start-of-region (point)) + end-of-region) + (insert (propertize "Just some text with a the sought property" 'test-property 'set)) + (setq end-of-region (point-max)) + + ;; before the region + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property 1 nil))) + (should (null (mastodon-tl--find-property-range 'test-property 1 t))) + ;; in the region + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property (1+ start-of-region) nil))) + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property (1+ start-of-region) t))) + ;; at end of region + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property (1- end-of-region) nil))) + (should (equal (cons start-of-region end-of-region) + (mastodon-tl--find-property-range 'test-property (1- end-of-region) t)))))) + +(ert-deftest mastodon-tl--find-property-range--successful-finding-whole-buffer () + "Should cope with a tag being set for the whole buffer." + (with-temp-buffer + (insert (propertize "Just some text with a the sought property" 'test-property 'set)) + + (should (equal (cons (point-min) (point-max)) + (mastodon-tl--find-property-range 'test-property 2 nil))) + (should (equal (cons (point-min) (point-max)) + (mastodon-tl--find-property-range 'test-property 2 t))))) + +(defun tl-tests--all-regions-with-property (property) + "Returns a list with (start . end) regions where PROPERTY is set." + (let (result + region) + (goto-char (point-min)) + (while (and (< (point) (point-max)) + (setq region (mastodon-tl--find-property-range property (point)))) + (push region result) + (goto-char (min (point-max) (cdr region)))) + (nreverse result))) + + +(ert-deftest mastodon-tl--next-tab-item--with-spaces-at-ends () + "Should do the correct tab actions." + (with-temp-buffer + ;; We build a buffer with 3 tab stops: "...R1...R2R3..." (a dot + ;; represents text that is not part of a link, so R1 and R2 have a + ;; gap in between each other, R2 and R3 don't. + (insert "Random text at start") + (let ((start 2) + (r1 (point)) + r2 gap r3 + end) + (insert (propertize "R1 R1 R1" 'mastodon-tab-stop 'region1)) + (setq gap (+ (point) 2)) + (insert " a gap ") + (setq r2 (point)) + (insert (propertize "R2 R2 R2" 'mastodon-tab-stop 'region2)) + (setq r3 (point)) + (insert (propertize "R3 R3 R3" 'mastodon-tab-stop 'region3)) + (setq end (+ (point) 2)) + (insert " more text at end") + + (let ((test-cases + ;; a list 4-elemet lists of (test-name start-point + ;; expected-prev-stop expected-next-stop): + (list (list 'start start start r1) + (list 'r1 r1 r1 r2) + (list 'gap gap r1 r2) + (list 'r2 r2 r1 r3) + (list 'r3 r3 r2 r3) + (list 'end end r3 end)))) + (with-mock + (stub message => nil) ;; don't mess up our test output with the function's messages + (cl-dolist (test test-cases) + (let ((test-name (cl-first test)) + (test-start (cl-second test)) + (expected-prev (cl-third test)) + (expected-next (cl-fourth test))) + (goto-char test-start) + (mastodon-tl--previous-tab-item) + (should (equal (list 'prev test-name expected-prev) + (list 'prev test-name (point)))) + (goto-char test-start) + (mastodon-tl--next-tab-item) + (should (equal (list 'next test-name expected-next) + (list 'next test-name (point))))))))))) + +(ert-deftest mastodon-tl--next-tab-item--no-spaces-at-ends () + "Should do the correct tab actions even with regions right at buffer ends." + (with-temp-buffer + ;; We build a buffer with 3 tab stops: "R1...R2R3...R4" (a dot + ;; represents text that is not part of a link, so R1 and R2, and + ;; R3 and R4 have a gap in between each other, R2 and R3 don't. + (let ((r1 (point)) + gap1 + r2 r3 + gap2 + r4) + (insert (propertize "R1 R1 R1" 'mastodon-tab-stop 'region1)) + (setq gap1 (+ (point) 2)) + (insert " a gap ") + (setq r2 (point)) + (insert (propertize "R2 R2 R2" 'mastodon-tab-stop 'region2)) + (setq r3 (point)) + (insert (propertize "R3 R3 R3" 'mastodon-tab-stop 'region3)) + (setq gap2 (+ (point) 2)) + (insert " another gap ") + (setq r4 (point)) + (insert (propertize "R4 R4 R4" 'mastodon-tab-stop 'region4)) + + (let ((test-cases + ;; a list 4-elemet lists of (test-name start-point + ;; expected-prev-stop expected-next-stop): + (list (list 'r1 r1 r1 r2) + (list 'gap1 gap1 r1 r2) + (list 'r2 r2 r1 r3) + (list 'r3 r3 r2 r4) + (list 'gap2 gap2 r3 r4) + (list 'r4 r4 r3 r4)))) + (with-mock + (stub message => nil) ;; don't mess up our test output with the function's messages + (cl-dolist (test test-cases) + (let ((test-name (cl-first test)) + (test-start (cl-second test)) + (expected-prev (cl-third test)) + (expected-next (cl-fourth test))) + (goto-char test-start) + (mastodon-tl--previous-tab-item) + (should (equal (list 'prev test-name expected-prev) + (list 'prev test-name (point)))) + (goto-char test-start) + (mastodon-tl--next-tab-item) + (should (equal (list 'next test-name expected-next) + (list 'next test-name (point))))))))))) + + +(defun tl-tests--property-values-at (property ranges) + "Returns a list with property values at the given ranges. + +The property value for PROPERTY within a region is assumed to be +constant." + (let (result) + (dolist (range ranges (nreverse result)) + (push (get-text-property (car range) property) result)))) + +(ert-deftest mastodon-tl--update-timestamps-callback () + "Should update the 5 timestamps at a time as expected." + (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."))) + (with-temp-buffer + (cl-dotimes (n 12) (insert-timestamp (+ n 2))) + (setq markers (nreverse markers)) + + (with-mock + (mock (current-time) => now) + (stub run-at-time => 'fake-timer) + + ;; 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)))) + + ;; 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" + "unset 12" "unset 13") + (tl-tests--property-values-at 'display + (tl-tests--all-regions-with-property 'timestamp)))) + (should (null (marker-position (nth 4 markers)))) + + ;; 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") + (tl-tests--property-values-at 'display + (tl-tests--all-regions-with-property 'timestamp)))) + (should (null (marker-position (nth 9 markers))))))))) + +(ert-deftest mastodon-tl--has-spoiler () + "Should be able to detect toots with spoiler text as expected" + (let* ((normal-toot mastodon-tl-test-base-toot) + (normal-toot-with-spoiler (cons '(spoiler_text . "spoiler") normal-toot)) + (boosted-toot mastodon-tl-test-base-boosted-toot) + (boosted-toot-with-spoiler (cons (cons 'reblog normal-toot-with-spoiler) + boosted-toot))) + (should (null (mastodon-tl--has-spoiler normal-toot))) + (should-not (null (mastodon-tl--has-spoiler normal-toot-with-spoiler))) + (should (null (mastodon-tl--has-spoiler boosted-toot))) + (should-not (null (mastodon-tl--has-spoiler boosted-toot-with-spoiler))))) + +(ert-deftest mastodon-tl--spoiler () + "Should render a toot with spoiler properly, with link that toggles the body." + (let ((normal-toot-with-spoiler (cons '(spoiler_text . "This is the spoiler warning text") + mastodon-tl-test-base-toot)) + toot-start + toot-end + link-region + body-position) + (with-temp-buffer + (insert "some text before\n") + (setq toot-start (point)) + (with-mock + (stub create-image => '(image "fake data")) + (stub shr-render-region => nil) ;; Travis's Emacs doesn't have libxml + (insert + (mastodon-tl--spoiler normal-toot-with-spoiler))) + (setq toot-end (point)) + (insert "\nsome more text.") + + (goto-char toot-start) + (should (eq t (looking-at "This is the spoiler warning text"))) + + (setq link-region (mastodon-tl--find-next-or-previous-property-range + 'mastodon-tab-stop toot-start nil)) + ;; There should be a link following the text: + (should-not (null link-region)) + (goto-char (car link-region)) + (should (eq t (looking-at "Content Warning"))) + + (setq body-position (+ 25 (cdr link-region))) ;; 25 is enough to skip the "\n--------------...." + + ;; The text a bit after the link should be invisible: + (should (eq t (get-text-property body-position 'invisible))) + + ;; Click the link: + (mastodon-tl--do-link-action-at-point (car link-region)) + + ;; The body is now visible: + (should (eq nil (get-text-property body-position 'invisible))) + + ;; Click the link once more: + (mastodon-tl--do-link-action-at-point (car link-region)) + + ;; The body is invisible again: + (should (eq t (get-text-property body-position 'invisible)))))) diff --git a/test/mastodon-toot-tests.el b/test/mastodon-toot-tests.el index e9d3b26..3e25536 100644 --- a/test/mastodon-toot-tests.el +++ b/test/mastodon-toot-tests.el @@ -1,5 +1,44 @@ (require 'el-mock) +(defconst mastodon-toot-multi-mention + '((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 . []))) + +(ert-deftest toot-multi-mentions () + (let ((mastodon-auth--acct-alist '(("https://local.social". "null"))) + (mastodon-instance-url "https://local.social")) + (should (string= + (mastodon-toot--mentions mastodon-toot-multi-mention) + "@local@local.social @federated@federated.social @federated@federated.cafe ")))) + +(ert-deftest toot-multi-mentions-with-name () + (let ((mastodon-auth--acct-alist + '(("https://local.social". "local"))) + (mastodon-instance-url "https://local.social")) + (should (string= + (mastodon-toot--mentions mastodon-toot-multi-mention) + "@federated@federated.social @federated@federated.cafe ")))) + +(ert-deftest toot-no-mention () + (let ((mastodon-auth--acct-alist + '(("https://local.social". "null"))) + (mastodon-instance-url "https://local.social")) + (should (string= (mastodon-toot--mentions mastodon-toot-no-mention) "")))) + (ert-deftest cancel () (with-mock (mock (kill-buffer-and-window)) |