first test merge of hdurer's WIP: Posting of images

5 files changed, 176 insertions, 64 deletions

diff --git a/lisp/mastodon-auth.el b/lisp/mastodon-auth.el
index 0b0c703..cd74ef8 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))
 
@@ -98,15 +98,15 @@ Reads and/or stores secrets in `MASTODON-AUTH-SOURCE-FILE'."
     (prog1
         (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" . ,(plist-get credentials-plist :user))
-           ("password" . ,(let ((secret (plist-get credentials-plist :secret)))
-                            (if (functionp secret)
-                                (funcall secret)
-                              secret)))
-           ("scope" . "read write follow"))
+         `(("client_id" ,(plist-get (mastodon-client) :client_id))
+           ("client_secret" ,(plist-get (mastodon-client) :client_secret))
+           ("grant_type" "password")
+           ("username" ,(plist-get credentials-plist :user))
+           ("password" ,(let ((secret (plist-get credentials-plist :secret)))
+                          (if (functionp secret)
+                              (funcall secret)
+                            secret)))
+           ("scope" "read write follow"))
          nil
 	 :unauthenticated)
       (when (functionp (plist-get credentials-plist :save-function))
diff --git a/lisp/mastodon-client.el b/lisp/mastodon-client.el
index bdfbca9..4503d6d 100644
--- a/lisp/mastodon-client.el
+++ b/lisp/mastodon-client.el
@@ -49,10 +49,10 @@
   "POST client to Mastodon."
   (mastodon-http--post
    (mastodon-http--api "apps")
-   '(("client_name" . "mastodon.el")
-     ("redirect_uris" . "urn:ietf:wg:oauth:2.0:oob")
-     ("scopes" . "read write follow")
-     ("website" . "https://github.com/jdenen/mastodon.el"))
+   '(("client_name" "mastodon.el")
+     ("redirect_uris" "urn:ietf:wg:oauth:2.0:oob")
+     ("scopes" "read write follow")
+     ("website" "https://github.com/jdenen/mastodon.el"))
    nil
    :unauthenticated))
 
diff --git a/lisp/mastodon-http.el b/lisp/mastodon-http.el
index bc48e8d..85ee588 100644
--- a/lisp/mastodon-http.el
+++ b/lisp/mastodon-http.el
@@ -90,29 +90,75 @@ Message status and JSON error from RESPONSE if unsuccessful."
         (let ((json-response (mastodon-http--process-json)))
           (message "Error %s: %s" status (cdr (assoc 'error json-response))))))))
 
+(defun mastodon-http--encode-multipart-form-data (boundary fields)
+  "Encode FIELDS suitable to post as multipart/form-data.
+
+It uses BOUNDARY as the boundary for the values.
+FIELDS should be a list of either 2-element (name contents) lists
+or 4-element list of (name file-name content-type contents)."
+  (with-temp-buffer
+    (dolist (field fields)
+      (insert "--" boundary "\r\n")
+      (if (= (length field) 2)
+          ;; a 2-element list is a simple name=value item:
+          (insert  "Content-Disposition: form-data; name=\""
+                   (url-hexify-string (car field))
+                   "\"\r\n"
+                   "\r\n"
+                   (cadr field) "\r\n")
+        ;; a 4-element list ist a file to be attached:
+        (insert "Content-Disposition: form-data; name=\""
+                (url-hexify-string (car field))
+                "\"; filename=\""
+                (url-hexify-string (cadr field))
+                "\"\r\n"
+                "Content-type: " (caddr field) "\r\n"
+                 "\r\n"
+                 (cadddr field) "\r\n")))
+    ;; Finally add the terminating boundary and another empty line:
+    (insert "--" boundary "--\r\n"
+            "\r\n")
+    (string-to-unibyte (buffer-string))))
+
 (defun mastodon-http--post (url args headers &optional unauthenticed-p)
   "POST synchronously to URL with ARGS and HEADERS.
 
 Authorization header is included by default unless UNAUTHENTICED-P is non-nil."
-  (let ((url-request-method "POST")
-        (url-request-data
-         (when args
-           (mapconcat (lambda (arg)
-                        (concat (url-hexify-string (car arg))
-                                "="
-                                (url-hexify-string (cdr arg))))
-                      args
-                      "&")))
+  (let* ((url-request-method "POST")
+         (boundary (md5 (format "b%s-%s-%s-%s"
+                                (random 1000000000) (random 1000000000)
+                                (random 1000000000) (random 1000000000))))
+         (needs-multi-form (> (apply #'max (mapcar #'length args)) 2))
+         (url-request-data
+          (when args
+            (if needs-multi-form
+                (mastodon-http--encode-multipart-form-data boundary args)
+              (mapconcat (lambda (arg)
+                           (concat (url-hexify-string (car arg))
+                                   "="
+                                   (url-hexify-string (cadr arg))))
+                         args
+                         "&"))))
         (url-request-extra-headers
 	 (append
+          (when needs-multi-form
+            `(("Content-Type" .
+               ,(concat "multipart/form-data; boundary=\"" boundary "\""))))
 	  (unless unauthenticed-p
 	    `(("Authorization" . ,(concat "Bearer " (mastodon-auth--access-token)))))
 	  headers)))
+    (message "Posting to %s with %d bytes of request data and headers %s" url (length url-request-data) url-request-extra-headers)
     (with-temp-buffer
       (if (< (cdr (func-arity 'url-retrieve-synchronously)) 4)
           (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 8aadf0a..fd2a6b7 100644
--- a/lisp/mastodon-media.el
+++ b/lisp/mastodon-media.el
@@ -51,6 +51,11 @@
   :group 'mastodon-media
   :type 'integer)
 
+(defcustom mastodon-media--attachment-height 100
+  "Height of the attached images preview."
+  :group 'mastodon-media
+  :type 'integer)
+
 (defvar mastodon-media--generic-avatar-data
   (base64-decode-string
    "iVBORw0KGgoAAAANSUhEUgAAAGQAAABkCAIAAAD/gAIDAAAACXBIWXMAAAsTAAALEwEAmpwYAAAA
diff --git a/lisp/mastodon-toot.el b/lisp/mastodon-toot.el
index a8b121b..6c08859 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"))
@@ -103,6 +104,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 +115,10 @@ 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-a") #'mastodon-toot--attach-media)
+    (define-key map (kbd "C-c !") #'mastodon-toot--clear-all-attachments)
     map)
   "Keymap for `mastodon-toot'.")
 
@@ -147,6 +153,14 @@ Remove MARKER if REMOVE is non-nil, otherwise add it."
     (let ((response (mastodon-http--post url nil nil)))
       (mastodon-http--triage response callback))))
 
+(defun mastodon-toot--post-media (contents content-type description)
+  (let* ((url (mastodon-http--api "media"))
+         (response (mastodon-http--post
+                    url
+                    (list (list "description" description)
+                          (list "file" "file" content-type contents)))))
+    response))
+
 (defun mastodon-toot--toggle-boost ()
   "Boost/unboost toot at `point'."
   (interactive)
@@ -414,6 +428,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 +445,54 @@ eg. \"feduser@fed.social\" -> \"feduser@fed.social\"."
                "public")))
   (mastodon-toot--update-status-fields))
 
+(defun mastodon-toot--clear-all-attachments ()
+  ""
+  (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)
+  ""
+  (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)))))
+  (mastodon-toot--refresh-attachments-display))
+
+(defun mastodon-toot--refresh-attachments-display ()
+  (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 ()
+  (or (let ((counter 0)
+            (image-options (when (image-type-available-p 'imagemagick)
+                             `(:height ,mastodon-media--attachment-height))))
+        (mapcan (lambda (attachment)
+                  (let* ((data (cdr (assoc :contents attachment)))
+                         (image (apply #'create-image data
+                                       (when image-options 'imagemagick)
+                                       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 +546,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)
@@ -515,43 +582,35 @@ 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)
-                         (list 'display
-                               (format "Visibility: %s"
-                                       (if (equal
-                                            mastodon-toot--visibility
-                                            "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))))
+         (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 in message"
+                                        (- (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 '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 +620,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