diff options
| -rw-r--r-- | emacs/.emacs.d/lisp/my/mastorg.el | 205 |
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 |