;;; mastorg.el -- Read or archive mastodon toot context in org mode -*- lexical-binding: t -*- ;; Copyright (C) 2023 Free Software Foundation, Inc. ;; Author: Yuchen Pei ;; 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 . ;;; 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 https://mastodon.instance/@user/12345678901234 ;; ;; 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) (let ((inhibit-read-only t)) (erase-buffer) (insert (mastorg-format-toot-tree url)) (org-mode) (goto-char (point-min)))) (switch-to-buffer mastorg-buffer)) (provide 'mastorg) ;;; mastorg.el ends here