[emacs] Add mastorg.el, which renders a mastodon toot in org mode

From Commentary:

;; Read or archive mastodon toot context in org mode. This is a
;; standalone library, and can be used without any other files in this
;; project.

;; Usage:
;; M-x mastorg-open <RET> https://mastodon.instance/@user/12345678901234 <RET>
;;
;; The toot, together with its ancestors and descendants, subject to
;; mastodon API depth limit, are displayed in an org buffer.

;; TODO:
;;
;; To be able to refresh the org buffer at an org entry, which would
;; re-fetch the context of the corresponding toot and upsert them in
;; the buffer.

1 files changed, 205 insertions, 0 deletions

diff --git a/emacs/.emacs.d/lisp/my/mastorg.el b/emacs/.emacs.d/lisp/my/mastorg.el
new file mode 100644
index 0000000..61bc027
--- /dev/null
+++ b/emacs/.emacs.d/lisp/my/mastorg.el
@@ -0,0 +1,205 @@
+;;; mastorg.el -- Read or archive mastodon toot context in org mode -*- lexical-binding: t -*-
+
+;; Copyright (C) 2023  Free Software Foundation, Inc.
+
+;; Author: Yuchen Pei <id@ypei.org>
+;; Package-Requires: ((emacs "28.2"))
+
+;; This file is part of dotted.
+
+;; dotted is free software: you can redistribute it and/or modify it under
+;; the terms of the GNU Affero General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; dotted is distributed in the hope that it will be useful, but WITHOUT
+;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Affero General
+;; Public License for more details.
+
+;; You should have received a copy of the GNU Affero General Public
+;; License along with dotted.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Read or archive mastodon toot context in org mode. This is a
+;; standalone library, and can be used without any other files in this
+;; project.
+
+;; Usage:
+;; M-x mastorg-open <RET> https://mastodon.instance/@user/12345678901234 <RET>
+;;
+;; The toot, together with its ancestors and descendants, subject to
+;; mastodon API depth limit, are displayed in an org buffer.
+
+;; TODO:
+;;
+;; To be able to refresh the org buffer at an org entry, which would
+;; re-fetch the context of the corresponding toot and upsert them in
+;; the buffer.
+;;; Code:
+
+
+(require 'hierarchy)
+(require 'json)
+(require 'url-parse)
+
+(defvar mastorg-buffer "*mastorg*" "Buffer name for mastorg buffers.")
+
+;;; Fetching utilities
+(defvar mastorg-client-buffer-name "*mastorg-api*"
+  "Buffer name for logging API requests.")
+
+(defun mastorg-url-fetch-json (url &optional decompression with-header)
+  "Fetch and parse json from URL.
+
+With nonnil DECOMPRESSION, gunzip the response first.
+With nonnil WITH-HEADER, include the response headers in the return value."
+  (mastorg-url-fetch-internal
+   url
+   (lambda ()
+     (json-read-from-string (decode-coding-string (buffer-string) 'utf-8)))
+   decompression
+   with-header))
+
+(defun mastorg-url-fetch-internal (url buffer-processor decompression with-header)
+  "Fetch from URL and process the response with BUFFER-PROCESSOR.
+
+With nonnil DECOMPRESSION, gunzip the response first.
+With nonnil WITH-HEADER, include the response headers in the return value."
+  (with-current-buffer (get-buffer-create mastorg-client-buffer-name)
+    (goto-char (point-max))
+    (insert "[" (current-time-string) "] Request: " url "\n"))
+  (with-current-buffer (url-retrieve-synchronously url t)
+    (let ((header (mastorg-kill-http-header)) (status) (fields))
+      (goto-char (point-min))
+      (setq header (mastorg-parse-http-header header)
+            status (alist-get 'status header)
+            fields (alist-get 'fields header))
+      (with-current-buffer mastorg-client-buffer-name
+        (insert "[" (current-time-string) "] Response: " status "\n"))
+      (when decompression
+        (call-process-region (point) (point-max) "gunzip" t t t)
+        (goto-char (point-min)))
+      (call-interactively 'delete-trailing-whitespace)
+      (if (string= status "200")
+          (unless (= (point) (point-max))
+            (if with-header
+                (list
+                 (cons 'header fields)
+                 (cons 'json (funcall buffer-processor)))
+              (funcall buffer-processor)))
+        (error "HTTP error: %s" (buffer-substring (point) (point-max)))))))
+
+(defun mastorg-kill-http-header ()
+  "Kill http headers in the current buffer."
+  (mastorg-skip-http-header)
+  (let ((killed (buffer-substring-no-properties (point-min) (point))))
+    (delete-region (point-min) (point))
+    killed))
+
+(defun mastorg-skip-http-header ()
+  "Skip http headers in the current buffer."
+  (goto-char (point-min))
+  (re-search-forward "\r?\n\r?\n"))
+
+(defun mastorg-parse-http-header (text)
+  "Parse http headers from TEXT in the current buffer."
+  (let ((status) (fields))
+    (with-temp-buffer
+      (insert text)
+      (goto-char (point-min))
+      (re-search-forward "^HTTP.*\\([0-9]\\{3\\}\\).*$")
+      (setq status (match-string 1))
+      (while (re-search-forward "^\\(.*?\\): \\(.*\\)$" nil t)
+        (push (cons (intern (match-string 1)) (match-string 2)) fields)))
+    (list (cons 'status status) (cons 'fields fields))))
+
+;;; mastodon utilities
+(defun mastorg-parse-url (url)
+  "Parse mastodon post URL."
+  (pcase-let* ((urlobj (url-generic-parse-url url))
+               (`(,path . _) (url-path-and-query urlobj))
+               (host (url-host urlobj)))
+    (cons host (caddr (split-string path "/")))))
+
+(defun mastorg-api-status (url)
+  "Get the status given URL."
+  (pcase-let ((`(,host . ,post-id) (mastorg-parse-url url)))
+    (mastorg-url-fetch-json
+     (format "https://%s/api/v1/statuses/%s" host post-id))))
+
+(defun mastorg-api-status-context (url)
+  "Get the status context given URL."
+  (pcase-let ((`(,host . ,post-id) (mastorg-parse-url url)))
+    (mastorg-url-fetch-json
+     (format "https://%s/api/v1/statuses/%s/context" host post-id))))
+
+(defun mastorg-get-first-ancestor (url)
+  "Given a mastodon URL, return the url of its first ancestor."
+  (let ((ancestors
+         (alist-get 'ancestors (mastorg-api-status-context url))))
+    (if (length> ancestors 0)
+        (alist-get 'url (elt ancestors 0))
+      url)))
+
+(defun mastorg-toot-make-parent-fn (toots)
+  "Given a collection of TOOTS, return a function that find the parent toot."
+  (lambda (toot)
+    (let ((id (alist-get 'in_reply_to_id toot)))
+      (seq-find
+       (lambda (candidate)
+         (equal (alist-get 'id candidate) id))
+       toots))))
+
+;;; Formatting functions
+(defun mastorg-format-toot-tree (url)
+  "Format a toot tree of toot located at URL.
+
+Including ancestors and descendants, if any."
+  (let* ((toots-hier (hierarchy-new))
+         (context-toots (mastorg-api-status-context url))
+         (toots (vconcat
+                 (alist-get 'ancestors context-toots)
+                 (vector (mastorg-api-status url))
+                 (alist-get 'descendants context-toots))))
+    (hierarchy-add-trees
+     toots-hier
+     toots
+     (mastorg-toot-make-parent-fn toots))
+    (string-join
+     (hierarchy-map 'mastorg-format-toot toots-hier 1)
+     "\n")))
+
+(defun mastorg-format-toot (toot level)
+  "Format a TOOT with indent LEVEL."
+  (pcase-let* ((url (alist-get 'url toot))
+               (account (alist-get 'account toot))
+               (display-name (alist-get 'display_name account))
+               (username (alist-get 'username account))
+               (`(,host . _) (mastorg-parse-url url)))
+    (format "%s %s @%s@%s %s\n%s"
+            (make-string level ?*)
+            (if (string-empty-p display-name) username display-name)
+            username
+            host
+            (alist-get 'created_at toot)
+            (with-temp-buffer
+              (insert (alist-get 'content toot))
+              (shr-render-region (point-min) (point-max))
+              (buffer-substring-no-properties (point-min) (point-max))))))
+
+;;;###autoload
+(defun mastorg-open (url)
+  "Given a mastodon toot URL, open an org buffer rendering the toot.
+
+Including the context, i.e. ancestors and descendant toots."
+  (interactive "sToot URL: ")
+  (with-current-buffer (get-buffer-create mastorg-buffer)
+    (insert (mastorg-format-toot-tree url))
+    (org-mode)
+    (goto-char (point-min)))
+  (switch-to-buffer mastorg-buffer))
+
+(provide 'mastorg)
+;;; mastorg.el ends here