From 1f2ebe94c647fef509e06e9ef6f79697ef98a356 Mon Sep 17 00:00:00 2001 From: mousebot Date: Fri, 15 Oct 2021 12:57:41 +0200 Subject: first test merge of hdurer's WIP: Posting of images --- lisp/mastodon-auth.el | 30 +++++------ lisp/mastodon-client.el | 8 +-- lisp/mastodon-http.el | 64 +++++++++++++++++++---- lisp/mastodon-media.el | 5 ++ lisp/mastodon-toot.el | 133 +++++++++++++++++++++++++++++++++++------------- 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 -- cgit v1.2.3