gnus-mast.el

(defvar vz/gnus-mast-homeserver "https://mastinsaan.in"
  "URL of the Mastodon homeserver.")

(defun vz/gnus-mast--api (api)
  "Return the full URL for API."
  (concat vz/gnus-mast-homeserver api))

(defun vz/gnus-mast--json-read-buffer ()
  "Return the JSON object in the current URL request buffer."
  (goto-char (point-min))
  (search-forward "\n\n")
  (json-parse-buffer
   :object-type 'hash-table
   :array-type 'list
   :null-object nil
   :false-object nil))

(defun vz/gnus-mast--client-id ()
  "Return the client id and secret for the homeserver."
  (if (file-readable-p (locate-user-emacs-file "gnus-mast/client-secret.eld"))
      (with-temp-buffer
        (insert-file-contents-literally
         (locate-user-emacs-file "gnus-mast/client-secret.eld"))
        (goto-char (point-min))
        (let ((ht (read (current-buffer))))
          (cons (gethash "client_id" ht)
                (gethash "client_secret" ht))))
      (let ((url-request-method "POST")
            (url-request-extra-headers
             '(("Content-Type" . "application/x-www-form-urlencoded")))
            (url-request-data
             (url-encode-url
              (concat "client_name=gnus-mastodon&"
                      "redirect_uris=urn:ietf:wg:oauth:2.0:oob&"
                      "scopes=read"))))
        (with-current-buffer
            (url-retrieve-synchronously
             (vz/gnus-mast--api "/api/v1/apps"))
          (let ((json (vz/gnus-mast--json-read-buffer)))
            (if (gethash "error" json)
                (error "Failed to fetch client key")
              (unless (file-directory-p
                       (expand-file-name "gnus-mast" user-emacs-directory))
                (make-directory (expand-file-name "gnus-mast" user-emacs-directory) t))
              (with-temp-file (locate-user-emacs-file "gnus-mast/client-secret.eld")
                (let (print-length print-level)
                  (prin1 json (current-buffer))))
              (cons (gethash "client_id" json)
                    (gethash "client_secret" json))))))))

(defun vz/gnus-mast--auth-user ()
  (if (file-readable-p (locate-user-emacs-file "gnus-mast/auth-code.eld"))
      (with-temp-buffer
        (insert-file-contents-literally (locate-user-emacs-file "gnus-mast/auth-code.eld"))
        (goto-char (point-min))
        (gethash "access_token" (read (current-buffer))))
    (let* ((client-secret (vz/gnus-mast--client-id))
           (url
            (format (vz/gnus-mast--api
                     (concat "/oauth/authorize?"
                             "client_id=%s&"
                             "scope=read&"
                             "redirect_uri=urn:ietf:wg:oauth:2.0:oob&"
                             "response_type=code"))
                    (car client-secret))))
      (gui-set-selection 'CLIPBOARD url)
      (browse-url-with-browser-kind 'external url)
      (let* ((auth-code
              (read-string "Copy the authorization code from the browser and paste here: "))
             (url-request-method "POST")
             (url-request-extra-headers
              '(("Content-Type" . "application/x-www-form-urlencoded")))
             (url-request-data
              (url-encode-url
               (concat "grant_type=authorization_code&"
                       "code=" auth-code "&"
                       "client_id=" (car client-secret) "&"
                       "client_secret=" (cdr client-secret) "&"
                       "redirect_uri=urn:ietf:wg:oauth:2.0:oob"))))
        (with-current-buffer
            (url-retrieve-synchronously
             (vz/gnus-mast--api "/oauth/token"))
          (let ((json (vz/gnus-mast--json-read-buffer)))
            (if (gethash "error" json)
                (error "Failed to obtain authorization token")
              (with-temp-file (locate-user-emacs-file "gnus-mast/auth-code.eld")
                (let (print-level print-length)
                  (prin1 json (current-buffer))))
              (gethash "access_token" json))))))))

(defun vz/gnus-mast--status-id (url)
  "Return the status ID from the mastodon url URL."
  (when (string-match
         (concat vz/gnus-mast-homeserver
                 "/[^/]+/\\([0-9]+\\)")
         url)
    (match-string 1 url)))

(defun vz/gnus-mast--ancestor (id)
  "Return the ancestor's ID and hashtable for the status ID."
  (let ((url-request-extra-headers
         `(("Authorization" . ,(concat "Bearer "
                                       (vz/gnus-mast--auth-user))))))
    (with-current-buffer
        (url-retrieve-synchronously
         (vz/gnus-mast--api (concat "/api/v1/statuses/"
                                    id
                                    "/context")))
      (let ((json (vz/gnus-mast--json-read-buffer)))
        (if (null (gethash "ancestors" json))
            (cons id json)
          (vz/gnus-mast--ancestor
           (gethash
            "id"
            (seq-find
             (lambda (ht)
               (null (gethash "in_reply_to_id" ht)))
             (gethash "ancestors" json)
             (car (gethash "ancestors" json))))))))))

(defun vz/gnus-mast--gethash (ht &rest keys)
  (declare (indent 1))
  (while keys
    (setq ht (gethash (car keys) ht)
          keys (cdr keys)))
  ht)

(defun vz/gnus-mast--ancestor-to-mbox (root descendants buffer)
  "Write mbox for the ROOT hashtable and its DESCENDANTS to BUFFER."
  (require 'message)
  (require 'mail-parse)
  (require 'qp)
  (with-current-buffer buffer
    (dolist (ht (cons root descendants))
      (insert "From mastodon@localhost Wed Aug 12 21:34:56 2020\n")
      (insert "From: "
              (let ((string
                     (decode-coding-string
                      (vz/gnus-mast--gethash ht
                        "account" "display_name")
                      'utf-8)))
                (mail-encode-encoded-word-string string))
              " <"
              (let ((acct (vz/gnus-mast--gethash ht
                            "account" "acct")))
                (if (string-search "@" acct)
                    acct
                  (concat acct "@mastodon")))
              ">\n")
      (insert "Subject: "
              (if (eq ht root)
                  "Mastodon thread"
                "Re: Mastodon thread")
              "\n")
      (insert "Message-ID: <"
              (gethash "id" ht)
              "@localhost>\n")
      (when (gethash "in_reply_to_id" ht)
        (insert "References: <"
                (gethash "in_reply_to_id" ht)
                "@localhost>\n"))
      (insert "Date: "
              (message-make-date
               (encode-time
                (parse-time-string
                 (gethash "created_at" ht))))
              "\n")
      (insert "Content-Transfer-Encoding: quoted-printable\n")
      (insert "Content-Type: text/html; charset=utf-8\n\n")
      (let ((point (point)))
        (insert (gethash "content" ht))
        (insert "\n\n")
        (insert "<p>URL: <a href=\""
                (gethash "url" ht)
                "\">"
                (gethash "url" ht)
                "</a>")
        (insert "\n\n\n")
        (encode-coding-region point (point) 'utf-8)
        (quoted-printable-encode-region point (point))))))

(defun vz/gnus-mast--status (id)
  "Return the status hashtable for status ID."
  (let ((url-request-extra-headers
         `(("Authorization" . ,(concat "Bearer "
                                       (vz/gnus-mast--auth-user))))))
    (with-current-buffer
        (url-retrieve-synchronously
         (vz/gnus-mast--api
          (concat "/api/v1/statuses/" id)))
      (vz/gnus-mast--json-read-buffer))))

(defun vz/gnus-mast-read-mastodon-thread (url)
  "Read mastodon thread URL in Gnus."
  (interactive "sMastodon thread URL: ")
  (require 'gnus-group)
  (let* ((id (vz/gnus-mast--status-id url))
         (tmp-file (make-temp-file (concat "gnus-mast-" id))))
    (unwind-protect
        (let* ((root-desc (vz/gnus-mast--ancestor id))
               (root (vz/gnus-mast--status (car root-desc))))
          (with-temp-buffer
            (vz/gnus-mast--ancestor-to-mbox
             root (gethash "descendants" (cdr root-desc))
             (current-buffer))
            (write-region (point-min) (point-max) tmp-file))
          (gnus-group-read-ephemeral-group
           (concat "nndoc+emphemeral:mast#" id)
           `(nndoc ,tmp-file
                   (nndoc-article-type mbox))))
      (delete-file tmp-file))))