implement uploading and posting of media attachments.

uses request library and requires curl backend.

supports multiple files upload and marking media as sensitive.

2 files changed, 115 insertions, 25 deletions

diff --git a/lisp/mastodon-http.el b/lisp/mastodon-http.el
index 58f6c7e..7250ef8 100644
--- a/lisp/mastodon-http.el
+++ b/lisp/mastodon-http.el
@@ -30,6 +30,7 @@
 ;;; Code:
 
 (require 'json)
+(require 'request) ; for attachments upload
 (defvar mastodon-instance-url)
 (autoload 'mastodon-auth--access-token "mastodon-auth")
 
@@ -154,6 +155,7 @@ Pass response buffer to CALLBACK function with args CBARGS."
 
 Authorization header is included by default unless UNAUTHENTICED-P is non-nil."
   (let ((url-request-method "POST")
+        (request-timeout 5)
         (url-request-data
          (when args
            (mapconcat (lambda (arg)
@@ -168,5 +170,45 @@ Authorization header is included by default unless UNAUTHENTICED-P is non-nil."
     (with-temp-buffer
       (url-retrieve url callback cbargs mastodon-http--timeout))))
 
+;; TODO: test for curl first?
+(defun mastodon-http--post-media-attachment (url filename caption)
+  "Make a POST request to upload file FILENAME with CAPTION to the server's media URL.
+
+The upload is asynchronous. On succeeding, `mastodon-toot--media-attachment-ids' is set to the id(s) of the item uploaded, `mastodon-toot--media-attachments' is set to t, and `mastodon-toot--update-status-fields' is run."
+  (let* ((file (file-name-nondirectory filename))
+         (request-backend 'curl)
+         (response
+          (request
+            url
+            :type "POST"
+            :params `(("description" . ,caption))
+            :files `(("file" . (,file :file ,filename
+                                      :mime-type "multipart/form-data")))
+            :parser 'json-read
+            :headers `(("Authorization" . ,(concat "Bearer "
+                                                   (mastodon-auth--access-token))))
+            :sync nil
+            :success (cl-function
+                      (lambda (&key data &allow-other-keys)
+                        (when data
+                          (progn
+                            (push (cdr (assoc 'id data))
+                                  mastodon-toot--media-attachment-ids) ; add ID to list
+                            (push file mastodon-toot--media-attachment-filenames)
+                            (message "%s file %s with id %S and caption '%s' uploaded!"
+                                     (capitalize (cdr (assoc 'type data)))
+                                     file
+                                     (cdr (assoc 'id data))
+                                     (cdr (assoc 'description data)))
+                            (mastodon-toot--update-status-fields)))))
+            :error (cl-function
+                    (lambda (&key error-thrown &allow-other-keys)
+                      (message "Got error: %s" error-thrown)))
+            )))
+    (pcase (request-response-status-code response)
+      (200
+       (request-response-data response)
+       ))))
+
 (provide 'mastodon-http)
 ;;; mastodon-http.el ends here
diff --git a/lisp/mastodon-toot.el b/lisp/mastodon-toot.el
index 52af778..a11bfa0 100644
--- a/lisp/mastodon-toot.el
+++ b/lisp/mastodon-toot.el
@@ -73,6 +73,18 @@ Must be one of \"public\", \"unlisted\", \"private\", or \"direct\"."
 Valid values are \"direct\", \"private\", \"unlisted\", and \"public\".")
 (make-variable-buffer-local 'mastodon-toot--visibility)
 
+(defvar mastodon-toot--media-attachments nil
+  "A flag indicating if the toot being composed has media attachments.")
+(make-variable-buffer-local 'mastodon-toot--media-attachments)
+
+(defvar mastodon-toot--media-attachment-ids nil
+  "A list of any media attachment ids of the toot being composed.")
+(make-variable-buffer-local 'mastodon-toot--media-attachment-ids)
+
+(defvar mastodon-toot--media-attachment-filenames nil
+  "A list of any media attachment filenames of the toot being composed.")
+(make-variable-buffer-local 'mastodon-toot--media-attachment-filenames)
+
 (defvar mastodon-toot--reply-to-id nil
   "Buffer-local variable to hold the id of the toot being replied to.")
 (make-variable-buffer-local 'mastodon-toot--reply-to-id)
@@ -82,8 +94,9 @@ Valid values are \"direct\", \"private\", \"unlisted\", and \"public\".")
     (define-key map (kbd "C-c C-c") #'mastodon-toot--send)
     (define-key map (kbd "C-c C-k") #'mastodon-toot--cancel)
     (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-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)
     map)
   "Keymap for `mastodon-toot'.")
 
@@ -194,28 +207,52 @@ 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: "))
+         (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."
+  "Kill new-toot buffer/window and POST contents to the Mastodon instance.
+
+If media items have been uploaded with `mastodon-toot--add-media-attachment', attach them to the toot."
   (interactive)
   (let* ((toot (mastodon-toot--remove-docs))
-         (empty-toot-p (string= "" (mastodon-tl--clean-tabs-and-nl toot)))
+         (empty-toot-p (and (not mastodon-toot--media-attachments)
+                            (string= "" (mastodon-tl--clean-tabs-and-nl toot))))
          (endpoint (mastodon-http--api "statuses"))
          (spoiler (when (and (not empty-toot-p)
                              mastodon-toot--content-warning)
                     (read-string "Warning: ")))
-         (args `(("status" . ,toot)
-                 ("in_reply_to_id" . ,mastodon-toot--reply-to-id)
-                 ("visibility" . ,mastodon-toot--visibility)
-                 ("sensitive" . ,(when mastodon-toot--content-nsfw
-                                   (symbol-name t)))
-                 ("visibility" . ,mastodon-toot--visibility)
-                 ("spoiler_text" . ,spoiler))))
-    (if empty-toot-p
-        (message "Empty toot. Cowardly refusing to post this.")
-      (mastodon-toot--kill)
-      (let ((response (mastodon-http--post endpoint args nil)))
-        (mastodon-http--triage response
-                               (lambda () (message "Toot toot!")))))))
+         (args-no-media `(("status" . ,toot)
+                          ("in_reply_to_id" . ,mastodon-toot--reply-to-id)
+                          ("visibility" . ,mastodon-toot--visibility)
+                          ("sensitive" . ,(when mastodon-toot--content-nsfw
+                                            (symbol-name t)))
+                          ("spoiler_text" . ,spoiler)))
+         (args-media
+          (when mastodon-toot--media-attachments
+              (mapcar
+               (lambda (id)
+                 (cons "media_ids[]" id))
+               mastodon-toot--media-attachment-ids)))
+         (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...")
+      (if empty-toot-p
+          (message "Empty toot. Cowardly refusing to post this.")
+        (mastodon-toot--kill)
+        (let ((response (mastodon-http--post endpoint args 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 \"\".
@@ -359,11 +396,14 @@ warning flags etc."
        (propertize "Visibility"
                    'toot-post-visibility t)
        " ⋅ "
+       (propertize "Attachment"
+                   'toot-attachment t)
+       " ⋅ "
        (propertize "CW"
                    'toot-post-cw-flag t)
-       ;; " "
-       ;; (propertize "NSFW"
-       ;;             'toot-post-nsfw-flag t)
+       " "
+       (propertize "NSFW"
+                   'toot-post-nsfw-flag t)
        "\n"
        divider
        (propertize "\n"
@@ -388,22 +428,30 @@ If REPLY-TO-ID is provided, set the MASTODON-TOOT--REPLY-TO-ID var."
                                                         (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)))
+        (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 in message"
+                               (format "%s characters"
                                        (- (point-max) (cdr header-region)))))
     (add-text-properties (car visibility-region) (cdr visibility-region)
                          (list 'display
                                (format "Visibility: %s"
                                        mastodon-toot--visibility)))
-    ;; (add-text-properties (car nsfw-region) (cdr nsfw-region)
-    ;;                      (list 'invisible (not mastodon-toot--content-nsfw)
-    ;;                            'face 'mastodon-cw-face))
+    (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))))