[emacs] Rename mastorg to fediorg

Now that the package handles fedi posts in general, it no longer makes
sense to use mastodon-specific naming.

Also updated ytdl infobox formatting chapters and removal of extra
queries in urls

1 files changed, 367 insertions, 0 deletions

diff --git a/emacs/.emacs.d/lisp/my/fediorg.el b/emacs/.emacs.d/lisp/my/fediorg.el
new file mode 100644
index 0000000..123545b
--- /dev/null
+++ b/emacs/.emacs.d/lisp/my/fediorg.el
@@ -0,0 +1,367 @@
+;;; fediorg.el -- Read and archive fedi post 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 a fedi thread context in org mode. This is a
+;; standalone library, and can be used without any other files in this
+;; project.
+
+;; Usage:
+;; M-x fediorg-open <RET> https://pleroma.instance/notice/... <RET>
+;; M-x fediorg-open <RET> https://mastodon.instance/@user/... <RET>
+;;
+;; The post, together with its ancestors and descendants, subject to
+;; the 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 post and upsert them in
+;; the buffer.
+;;; Code:
+
+
+(require 'hierarchy)
+(require 'json)
+(require 'url-parse)
+
+(defvar fediorg-buffer "*fediorg*" "Buffer name for fediorg buffers.")
+
+;;; Fetching utilities
+(defvar fediorg-client-buffer-name "*fediorg-api*"
+  "Buffer name for logging API requests.")
+
+(defun fediorg-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."
+  (fediorg-url-fetch-internal
+   url
+   (lambda ()
+     (json-read-from-string (decode-coding-string (buffer-string) 'utf-8)))
+   decompression
+   with-header))
+
+(defun fediorg-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 fediorg-client-buffer-name)
+    (goto-char (point-max))
+    (insert "[" (current-time-string) "] Request: " url "\n"))
+  (with-current-buffer (url-retrieve-synchronously url t)
+    (let ((header (fediorg-kill-http-header)) (status) (fields))
+      (goto-char (point-min))
+      (setq header (fediorg-parse-http-header header)
+            status (alist-get 'status header)
+            fields (alist-get 'fields header))
+      (with-current-buffer fediorg-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 fediorg-kill-http-header ()
+  "Kill http headers in the current buffer."
+  (fediorg-skip-http-header)
+  (let ((killed (buffer-substring-no-properties (point-min) (point))))
+    (delete-region (point-min) (point))
+    killed))
+
+(defun fediorg-skip-http-header ()
+  "Skip http headers in the current buffer."
+  (goto-char (point-min))
+  (re-search-forward "\r?\n\r?\n"))
+
+(defun fediorg-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))))
+
+;;; utilities
+(defun fediorg-api-search (host url)
+  (fediorg-url-fetch-json
+   (format "https://%s/api/v2/search/?q=%s&resolve=true" host url)))
+
+(defun fediorg-canonical-post-url-by-search (host url)
+  (let-alist (fediorg-api-search host url)
+    (if (seq-empty-p .statuses)
+        (error "No statuses associated with URL %s" url)
+      (fediorg-canonical-post-url (alist-get 'url (elt .statuses 0)) t))))
+
+(defun fediorg-post-url-p (url &optional no-fetch)
+  (pcase-let* ((urlobj (url-generic-parse-url url))
+               (`(,path . _) (url-path-and-query urlobj))
+               (host (url-host urlobj)))
+    (or (string-match-p "^/objects/[-a-f0-9]+$" path)
+        (string-match-p
+         "^/user[s]?/[[:alnum:]_]+/statuses/[[:digit:]]+$" path)
+        (string-match-p "^/@[^/]+/\\([0-9]+\\)$" path)
+        (string-match-p "^/notice/\\([[:alnum:]]+\\)$" path))))
+
+(defun fediorg-canonical-post-url (url &optional no-fetch)
+  (pcase-let* ((urlobj (url-generic-parse-url url))
+               (`(,path . _) (url-path-and-query urlobj))
+               (host (url-host urlobj)))
+    (cond ((or (string-match-p "^/objects/[-a-f0-9]+$" path)
+               (string-match-p
+                "^/user[s]?/[[:alnum:]_]+/statuses/[[:digit:]]+$" path))
+           (unless no-fetch (fediorg-canonical-post-url-by-search host url)))
+          ((or (string-match-p "^/@[^/]+/\\([0-9]+\\)$" path)
+               (string-match-p "^/notice/\\([[:alnum:]]+\\)$" path))
+           url)
+          (t (error "Unrecognisable URL: %s" url)))))
+
+(defun fediorg-parse-url (url)
+  "Parse fedi 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 fediorg-api-status (url)
+  "Get the status given URL."
+  (pcase-let ((`(,host . ,post-id) (fediorg-parse-url url)))
+    (fediorg-url-fetch-json
+     (format "https://%s/api/v1/statuses/%s" host post-id))))
+
+(defun fediorg-api-status-context (url)
+  "Get the status context given URL."
+  (pcase-let ((`(,host . ,post-id) (fediorg-parse-url url)))
+    (fediorg-url-fetch-json
+     (format "https://%s/api/v1/statuses/%s/context" host post-id))))
+
+(defun fediorg-get-first-ancestor (url)
+  "Given a fedi post URL, return the url of its first ancestor."
+  (let ((ancestors
+         (alist-get 'ancestors (fediorg-api-status-context url))))
+    (if (length> ancestors 0)
+        (alist-get 'url (elt ancestors 0))
+      url)))
+
+(defun fediorg-post-make-parent-fn (posts)
+  "Given a collection of POSTS, return a function that find the parent post."
+  (lambda (post)
+    (let ((id (alist-get 'in_reply_to_id post)))
+      (seq-find
+       (lambda (candidate)
+         (equal (alist-get 'id candidate) id))
+       posts))))
+
+;;; Formatting functions
+(defun fediorg-format-post-tree (url)
+  "Format a post tree of post located at URL.
+
+Including ancestors and descendants, if any."
+  (let* ((posts-hier (hierarchy-new))
+         (context-posts (fediorg-api-status-context url))
+         (posts (vconcat
+                 (alist-get 'ancestors context-posts)
+                 (vector (fediorg-api-status url))
+                 (alist-get 'descendants context-posts))))
+    (hierarchy-add-trees
+     posts-hier
+     posts
+     (fediorg-post-make-parent-fn posts))
+    (string-join
+     (hierarchy-map 'fediorg-format-post posts-hier 1)
+     "\n")))
+
+(defun fediorg-make-org-link (link desc)
+  (format "[[%s][%s]]" link desc))
+
+(defun fediorg-format-attached (attachments host)
+  (mapconcat
+   (lambda (attachment)
+     (let-alist attachment
+       (with-temp-buffer
+         (insert
+          (fediorg-make-org-link .url .type))
+         (if .description
+             (insert ": " .description))
+         (when .preview_url
+           (let ((thumb-file-name
+                  (file-name-concat
+                   fediorg-dir
+                   (format "%s.%s.%s" host .id
+                           (file-name-extension .preview_url)))))
+             (ignore-error 'file-already-exists
+               (url-copy-file .preview_url thumb-file-name))
+             (insert "\n")
+             (insert-image (create-image thumb-file-name))
+             ))
+         (buffer-string))))
+   attachments
+   "\n"))
+
+(defun fediorg-format-post (post level)
+  "Format a POST with indent LEVEL."
+  (let-alist post
+    (let ((host (car (fediorg-parse-url .url))))
+      (format "%s %s (@%s@%s) %s\n\n%s%s\n\n⤷%d ⇆%d ★%d\n"
+              (make-string level ?*)
+              (if (string-empty-p .account.display_name)
+                  .account.username .account.display_name)
+              .account.username
+              host
+              (fediorg-make-org-link
+               .url
+               (fediorg--relative-time-description .created_at))
+              (with-temp-buffer
+                (insert .content)
+                (shr-render-region (point-min) (point-max))
+                (buffer-substring-no-properties (point-min) (point-max)))
+              (fediorg-format-attached .media_attachments host)
+              .replies_count
+              .reblogs_count
+              .favourites_count))))
+
+(defun fediorg-save-text-and-switch-to-buffer (text file-name)
+  "Save TEXT to FILE-NAME and switch to buffer."
+  (let ((buffer (find-file-noselect file-name))
+        (coding-system-for-write 'utf-8))
+    (with-current-buffer buffer
+      (let ((inhibit-read-only t))
+        (erase-buffer)
+        (insert text))
+      (goto-char (point-min))
+      (save-buffer)
+      (revert-buffer t t))
+    (switch-to-buffer buffer)))
+
+(defvar fediorg-dir (locate-user-emacs-file "fediorg")
+  "Path to local directory of saved threads.")
+
+(defun fediorg-make-post-file-name (url)
+  (pcase-let ((`(,host . ,post-id) (fediorg-parse-url url)))
+    (format "%s.%s.org" host post-id)))
+
+;;;###autoload
+(defun fediorg-open (url)
+  "Given a fedi post URL, open an org buffer rendering the post.
+
+Including the context, i.e. ancestors and descendant posts."
+  (interactive "sPost URL: ")
+  (setq url (fediorg-canonical-post-url url))
+  (fediorg-save-text-and-switch-to-buffer
+   (fediorg-format-post-tree url)
+   (file-name-concat fediorg-dir (fediorg-make-post-file-name url))))
+
+;;; code adapted from mastodon.el
+(defun fediorg--human-duration (seconds &optional resolution)
+  "Return a string describing SECONDS in a more human-friendly way.
+The return format is (STRING . RES) where RES is the resolution of
+this string, in seconds.
+RESOLUTION is the finest resolution, in seconds, to use for the
+second part of the output (defaults to 60, so that seconds are only
+displayed when the duration is smaller than a minute)."
+  (cl-assert (>= seconds 0))
+  (unless resolution (setq resolution 60))
+  (let* ((units fediorg--time-units)
+         (n1 seconds) (unit1 (pop units)) (res1 1)
+         n2 unit2 res2
+         next)
+    (while (and units (> (truncate (setq next (/ n1 (car units)))) 0))
+      (setq unit2 unit1)
+      (setq res2 res1)
+      (setq n2 (- n1 (* (car units) (truncate n1 (car units)))))
+      (setq n1 next)
+      (setq res1 (truncate (* res1 (car units))))
+      (pop units)
+      (setq unit1 (pop units)))
+    (setq n1 (truncate n1))
+    (if n2 (setq n2 (truncate n2)))
+    (cond
+     ((null n2)
+      ;; revert to old just now style for < 1 min:
+      (cons "just now" 60))
+     ;; (cons (format "%d %s%s" n1 unit1 (if (> n1 1) "s" ""))
+     ;;       (max resolution res1)))
+     ((< (* res2 n2) resolution)
+      (cons (format "%d %s%s" n1 unit1 (if (> n1 1) "s" ""))
+            (max resolution res2)))
+     ((< res2 resolution)
+      (let ((n2 (/ (* resolution (/ (* n2 res2) resolution)) res2)))
+        (cons (format "%d %s%s, %d %s%s"
+                      n1 unit1 (if (> n1 1) "s" "")
+                      n2 unit2 (if (> n2 1) "s" ""))
+              resolution)))
+     (t
+      (cons (format "%d %s%s, %d %s%s"
+                    n1 unit1 (if (> n1 1) "s" "")
+                    n2 unit2 (if (> n2 1) "s" ""))
+            (max res2 resolution))))))
+
+(defconst fediorg--time-units
+  '("sec"   60.0 ;; Use a float to convert `n' to float.
+    "min"   60
+    "hour"  24
+    "day"   7
+    "week"  4.345
+    "month" 12
+    "year"))
+
+(defun fediorg--relative-time-details (timestamp &optional current-time)
+  "Return cons of (DESCRIPTIVE STRING . NEXT-CHANGE) for the TIMESTAMP.
+Use the optional CURRENT-TIME as the current time (only used for
+reliable testing).
+The descriptive string is a human readable version relative to
+the current time while the next change timestamp give the first
+time that this description will change in the future.
+TIMESTAMP is assumed to be in the past."
+  (let* ((time-difference (time-subtract current-time timestamp))
+         (seconds-difference (float-time time-difference))
+         (tmp (fediorg--human-duration (max 0 seconds-difference))))
+    ;; revert to old just now style for < 1 min
+    (cons (concat (car tmp) (if (string= "just now" (car tmp)) "" " ago"))
+          (time-add current-time (cdr tmp)))))
+
+(defun fediorg--relative-time-description (time-string &optional current-time)
+  "Return a string with a human readable TIME-STRING relative to the current time.
+Use the optional CURRENT-TIME as the current time (only used for
+reliable testing).
+E.g. this could return something like \"1 min ago\", \"yesterday\", etc.
+TIME-STAMP is assumed to be in the past."
+  (car (fediorg--relative-time-details
+        (encode-time (parse-time-string time-string)) current-time)))
+
+(provide 'fediorg)
+;;; fediorg.el ends here