Merge branch 'develop'

7 files changed, 202 insertions, 26 deletions

diff --git a/Cask b/Cask
index a960f81..c193326 100644
--- a/Cask
+++ b/Cask
@@ -7,6 +7,7 @@
 (depends-on "request" "0.3.0")
 (depends-on "seq")
 (depends-on "persist")
+(depends-on "ts")
 
 (development
  (depends-on "ert-runner")
diff --git a/README.org b/README.org
index 73a42e5..2db8681 100644
--- a/README.org
+++ b/README.org
@@ -202,7 +202,8 @@ You can download and use your instance's custom emoji
 | =C-c C-n= | Add sensitive media/nsfw flag    |
 | =C-c C-a= | Upload attachment(s)             |
 | =C-c !=   | Remove all attachments           |
-| =C-c C-e= | add emoji (if =emojify= installed) |
+| =C-c C-e= | Add emoji (if =emojify= installed) |
+| =C-c C-p= | Create a poll                    |
 |---------+----------------------------------|
 
 **** draft toots
@@ -222,6 +223,8 @@ You can download and use your instance's custom emoji
 - =mastodon-search-trending-tags=: View a list of trending hashtags on your instance.
 
 - =mastodon-profile-update-display-name=: Update the display name for your account.
+- =mastodon-profile-update-user-profile-note=: Update your bio note.
+- =mastodon-profile-update-meta-fields=: Update your metadata fields.
 - =mastodon-profile-set-default-toot-visibility=: Set the default visibility for your toots.
 - =mastodon-profile-account-locked-toggle=: Toggle the locked status of your account. Locked accounts have to manually approve follow requests.
 - =mastodon-profile-account-discoverable-toggle=: Toggle the discoverable status of your account. Non-discoverable accounts are not listed in the profile directory.
@@ -283,8 +286,10 @@ to your translator function as its text argument. Here's what
 
 ** Dependencies
 
-This version depends on the library =request= (for uploading attachments). You
-can install it from MELPA, or https://github.com/tkf/emacs-request.
+Hard dependencies (should all install with =mastodon.el=):
+- =request= (for uploading attachments), https://github.com/tkf/emacs-request
+- =persist= for storing some settings across sessions
+- =ts= for poll relative expiry times
 
 Optional dependencies:
 - =company= for autocompletion of mentions and tags when composing a toot
@@ -294,7 +299,7 @@ Optional dependencies:
 
 ** Contributing
 
-PRs, issues, and feature requests are very welcome!
+PRs, issues, feature requests, and general feedback are very welcome!
 
 *** Features
 
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))