diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/mastodon-http.el | 16 | ||||
| -rw-r--r-- | lisp/mastodon-profile.el | 77 | ||||
| -rw-r--r-- | lisp/mastodon-tl.el | 34 | ||||
| -rw-r--r-- | lisp/mastodon-toot.el | 75 | ||||
| -rw-r--r-- | lisp/mastodon.el | 12 |
5 files changed, 192 insertions, 22 deletions
diff --git a/lisp/mastodon-http.el b/lisp/mastodon-http.el index f73fd6b..e3efabe 100644 --- a/lisp/mastodon-http.el +++ b/lisp/mastodon-http.el @@ -74,7 +74,8 @@ This is a thin abstraction over the system `url-retrieve-synchronously'. Depending on which version of this -is available we will call it with or without a timeout." +is available we will call it with or without a timeout. +SILENT means don't message." (if (< (cdr (func-arity 'url-retrieve-synchronously)) 4) (url-retrieve-synchronously url) (url-retrieve-synchronously url (or silent nil) nil mastodon-http--timeout))) @@ -141,14 +142,15 @@ Authorization header is included by default unless UNAUTHENTICATED-P is non-nil. (defun mastodon-http--get (url &optional silent) "Make synchronous GET request to URL. - -Pass response buffer to CALLBACK function." +Pass response buffer to CALLBACK function. +SILENT means don't message." (mastodon-http--authorized-request "GET" (mastodon-http--url-retrieve-synchronously url silent))) (defun mastodon-http--get-json (url &optional silent) - "Make synchronous GET request to URL. Return JSON response." + "Make synchronous GET request to URL. Return JSON response. +SILENT means don't message." (with-current-buffer (mastodon-http--get url silent) (mastodon-http--process-json))) @@ -194,7 +196,8 @@ PARAMS should be an alist as required by `url-build-query-string'." (defun mastodon-http--get-search-json (url query &optional param silent) "Make GET request to URL, searching for QUERY and return JSON response. -PARAM is any extra parameters to send with the request." +PARAM is any extra parameters to send with the request. +SILENT means don't message." (let ((buffer (mastodon-http--get-search url query param silent))) (with-current-buffer buffer (mastodon-http--process-json-search)))) @@ -202,7 +205,8 @@ PARAM is any extra parameters to send with the request." (defun mastodon-http--get-search (base-url query &optional param silent) "Make GET request to BASE-URL, searching for QUERY. Pass response buffer to CALLBACK function. -PARAM is a formatted request parameter, eg 'following=true'." +PARAM is a formatted request parameter, eg 'following=true'. +SILENT means don't message." (mastodon-http--authorized-request "GET" (let ((url (if param diff --git a/lisp/mastodon-profile.el b/lisp/mastodon-profile.el index 054f6e5..4aa9310 100644 --- a/lisp/mastodon-profile.el +++ b/lisp/mastodon-profile.el @@ -74,6 +74,8 @@ (defvar mastodon-tl--update-point) (defvar mastodon-mode-map) (defvar mastodon-toot--max-toot-chars) +(defvar mastodon-toot--visibility) +(defvar mastodon-toot--content-nsfw) (defvar-local mastodon-profile--account nil "The data for the account being described in the current profile buffer.") @@ -226,7 +228,9 @@ JSON is the data returned by the server." "Fetch current VAL ue from account." (let* ((url (mastodon-http--api "accounts/verify_credentials")) (response (mastodon-http--get-json url))) - (alist-get val response))) + (if (eq (alist-get val response) ':json-false) + nil + (alist-get val response)))) (defun mastodon-profile--get-source-values () "Return the \"source\" preferences from the server." @@ -235,7 +239,9 @@ JSON is the data returned by the server." (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))) - (alist-get pref source))) + (if (eq (alist-get pref source) ':json-false) + nil + (alist-get pref source)))) (defun mastodon-profile--update-user-profile-note () "Fetch user's profile note and display for editing." @@ -346,7 +352,7 @@ Current settings are fetched from the server." (mastodon-profile--get-source-value key) (mastodon-profile--get-json-value key))) (prompt (format "Account setting %s is %s. Toggle?" key val))) - (if (not (equal val :json-false)) + (if val (when (y-or-n-p prompt) (mastodon-profile--update-preference (symbol-name key) "false" source)) (when (y-or-n-p prompt) @@ -365,6 +371,63 @@ Current settings are fetched from the server." (interactive) (mastodon-profile--edit-string-value 'display_name)) +(defun mastodon-profile--make-meta-fields-params (fields) + "Construct a parameter query string from metadata alist FIELDS. +Returns an alist." + (let ((keys (cl-loop for count from 1 to 5 + collect (cons (format "fields_attributes[%s][name]" count) + (format "fields_attributes[%s][value]" count))))) + (cl-loop for a-pair in keys + for b-pair in fields + append (list (cons (car a-pair) + (car b-pair)) + (cons (cdr a-pair) + (cdr b-pair)))))) + +(defun mastodon-profile-update-meta-fields () + "Prompt for new metadata fields information and PATCH the server." + (interactive) + (let* ((url (mastodon-http--api "accounts/update_credentials")) + (fields-updated (mastodon-profile--update-meta-fields-alist)) + (params (mastodon-profile--make-meta-fields-params fields-updated)) + (response (mastodon-http--patch url params))) + (mastodon-http--triage response + (lambda () + (mastodon-profile-fetch-server-account-settings) + (message "Account setting %s updated to %s!" + "metadata fields" fields-updated))))) + +(defun mastodon-profile--update-meta-fields-alist () + "Prompt for new metadata fields information. +Returns the results as an alist." + (let ((fields-old (mastodon-profile--fields-get + nil + ;; we must fetch the plaintext version: + (mastodon-profile--get-source-value 'fields)))) + ;; offer empty fields if user currently has less than four filled: + (while (< (length fields-old) 4) + (setq fields-old + (append fields-old '(("" . ""))))) + (let ((alist + (cl-loop for f in fields-old + for x from 1 to 5 + collect + (cons (read-string + (format "Metadata key [%s/4] (max. 255 chars): " x) + (car f)) + (read-string + (format "Metadata value [%s/4] (max. 255 chars): " x) + (cdr f)))))) + ;; hack to avoiding using `string-limit', which req. 28.1: + (mapcar (lambda (x) + (cons (mastodon-profile--limit-to-255 (car x)) + (mastodon-profile--limit-to-255 (cdr x)))) + alist)))) + +(defun mastodon-profile--limit-to-255 (x) + "Limit string X to 255 chars max." + (if (> (length x) 255) (substring x 0 255) x)) + (defun mastodon-profile--get-preferences-pref (pref) "Fetch PREF from the endpoint \"/preferences\". This endpoint only holds a few preferences. For others, see @@ -404,10 +467,12 @@ This endpoint only holds a few preferences. For others, see their-id)))) (mastodon-http--get-json url))) -(defun mastodon-profile--fields-get (account) +(defun mastodon-profile--fields-get (&optional account fields) "Fetch the fields vector (aka profile metadata) from profile of ACCOUNT. -Returns an alist." - (let ((fields (mastodon-profile--account-field account 'fields))) +Returns an alist. +FIELDS means provide a fields vector fetched by other means." + (let ((fields (or fields + (mastodon-profile--account-field account 'fields)))) (when fields (mapcar (lambda (el) (cons (alist-get 'name el) diff --git a/lisp/mastodon-tl.el b/lisp/mastodon-tl.el index 130b01f..6f53f93 100644 --- a/lisp/mastodon-tl.el +++ b/lisp/mastodon-tl.el @@ -5,7 +5,7 @@ ;; Marty Hiatt <martianhiatus@riseup.net> ;; Maintainer: Marty Hiatt <martianhiatus@riseup.net> ;; Version: 1.0.0 -;; Package-Requires: ((emacs "27.1")) +;; Package-Requires: ((emacs "27.1") (ts "0.3")) ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. @@ -32,6 +32,7 @@ ;;; Code: (require 'shr) +(require 'ts) (require 'thingatpt) ; for word-at-point (require 'time-date) (require 'cl-lib) @@ -946,6 +947,10 @@ this just means displaying toot client." (defun mastodon-tl--get-poll (toot) "If TOOT includes a poll, return it as a formatted string." (let* ((poll (mastodon-tl--field 'poll toot)) + (expiry (mastodon-tl--field 'expires_at poll)) + (expired-p (if (eq (mastodon-tl--field 'expired poll) :json-false) nil t)) + (multi (mastodon-tl--field 'multiple poll)) + (vote-count (mastodon-tl--field 'voters_count poll)) (options (mastodon-tl--field 'options poll)) (option-titles (mapcar (lambda (x) (alist-get 'title x)) @@ -958,20 +963,41 @@ this just means displaying toot client." (concat "\nPoll: \n\n" (mapconcat (lambda (option) (progn - (format "Option %s: %s%s [%s votes].\n" + (format "%s: %s%s%s\n" (setq option-counter (1+ option-counter)) - (alist-get 'title option) + (propertize (alist-get 'title option) + 'face 'success) (make-string (1+ (- (length longest-option) (length (alist-get 'title option)))) ?\ ) - (alist-get 'votes_count option)))) + ;; TODO: disambiguate no votes from hidden votes + (format "[%s votes]" (or (alist-get 'votes_count option) + "0"))))) options "\n") + "\n" + (propertize (format "%s people | " vote-count) + 'face 'font-lock-comment-face) + (let ((str (if expired-p + "Poll expired." + (mastodon-tl--format-poll-expiry expiry)))) + (propertize str 'face 'font-lock-comment-face)) "\n"))) +(defun mastodon-tl--format-poll-expiry (timestamp) + "Convert poll expiry TIMESTAMP into a descriptive string." + (let ((parsed (ts-human-duration + (ts-diff (ts-parse timestamp) (ts-now))))) + (cond ((> (plist-get parsed :days) 0) + (format "%s days, %s hours left" (plist-get parsed :days) (plist-get parsed :hours))) + ((> (plist-get parsed :hours) 0) + (format "%s hours, %s minutes left" (plist-get parsed :hours) (plist-get parsed :minutes))) + ((> (plist-get parsed :minutes) 0) + (format "%s minutes left" (plist-get parsed :minutes)))))) + (defun mastodon-tl--poll-vote (option) "If there is a poll at point, prompt user for OPTION to vote on it." (interactive diff --git a/lisp/mastodon-toot.el b/lisp/mastodon-toot.el index bcf9c83..bd24f6f 100644 --- a/lisp/mastodon-toot.el +++ b/lisp/mastodon-toot.el @@ -76,6 +76,7 @@ (autoload 'mastodon-toot "mastodon") (autoload 'mastodon-profile--get-source-pref "mastodon-profile") (autoload 'mastodon-profile--update-preference "mastodon-profile") +(autoload 'mastodon-profile-fetch-server-account-settings "mastodon-profile") (autoload 'mastodon-tl--render-text "mastodon-tl") ;; for mastodon-toot--translate-toot-text @@ -161,6 +162,9 @@ change the setting on the server, see (defvar-local mastodon-toot--media-attachment-ids nil "A list of any media attachment ids of the toot being composed.") +(defvar-local mastodon-toot-poll nil + "A list of poll options for the toot being composed.") + (defvar-local mastodon-toot--reply-to-id nil "Buffer-local variable to hold the id of the toot being replied to.") @@ -187,6 +191,7 @@ send.") (define-key map (kbd "C-c C-e") #'mastodon-toot--insert-emoji)) (define-key map (kbd "C-c C-a") #'mastodon-toot--attach-media) (define-key map (kbd "C-c !") #'mastodon-toot--clear-all-attachments) + (define-key map (kbd "C-c C-p") #'mastodon-toot--create-poll) map) "Keymap for `mastodon-toot'.") @@ -473,7 +478,7 @@ CANCEL means the toot was not sent, so we save the toot text as a draft." (cl-pushnew mastodon-toot-current-toot-text mastodon-toot-draft-toots-list :test 'equal))) ;; prevent some weird bug when cancelling a non-empty toot: - (delete #'mastodon-toot-save-toot-text after-change-functions) + (delete #'mastodon-toot--save-toot-text after-change-functions) (kill-buffer-and-window)) (defun mastodon-toot--cancel () @@ -594,6 +599,15 @@ to `emojify-user-emojis', and the emoji data is updated." (setq mastodon-toot--visibility visibility) (message "Visibility set to %s" visibility)) +(defun mastodon-toot--build-poll-params () + "Return an alist of parameters for POSTing a poll status." + (append + (mastodon-toot--make-poll-options-params + (plist-get mastodon-toot-poll :options)) + `(("poll[expires_in]" . ,(plist-get mastodon-toot-poll :expiry))) + `(("poll[multiple]" . ,(symbol-name (plist-get mastodon-toot-poll :multi)))) + `(("poll[hide_totals]" . ,(symbol-name (plist-get mastodon-toot-poll :hide)))))) + (defun mastodon-toot--send () "POST contents of new-toot buffer to Mastodon instance and kill buffer. If media items have been attached and uploaded with @@ -614,7 +628,14 @@ If media items have been attached and uploaded with (mapcar (lambda (id) (cons "media_ids[]" id)) mastodon-toot--media-attachment-ids))) - (args (append args-media args-no-media))) + (args-poll (when mastodon-toot-poll + (mastodon-toot--build-poll-params))) + ;; media || polls: + (args (if mastodon-toot--media-attachments + (append args-media args-no-media) + (if mastodon-toot-poll + (append args-no-media args-poll) + args-no-media)))) (cond ((and mastodon-toot--media-attachments ;; make sure we have media args ;; and the same num of ids as attachments @@ -919,6 +940,53 @@ which is used to attach it to a toot when posting." mastodon-toot--media-attachments)) (list "None"))) +(defun mastodon-toot--make-poll-options-params (options) + "Return an parameter query alist from poll OPTIONS." + (let ((key "poll[options][]")) + (cl-loop for o in options + collect `(,key . ,o)))) + +(defun mastodon-toot--create-poll () + "Prompt for new poll options and return as a list." + (interactive) + ;; re length, API docs show a poll 9 options. + (let* ((length (read-number "Number of options [2-4]: " 2)) + (multiple-p (y-or-n-p "Multiple choice? ")) + (options (mastodon-toot--read-poll-options length)) + (hide-totals (y-or-n-p "Hide votes until poll ends? ")) + (expiry (mastodon-toot--get-poll-expiry))) + (setq mastodon-toot-poll + `(:options ,options :length ,length :multi ,multiple-p :hide ,hide-totals :expiry ,expiry)) + (message "poll created!"))) + +(defun mastodon-toot--read-poll-options (length) + "Read a list of options for poll of LENGTH options." + (cl-loop for x from 1 to length + collect (read-string (format "Poll option [%s/%s]: " x length)))) + +(defun mastodon-toot--get-poll-expiry () + "Prompt for a poll expiry time." + ;; API requires this in seconds + (let* ((options (mastodon-toot--poll-expiry-options-alist)) + (response (completing-read "poll ends in [or enter seconds]: " + options nil 'confirm))) + (or (alist-get response options nil nil #'equal) + (if (< (string-to-number response) 600) + "600" ;; min 5 mins + response)))) + +(defun mastodon-toot--poll-expiry-options-alist () + "Return an alist of seconds options." + `(("5 minutes" . ,(number-to-string (* 60 5))) + ("30 minutes" . ,(number-to-string (* 60 30))) + ("1 hour" . ,(number-to-string (* 60 60))) + ("6 hours" . ,(number-to-string (* 60 60 6))) + ("1 day" . ,(number-to-string (* 60 60 24))) + ("3 days" . ,(number-to-string (* 60 60 24 3))) + ("7 days" . ,(number-to-string (* 60 60 24 7))) + ("14 days" . ,(number-to-string (* 60 60 24 14))) + ("30 days" . ,(number-to-string (* 60 60 24 30))))) + ;; we'll need to revisit this if the binds get ;; more diverse than two-chord bindings (defun mastodon-toot--get-mode-kbinds () @@ -1187,6 +1255,9 @@ a draft into the buffer." (when initial-text (insert initial-text)))) +;;;###autoload +(add-hook 'mastodon-toot-mode-hook #'mastodon-profile-fetch-server-account-settings) + (define-minor-mode mastodon-toot-mode "Minor mode to capture Mastodon toots." :group 'mastodon-toot diff --git a/lisp/mastodon.el b/lisp/mastodon.el index e50d5c1..671c88d 100644 --- a/lisp/mastodon.el +++ b/lisp/mastodon.el @@ -1,11 +1,13 @@ -;;; mastodon.el --- Client for Mastodon -*- lexical-binding: t -*- +;;; mastodon.el --- Client for Mastodon, a federated social network -*- lexical-binding: t -*- ;; Copyright (C) 2017-2019 Johnson Denen +;; Copyright (C) 2020-2022 Marty Hiatt ;; Copyright (C) 2021 Abhiseck Paira <abhiseckpaira@disroot.org> ;; Author: Johnson Denen <johnson.denen@gmail.com> +;; Marty Hiatt <martianhiatus@riseup.net> ;; Maintainer: Marty Hiatt <martianhiatus@riseup.net> ;; Version: 1.0.0 -;; Package-Requires: ((emacs "27.1") (request "0.3.0") (persist "0.4")) +;; Package-Requires: ((emacs "27.1") (request "0.3.0") (persist "0.4") (ts "0.3")) ;; Homepage: https://codeberg.org/martianh/mastodon.el ;; This file is not part of GNU Emacs. @@ -29,7 +31,7 @@ ;; mastodon.el is an Emacs client for Mastodon <https://github.com/tootsuite/mastodon>, ;; the federated microblogging social network. It also works with Pleroma instances. -;; see the readme file at https://codeberg.org/martianh/mastodon.el for set up and usage details. +;; See the readme file at https://codeberg.org/martianh/mastodon.el for set up and usage details. ;;; Code: (require 'cl-lib) ; for `cl-some' call in mastodon @@ -37,6 +39,8 @@ (require 'mastodon-http) (require 'mastodon-toot) (require 'url) +(require 'thingatpt) +(require 'shr) (declare-function discover-add-context-menu "discover") (declare-function emojify-mode "emojify") @@ -280,7 +284,7 @@ If a status or account is found, load it in `mastodon.el', if not, just browse the URL in the normal fashion." (interactive) (let* ((query (or query-url - (url-get-url-at-point) + (thing-at-point-url-at-point) (get-text-property (point) 'shr-url) (read-string "Lookup URL: ")))) (if (not (mastodon--masto-url-p query)) |