aboutsummaryrefslogtreecommitdiff
path: root/emacs/.emacs.d/lisp/my/mastorg.el
diff options
context:
space:
mode:
Diffstat (limited to 'emacs/.emacs.d/lisp/my/mastorg.el')
-rw-r--r--emacs/.emacs.d/lisp/my/mastorg.el207
1 files changed, 0 insertions, 207 deletions
diff --git a/emacs/.emacs.d/lisp/my/mastorg.el b/emacs/.emacs.d/lisp/my/mastorg.el
deleted file mode 100644
index 3544b2e..0000000
--- a/emacs/.emacs.d/lisp/my/mastorg.el
+++ /dev/null
@@ -1,207 +0,0 @@
-;;; 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)
- (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
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-27 10:16:02 +0000