;;; 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))
         (when .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")
             (when-let ((image (create-image thumb-file-name)))
               (insert-image image))
             ))
         (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