Merge branch 'img-previews' into develop

4 files changed, 132 insertions, 56 deletions

diff --git a/lisp/mastodon-auth.el b/lisp/mastodon-auth.el
index 0b0c703..6729e81 100644
--- a/lisp/mastodon-auth.el
+++ b/lisp/mastodon-auth.el
@@ -73,12 +73,12 @@ If no auth-sources file, runs `mastodon-auth--generate-token-no-storing-credenti
   "Make POST to generate auth token, without using auth-sources file."
   (mastodon-http--post
    (concat mastodon-instance-url "/oauth/token")
-   `(("client_id" . ,(plist-get (mastodon-client) :client_id))
-     ("client_secret" . ,(plist-get (mastodon-client) :client_secret))
-     ("grant_type" . "password")
-     ("username" . ,(read-string "Email: " user-mail-address))
-     ("password" . ,(read-passwd "Password: "))
-     ("scope" . "read write follow"))
+   `(("client_id" ,(plist-get (mastodon-client) :client_id))
+     ("client_secret" ,(plist-get (mastodon-client) :client_secret))
+     ("grant_type" "password")
+     ("username" ,(read-string "Email: " user-mail-address))
+     ("password" ,(read-passwd "Password: "))
+     ("scope" "read write follow"))
    nil
    :unauthenticated))
 
diff --git a/lisp/mastodon-http.el b/lisp/mastodon-http.el
index bc48e8d..052218c 100644
--- a/lisp/mastodon-http.el
+++ b/lisp/mastodon-http.el
@@ -113,6 +113,12 @@ Authorization header is included by default unless UNAUTHENTICED-P is non-nil."
           (url-retrieve-synchronously url)
         (url-retrieve-synchronously url nil nil mastodon-http--timeout)))))
 
+(defun mastodon-http--read-file-as-string (filename)
+  ""
+  (with-temp-buffer
+    (insert-file-contents filename)
+    (string-to-unibyte (buffer-string))))
+
 (defun mastodon-http--get (url)
   "Make synchronous GET request to URL.
 
diff --git a/lisp/mastodon-media.el b/lisp/mastodon-media.el
index b58eab6..3016d33 100644
--- a/lisp/mastodon-media.el
+++ b/lisp/mastodon-media.el
@@ -47,7 +47,12 @@
   :type 'integer)
 
 (defcustom mastodon-media--preview-max-height 250
-  "Max height of any media attachment preview to be shown."
+  "Max height of any media attachment preview to be shown in timelines."
+  :group 'mastodon-media
+  :type 'integer)
+
+(defcustom mastodon-media--attachment-height 80
+  "Height of the attached images preview in the toot draft buffer."
   :group 'mastodon-media
   :type 'integer)
 
@@ -130,7 +135,7 @@ 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)
+    (status-plist marker image-options region-length url)
   "Callback function processing the url retrieve response for URL.
 
 STATUS-PLIST is the usual plist of status events as per `url-retrieve'.
@@ -151,6 +156,8 @@ REGION-LENGTH is the length of the region that should be replaced with the image
                                      (when image-options 'imagemagick)
                                    nil) ; inbuilt scaling in 27.1
                                  t image-options))))
+            (unless (url-is-cached url) ; cache image if not already cached
+              (url-store-in-cache url-buffer))
             (with-current-buffer (marker-buffer marker)
               ;; Save narrowing in our buffer
               (let ((inhibit-read-only t))
diff --git a/lisp/mastodon-toot.el b/lisp/mastodon-toot.el
index a8b121b..ec5a8ac 100644
--- a/lisp/mastodon-toot.el
+++ b/lisp/mastodon-toot.el
@@ -30,6 +30,7 @@
 ;;; Code:
 
 (defvar mastodon-instance-url)
+(defvar mastodon-media--attachment-height)
 
 (when (require 'emojify nil :noerror)
   (declare-function emojify-insert-emoji "emojify"))
@@ -49,6 +50,7 @@
 (autoload 'mastodon-tl--find-property-range "mastodon-tl")
 (autoload 'mastodon-toot "mastodon")
 (autoload 'mastodon-http--post-media-attachment "mastodon-http")
+(autoload 'mastodon-http--read-file-as-string "mastodon-http")
 (autoload 'mastodon-tl--toot-id "mastodon-tl")
 (autoload 'mastodon-tl--reload-timeline-or-profile "mastodon-tl")
 
@@ -88,7 +90,7 @@ Valid values are \"direct\", \"private\" (followers-only), \"unlisted\", and \"p
 (make-variable-buffer-local 'mastodon-toot--visibility)
 
 (defvar mastodon-toot--media-attachments nil
-  "A flag indicating if the toot being composed has media attachments.")
+  "A list of the media attachments of the toot being composed .")
 (make-variable-buffer-local 'mastodon-toot--media-attachments)
 
 (defvar mastodon-toot--media-attachment-ids nil
@@ -103,6 +105,10 @@ Valid values are \"direct\", \"private\" (followers-only), \"unlisted\", and \"p
   "Buffer-local variable to hold the id of the toot being replied to.")
 (make-variable-buffer-local 'mastodon-toot--reply-to-id)
 
+(defvar mastodon-toot--media-attachments nil
+  "Buffer-local variable to hold the list of media attachments.")
+(make-variable-buffer-local 'mastodon-toot--media-attachments)
+
 (defvar mastodon-toot-mode-map
   (let ((map (make-sparse-keymap)))
     (define-key map (kbd "C-c C-c") #'mastodon-toot--send)
@@ -110,9 +116,11 @@ Valid values are \"direct\", \"private\" (followers-only), \"unlisted\", and \"p
     (define-key map (kbd "C-c C-w") #'mastodon-toot--toggle-warning)
     (define-key map (kbd "C-c C-n") #'mastodon-toot--toggle-nsfw)
     (define-key map (kbd "C-c C-v") #'mastodon-toot--change-visibility)
-    (define-key map (kbd "C-c C-a") #'mastodon-toot--add-media-attachment)
     (when (require 'emojify nil :noerror)
       (define-key map (kbd "C-c C-e") #'mastodon-toot--insert-emoji))
+    (define-key map (kbd "C-c C-u") #'mastodon-toot--upload-attached-media)
+    (define-key map (kbd "C-c C-a") #'mastodon-toot--attach-media)
+    (define-key map (kbd "C-c !") #'mastodon-toot--clear-all-attachments)
     map)
   "Keymap for `mastodon-toot'.")
 
@@ -300,19 +308,6 @@ Remove MARKER if REMOVE is non-nil, otherwise add it."
   (setq mastodon-toot--visibility visibility)
   (message "Visibility set to %s" visibility))
 
-(defun mastodon-toot--add-media-attachment ()
-  "Prompt the user for a file and POST it to the media endpoint on the server.
-
-Set `mastodon-toot--media-attachment-ids' to the item's id so it can be attached to the toot."
-  (interactive)
-  (let* ((filename (read-file-name "Choose file to attach to this toot: "
-                                   mastodon-toot--default-media-directory))
-         (caption (read-string "Enter a caption: "))
-         (url (concat mastodon-instance-url "/api/v1/media")))
-    (message "Uploading %s..." (file-name-nondirectory filename))
-    (mastodon-http--post-media-attachment url filename caption)
-    (setq mastodon-toot--media-attachments t)))
-
 (defun mastodon-toot--send ()
   "Kill new-toot buffer/window and POST contents to the Mastodon instance.
 
@@ -340,10 +335,10 @@ If media items have been uploaded with `mastodon-toot--add-media-attachment', at
          (args (append args-no-media args-media)))
     (if (and mastodon-toot--media-attachments
              (equal mastodon-toot--media-attachment-ids nil))
-        (message "Looks like your uploads are not yet ready...")
+        (message "Looks like your uploads are not up: C-c C-u to upload...")
       (if empty-toot-p
           (message "Empty toot. Cowardly refusing to post this.")
-          (let ((response (mastodon-http--post endpoint args nil)))
+        (let ((response (mastodon-http--post endpoint args nil)))
           (mastodon-http--triage response
                                  (lambda ()
                                    (mastodon-toot--kill)
@@ -414,6 +409,7 @@ eg. \"feduser@fed.social\" -> \"feduser@fed.social\"."
   (interactive)
   (setq mastodon-toot--content-nsfw
         (not mastodon-toot--content-nsfw))
+  (message "NSFW flag is now %s" (if mastodon-toot--content-nsfw "on" "off"))
   (mastodon-toot--update-status-fields))
 
 (defun mastodon-toot--change-visibility ()
@@ -430,6 +426,74 @@ eg. \"feduser@fed.social\" -> \"feduser@fed.social\"."
                "public")))
   (mastodon-toot--update-status-fields))
 
+(defun mastodon-toot--clear-all-attachments ()
+  "Remove all attachments from a toot draft."
+  (interactive)
+  (setq mastodon-toot--media-attachments nil)
+  (mastodon-toot--refresh-attachments-display)
+  (mastodon-toot--update-status-fields))
+
+(defun mastodon-toot--attach-media (file content-type description)
+  "Prompt for a attachment FILE of CONTENT-TYPE with DESCRIPTION.
+A preview is displayed in the toot create buffer, and the file
+will be uploaded and attached to the toot upon sending."
+  (interactive "fFilename: \nsContent type: \nsDescription: ")
+  (when (>= (length mastodon-toot--media-attachments) 4)
+    ;; Only a max. of 4 attachments are allowed, so pop the oldest one.
+    (pop mastodon-toot--media-attachments))
+  (setq mastodon-toot--media-attachments
+        (nconc mastodon-toot--media-attachments
+               `(((:contents . ,(mastodon-http--read-file-as-string file))
+                  (:content-type . ,content-type)
+                  (:description . ,description)
+                  (:filename . ,file)))))
+  (mastodon-toot--refresh-attachments-display))
+
+(defun mastodon-toot--upload-attached-media ()
+  "Actually upload attachments using `mastodon-http--post-media-attachment'.
+It adds the items' ids to `mastodon-toot--media-attachment-ids', which is used to actually attach them to a toot after uploading."
+  (interactive)
+  (mapcar (lambda (attachment)
+            (let* ((filename (cdr (assoc :filename attachment)))
+                   (caption (cdr (assoc :description attachment)))
+                   (url (concat mastodon-instance-url "/api/v1/media")))
+              (message "Uploading %s..." (file-name-nondirectory filename))
+              (mastodon-http--post-media-attachment url filename caption)))
+            mastodon-toot--media-attachments))
+
+(defun mastodon-toot--refresh-attachments-display ()
+  "Update the display attachment previews in toot draft buffer."
+  (let ((inhibit-read-only t)
+        (attachments-region (mastodon-tl--find-property-range
+                             'toot-attachments (point-min)))
+        (display-specs (mastodon-toot--format-attachments)))
+    (dotimes (i (- (cdr attachments-region) (car attachments-region)))
+      (add-text-properties (+ (car attachments-region) i)
+                           (+ (car attachments-region) i 1)
+                           (list 'display (or (nth i display-specs) ""))))))
+
+(defun mastodon-toot--format-attachments ()
+  "Format the attachment previews for display in toot draft buffer."
+  (or (let ((counter 0)
+            (image-options (when (or (image-type-available-p 'imagemagick)
+                                     (image-transforms-p))
+                             `(:height ,mastodon-media--attachment-height))))
+        (mapcan (lambda (attachment)
+                  (let* ((data (cdr (assoc :contents attachment)))
+                         (image (apply #'create-image data
+                                       (if (version< emacs-version "27.1")
+                                           (when image-options 'imagemagick)
+                                         nil) ; inbuilt scaling in 27.1
+                                       t image-options))
+                         (type (cdr (assoc :content-type attachment)))
+                         (description (cdr (assoc :description attachment))))
+                    (setq counter (1+ counter))
+                    (list (format "\n    %d: " counter)
+                          image
+                          (format " \"%s\" (%s)" description type))))
+                mastodon-toot--media-attachments))
+      (list "None")))
+
 ;; we'll need to revisit this if the binds get
 ;; more diverse than two-chord bindings
 (defun mastodon-toot--get-mode-kbinds ()
@@ -483,6 +547,10 @@ on the status of NSFW, content warning flags, media attachments, etc."
        divider "\n"
        (mastodon-toot--make-mode-docs) "\n"
        divider "\n"
+       " Attachments: "
+       (propertize "None                  " 'toot-attachments t)
+       "\n"
+       divider "\n"
        " "
        (propertize "Count"
                    'toot-post-counter t)
@@ -490,9 +558,6 @@ on the status of NSFW, content warning flags, media attachments, etc."
        (propertize "Visibility"
                    'toot-post-visibility t)
        " ⋅ "
-       (propertize "Attachment"
-                   'toot-attachment t)
-       " ⋅ "
        (propertize "CW"
                    'toot-post-cw-flag t)
        " "
@@ -515,24 +580,23 @@ If REPLY-TO-ID is provided, set the MASTODON-TOOT--REPLY-TO-ID var."
 
 (defun mastodon-toot--update-status-fields (&rest args)
   "Update the status fields in the header based on the current state."
-  (let ((inhibit-read-only t)
-        (header-region (mastodon-tl--find-property-range 'toot-post-header
+  (ignore-errors  ;; called from after-change-functions so let's not leak errors
+    (let ((inhibit-read-only t)
+         (header-region (mastodon-tl--find-property-range 'toot-post-header
+                                                          (point-min)))
+         (count-region (mastodon-tl--find-property-range 'toot-post-counter
                                                          (point-min)))
-        (count-region (mastodon-tl--find-property-range 'toot-post-counter
+         (visibility-region (mastodon-tl--find-property-range
+                             'toot-post-visibility (point-min)))
+         (nsfw-region (mastodon-tl--find-property-range 'toot-post-nsfw-flag
                                                         (point-min)))
-        (visibility-region (mastodon-tl--find-property-range
-                            'toot-post-visibility (point-min)))
-        (nsfw-region (mastodon-tl--find-property-range 'toot-post-nsfw-flag
-                                                       (point-min)))
-        (cw-region (mastodon-tl--find-property-range 'toot-post-cw-flag
-                                                     (point-min)))
-        (attachment-region (mastodon-tl--find-property-range
-                            'toot-attachment (point-min))))
-    (add-text-properties (car count-region) (cdr count-region)
-                         (list 'display
-                               (format "%s characters"
-                                       (- (point-max) (cdr header-region)))))
-    (add-text-properties (car visibility-region) (cdr visibility-region)
+         (cw-region (mastodon-tl--find-property-range 'toot-post-cw-flag
+                                                      (point-min))))
+     (add-text-properties (car count-region) (cdr count-region)
+                          (list 'display
+                                (format "%s characters"
+                                        (- (point-max) (cdr header-region)))))
+     (add-text-properties (car visibility-region) (cdr visibility-region)
                          (list 'display
                                (format "Visibility: %s"
                                        (if (equal
@@ -540,18 +604,15 @@ If REPLY-TO-ID is provided, set the MASTODON-TOOT--REPLY-TO-ID var."
                                             "private")
                                            "followers-only"
                                          mastodon-toot--visibility))))
-    (add-text-properties (car attachment-region) (cdr attachment-region)
-                         (list 'display
-                               (format "Attached: %s"
-                                       (mapconcat 'identity
-                                        mastodon-toot--media-attachment-filenames
-                                        ", "))))
-    (add-text-properties (car nsfw-region) (cdr nsfw-region)
-                         (list 'invisible (not mastodon-toot--content-nsfw)
-                               'face 'mastodon-cw-face))
-    (add-text-properties (car cw-region) (cdr cw-region)
-                         (list 'invisible (not mastodon-toot--content-warning)
-                               'face 'mastodon-cw-face))))
+     (add-text-properties (car nsfw-region) (cdr nsfw-region)
+                          (list 'display (if mastodon-toot--content-nsfw
+                                             (if mastodon-toot--media-attachments
+                                                 "NSFW" "NSFW (no effect until attachments added)")
+                                           "")
+                                'face 'mastodon-cw-face))
+     (add-text-properties (car cw-region) (cdr cw-region)
+                          (list 'invisible (not mastodon-toot--content-warning)
+                                'face 'mastodon-cw-face)))))
 
 (defun mastodon-toot--compose-buffer (reply-to-user reply-to-id)
   "Create a new buffer to capture text for a new toot.
@@ -561,12 +622,14 @@ If REPLY-TO-ID is provided, set the MASTODON-TOOT--REPLY-TO-ID var."
          (buffer (or buffer-exists (get-buffer-create "*new toot*")))
          (inhibit-read-only t))
     (switch-to-buffer-other-window buffer)
+    (mastodon-toot-mode t)
     (when (not buffer-exists)
       (mastodon-toot--display-docs-and-status-fields)
       (mastodon-toot--setup-as-reply reply-to-user reply-to-id))
     (mastodon-toot-mode t)
     (make-local-variable 'after-change-functions)
     (push #'mastodon-toot--update-status-fields after-change-functions)
+    (mastodon-toot--refresh-attachments-display)
     (mastodon-toot--update-status-fields)))
 
 (define-minor-mode mastodon-toot-mode