path: root/emacs/.emacs.d/lisp/my/mastorg.el

;;; 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-make-org-link (link desc)
  (format "[[%s][%s]]" link desc))

(defun mastorg-format-attached (attachments host)
  (mapconcat
   (lambda (attachment)
     (let-alist attachment
       (with-temp-buffer
         (insert
          (mastorg-make-org-link .url .type))
         (if .description
             (insert ": " .description))
         (when .preview_url
           (let ((thumb-file-name
                  (file-name-concat
                   mastorg-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 mastorg-format-toot (toot level)
  "Format a TOOT with indent LEVEL."
  (let-alist toot
    (let ((host (car (mastorg-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
              (mastorg-make-org-link
               .url
               (mastorg--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)))
              (mastorg-format-attached .media_attachments host)
              .replies_count
              .reblogs_count
              .favourites_count))))

(defun mastorg-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 mastorg-dir (locate-user-emacs-file "mastorg")
  "Path to local directory of saved threads.")

(defun mastorg-make-filename (url)
  (pcase-let ((`(,host . ,post-id) (mastorg-parse-url url)))
    (format "%s.%s.org" host post-id)))

;;;###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: ")
  (mastorg-save-text-and-switch-to-buffer
   (mastorg-format-toot-tree url)
   (file-name-concat mastorg-dir (mastorg-make-filename url))))

;;; code adapted from mastodon.el
(defun mastorg--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 mastorg--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 mastorg--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 mastorg--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 (mastorg--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 mastorg--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 (mastorg--relative-time-details
        (encode-time (parse-time-string time-string)) current-time)))

(provide 'mastorg)
;;; mastorg.el ends here